From 011b510f35a170f1a19f1e5c7f5bb2550e4da146 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 16 Jun 2023 15:56:01 -0400 Subject: [PATCH 001/394] feat: merge 2023.01.01 changes into main (#1259) * fix: fms2 io performance update for domain_reads (#1226) * fix: fms2 io performance update for compressed writes (#1227) * chore: build/log updates for patch (#1247) Co-authored-by: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Co-authored-by: rem1776 --- CHANGELOG.md | 15 + fms2_io/include/compressed_write.inc | 479 +++++++------- fms2_io/include/domain_read.inc | 663 +++++++++----------- fms2_io/netcdf_io.F90 | 1 + mpp/include/mpp_comm.inc | 22 + mpp/include/mpp_domains_util.inc | 8 + mpp/mpp.F90 | 6 + test_fms/fms2_io/Makefile.am | 4 +- test_fms/fms2_io/test_compressed_writes.F90 | 290 +++++++++ test_fms/fms2_io/test_domain_io.F90 | 312 +++++++++ test_fms/fms2_io/test_fms2_io.sh | 69 ++ 11 files changed, 1267 insertions(+), 602 deletions(-) create mode 100644 test_fms/fms2_io/test_compressed_writes.F90 create mode 100644 test_fms/fms2_io/test_domain_io.F90 diff --git a/CHANGELOG.md b/CHANGELOG.md index 55522567bb..0cc9802f8f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,21 @@ and this project uses `yyyy.rr[.pp]`, where `yyyy` is the year a patch is releas `rr` is a sequential release number (starting from `01`), and an optional two-digit sequential patch number (starting from `01`). +## [2023.01.01] - 2023-06-06 +### Changed +- FMS2_IO: Performance changes for domain_reads_2d and domain_reads_3d: + - Root pe reads the data + - Uses mpp_scatter to send the data to the other pes + - Added unit tests to test all of the domain_read/domain_write interfaces + +- FMS2_IO: Performance changes for compressed_writes_1d/2d/3d + - Uses mpp_gather to get data for write + - Added unit tests to test all of the compressed writes interfaces + - Compressed_writes_4d/5d were unchanged + +- FMS2_IO: Extended mpp_scatter and mpp_gather to work for int8; added a kludge for scatter since the data is assumed to be (x,y,z) + + ## [2023.01] - 2023-04-03 ### Known Issues - If using GCC 10 or higher as well as MPICH, compilation errors will occur unless `-fallow-argument-mismatch` is included in the Fortran compiler flags(the flag will now be added automatically if building with autotools or CMake). diff --git a/fms2_io/include/compressed_write.inc b/fms2_io/include/compressed_write.inc index dffff9ea94..cd2919c162 100644 --- a/fms2_io/include/compressed_write.inc +++ b/fms2_io/include/compressed_write.inc @@ -81,31 +81,32 @@ end subroutine compressed_write_0d_wrap subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, & corner, edge_lengths) - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:), intent(in) :: cdata !< Compressed data that - !! will be gathered and - !! written to the - !! netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(1), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(1), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. - - integer, dimension(2) :: compressed_dim_index - integer, dimension(1) :: c - integer, dimension(1) :: e - integer :: i - integer(kind=i4_kind), dimension(:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:), allocatable :: buf_r8_kind + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), dimension(:), intent(in) :: cdata !< Compressed data that + !! will be gathered and + !! written to the + !! netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(1), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be written to. + integer, dimension(1), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be written + !! in each dimension. + + integer, dimension(2) :: compressed_dim_index !< index of the compressed dimension + !! compressed_dim_index(1) relative to cdata + !! compressed_dim_index(2) relative to the fileobj + integer, dimension(1) :: e !< "edges" number of points to read + + integer(kind=i4_kind), dimension(:), allocatable :: buf_i4_kind !< Global buffer of data + integer(kind=i8_kind), dimension(:), allocatable :: buf_i8_kind !< Global buffer of data + real (kind=r4_kind), dimension(:), allocatable :: buf_r4_kind !< Global buffer of data + real (kind=r8_kind), dimension(:), allocatable :: buf_r8_kind !< Global buffer of data character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message @@ -120,66 +121,54 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, & return endif - !Gather the data onto the I/O root and write it out. + e(:) = shape(cdata) + !The root pe creates a buffer big enough to store the data: if (fileobj%is_root) then - c(:) = 1 - e(:) = shape(cdata) - do i = 1, size(fileobj%pelist) - c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(i) - e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(i) - if (i .eq. 1) then - call netcdf_write_data(fileobj, variable_name, cdata, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - else - select type(cdata) - type is (integer(kind=i4_kind)) - call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: "//trim(append_error_msg)) - end select - endif - enddo - else + e(compressed_dim_index(1)) = sum(fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems) select type(cdata) type is (integer(kind=i4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i4_kind, e) type is (integer(kind=i8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i8_kind, e) type is (real(kind=r4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r4_kind, e) type is (real(kind=r8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r8_kind, e) class default call error("unsupported variable type: "//trim(append_error_msg)) - end select - call mpp_sync_self(check=EVENT_SEND) + end select + endif + + !Gather the data onto the I/O root and write it out. + select type(cdata) + type is (integer(kind=i4_kind)) + call mpp_gather(cdata, size(cdata), buf_i4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level) + type is (integer(kind=i8_kind)) + call mpp_gather(cdata, size(cdata), buf_i8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r4_kind)) + call mpp_gather(cdata, size(cdata), buf_r4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r8_kind)) + call mpp_gather(cdata, size(cdata), buf_r8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level) + class default + call error("unsupported variable type: "//trim(append_error_msg)) + end select + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine compressed_write_1d @@ -191,33 +180,43 @@ end subroutine compressed_write_1d subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, & corner, edge_lengths) - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:), intent(in) :: cdata !< Compressed data that - !! will be gathered and - !! written to the - !! netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(2), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(2), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), dimension(:,:), intent(in) :: cdata !< Compressed data that + !! will be gathered and + !! written to the + !! netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(2), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be written to. + integer, dimension(2), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be written + !! in each dimension. + + integer, dimension(2) :: compressed_dim_index !< index of the compressed dimension + !! compressed_dim_index(1) relative to cdata + !! compressed_dim_index(2) relative to the fileobj + integer, dimension(2) :: c !! corners of the data to read + integer, dimension(2) :: e !< "edges" number of points to read + + integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind !< Global buffer of data + integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind !< Global buffer of data + real (kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind !< Global buffer of data + real (kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind !< Global buffer of data - integer, dimension(2) :: compressed_dim_index - integer, dimension(2) :: c - integer, dimension(2) :: e - integer :: i - integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message + integer :: index(1) !< index of the PE in the pelist + + integer :: is !< Starting index of the first dimension + integer :: ie !< Ending index of the first dimension + integer :: js !< Starting index of the second dimension + integer :: je !< Ending index of the second dimension + append_error_msg = "compressed_write_2d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name) compressed_dim_index = get_variable_compressed_dimension_index(fileobj, variable_name) @@ -228,66 +227,68 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, & return endif - !Gather the data onto the I/O root and write it out. + e(:) = shape(cdata) + !The root pe creates a buffer big enough to store the data: if (fileobj%is_root) then - c(:) = 1 - e(:) = shape(cdata) - do i = 1, size(fileobj%pelist) - c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(i) - e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(i) - if (i .eq. 1) then - call netcdf_write_data(fileobj, variable_name, cdata, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - else - select type(cdata) - type is (integer(kind=i4_kind)) - call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: "//trim(append_error_msg)) - end select - endif - enddo - else + e(compressed_dim_index(1)) = sum(fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems) select type(cdata) type is (integer(kind=i4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i4_kind, e) type is (integer(kind=i8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i8_kind, e) type is (real(kind=r4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r4_kind, e) type is (real(kind=r8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r8_kind, e) class default call error("unsupported variable type: "//trim(append_error_msg)) - end select - call mpp_sync_self(check=EVENT_SEND) + end select + endif + + c(:) = 1 + index = FINDLOC(fileobj%pelist, mpp_pe()) + + c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(index(1)) + e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(index(1)) + + if (compressed_dim_index(1) .eq. 1) then + is = c(compressed_dim_index(1)) + ie = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + js = 1 + je = size(cdata,2) + else + js = c(compressed_dim_index(1)) + je = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + is = 1 + ie = size(cdata,2) + endif + + select type(cdata) + type is (integer(kind=i4_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level) + type is (integer(kind=i8_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r4_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r8_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level) + class default + call error("unsupported variable type: "//trim(append_error_msg)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine compressed_write_2d @@ -299,32 +300,43 @@ end subroutine compressed_write_2d subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, & corner, edge_lengths) - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:,:), intent(in) :: cdata !< Compressed data that - !! will be gathered and - !! written to the - !! netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(3), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(3), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), contiguous, intent(in), target :: cdata(:,:,:) !< Compressed data that + !! will be gathered and + !! written to the + !! netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(3), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be written to. + integer, dimension(3), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be written + !! in each dimension. + + integer, dimension(2) :: compressed_dim_index !< index of the compressed dimension + !! compressed_dim_index(1) relative to cdata + !! compressed_dim_index(2) relative to the fileobj + integer, dimension(3) :: c !! corners of the data to read + integer, dimension(3) :: e !< "edges" number of points to read + + integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind !< Global buffer of data + integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind !< Global buffer of data + real (kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind !< Global buffer of data + real (kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind !< Global buffer of data - integer, dimension(2) :: compressed_dim_index - integer, dimension(3) :: c - integer, dimension(3) :: e - integer :: i - integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message + class(*), pointer :: cdata_dummy(:,:,:,:) + + integer :: index(1) !< index of the PE in the pelist + + integer :: is !< Starting index of the first dimension + integer :: ie !< Ending index of the first dimension + integer :: js !< Starting index of the second dimension + integer :: je !< Ending index of the second dimension append_error_msg = "compressed_write_3d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name) @@ -334,68 +346,77 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, & unlim_dim_level=unlim_dim_level, corner=corner, & edge_lengths=edge_lengths) return + else if (compressed_dim_index(1) .eq. 3) then + cdata_dummy(1:size(cdata,1), 1:size(cdata,2), 1:size(cdata,3), 1:1) => cdata(:,:,:) + call compressed_write_4d(fileobj, variable_name, cdata_dummy, unlim_dim_level) endif - !Gather the data onto the I/O root and write it out. + e(:) = shape(cdata) + !The root pe creates a buffer big enough to store the data: if (fileobj%is_root) then - c(:) = 1 - e(:) = shape(cdata) - do i = 1, size(fileobj%pelist) - c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(i) - e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(i) - if (i .eq. 1) then - call netcdf_write_data(fileobj, variable_name, cdata, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - else - select type(cdata) - type is (integer(kind=i4_kind)) - call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: "//trim(append_error_msg)) - end select - endif - enddo - else + e(compressed_dim_index(1)) = sum(fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems) select type(cdata) type is (integer(kind=i4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i4_kind, e) type is (integer(kind=i8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i8_kind, e) type is (real(kind=r4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r4_kind, e) type is (real(kind=r8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r8_kind, e) class default call error("unsupported variable type: "//trim(append_error_msg)) - end select - call mpp_sync_self(check=EVENT_SEND) + end select + endif + + c(:) = 1 + index = FINDLOC(fileobj%pelist, mpp_pe()) + + c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(index(1)) + e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(index(1)) + + if (compressed_dim_index(1) .eq. 1) then + is = c(compressed_dim_index(1)) + ie = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + js = 1 + je = size(cdata,2) + else + js = c(compressed_dim_index(1)) + je = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + is = 1 + ie = size(cdata,2) + endif + + select type(cdata) + type is (integer(kind=i4_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level) + type is (integer(kind=i8_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r4_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r8_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level) + class default + call error("unsupported variable type: "//trim(append_error_msg)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine compressed_write_3d diff --git a/fms2_io/include/domain_read.inc b/fms2_io/include/domain_read.inc index 3a70c067b2..13f142c19a 100644 --- a/fms2_io/include/domain_read.inc +++ b/fms2_io/include/domain_read.inc @@ -32,14 +32,14 @@ subroutine domain_read_0d(fileobj, variable_name, vdata, unlim_dim_level, corner type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. call netcdf_read_data(fileobj, variable_name, vdata, & unlim_dim_level=unlim_dim_level, corner=corner, & @@ -59,17 +59,17 @@ subroutine domain_read_1d(fileobj, variable_name, vdata, unlim_dim_level, & type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), dimension(:), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, dimension(1), intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. integer, dimension(1), intent(in), optional :: edge_lengths !< The number of !! elements that - !! will be written + !! will be read !! in each dimension. call netcdf_read_data(fileobj, variable_name, vdata, & @@ -86,48 +86,52 @@ end subroutine domain_read_1d !! decomposed". subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, & corner, edge_lengths) - - type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:), intent(inout) :: vdata !< Data that will - !! be written out - !! to the netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(2), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(2), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. - - integer :: xdim_index - integer :: ydim_index - type(domain2d), pointer :: io_domain - integer :: xpos - integer :: ypos - integer :: i - integer :: isd - integer :: isc - integer :: xc_size - integer :: jsd - integer :: jsc - integer :: yc_size - integer, dimension(:), allocatable :: pe_isc - integer, dimension(:), allocatable :: pe_icsize - integer, dimension(:), allocatable :: pe_jsc - integer, dimension(:), allocatable :: pe_jcsize - integer, dimension(2) :: c - integer, dimension(2) :: e - integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind - logical :: buffer_includes_halos - integer :: xgmin !< Starting x index of global io domain - integer :: ygmin !< Starting y index of global io domain + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), contiguous, target, intent(inout) :: vdata(:,:) !< Data that will + !! be read out + !! to the netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(2), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be read to. + integer, dimension(2), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be read + !! in each dimension. + + integer :: xdim_index !< The index of the variable that is the x dimension + integer :: ydim_index !< The index of the variable that is the y dimension + integer :: xpos !< The position of the x axis + integer :: ypos !< The position of the y axis + integer :: i !< For do loops + integer :: isd !< The starting x position of the data io_domain + integer :: isc !< The starting x position of the compute io_domain + integer :: xc_size !< The size of the x compute io_domain + integer :: yc_size !< The size of the y compute io_domain + integer :: jsd !< The ending x position of the data io_domain + integer :: jsc !< The ending y position of the compute io_domain + integer :: c(2) !< The corners of the data + integer :: e(2) !< The number of points (edges) + logical :: buffer_includes_halos !< .True. if vdata includes halo points + integer :: xgbegin !< Starting x index of global io domain + integer :: xgsize !< Size of global x io domain + integer :: ygbegin !< Starting y index of global io domain + integer :: ygsize !< Size of global y io domain + type(domain2d), pointer :: io_domain !< pointer to the io_domain + + !< The global data is only allocated by the io root PEs + integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind_pe !< PES section of the data + integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind_pe !< PES section of the data + real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind_pe !< PES section of the data + real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind_pe !< PES section of the data + integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind !< Global section of the data + integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind !< Global section of the data + real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind !< Global section of the data + real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind !< Global section of the data + class(*), dimension(:,:,:,:), pointer :: vdata_dummy !< Vdata remapped as 4D if (.not. is_variable_domain_decomposed(fileobj, variable_name, .true., & xdim_index, ydim_index, xpos, ypos)) then @@ -136,6 +140,15 @@ subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, & edge_lengths=edge_lengths, broadcast=.true.) return endif + + if (xdim_index .ne. 1 .or. ydim_index .ne. 2) then + ! This is a KLUDGE + ! mpp_scatter assumes that the variable is (x,y), if that is not the case it remaps the data + ! to a 4D array and calls domain_read_4d which does not use mpp_scatter yet + vdata_dummy(1:size(vdata,1),1:size(vdata,2), 1:1, 1:1) => vdata(:,:) + call domain_read_4d(fileobj, variable_name, vdata_dummy, unlim_dim_level) + return + endif io_domain => mpp_get_io_domain(fileobj%domain) call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, & xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, & @@ -143,159 +156,105 @@ subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, & c(:) = 1 e(:) = shape(vdata) + call mpp_get_global_domain(io_domain, xbegin=xgbegin, xsize=xgsize, position=xpos) + call mpp_get_global_domain(io_domain, ybegin=ygbegin, ysize=ygsize, position=ypos) + !I/O root reads in the data and scatters it. if (fileobj%is_root) then - allocate(pe_isc(size(fileobj%pelist))) - allocate(pe_icsize(size(fileobj%pelist))) - allocate(pe_jsc(size(fileobj%pelist))) - allocate(pe_jcsize(size(fileobj%pelist))) - call mpp_get_compute_domains(io_domain, xbegin=pe_isc, xsize=pe_icsize, position=xpos) - call mpp_get_compute_domains(io_domain, ybegin=pe_jsc, ysize=pe_jcsize, position=ypos) - call mpp_get_global_domain(io_domain, xbegin=xgmin, position=xpos) - call mpp_get_global_domain(io_domain, ybegin=ygmin, position=ypos) - do i = 1, size(fileobj%pelist) - c(xdim_index) = pe_isc(i) - c(ydim_index) = pe_jsc(i) - if (fileobj%adjust_indices) then - c(xdim_index) = c(xdim_index) - xgmin + 1 - c(ydim_index) = c(ydim_index) - ygmin + 1 - endif - e(xdim_index) = pe_icsize(i) - e(ydim_index) = pe_jcsize(i) - select type(vdata) - type is (integer(kind=i4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) - end select - enddo - deallocate(pe_isc) - deallocate(pe_icsize) - deallocate(pe_jsc) - deallocate(pe_jcsize) - else - if (buffer_includes_halos) then - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 + + if (fileobj%adjust_indices) then + !< If the file is distributed, the file only contains the io global domain + c(xdim_index) = 1 + c(ydim_index) = 1 + else + !< If the file is not distributed read, the file contains the global domain, + !! so you only need to read the global io domain + c(xdim_index) = xgbegin + c(ydim_index) = ygbegin endif - e(xdim_index) = xc_size - e(ydim_index) = yc_size + + e(xdim_index) = xgsize + e(ydim_index) = ygsize + + !Read in the global io domain select type(vdata) type is (integer(kind=i4_kind)) call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i4_kind, vdata, c, e) - deallocate(buf_i4_kind) + call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (integer(kind=i8_kind)) call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i8_kind, vdata, c, e) - deallocate(buf_i8_kind) + call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r4_kind)) call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r4_kind, vdata, c, e) - deallocate(buf_r4_kind) + call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r8_kind)) call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r8_kind, vdata, c, e) - deallocate(buf_r8_kind) + call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) class default call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) + & trim(variable_name)) end select + + endif + + c = 1 + e = shape(vdata) + + if (buffer_includes_halos) then + !Adjust if the input buffer has room for halos. + c(xdim_index) = isc - isd + 1 + c(ydim_index) = jsc - jsd + 1 + else + c(xdim_index) = 1 + c(ydim_index) = 1 + endif + + e(xdim_index) = xc_size + e(ydim_index) = yc_size + + select type(vdata) + type is (integer(kind=i4_kind)) + call allocate_array(buf_i4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_i4_kind_pe, buf_i4_kind, fileobj%is_root) + call put_array_section(buf_i4_kind_pe, vdata, c, e) + deallocate(buf_i4_kind_pe) + type is (integer(kind=i8_kind)) + call allocate_array(buf_i8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_i8_kind_pe, buf_i8_kind, fileobj%is_root) + call put_array_section(buf_i8_kind_pe, vdata, c, e) + deallocate(buf_i8_kind_pe) + type is (real(kind=r4_kind)) + call allocate_array(buf_r4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_r4_kind_pe, buf_r4_kind, fileobj%is_root) + call put_array_section(buf_r4_kind_pe, vdata, c, e) + deallocate(buf_r4_kind_pe) + type is (real(kind=r8_kind)) + call allocate_array(buf_r8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_r8_kind_pe, buf_r8_kind, fileobj%is_root) + call put_array_section(buf_r8_kind_pe, vdata, c, e) + deallocate(buf_r8_kind_pe) + class default + call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & + & trim(variable_name)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine domain_read_2d @@ -307,48 +266,52 @@ end subroutine domain_read_2d !! decomposed". subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, & corner, edge_lengths) - - type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:,:), intent(inout) :: vdata !< Data that will - !! be written out - !! to the netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(3), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(3), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. - - integer :: xdim_index - integer :: ydim_index - type(domain2d), pointer :: io_domain - integer :: xpos - integer :: ypos - integer :: i - integer :: isd - integer :: isc - integer :: xc_size - integer :: jsd - integer :: jsc - integer :: yc_size - integer, dimension(:), allocatable :: pe_isc - integer, dimension(:), allocatable :: pe_icsize - integer, dimension(:), allocatable :: pe_jsc - integer, dimension(:), allocatable :: pe_jcsize - integer, dimension(3) :: c - integer, dimension(3) :: e - integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind - logical :: buffer_includes_halos - integer :: xgmin !< Starting x index of global io domain - integer :: ygmin !< Starting y index of global io domain + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), contiguous, target, intent(inout) :: vdata(:,:,:) !< Data that will + !! be read out + !! to the netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(3), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be read to. + integer, dimension(3), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be read + !! in each dimension. + + integer :: xdim_index !< The index of the variable that is the x dimension + integer :: ydim_index !< The index of the variable that is the y dimension + integer :: xpos !< The position of the x axis + integer :: ypos !< The position of the y axis + integer :: i !< For do loops + integer :: isd !< The starting x position of the data io_domain + integer :: isc !< The starting x position of the compute io_domain + integer :: xc_size !< The size of the x compute io_domain + integer :: yc_size !< The size of the y compute io_domain + integer :: jsd !< The ending x position of the data io_domain + integer :: jsc !< The ending y position of the compute io_domain + integer :: c(3) !< The corners of the data + integer :: e(3) !< The number of points (edges) + logical :: buffer_includes_halos !< .True. if vdata includes halo points + integer :: xgbegin !< Starting x index of global io domain + integer :: xgsize !< Size of global x io domain + integer :: ygbegin !< Starting y index of global io domain + integer :: ygsize !< Size of global y io domain + type(domain2d), pointer :: io_domain !< pointer to the io_domain + + !< The global data is only allocated by the io root PEs + integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind_pe !< PES section of the data + integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind_pe !< PES section of the data + real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind_pe !< PES section of the data + real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind_pe !< PES section of the data + integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind !< Global section of the data + integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind !< Global section of the data + real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind !< Global section of the data + real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind !< Global section of the data + class(*), dimension(:,:,:,:), pointer :: vdata_dummy !< Vdata remapped as 4D if (.not. is_variable_domain_decomposed(fileobj, variable_name, .true., & xdim_index, ydim_index, xpos, ypos)) then @@ -357,6 +320,15 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, & edge_lengths=edge_lengths, broadcast=.true.) return endif + + if (xdim_index .ne. 1 .or. ydim_index .ne. 2) then + ! This is a KLUDGE + ! mpp_scatter assumes that the variable is (x,y), if that is not the case it remaps the data + ! to a 4D array and calls domain_read_4d which does not use mpp_scatter yet + vdata_dummy(1:size(vdata,1),1:size(vdata,2), 1:size(vdata,3), 1:1) => vdata(:,:,:) + call domain_read_4d(fileobj, variable_name, vdata_dummy, unlim_dim_level) + return + endif io_domain => mpp_get_io_domain(fileobj%domain) call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, & xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, & @@ -364,160 +336,107 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, & c(:) = 1 e(:) = shape(vdata) + call mpp_get_global_domain(io_domain, xbegin=xgbegin, xsize=xgsize, position=xpos) + call mpp_get_global_domain(io_domain, ybegin=ygbegin, ysize=ygsize, position=ypos) + !I/O root reads in the data and scatters it. if (fileobj%is_root) then - allocate(pe_isc(size(fileobj%pelist))) - allocate(pe_icsize(size(fileobj%pelist))) - allocate(pe_jsc(size(fileobj%pelist))) - allocate(pe_jcsize(size(fileobj%pelist))) - call mpp_get_compute_domains(io_domain, xbegin=pe_isc, xsize=pe_icsize, position=xpos) - call mpp_get_compute_domains(io_domain, ybegin=pe_jsc, ysize=pe_jcsize, position=ypos) - call mpp_get_global_domain(io_domain, xbegin=xgmin, position=xpos) - call mpp_get_global_domain(io_domain, ybegin=ygmin, position=ypos) - do i = 1, size(fileobj%pelist) - c(xdim_index) = pe_isc(i) - c(ydim_index) = pe_jsc(i) - if (fileobj%adjust_indices) then - c(xdim_index) = c(xdim_index) - xgmin + 1 - c(ydim_index) = c(ydim_index) - ygmin + 1 - endif - e(xdim_index) = pe_icsize(i) - e(ydim_index) = pe_jcsize(i) - select type(vdata) - type is (integer(kind=i4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: domain_read_3d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) - end select - enddo - deallocate(pe_isc) - deallocate(pe_icsize) - deallocate(pe_jsc) - deallocate(pe_jcsize) - else - if (buffer_includes_halos) then - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 + + if (fileobj%adjust_indices) then + !< If the file is distributed, the file only contains the io global domain + c(xdim_index) = 1 + c(ydim_index) = 1 + else + !< If the file is not distributed read, the file contains the global domain, + !! so you only need to read the global io domain + c(xdim_index) = xgbegin + c(ydim_index) = ygbegin endif - e(xdim_index) = xc_size - e(ydim_index) = yc_size + + e(xdim_index) = xgsize + e(ydim_index) = ygsize + + !Read in the global io domain select type(vdata) type is (integer(kind=i4_kind)) call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i4_kind, vdata, c, e) - deallocate(buf_i4_kind) + call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (integer(kind=i8_kind)) call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i8_kind, vdata, c, e) - deallocate(buf_i8_kind) + call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r4_kind)) call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r4_kind, vdata, c, e) - deallocate(buf_r4_kind) + call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r8_kind)) call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r8_kind, vdata, c, e) - deallocate(buf_r8_kind) + call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) class default - call error("unsupported variable type: domain_read_3d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) + call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & + & trim(variable_name)) end select + + endif + + c = 1 + e = shape(vdata) + + if (buffer_includes_halos) then + !Adjust if the input buffer has room for halos. + c(xdim_index) = isc - isd + 1 + c(ydim_index) = jsc - jsd + 1 + else + c(xdim_index) = 1 + c(ydim_index) = 1 endif + + e(xdim_index) = xc_size + e(ydim_index) = yc_size + + select type(vdata) + type is (integer(kind=i4_kind)) + call allocate_array(buf_i4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_i4_kind_pe, buf_i4_kind, fileobj%is_root) + call put_array_section(buf_i4_kind_pe, vdata, c, e) + deallocate(buf_i4_kind_pe) + type is (integer(kind=i8_kind)) + call allocate_array(buf_i8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_i8_kind_pe, buf_i8_kind, fileobj%is_root) + call put_array_section(buf_i8_kind_pe, vdata, c, e) + deallocate(buf_i8_kind_pe) + type is (real(kind=r4_kind)) + call allocate_array(buf_r4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_r4_kind_pe, buf_r4_kind, fileobj%is_root) + call put_array_section(buf_r4_kind_pe, vdata, c, e) + deallocate(buf_r4_kind_pe) + type is (real(kind=r8_kind)) + call allocate_array(buf_r8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_r8_kind_pe, buf_r8_kind, fileobj%is_root) + call put_array_section(buf_r8_kind_pe, vdata, c, e) + deallocate(buf_r8_kind_pe) + class default + call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & + & trim(variable_name)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) + endif + end subroutine domain_read_3d @@ -532,17 +451,17 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), dimension(:,:,:,:), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, dimension(4), intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. integer, dimension(4), intent(in), optional :: edge_lengths !< The number of !! elements that - !! will be written + !! will be read !! in each dimension. integer :: xdim_index @@ -753,17 +672,17 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), dimension(:,:,:,:,:), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, dimension(5), intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. integer, dimension(5), intent(in), optional :: edge_lengths !< The number of !! elements that - !! will be written + !! will be read !! in each dimension. integer :: xdim_index diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 03adef35a6..b76042900a 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -1015,6 +1015,7 @@ function get_variable_compressed_dimension_index(fileobj, variable_name, broadca endif endif call mpp_broadcast(compressed_dimension_index(1), fileobj%io_root, pelist=fileobj%pelist) + call mpp_broadcast(compressed_dimension_index(2), fileobj%io_root, pelist=fileobj%pelist) end function get_variable_compressed_dimension_index diff --git a/mpp/include/mpp_comm.inc b/mpp/include/mpp_comm.inc index 2355102ea9..024cb097fc 100644 --- a/mpp/include/mpp_comm.inc +++ b/mpp/include/mpp_comm.inc @@ -398,6 +398,20 @@ #define MPP_GATHER_PELIST_3D_ mpp_gather_pelist_int4_3d #include + +#undef MPP_GATHER_1D_ +#undef MPP_GATHER_1DV_ +#undef MPP_TYPE_ +#define MPP_TYPE_ integer(i8_kind) +#define MPP_GATHER_1D_ mpp_gather_int8_1d +#define MPP_GATHER_1DV_ mpp_gather_int8_1dv +#undef MPP_GATHER_PELIST_2D_ +#undef MPP_GATHER_PELIST_3D_ +#define MPP_GATHER_PELIST_2D_ mpp_gather_pelist_int8_2d +#define MPP_GATHER_PELIST_3D_ mpp_gather_pelist_int8_3d +#include + + #undef MPP_GATHER_1D_ #undef MPP_GATHER_1DV_ #undef MPP_TYPE_ @@ -431,6 +445,14 @@ #define MPP_SCATTER_PELIST_3D_ mpp_scatter_pelist_int4_3d #include +#undef MPP_SCATTER_PELIST_2D_ +#undef MPP_SCATTER_PELIST_3D_ +#undef MPP_TYPE_ +#define MPP_TYPE_ integer(i8_kind) +#define MPP_SCATTER_PELIST_2D_ mpp_scatter_pelist_int8_2d +#define MPP_SCATTER_PELIST_3D_ mpp_scatter_pelist_int8_3d +#include + #undef MPP_SCATTER_PELIST_2D_ #undef MPP_SCATTER_PELIST_3D_ #undef MPP_TYPE_ diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc index 74b195b809..c27af7c093 100644 --- a/mpp/include/mpp_domains_util.inc +++ b/mpp/include/mpp_domains_util.inc @@ -324,6 +324,14 @@ !call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%data) enddo + do i=1, size(domain%x(1)%list) + call mpp_set_super_grid_indices(domain%x(1)%list(i-1)%compute) + enddo + + do i=1, size(domain%y(1)%list) + call mpp_set_super_grid_indices(domain%y(1)%list(i-1)%compute) + enddo + end subroutine mpp_create_super_grid_domain !##################################################################### diff --git a/mpp/mpp.F90 b/mpp/mpp.F90 index d429abb3f9..7d07e1937c 100644 --- a/mpp/mpp.F90 +++ b/mpp/mpp.F90 @@ -698,16 +698,20 @@ module mpp_mod interface mpp_gather module procedure mpp_gather_logical_1d module procedure mpp_gather_int4_1d + module procedure mpp_gather_int8_1d module procedure mpp_gather_real4_1d module procedure mpp_gather_real8_1d module procedure mpp_gather_logical_1dv module procedure mpp_gather_int4_1dv + module procedure mpp_gather_int8_1dv module procedure mpp_gather_real4_1dv module procedure mpp_gather_real8_1dv module procedure mpp_gather_pelist_logical_2d module procedure mpp_gather_pelist_logical_3d module procedure mpp_gather_pelist_int4_2d module procedure mpp_gather_pelist_int4_3d + module procedure mpp_gather_pelist_int8_2d + module procedure mpp_gather_pelist_int8_3d module procedure mpp_gather_pelist_real4_2d module procedure mpp_gather_pelist_real4_3d module procedure mpp_gather_pelist_real8_2d @@ -734,6 +738,8 @@ module mpp_mod interface mpp_scatter module procedure mpp_scatter_pelist_int4_2d module procedure mpp_scatter_pelist_int4_3d + module procedure mpp_scatter_pelist_int8_2d + module procedure mpp_scatter_pelist_int8_3d module procedure mpp_scatter_pelist_real4_2d module procedure mpp_scatter_pelist_real4_3d module procedure mpp_scatter_pelist_real8_2d diff --git a/test_fms/fms2_io/Makefile.am b/test_fms/fms2_io/Makefile.am index d7fd03a867..ee4fddbc0e 100644 --- a/test_fms/fms2_io/Makefile.am +++ b/test_fms/fms2_io/Makefile.am @@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_get_is_valid test_file_appendix test_fms2_io test_atmosphere_io test_io_simple test_io_with_mask test_global_att \ - test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes + test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes test_domain_io test_compressed_writes # This is the source code for the test. test_get_is_valid_SOURCES = test_get_is_valid.F90 @@ -49,6 +49,8 @@ test_read_ascii_file_SOURCES=test_read_ascii_file.F90 test_file_appendix_SOURCES=test_file_appendix.F90 test_unlimit_compressed_SOURCES=test_unlimit_compressed.F90 test_chunksizes_SOURCES = test_chunksizes.F90 +test_compressed_writes_SOURCES = test_compressed_writes.F90 +test_domain_io_SOURCES = test_domain_io.F90 EXTRA_DIST = test_bc_restart.sh test_fms2_io.sh test_atmosphere_io.sh test_io_simple.sh test_global_att.sh test_io_with_mask.sh test_read_ascii_file.sh diff --git a/test_fms/fms2_io/test_compressed_writes.F90 b/test_fms/fms2_io/test_compressed_writes.F90 new file mode 100644 index 0000000000..b905be70d7 --- /dev/null +++ b/test_fms/fms2_io/test_compressed_writes.F90 @@ -0,0 +1,290 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief This programs tests the compressed writes in fms2_io +program test_compressed_writes + use fms_mod, only: fms_init, fms_end + use fms2_io_mod, only: open_file, close_file, FmsNetcdfFile_t, register_axis, write_data, & + register_field, read_data + use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_get_current_pelist, FATAL, mpp_npes, mpp_chksum, & + mpp_error + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind + + implicit none + + !> @brief Dummy type to hold variable data + type data_type + real(kind=r4_kind), allocatable :: var_r4(:,:,:,:,:) + real(kind=r8_kind), allocatable :: var_r8(:,:,:,:,:) + integer(kind=i4_kind), allocatable :: var_i4(:,:,:,:,:) + integer(kind=i8_kind), allocatable :: var_i8(:,:,:,:,:) + end type + + type(FmsNetcdfFile_t) :: fileobj !< fms2io fileobj for domain decomposed + character(len=6), dimension(5) :: names !< Dimensions names + type(data_type) :: var_data_in !< Variable data written in + type(data_type) :: var_data_out !< Variable data read + type(data_type) :: var_data_ref !< Variable data read + integer :: ndim2 = 2 !< The size of the second dimension + integer :: ndim3 = 3 !< The size of the third dimension + integer :: ndim4 = 4 !< The size of the fourth dimension + integer :: ndim5 = 1 !< The size of the fifth dimension + integer, allocatable :: pes(:) !< The pelist + + call fms_init + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if (open_file(fileobj, "test_compressed_writes.nc", "overwrite", nc_format="netcdf4", pelist=pes)) then + + names(1) = "c_xy" + names(2) = "dim2" + names(3) = "dim3" + names(4) = "dim4" + names(5) = "dim5" + + call register_axis(fileobj, "c_xy", mpp_pe()+1, is_compressed=.true.) + call register_axis(fileobj, "dim2", ndim2) + call register_axis(fileobj, "dim3", ndim3) + call register_axis(fileobj, "dim4", ndim4) + call register_axis(fileobj, "dim5", ndim5) + + call register_field_wrapper(fileobj, "var1", names, 1) + call register_field_wrapper(fileobj, "var2", names, 2) + call register_field_wrapper(fileobj, "var3", names, 3) + call register_field_wrapper(fileobj, "var4", names, 4) + call register_field_wrapper(fileobj, "var5", names, 5) + + call var_data_alloc(var_data_in, ndim2, ndim3, ndim4, ndim5, mpp_pe()+1) + call var_data_set(var_data_in, mpp_pe()) + + call write_data_wrapper(fileobj, "r4", var_data_in%var_r4) + call write_data_wrapper(fileobj, "r8", var_data_in%var_r8) + call write_data_wrapper(fileobj, "i4", var_data_in%var_i4) + call write_data_wrapper(fileobj, "i8", var_data_in%var_i8) + + call close_file(fileobj) + endif + + !< Now check answers + if (mpp_pe() .eq. mpp_root_pe()) then + !call mpp_set_current_pelist((/mpp_pe()/)) + if (open_file(fileobj, "test_compressed_writes.nc", "read", nc_format="netcdf4")) then + call var_data_alloc(var_data_out, ndim2, ndim3, ndim4, ndim5, sum(pes)+mpp_npes()) + call var_data_alloc(var_data_ref, ndim2, ndim3, ndim4, ndim5, sum(pes)+mpp_npes()) + call var_data_set_ref(var_data_ref) + + call read_data_wrapper(fileobj, "var2", 1, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var2", 2, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var3", 3, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var4", 4, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var5", 5, var_data_out, var_data_ref) + + call close_file(fileobj) + endif + endif + call fms_end + + contains + + !> @brief registers all of the possible variable types for a given + !! number of dimensions + subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim) + type(FmsNetcdfFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< Name of the variable + character(len=*), intent(in) :: dimension_names(:) !< dimension names + integer, intent(in) :: ndim !< Number of dimension + + call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int64", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int", names(1:ndim)) + end subroutine register_field_wrapper + +!> @brief Allocates the variable to be the size of data compute domain for x and y + !! and for a given size for the 3rd 4th and 5th dimension + subroutine var_data_alloc(var_data, dim2, dim3, dim4, dim5, compressed_dim) + type(data_type), intent(inout) :: var_data !< Variable data + integer, intent(in) :: dim2 !< Size of dim3 + integer, intent(in) :: dim3 !< Size of dim3 + integer, intent(in) :: dim4 !< Size of dim4 + integer, intent(in) :: dim5 !< Size of dim5 + integer, intent(in) :: compressed_dim !< Size of the compressed dimension + + allocate(var_data%var_r4(compressed_dim, dim2, dim3, dim4, dim5)) + allocate(var_data%var_r8(compressed_dim, dim2, dim3, dim4, dim5)) + allocate(var_data%var_i4(compressed_dim, dim2, dim3, dim4, dim5)) + allocate(var_data%var_i8(compressed_dim, dim2, dim3, dim4, dim5)) + end subroutine var_data_alloc + + + !> @brief Sets the data to some value + subroutine var_data_set(var_data, var_value) + type(data_type), intent(inout) :: var_data !< Variable data + integer, intent(in) :: var_value !< Value to set the data as + + var_data%var_r4 = real(var_value, kind=r4_kind) + var_data%var_r8 = real(var_value, kind=r8_kind) + var_data%var_i4 = int(var_value, kind=i4_kind) + var_data%var_i8 = int(var_value, kind=i8_kind) + end subroutine var_data_set + + !> @brief Writes the data for a give variable type + subroutine write_data_wrapper(fileob, var_kind, var_data) + type(FmsNetcdfFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_kind !< The kind of the variable + class(*), intent(in) :: var_data(:,:,:,:,:) !< Variable data + + call write_data(fileob, "var1_"//trim(var_kind), var_data(:,1,1,1,1)) + call write_data(fileob, "var2_"//trim(var_kind), var_data(:,:,1,1,1)) + call write_data(fileob, "var3_"//trim(var_kind), var_data(:,:,:,1,1)) + call write_data(fileob, "var4_"//trim(var_kind), var_data(:,:,:,:,1)) + call write_data(fileob, "var5_"//trim(var_kind), var_data(:,:,:,:,:)) + + end subroutine + + !> @brief Reads the data and compares it with reference data + subroutine read_data_wrapper(fileob, var_name, dim, var_data, ref_data) + type(FmsNetcdfFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< The kind of the variable + integer, intent(in) :: dim !< The dimension of the variable + type(data_type), intent(inout) :: var_data !< Variable data to read to + type(data_type), intent(in) :: ref_data !< Variable data to compare to + + select case(dim) + case(1) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,1,1,1,1), (/mpp_pe()/)), "var2_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,1,1,1,1), (/mpp_pe()/)), "var2_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,1,1,1,1), (/mpp_pe()/)), "var2_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,1,1,1,1), (/mpp_pe()/)), "var2_i8") + case(2) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,1,1,1), (/mpp_pe()/)), "var2_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,1,1,1), (/mpp_pe()/)), "var2_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,1,1,1), (/mpp_pe()/)), "var2_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,1,1,1), (/mpp_pe()/)), "var2_i8") + case(3) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,:,1,1), (/mpp_pe()/)), "var3_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,:,1,1), (/mpp_pe()/)), "var3_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,:,1,1), (/mpp_pe()/)), "var3_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,:,1,1), (/mpp_pe()/)), "var3_i8") + case(4) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,:,:,1), (/mpp_pe()/)), "var4_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,:,:,1), (/mpp_pe()/)), "var4_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,:,:,1), (/mpp_pe()/)), "var4_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,:,:,1), (/mpp_pe()/)), "var4_i8") + case(5) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,:,:,:), (/mpp_pe()/)), "var5_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,:,:,:), (/mpp_pe()/)), "var5_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,:,:,:), (/mpp_pe()/)), "var5_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,:,:,:), (/mpp_pe()/)), "var5_i8") + end select + end subroutine + + !> @brief Sets the data to the expected answer + subroutine var_data_set_ref(var_data) + type(data_type), intent(inout) :: var_data !< Variable data to set + integer :: starting_index !< Starting index of the current pes data + integer :: ending_index !< Ending index of the current pes data + integer :: i !< for do loops + + ending_index = 0 + do i = 1, size(pes) + starting_index = ending_index + 1 + ending_index = starting_index + pes(i) + + var_data%var_r4(starting_index:ending_index,:,:,:,:) = real(pes(i), kind=r4_kind) + var_data%var_r8(starting_index:ending_index,:,:,:,:) = real(pes(i), kind=r8_kind) + var_data%var_i4(starting_index:ending_index,:,:,:,:) = int(pes(i), kind=i4_kind) + var_data%var_i8(starting_index:ending_index,:,:,:,:) = int(pes(i), kind=i8_kind) + + enddo + end subroutine + + !> @brief Compares two checksums and crashes if they are not the same + subroutine compare_var_data(check_sum_in, check_sum_ref, varname) + integer(kind=i8_kind), intent(in) :: check_sum_in !< The checksum calculated from the data read + integer(kind=i8_kind), intent(in) :: check_sum_ref !< The checksum to compare to + character(len=*), intent(in) :: varname !< Variable name for reference + + if (check_sum_ref .ne. check_sum_in) call mpp_error(FATAL, & + "Checksums do not match for variable: "//trim(varname)) + end subroutine compare_var_data + +end program test_compressed_writes diff --git a/test_fms/fms2_io/test_domain_io.F90 b/test_fms/fms2_io/test_domain_io.F90 new file mode 100644 index 0000000000..07a3e2845a --- /dev/null +++ b/test_fms/fms2_io/test_domain_io.F90 @@ -0,0 +1,312 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +program test_domain_read + use mpp_domains_mod, only: mpp_domains_set_stack_size, mpp_define_domains, mpp_define_io_domain, & + mpp_get_compute_domain, mpp_get_data_domain, domain2d, EAST, NORTH, CENTER + use mpp_mod, only: mpp_chksum, mpp_pe, mpp_root_pe, mpp_error, FATAL, input_nml_file + use fms2_io_mod, only: open_file, register_axis, register_variable_attribute, close_file, & + FmsNetcdfDomainFile_t, write_data, register_field, read_data, & + parse_mask_table + use fms_mod, only: fms_init, fms_end, check_nml_error + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind + + implicit none + + !> @brief Dummy type to hold variable data + type data_t + real(kind=r4_kind), allocatable :: var_r4(:,:,:,:,:) + real(kind=r8_kind), allocatable :: var_r8(:,:,:,:,:) + integer(kind=i4_kind), allocatable :: var_i4(:,:,:,:,:) + integer(kind=i8_kind), allocatable :: var_i8(:,:,:,:,:) + end type + + ! Namelist variables + integer, dimension(2) :: layout = (/2,3/) !< Domain layout + integer, dimension(2) :: io_layout = (/1,1/) !< Domain layout + integer :: nx = 96 !< Number of points in dim1 + integer :: ny = 96 !< Number of points in dim2 + character(len=20) :: mask_table = "" !< Name of a masktable to use + integer :: xhalo = 3 !< Number of halo points in X + integer :: yhalo = 2 !< Number of halo points in Y + integer :: nz = 2 !< Number of points in the z dimension + character(len=20) :: filename="test.nc" !< Name of the file + logical :: use_edges=.false. !< Use North and East domain positions + + integer :: ndim4 !< Number of points in dim4 + integer :: ndim5 !< Number of points in dim5 + type(domain2d) :: Domain !< Domain with mask table + type(FmsNetcdfDomainFile_t) :: fileobj !< fms2io fileobj for domain decomposed + character(len=6), dimension(5) :: names !< Dimensions names + type(data_t) :: var_data_in !< Variable data written in + type(data_t) :: var_data_out !< Variable data read in + logical, allocatable, dimension(:,:) :: parsed_mask !< Parsed masked + integer :: io !< Error code when reading namelist + integer :: ierr !< Error code when reading namelist + integer :: xposition !< position in the x dimension ("EAST" or "CENTER") + integer :: yposition !< position in the y dimension ("NORTH" or "CENTER") + + namelist /test_domain_io_nml/ layout, io_layout, nx, ny, nz, mask_table, xhalo, yhalo, nz, filename, use_edges + + call fms_init + + read(input_nml_file, nml=test_domain_io_nml, iostat=io) + ierr = check_nml_error(io, 'test_domain_io_nml') + + ndim4 = 2 + ndim5 = 2 + + if (use_edges) then + xposition = EAST + yposition = NORTH + else + xposition = CENTER + yposition = CENTER + endif + + !< Parse the mask table + allocate(parsed_mask(layout(1), layout(2))) + parsed_mask = .True. + if (trim(mask_table) .ne. "") then + call parse_mask_table(trim(mask_table), parsed_mask, 'test_io_with_mask') + endif + + call mpp_domains_set_stack_size(17280000) + call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, xhalo=xhalo, yhalo=yhalo, & + maskmap=parsed_mask) + call mpp_define_io_domain(Domain, io_layout) + + if (open_file(fileobj, trim(filename), "overwrite", domain, nc_format="netcdf4")) then + names(1) = "dim1" + names(2) = "dim2" + names(3) = "dim3" + names(4) = "dim4" + names(5) = "dim5" + + call register_axis(fileobj, "dim1", "x", domain_position=xposition ) + call register_axis(fileobj, "dim2", "y", domain_position=yposition ) + call register_axis(fileobj, "dim3", nz) + call register_axis(fileobj, "dim4", ndim4) + call register_axis(fileobj, "dim5", ndim5) + + call register_field_wrapper(fileobj, "var2", names, 2) + call register_field_wrapper(fileobj, "var3", names, 3) + call register_field_wrapper(fileobj, "var4", names, 4) + call register_field_wrapper(fileobj, "var5", names, 5) + + call var_data_alloc(var_data_in, Domain, nz, ndim4, ndim5) + call var_data_init(var_data_in) + call var_data_set(var_data_in, Domain, nz, ndim4, ndim5) + + call write_data_wrapper(fileobj, "r4", var_data_in%var_r4) + call write_data_wrapper(fileobj, "r8", var_data_in%var_r8) + call write_data_wrapper(fileobj, "i4", var_data_in%var_i4) + call write_data_wrapper(fileobj, "i8", var_data_in%var_i8) + + call close_file(fileobj) + endif + + if (open_file(fileobj, trim(filename), "read", domain, nc_format="netcdf4")) then + call register_axis(fileobj, "dim1", "x") + call register_axis(fileobj, "dim2", "y") + + call var_data_alloc(var_data_out, Domain, nz, ndim4, ndim5) + call read_data_wrapper(fileobj, "var2", 2, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var3", 3, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var4", 4, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var5", 5, var_data_out, var_data_in) + + call close_file(fileobj) + endif + call fms_end + + contains + + !> @brief registers all of the possible variable types for a given + !! number of dimensions + subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< Name of the variable + character(len=*), intent(in) :: dimension_names(:) !< dimension names + integer, intent(in) :: ndim !< Number of dimension + + call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int64", names(1:ndim)) + end subroutine register_field_wrapper + + !> @brief Allocates the variable to be the size of data compute domain for x and y + !! and for a given size for the 3rd 4th and 5th dimension + subroutine var_data_alloc(var_data, var_domain, dim3, dim4, dim5) + type(data_t), intent(inout) :: var_data !< Variable data + type(domain2d), intent(in) :: var_domain !< Domain with mask table + integer, intent(in) :: dim3 !< Size of dim3 + integer, intent(in) :: dim4 !< Size of dim4 + integer, intent(in) :: dim5 !< Size of dim5 + + integer :: is !< Starting x index + integer :: ie !< Ending x index + integer :: js !< Starting y index + integer :: je !< Ending y index + + call mpp_get_data_domain(var_domain, is, ie, js, je) !< This includes halos (but halos will not be written!) + + allocate(var_data%var_r4(is:ie, js:je, dim3, dim4, dim5)) + allocate(var_data%var_r8(is:ie, js:je, dim3, dim4, dim5)) + allocate(var_data%var_i4(is:ie, js:je, dim3, dim4, dim5)) + allocate(var_data%var_i8(is:ie, js:je, dim3, dim4, dim5)) + end subroutine var_data_alloc + + !> @brief Initializes the data to -999.99 for reals and -999 for integers + subroutine var_data_init(var_data) + type(data_t), intent(inout) :: var_data !< Variable data + + var_data%var_r4 = real(-999.99, kind=r4_kind) + var_data%var_r8 = real(-999.99, kind=r8_kind) + var_data%var_i4 = int(-999, kind=i4_kind) + var_data%var_i8 = int(-999, kind=i8_kind) + end subroutine var_data_init + + !> @brief Sets the dcompute domain part of the variable to the expected number + subroutine var_data_set(var_data, var_domain, dim3, dim4, dim5) + type(data_t), intent(inout) :: var_data !< Variable data + type(domain2d), intent(in) :: var_domain !< Domain with mask table + integer, intent(in) :: dim3 !< Size of dim3 + integer, intent(in) :: dim4 !< Size of dim4 + integer, intent(in) :: dim5 !< Size of dim5 + + integer :: i, j, k, l, m !< For do loops + + integer :: is !< Starting x index + integer :: ie !< Ending x index + integer :: js !< Starting y index + integer :: je !< Ending y index + integer :: var_count !< For keeping track of the varible's data + + call mpp_get_compute_domain(var_domain, is, ie, js, je) !< This does not include halos! + + var_count = 0 + do i = is, ie + do j = js, je + do k = 1, dim3 + do l = 1, dim4 + do m = 1, dim5 + var_count = var_count + 1 + var_data%var_r4(i,j,k,l,m) = real(var_count, kind=r4_kind) + var_data%var_r8(i,j,k,l,m) = real(var_count, kind=r8_kind) + var_data%var_i4(i,j,k,l,m) = int(var_count, kind=i4_kind) + var_data%var_i8(i,j,k,l,m) = int(var_count, kind=i8_kind) + enddo + enddo + enddo + enddo + enddo + + end subroutine + + !> @brief Writes the data for a give variable type + subroutine write_data_wrapper(fileob, var_kind, var_data) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_kind !< The kind of the variable + class(*), intent(in) :: var_data(:,:,:,:,:) !< Variable data + + call write_data(fileob, "var2_"//trim(var_kind), var_data(:,:,1,1,1)) + call write_data(fileob, "var3_"//trim(var_kind), var_data(:,:,:,1,1)) + call write_data(fileob, "var4_"//trim(var_kind), var_data(:,:,:,:,1)) + call write_data(fileob, "var5_"//trim(var_kind), var_data(:,:,:,:,:)) + + end subroutine + + !> @brief Reads the data and compares the checksum from the expected result + subroutine read_data_wrapper(fileob, var_name, dim, var_data, ref_data) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< The kind of the variable + integer, intent(in) :: dim !< The variable's dimension + type(data_t), intent(inout) :: var_data !< The variable's data + type(data_t), intent(inout) :: ref_data !< The variable's reference data + + select case(dim) + case(2) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,1,1,1)), mpp_chksum(ref_data%var_r4(:,:,1,1,1)), "var2_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,1,1,1)), mpp_chksum(ref_data%var_r8(:,:,1,1,1)), "var2_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,1,1,1)), mpp_chksum(ref_data%var_i4(:,:,1,1,1)), "var2_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,1,1,1)), mpp_chksum(ref_data%var_i8(:,:,1,1,1)), "var2_i8") + case(3) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,1,1)), mpp_chksum(ref_data%var_r4(:,:,:,1,1)), "var3_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,1,1)), mpp_chksum(ref_data%var_r8(:,:,:,1,1)), "var3_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,1,1)), mpp_chksum(ref_data%var_i4(:,:,:,1,1)), "var3_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,1,1)), mpp_chksum(ref_data%var_i8(:,:,:,1,1)), "var3_i8") + case(4) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,1)), mpp_chksum(ref_data%var_r4(:,:,:,:,1)), "var4_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,1)), mpp_chksum(ref_data%var_r8(:,:,:,:,1)), "var4_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,1)), mpp_chksum(ref_data%var_i4(:,:,:,:,1)), "var4_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,1)), mpp_chksum(ref_data%var_i8(:,:,:,:,1)), "var4_i8") + case(5) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,:)), mpp_chksum(ref_data%var_r4(:,:,:,:,:)), "var5_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,:)), mpp_chksum(ref_data%var_r8(:,:,:,:,:)), "var5_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,:)), mpp_chksum(ref_data%var_i4(:,:,:,:,:)), "var5_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,:)), mpp_chksum(ref_data%var_i8(:,:,:,:,:)), "var5_i8") + end select + + end subroutine read_data_wrapper + + !> @brief Compares two checksums and crashes if they are not the same + subroutine compare_var_data(check_sum_in, check_sum_ref, varname) + integer(kind=i8_kind), intent(in) :: check_sum_in !< Checksum + integer(kind=i8_kind), intent(in) :: check_sum_ref !< The reference checksum + character(len=*), intent(in) :: varname !< The variable's name (for error messages) + + if (check_sum_ref .ne. check_sum_in) call mpp_error(FATAL, & + "Checksums do not match for variable: "//trim(varname)) + end subroutine compare_var_data + +end program test_domain_read diff --git a/test_fms/fms2_io/test_fms2_io.sh b/test_fms/fms2_io/test_fms2_io.sh index a8cd54eaa2..8a604e6655 100755 --- a/test_fms/fms2_io/test_fms2_io.sh +++ b/test_fms/fms2_io/test_fms2_io.sh @@ -48,4 +48,73 @@ test_expect_success "FMS2 IO Test" ' mpirun -n 6 ../test_fms2_io ' +test_expect_success "Compressed writes tests" ' + mpirun -n 5 ../test_compressed_writes +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 1, 6 + io_layout = 1, 1 + filename = "test_simple_layout.nc" +/ +_EOF +test_expect_success "Domain Read Write Tests with simple layout" ' + mpirun -n 6 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 2, 8 + io_layout = 1, 2 + filename = "test_dist_layout.nc" +/ +_EOF +test_expect_success "Domain Read Write Tests with 2 distributed files" ' + mpirun -n 16 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 2, 8 + io_layout = 1, 2 + filename = "test_dist_layout.nc" + use_edges = .true. +/ +_EOF +test_expect_success "Domain Read Write Tests with 2 distributed files and EAST and NORTH axis" ' + mpirun -n 16 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + nx = 33 + ny = 43 + layout = 4, 6 + io_layout = 2, 3 + filename = "test_non_uniform.nc" +/ +_EOF +test_expect_success "Domain Read Write Tests with non uniform layouts" ' + mpirun -n 24 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 3, 6 + io_layout = 1, 2 + mask_table = "mask_table" + filename = "test_io_mask.nc" +/ +_EOF + +cat <<_EOF > mask_table +1 +3,6 +1,1 +_EOF +test_expect_success "Domain Read Write Tests with a ocean mask" ' + mpirun -n 17 ../test_domain_io +' + test_done From 23b86dbd78a376b004fd385fecda439cbe5cd080 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 16 Jun 2023 15:56:42 -0400 Subject: [PATCH 002/394] feat: mixed precision for axis_utils2, horiz_interp, sat_vapor_pressure, and fms_mod (#1239) (#1258) * feat: mixed precision axis_utils2 (#1104) * feat: mixed precision fms_mod (#1147) * feat: horiz interp mixed precision (#1067) * mixed precision sat_vapor_pressure (#1095) * feat: add mixed precision axis_utils unit tests (#1172) * fix: move type definitions to before first usage to fix nvhpc bug (#1187) * fix: change allocatable type for intel errors (#1221) Co-authored-by: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com> Co-authored-by: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Co-authored-by: MiKyung Lee <58964324+mlee03@users.noreply.github.com> --- CMakeLists.txt | 9 +- axis_utils/Makefile.am | 12 +- axis_utils/axis_utils2.F90 | 684 +-- axis_utils/include/axis_utils2.inc | 625 +++ axis_utils/include/axis_utils2_r4.fh | 67 + axis_utils/include/axis_utils2_r8.fh | 67 + configure.ac | 1 + fms/Makefile.am | 12 +- fms/fms.F90 | 55 +- fms/include/fms.inc | 64 + fms/include/fms_r4.fh | 8 + fms/include/fms_r8.fh | 8 + horiz_interp/Makefile.am | 22 +- horiz_interp/horiz_interp.F90 | 865 +--- horiz_interp/horiz_interp_bicubic.F90 | 701 +-- horiz_interp/horiz_interp_bilinear.F90 | 1247 +---- horiz_interp/horiz_interp_conserve.F90 | 992 +--- horiz_interp/horiz_interp_spherical.F90 | 841 +--- horiz_interp/horiz_interp_type.F90 | 247 +- horiz_interp/include/horiz_interp.inc | 843 ++++ horiz_interp/include/horiz_interp_bicubic.inc | 663 +++ .../include/horiz_interp_bicubic_r4.fh | 52 + .../include/horiz_interp_bicubic_r8.fh | 52 + .../include/horiz_interp_bilinear.inc | 1230 +++++ .../include/horiz_interp_bilinear_r4.fh | 52 + .../include/horiz_interp_bilinear_r8.fh | 52 + .../include/horiz_interp_conserve.inc | 926 ++++ .../include/horiz_interp_conserve_r4.fh | 55 + .../include/horiz_interp_conserve_r8.fh | 55 + horiz_interp/include/horiz_interp_r4.fh | 64 + horiz_interp/include/horiz_interp_r8.fh | 64 + .../include/horiz_interp_spherical.inc | 821 +++ .../include/horiz_interp_spherical_r4.fh | 49 + .../include/horiz_interp_spherical_r8.fh | 49 + horiz_interp/include/horiz_interp_type.inc | 90 + horiz_interp/include/horiz_interp_type_r4.fh | 28 + horiz_interp/include/horiz_interp_type_r8.fh | 28 + sat_vapor_pres/Makefile.am | 26 +- sat_vapor_pres/include/sat_vapor_pres.inc | 1984 ++++++++ sat_vapor_pres/include/sat_vapor_pres_k.inc | 2647 ++++++++++ sat_vapor_pres/include/sat_vapor_pres_k_r4.fh | 174 + sat_vapor_pres/include/sat_vapor_pres_k_r8.fh | 174 + sat_vapor_pres/include/sat_vapor_pres_r4.fh | 186 + sat_vapor_pres/include/sat_vapor_pres_r8.fh | 186 + sat_vapor_pres/sat_vapor_pres.F90 | 2116 +------- sat_vapor_pres/sat_vapor_pres_k.F90 | 4417 +---------------- test_fms/Makefile.am | 2 +- test_fms/axis_utils/Makefile.am | 10 +- test_fms/axis_utils/test_axis_utils.F90 | 842 +++- test_fms/axis_utils/test_axis_utils2.sh | 29 +- test_fms/fms/Makefile.am | 9 +- test_fms/fms/include/test_fms.inc | 111 + test_fms/fms/include/test_fms_r4.fh | 13 + test_fms/fms/include/test_fms_r8.fh | 13 + test_fms/fms/test_fms.F90 | 14 +- test_fms/horiz_interp/Makefile.am | 8 +- test_fms/horiz_interp/test_horiz_interp.F90 | 1479 +++++- test_fms/horiz_interp/test_horiz_interp2.sh | 177 +- test_fms/sat_vapor_pres/Makefile.am | 50 + .../sat_vapor_pres/test_sat_vapor_pres.F90 | 1010 ++++ .../sat_vapor_pres/test_sat_vapor_pres.sh | 116 + 61 files changed, 15697 insertions(+), 11796 deletions(-) create mode 100644 axis_utils/include/axis_utils2.inc create mode 100644 axis_utils/include/axis_utils2_r4.fh create mode 100644 axis_utils/include/axis_utils2_r8.fh create mode 100644 fms/include/fms.inc create mode 100644 fms/include/fms_r4.fh create mode 100644 fms/include/fms_r8.fh create mode 100644 horiz_interp/include/horiz_interp.inc create mode 100644 horiz_interp/include/horiz_interp_bicubic.inc create mode 100644 horiz_interp/include/horiz_interp_bicubic_r4.fh create mode 100644 horiz_interp/include/horiz_interp_bicubic_r8.fh create mode 100644 horiz_interp/include/horiz_interp_bilinear.inc create mode 100644 horiz_interp/include/horiz_interp_bilinear_r4.fh create mode 100644 horiz_interp/include/horiz_interp_bilinear_r8.fh create mode 100644 horiz_interp/include/horiz_interp_conserve.inc create mode 100644 horiz_interp/include/horiz_interp_conserve_r4.fh create mode 100644 horiz_interp/include/horiz_interp_conserve_r8.fh create mode 100644 horiz_interp/include/horiz_interp_r4.fh create mode 100644 horiz_interp/include/horiz_interp_r8.fh create mode 100644 horiz_interp/include/horiz_interp_spherical.inc create mode 100644 horiz_interp/include/horiz_interp_spherical_r4.fh create mode 100644 horiz_interp/include/horiz_interp_spherical_r8.fh create mode 100644 horiz_interp/include/horiz_interp_type.inc create mode 100644 horiz_interp/include/horiz_interp_type_r4.fh create mode 100644 horiz_interp/include/horiz_interp_type_r8.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres.inc create mode 100644 sat_vapor_pres/include/sat_vapor_pres_k.inc create mode 100644 sat_vapor_pres/include/sat_vapor_pres_k_r4.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres_k_r8.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres_r4.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres_r8.fh create mode 100644 test_fms/fms/include/test_fms.inc create mode 100644 test_fms/fms/include/test_fms_r4.fh create mode 100644 test_fms/fms/include/test_fms_r8.fh create mode 100644 test_fms/sat_vapor_pres/Makefile.am create mode 100644 test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 create mode 100755 test_fms/sat_vapor_pres/test_sat_vapor_pres.sh diff --git a/CMakeLists.txt b/CMakeLists.txt index 473d8b91f9..cc60d914c2 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -295,12 +295,16 @@ foreach(kind ${kinds}) target_include_directories(${libTgt}_f PRIVATE include fms + fms/include fms2_io/include string_utils/include mpp/include + sat_vapor_pres/include + horiz_interp/include diag_manager/include constants4 - constants) + constants + axis_utils/include) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") @@ -334,7 +338,10 @@ foreach(kind ${kinds}) target_include_directories(${libTgt} PUBLIC $ $ + $ $ + $ + $ $ $ $) diff --git a/axis_utils/Makefile.am b/axis_utils/Makefile.am index 691f9c1f2d..a8f1b3528b 100644 --- a/axis_utils/Makefile.am +++ b/axis_utils/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/axis_utils/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. @@ -31,7 +31,15 @@ noinst_LTLIBRARIES = libaxis_utils.la libaxis_utils_la_SOURCES = \ axis_utils.F90 \ - axis_utils2.F90 + axis_utils2.F90 \ + include/axis_utils2_r4.fh \ + include/axis_utils2_r8.fh \ + include/axis_utils2.inc + +axis_utils2.$(FC_MODEXT) : \ +include/axis_utils2_r4.fh \ +include/axis_utils2_r8.fh \ +include/axis_utils2.inc # Mod file depends on its o file, is built and then installed. nodist_include_HEADERS = axis_utils_mod.$(FC_MODEXT) axis_utils2_mod.$(FC_MODEXT) diff --git a/axis_utils/axis_utils2.F90 b/axis_utils/axis_utils2.F90 index 3086f3b867..bbc7611a77 100644 --- a/axis_utils/axis_utils2.F90 +++ b/axis_utils/axis_utils2.F90 @@ -25,12 +25,12 @@ !> @addtogroup axis_utils2_mod !> @{ module axis_utils2_mod - use mpp_mod, only: mpp_error, FATAL, stdout - use fms_mod, only: lowercase, uppercase, string_array_index, fms_error_handler - use fms2_io_mod, only: FmsNetcdfDomainFile_t, variable_att_exists, FmsNetcdfFile_t, & - get_variable_num_dimensions, get_variable_attribute, & - get_variable_size, read_data, variable_exists - use platform_mod + use mpp_mod, only: mpp_error, FATAL, stdout + use fms_mod, only: lowercase, uppercase, string_array_index, fms_error_handler + use fms2_io_mod, only: FmsNetcdfDomainFile_t, variable_att_exists, FmsNetcdfFile_t, & + get_variable_num_dimensions, get_variable_attribute, & + get_variable_size, read_data, variable_exists + use platform_mod, only: r4_kind, r8_kind implicit none @@ -40,8 +40,9 @@ module axis_utils2_mod private integer, parameter :: maxatts = 100 - real, parameter :: epsln= 1.e-10 - real, parameter :: fp5 = 0.5, f360 = 360.0 + real(r8_kind), parameter :: epsln = 1.e-10_r8_kind + real(r8_kind), parameter :: fp5 = 0.5_r8_kind, f360 = 360.0_r8_kind + !> @} ! Include variable "version" to be written to log file. #include @@ -55,11 +56,44 @@ module axis_utils2_mod !! @param [inout] data2 Interpolated data !! @param method Either "linear" or "cubic_spline" interpolation method, default="linear" !! @ingroup axis_utils2_mod + + interface axis_edges + module procedure axis_edges_r4, axis_edges_r8 + end interface axis_edges + + interface lon_in_range + module procedure lon_in_range_r4, lon_in_range_r8 + end interface lon_in_range + + interface frac_index + module procedure frac_index_r4, frac_index_r8 + end interface frac_index + + interface nearest_index + module procedure nearest_index_r4, nearest_index_r8 + end interface nearest_index + + interface tranlon + module procedure tranlon_r4, tranlon_r8 + end interface tranlon + + interface interp_1d_linear + module procedure interp_1d_linear_r4, interp_1d_linear_r8 + end interface interp_1d_linear + + interface interp_1d_cubic_spline + module procedure interp_1d_cubic_spline_r4, interp_1d_cubic_spline_r8 + end interface interp_1d_cubic_spline + interface interp_1d - module procedure interp_1d_1d - module procedure interp_1d_2d - module procedure interp_1d_3d - end interface + module procedure interp_1d_1d_r4, interp_1d_1d_r8 + module procedure interp_1d_2d_r4, interp_1d_2d_r8 + module procedure interp_1d_3d_r4, interp_1d_3d_r8 + end interface interp_1d + + interface find_index + module procedure find_index_r4, find_index_r8 + end interface find_index !> @addtogroup axis_utils2_mod !> @{ @@ -139,130 +173,6 @@ subroutine get_axis_cart(fileobj, axisname, cart) end if end subroutine get_axis_cart - !> get axis edge data from a given file - subroutine axis_edges(fileobj, name, edge_data, reproduce_null_char_bug_flag) - - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object to read from - character(len=*), intent(in) :: name !< Name of a given axis - class(*), dimension(:), intent(out) :: edge_data !< Returned edge data from given axis name - logical, intent(in), optional :: reproduce_null_char_bug_flag !< Flag indicating to reproduce - !! the mpp_io bug where the null characters were not removed - !! after reading a string attribute - - integer :: ndims - character(len=128) :: buffer - integer, dimension(:), allocatable :: dim_sizes - real(kind=r4_kind), dimension(:), allocatable :: r32 - real(kind=r4_kind), dimension(:,:), allocatable :: r322d - real(kind=r8_kind), dimension(:), allocatable :: r64 - real(kind=r8_kind), dimension(:,:), allocatable :: r642d - integer :: i - integer :: n - logical :: reproduce_null_char_bug !< Local flag indicating to reproduce the mpp_io bug where - !! the null characters were not removed after reading a string attribute - - ndims = get_variable_num_dimensions(fileobj, name) - allocate(dim_sizes(ndims)) - call get_variable_size(fileobj, name, dim_sizes) - n = dim_sizes(1) - if (size(edge_data) .ne. n+1) then - call mpp_error(FATAL, "axis_edge: incorrect size of edge_data array.") - endif - deallocate(dim_sizes) - - reproduce_null_char_bug = .false. - if (present(reproduce_null_char_bug_flag)) reproduce_null_char_bug = reproduce_null_char_bug_flag - - buffer = "" - if (variable_att_exists(fileobj, name, "edges")) then - !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character - call get_variable_attribute(fileobj, name, "edges", buffer(1:128), & - reproduce_null_char_bug_flag=reproduce_null_char_bug) - - !! Check for a null character here, if it exists *_bnds will be calculated instead of read in - if (reproduce_null_char_bug) then - i = 0 - i = index(buffer, char(0)) - if (i > 0) buffer = "" - endif - elseif (variable_att_exists(fileobj, name, "bounds")) then - !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character - call get_variable_attribute(fileobj, name, "bounds", buffer(1:128), & - reproduce_null_char_bug_flag=reproduce_null_char_bug) - - !! Check for a null character here, if it exists *_bnds will be calculated instead of read in - if (reproduce_null_char_bug) then - i = 0 - i = index(buffer, char(0)) - if (i > 0) buffer = "" - endif - endif - if (trim(buffer) .ne. "") then - ndims = get_variable_num_dimensions(fileobj, buffer) - allocate(dim_sizes(ndims)) - call get_variable_size(fileobj, buffer, dim_sizes) - if (size(dim_sizes) .eq. 1) then - if (dim_sizes(1) .ne. n+1) then - call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") - endif - call read_data(fileobj, buffer, edge_data) - elseif (size(dim_sizes) .eq. 2) then - if (dim_sizes(1) .ne. 2) then - call mpp_error(FATAL, "axis_edges: first dimension of edge must be of size 2") - endif - if (dim_sizes(2) .ne. n) then - call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") - endif - select type (edge_data) - type is (real(kind=r4_kind)) - allocate(r322d(dim_sizes(1), dim_sizes(2))) - call read_data(fileobj, buffer, r322d) - edge_data(1:dim_sizes(2)) = r322d(1,:) - edge_data(dim_sizes(2)+1) = r322d(2,dim_sizes(2)) - deallocate(r322d) - type is (real(kind=r8_kind)) - allocate(r642d(dim_sizes(1), dim_sizes(2))) - call read_data(fileobj, buffer, r642d) - edge_data(1:dim_sizes(2)) = r642d(1,:) - edge_data(dim_sizes(2)+1) = r642d(2,dim_sizes(2)) - deallocate(r642d) - class default - call mpp_error(FATAL, "axis_edges: unsupported kind.") - end select - endif - deallocate(dim_sizes) - else - select type (edge_data) - type is (real(kind=r4_kind)) - allocate(r32(n)) - call read_data(fileobj, name, r32) - do i = 2, n - edge_data(i) = r32(i-1) + 0.5_r4_kind*(r32(i) - r32(i-1)) - enddo - edge_data(1) = r32(1) - 0.5_r4_kind*(r32(2) - r32(1)) - if (abs(edge_data(1)) .lt. 1.e-10) then - edge_data(1) = 0._r4_kind - endif - edge_data(n+1) = r32(n) + 0.5_r4_kind*(r32(n) - r32(n-1)) - deallocate(r32) - type is (real(kind=r8_kind)) - allocate(r64(n)) - call read_data(fileobj, name, r64) - do i = 2, n - edge_data(i) = r64(i-1) + 0.5_r8_kind*(r64(i) - r64(i-1)) - enddo - edge_data(1) = r64(1) - 0.5_r8_kind*(r64(2) - r64(1)) - if (abs(edge_data(1)) .lt. 1.d-10) then - edge_data(1) = 0._r8_kind - endif - edge_data(n+1) = r64(n) + 0.5_r8_kind*(r64(n) - r64(n-1)) - deallocate(r64) - class default - call mpp_error(FATAL, "axis_edges: unsupported kind.") - end select - endif -end subroutine axis_edges - !> @brief Checks if 'modulo' variable exists for a given axis. !! !> @return true if modulo variable exists in fileobj for the given axis name. @@ -303,506 +213,8 @@ function get_axis_modulo_times(fileobj, axisname, tbeg, tend) get_axis_modulo_times = found_tbeg end function get_axis_modulo_times - !> @brief Returns lon_strt <= longitude <= lon_strt+360 - !! @return real lon_in_range - function lon_in_range(lon, l_strt) - real, intent(in) :: lon, l_strt - real :: lon_in_range - real :: l_end - - lon_in_range = lon - l_end = l_strt+360. - - if (abs(lon_in_range - l_strt) < 1.e-4) then - lon_in_range = l_strt - return - endif - - if (abs(lon_in_range - l_end) < 1.e-4) then - lon_in_range = l_strt - return - endif - - do - if (lon_in_range < l_strt) then - lon_in_range = lon_in_range + f360 - else if (lon_in_range > l_end) then - lon_in_range = lon_in_range - f360 - else - exit - end if - end do - - end function lon_in_range - - !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360. - !! - !>
The first istrt-1 entries are moved to the end of the array: - !! - !! e.g. - !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - !! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 - subroutine tranlon(lon, lon_start, istrt) - - ! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360. - ! also, the first istrt-1 entries are moved to the end of the array - ! - ! e.g. - ! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - ! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 - - real, intent(inout), dimension(:) :: lon - real, intent(in) :: lon_start - integer, intent(out) :: istrt - - - integer :: len, i - real :: lon_strt, tmp(size(lon(:))-1) - - len = size(lon(:)) - - do i=1,len - lon(i) = lon_in_range(lon(i),lon_start) - enddo - - istrt=0 - do i=1,len-1 - if (lon(i+1) < lon(i)) then - istrt=i+1 - exit - endif - enddo - - if (istrt>1) then ! grid is not monotonic - if (abs(lon(len)-lon(1)) < epsln) then - tmp = cshift(lon(1:len-1),istrt-1) - lon(1:len-1) = tmp - lon(len) = lon(1) - else - lon = cshift(lon,istrt-1) - endif - lon_strt = lon(1) - do i=2,len+1 - lon(i) = lon_in_range(lon(i),lon_strt) - lon_strt = lon(i) - enddo - endif - - return - end subroutine tranlon - - !> nearest_index = index of nearest data point within "array" corresponding to - !! "value". - !! - !! inputs: - !! - !! value = arbitrary data...same units as elements in "array" - !! array = array of data points (must be monotonically increasing) - !! - !! output: - !! - !! nearest_index = index of nearest data point to "value" - !! if "value" is outside the domain of "array" then nearest_index = 1 - !! or "ia" depending on whether array(1) or array(ia) is - !! closest to "value" - !! - !! note: if "array" is dimensioned array(0:ia) in the calling - !! program, then the returned index should be reduced - !! by one to account for the zero base. - !! - !! example: - !! - !! let model depths be defined by the following: - !! parameter (km=5) - !! dimension z(km) - !! data z /5.0, 10.0, 50.0, 100.0, 250.0/ - !! - !! k1 = nearest_index (12.5, z, km) - !! k2 = nearest_index (0.0, z, km) - !! - !! k1 would be set to 2, and k2 would be set to 1 so that - !! z(k1) would be the nearest data point to 12.5 and z(k2) would - !! be the nearest data point to 0.0 - !! - !! @return real frac_index - function frac_index (value, array) - - integer :: ia, i, ii, unit - real :: value !< arbitrary data...same units as elements in "array" - real :: frac_index - real, dimension(:) :: array !< array of data points (must be monotonically increasing) - logical keep_going - - ia = size(array(:)) - - do i=2,ia - if (array(i) < array(i-1)) then - unit = stdout() - write (unit,*) & - '=> Error: "frac_index" array must be monotonically increasing when searching for nearest value to ', value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' - do ii=1,ia - write (unit,*) 'i=',ii, ' array(i)=',array(ii) - enddo - call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.') - endif - enddo - if (value < array(1) .or. value > array(ia)) then -! if (value < array(1)) frac_index = 1. -! if (value > array(ia)) frac_index = float(ia) - frac_index = -1.0 - else - i=1 - keep_going = .true. - do while (i <= ia .and. keep_going) - i = i+1 - if (value <= array(i)) then - frac_index = float(i-1) + (value-array(i-1))/(array(i)-array(i-1)) - keep_going = .false. - endif - enddo - endif - end function frac_index - - !> @brief Return index of nearest point along axis - !! - !> nearest_index = index of nearest data point within "array" corresponding to - !! "value". - !! - !! inputs: - !! - !! value = arbitrary data...same units as elements in "array" - !! array = array of data points (must be monotonically increasing) - !! ia = dimension of "array" - !! - !! output: - !! - !! nearest_index = index of nearest data point to "value" - !! if "value" is outside the domain of "array" then nearest_index = 1 - !! or "ia" depending on whether array(1) or array(ia) is - !! closest to "value" - !! - !! note: if "array" is dimensioned array(0:ia) in the calling - !! program, then the returned index should be reduced - !! by one to account for the zero base. - !! - !! example: - !! - !! let model depths be defined by the following: - !! parameter (km=5) - !! dimension z(km) - !! data z /5.0, 10.0, 50.0, 100.0, 250.0/ - !! - !! k1 = nearest_index (12.5, z, km) - !! k2 = nearest_index (0.0, z, km) - !! - !! k1 would be set to 2, and k2 would be set to 1 so that - !! z(k1) would be the nearest data point to 12.5 and z(k2) would - !! be the nearest data point to 0.0 - !! @return integer nearest_index - function nearest_index (value, array) - - integer :: nearest_index - integer :: ia !< dimension of "array" - integer :: i, ii, unit - real :: value !< arbitrary data...same units as elements in "array" - real, dimension(:) :: array !< array of data points (must be monotonically increasing) - logical keep_going - - ia = size(array(:)) - - do i=2,ia - if (array(i) < array(i-1)) then - unit = stdout() - write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing & - &when searching for nearest value to ',value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' - do ii=1,ia - write (unit,*) 'i=',ii, ' array(i)=',array(ii) - enddo - call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.') - endif - enddo - if (value < array(1) .or. value > array(ia)) then - if (value < array(1)) nearest_index = 1 - if (value > array(ia)) nearest_index = ia - else - i=1 - keep_going = .true. - do while (i <= ia .and. keep_going) - i = i+1 - if (value <= array(i)) then - nearest_index = i - if (array(i)-value > value-array(i-1)) nearest_index = i-1 - keep_going = .false. - endif - enddo - endif - end function nearest_index - - !############################################################################# - - subroutine interp_1d_linear(grid1,grid2,data1,data2) - - real, dimension(:), intent(in) :: grid1, data1, grid2 - real, dimension(:), intent(inout) :: data2 - - integer :: n1, n2, i, n - real :: w - - n1 = size(grid1(:)) - n2 = size(grid2(:)) - - - do i=2,n1 - if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') - enddo - - do i=2,n2 - if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') - enddo - - if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - if (grid1(n1) < grid2(n2) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - - do i=1,n2 - n = nearest_index(grid2(i),grid1) - - if (grid1(n) < grid2(i)) then - w = (grid2(i)-grid1(n))/(grid1(n+1)-grid1(n)) - data2(i) = (1.-w)*data1(n) + w*data1(n+1) - else - if(n==1) then - data2(i) = data1(n) - else - w = (grid2(i)-grid1(n-1))/(grid1(n)-grid1(n-1)) - data2(i) = (1.-w)*data1(n-1) + w*data1(n) - endif - endif - enddo - - - return - - end subroutine interp_1d_linear - - !################################################################### - subroutine interp_1d_cubic_spline(grid1, grid2, data1, data2, yp1, ypn) - - real, dimension(:), intent(in) :: grid1, grid2, data1 - real, dimension(:), intent(inout) :: data2 - real, intent(in) :: yp1, ypn - - real, dimension(size(grid1)) :: y2, u - real :: sig, p, qn, un, h, a ,b - integer :: n, m, i, k, klo, khi - - n = size(grid1(:)) - m = size(grid2(:)) - - do i=2,n - if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') - enddo - - do i=2,m - if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') - enddo - - if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - - if (yp1 >.99e30) then - y2(1)=0. - u(1)=0. - else - y2(1)=-0.5 - u(1)=(3./(grid1(2)-grid1(1)))*((data1(2)-data1(1))/(grid1(2)-grid1(1))-yp1) - endif - - do i=2,n-1 - sig=(grid1(i)-grid1(i-1))/(grid1(i+1)-grid1(i-1)) - p=sig*y2(i-1)+2. - y2(i)=(sig-1.)/p - u(i)=(6.*((data1(i+1)-data1(i))/(grid1(i+1)-grid1(i))-(data1(i)-data1(i-1)) & - /(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p - enddo - - if (ypn > .99e30) then - qn=0. - un=0. - else - qn=0.5 - un=(3./(grid1(n)-grid1(n-1)))*(ypn-(data1(n)-data1(n-1))/(grid1(n)-grid1(n-1))) - endif - - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) - - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - enddo - - do k = 1, m - n = nearest_index(grid2(k),grid1) - if (grid1(n) < grid2(k)) then - klo = n - else - if(n==1) then - klo = n - else - klo = n -1 - endif - endif - khi = klo+1 - h = grid1(khi)-grid1(klo) - a = (grid1(khi) - grid2(k))/h - b = (grid2(k) - grid1(klo))/h - data2(k) = a*data1(klo) + b*data1(khi)+ ((a**3-a)*y2(klo) + (b**3-b)*y2(khi))*(h**2)/6. - enddo - - end subroutine interp_1d_cubic_spline - - !################################################################### - - subroutine interp_1d_1d(grid1,grid2,data1,data2, method, yp1, yp2) - - real, dimension(:), intent(in) :: grid1, data1, grid2 - real, dimension(:), intent(inout) :: data2 - character(len=*), optional, intent(in) :: method - real, optional, intent(in) :: yp1, yp2 - - real :: y1, y2 - character(len=32) :: interp_method - integer :: k2, ks, ke - - k2 = size(grid2(:)) - - interp_method = "linear" - if(present(method)) interp_method = method - y1 = 1.0e30 - if(present(yp1)) y1 = yp1 - y2 = 1.0e30 - if(present(yp2)) y2 = yp2 - call find_index(grid1, grid2(1), grid2(k2), ks, ke) - select case(trim(interp_method)) - case("linear") - call interp_1d_linear(grid1(ks:ke),grid2,data1(ks:ke),data2) - case("cubic_spline") - call interp_1d_cubic_spline(grid1(ks:ke),grid2,data1(ks:ke),data2, y1, y2) - case default - call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") - end select - - return - - end subroutine interp_1d_1d - - !################################################################### - - - subroutine interp_1d_2d(grid1,grid2,data1,data2) - - real, dimension(:,:), intent(in) :: grid1, data1, grid2 - real, dimension(:,:), intent(inout) :: data2 - - integer :: n1, n2, n, k2, ks, ke - - n1 = size(grid1,1) - n2 = size(grid2,1) - k2 = size(grid2,2) - - if (n1 /= n2) call mpp_error(FATAL,'grid size mismatch') - - do n=1,n1 - call find_index(grid1(n,:), grid2(n,1), grid2(n,k2), ks, ke) - call interp_1d_linear(grid1(n,ks:ke),grid2(n,:),data1(n,ks:ke),data2(n,:)) - enddo - - return - - end subroutine interp_1d_2d - - !################################################################### - - subroutine interp_1d_3d(grid1,grid2,data1,data2, method, yp1, yp2) - - real, dimension(:,:,:), intent(in) :: grid1, data1, grid2 - real, dimension(:,:,:), intent(inout) :: data2 - character(len=*), optional, intent(in) :: method - real, optional, intent(in) :: yp1, yp2 - - integer :: n1, n2, m1, m2, k2, n, m - real :: y1, y2 - character(len=32) :: interp_method - integer :: ks, ke - n1 = size(grid1,1) - n2 = size(grid2,1) - m1 = size(grid1,2) - m2 = size(grid2,2) - k2 = size(grid2,3) - - interp_method = "linear" - if(present(method)) interp_method = method - y1 = 1.0e30 - if(present(yp1)) y1 = yp1 - y2 = 1.0e30 - if(present(yp2)) y2 = yp2 - - if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch') - - select case(trim(interp_method)) - case("linear") - do m=1,m1 - do n=1,n1 - call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) - call interp_1d_linear(grid1(n,m,ks:ke),grid2(n,m,:),data1(n,m,ks:ke),data2(n,m,:)) - enddo - enddo - case("cubic_spline") - do m=1,m1 - do n=1,n1 - call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) - call interp_1d_cubic_spline(grid1(n,m,ks:ke),grid2(n,m,:), data1(n,m,ks:ke),data2(n,m,:), y1, y2) - enddo - enddo - case default - call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") - end select - - return - - end subroutine interp_1d_3d - - - !##################################################################### - subroutine find_index(grid1, xs, xe, ks, ke) - real, dimension(:), intent(in) :: grid1 - real, intent(in) :: xs, xe - integer, intent(out) :: ks, ke - - integer :: k, nk - - nk = size(grid1(:)) - - ks = 0; ke = 0 - do k = 1, nk-1 - if(grid1(k) <= xs .and. grid1(k+1) > xs ) then - ks = k - exit - endif - enddo - do k = nk, 2, -1 - if(grid1(k) >= xe .and. grid1(k-1) < xe ) then - ke = k - exit - endif - enddo - - if(ks == 0 ) call mpp_error(FATAL,' xs locate outside of grid1') - if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') - - end subroutine find_index +#include "axis_utils2_r4.fh" +#include "axis_utils2_r8.fh" end module axis_utils2_mod !> @} diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc new file mode 100644 index 0000000000..53707fcf78 --- /dev/null +++ b/axis_utils/include/axis_utils2.inc @@ -0,0 +1,625 @@ + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @defgroup axis_utils2_mod axis_utils2_mod +!> @ingroup axis_utils +!> @brief A set of utilities for manipulating axes and extracting axis attributes. +!! FMS2_IO equivalent version of @ref axis_utils_mod. +!> @author M.J. Harrison + +!> @addtogroup axis_utils2_mod +!> @{ + + !> get axis edge data from a given file + subroutine AXIS_EDGES_(fileobj, name, edge_data, reproduce_null_char_bug_flag) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object to read from + character(len=*), intent(in) :: name !< Name of a given axis + real(FMS_AU_KIND_), dimension(:), intent(out) :: edge_data !< Returned edge data from given axis name + logical, intent(in), optional :: reproduce_null_char_bug_flag !< Flag indicating to reproduce + !! the mpp_io bug where the null characters were not removed + !! after reading a string attribute + + integer :: ndims + character(len=128) :: buffer + integer, dimension(:), allocatable :: dim_sizes + real(kind=FMS_AU_KIND_), dimension(:), allocatable :: r_var + real(kind=FMS_AU_KIND_), dimension(:,:), allocatable :: r2d + integer :: i + integer :: n + logical :: reproduce_null_char_bug !< Local flag + !! indicating to reproduce the mpp_io bug where + !! the null characters were not removed after reading a string attribute + integer, parameter :: lkind = FMS_AU_KIND_ + + ndims = get_variable_num_dimensions(fileobj, name) + allocate(dim_sizes(ndims)) + + call get_variable_size(fileobj, name, dim_sizes) + + n = dim_sizes(1) + if (size(edge_data) .ne. n+1) then + call mpp_error(FATAL, "axis_edge: incorrect size of edge_data array.") + endif + deallocate(dim_sizes) + + reproduce_null_char_bug = .false. + if (present(reproduce_null_char_bug_flag)) reproduce_null_char_bug = reproduce_null_char_bug_flag + + buffer = "" + if (variable_att_exists(fileobj, name, "edges")) then + !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character + call get_variable_attribute(fileobj, name, "edges", buffer(1:128), & + reproduce_null_char_bug_flag=reproduce_null_char_bug) + + !! Check for a null character here, if it exists *_bnds will be calculated instead of read in + if (reproduce_null_char_bug) then + i = 0 + i = index(buffer, char(0)) + if (i > 0) buffer = "" + endif + elseif (variable_att_exists(fileobj, name, "bounds")) then + !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character + call get_variable_attribute(fileobj, name, "bounds", buffer(1:128), & + reproduce_null_char_bug_flag=reproduce_null_char_bug) + + !! Check for a null character here, if it exists *_bnds will be calculated instead of read in + if (reproduce_null_char_bug) then + i = 0 + i = index(buffer, char(0)) + if (i > 0) buffer = "" + endif + endif + if (trim(buffer) .ne. "") then + ndims = get_variable_num_dimensions(fileobj, buffer) + allocate(dim_sizes(ndims)) + + call get_variable_size(fileobj, buffer, dim_sizes) + + if (size(dim_sizes) .eq. 1) then + if (dim_sizes(1) .ne. n+1) then + call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") + endif + + call read_data(fileobj, buffer, edge_data) + + elseif (size(dim_sizes) .eq. 2) then + if (dim_sizes(1) .ne. 2) then + call mpp_error(FATAL, "axis_edges: first dimension of edge must be of size 2") + endif + if (dim_sizes(2) .ne. n) then + call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") + endif + + allocate(r2d(dim_sizes(1), dim_sizes(2))) + call read_data(fileobj, buffer, r2d) + edge_data(1:dim_sizes(2)) = r2d(1,:) + edge_data(dim_sizes(2)+1) = r2d(2,dim_sizes(2)) + deallocate(r2d) + endif + deallocate(dim_sizes) + else + allocate(r_var(n)) + + call read_data(fileobj, name, r_var) + + do i = 2, n + edge_data(i) = r_var(i-1) + 0.5_lkind*(r_var(i) - r_var(i-1)) + enddo + edge_data(1) = r_var(1) - 0.5_lkind*(r_var(2) - r_var(1)) + if (abs(edge_data(1)) .lt. 1.e-10_lkind) then + edge_data(1) = 0.0_lkind + endif + edge_data(n+1) = r_var(n) + 0.5_lkind*(r_var(n) - r_var(n-1)) + deallocate(r_var) + endif + end subroutine AXIS_EDGES_ + + !> @brief Returns lon_strt <= longitude <= lon_strt+360 + !! @return real lon_in_range */ + + function LON_IN_RANGE_(lon, l_strt) + real(kind=FMS_AU_KIND_), intent(in) :: lon, l_strt + real(kind=FMS_AU_KIND_) :: LON_IN_RANGE_ + real(kind=FMS_AU_KIND_) :: l_end + integer, parameter :: lkind = FMS_AU_KIND_ + + LON_IN_RANGE_ = lon + l_end = l_strt + 360.0_lkind + + if (abs(LON_IN_RANGE_ - l_strt) < 1.e-4_lkind) then + LON_IN_RANGE_ = l_strt + return + endif + + if (abs(LON_IN_RANGE_ - l_end) < 1.e-4_lkind) then + LON_IN_RANGE_ = l_strt + return + endif + + do + if (LON_IN_RANGE_ < l_strt) then + LON_IN_RANGE_ = real(LON_IN_RANGE_, FMS_AU_KIND_) + real(f360, FMS_AU_KIND_) + else if (LON_IN_RANGE_ > l_end) then + LON_IN_RANGE_ = real(LON_IN_RANGE_, FMS_AU_KIND_) - real(f360, FMS_AU_KIND_) + else + exit + end if + end do + + end function LON_IN_RANGE_ + + !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360. + !! + !>
The first istrt-1 entries are moved to the end of the array: + !! + !! e.g. + !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> + !! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + + subroutine TRANLON_(lon, lon_start, istrt) + + ! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360. + ! also, the first istrt-1 entries are moved to the end of the array + ! + ! e.g. + ! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> + ! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + + real(kind=FMS_AU_KIND_), intent(inout), dimension(:) :: lon + real(kind=FMS_AU_KIND_), intent(in) :: lon_start + integer, intent(out) :: istrt + + + integer :: len, i + real(kind=FMS_AU_KIND_) :: lon_strt, tmp(size(lon(:))-1) + + len = size(lon(:)) + + do i = 1, len + lon(i) = lon_in_range(lon(i),lon_start) + enddo + + istrt = 0 + do i = 1,len-1 + if (lon(i+1) < lon(i)) then + istrt = i+1 + exit + endif + enddo + + if (istrt>1) then ! grid is not monotonic + if (abs(lon(len)-lon(1)) < real(epsln, FMS_AU_KIND_)) then + tmp = cshift(lon(1:len-1),istrt-1) + lon(1:len-1) = tmp + lon(len) = lon(1) + else + lon = cshift(lon,istrt-1) + endif + + lon_strt = lon(1) + do i=2,len+1 + lon(i) = lon_in_range(lon(i),lon_strt) + lon_strt = lon(i) + enddo + endif + + return + end subroutine TRANLON_ + + + function FRAC_INDEX_(value, array) + + integer :: ia, i, ii, unit + real(kind=FMS_AU_KIND_) :: value !< arbitrary data...same units as elements in "array" + real(kind=FMS_AU_KIND_) :: FRAC_INDEX_ + real(kind=FMS_AU_KIND_), dimension(:) :: array !< array of data points (must be monotonically increasing) + logical :: keep_going + integer, parameter :: lkind = FMS_AU_KIND_ + ia = size(array(:)) + + do i = 2, ia + if (array(i) < array(i-1)) then + unit = stdout() + write (unit,*) '=> Error: "frac_index" array must be monotonically' & + & // 'increasing when searching for nearest value to ', value + write (unit,*) ' array(i) < array(i-1) for i=',i + write (unit,*) ' array(i) for i=1..ia follows:' + do ii = 1, ia + write (unit,*) 'i=',ii, ' array(i)=',array(ii) + enddo + call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.') + endif + enddo + + if (value < array(1) .or. value > array(ia)) then + ! if (value < array(1)) frac_index = 1. + ! if (value > array(ia)) frac_index = float(ia) + FRAC_INDEX_ = -1.0_lkind + else + i = 1 + keep_going = .true. + do while (i <= ia .and. keep_going) + i = i+1 + if (value <= array(i)) then + FRAC_INDEX_ = real((i-1), lkind) + (value-array(i-1)) / (array(i) - array(i-1)) + keep_going = .false. + endif + enddo + endif + end function FRAC_INDEX_ + + !> @brief Return index of nearest point along axis + !! + !> nearest_index = index of nearest data point within "array" corresponding to + !! "value". + !! + !! inputs: + !! + !! value = arbitrary data...same units as elements in "array" + !! array = array of data points (must be monotonically increasing) + !! ia = dimension of "array" + !! + !! output: + !! + !! nearest_index = index of nearest data point to "value" + !! if "value" is outside the domain of "array" then nearest_index = 1 + !! or "ia" depending on whether array(1) or array(ia) is + !! closest to "value" + !! + !! note: if "array" is dimensioned array(0:ia) in the calling + !! program, then the returned index should be reduced + !! by one to account for the zero base. + !! + !! example: + !! + !! let model depths be defined by the following: + !! parameter (km=5) + !! dimension z(km) + !! data z /5.0, 10.0, 50.0, 100.0, 250.0/ + !! + !! k1 = nearest_index (12.5, z, km) + !! k2 = nearest_index (0.0, z, km) + !! + !! k1 would be set to 2, and k2 would be set to 1 so that + !! z(k1) would be the nearest data point to 12.5 and z(k2) would + !! be the nearest data point to 0.0 + !! @return integer nearest_index + + + + function NEAREST_INDEX_(value, array) + + integer :: NEAREST_INDEX_ + integer :: ia !< dimension of "array" + integer :: i, ii, unit + real(kind=FMS_AU_KIND_) :: value !< arbitrary data...same units as elements in "array" + real(kind=FMS_AU_KIND_), dimension(:) :: array !< array of data points (must be monotonically increasing) + logical :: keep_going + + ia = size(array(:)) + + do i = 2, ia + if (array(i) < array(i-1)) then + unit = stdout() + write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing' & + & // 'when searching for nearest value to ', value + write (unit,*) ' array(i) < array(i-1) for i=',i + write (unit,*) ' array(i) for i=1..ia follows:' + do ii = 1, ia + write (unit,*) 'i=',ii, ' array(i)=', array(ii) + enddo + call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.') + endif + enddo + + if (value < array(1) .or. value > array(ia)) then + if (value < array(1)) NEAREST_INDEX_ = 1 + if (value > array(ia)) NEAREST_INDEX_ = ia + else + i = 1 + keep_going = .true. + do while (i <= ia .and. keep_going) + i = i+1 + if (value <= array(i)) then + NEAREST_INDEX_ = i + if (array(i)-value > value-array(i-1)) NEAREST_INDEX_ = i-1 + keep_going = .false. + endif + enddo + endif + end function NEAREST_INDEX_ + + !############################################################################# + + subroutine INTERP_1D_LINEAR_(grid1,grid2,data1,data2) + + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1, data1, grid2 + real(kind=FMS_AU_KIND_), dimension(:), intent(inout) :: data2 + + integer :: n1, n2, i, n + real(kind=FMS_AU_KIND_) :: w + integer, parameter :: lkind = FMS_AU_KIND_ + + n1 = size(grid1(:)) + n2 = size(grid2(:)) + + + do i = 2, n1 + if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') + enddo + + do i = 2, n2 + if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') + enddo + + if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + if (grid1(n1) < grid2(n2) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + + do i = 1, n2 + n = nearest_index(grid2(i),grid1) + + if (grid1(n) < grid2(i)) then + w = (grid2(i)-grid1(n))/(grid1(n+1)-grid1(n)) + data2(i) = (1.0_lkind-w)*data1(n) + w*data1(n+1) + else + if(n==1) then + data2(i) = data1(n) + else + w = (grid2(i)-grid1(n-1))/(grid1(n)-grid1(n-1)) + data2(i) = (1.0_lkind-w)*data1(n-1) + w*data1(n) + endif + endif + enddo + + + return + + end subroutine INTERP_1D_LINEAR_ + + !################################################################### + subroutine INTERP_1D_CUBIC_SPLINE_(grid1, grid2, data1, data2, yp1, ypn) + + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1, grid2, data1 + real(kind=FMS_AU_KIND_), dimension(:), intent(inout) :: data2 + real(kind=FMS_AU_KIND_), intent(in) :: yp1, ypn + + real(kind=FMS_AU_KIND_), dimension(size(grid1)) :: y2, u + real(kind=FMS_AU_KIND_) :: sig, p, qn, un, h, a ,b + integer :: n, m, i, k, klo, khi + integer, parameter :: lkind = FMS_AU_KIND_ + + n = size(grid1(:)) + m = size(grid2(:)) + + do i = 2, n + if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') + enddo + + do i = 2, m + if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') + enddo + + if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + +if (yp1>0.99e30_lkind) then + y2(1) = 0.0_lkind + u(1) = 0.0_lkind + else + y2(1) = -0.5_lkind + u(1) = (3.0_lkind)/(grid1(2)-grid1(1))*((data1(2)-data1(1))/(grid1(2)-grid1(1))-yp1) + endif + + do i = 2, n-1 + sig = (grid1(i)-grid1(i-1))/(grid1(i+1)-grid1(i-1)) + p = sig*y2(i-1) + 2.0_lkind + y2(i) = (sig-1.0_lkind)/p + u(i) = (6.0_lkind*((data1(i+1)-data1(i))/(grid1(i+1)-grid1(i))-(data1(i)-data1(i-1)) & + /(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p + enddo + + if (ypn>0.99e30_lkind) then + qn = 0.0_lkind + un = 0.0_lkind + else + qn = 0.5_lkind + un = (3.0_lkind)/(grid1(n)-grid1(n-1))*(ypn-(data1(n)-data1(n-1))/ & + (grid1(n)-grid1(n-1))) + endif + + y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.0_lkind) + + do k = n-1,1,-1 + y2(k) = y2(k)*y2(k+1)+u(k) + enddo + + do k = 1, m + n = nearest_index(grid2(k),grid1) + if (grid1(n) < grid2(k)) then + klo = n + else + if(n==1) then + klo = n + else + klo = n -1 + endif + endif + + khi = klo+1 + h = grid1(khi)-grid1(klo) + a = (grid1(khi) - grid2(k))/h + b = (grid2(k) - grid1(klo))/h + data2(k) = a*data1(klo) + b*data1(khi)+ ((a**3-a)*y2(klo) + (b**3-b)*y2(khi))*(h**2) & + /6.0_lkind + enddo + + end subroutine INTERP_1D_CUBIC_SPLINE_ + + !################################################################### + + subroutine INTERP_1D_1D_(grid1,grid2,data1,data2, method, yp1, yp2) + + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1, data1, grid2 + real(kind=FMS_AU_KIND_), dimension(:), intent(inout) :: data2 + character(len=*), optional, intent(in) :: method + real(kind=FMS_AU_KIND_), optional, intent(in) :: yp1, yp2 + + real(kind=FMS_AU_KIND_) :: y1, y2 + character(len=32) :: interp_method + integer :: k2, ks, ke + integer, parameter :: lkind = FMS_AU_KIND_ + + k2 = size(grid2(:)) + + interp_method = "linear" + if(present(method)) interp_method = method + y1 = 1.0e30_lkind + + if(present(yp1)) y1 = yp1 + y2 = 1.0e30_lkind + + if(present(yp2)) y2 = yp2 + call find_index(grid1, grid2(1), grid2(k2), ks, ke) + select case(trim(interp_method)) + case("linear") + call interp_1d_linear(grid1(ks:ke),grid2,data1(ks:ke),data2) + case("cubic_spline") + call interp_1d_cubic_spline(grid1(ks:ke),grid2,data1(ks:ke),data2, y1, y2) + case default + call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") + end select + + return + + end subroutine INTERP_1D_1D_ + + !################################################################### + + + subroutine INTERP_1D_2D_(grid1,grid2,data1,data2) + + real(kind=FMS_AU_KIND_), dimension(:,:), intent(in) :: grid1, data1, grid2 + real(kind=FMS_AU_KIND_), dimension(:,:), intent(inout) :: data2 + + integer :: n1, n2, n, k2, ks, ke + + n1 = size(grid1,1) + n2 = size(grid2,1) + k2 = size(grid2,2) + + if (n1 /= n2) call mpp_error(FATAL,'grid size mismatch') + + do n = 1, n1 + call find_index(grid1(n,:), grid2(n,1), grid2(n,k2), ks, ke) + call interp_1d_linear(grid1(n,ks:ke),grid2(n,:),data1(n,ks:ke),data2(n,:)) + enddo + + return + + end subroutine INTERP_1D_2D_ + + !################################################################### + + subroutine INTERP_1D_3D_(grid1,grid2,data1,data2, method, yp1, yp2) + + real(FMS_AU_KIND_), dimension(:,:,:), intent(in) :: grid1, data1, grid2 + real(FMS_AU_KIND_), dimension(:,:,:), intent(inout) :: data2 + character(len=*), optional, intent(in) :: method + real(kind=FMS_AU_KIND_), optional, intent(in) :: yp1, yp2 + + integer :: n1, n2, m1, m2, k2, n, m + real(kind=FMS_AU_KIND_) :: y1, y2 + character(len=32) :: interp_method + integer :: ks, ke + integer, parameter :: lkind = FMS_AU_KIND_ + + n1 = size(grid1,1) + n2 = size(grid2,1) + m1 = size(grid1,2) + m2 = size(grid2,2) + k2 = size(grid2,3) + + interp_method = "linear" + if(present(method)) interp_method = method + y1 = 1.0e30_lkind + + if(present(yp1)) y1 = yp1 + y2 = 1.0e30_lkind + if(present(yp2)) y2 = yp2 + + if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch') + + select case(trim(interp_method)) + case("linear") + do m = 1, m1 + do n = 1, n1 + call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) + call interp_1d_linear(grid1(n,m,ks:ke),grid2(n,m,:),data1(n,m,ks:ke),data2(n,m,:)) + enddo + enddo + + case("cubic_spline") + do m = 1, m1 + do n = 1, n1 + call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) + call interp_1d_cubic_spline(grid1(n,m,ks:ke),grid2(n,m,:), data1(n,m,ks:ke),data2(n,m,:), y1, y2) + enddo + enddo + + case default + call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") + end select + + return + + end subroutine INTERP_1D_3D_ + + + !##################################################################### + subroutine FIND_INDEX_(grid1, xs, xe, ks, ke) + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1 + real(kind=FMS_AU_KIND_), intent(in) :: xs, xe + integer, intent(out) :: ks, ke + + integer :: k, nk + + nk = size(grid1(:)) + + ks = 0; ke = 0 + do k = 1, nk-1 + if(grid1(k) <= xs .and. grid1(k+1) > xs ) then + ks = k + exit + endif + enddo + + do k = nk, 2, -1 + if(grid1(k) >= xe .and. grid1(k-1) < xe ) then + ke = k + exit + endif + enddo + + if(ks == 0 ) call mpp_error(FATAL,' xs locate outside of grid1') + if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') + + end subroutine FIND_INDEX_ + !> @} + ! close documentation grouping diff --git a/axis_utils/include/axis_utils2_r4.fh b/axis_utils/include/axis_utils2_r4.fh new file mode 100644 index 0000000000..b7eb3337c0 --- /dev/null +++ b/axis_utils/include/axis_utils2_r4.fh @@ -0,0 +1,67 @@ +! -*-f90-*- + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!> @brief Imports checksum, gather, and scatter routines from other include files used +!! for communications and calculations between PE's in @ref mpp_mod + +!> @addtogroup mpp_mod +!> @{ + +#undef FMS_AU_KIND_ +#define FMS_AU_KIND_ r4_kind + +#undef AXIS_EDGES_ +#define AXIS_EDGES_ axis_edges_r4 + +#undef LON_IN_RANGE_ +#define LON_IN_RANGE_ lon_in_range_r4 + +#undef FRAC_INDEX_ +#define FRAC_INDEX_ frac_index_r4 + +#undef NEAREST_INDEX_ +#define NEAREST_INDEX_ nearest_index_r4 + +#undef TRANLON_ +#define TRANLON_ tranlon_r4 + +#undef INTERP_1D_LINEAR_ +#define INTERP_1D_LINEAR_ interp_1d_linear_r4 + +#undef INTERP_1D_CUBIC_SPLINE_ +#define INTERP_1D_CUBIC_SPLINE_ interp_1d_cubic_spline_r4 + +#undef INTERP_1D_1D_ +#define INTERP_1D_1D_ interp_1d_1d_r4 + +#undef INTERP_1D_2D_ +#define INTERP_1D_2D_ interp_1d_2d_r4 + +#undef INTERP_1D_3D_ +#define INTERP_1D_3D_ interp_1d_3d_r4 + +#undef FIND_INDEX_ +#define FIND_INDEX_ find_index_r4 + +#include "axis_utils2.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/axis_utils/include/axis_utils2_r8.fh b/axis_utils/include/axis_utils2_r8.fh new file mode 100644 index 0000000000..ac6c176996 --- /dev/null +++ b/axis_utils/include/axis_utils2_r8.fh @@ -0,0 +1,67 @@ +! -*-f90-*- + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!> @brief Imports checksum, gather, and scatter routines from other include files used +!! for communications and calculations between PE's in @ref mpp_mod + +!> @addtogroup mpp_mod +!> @{ + +#undef FMS_AU_KIND_ +#define FMS_AU_KIND_ r8_kind + +#undef AXIS_EDGES_ +#define AXIS_EDGES_ axis_edges_r8 + +#undef LON_IN_RANGE_ +#define LON_IN_RANGE_ lon_in_range_r8 + +#undef FRAC_INDEX_ +#define FRAC_INDEX_ frac_index_r8 + +#undef NEAREST_INDEX_ +#define NEAREST_INDEX_ nearest_index_r8 + +#undef TRANLON_ +#define TRANLON_ tranlon_r8 + +#undef INTERP_1D_LINEAR_ +#define INTERP_1D_LINEAR_ interp_1d_linear_r8 + +#undef INTERP_1D_CUBIC_SPLINE_ +#define INTERP_1D_CUBIC_SPLINE_ interp_1d_cubic_spline_r8 + +#undef INTERP_1D_1D_ +#define INTERP_1D_1D_ interp_1d_1d_r8 + +#undef INTERP_1D_2D_ +#define INTERP_1D_2D_ interp_1d_2d_r8 + +#undef INTERP_1D_3D_ +#define INTERP_1D_3D_ interp_1d_3d_r8 + +#undef FIND_INDEX_ +#define FIND_INDEX_ find_index_r8 + +#include "axis_utils2.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/configure.ac b/configure.ac index 799fa4ba48..241e08d079 100644 --- a/configure.ac +++ b/configure.ac @@ -480,6 +480,7 @@ AC_CONFIG_FILES([ test_fms/coupler/Makefile test_fms/parser/Makefile test_fms/string_utils/Makefile + test_fms/sat_vapor_pres/Makefile FMS.pc ]) diff --git a/fms/Makefile.am b/fms/Makefile.am index ea443f17e6..8f8c58525b 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/fms/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -32,6 +32,9 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ fms.F90 \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh \ fms_io.F90 \ fms_io_unstructured_field_exist.inc \ fms_io_unstructured_get_file_name.inc \ @@ -47,7 +50,12 @@ libfms_la_SOURCES = \ fms_io_unstructured_save_restart.inc \ read_data_3d.inc -fms_mod.$(FC_MODEXT): fms_io_mod.$(FC_MODEXT) +fms_mod.$(FC_MODEXT): fms_io_mod.$(FC_MODEXT) \ + fms.F90 \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh + fms_io_mod.$(FC_MODEXT): fms_io_unstructured_field_exist.inc \ fms_io_unstructured_get_file_name.inc \ fms_io_unstructured_register_restart_axis.inc \ diff --git a/fms/fms.F90 b/fms/fms.F90 index e37139a056..7067b86aee 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -96,7 +96,7 @@ module fms_mod ! ! uppercase Convert character strings to all upper case ! -! monotonic_array Determines if the real input array has +! monotonic_array Determines if the real input array has strictly ! monotonically increasing or decreasing values. ! ! string_array_index Match the input character string to a string @@ -162,6 +162,7 @@ module fms_mod use memutils_mod, only: print_memuse_stats, memutils_init use grid2_mod, only: grid_init, grid_end use fms_string_utils_mod, only: fms_c2f_string, fms_cstring2cpointer, string +use platform_mod, only: r4_kind, r8_kind use, intrinsic :: iso_c_binding @@ -214,6 +215,10 @@ module fms_mod ! public mpp-io interfaces public :: do_cf_compliance +interface monotonic_array + module procedure :: monotonic_array_r4, monotonic_array_r8 +end interface monotonic_array + !Balaji !this is published by fms and applied to any initialized clocks !of course you can go and set the flag to SYNC or DETAILED by hand @@ -720,51 +725,6 @@ function string_array_index ( string, string_array, index ) result (found) end function string_array_index -!####################################################################### - -!> @brief Determines if a real input array has monotonically increasing or -!! decreasing values. -!! @return If the input array of real values either increases or decreases monotonically then true -!! is returned, otherwise false is returned. -function monotonic_array ( array, direction ) -real, intent(in) :: array(:) !< An array of real values. If the size(array) < 2 this function - !! assumes the array is not monotonic, no fatal error will occur. -integer, intent(out), optional :: direction !< If the input array is: - !! >> monotonic (small to large) then direction = +1. - !! >> monotonic (large to small) then direction = -1. - !! >> not monotonic then direction = 0. -logical :: monotonic_array !< If the input array of real values either increases or decreases monotonically - !! then TRUE is returned, otherwise FALSE is returned. -integer :: i - -! initialize - monotonic_array = .false. - if (present(direction)) direction = 0 - -! array too short - if ( size(array(:)) < 2 ) return - -! ascending - if ( array(1) < array(size(array(:))) ) then - do i = 2, size(array(:)) - if (array(i-1) < array(i)) cycle - return - enddo - monotonic_array = .true. - if (present(direction)) direction = +1 - -! descending - else - do i = 2, size(array(:)) - if (array(i-1) > array(i)) cycle - return - enddo - monotonic_array = .true. - if (present(direction)) direction = -1 - endif - -end function monotonic_array - !####################################################################### !> @brief Prints to the log file (or a specified unit) the version id string and !! tag name. @@ -794,6 +754,9 @@ subroutine write_version_number (version, tag, unit) end subroutine write_version_number +#include "fms_r4.fh" +#include "fms_r8.fh" + end module fms_mod ! ! diff --git a/fms/include/fms.inc b/fms/include/fms.inc new file mode 100644 index 0000000000..960a529ced --- /dev/null +++ b/fms/include/fms.inc @@ -0,0 +1,64 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief Determines if a real input array has values which increase or +!! decrease with strict monotonicity. +!! @return If the input array of real values either increases or decreases in a strictly monotonic manner, +!! then true is returned. Otherwise, false is returned. + +function MONOTONIC_ARRAY_(array, direction) result(ret) +real(FMS_MOD_KIND_), intent(in) :: array(:) !< An array of real values. If size(array) < 2, this function + !! assumes the array is not monotonic; no fatal error will occur + !! in this case. +integer, intent(out), optional :: direction !< If the input array is: + !! >> strictly monotonic (small to large), then direction = +1. + !! >> strictly monotonic (large to small), then direction = -1. + !! >> not strictly monotonic, then direction = 0. +logical :: ret !< If the input array of real values either increases or + !! decreases with strict monotonicity, then TRUE is returned; + !! otherwise, FALSE is returned. +integer :: i + +! initialize + ret = .false. + if (present(direction)) direction = 0 + +! array too short + if ( size(array(:)) < 2 ) return + +! ascending + if ( array(1) < array(size(array(:))) ) then + do i = 2, size(array(:)) + if (array(i-1) < array(i)) cycle + return + enddo + ret = .true. + if (present(direction)) direction = +1 + +! descending + else + do i = 2, size(array(:)) + if (array(i-1) > array(i)) cycle + return + enddo + ret = .true. + if (present(direction)) direction = -1 + endif + +end function diff --git a/fms/include/fms_r4.fh b/fms/include/fms_r4.fh new file mode 100644 index 0000000000..1347478c4b --- /dev/null +++ b/fms/include/fms_r4.fh @@ -0,0 +1,8 @@ +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ + +#define FMS_MOD_KIND_ r4_kind +#define MONOTONIC_ARRAY_ monotonic_array_r4 +#include "fms.inc" +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ diff --git a/fms/include/fms_r8.fh b/fms/include/fms_r8.fh new file mode 100644 index 0000000000..37cd103093 --- /dev/null +++ b/fms/include/fms_r8.fh @@ -0,0 +1,8 @@ +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ + +#define FMS_MOD_KIND_ r8_kind +#define MONOTONIC_ARRAY_ monotonic_array_r8 +#include "fms.inc" +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ diff --git a/horiz_interp/Makefile.am b/horiz_interp/Makefile.am index ead18ecbb2..55f8f1cbbd 100644 --- a/horiz_interp/Makefile.am +++ b/horiz_interp/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/horiz_interp/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -36,7 +36,25 @@ libhoriz_interp_la_SOURCES = \ horiz_interp_conserve.F90 \ horiz_interp.F90 \ horiz_interp_spherical.F90 \ - horiz_interp_type.F90 + horiz_interp_type.F90 \ + include/horiz_interp_bicubic.inc \ + include/horiz_interp_bilinear.inc \ + include/horiz_interp_conserve.inc \ + include/horiz_interp.inc \ + include/horiz_interp_spherical.inc \ + include/horiz_interp_type.inc \ + include/horiz_interp_bicubic_r4.fh \ + include/horiz_interp_bilinear_r4.fh \ + include/horiz_interp_conserve_r4.fh \ + include/horiz_interp_r4.fh \ + include/horiz_interp_spherical_r4.fh \ + include/horiz_interp_type_r4.fh \ + include/horiz_interp_bicubic_r8.fh \ + include/horiz_interp_bilinear_r8.fh \ + include/horiz_interp_conserve_r8.fh \ + include/horiz_interp_r8.fh \ + include/horiz_interp_spherical_r8.fh \ + include/horiz_interp_type_r8.fh # Some mods are dependant on other mods in this dir. horiz_interp_bicubic_mod.$(FC_MODEXT): horiz_interp_type_mod.$(FC_MODEXT) diff --git a/horiz_interp/horiz_interp.F90 b/horiz_interp/horiz_interp.F90 index 9d694f4d21..5b29559f3d 100644 --- a/horiz_interp/horiz_interp.F90 +++ b/horiz_interp/horiz_interp.F90 @@ -58,6 +58,7 @@ module horiz_interp_mod use horiz_interp_bicubic_mod, only: horiz_interp_bicubic_new, horiz_interp_bicubic_del use horiz_interp_spherical_mod, only: horiz_interp_spherical_init, horiz_interp_spherical use horiz_interp_spherical_mod, only: horiz_interp_spherical_new, horiz_interp_spherical_del +use platform_mod, only: r4_kind, r8_kind implicit none private @@ -122,10 +123,18 @@ module horiz_interp_mod !! interpolations. To reinitialize this variable for a different grid-to-grid !! interpolation you must first use the "horiz_interp_del" interface. interface horiz_interp_new - module procedure horiz_interp_new_1d ! Source grid is 1d, destination grid is 1d - module procedure horiz_interp_new_1d_src ! Source grid is 1d, destination grid is 2d - module procedure horiz_interp_new_2d ! Source grid is 2d, destination grid is 2d - module procedure horiz_interp_new_1d_dst ! Source grid is 2d, destination grid is 1d + ! Source grid is 1d, destination grid is 1d + module procedure horiz_interp_new_1d_r4 + module procedure horiz_interp_new_1d_r8 + ! Source grid is 1d, destination grid is 2d + module procedure horiz_interp_new_1d_src_r4 + module procedure horiz_interp_new_1d_src_r8 + ! Source grid is 2d, destination grid is 2d + module procedure horiz_interp_new_2d_r4 + module procedure horiz_interp_new_2d_r8 + ! Source grid is 2d, destination grid is 1d + module procedure horiz_interp_new_1d_dst_r4 + module procedure horiz_interp_new_1d_dst_r8 end interface @@ -186,15 +195,33 @@ module horiz_interp_mod !! sure you have the correct grid size. !> @ingroup horiz_interp_mod interface horiz_interp - module procedure horiz_interp_base_2d - module procedure horiz_interp_base_3d - module procedure horiz_interp_solo_1d - module procedure horiz_interp_solo_1d_src - module procedure horiz_interp_solo_2d - module procedure horiz_interp_solo_1d_dst - module procedure horiz_interp_solo_old + module procedure horiz_interp_base_2d_r4 + module procedure horiz_interp_base_2d_r8 + module procedure horiz_interp_base_3d_r4 + module procedure horiz_interp_base_3d_r8 + module procedure horiz_interp_solo_1d_r4 + module procedure horiz_interp_solo_1d_r8 + module procedure horiz_interp_solo_1d_src_r4 + module procedure horiz_interp_solo_1d_src_r8 + module procedure horiz_interp_solo_2d_r4 + module procedure horiz_interp_solo_2d_r8 + module procedure horiz_interp_solo_1d_dst_r4 + module procedure horiz_interp_solo_1d_dst_r8 + module procedure horiz_interp_solo_old_r4 + module procedure horiz_interp_solo_old_r8 end interface +!> Private helper routines +interface is_lat_lon + module procedure is_lat_lon_r4 + module procedure is_lat_lon_r8 +end interface + +interface horiz_interp_solo_1d + module procedure horiz_interp_solo_1d_r4 + module procedure horiz_interp_solo_1d_r8 +end interface + !> @addtogroup horiz_interp_mod !> @{ @@ -247,778 +274,6 @@ subroutine horiz_interp_init end subroutine horiz_interp_init -!####################################################################### - - !> @brief Creates a 1D @ref horiz_interp_type with the given parameters - subroutine horiz_interp_new_1d (Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - grid_at_center, mask_in, mask_out) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center - real, intent(in), dimension(:,:), optional :: mask_in !< dummy variable - real, intent(inout),dimension(:,:), optional :: mask_out !< dummy variable - !----------------------------------------------------------------------- - real, dimension(:,:), allocatable :: lon_src, lat_src, lon_dst, lat_dst - real, dimension(:), allocatable :: lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d - integer :: i, j, nlon_in, nlat_in, nlon_out, nlat_out - logical :: center - character(len=40) :: method - !----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) - case ("bilinear") - Interp%interp_method = BILINEAR - center = .false. - if(present(grid_at_center) ) center = grid_at_center - if(center) then - nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_out - lon_dst(i,:) = lon_out(i) - enddo - do j = 1, nlat_out - lat_dst(:,j) = lat_out(j) - enddo - - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & - verbose, src_modulo) - deallocate(lon_dst, lat_dst) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - do i = 1, nlon_out - lon_dst(i,:) = (lon_out(i) + lon_out(i+1)) * 0.5 - enddo - do j = 1, nlat_out - lat_dst(:,j) = (lat_out(j) + lat_out(j+1)) * 0.5 - enddo - call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_dst, lat_dst, & - verbose, src_modulo) - deallocate(lon_src_1d, lat_src_1d, lon_dst, lat_dst) - endif - case ("bicubic") - Interp%interp_method = BICUBIC - center = .false. - if(present(grid_at_center) ) center = grid_at_center - !No need to expand to 2d, horiz_interp_bicubic_new does 1d-1d - if(center) then - call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - allocate(lon_dst_1d(nlon_out), lat_dst_1d(nlat_out)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - do i = 1, nlon_out - lon_dst_1d(i) = (lon_out(i) + lon_out(i+1)) * 0.5 - enddo - do j = 1, nlat_out - lat_dst_1d(j) = (lat_out(j) + lat_out(j+1)) * 0.5 - enddo - call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d, & - verbose, src_modulo) - deallocate(lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d) - endif - case ("spherical") - Interp%interp_method = SPHERICA - nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) - nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) - allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_in - lon_src(i,:) = lon_in(i) - enddo - do j = 1, nlat_in - lat_src(:,j) = lat_in(j) - enddo - do i = 1, nlon_out - lon_dst(i,:) = lon_out(i) - enddo - do j = 1, nlat_out - lat_dst(:,j) = lat_out(j) - enddo - call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_dst, lat_dst, & - num_nbrs, max_dist, src_modulo) - deallocate(lon_src, lat_src, lon_dst, lat_dst) - case default - call mpp_error(FATAL,'horiz_interp_mod: interp_method should be conservative, bilinear, bicubic, spherical') - end select - - !----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_1d - -!####################################################################### - - subroutine horiz_interp_new_1d_src (Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, interp_method, num_nbrs, max_dist, & - src_modulo, grid_at_center, mask_in, mask_out, is_latlon_out ) - - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs !< minimum number of neighbors - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out),dimension(:,:), optional :: mask_out - logical, intent(in), optional :: is_latlon_out - - real, dimension(:,:), allocatable :: lon_src, lat_src - real, dimension(:), allocatable :: lon_src_1d, lat_src_1d - integer :: i, j, nlon_in, nlat_in - character(len=40) :: method - logical :: center - logical :: dst_is_latlon - !----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - !--- check to see if the source grid is regular lat-lon grid or not. - if(PRESENT(is_latlon_out)) then - dst_is_latlon = is_latlon_out - else - dst_is_latlon = is_lat_lon(lon_out, lat_out) - end if - if(dst_is_latlon ) then - if(present(mask_in)) then - if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1d_src(horiz_interp_conserve_mod): input mask not between 0,1') - allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) ) - Interp%mask_in = mask_in - end if - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & - verbose=verbose ) - else - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - end if - case ("bilinear") - Interp%interp_method = BILINEAR - center = .false. - if(present(grid_at_center) ) center = grid_at_center - if(center) then - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & - verbose, src_modulo ) - deallocate(lon_src_1d,lat_src_1d) - endif - case ("bicubic") - Interp%interp_method = BICUBIC - center = .false. - if(present(grid_at_center) ) center = grid_at_center - if(center) then - call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & - verbose, src_modulo ) - deallocate(lon_src_1d,lat_src_1d) - endif - case ("spherical") - Interp%interp_method = SPHERICA - nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) - allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) - do i = 1, nlon_in - lon_src(i,:) = lon_in(i) - enddo - do j = 1, nlat_in - lat_src(:,j) = lat_in(j) - enddo - call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_out, lat_out, & - num_nbrs, max_dist, src_modulo) - deallocate(lon_src, lat_src) - case default - call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') - end select - - !----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_1d_src - -!####################################################################### - - subroutine horiz_interp_new_2d (Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, interp_method, num_nbrs, max_dist, & - src_modulo, mask_in, mask_out, is_latlon_in, is_latlon_out ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out),dimension(:,:), optional :: mask_out - logical, intent(in), optional :: is_latlon_in, is_latlon_out - logical :: src_is_latlon, dst_is_latlon - character(len=40) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - - method = 'bilinear' - if(present(interp_method)) method = interp_method - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - if(PRESENT(is_latlon_in)) then - src_is_latlon = is_latlon_in - else - src_is_latlon = is_lat_lon(lon_in, lat_in) - end if - if(PRESENT(is_latlon_out)) then - dst_is_latlon = is_latlon_out - else - dst_is_latlon = is_lat_lon(lon_out, lat_out) - end if - if(src_is_latlon .AND. dst_is_latlon) then - if(present(mask_in)) then - if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2d(horiz_interp_conserve_mod): input mask not between 0,1') - allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) ) - Interp%mask_in = mask_in - end if - call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out(:,1), lat_out(1,:), & - verbose=verbose ) - else if(src_is_latlon) then - call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - else if(dst_is_latlon) then - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - else - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - end if - - case ("spherical") - Interp%interp_method = SPHERICA - call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - num_nbrs, max_dist, src_modulo ) - case ("bilinear") - Interp%interp_method = BILINEAR - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - case default - call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') - end select - -!----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_2d - -!####################################################################### - subroutine horiz_interp_new_1d_dst (Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, interp_method, num_nbrs, max_dist, src_modulo, mask_in, mask_out, is_latlon_in ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out),dimension(:,:), optional :: mask_out - logical, intent(in), optional :: is_latlon_in - - character(len=40) :: method - !-------------some local variables----------------------------------------------- - integer :: i, j, nlon_out, nlat_out - real, dimension(:,:), allocatable :: lon_dst, lat_dst - logical :: src_is_latlon - !----------------------------------------------------------------------- - call horiz_interp_init - - method = 'bilinear' - if(present(interp_method)) method = interp_method - - nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_out - lon_dst(i,:) = lon_out(i) - enddo - do j = 1, nlat_out - lat_dst(:,j) = lat_out(j) - enddo - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - if(PRESENT(is_latlon_in)) then - src_is_latlon = is_latlon_in - else - src_is_latlon = is_lat_lon(lon_in, lat_in) - end if - - if(src_is_latlon) then - if(present(mask_in)) then - if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1d_dst(horiz_interp_conserve_mod): input mask not between 0,1') - allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) ) - Interp%mask_in = mask_in - end if - call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & - verbose=verbose) - else - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - end if - case ("bilinear") - Interp%interp_method = BILINEAR - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & - verbose, src_modulo ) - case ("spherical") - Interp%interp_method = SPHERICA - call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & - num_nbrs, max_dist, src_modulo) - case default - call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') - end select - - deallocate(lon_dst,lat_dst) - - !----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_1d_dst - -!####################################################################### - - subroutine horiz_interp_base_2d ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit, & - err_msg, new_missing_handle ) -!----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - character(len=*), intent(out), optional :: err_msg - logical, intent(in), optional :: new_missing_handle -!----------------------------------------------------------------------- - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return - endif - - select case(Interp%interp_method) - case(CONSERVE) - call horiz_interp_conserve(Interp,data_in, data_out, verbose, mask_in, mask_out) - case(BILINEAR) - call horiz_interp_bilinear(Interp,data_in, data_out, verbose, mask_in, mask_out, & - missing_value, missing_permit, new_missing_handle ) - case(BICUBIC) - call horiz_interp_bicubic(Interp,data_in, data_out, verbose, mask_in, mask_out, & - missing_value, missing_permit ) - case(SPHERICA) - call horiz_interp_spherical(Interp,data_in, data_out, verbose, mask_in, mask_out, & - missing_value ) - case default - call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') - end select - - return - - end subroutine horiz_interp_base_2d - -!####################################################################### - - !> Overload of interface horiz_interp_base_2d - !! uses 3d arrays for data and mask - !! this allows for multiple interpolations with one call - subroutine horiz_interp_base_3d ( Interp, data_in, data_out, verbose, mask_in, mask_out, & - missing_value, missing_permit, err_msg ) - !----------------------------------------------------------------------- - ! overload of interface horiz_interp_base_2d - ! uses 3d arrays for data and mask - ! this allows for multiple interpolations with one call - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:,:) :: data_in - real, intent(out), dimension(:,:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:,:), optional :: mask_in - real, intent(out), dimension(:,:,:), optional :: mask_out - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - character(len=*), intent(out), optional :: err_msg - !----------------------------------------------------------------------- - integer :: n - - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return - endif - - do n = 1, size(data_in,3) - if (present(mask_in))then - if(present(mask_out)) then - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, mask_in(:,:,n), mask_out(:,:,n), & - missing_value, missing_permit ) - else - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, mask_in(:,:,n), missing_value = missing_value, & - missing_permit = missing_permit ) - endif - else - if(present(mask_out)) then - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, mask_out=mask_out(:,:,n), missing_value = missing_value, & - missing_permit = missing_permit ) - else - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, missing_value = missing_value, & - missing_permit = missing_permit ) - endif - endif - enddo - - return -!----------------------------------------------------------------------- - end subroutine horiz_interp_base_3d - -!####################################################################### - -!> Interpolates from a rectangular grid to rectangular grid. -!! interp_method can be the value conservative, bilinear or spherical. -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_1d ( data_in, lon_in, lat_in, lon_out, lat_out, & - data_out, verbose, mask_in, mask_out, & - interp_method, missing_value, missing_permit, & - num_nbrs, max_dist,src_modulo, grid_at_center ) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp -!----------------------------------------------------------------------- - call horiz_interp_init - - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, grid_at_center ) - - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - - call horiz_interp_del ( Interp ) -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_1d - -!####################################################################### - -!> Interpolates from a uniformly spaced grid to any output grid. -!! interp_method can be the value "onservative","bilinear" or "spherical". -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_1d_src ( data_in, lon_in, lat_in, lon_out, lat_out, & - data_out, verbose, mask_in, mask_out, & - interp_method, missing_value, missing_permit, & - num_nbrs, max_dist, src_modulo, grid_at_center ) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center - -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp - logical :: dst_is_latlon - character(len=128) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - method = 'conservative' - if(present(interp_method)) method = interp_method - dst_is_latlon = .true. - if(trim(method) == 'conservative') dst_is_latlon = is_lat_lon(lon_out, lat_out) - - if(dst_is_latlon) then - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - grid_at_center, is_latlon_out = dst_is_latlon ) - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - else - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - grid_at_center, mask_in, mask_out, is_latlon_out = dst_is_latlon) - - call horiz_interp ( Interp, data_in, data_out, verbose, & - missing_value=missing_value, missing_permit=missing_permit ) - end if - - call horiz_interp_del ( Interp ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_1d_src - - -!####################################################################### - -!> Interpolates from any grid to any grid. interp_method should be "spherical" -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_2d ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & - verbose, mask_in, mask_out, interp_method, missing_value,& - missing_permit, num_nbrs, max_dist, src_modulo ) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp - logical :: dst_is_latlon, src_is_latlon - character(len=128) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - dst_is_latlon = .true. - src_is_latlon = .true. - if(trim(method) == 'conservative') then - dst_is_latlon = is_lat_lon(lon_out, lat_out) - src_is_latlon = is_lat_lon(lon_in, lat_in) - end if - - if(dst_is_latlon .and. src_is_latlon) then - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon ) - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - else - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - mask_in, mask_out, & - is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon) - call horiz_interp ( Interp, data_in, data_out, verbose, & - missing_value=missing_value, missing_permit=missing_permit ) - end if - - call horiz_interp_del ( Interp ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_2d - -!####################################################################### - -!> interpolates from any grid to rectangular longitude/latitude grid. -!! interp_method should be "spherical". -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_1d_dst ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & - verbose, mask_in, mask_out,interp_method,missing_value, & - missing_permit, num_nbrs, max_dist, src_modulo) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp - logical :: src_is_latlon - character(len=128) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - src_is_latlon = .true. - if(trim(method) == 'conservative') src_is_latlon = is_lat_lon(lon_in, lat_in) - - if(src_is_latlon) then - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - is_latlon_in = src_is_latlon ) - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - else - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - mask_in, mask_out, is_latlon_in = src_is_latlon) - - call horiz_interp ( Interp, data_in, data_out, verbose, & - missing_value=missing_value, missing_permit=missing_permit ) - end if - - call horiz_interp_del ( Interp ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_1d_dst - -!####################################################################### - -!> Overloaded version of interface horiz_interp_solo_2 - subroutine horiz_interp_solo_old (data_in, wb, sb, dx, dy, & - lon_out, lat_out, data_out, & - verbose, mask_in, mask_out) - -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in !< Global input data stored from west to east - !! (1st dimension), south to north (2nd dimension) - real, intent(in) :: wb !< Longitude (radians) that correspond to western-most - !! boundary of grid box j=1 in array data_in - real, intent(in) :: sb !< Latitude (radians) that correspond to western-most - !! boundary of grid box j=1 in array data_in - real, intent(in) :: dx !< Grid spacing (in radians) for the longitude axis - !! (first dimension) for the input data - real, intent(in) :: dy !< Grid spacing (in radians) for the latitude axis - !! (first dimension) for the input data - real, intent(in), dimension(:) :: lon_out !< The longitude edges (in radians) for output - !! data grid boxes. The values are for adjacent grid boxes - !! and must increase in value. If there are MLON grid boxes - !! there must be MLON+1 edge values - real, intent(in), dimension(:) :: lat_out !< The latitude edges (in radians) for output - !! data grid boxes. The values are for adjacent grid boxes - !! and may increase or decrease in value. If there are NLAT - !! grid boxes there must be NLAT+1 edge values - real, intent(out), dimension(:,:) :: data_out !< Output data on the output grid defined by grid box - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out -!----------------------------------------------------------------------- - real, dimension(size(data_in,1)+1) :: blon_in - real, dimension(size(data_in,2)+1) :: blat_in - integer :: i, j, nlon_in, nlat_in - real :: tpi -!----------------------------------------------------------------------- - call horiz_interp_init - - tpi = 2.*pi - nlon_in = size(data_in,1) - nlat_in = size(data_in,2) - - do i = 1, nlon_in+1 - blon_in(i) = wb + float(i-1)*dx - enddo - if (abs(blon_in(nlon_in+1)-blon_in(1)-tpi) < epsilon(blon_in)) & - blon_in(nlon_in+1)=blon_in(1)+tpi - - do j = 2, nlat_in - blat_in(j) = sb + float(j-1)*dy - enddo - blat_in(1) = -0.5*pi - blat_in(nlat_in+1) = 0.5*pi - - - call horiz_interp_solo_1d (data_in, blon_in, blat_in, & - lon_out, lat_out, data_out, & - verbose, mask_in, mask_out ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_old - -!####################################################################### - !> Deallocates memory used by "horiz_interp_type" variables. !! Must be called before reinitializing with horiz_interp_new. subroutine horiz_interp_del ( Interp ) @@ -1055,48 +310,8 @@ subroutine horiz_interp_end return end subroutine horiz_interp_end - !#################################################################### - function is_lat_lon(lon, lat) - real, dimension(:,:), intent(in) :: lon, lat - logical :: is_lat_lon - integer :: i, j, nlon, nlat, num - - is_lat_lon = .true. - nlon = size(lon,1) - nlat = size(lon,2) - LOOP_LAT: do j = 1, nlat - do i = 2, nlon - if(lat(i,j) .NE. lat(1,j)) then - is_lat_lon = .false. - exit LOOP_LAT - end if - end do - end do LOOP_LAT - - if(is_lat_lon) then - LOOP_LON: do i = 1, nlon - do j = 2, nlat - if(lon(i,j) .NE. lon(i,1)) then - is_lat_lon = .false. - exit LOOP_LON - end if - end do - end do LOOP_LON - end if - - num = 0 - if(is_lat_lon) num = 1 - call mpp_min(num) - if(num == 1) then - is_lat_lon = .true. - else - is_lat_lon = .false. - end if - - return - end function is_lat_lon - -!##################################################################### +#include "horiz_interp_r4.fh" +#include "horiz_interp_r8.fh" end module horiz_interp_mod !> @} diff --git a/horiz_interp/horiz_interp_bicubic.F90 b/horiz_interp/horiz_interp_bicubic.F90 index b57fad23ca..25ac5c1a54 100644 --- a/horiz_interp/horiz_interp_bicubic.F90 +++ b/horiz_interp/horiz_interp_bicubic.F90 @@ -43,13 +43,13 @@ !! The module is thought to interact with MOM-4. !! Alle benotigten Felder werden extern von MOM verwaltet, da sie !! nicht fur alle interpolierten Daten die gleiche Dimension haben mussen. - module horiz_interp_bicubic_mod use mpp_mod, only: mpp_error, FATAL, stdout, mpp_pe, mpp_root_pe use fms_mod, only: write_version_number use horiz_interp_type_mod, only: horiz_interp_type use constants_mod, only: PI + use platform_mod, only: r4_kind, r8_kind implicit none @@ -60,10 +60,20 @@ module horiz_interp_bicubic_mod public :: horiz_interp_bicubic_init !> Creates a new @ref horiz_interp_type for bicubic interpolation. + !! Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. !> @ingroup horiz_interp_bicubic_mod interface horiz_interp_bicubic_new - module procedure horiz_interp_bicubic_new_1d - module procedure horiz_interp_bicubic_new_1d_s + module procedure horiz_interp_bicubic_new_1d_r8 + module procedure horiz_interp_bicubic_new_1d_s_r8 + module procedure horiz_interp_bicubic_new_1d_r4 + module procedure horiz_interp_bicubic_new_1d_s_r4 + end interface + + !> @brief Perform bicubic horizontal interpolation + interface horiz_interp_bicubic + module procedure horiz_interp_bicubic_r4 + module procedure horiz_interp_bicubic_r8 end interface !> @addtogroup horiz_interp_bicubic_mod @@ -87,12 +97,36 @@ module horiz_interp_bicubic_mod ! dff_xy : x-y-derivative of fc at the fine grid - real :: tpi + real(r8_kind) :: tpi + + !! Private interfaces for mixed precision helper routines interface fill_xy - module procedure fill_xy + module procedure fill_xy_r4 + module procedure fill_xy_r8 + end interface + + interface bcuint + module procedure bcuint_r4 + module procedure bcuint_r8 + end interface + + interface bcucof + module procedure bcucof_r4 + module procedure bcucof_r8 end interface + !> find the lower neighbour of xf in field xc, return is the index + interface indl + module procedure indl_r4 + module procedure indl_r8 + end interface + + !> find the upper neighbour of xf in field xc, return is the index + interface indu + module procedure indu_r4 + module procedure indu_r8 + end interface contains @@ -102,650 +136,39 @@ subroutine horiz_interp_bicubic_init if(module_is_initialized) return call write_version_number("HORIZ_INTERP_BICUBIC_MOD", version) module_is_initialized = .true. - tpi = 2.0*PI + tpi = real(2.0_r8_kind*PI, R8_KIND) end subroutine horiz_interp_bicubic_init - !####################################################################### - - !> @brief Creates a new @ref horiz_interp_type - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_bicubic_new_1d_s ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp !< A derived-type variable containing indices - !! and weights used for subsequent interpolations. To - !! reinitialize this variable for a different grid-to-grid - !! interpolation you must first use the - !! @ref horiz_interp_bicubic_del interface. - real, intent(in), dimension(:) :: lon_in !< Longitude (radians) for source data grid - real, intent(in), dimension(:) :: lat_in !< Latitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid - real, intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid - integer, intent(in), optional :: verbose !< flag for print output amount - logical, intent(in), optional :: src_modulo !< indicates if the boundary condition along - !! zonal boundary is cyclic or not. Zonal boundary condition - !!is cyclic when true - integer :: i, j, ip1, im1, jp1, jm1 - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: jcl, jcu, icl, icu, jj - real :: xz, yz - integer :: unit - - if(present(verbose)) verbose_bicubic = verbose - src_is_modulo = .false. - if (present(src_modulo)) src_is_modulo = src_modulo - - if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & - 'interplation, the output grids should be geographical grids') - - !--- get the grid size - nlon_in = size(lon_in) ; nlat_in = size(lat_in) - nlon_out = size(lon_out,1); nlat_out = size(lat_out,2) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out -! use wti(:,:,1) for x-derivative, wti(:,:,2) for y-derivative, wti(:,:,3) for xy-derivative - allocate ( Interp%wti (nlon_in, nlat_in, 3) ) - allocate ( Interp%lon_in (nlon_in) ) - allocate ( Interp%lat_in (nlat_in) ) - allocate ( Interp%rat_x (nlon_out, nlat_out) ) - allocate ( Interp%rat_y (nlon_out, nlat_out) ) - allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) - allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) - - Interp%lon_in = lon_in - Interp%lat_in = lat_in - - if ( verbose_bicubic > 0 ) then - unit = stdout() - write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d_s")') - write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src - write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src) - write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src - write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src) - do i=1, Interp%nlat_dst - write (unit,*) - write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst - write (unit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst) - enddo - do i=1, Interp%nlon_dst - write (unit,*) - write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst - write (unit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst) - enddo - endif - - -!--------------------------------------------------------------------------- -! Find the x-derivative. Use central differences and forward or -! backward steps at the boundaries - - do j=1,nlat_in - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,1) = 1./(Interp%lon_in(ip1)-Interp%lon_in(im1)) - enddo - enddo - - -!--------------------------------------------------------------------------- - -! Find the y-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - Interp%wti(i,j,2) = 1./(Interp%lat_in(jp1)-Interp%lat_in(jm1)) - enddo - enddo - -!--------------------------------------------------------------------------- - -! Find the xy-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,3) = 1./((Interp%lon_in(ip1)-Interp%lon_in(im1))*(Interp%lat_in(jp1)-Interp%lat_in(jm1))) - enddo - enddo -!--------------------------------------------------------------------------- -! Now for each point at the dest-grid find the boundary points of -! the source grid - do j=1, nlat_out - do i=1,nlon_out - yz = lat_out(i,j) - xz = lon_out(i,j) - - jcl = 0 - jcu = 0 - if( yz .le. Interp%lat_in(1) ) then - jcl = 1 - jcu = 1 - else if( yz .ge. Interp%lat_in(nlat_in) ) then - jcl = nlat_in - jcu = nlat_in - else - jcl = indl(Interp%lat_in, yz) - jcu = indu(Interp%lat_in, yz) - endif - - icl = 0 - icu = 0 - !--- cyclic condition, do we need to use do while - if( xz .gt. Interp%lon_in(nlon_in) ) xz = xz - tpi - if( xz .le. Interp%lon_in(1) ) xz = xz + tpi - if( xz .ge. Interp%lon_in(nlon_in) ) then - icl = nlon_in - icu = 1 - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl) + tpi) - else - icl = indl(Interp%lon_in, xz) - icu = indu(Interp%lon_in, xz) - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl)) - endif - Interp%j_lat(i,j,1) = jcl - Interp%j_lat(i,j,2) = jcu - Interp%i_lon(i,j,1) = icl - Interp%i_lon(i,j,2) = icu - if(jcl == jcu) then - Interp%rat_y(i,j) = 0.0 - else - Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl)) - endif -! if(yz.gt.Interp%lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! yf < ycl, no valid boundary point') -! if(yz.lt.Interp%lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! yf > ycu, no valid boundary point') -! if(xz.gt.Interp%lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! xf < xcl, no valid boundary point') -! if(xz.lt.Interp%lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! xf > xcu, no valid boundary point') - enddo - enddo - end subroutine horiz_interp_bicubic_new_1d_s - - !> @brief Creates a new @ref horiz_interp_type - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_bicubic_new_1d ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - - !----------------------------------------------------------------------- + !> Free memory from a horiz_interp_type used for bicubic interpolation + !! (allocated via @ref horiz_bicubic_new) + subroutine horiz_interp_bicubic_del( Interp ) type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - logical, intent(in), optional :: src_modulo - integer :: i, j, ip1, im1, jp1, jm1 - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: jcl, jcu, icl, icu, jj - real :: xz, yz - integer :: unit - if(present(verbose)) verbose_bicubic = verbose - src_is_modulo = .false. - if (present(src_modulo)) src_is_modulo = src_modulo - - !--- get the grid size - nlon_in = size(lon_in) ; nlat_in = size(lat_in) - nlon_out = size(lon_out); nlat_out = size(lat_out) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - allocate ( Interp%wti (nlon_in, nlat_in, 3) ) - allocate ( Interp%lon_in (nlon_in) ) - allocate ( Interp%lat_in (nlat_in) ) - allocate ( Interp%rat_x (nlon_out, nlat_out) ) - allocate ( Interp%rat_y (nlon_out, nlat_out) ) - allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) - allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) - - Interp%lon_in = lon_in - Interp%lat_in = lat_in - - if ( verbose_bicubic > 0 ) then - unit = stdout() - write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d")') - write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src - write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src) - write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src - write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src) - write (unit,*) - write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst - write (unit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst) - write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst - write (unit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst) + if(Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%rat_x)) deallocate ( Interp%horizInterpReals8_type%rat_x ) + if(allocated(Interp%horizInterpReals8_type%rat_y)) deallocate ( Interp%horizInterpReals8_type%rat_y ) + if(allocated(Interp%horizInterpReals8_type%lon_in)) deallocate ( Interp%horizInterpReals8_type%lon_in ) + if(allocated(Interp%horizInterpReals8_type%lat_in)) deallocate ( Interp%horizInterpReals8_type%lat_in ) + if(allocated(Interp%horizInterpReals8_type%wti)) deallocate ( Interp%horizInterpReals8_type%wti ) + else if(Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%rat_x)) deallocate ( Interp%horizInterpReals4_type%rat_x ) + if(allocated(Interp%horizInterpReals4_type%rat_y)) deallocate ( Interp%horizInterpReals4_type%rat_y ) + if(allocated(Interp%horizInterpReals4_type%lon_in)) deallocate ( Interp%horizInterpReals4_type%lon_in ) + if(allocated(Interp%horizInterpReals4_type%lat_in)) deallocate ( Interp%horizInterpReals4_type%lat_in ) + if(allocated(Interp%horizInterpReals4_type%wti)) deallocate ( Interp%horizInterpReals4_type%wti ) endif + if( allocated(Interp%i_lon) ) deallocate( Interp%i_lon ) + if( allocated(Interp%j_lat) ) deallocate( Interp%j_lat ) - -!--------------------------------------------------------------------------- -! Find the x-derivative. Use central differences and forward or -! backward steps at the boundaries - - do j=1,nlat_in - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,1) = 1./(lon_in(ip1)-lon_in(im1)) - enddo - enddo - - -!--------------------------------------------------------------------------- - -! Find the y-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - Interp%wti(i,j,2) = 1./(lat_in(jp1)-lat_in(jm1)) - enddo - enddo - -!--------------------------------------------------------------------------- - -! Find the xy-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,3) = 1./((lon_in(ip1)-lon_in(im1))*(lat_in(jp1)-lat_in(jm1))) - enddo - enddo -!--------------------------------------------------------------------------- -! Now for each point at the dest-grid find the boundary points of -! the source grid - do j=1, nlat_out - yz = lat_out(j) - jcl = 0 - jcu = 0 - if( yz .le. lat_in(1) ) then - jcl = 1 - jcu = 1 - else if( yz .ge. lat_in(nlat_in) ) then - jcl = nlat_in - jcu = nlat_in - else - jcl = indl(lat_in, yz) - jcu = indu(lat_in, yz) - endif - do i=1,nlon_out - xz = lon_out(i) - icl = 0 - icu = 0 - !--- cyclic condition, do we need to use do while - if( xz .gt. lon_in(nlon_in) ) xz = xz - tpi - if( xz .le. lon_in(1) ) xz = xz + tpi - if( xz .ge. lon_in(nlon_in) ) then - icl = nlon_in - icu = 1 - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl) + tpi) - else - icl = indl(lon_in, xz) - icu = indu(lon_in, xz) - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl)) - endif - icl = indl(lon_in, xz) - icu = indu(lon_in, xz) - Interp%j_lat(i,j,1) = jcl - Interp%j_lat(i,j,2) = jcu - Interp%i_lon(i,j,1) = icl - Interp%i_lon(i,j,2) = icu - if(jcl == jcu) then - Interp%rat_y(i,j) = 0.0 - else - Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl)) - endif -! if(yz.gt.lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: yf < -! ycl, no valid boundary point') -! if(yz.lt.lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: yf > -! ycu, no valid boundary point') -! if(xz.gt.lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: xf < -! xcl, no valid boundary point') -! if(xz.lt.lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: xf > -! xcu, no valid boundary point') - enddo - enddo - - end subroutine horiz_interp_bicubic_new_1d - - !> @brief Perform bicubic horizontal interpolation - subroutine horiz_interp_bicubic( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value, & - & missing_permit) - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - real :: yz, ycu, ycl - real :: xz, xcu, xcl - real :: val, val1, val2 - real, dimension(4) :: y, y1, y2, y12 - integer :: icl, icu, jcl, jcu - integer :: iclp1, icup1, jclp1, jcup1 - integer :: iclm1, icum1, jclm1, jcum1 - integer :: i,j - - if ( present(verbose) ) verbose_bicubic = verbose -! fill_in = .false. -! if ( present(fill) ) fill_in = fill -! use dfc_x and dfc_y as workspace -! if ( fill_in ) call fill_xy(fc(ics:ice,jcs:jce), ics, ice, jcs, jce, maxpass=2) -! where ( data_in .le. missing ) data_in(:,:) = 0. -!! - do j=1, Interp%nlat_dst - do i=1, Interp%nlon_dst - yz = Interp%rat_y(i,j) - xz = Interp%rat_x(i,j) - jcl = Interp%j_lat(i,j,1) - jcu = Interp%j_lat(i,j,2) - icl = Interp%i_lon(i,j,1) - icu = Interp%i_lon(i,j,2) - if( icl > icu ) then - iclp1 = icu - icum1 = icl - xcl = Interp%lon_in(icl) - xcu = Interp%lon_in(icu)+tpi - else - iclp1 = min(icl+1,Interp%nlon_src) - icum1 = max(icu-1,1) - xcl = Interp%lon_in(icl) - xcu = Interp%lon_in(icu) - endif - iclm1 = max(icl-1,1) - icup1 = min(icu+1,Interp%nlon_src) - jclp1 = min(jcl+1,Interp%nlat_src) - jclm1 = max(jcl-1,1) - jcup1 = min(jcu+1,Interp%nlat_src) - jcum1 = max(jcu-1,1) - ycl = Interp%lat_in(jcl) - ycu = Interp%lat_in(jcu) -! xcl = Interp%lon_in(icl) -! xcu = Interp%lon_in(icu) - y(1) = data_in(icl,jcl) - y(2) = data_in(icu,jcl) - y(3) = data_in(icu,jcu) - y(4) = data_in(icl,jcu) - y1(1) = ( data_in(iclp1,jcl) - data_in(iclm1,jcl) ) * Interp%wti(icl,jcl,1) - y1(2) = ( data_in(icup1,jcl) - data_in(icum1,jcl) ) * Interp%wti(icu,jcl,1) - y1(3) = ( data_in(icup1,jcu) - data_in(icum1,jcu) ) * Interp%wti(icu,jcu,1) - y1(4) = ( data_in(iclp1,jcu) - data_in(iclm1,jcu) ) * Interp%wti(icl,jcu,1) - y2(1) = ( data_in(icl,jclp1) - data_in(icl,jclm1) ) * Interp%wti(icl,jcl,2) - y2(2) = ( data_in(icu,jclp1) - data_in(icu,jclm1) ) * Interp%wti(icu,jcl,2) - y2(3) = ( data_in(icu,jcup1) - data_in(icu,jcum1) ) * Interp%wti(icu,jcu,2) - y2(4) = ( data_in(icl,jcup1) - data_in(icl,jcum1) ) * Interp%wti(icl,jcu,2) - y12(1)= ( data_in(iclp1,jclp1) + data_in(iclm1,jclm1) - data_in(iclm1,jclp1) & - - data_in(iclp1,jclm1) ) * Interp%wti(icl,jcl,3) - y12(2)= ( data_in(icup1,jclp1) + data_in(icum1,jclm1) - data_in(icum1,jclp1) & - - data_in(icup1,jclm1) ) * Interp%wti(icu,jcl,3) - y12(3)= ( data_in(icup1,jcup1) + data_in(icum1,jcum1) - data_in(icum1,jcup1) & - - data_in(icup1,jcum1) ) * Interp%wti(icu,jcu,3) - y12(4)= ( data_in(iclp1,jcup1) + data_in(iclm1,jcum1) - data_in(iclm1,jcup1) & - - data_in(iclp1,jcum1) ) * Interp%wti(icl,jcu,3) - - call bcuint(y,y1,y2,y12,xcl,xcu,ycl,ycu,xz,yz,val,val1,val2) - data_out (i,j) = val - if(present(mask_out)) mask_out(i,j) = 1. -!! dff_x(i,j) = val1 -!! dff_y(i,j) = val2 - enddo - enddo - return - end subroutine horiz_interp_bicubic - - -!--------------------------------------------------------------------------- - - subroutine bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,t,u,ansy,ansy1,ansy2) - real ansy,ansy1,ansy2,x1l,x1u,x2l,x2u,y(4),y1(4),y12(4),y2(4) -! uses bcucof - integer i - real t,u,c(4,4) - call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c) - ansy=0. - ansy2=0. - ansy1=0. - do i=4,1,-1 - ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1) -! ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2) -! ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i) - enddo -! ansy1=ansy1/(x1u-x1l) ! could be used for accuracy checks -! ansy2=ansy2/(x2u-x2l) ! could be used for accuracy checks - return -! (c) copr. 1986-92 numerical recipes software -3#(-)f. - end subroutine bcuint -!--------------------------------------------------------------------------- - - subroutine bcucof(y,y1,y2,y12,d1,d2,c) - real d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4) - integer i,j,k,l - real d1d2,xx,cl(16),wt(16,16),x(16) - save wt - data wt/1., 0., -3., 2., 4*0., -3., 0., 9., -6., 2., 0., -6., 4., 8*0., & - 3., 0., -9., 6., -2., 0., 6., -4., 10*0., 9., -6., 2*0., -6., & - 4., 2*0., 3., -2., 6*0., -9., 6., 2*0., 6., -4., 4*0., 1., 0., & - -3., 2., -2., 0., 6., -4., 1., 0., -3., 2., 8*0., -1., 0., 3., & - -2., 1., 0., -3., 2., 10*0., -3., 2., 2*0., 3., -2., 6*0., 3., & - -2., 2*0., -6., 4., 2*0., 3., -2., 0., 1., -2., 1., 5*0., -3., & - 6., -3., 0., 2., -4., 2., 9*0., 3., -6., 3., 0., -2., 4., -2., & - 10*0., -3., 3., 2*0., 2., -2., 2*0., -1., 1., 6*0., 3., -3., & - 2*0., -2., 2., 5*0., 1., -2., 1., 0., -2., 4., -2., 0., 1., -2., & - 1., 9*0., -1., 2., -1., 0., 1., -2., 1., 10*0., 1., -1., 2*0., & - -1., 1., 6*0., -1., 1., 2*0., 2., -2., 2*0., -1., 1./ - - d1d2=d1*d2 - do i=1,4 - x(i)=y(i) - x(i+4)=y1(i)*d1 - x(i+8)=y2(i)*d2 - x(i+12)=y12(i)*d1d2 - enddo - do i=1,16 - xx=0. - do k=1,16 - xx=xx+wt(i,k)*x(k) - enddo - cl(i)=xx - enddo - l=0 - do i=1,4 - do j=1,4 - l=l+1 - c(i,j)=cl(l) - enddo - enddo - return -! (c) copr. 1986-92 numerical recipes software -3#(-)f. - end subroutine bcucof - -!----------------------------------------------------------------------- - -!> find the lower neighbour of xf in field xc, return is the index - function indl(xc, xf) - real, intent(in) :: xc(1:) - real, intent(in) :: xf - integer :: indl - integer :: ii - indl = 1 - do ii=1, size(xc) - if(xc(ii).gt.xf) return - indl = ii - enddo - call mpp_error(FATAL,'Error in indl') - return - end function indl - -!----------------------------------------------------------------------- - -!> find the upper neighbour of xf in field xc, return is the index - function indu(xc, xf) - real, intent(in) :: xc(1:) - real, intent(in) :: xf - integer :: indu - integer :: ii - do ii=1, size(xc) - indu = ii - if(xc(ii).gt.xf) return - enddo - call mpp_error(FATAL,'Error in indu') - return - end function indu - -!----------------------------------------------------------------------- - - subroutine fill_xy(fi, ics, ice, jcs, jce, mask, maxpass) - integer, intent(in) :: ics,ice,jcs,jce - real, intent(inout) :: fi(ics:ice,jcs:jce) - real, intent(in), optional :: mask(ics:ice,jcs:jce) - integer, intent(in) :: maxpass - real :: work_old(ics:ice,jcs:jce) - real :: work_new(ics:ice,jcs:jce) - logical :: ready - real :: blank = -1.e30 - real :: tavr - integer :: ipass = 0 - integer :: inl, inr, jnl, jnu, i, j, is, js, iavr - - - ready = .false. - - work_new(:,:) = fi(:,:) - work_old(:,:) = work_new(:,:) - ipass = 0 - if ( present(mask) ) then - do while (.not.ready) - ipass = ipass+1 - ready = .true. - do j=jcs, jce - do i=ics, ice - if (work_old(i,j).le.blank) then - tavr=0. - iavr=0 - inl = max(i-1,ics) - inr = min(i+1,ice) - jnl = max(j-1,jcs) - jnu = min(j+1,jce) - do js=jnl,jnu - do is=inl,inr - if (work_old(is,js) .ne. blank .and. mask(is,js).ne.0.) then - tavr = tavr + work_old(is,js) - iavr = iavr+1 - endif - enddo - enddo - if (iavr.gt.0) then - if (iavr.eq.1) then -! spreading is not allowed if the only valid neighbor is a corner point -! otherwise an ill posed cellular automaton is established leading to -! a spreading of constant values in diagonal direction -! if all corner points are blanked the valid neighbor must be a direct one -! and spreading is allowed - if (work_old(inl,jnu).eq.blank.and.& - work_old(inr,jnu).eq.blank.and.& - work_old(inr,jnl).eq.blank.and.& - work_old(inl,jnl).eq.blank) then - work_new(i,j)=tavr/iavr - ready = .false. - endif - else - work_new(i,j)=tavr/iavr - ready = .false. - endif - endif - endif - enddo ! j - enddo ! i -! save changes made during this pass to work_old - work_old(:,:)=work_new(:,:) - if(ipass.eq.maxpass) ready=.true. - enddo !while (.not.ready) - fi(:,:) = work_new(:,:) - else - do while (.not.ready) - ipass = ipass+1 - ready = .true. - do j=jcs, jce - do i=ics, ice - if (work_old(i,j).le.blank) then - tavr=0. - iavr=0 - inl = max(i-1,ics) - inr = min(i+1,ice) - jnl = max(j-1,jcs) - jnu = min(j+1,jce) - do is=inl,inr - do js=jnl,jnu - if (work_old(is,js).gt.blank) then - tavr = tavr + work_old(is,js) - iavr = iavr+1 - endif - enddo - enddo - if (iavr.gt.0) then - if (iavr.eq.1) then -! spreading is not allowed if the only valid neighbor is a corner point -! otherwise an ill posed cellular automaton is established leading to -! a spreading of constant values in diagonal direction -! if all corner points are blanked the valid neighbor must be a direct one -! and spreading is allowed - if (work_old(inl,jnu).le.blank.and. & - work_old(inr,jnu).le.blank.and. & - work_old(inr,jnl).le.blank.and. & - work_old(inl,jnl).le.blank) then - work_new(i,j)=tavr/iavr - ready = .false. - endif - else - work_new(i,j)=tavr/iavr - ready = .false. - endif - endif - endif - enddo ! j - enddo ! i -! save changes made during this pass to work_old - work_old(:,:)=work_new(:,:) - if(ipass.eq.maxpass) ready=.true. - enddo !while (.not.ready) - fi(:,:) = work_new(:,:) - endif - return - end subroutine fill_xy - - subroutine horiz_interp_bicubic_del( Interp ) - - type (horiz_interp_type), intent(inout) :: Interp - - if(allocated(Interp%rat_x)) deallocate ( Interp%rat_x ) - if(allocated(Interp%rat_y)) deallocate ( Interp%rat_y ) - if(allocated(Interp%lon_in)) deallocate ( Interp%lon_in ) - if(allocated(Interp%lat_in)) deallocate ( Interp%lat_in ) - if(allocated(Interp%i_lon)) deallocate ( Interp%i_lon ) - if(allocated(Interp%j_lat)) deallocate ( Interp%j_lat ) - if(allocated(Interp%wti)) deallocate ( Interp%wti ) + Interp%horizInterpReals8_type%is_allocated = .false. + Interp%horizInterpReals4_type%is_allocated = .false. end subroutine horiz_interp_bicubic_del +#include "horiz_interp_bicubic_r4.fh" +#include "horiz_interp_bicubic_r8.fh" + end module horiz_interp_bicubic_mod !> @} ! close documentation diff --git a/horiz_interp/horiz_interp_bilinear.F90 b/horiz_interp/horiz_interp_bilinear.F90 index 126b46087c..64abf15263 100644 --- a/horiz_interp/horiz_interp_bilinear.F90 +++ b/horiz_interp/horiz_interp_bilinear.F90 @@ -33,6 +33,7 @@ module horiz_interp_bilinear_mod use fms_mod, only: write_version_number use constants_mod, only: PI use horiz_interp_type_mod, only: horiz_interp_type, stats + use platform_mod, only: r4_kind, r8_kind implicit none private @@ -44,16 +45,35 @@ module horiz_interp_bilinear_mod !> Creates a @ref horiz_interp_type for bilinear interpolation. !> @ingroup horiz_interp_bilinear_mod interface horiz_interp_bilinear_new - module procedure horiz_interp_bilinear_new_1d - module procedure horiz_interp_bilinear_new_2d + module procedure horiz_interp_bilinear_new_1d_r4 + module procedure horiz_interp_bilinear_new_1d_r8 + module procedure horiz_interp_bilinear_new_2d_r4 + module procedure horiz_interp_bilinear_new_2d_r8 + end interface + + interface horiz_interp_bilinear + module procedure horiz_interp_bilinear_r4 + module procedure horiz_interp_bilinear_r8 end interface !> @addtogroup horiz_interp_bilinear_mod !> @{ - real, parameter :: epsln=1.e-10 + real(r8_kind), parameter :: epsln=1.e-10_r8_kind integer, parameter :: DUMMY = -999 +!! Private helper routines, interfaces for mixed real precision support + + interface indp + module procedure indp_r4 + module procedure indp_r8 + end interface + + interface intersect + module procedure intersect_r4 + module procedure intersect_r8 + end interface + !----------------------------------------------------------------------- ! Include variable "version" to be written to log file. #include @@ -70,1166 +90,6 @@ subroutine horiz_interp_bilinear_init end subroutine horiz_interp_bilinear_init - - !######################################################################## - - subroutine horiz_interp_bilinear_new_1d ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - logical, intent(in), optional :: src_modulo - - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m - integer :: ie, is, je, js, ln_err, lt_err, warns, unit - real :: wtw, wte, wts, wtn, lon, lat, tpi, hpi - real :: glt_min, glt_max, gln_min, gln_max, min_lon, max_lon - - warns = 0 - if(present(verbose)) warns = verbose - src_is_modulo = .true. - if (present(src_modulo)) src_is_modulo = src_modulo - - hpi = 0.5*pi - tpi = 4.0*hpi - glt_min = hpi - glt_max = -hpi - gln_min = tpi - gln_max = -tpi - min_lon = 0.0 - max_lon = tpi - ln_err = 0 - lt_err = 0 - !----------------------------------------------------------------------- - - allocate ( Interp % wti (size(lon_out,1),size(lon_out,2),2), & - Interp % wtj (size(lon_out,1),size(lon_out,2),2), & - Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & - Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) - !----------------------------------------------------------------------- - - nlon_in = size(lon_in(:)) ; nlat_in = size(lat_in(:)) - nlon_out = size(lon_out, 1); nlat_out = size(lon_out, 2) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - - if(src_is_modulo) then - if(lon_in(nlon_in) - lon_in(1) .gt. tpi + epsln) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: '// & - 'The range of source grid longitude should be no larger than tpi') - - if(lon_in(1) .lt. 0.0 .OR. lon_in(nlon_in) > tpi ) then - min_lon = lon_in(1) - max_lon = lon_in(nlon_in) - endif - endif - - do n = 1, nlat_out - do m = 1, nlon_out - lon = lon_out(m,n) - lat = lat_out(m,n) - - if(src_is_modulo) then - if(lon .lt. min_lon) then - lon = lon + tpi - else if(lon .gt. max_lon) then - lon = lon - tpi - endif - else ! when the input grid is in not cyclic, the output grid should located inside - ! the input grid - if((lon .lt. lon_in(1)) .or. (lon .gt. lon_in(nlon_in))) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& - 'when input grid is not modulo, output grid should locate inside input grid') - endif - - glt_min = min(lat,glt_min); glt_max = max(lat,glt_max) - gln_min = min(lon,gln_min); gln_max = max(lon,gln_max) - - is = indp(lon, lon_in ) - if( lon_in(is) .gt. lon ) is = max(is-1,1) - if( lon_in(is) .eq. lon .and. is .eq. nlon_in) is = max(is - 1,1) - ie = min(is+1,nlon_in) - if(lon_in(is) .ne. lon_in(ie) .and. lon_in(is) .le. lon) then - wtw = ( lon_in(ie) - lon) / (lon_in(ie) - lon_in(is) ) - else - ! east or west of the last data value. this could be because a - ! cyclic condition is needed or the dataset is too small. - ln_err = 1 - ie = 1 - is = nlon_in - if (lon_in(ie) .ge. lon ) then - wtw = (lon_in(ie) -lon)/(lon_in(ie)-lon_in(is)+tpi+epsln) - else - wtw = (lon_in(ie) -lon+tpi+epsln)/(lon_in(ie)-lon_in(is)+tpi+epsln) - endif - endif - wte = 1. - wtw - - js = indp(lat, lat_in ) - - if( lat_in(js) .gt. lat ) js = max(js - 1, 1) - if( lat_in(js) .eq. lat .and. js .eq. nlat_in) js = max(js - 1, 1) - je = min(js + 1, nlat_in) - - if ( lat_in(js) .ne. lat_in(je) .and. lat_in(js) .le. lat) then - wts = ( lat_in(je) - lat )/(lat_in(je)-lat_in(js)) - else - ! north or south of the last data value. this could be because a - ! pole is not included in the data set or the dataset is too small. - ! in either case extrapolate north or south - lt_err = 1 - wts = 1. - endif - - wtn = 1. - wts - - Interp % i_lon (m,n,1) = is; Interp % i_lon (m,n,2) = ie - Interp % j_lat (m,n,1) = js; Interp % j_lat (m,n,2) = je - Interp % wti (m,n,1) = wtw - Interp % wti (m,n,2) = wte - Interp % wtj (m,n,1) = wts - Interp % wtj (m,n,2) = wtn - - enddo - enddo - - unit = stdout() - - if (ln_err .eq. 1 .and. warns > 0) then - write (unit,'(/,(1x,a))') & - '==> Warning: the geographic data set does not extend far ', & - ' enough east or west - a cyclic boundary ', & - ' condition was applied. check if appropriate ' - write (unit,'(/,(1x,a,2f8.4))') & - ' data required between longitudes:', gln_min, gln_max, & - ' data set is between longitudes:', lon_in(1), lon_in(nlon_in) - warns = warns - 1 - endif - - if (lt_err .eq. 1 .and. warns > 0) then - write (unit,'(/,(1x,a))') & - '==> Warning: the geographic data set does not extend far ',& - ' enough north or south - extrapolation from ',& - ' the nearest data was applied. this may create ',& - ' artificial gradients near a geographic pole ' - write (unit,'(/,(1x,a,2f8.4))') & - ' data required between latitudes:', glt_min, glt_max, & - ' data set is between latitudes:', lat_in(1), lat_in(nlat_in) - endif - - return - - end subroutine horiz_interp_bilinear_new_1d - - !####################################################################### - - !> Initialization routine. - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_bilinear_new_2d ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo, new_search, no_crash_when_not_found ) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices - !! and weights for subsequent interpolations. To - !! reinitialize for different grid-to-grid interpolation - !! @ref horiz_interp_del must be used first. - real, intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid - real, intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid - integer, intent(in), optional :: verbose !< flag for amount of print output - logical, intent(in), optional :: src_modulo !< indicates if the boundary condition - !! along zonal boundary is cyclic or not. Cyclic when true - logical, intent(in), optional :: new_search - logical, intent(in), optional :: no_crash_when_not_found - integer :: warns - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: m, n, is, ie, js, je, num_solution - real :: lon, lat, quadra, x, y, y1, y2 - real :: a1, b1, c1, d1, a2, b2, c2, d2, a, b, c - real :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 - real :: tpi, lon_min, lon_max - real :: epsln2 - logical :: use_new_search, no_crash - - tpi = 2.0*pi - - warns = 0 - if(present(verbose)) warns = verbose - src_is_modulo = .true. - if (present(src_modulo)) src_is_modulo = src_modulo - use_new_search = .false. - if (present(new_search)) use_new_search = new_search - no_crash = .false. - if(present(no_crash_when_not_found)) no_crash = no_crash_when_not_found - - ! make sure lon and lat has the same dimension - if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & - 'interplation, the output grids should be geographical grids') - - if(size(lon_in,1) /= size(lat_in,1) .or. size(lon_in,2) /= size(lat_in,2) ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear '// & - 'interplation, the input grids should be geographical grids') - - !--- get the grid size - nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) - nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - - allocate ( Interp % wti (size(lon_out,1),size(lon_out,2),2), & - Interp % wtj (size(lon_out,1),size(lon_out,2),2), & - Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & - Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) - - !--- first fine the neighbor points for the destination points. - if(use_new_search) then - epsln2 = epsln*1e5 - call find_neighbor_new(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo, no_crash) - else - epsln2 = epsln - call find_neighbor(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo) - endif - - !*************************************************************************** - ! Algorithm explanation (from disscussion with Steve Garner ) * - ! * - ! lon(x,y) = a1*x + b1*y + c1*x*y + d1 (1) * - ! lat(x,y) = a2*x + b2*y + c2*x*y + d2 (2) * - ! f (x,y) = a3*x + b3*y + c3*x*y + d3 (3) * - ! with x and y is between 0 and 1. * - ! lon1 = lon(0,0) = d1, lat1 = lat(0,0) = d2 * - ! lon2 = lon(1,0) = a1+d1, lat2 = lat(1,0) = a2+d2 * - ! lon3 = lon(1,1) = a1+b1+c1+d1, lat3 = lat(1,1) = a2+b2+c2+d2 * - ! lon4 = lon(0,1) = b1+d1, lat4 = lat(0,1) = b2+d2 * - ! where (lon1,lat1),(lon2,lat2),(lon3,lat3),(lon4,lat4) represents * - ! the four corners starting from the left lower corner of grid box * - ! that encloses a destination grid ( the rotation direction is * - ! counterclockwise ). With these conditions, we get * - ! a1 = lon2-lon1, a2 = lat2-lat1 * - ! b1 = lon4-lon1, b2 = lat4-lat1 * - ! c1 = lon3-lon2-lon4+lon1, c2 = lat3-lat2-lat4+lat1 * - ! d1 = lon1 d2 = lat1 * - ! So given any point (lon,lat), from equation (1) and (2) we can * - ! solve (x,y). * - ! From equation (3) * - ! f1 = f(0,0) = d3, f2 = f(1,0) = a3+d3 * - ! f3 = f(1,1) = a3+b3+c3+d3, f4 = f(0,1) = b3+d3 * - ! we obtain * - ! a3 = f2-f1, b3 = f4-f1 * - ! c3 = f3-f2-f4+f1, d3 = f1 * - ! at point (lon,lat) ---> (x,y) * - ! f(x,y) = (f2-f1)x + (f4-f1)y + (f3-f2-f4+f1)xy + f1 * - ! = f1*(1-x)*(1-y) + f2*x*(1-y) + f3*x*y + f4*y*(1-x) * - ! wtw=1-x; wte=x; wts=1-y; xtn=y * - ! * - !*************************************************************************** - - lon_min = minval(lon_in); - lon_max = maxval(lon_in); - !--- calculate the weight - do n = 1, nlat_out - do m = 1, nlon_out - lon = lon_out(m,n) - lat = lat_out(m,n) - if(lon .lt. lon_min) then - lon = lon + tpi - else if(lon .gt. lon_max) then - lon = lon - tpi - endif - is = Interp%i_lon(m,n,1); ie = Interp%i_lon(m,n,2) - js = Interp%j_lat(m,n,1); je = Interp%j_lat(m,n,2) - if( is == DUMMY) cycle - lon1 = lon_in(is,js); lat1 = lat_in(is,js); - lon2 = lon_in(ie,js); lat2 = lat_in(ie,js); - lon3 = lon_in(ie,je); lat3 = lat_in(ie,je); - lon4 = lon_in(is,je); lat4 = lat_in(is,je); - if(lon .lt. lon_min) then - lon1 = lon1 -tpi; lon4 = lon4 - tpi - else if(lon .gt. lon_max) then - lon2 = lon2 +tpi; lon3 = lon3 + tpi - endif - a1 = lon2-lon1 - b1 = lon4-lon1 - c1 = lon1+lon3-lon4-lon2 - d1 = lon1 - a2 = lat2-lat1 - b2 = lat4-lat1 - c2 = lat1+lat3-lat4-lat2 - d2 = lat1 - !--- the coefficient of the quadratic equation - a = b2*c1-b1*c2 - b = a1*b2-a2*b1+c1*d2-c2*d1+c2*lon-c1*lat - c = a2*lon-a1*lat+a1*d2-a2*d1 - quadra = b*b-4.*a*c - if(abs(quadra) < epsln) quadra = 0.0 - if(quadra < 0.0) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: No solution existed for this quadratic equation") - if ( abs(a) .lt. epsln2) then ! a = 0 is a linear equation - if( abs(b) .lt. epsln) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: no unique solution existed for this linear equation") - y = -c/b - else - y1 = 0.5*(-b+sqrt(quadra))/a - y2 = 0.5*(-b-sqrt(quadra))/a - if(abs(y1) < epsln2) y1 = 0.0 - if(abs(y2) < epsln2) y2 = 0.0 - if(abs(1.0-y1) < epsln2) y1 = 1.0 - if(abs(1.0-y2) < epsln2) y2 = 1.0 - num_solution = 0 - if(y1 >= 0.0 .and. y1 <= 1.0) then - y = y1 - num_solution = num_solution +1 - endif - if(y2 >= 0.0 .and. y2 <= 1.0) then - y = y2 - num_solution = num_solution + 1 - endif - if(num_solution == 0) then - call mpp_error(FATAL, "horiz_interp_bilinear_mod: No solution found") - else if(num_solution == 2) then - call mpp_error(FATAL, "horiz_interp_bilinear_mod: Two solutions found") - endif - endif - if(abs(a1+c1*y) < epsln) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: the denomenator is 0") - if(abs(y) < epsln2) y = 0.0 - if(abs(1.0-y) < epsln2) y = 1.0 - x = (lon-b1*y-d1)/(a1+c1*y) - if(abs(x) < epsln2) x = 0.0 - if(abs(1.0-x) < epsln2) x = 1.0 - ! x and y should be between 0 and 1. - !! Added for ECDA - if(use_new_search) then - if (x < 0.0) x = 0.0 ! snz - if (y < 0.0) y = 0.0 ! snz - if (x > 1.0) x = 1.0 - if (y > 1.0) y = 1.0 - endif - if( x>1. .or. x<0. .or. y>1. .or. y < 0.) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: weight should be between 0 and 1") - Interp % wti(m,n,1)=1.0-x; Interp % wti(m,n,2)=x - Interp % wtj(m,n,1)=1.0-y; Interp % wtj(m,n,2)=y - enddo - enddo - - end subroutine horiz_interp_bilinear_new_2d - - !####################################################################### - !> this routine will search the source grid to fine the grid box that encloses - !! each destination grid. - subroutine find_neighbor( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - logical, intent(in) :: src_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: max_step, n, m, l, i, j, ip1, jp1, step - integer :: is, js, jstart, jend, istart, iend, npts - integer, allocatable, dimension(:) :: ilon, jlat - real :: lon_min, lon_max, lon, lat, tpi - logical :: found - real :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 - - tpi = 2.0*pi - nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) - nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) - - lon_min = minval(lon_in); - lon_max = maxval(lon_in); - - max_step = max(nlon_in,nlat_in) ! can be adjusted if needed - allocate(ilon(5*max_step), jlat(5*max_step) ) - - do n = 1, nlat_out - do m = 1, nlon_out - found = .false. - lon = lon_out(m,n) - lat = lat_out(m,n) - - if(src_modulo) then - if(lon .lt. lon_min) then - lon = lon + tpi - else if(lon .gt. lon_max) then - lon = lon - tpi - endif - else - if(lon .lt. lon_min .or. lon .gt. lon_max ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& - 'when input grid is not modulo, output grid should locate inside input grid') - endif - !--- search for the surrounding four points locatioon. - if(m==1 .and. n==1) then - J_LOOP: do j = 1, nlat_in-1 - do i = 1, nlon_in - ip1 = i+1 - jp1 = j+1 - if(i==nlon_in) then - if(src_modulo)then - ip1 = 1 - else - cycle - endif - endif - lon1 = lon_in(i, j); lat1 = lat_in(i,j) - lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) - lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) - lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) - - if(lon .lt. lon_min .or. lon .gt. lon_max) then - if(i .ne. nlon_in) then - cycle - else - if(lon .lt. lon_min) then - lon1 = lon1 -tpi; lon4 = lon4 - tpi - else if(lon .gt. lon_max) then - lon2 = lon2 +tpi; lon3 = lon3 + tpi - endif - endif - endif - - if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south - if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east - if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then ! north - if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west - found = .true. - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit J_LOOP - endif - endif - endif - endif - enddo - enddo J_LOOP - else - step = 0 - do while ( .not. found .and. step .lt. max_step ) - !--- take the adajcent point as the starting point - if(m == 1) then - is = Interp % i_lon (m,n-1,1) - js = Interp % j_lat (m,n-1,1) - else - is = Interp % i_lon (m-1,n,1) - js = Interp % j_lat (m-1,n,1) - endif - if(step==0) then - npts = 1 - ilon(1) = is - jlat(1) = js - else - npts = 0 - !--- bottom boundary - jstart = max(js-step,1) - jend = min(js+step,nlat_in) - - do l = -step, step - i = is+l - if(src_modulo)then - if( i < 1) then - i = i + nlon_in - else if (i > nlon_in) then - i = i - nlon_in - endif - if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) - else - if( i < 1 .or. i > nlon_in) cycle - endif - - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jstart - enddo - - !--- right and left boundary ----------------------------------------------- - istart = is - step - iend = is + step - if(src_modulo) then - if( istart < 1) istart = istart + nlon_in - if( iend > nlon_in) iend = iend - nlon_in - else - istart = max(istart,1) - iend = min(iend, nlon_in) - endif - do l = -step, step - j = js+l - if( j < 1 .or. j > nlat_in .or. j==jstart .or. j==jend) cycle - npts = npts+1 - ilon(npts) = istart - jlat(npts) = j - npts = npts+1 - ilon(npts) = iend - jlat(npts) = j - end do - - !--- top boundary - - do l = -step, step - i = is+l - if(src_modulo)then - if( i < 1) then - i = i + nlon_in - else if (i > nlon_in) then - i = i - nlon_in - endif - if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) - else - if( i < 1 .or. i > nlon_in) cycle - endif - - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jend - enddo - - - end if - - !--- find the surrouding points - do l = 1, npts - i = ilon(l) - j = jlat(l) - ip1 = i+1 - if(ip1>nlon_in) then - if(src_modulo) then - ip1 = 1 - else - cycle - endif - endif - jp1 = j+1 - if(jp1>nlat_in) cycle - lon1 = lon_in(i, j); lat1 = lat_in(i,j) - lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) - lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) - lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) - - if(lon .lt. lon_min .or. lon .gt. lon_max) then - if(i .ne. nlon_in) then - cycle - else - if(lon .lt. lon_min) then - lon1 = lon1 -tpi; lon4 = lon4 - tpi - else if(lon .gt. lon_max) then - lon2 = lon2 +tpi; lon3 = lon3 + tpi - endif - endif - endif - - if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south - if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east - if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then !north - if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west - found = .true. - is=i; js=j - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit - endif - endif - endif - endif - enddo - step = step + 1 - enddo - endif - if(.not.found) then - print *,'lon,lat=',lon*180./PI,lat*180./PI - print *,'npts=',npts - print *,'is,ie= ',istart,iend - print *,'js,je= ',jstart,jend - print *,'lon_in(is,js)=',lon_in(istart,jstart)*180./PI - print *,'lon_in(ie,js)=',lon_in(iend,jstart)*180./PI - print *,'lat_in(is,js)=',lat_in(istart,jstart)*180./PI - print *,'lat_in(ie,js)=',lat_in(iend,jstart)*180./PI - print *,'lon_in(is,je)=',lon_in(istart,jend)*180./PI - print *,'lon_in(ie,je)=',lon_in(iend,jend)*180./PI - print *,'lat_in(is,je)=',lat_in(istart,jend)*180./PI - print *,'lat_in(ie,je)=',lat_in(iend,jend)*180./PI - - call mpp_error(FATAL, & - 'find_neighbor: the destination point is not inside the source grid' ) - endif - enddo - enddo - - end subroutine find_neighbor - - !####################################################################### - - !> The function will return true if the point x,y is inside a polygon, or - !! false if it is not. If the point is exactly on the edge of a polygon, - !! the function will return .true. - function inside_polygon(polyx, polyy, x, y) - real, dimension(:), intent(in) :: polyx !< longitude coordinates of corners - real, dimension(:), intent(in) :: polyy !< latitude coordinates of corners - real, intent(in) :: x !< x coordinate of point to be tested - real, intent(in) :: y !< y coordinate of point to be tested - logical :: inside_polygon - integer :: i, j, nedges - real :: xx - - inside_polygon = .false. - nedges = size(polyx(:)) - j = nedges - do i = 1, nedges - if( (polyy(i) < y .AND. polyy(j) >= y) .OR. (polyy(j) < y .AND. polyy(i) >= y) ) then - xx = polyx(i)+(y-polyy(i))/(polyy(j)-polyy(i))*(polyx(j)-polyx(i)) - if( xx == x ) then - inside_polygon = .true. - return - else if( xx < x ) then - inside_polygon = .not. inside_polygon - endif - endif - j = i - enddo - - return - - end function inside_polygon - - !####################################################################### - !> this routine will search the source grid to fine the grid box that encloses - !! each destination grid. - subroutine find_neighbor_new( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo, no_crash ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - logical, intent(in) :: src_modulo, no_crash - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: max_step, n, m, l, i, j, ip1, jp1, step - integer :: is, js, jstart, jend, istart, iend, npts - integer, allocatable, dimension(:) :: ilon, jlat - real :: lon_min, lon_max, lon, lat, tpi - logical :: found - real :: polyx(4), polyy(4) - real :: min_lon, min_lat, max_lon, max_lat - - integer, parameter :: step_div=8 - - tpi = 2.0*pi - nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) - nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) - - lon_min = minval(lon_in); - lon_max = maxval(lon_in); - - max_step = min(nlon_in,nlat_in)/step_div ! can be adjusted if needed - allocate(ilon(step_div*max_step), jlat(step_div*max_step) ) - - do n = 1, nlat_out - do m = 1, nlon_out - found = .false. - lon = lon_out(m,n) - lat = lat_out(m,n) - - if(src_modulo) then - if(lon .lt. lon_min) then - lon = lon + tpi - else if(lon .gt. lon_max) then - lon = lon - tpi - endif - else - if(lon .lt. lon_min .or. lon .gt. lon_max ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& - 'when input grid is not modulo, output grid should locate inside input grid') - endif - !--- search for the surrounding four points locatioon. - if(m==1 .and. n==1) then - J_LOOP: do j = 1, nlat_in-1 - do i = 1, nlon_in - ip1 = i+1 - jp1 = j+1 - if(i==nlon_in) then - if(src_modulo)then - ip1 = 1 - else - cycle - endif - endif - - polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) - polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) - polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) - polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) - if(lon .lt. lon_min .or. lon .gt. lon_max) then - if(i .ne. nlon_in) then - cycle - else - if(lon .lt. lon_min) then - polyx(1) = polyx(1) -tpi; polyx(4) = polyx(4) - tpi - else if(lon .gt. lon_max) then - polyx(2) = polyx(2) +tpi; polyx(3) = polyx(3) + tpi - endif - endif - endif - - min_lon = minval(polyx) - max_lon = maxval(polyx) - min_lat = minval(polyy) - max_lat = maxval(polyy) -! if( lon .GE. min_lon .AND. lon .LE. max_lon .AND. & -! lat .GE. min_lat .AND. lat .LE. max_lat ) then -! print*, 'i =', i, 'j = ', j -! print '(5f15.11)', lon, polyx -! print '(5f15.11)', lat, polyy -! endif - - if(inside_polygon(polyx, polyy, lon, lat)) then - found = .true. -! print*, " found ", i, j - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit J_LOOP - endif - enddo - enddo J_LOOP - else - step = 0 - do while ( .not. found .and. step .lt. max_step ) - !--- take the adajcent point as the starting point - if(m == 1) then - is = Interp % i_lon (m,n-1,1) - js = Interp % j_lat (m,n-1,1) - else - is = Interp % i_lon (m-1,n,1) - js = Interp % j_lat (m-1,n,1) - endif - if(step==0) then - npts = 1 - ilon(1) = is - jlat(1) = js - else - npts = 0 - !--- bottom and top boundary - jstart = max(js-step,1) - jend = min(js+step,nlat_in) - - do l = -step, step - i = is+l - if(src_modulo)then - if( i < 1) then - i = i + nlon_in - else if (i > nlon_in) then - i = i - nlon_in - endif - if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) - else - if( i < 1 .or. i > nlon_in) cycle - endif - - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jstart - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jend - enddo - - !--- right and left boundary ----------------------------------------------- - istart = is - step - iend = is + step - if(src_modulo) then - if( istart < 1) istart = istart + nlon_in - if( iend > nlon_in) iend = iend - nlon_in - else - istart = max(istart,1) - iend = min(iend, nlon_in) - endif - do l = -step, step - j = js+l - if( j < 1 .or. j > nlat_in) cycle - npts = npts+1 - ilon(npts) = istart - jlat(npts) = j - npts = npts+1 - ilon(npts) = iend - jlat(npts) = j - end do - end if - - !--- find the surrouding points - do l = 1, npts - i = ilon(l) - j = jlat(l) - ip1 = i+1 - if(ip1>nlon_in) then - if(src_modulo) then - ip1 = 1 - else - cycle - endif - endif - jp1 = j+1 - if(jp1>nlat_in) cycle - polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) - polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) - polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) - polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) - if(inside_polygon(polyx, polyy, lon, lat)) then - found = .true. - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit - endif - enddo - step = step + 1 - enddo - endif - if(.not.found) then - if(no_crash) then - Interp % i_lon (m,n,1:2) = DUMMY - Interp % j_lat (m,n,1:2) = DUMMY - print*,'lon,lat=',lon,lat ! snz - else - call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: the destination point is not inside the source grid' ) - endif - endif - enddo - enddo - - end subroutine find_neighbor_new - - !####################################################################### - function intersect(x1, y1, x2, y2, x) - real, intent(in) :: x1, y1, x2, y2, x - real :: intersect - - intersect = (y2-y1)*(x-x1)/(x2-x1) + y1 - - return - - end function intersect - - !####################################################################### - - !> Subroutine for performing the horizontal interpolation between two grids - !! - !! @ref horiz_interp_bilinear_new must be called before calling this routine. - subroutine horiz_interp_bilinear ( Interp, data_in, data_out, verbose, mask_in,mask_out, & - missing_value, missing_permit, new_handle_missing ) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp !< Derived type variable containing - !! interpolation indices and weights. Returned by a - !! previous call to horiz_interp_bilinear_new - real, intent(in), dimension(:,:) :: data_in !< input data on source grid - real, intent(out), dimension(:,:) :: data_out !< output data on source grid - integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = - !! all output - real, intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as - !! the input data. The real value of mask_in must be in the - !! range (0.,1.). Set mask_in=0.0 for data points - !! that should not be used or have missing data - real, intent(out), dimension(:,:), optional :: mask_out !< output mask that specifies whether - !! data was computed - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - logical, intent(in), optional :: new_handle_missing - !----------------------------------------------------------------------- - integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m, & - is, ie, js, je, iverbose, max_missing, num_missing, & - miss_in, miss_out, unit - real :: dwtsum, wtsum, min_in, max_in, avg_in, & - min_out, max_out, avg_out, wtw, wte, wts, wtn - real :: mask(size(data_in,1), size(data_in,2) ) - logical :: set_to_missing, is_missing(4), new_handler - real :: f1, f2, f3, f4, middle, w, s - - num_missing = 0 - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - if(present(mask_in)) then - mask = mask_in - else - mask = 1.0 - endif - - if (present(verbose)) then - iverbose = verbose - else - iverbose = 0 - endif - - if(present(missing_permit)) then - max_missing = missing_permit - else - max_missing = 0 - endif - - if(present(new_handle_missing)) then - new_handler = new_handle_missing - else - new_handler = .false. - endif - - if(max_missing .gt. 3 .or. max_missing .lt. 0) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: missing_permit should be between 0 and 3') - - if (size(data_in,1) /= nlon_in .or. size(data_in,2) /= nlat_in) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of input array incorrect') - - if (size(data_out,1) /= nlon_out .or. size(data_out,2) /= nlat_out) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of output array incorrect') - - if(new_handler) then - if( .not. present(missing_value) ) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: misisng_value must be present when new_handle_missing is .true.") - if( present(mask_in) ) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: mask_in should not be present when new_handle_missing is .true.") - do n = 1, nlat_out - do m = 1, nlon_out - is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) - js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) - wtw = Interp % wti (m,n,1) - wte = Interp % wti (m,n,2) - wts = Interp % wtj (m,n,1) - wtn = Interp % wtj (m,n,2) - - is_missing = .false. - num_missing = 0 - set_to_missing = .false. - if(data_in(is,js) == missing_value) then - num_missing = num_missing+1 - is_missing(1) = .true. - if(wtw .GE. 0.5 .AND. wts .GE. 0.5) set_to_missing = .true. - endif - - if(data_in(ie,js) == missing_value) then - num_missing = num_missing+1 - is_missing(2) = .true. - if(wte .GE. 0.5 .AND. wts .GE. 0.5) set_to_missing = .true. - endif - if(data_in(ie,je) == missing_value) then - num_missing = num_missing+1 - is_missing(3) = .true. - if(wte .GE. 0.5 .AND. wtn .GE. 0.5) set_to_missing = .true. - endif - if(data_in(is,je) == missing_value) then - num_missing = num_missing+1 - is_missing(4) = .true. - if(wtw .GE. 0.5 .AND. wtn .GE. 0.5) set_to_missing = .true. - endif - - if( num_missing == 4 .OR. set_to_missing ) then - data_out(m,n) = missing_value - if(present(mask_out)) mask_out(m,n) = 0.0 - cycle - else if(num_missing == 0) then - f1 = data_in(is,js) - f2 = data_in(ie,js) - f3 = data_in(ie,je) - f4 = data_in(is,je) - w = wtw - s = wts - else if(num_missing == 3) then !--- three missing value - if(.not. is_missing(1) ) then - data_out(m,n) = data_in(is,js) - else if(.not. is_missing(2) ) then - data_out(m,n) = data_in(ie,js) - else if(.not. is_missing(3) ) then - data_out(m,n) = data_in(ie,je) - else if(.not. is_missing(4) ) then - data_out(m,n) = data_in(is,je) - endif - if(present(mask_out) ) mask_out(m,n) = 1.0 - cycle - else !--- one or two missing value - if( num_missing == 1) then - if( is_missing(1) .OR. is_missing(3) ) then - middle = 0.5*(data_in(ie,js)+data_in(is,je)) - else - middle = 0.5*(data_in(is,js)+data_in(ie,je)) - endif - else ! num_missing = 2 - if( is_missing(1) .AND. is_missing(2) ) then - middle = 0.5*(data_in(ie,je)+data_in(is,je)) - else if( is_missing(1) .AND. is_missing(3) ) then - middle = 0.5*(data_in(ie,js)+data_in(is,je)) - else if( is_missing(1) .AND. is_missing(4) ) then - middle = 0.5*(data_in(ie,js)+data_in(ie,je)) - else if( is_missing(2) .AND. is_missing(3) ) then - middle = 0.5*(data_in(is,js)+data_in(is,je)) - else if( is_missing(2) .AND. is_missing(4) ) then - middle = 0.5*(data_in(is,js)+data_in(ie,je)) - else if( is_missing(3) .AND. is_missing(4) ) then - middle = 0.5*(data_in(is,js)+data_in(ie,js)) - endif - endif - - if( wtw .GE. 0.5 .AND. wts .GE. 0.5 ) then ! zone 1 - w = 2.0*(wtw-0.5) - s = 2.0*(wts-0.5) - f1 = data_in(is,js) - if(is_missing(2)) then - f2 = f1 - else - f2 = 0.5*(data_in(is,js)+data_in(ie,js)) - endif - f3 = middle - if(is_missing(4)) then - f4 = f1 - else - f4 = 0.5*(data_in(is,js)+data_in(is,je)) - endif - else if( wte .GE. 0.5 .AND. wts .GE. 0.5 ) then ! zone 2 - w = 2.0*(1.0-wte) - s = 2.0*(wts-0.5) - f2 = data_in(ie,js) - if(is_missing(1)) then - f1 = f2 - else - f1 = 0.5*(data_in(is,js)+data_in(ie,js)) - endif - f4 = middle - if(is_missing(3)) then - f3 = f2 - else - f3 = 0.5*(data_in(ie,js)+data_in(ie,je)) - endif - else if( wte .GE. 0.5 .AND. wtn .GE. 0.5 ) then ! zone 3 - w = 2.0*(1.0-wte) - s = 2.0*(1.0-wtn) - f3 = data_in(ie,je) - if(is_missing(2)) then - f2 = f3 - else - f2 = 0.5*(data_in(ie,js)+data_in(ie,je)) - endif - f1 = middle - if(is_missing(4)) then - f4 = f3 - else - f4 = 0.5*(data_in(ie,je)+data_in(is,je)) - endif - else if( wtw .GE. 0.5 .AND. wtn .GE. 0.5 ) then ! zone 4 - w = 2.0*(wtw-0.5) - s = 2.0*(1.0-wtn) - f4 = data_in(is,je) - if(is_missing(1)) then - f1 = f4 - else - f1 = 0.5*(data_in(is,js)+data_in(is,je)) - endif - f2 = middle - if(is_missing(3)) then - f3 = f4 - else - f3 = 0.5*(data_in(ie,je)+data_in(is,je)) - endif - else - call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: the point should be in one of the four zone") - endif - endif - - data_out(m,n) = f3 + (f4-f3)*w + (f2-f3)*s + ((f1-f2)+(f3-f4))*w*s - if(present(mask_out)) mask_out(m,n) = 1.0 - enddo - enddo - else - do n = 1, nlat_out - do m = 1, nlon_out - is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) - js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) - wtw = Interp % wti (m,n,1) - wte = Interp % wti (m,n,2) - wts = Interp % wtj (m,n,1) - wtn = Interp % wtj (m,n,2) - - if(present(missing_value) ) then - num_missing = 0 - if(data_in(is,js) == missing_value) then - num_missing = num_missing+1 - mask(is,js) = 0.0 - endif - if(data_in(ie,js) == missing_value) then - num_missing = num_missing+1 - mask(ie,js) = 0.0 - endif - if(data_in(ie,je) == missing_value) then - num_missing = num_missing+1 - mask(ie,je) = 0.0 - endif - if(data_in(is,je) == missing_value) then - num_missing = num_missing+1 - mask(is,je) = 0.0 - endif - endif - - dwtsum = data_in(is,js)*mask(is,js)*wtw*wts & - + data_in(ie,js)*mask(ie,js)*wte*wts & - + data_in(ie,je)*mask(ie,je)*wte*wtn & - + data_in(is,je)*mask(is,je)*wtw*wtn - wtsum = mask(is,js)*wtw*wts + mask(ie,js)*wte*wts & - + mask(ie,je)*wte*wtn + mask(is,je)*wtw*wtn - - if(.not. present(mask_in) .and. .not. present(missing_value)) wtsum = 1.0 - - if(num_missing .gt. max_missing ) then - data_out(m,n) = missing_value - if(present(mask_out)) mask_out(m,n) = 0.0 - else if(wtsum .lt. epsln) then - if(present(missing_value)) then - data_out(m,n) = missing_value - else - data_out(m,n) = 0.0 - endif - if(present(mask_out)) mask_out(m,n) = 0.0 - else - data_out(m,n) = dwtsum/wtsum - if(present(mask_out)) mask_out(m,n) = wtsum - endif - enddo - enddo - endif - !*********************************************************************** - ! compute statistics: minimum, maximum, and mean - !----------------------------------------------------------------------- - if (iverbose > 0) then - - ! compute statistics of input data - - call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask_in) - - ! compute statistics of output data - call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask_out) - - !---- output statistics ---- - unit = stdout() - write (unit,900) - write (unit,901) min_in ,max_in, avg_in - if (present(mask_in)) write (unit,903) miss_in - write (unit,902) min_out,max_out,avg_out - if (present(mask_out)) write (unit,903) miss_out - -900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) -901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) -902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) -903 format (' number of missing points = ',i6) - - endif - - return - - end subroutine horiz_interp_bilinear - - !####################################################################### - !> @brief Deallocates memory used by "horiz_interp_type" variables. !! !> Must be called before reinitializing with horiz_interp_bilinear_new. @@ -1240,60 +100,23 @@ subroutine horiz_interp_bilinear_del( Interp ) !! have allocated arrays. The returned variable will contain !! deallocated arrays - if(allocated(Interp%wti)) deallocate(Interp%wti) - if(allocated(Interp%wtj)) deallocate(Interp%wtj) + if( Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%wti)) deallocate(Interp%horizInterpReals4_type%wti) + if(allocated(Interp%horizInterpReals4_type%wtj)) deallocate(Interp%horizInterpReals4_type%wtj) + else if (Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%wti)) deallocate(Interp%horizInterpReals8_type%wti) + if(allocated(Interp%horizInterpReals8_type%wtj)) deallocate(Interp%horizInterpReals8_type%wtj) + endif if(allocated(Interp%i_lon)) deallocate(Interp%i_lon) if(allocated(Interp%j_lat)) deallocate(Interp%j_lat) - end subroutine horiz_interp_bilinear_del - - !####################################################################### - !> @returns index of nearest data point to "value" - !! if "value" is outside the domain of "array" then indp = 1 - !! or "ia" depending on whether array(1) or array(ia) is - !! closest to "value" - function indp (value, array) - integer :: indp !< index of nearest data point within "array" - !! corresponding to "value". - real, dimension(:), intent(in) :: array !< array of data points (must be monotonically increasing) - real, intent(in) :: value !< arbitrary data, same units as elements in 'array' - - !======================================================================= + Interp%horizInterpReals4_type%is_allocated = .false. + Interp%horizInterpReals8_type%is_allocated = .false. - integer i, ia, unit - logical keep_going - ! - ia = size(array(:)) - do i=2,ia - if (array(i) .lt. array(i-1)) then - unit = stdout() - write (unit,*) & - ' => Error: array must be monotonically increasing in "indp"' , & - ' when searching for nearest element to value=',value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' - call mpp_error() - endif - enddo - if (value .lt. array(1) .or. value .gt. array(ia)) then - if (value .lt. array(1)) indp = 1 - if (value .gt. array(ia)) indp = ia - else - i=1 - keep_going = .true. - do while (i .le. ia .and. keep_going) - i = i+1 - if (value .le. array(i)) then - indp = i - if (array(i)-value .gt. value-array(i-1)) indp = i-1 - keep_going = .false. - endif - enddo - endif - return - end function indp + end subroutine horiz_interp_bilinear_del - !###################################################################### +#include "horiz_interp_bilinear_r4.fh" +#include "horiz_interp_bilinear_r8.fh" end module horiz_interp_bilinear_mod !> @} diff --git a/horiz_interp/horiz_interp_conserve.F90 b/horiz_interp/horiz_interp_conserve.F90 index 1f73062997..b1b04a1b34 100644 --- a/horiz_interp/horiz_interp_conserve.F90 +++ b/horiz_interp/horiz_interp_conserve.F90 @@ -37,7 +37,7 @@ module horiz_interp_conserve_mod -#include + use platform_mod, only: r4_kind, r8_kind use mpp_mod, only: mpp_send, mpp_recv, mpp_pe, mpp_root_pe, mpp_npes use mpp_mod, only: mpp_error, FATAL, mpp_sync_self use mpp_mod, only: COMM_TAG_1, COMM_TAG_2 @@ -90,12 +90,44 @@ module horiz_interp_conserve_mod !! !> @ingroup horiz_interp_conserve_mod interface horiz_interp_conserve_new - module procedure horiz_interp_conserve_new_1dx1d - module procedure horiz_interp_conserve_new_1dx2d - module procedure horiz_interp_conserve_new_2dx1d - module procedure horiz_interp_conserve_new_2dx2d + module procedure horiz_interp_conserve_new_1dx1d_r4 + module procedure horiz_interp_conserve_new_1dx2d_r4 + module procedure horiz_interp_conserve_new_2dx1d_r4 + module procedure horiz_interp_conserve_new_2dx2d_r4 + module procedure horiz_interp_conserve_new_1dx1d_r8 + module procedure horiz_interp_conserve_new_1dx2d_r8 + module procedure horiz_interp_conserve_new_2dx1d_r8 + module procedure horiz_interp_conserve_new_2dx2d_r8 end interface + interface horiz_interp_conserve + module procedure horiz_interp_conserve_r4 + module procedure horiz_interp_conserve_r8 + end interface + +!> private helper routines + interface data_sum + module procedure data_sum_r4 + module procedure data_sum_r8 + end interface + + interface stats + module procedure stats_r4 + module procedure stats_r8 + end interface + + interface horiz_interp_conserve_version1 + module procedure horiz_interp_conserve_version1_r8 + module procedure horiz_interp_conserve_version1_r4 + end interface + + interface horiz_interp_conserve_version2 + module procedure horiz_interp_conserve_version2_r8 + module procedure horiz_interp_conserve_version2_r4 + end interface + + + !> @addtogroup horiz_interp_conserve_mod !> @{ public :: horiz_interp_conserve_init @@ -111,8 +143,6 @@ module horiz_interp_conserve_mod contains - !####################################################################### - !> Writes version number to logfile. subroutine horiz_interp_conserve_init @@ -125,796 +155,7 @@ subroutine horiz_interp_conserve_init end subroutine horiz_interp_conserve_init - !####################################################################### - - subroutine horiz_interp_conserve_new_1dx1d ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - - !----------------------------------------------------------------------- - real, dimension(size(lat_out(:))-1,2) :: sph - real, dimension(size(lon_out(:))-1,2) :: theta - real, dimension(size(lat_in(:))) :: slat_in - real, dimension(size(lon_in(:))-1) :: dlon_in - real, dimension(size(lat_in(:))-1) :: dsph_in - real, dimension(size(lon_out(:))-1) :: dlon_out - real, dimension(size(lat_out(:))-1) :: dsph_out - real :: blon, fac, hpi, tpi, eps - integer :: num_iters = 4 - integer :: i, j, m, n, nlon_in, nlat_in, nlon_out, nlat_out, & - iverbose, m2, n2, iter - logical :: s2n - character(len=64) :: mesg - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx1d: horiz_interp_conserve_init is not called') - - if(great_circle_algorithm) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx1d: great_circle_algorithm is not implemented, contact developer') - !----------------------------------------------------------------------- - iverbose = 0; if (present(verbose)) iverbose = verbose - - pe = mpp_pe() - root_pe = mpp_root_pe() - !----------------------------------------------------------------------- - hpi = 0.5*pi - tpi = 4.*hpi - Interp%version = 1 - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 - - allocate ( Interp % facj (nlat_out,2), Interp % jlat (nlat_out,2), & - Interp % faci (nlon_out,2), Interp % ilon (nlon_out,2), & - Interp % area_src (nlon_in, nlat_in), & - Interp % area_dst (nlon_out, nlat_out) ) - - !----------------------------------------------------------------------- - ! --- set-up for input grid boxes --- - - do j = 1, nlat_in+1 - slat_in(j) = sin(lat_in(j)) - enddo - - do j = 1, nlat_in - dsph_in(j) = abs(slat_in(j+1)-slat_in(j)) - enddo - - do i = 1,nlon_in - dlon_in(i) = abs(lon_in(i+1)-lon_in(i)) - enddo - - ! set south to north flag - s2n = .true. - if (lat_in(1) > lat_in(nlat_in+1)) s2n = .false. - - !----------------------------------------------------------------------- - ! --- set-up for output grid boxes --- - - do n = 1, nlat_out - dsph_out(n) = abs(sin(lat_out(n+1))-sin(lat_out(n))) - enddo - - do m = 1,nlon_out - theta(m,1) = lon_out(m) - theta(m,2) = lon_out(m+1) - dlon_out(m) = abs(lon_out(m+1)-lon_out(m)) - enddo - - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - !*********************************************************************** - - !------ set up latitudinal indexing ------ - !------ make sure output grid goes south to north ------ - - do n = 1, nlat_out - if (lat_out(n) < lat_out(n+1)) then - sph(n,1) = sin(lat_out(n)) - sph(n,2) = sin(lat_out(n+1)) - else - sph(n,1) = sin(lat_out(n+1)) - sph(n,2) = sin(lat_out(n)) - endif - enddo - - Interp%jlat = 0 - do n2 = 1, 2 ! looping on grid box edges - do n = 1, nlat_out ! looping on output latitudes - eps = 0.0 - do iter=1,num_iters - ! find indices from input latitudes - do j = 1, nlat_in - if ( (s2n .and. (slat_in(j)-sph(n,n2)) <= eps .and. & - (sph(n,n2)-slat_in(j+1)) <= eps) .or. & - (.not.s2n .and. (slat_in(j+1)-sph(n,n2)) <= eps .and. & - (sph(n,n2)-slat_in(j)) <= eps) ) then - Interp%jlat(n,n2) = j - ! weight with sin(lat) to exactly conserve area-integral - fac = (sph(n,n2)-slat_in(j))/(slat_in(j+1)-slat_in(j)) - if (s2n) then - if (n2 == 1) Interp%facj(n,n2) = 1.0 - fac - if (n2 == 2) Interp%facj(n,n2) = fac - else - if (n2 == 1) Interp%facj(n,n2) = fac - if (n2 == 2) Interp%facj(n,n2) = 1.0 - fac - endif - exit - endif - enddo - if ( Interp%jlat(n,n2) /= 0 ) exit - ! did not find this output grid edge in the input grid - ! increase tolerance for multiple passes - eps = epsilon(sph)*real(10**iter) - enddo - ! no match - if ( Interp%jlat(n,n2) == 0 ) then - write (mesg,710) n,sph(n,n2) -710 format (': n,sph=',i3,f14.7,40x) - call mpp_error(FATAL, 'horiz_interp_conserve_mod:no latitude index found'//trim(mesg)) - endif - enddo - enddo - - !------ set up longitudinal indexing ------ - - Interp%ilon = 0 - do m2 = 1, 2 ! looping on grid box edges - do m = 1, nlon_out ! looping on output longitudes - blon = theta(m,m2) - if ( blon < lon_in(1) ) blon = blon + tpi - if ( blon > lon_in(nlon_in+1) ) blon = blon - tpi - eps = 0.0 - do iter=1,num_iters - ! find indices from input longitudes - do i = 1, nlon_in - if ( (lon_in(i)-blon) <= eps .and. & - (blon-lon_in(i+1)) <= eps ) then - Interp%ilon(m,m2) = i - fac = (blon-lon_in(i))/(lon_in(i+1)-lon_in(i)) - if (m2 == 1) Interp%faci(m,m2) = 1.0 - fac - if (m2 == 2) Interp%faci(m,m2) = fac - exit - endif - enddo - if ( Interp%ilon(m,m2) /= 0 ) exit - ! did not find this output grid edge in the input grid - ! increase tolerance for multiple passes - eps = epsilon(blon)*real(10**iter) - enddo - ! no match - if ( Interp%ilon(m,m2) == 0 ) then - print *, 'lon_out,blon,blon_in,eps=', & - theta(m,m2),blon,lon_in(1),lon_in(nlon_in+1),eps - call mpp_error(FATAL, 'horiz_interp_conserve_mod: no longitude index found') - endif - enddo - enddo - - ! --- area of input grid boxes --- - - do j = 1,nlat_in - do i = 1,nlon_in - Interp%area_src(i,j) = dlon_in(i) * dsph_in(j) - enddo - enddo - - ! --- area of output grid boxes --- - - do n = 1, nlat_out - do m = 1, nlon_out - Interp%area_dst(m,n) = dlon_out(m) * dsph_out(n) - enddo - enddo - - !----------------------------------------------------------------------- - ! this output may be quite lengthy and is not recommended - ! when using more than one processor - if (iverbose > 2) then - write (*,801) (i,Interp%ilon(i,1),Interp%ilon(i,2), & - Interp%faci(i,1),Interp%faci(i,2),i=1,nlon_out) - write (*,802) (j,Interp%jlat(j,1),Interp%jlat(j,2), & - Interp%facj(j,1),Interp%facj(j,2),j=1,nlat_out) -801 format (/,2x,'i',4x,'is',5x,'ie',4x,'facis',4x,'facie', & - /,(i4,2i7,2f10.5)) -802 format (/,2x,'j',4x,'js',5x,'je',4x,'facjs',4x,'facje', & - /,(i4,2i7,2f10.5)) - endif - !----------------------------------------------------------------------- - - end subroutine horiz_interp_conserve_new_1dx1d - - !####################################################################### - - subroutine horiz_interp_conserve_new_1dx2d ( Interp, lon_in, lat_in, lon_out, lat_out, & - mask_in, mask_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(in), optional, dimension(:,:) :: mask_in - real, intent(inout), optional, dimension(:,:) :: mask_out - integer, intent(in), optional :: verbose - - - integer :: create_xgrid_1DX2D_order1, get_maxxgrid, maxxgrid - integer :: create_xgrid_great_circle - integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j - real(DOUBLE_KIND), dimension(size(lon_in(:))-1, size(lat_in(:))-1) :: mask_src - integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst - real(DOUBLE_KIND), allocatable, dimension(:) :: xgrid_area, clon, clat - real(DOUBLE_KIND), allocatable, dimension(:,:) :: dst_area, lon_src, lat_src - real(DOUBLE_KIND), allocatable, dimension(:) :: lat_in_flip - real(DOUBLE_KIND), allocatable, dimension(:,:) :: mask_src_flip - real(DOUBLE_KIND), allocatable, dimension(:) :: lon_in_r8, lat_in_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 - - integer :: nincrease, ndecrease - logical :: flip_lat - integer :: wordsz - integer(kind=1) :: one_byte(8) - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx2d: horiz_interp_conserve_init is not called') - - wordsz=size(transfer(lon_in(1), one_byte)) - if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx2d: wordsz should be 4 or 8') - - if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') - nlon_in = size(lon_in(:)) - 1; nlat_in = size(lat_in(:)) - 1 - nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 - - mask_src = 1. - if(present(mask_in)) then - if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') - mask_src = mask_in - end if - - maxxgrid = get_maxxgrid() - allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) - allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) - - !--- check if source latitude is flipped - nincrease = 0 - ndecrease = 0 - do j = 1, nlat_in - if( lat_in(j+1) > lat_in(j) ) then - nincrease = nincrease + 1 - else if ( lat_in(j+1) < lat_in(j) ) then - ndecrease = ndecrease + 1 - endif - enddo - - if(nincrease == nlat_in) then - flip_lat = .false. - else if(ndecrease == nlat_in) then - flip_lat = .true. - else - call mpp_error(FATAL, 'horiz_interp_conserve_mod: nlat_in should be equal to nincreaase or ndecrease') - endif - - allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) - allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) - lon_out_r8 = lon_out - lat_out_r8 = lat_out - - if( .not. great_circle_algorithm ) then - if(flip_lat) then - allocate(lat_in_flip(nlat_in+1), mask_src_flip(nlon_in,nlat_in)) - do j = 1, nlat_in+1 - lat_in_flip(j) = lat_in(nlat_in+2-j) - enddo - do j = 1, nlat_in - mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) - enddo - allocate(lon_in_r8(size(lon_in))) - lon_in_r8 = lon_in - nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_flip, & - lon_out_r8, lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area) - deallocate(lon_in_r8, lat_in_flip, mask_src_flip) - else - allocate(lon_in_r8(size(lon_in))) - allocate(lat_in_r8(size(lat_in))) - lon_in_r8 = lon_in - lat_in_r8 = lat_in - nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) - deallocate(lon_in_r8,lat_in_r8) - endif - else - allocate(lon_src(nlon_in+1,nlat_in+1), lat_src(nlon_in+1,nlat_in+1)) - allocate(clon(maxxgrid), clat(maxxgrid)) - if(flip_lat) then - allocate(mask_src_flip(nlon_in,nlat_in)) - do j = 1, nlat_in+1 - do i = 1, nlon_in+1 - lon_src(i,j) = lon_in(i) - lat_src(i,j) = lat_in(nlat_in+2-j) - enddo - enddo - do j = 1, nlat_in - mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) - enddo - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & - & lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - deallocate(mask_src_flip) - else - do j = 1, nlat_in+1 - do i = 1, nlon_in+1 - lon_src(i,j) = lon_in(i) - lat_src(i,j) = lat_in(j) - enddo - enddo - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - endif - deallocate(lon_src, lat_src, clon, clat) - endif - - deallocate(lon_out_r8, lat_out_r8) - - allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) - allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) - allocate(Interp%area_frac_dst(nxgrid) ) - Interp%version = 2 - Interp%nxgrid = nxgrid - Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 - Interp%j_src = j_src(1:nxgrid)+1 - if(flip_lat) Interp%j_src = nlat_in+1-Interp%j_src - Interp%i_dst = i_dst(1:nxgrid)+1 - Interp%j_dst = j_dst(1:nxgrid)+1 - - ! sum over exchange grid area to get destination grid area - dst_area = 0. - do i = 1, nxgrid - dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) - end do - - do i = 1, nxgrid - Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ) - end do - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - if(present(mask_out)) then - if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') - mask_out = 0.0 - do i = 1, nxgrid - mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & - & Interp%j_dst(i)) + Interp%area_frac_dst(i) - end do - end if - - deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) - - end subroutine horiz_interp_conserve_new_1dx2d - - !####################################################################### - - subroutine horiz_interp_conserve_new_2dx1d ( Interp, lon_in, lat_in, lon_out, lat_out, & - mask_in, mask_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - real, intent(in), optional, dimension(:,:) :: mask_in - real, intent(inout), optional, dimension(:,:) :: mask_out - integer, intent(in), optional :: verbose - - integer :: create_xgrid_2DX1D_order1, get_maxxgrid, maxxgrid - integer :: create_xgrid_great_circle - integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j - integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst - real, allocatable, dimension(:,:) :: dst_area - real(DOUBLE_KIND), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src - real(DOUBLE_KIND), allocatable, dimension(:) :: xgrid_area, clon, clat - real(DOUBLE_KIND), allocatable, dimension(:) :: lon_out_r8, lat_out_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_dst, lat_dst - integer :: wordsz - integer(kind=1) :: one_byte(8) - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx1d: horiz_interp_conserve_init is not called') - - wordsz=size(transfer(lon_in(1,1), one_byte)) - if(wordsz .NE. 8) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx1d: currently only support 64-bit real, contact developer') - - if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') - nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 - nlon_out = size(lon_out(:)) - 1; nlat_out = size(lat_out(:)) - 1 - - mask_src = 1. - if(present(mask_in)) then - if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') - mask_src = mask_in - end if - - maxxgrid = get_maxxgrid() - allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) - allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) - - if( .not. great_circle_algorithm ) then - allocate(lon_out_r8(size(lon_out))) - allocate(lat_out_r8(size(lat_out))) - lon_out_r8 = lon_out - lat_out_r8 = lat_out - nxgrid = create_xgrid_2DX1D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, & - mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) - deallocate(lon_out_r8,lat_out_r8) - else - allocate(lon_in_r8(size(lon_in,1),size(lon_in,2))) - allocate(lat_in_r8(size(lat_in,1),size(lat_in,2))) - lon_in_r8 = lon_in - lat_in_r8 = lat_in - allocate(lon_dst(nlon_out+1, nlat_out+1), lat_dst(nlon_out+1, nlat_out+1) ) - allocate(clon(maxxgrid), clat(maxxgrid)) - do j = 1, nlat_out+1 - do i = 1, nlon_out+1 - lon_dst(i,j) = lon_out(i) - lat_dst(i,j) = lat_out(j) - enddo - enddo - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_dst, & - & lat_dst, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - deallocate(lon_in_r8, lat_in_r8, lon_dst, lat_dst, clon, clat) - endif - allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) - allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) - allocate(Interp%area_frac_dst(nxgrid) ) - Interp%version = 2 - Interp%nxgrid = nxgrid - Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 - Interp%j_src = j_src(1:nxgrid)+1 - Interp%i_dst = i_dst(1:nxgrid)+1 - Interp%j_dst = j_dst(1:nxgrid)+1 - - ! sum over exchange grid area to get destination grid area - dst_area = 0. - do i = 1, nxgrid - dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) - end do - - do i = 1, nxgrid - Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ) - end do - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - if(present(mask_out)) then - if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') - mask_out = 0.0 - do i = 1, nxgrid - mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & - & Interp%j_dst(i)) + Interp%area_frac_dst(i) - end do - end if - - deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area) - - end subroutine horiz_interp_conserve_new_2dx1d - - !####################################################################### - - subroutine horiz_interp_conserve_new_2dx2d ( Interp, lon_in, lat_in, lon_out, lat_out, & - mask_in, mask_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(in), optional, dimension(:,:) :: mask_in - real, intent(inout), optional, dimension(:,:) :: mask_out - integer, intent(in), optional :: verbose - - integer :: create_xgrid_2DX2D_order1, get_maxxgrid, maxxgrid - integer :: create_xgrid_great_circle - integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i - integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst - real(DOUBLE_KIND), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src - real(DOUBLE_KIND), allocatable, dimension(:) :: xgrid_area, clon, clat - real(DOUBLE_KIND), allocatable, dimension(:,:) :: dst_area - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 - integer :: wordsz - integer(kind=1) :: one_byte(8) - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx2d: horiz_interp_conserve_init is not called') - - wordsz=size(transfer(lon_in(1,1), one_byte)) - if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx2d: wordsz should be 4 or 8') - - if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') - if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') - nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 - nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 - - mask_src = 1. - if(present(mask_in)) then - if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') - mask_src = mask_in - end if - - maxxgrid = get_maxxgrid() - allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) - allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) - - allocate(lon_in_r8(size(lon_in,1),size(lon_in,2))) - allocate(lat_in_r8(size(lat_in,1),size(lat_in,2))) - allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) - allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) - lon_in_r8 = lon_in - lat_in_r8 = lat_in - lon_out_r8 = lon_out - lat_out_r8 = lat_out - - if( .not. great_circle_algorithm ) then - nxgrid = create_xgrid_2DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) - else - allocate(clon(maxxgrid), clat(maxxgrid)) - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - deallocate(clon, clat) - endif - - deallocate(lon_in_r8, lat_in_r8, lon_out_r8, lat_out_r8) - - allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) - allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) - allocate(Interp%area_frac_dst(nxgrid) ) - Interp%version = 2 - Interp%nxgrid = nxgrid - Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 - Interp%j_src = j_src(1:nxgrid)+1 - Interp%i_dst = i_dst(1:nxgrid)+1 - Interp%j_dst = j_dst(1:nxgrid)+1 - - ! sum over exchange grid area to get destination grid area - dst_area = 0. - do i = 1, nxgrid - dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) - end do - - do i = 1, nxgrid - Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ) - end do - - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - if(present(mask_out)) then - if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') - mask_out = 0.0 - do i = 1, nxgrid - mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & - & Interp%j_dst(i)) + Interp%area_frac_dst(i) - end do - end if - - deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) - - end subroutine horiz_interp_conserve_new_2dx2d - - !######################################################################## - - !> @brief Subroutine for performing the horizontal interpolation between two grids. - !! - !> Subroutine for performing the horizontal interpolation between two grids. - !! horiz_interp_conserve_new must be called before calling this routine. - subroutine horiz_interp_conserve ( Interp, data_in, data_out, verbose, & - mask_in, mask_out) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in !< Input data on source grid - real, intent(out), dimension(:,:) :: data_out !< Output data on destination grid - integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; - !! 2 = max output - real, intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as - !! the input data. The real value of mask_in must be in the range (0.,1.). - !! Set mask_in=0.0 for data points that should not be used or have missing - !! data. mask_in will be applied only when horiz_interp_conserve_new_1d is - !! called. mask_in will be passed into horiz_interp_conserve_new_2d - real, intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether - !! data was computed. mask_out will be computed only when - !! horiz_interp_conserve_new_1d is called. mask_out will be computed in - !! horiz_interp_conserve_new_2d - - ! --- error checking --- - if (size(data_in,1) /= Interp%nlon_src .or. size(data_in,2) /= Interp%nlat_src) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of input array incorrect') - - if (size(data_out,1) /= Interp%nlon_dst .or. size(data_out,2) /= Interp%nlat_dst) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of output array incorrect') - - select case ( Interp%version) - case (1) - call horiz_interp_conserve_version1(Interp, data_in, data_out, verbose, mask_in, mask_out) - case (2) - if(present(mask_in) .OR. present(mask_out) ) call mpp_error(FATAL, 'horiz_interp_conserve:'// & - & ' for version 2, mask_in and mask_out must be passed in horiz_interp_new, not in horiz_interp') - call horiz_interp_conserve_version2(Interp, data_in, data_out, verbose) - end select - - end subroutine horiz_interp_conserve - - !############################################################################## - subroutine horiz_interp_conserve_version1 ( Interp, data_in, data_out, verbose, & - mask_in, mask_out) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - !----------local variables---------------------------------------------------- - integer :: m, n, nlon_in, nlat_in, nlon_out, nlat_out, & - miss_in, miss_out, is, ie, js, je, & - np, npass, iverbose - real :: dsum, wsum, avg_in, min_in, max_in, & - avg_out, min_out, max_out, eps, asum, & - dwtsum, wtsum, arsum, fis, fie, fjs, fje - !----------------------------------------------------------------------- - iverbose = 0; if (present(verbose)) iverbose = verbose - - eps = epsilon(wtsum) - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - if (present(mask_in)) then - if ( count(mask_in < -.0001 .or. mask_in > 1.0001) > 0 ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: input mask not between 0,1') - endif - - !----------------------------------------------------------------------- - !---- loop through output grid boxes ---- - - data_out = 0.0 - do n = 1, nlat_out - ! latitude window - ! setup ascending latitude indices and weights - if (Interp%jlat(n,1) <= Interp%jlat(n,2)) then - js = Interp%jlat(n,1); je = Interp%jlat(n,2) - fjs = Interp%facj(n,1); fje = Interp%facj(n,2) - else - js = Interp%jlat(n,2); je = Interp%jlat(n,1) - fjs = Interp%facj(n,2); fje = Interp%facj(n,1) - endif - - do m = 1, nlon_out - ! longitude window - is = Interp%ilon(m,1); ie = Interp%ilon(m,2) - fis = Interp%faci(m,1); fie = Interp%faci(m,2) - npass = 1 - dwtsum = 0. - wtsum = 0. - arsum = 0. - - ! wrap-around on input grid - ! sum using 2 passes (pass 1: end of input grid) - if ( ie < is ) then - ie = nlon_in - fie = 1.0 - npass = 2 - endif - - do np = 1, npass - ! pass 2: beginning of input grid - if ( np == 2 ) then - is = 1 - fis = 1.0 - ie = Interp%ilon(m,2) - fie = Interp%faci(m,2) - endif - - ! summing data*weight and weight for single grid point - if (present(mask_in)) then - call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), & - fis, fie, fjs,fje, dwtsum, wtsum, arsum, mask_in(is:ie,js:je) ) - else if( allocated(Interp%mask_in) ) then - call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), & - fis, fie, fjs,fje, dwtsum, wtsum, arsum, Interp%mask_in(is:ie,js:je) ) - else - call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), & - fis, fie, fjs,fje, dwtsum, wtsum, arsum ) - endif - enddo - - if (wtsum > eps) then - data_out(m,n) = dwtsum/wtsum - if (present(mask_out)) mask_out(m,n) = wtsum/arsum - else - data_out(m,n) = 0. - if (present(mask_out)) mask_out(m,n) = 0.0 - endif - - enddo - enddo - - !*********************************************************************** - ! compute statistics: minimum, maximum, and mean - !----------------------------------------------------------------------- - - if (iverbose > 0) then - - ! compute statistics of input data - - call stats(data_in, Interp%area_src, asum, dsum, wsum, min_in, max_in, miss_in, mask_in) - ! diagnostic messages - ! on the root_pe, we can calculate the global mean, minimum and maximum. - if(pe == root_pe) then - if (wsum > 0.0) then - avg_in=dsum/wsum - else - print *, 'horiz_interp stats: input area equals zero ' - avg_in=0.0 - endif - if (iverbose > 1) print '(2f16.11)', 'global sum area_in = ', asum, wsum - endif - - ! compute statistics of output data - call stats(data_out, Interp%area_dst, asum, dsum, wsum, min_out, max_out, miss_out, mask_out) - ! diagnostic messages - if(pe == root_pe) then - if (wsum > 0.0) then - avg_out=dsum/wsum - else - print *, 'horiz_interp stats: output area equals zero ' - avg_out=0.0 - endif - if (iverbose > 1) print '(2f16.11)', 'global sum area_out = ', asum, wsum - endif - !---- output statistics ---- - ! the global mean, min and max are calculated on the root pe. - if(pe == root_pe) then - write (*,900) - write (*,901) min_in ,max_in ,avg_in - if (present(mask_in)) write (*,903) miss_in - write (*,902) min_out,max_out,avg_out - if (present(mask_out)) write (*,903) miss_out - endif - -900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) -901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) -902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) -903 format (' number of missing points = ',i6) - - endif - - !----------------------------------------------------------------------- - end subroutine horiz_interp_conserve_version1 - - !############################################################################# - subroutine horiz_interp_conserve_version2 ( Interp, data_in, data_out, verbose ) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - integer :: i, i_src, j_src, i_dst, j_dst - - data_out = 0.0 - do i = 1, Interp%nxgrid - i_src = Interp%i_src(i); j_src = Interp%j_src(i) - i_dst = Interp%i_dst(i); j_dst = Interp%j_dst(i) - data_out(i_dst, j_dst) = data_out(i_dst, j_dst) + data_in(i_src,j_src)*Interp%area_frac_dst(i) - end do - - end subroutine horiz_interp_conserve_version2 - - !####################################################################### - - !> Deallocates memory used by "horiz_interp_type" variables. + !> Deallocates memory used by "HI_KIND_TYPE" variables. !! Must be called before reinitializing with horiz_interp_new. subroutine horiz_interp_conserve_del ( Interp ) @@ -924,134 +165,45 @@ subroutine horiz_interp_conserve_del ( Interp ) select case(Interp%version) case (1) - if(allocated(Interp%area_src)) deallocate(Interp%area_src) - if(allocated(Interp%area_dst)) deallocate(Interp%area_dst) - if(allocated(Interp%facj)) deallocate(Interp%facj) - if(allocated(Interp%jlat)) deallocate(Interp%jlat) - if(allocated(Interp%faci)) deallocate(Interp%faci) - if(allocated(Interp%ilon)) deallocate(Interp%ilon) + if( Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%area_src)) deallocate(Interp%horizInterpReals8_type%area_src) + if(allocated(Interp%horizInterpReals8_type%area_dst)) deallocate(Interp%horizInterpReals8_type%area_dst) + if(allocated(Interp%horizInterpReals8_type%facj)) deallocate(Interp%horizInterpReals8_type%facj) + if(allocated(Interp%jlat)) deallocate(Interp%jlat) + if(allocated(Interp%horizInterpReals8_type%faci)) deallocate(Interp%horizInterpReals8_type%faci) + if(allocated(Interp%ilon)) deallocate(Interp%ilon) + else if( Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%area_src)) deallocate(Interp%horizInterpReals4_type%area_src) + if(allocated(Interp%horizInterpReals4_type%area_dst)) deallocate(Interp%horizInterpReals4_type%area_dst) + if(allocated(Interp%horizInterpReals4_type%facj)) deallocate(Interp%horizInterpReals4_type%facj) + if(allocated(Interp%jlat)) deallocate(Interp%jlat) + if(allocated(Interp%horizInterpReals4_type%faci)) deallocate(Interp%horizInterpReals4_type%faci) + if(allocated(Interp%ilon)) deallocate(Interp%ilon) + endif case (2) - if(allocated(Interp%i_src)) deallocate(Interp%i_src) - if(allocated(Interp%j_src)) deallocate(Interp%j_src) - if(allocated(Interp%i_dst)) deallocate(Interp%i_dst) - if(allocated(Interp%j_dst)) deallocate(Interp%j_dst) - if(allocated(Interp%area_frac_dst)) deallocate(Interp%area_frac_dst) + if( Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%i_src)) deallocate(Interp%i_src) + if(allocated(Interp%j_src)) deallocate(Interp%j_src) + if(allocated(Interp%i_dst)) deallocate(Interp%i_dst) + if(allocated(Interp%j_dst)) deallocate(Interp%j_dst) + if(allocated(Interp%horizInterpReals8_type%area_frac_dst)) & + deallocate(Interp%horizInterpReals8_type%area_frac_dst) + else if( Interp%horizInterpReals4_type%is_allocated ) then + if(allocated(Interp%i_src)) deallocate(Interp%i_src) + if(allocated(Interp%j_src)) deallocate(Interp%j_src) + if(allocated(Interp%i_dst)) deallocate(Interp%i_dst) + if(allocated(Interp%j_dst)) deallocate(Interp%j_dst) + if(allocated(Interp%horizInterpReals4_type%area_frac_dst)) & + deallocate(Interp%horizInterpReals4_type%area_frac_dst) + endif end select + Interp%horizInterpReals4_type%is_allocated = .false. + Interp%horizInterpReals8_type%is_allocated = .false. end subroutine horiz_interp_conserve_del - !####################################################################### - !> This statistics is for conservative scheme - subroutine stats ( dat, area, asum, dsum, wsum, low, high, miss, mask ) - real, intent(in) :: dat(:,:), area(:,:) - real, intent(out) :: asum, dsum, wsum, low, high - integer, intent(out) :: miss - real, intent(in), optional :: mask(:,:) - - integer :: pe, root_pe, npes, p, buffer_int(1) - real :: buffer_real(5) - - pe = mpp_pe() - root_pe = mpp_root_pe() - npes = mpp_npes() - - ! sum data, data*area; and find min,max on each pe. - - if (present(mask)) then - asum = sum(area(:,:)) - dsum = sum(area(:,:)*dat(:,:)*mask(:,:)) - wsum = sum(area(:,:)*mask(:,:)) - miss = count(mask(:,:) <= 0.5) - low = minval(dat(:,:),mask=mask(:,:) > 0.5) - high = maxval(dat(:,:),mask=mask(:,:) > 0.5) - else - asum = sum(area(:,:)) - dsum = sum(area(:,:)*dat(:,:)) - wsum = sum(area(:,:)) - miss = 0 - low = minval(dat(:,:)) - high = maxval(dat(:,:)) - endif - - ! other pe send local min, max, avg to the root pe and - ! root pe receive these information - - if(pe == root_pe) then - do p = 1, npes - 1 - ! Force use of "scalar", integer pointer mpp interface - call mpp_recv(buffer_real(1),glen=5,from_pe=root_pe+p, tag=COMM_TAG_1) - asum = asum + buffer_real(1) - dsum = dsum + buffer_real(2) - wsum = wsum + buffer_real(3) - low = min(low, buffer_real(4)) - high = max(high, buffer_real(5)) - call mpp_recv(buffer_int(1),glen=1,from_pe=root_pe+p, tag=COMM_TAG_2) - miss = miss + buffer_int(1) - enddo - else - buffer_real(1) = asum - buffer_real(2) = dsum - buffer_real(3) = wsum - buffer_real(4) = low - buffer_real(5) = high - ! Force use of "scalar", integer pointer mpp interface - call mpp_send(buffer_real(1),plen=5,to_pe=root_pe, tag=COMM_TAG_1) - buffer_int(1) = miss - call mpp_send(buffer_int(1),plen=1,to_pe=root_pe, tag=COMM_TAG_2) - endif - - call mpp_sync_self() - - end subroutine stats - - !####################################################################### - - !> sums up the data and weights for a single output grid box - subroutine data_sum( data, area, facis, facie, facjs, facje, & - dwtsum, wtsum, arsum, mask ) - - !----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data, area - real, intent(in) :: facis, facie, facjs, facje - real, intent(inout) :: dwtsum, wtsum, arsum - real, intent(in), optional :: mask(:,:) - - ! fac__ = fractional portion of each boundary grid box included - ! in the integral - ! dwtsum = sum(data*area*mask) - ! wtsum = sum(area*mask) - ! arsum = sum(area) - !----------------------------------------------------------------------- - real, dimension(size(area,1),size(area,2)) :: wt - real :: asum - integer :: id, jd - !----------------------------------------------------------------------- - - id=size(area,1); jd=size(area,2) - - wt=area - wt( 1,:)=wt( 1,:)*facis - wt(id,:)=wt(id,:)*facie - wt(:, 1)=wt(:, 1)*facjs - wt(:,jd)=wt(:,jd)*facje - - asum = sum(wt) - arsum = arsum + asum - - if (present(mask)) then - wt = wt * mask - dwtsum = dwtsum + sum(wt*data) - wtsum = wtsum + sum(wt) - else - dwtsum = dwtsum + sum(wt*data) - wtsum = wtsum + asum - endif - !----------------------------------------------------------------------- - - end subroutine data_sum - - - !####################################################################### +#include "horiz_interp_conserve_r4.fh" +#include "horiz_interp_conserve_r8.fh" end module horiz_interp_conserve_mod !> @} diff --git a/horiz_interp/horiz_interp_spherical.F90 b/horiz_interp/horiz_interp_spherical.F90 index 8a00ea9b76..128b7fd47d 100644 --- a/horiz_interp/horiz_interp_spherical.F90 +++ b/horiz_interp/horiz_interp_spherical.F90 @@ -29,6 +29,7 @@ !> @{ module horiz_interp_spherical_mod + use platform_mod, only : r4_kind, r8_kind use mpp_mod, only : mpp_error, FATAL, WARNING, stdout use mpp_mod, only : mpp_root_pe, mpp_pe use mpp_mod, only : input_nml_file @@ -40,15 +41,45 @@ module horiz_interp_spherical_mod implicit none private + interface horiz_interp_spherical + module procedure horiz_interp_spherical_r4 + module procedure horiz_interp_spherical_r8 + end interface + + interface horiz_interp_spherical_new + module procedure horiz_interp_spherical_new_r4 + module procedure horiz_interp_spherical_new_r8 + end interface + + interface horiz_interp_spherical_wght + module procedure horiz_interp_spherical_wght_r4 + module procedure horiz_interp_spherical_wght_r8 + end interface public :: horiz_interp_spherical_new, horiz_interp_spherical, horiz_interp_spherical_del public :: horiz_interp_spherical_init, horiz_interp_spherical_wght + !> private helper routines + interface full_search + module procedure full_search_r4 + module procedure full_search_r8 + end interface + + interface radial_search + module procedure radial_search_r4 + module procedure radial_search_r8 + end interface + + interface spherical_distance + module procedure spherical_distance_r4 + module procedure spherical_distance_r8 + end interface + integer, parameter :: max_neighbors = 400 - real, parameter :: max_dist_default = 0.1 ! radians + real(R8_KIND), parameter :: max_dist_default = 0.1_r8_kind ! radians integer, parameter :: num_nbrs_default = 4 - real, parameter :: large=1.e20 - real, parameter :: epsln=1.e-10 + real(R8_KIND), parameter :: large=1.e20_r8_kind + real(R8_KIND), parameter :: epsln=1.e-10_r8_kind integer :: pe, root_pe @@ -87,414 +118,13 @@ subroutine horiz_interp_spherical_init read (input_nml_file, horiz_interp_spherical_nml, iostat=io) ierr = check_nml_error(io,'horiz_interp_spherical_nml') - module_is_initialized = .true. - - - -end subroutine horiz_interp_spherical_init - - !####################################################################### - - !> Initialization routine. - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_spherical_new(Interp, lon_in,lat_in,lon_out,lat_out, & - num_nbrs, max_dist, src_modulo) - - type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices - !! and weights for subsequent interpolations. To - !! reinitialize for different grid-to-grid interpolation - !! @ref horiz_interp_del must be used first. - real, intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid - real, intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid - logical, intent(in), optional :: src_modulo !< indicates if the boundary condition - !! along zonal boundary is cyclic or not. Cyclic when true - integer, intent(in), optional :: num_nbrs !< Number of nearest neighbors for regridding - !! When number of neighbors within the radius max_dist - !! is less than num_nbrs, All the neighbors will be used - !! to interpolate onto destination grid. when number of - !! neighbors within the radius max_dist is greater than - !! num_nbrs, at least "num_nbrs" - ! neighbors will be used to remap onto destination grid - real, optional, intent(in) :: max_dist !< Maximum region of influence around - !! destination grid points - - !------local variables --------------------------------------- - integer :: i, j, n - integer :: map_dst_xsize, map_dst_ysize, map_src_xsize, map_src_ysize - integer :: map_src_size, num_neighbors - real :: max_src_dist, tpi, hpi - logical :: src_is_modulo - real :: min_theta_dst, max_theta_dst, min_phi_dst, max_phi_dst - real :: min_theta_src, max_theta_src, min_phi_src, max_phi_src - integer :: map_src_add(size(lon_out,1),size(lon_out,2),max_neighbors) - real :: map_src_dist(size(lon_out,1),size(lon_out,2),max_neighbors) - integer :: num_found(size(lon_out,1),size(lon_out,2)) - integer :: ilon(max_neighbors), jlat(max_neighbors) - real, dimension(size(lon_out,1),size(lon_out,2)) :: theta_dst, phi_dst - real, dimension(size(lon_in,1)*size(lon_in,2)) :: theta_src, phi_src - - !-------------------------------------------------------------- - - pe = mpp_pe() - root_pe = mpp_root_pe() - - tpi = 2.0*PI; hpi = 0.5*PI - - num_neighbors = num_nbrs_default - if(present(num_nbrs)) num_neighbors = num_nbrs - if (num_neighbors <= 0) call mpp_error(FATAL,'horiz_interp_spherical_mod: num_neighbors must be > 0') - - max_src_dist = max_dist_default - if (PRESENT(max_dist)) max_src_dist = max_dist - Interp%max_src_dist = max_src_dist - - src_is_modulo = .true. - if (PRESENT(src_modulo)) src_is_modulo = src_modulo - - !--- check the grid size comformable - map_dst_xsize=size(lon_out,1);map_dst_ysize=size(lon_out,2) - map_src_xsize=size(lon_in,1); map_src_ysize=size(lon_in,2) - map_src_size = map_src_xsize*map_src_ysize - - if (map_dst_xsize /= size(lat_out,1) .or. map_dst_ysize /= size(lat_out,2)) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: destination grids not conformable') - if (map_src_xsize /= size(lat_in,1) .or. map_src_ysize /= size(lat_in,2)) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: source grids not conformable') - - theta_src = reshape(lon_in,(/map_src_size/)) - phi_src = reshape(lat_in,(/map_src_size/)) - theta_dst(:,:) = lon_out(:,:) - phi_dst(:,:) = lat_out(:,:) - - min_theta_dst=tpi;max_theta_dst=0.0;min_phi_dst=pi;max_phi_dst=-pi - min_theta_src=tpi;max_theta_src=0.0;min_phi_src=pi;max_phi_src=-pi - - where(theta_dst<0.0) theta_dst = theta_dst+tpi - where(theta_dst>tpi) theta_dst = theta_dst-tpi - where(theta_src<0.0) theta_src = theta_src+tpi - where(theta_src>tpi) theta_src = theta_src-tpi - - where(phi_dst < -hpi) phi_dst = -hpi - where(phi_dst > hpi) phi_dst = hpi - where(phi_src < -hpi) phi_src = -hpi - where(phi_src > hpi) phi_src = hpi - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - min_theta_dst = min(min_theta_dst,theta_dst(i,j)) - max_theta_dst = max(max_theta_dst,theta_dst(i,j)) - min_phi_dst = min(min_phi_dst,phi_dst(i,j)) - max_phi_dst = max(max_phi_dst,phi_dst(i,j)) - enddo - enddo - - do i=1,map_src_size - min_theta_src = min(min_theta_src,theta_src(i)) - max_theta_src = max(max_theta_src,theta_src(i)) - min_phi_src = min(min_phi_src,phi_src(i)) - max_phi_src = max(max_phi_src,phi_src(i)) - enddo - - if (min_phi_dst < min_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' - if (max_phi_dst > max_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' - ! when src is cyclic, no need to print out the following warning. - if(.not. src_is_modulo) then - if (min_theta_dst < min_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' - if (max_theta_dst > max_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' - endif - - ! allocate memory to data type - if(allocated(Interp%i_lon)) then - if(size(Interp%i_lon,1) .NE. map_dst_xsize .OR. & - size(Interp%i_lon,2) .NE. map_dst_ysize ) call mpp_error(FATAL, & - 'horiz_interp_spherical_mod: size(Interp%i_lon(:),1) .NE. map_dst_xsize .OR. '// & - 'size(Interp%i_lon(:),2) .NE. map_dst_ysize') - else - allocate(Interp%i_lon(map_dst_xsize,map_dst_ysize,max_neighbors), & - Interp%j_lat(map_dst_xsize,map_dst_ysize,max_neighbors), & - Interp%src_dist(map_dst_xsize,map_dst_ysize,max_neighbors), & - Interp%num_found(map_dst_xsize,map_dst_ysize) ) - endif - - map_src_add = 0 - map_src_dist = large - num_found = 0 - - !using radial_search to find the nearest points and corresponding distance. - - select case(trim(search_method)) - case ("radial_search") ! will be efficient, but may be not so accurate for some cases - call radial_search(theta_src, phi_src, theta_dst, phi_dst, map_src_xsize, map_src_ysize, & - map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) - case ("full_search") ! always accurate, but less efficient. - call full_search(theta_src, phi_src, theta_dst, phi_dst, map_src_add, map_src_dist, & - num_found, num_neighbors,max_src_dist ) - case default - call mpp_error(FATAL,"horiz_interp_spherical_new: nml search_method = "// & - trim(search_method)//" is not a valid namelist option") - end select - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - do n=1,num_found(i,j) - if(map_src_add(i,j,n) == 0) then - jlat(n) = 0; ilon(n) = 0 - else - jlat(n) = map_src_add(i,j,n)/map_src_xsize + 1 - ilon(n) = map_src_add(i,j,n) - (jlat(n)-1)*map_src_xsize - if(ilon(n) == 0) then - jlat(n) = jlat(n) - 1 - ilon(n) = map_src_xsize - endif - endif - enddo - Interp%i_lon(i,j,:) = ilon(:) - Interp%j_lat(i,j,:) = jlat(:) - Interp%num_found(i,j) = num_found(i,j) - Interp%src_dist(i,j,:) = map_src_dist(i,j,:) - enddo - enddo - - Interp%nlon_src = map_src_xsize; Interp%nlat_src = map_src_ysize - Interp%nlon_dst = map_dst_xsize; Interp%nlat_dst = map_dst_ysize - - return - - end subroutine horiz_interp_spherical_new - - !####################################################################### - - !> Subroutine for performing the horizontal interpolation between two grids. - !! horiz_interp_spherical_new must be called before calling this routine. - subroutine horiz_interp_spherical( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value) - type(horiz_interp_type), intent(in) :: Interp !< A derived type variable containing indices - !! and weights for subsequent interpolations. Returned - !! by a previous call to horiz_interp_spherical_new - real, intent(in), dimension(:,:) :: data_in !< Input data on source grid - real, intent(out), dimension(:,:) :: data_out !< Output data on destination grid - integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = most output - real, intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as - !! the input data. The real value of mask_in must be - !! in the range (0.,1.). Set mask_in=0.0 for data points - !! that should not be used or have missing data - real, intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether data was computed. - real, intent(in), optional :: missing_value !< Used to indicate missing data - - !--- some local variables ---------------------------------------- - real, dimension(Interp%nlon_dst, Interp%nlat_dst,size(Interp%src_dist,3)) :: wt - real, dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src - real, dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst - integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found - integer :: m, n, i, j, k, miss_in, miss_out, i1, i2, j1, j2, iverbose - real :: min_in, max_in, avg_in, min_out, max_out, avg_out, sum - !----------------------------------------------------------------- - - iverbose = 0; if (present(verbose)) iverbose = verbose - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - if(size(data_in,1) .ne. nlon_in .or. size(data_in,2) .ne. nlat_in ) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: size of input array incorrect') - - if(size(data_out,1) .ne. nlon_out .or. size(data_out,2) .ne. nlat_out ) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: size of output array incorrect') - - mask_src = 1.0; mask_dst = 1.0 - if(present(mask_in)) mask_src = mask_in - - do n=1,nlat_out - do m=1,nlon_out - ! neighbors are sorted nearest to farthest - ! check nearest to see if it is a land point - num_found = Interp%num_found(m,n) - if(num_found == 0 ) then - mask_dst(m,n) = 0.0 - else - i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) - if (mask_src(i1,j1) .lt. 0.5) then - mask_dst(m,n) = 0.0 - endif - - if(num_found .gt. 1 ) then - i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) - ! compare first 2 nearest neighbors -- if they are nearly - ! equidistant then use this mask for robustness - if(abs(Interp%src_dist(m,n,2)-Interp%src_dist(m,n,1)) .lt. epsln) then - if((mask_src(i1,j1) .lt. 0.5)) mask_dst(m,n) = 0.0 - endif - endif - - sum=0.0 - do k=1, num_found - if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5 ) then - wt(m,n,k) = 0.0 - else - if (Interp%src_dist(m,n,k) <= epsln) then - wt(m,n,k) = large - sum = sum + large - else if(Interp%src_dist(m,n,k) <= Interp%max_src_dist ) then - wt(m,n,k) = 1.0/Interp%src_dist(m,n,k) - sum = sum+wt(m,n,k) - else - wt(m,n,k) = 0.0 - endif - endif - enddo - if (sum > epsln) then - do k = 1, num_found - wt(m,n,k) = wt(m,n,k)/sum - enddo - else - mask_dst(m,n) = 0.0 - endif - endif - enddo - enddo - - data_out = 0.0 - do n=1,nlat_out - do m=1,nlon_out - if(mask_dst(m,n) .gt. 0.5) then - do k=1, Interp%num_found(m,n) - i = Interp%i_lon(m,n,k) - j = Interp%j_lat(m,n,k) - data_out(m,n) = data_out(m,n)+data_in(i,j)*wt(m,n,k) - enddo - else - if(present(missing_value)) then - data_out(m,n) = missing_value - else - data_out(m,n) = 0.0 - endif - endif - enddo - enddo - - if(present(mask_out)) mask_out = mask_dst - - !*********************************************************************** - ! compute statistics: minimum, maximum, and mean - !----------------------------------------------------------------------- - - if (iverbose > 0) then - - ! compute statistics of input data - - call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask=mask_src) - - ! compute statistics of output data - call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask=mask_dst) - - !---- output statistics ---- - ! root_pe have the information of global mean, min and max - if(pe == root_pe) then - write (*,900) - write (*,901) min_in ,max_in, avg_in - if (present(mask_in)) write (*,903) miss_in - write (*,902) min_out,max_out,avg_out - if (present(mask_out)) write (*,903) miss_out - endif -900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) -901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) -902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) -903 format (' number of missing points = ',i6) - - endif - - return - end subroutine horiz_interp_spherical + module_is_initialized = .true. - !####################################################################### - subroutine horiz_interp_spherical_wght( Interp, wt, verbose, mask_in, mask_out, missing_value) - type (horiz_interp_type), intent(in) :: Interp - real, intent(out), dimension(:,:,:) :: wt - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(inout), dimension(:,:), optional :: mask_out - real, intent(in), optional :: missing_value - - !--- some local variables ---------------------------------------- - real, dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src - real, dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst - integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found - integer :: m, n, k, i1, i2, j1, j2, iverbose - real :: sum - !----------------------------------------------------------------- - - iverbose = 0; if (present(verbose)) iverbose = verbose - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - mask_src = 1.0; mask_dst = 1.0 - if(present(mask_in)) mask_src = mask_in - - do n=1,nlat_out - do m=1,nlon_out - ! neighbors are sorted nearest to farthest - ! check nearest to see if it is a land point - num_found = Interp%num_found(m,n) - - if (num_found > num_nbrs_default) then - print*,'pe=',mpp_pe(),'num_found=',num_found - num_found = num_nbrs_default - end if - - if(num_found == 0 ) then - mask_dst(m,n) = 0.0 - else - i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) - if (mask_src(i1,j1) .lt. 0.5) then - mask_dst(m,n) = 0.0 - endif - - if(num_found .gt. 1 ) then - i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) - ! compare first 2 nearest neighbors -- if they are nearly - ! equidistant then use this mask for robustness - if(abs(Interp%src_dist(m,n,2)-Interp%src_dist(m,n,1)) .lt. epsln) then - if((mask_src(i1,j1) .lt. 0.5)) mask_dst(m,n) = 0.0 - endif - endif - - sum=0.0 - do k=1, num_found - if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5 ) then - wt(m,n,k) = 0.0 - else - if (Interp%src_dist(m,n,k) <= epsln) then - wt(m,n,k) = large - sum = sum + large - else if(Interp%src_dist(m,n,k) <= Interp%max_src_dist ) then - wt(m,n,k) = 1.0/Interp%src_dist(m,n,k) - sum = sum+wt(m,n,k) - else - wt(m,n,k) = 0.0 - endif - endif - enddo - if (sum > epsln) then - do k = 1, num_found - wt(m,n,k) = wt(m,n,k)/sum - enddo - else - mask_dst(m,n) = 0.0 - endif - endif - enddo - enddo - - return - end subroutine horiz_interp_spherical_wght + end subroutine horiz_interp_spherical_init !####################################################################### - !> Deallocates memory used by "horiz_interp_type" variables. + !> Deallocates memory used by "HI_KIND_TYPE" variables. !! Must be called before reinitializing with horiz_interp_spherical_new. subroutine horiz_interp_spherical_del( Interp ) @@ -503,401 +133,24 @@ subroutine horiz_interp_spherical_del( Interp ) !! must have allocated arrays. The returned variable will !! contain deallocated arrays. - if(allocated(Interp%src_dist)) deallocate(Interp%src_dist) + if(Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%src_dist)) deallocate(Interp%horizInterpReals4_type%src_dist) + else if (Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%src_dist)) deallocate(Interp%horizInterpReals8_type%src_dist) + endif if(allocated(Interp%num_found)) deallocate(Interp%num_found) if(allocated(Interp%i_lon)) deallocate(Interp%i_lon) if(allocated(Interp%j_lat)) deallocate(Interp%j_lat) - end subroutine horiz_interp_spherical_del - - !####################################################################### - - subroutine radial_search(theta_src,phi_src,theta_dst,phi_dst, map_src_xsize, map_src_ysize, & - map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) - real, intent(in), dimension(:) :: theta_src, phi_src - real, intent(in), dimension(:,:) :: theta_dst, phi_dst - integer, intent(in) :: map_src_xsize, map_src_ysize - integer, intent(out), dimension(:,:,:) :: map_src_add - real, intent(out), dimension(:,:,:) :: map_src_dist - integer, intent(inout), dimension(:,:) :: num_found - integer, intent(in) :: num_neighbors - real, intent(in) :: max_src_dist - logical, intent(in) :: src_is_modulo - - !---------- local variables ---------------------------------------- - integer, parameter :: max_nbrs = 50 - integer :: i, j, jj, i0, j0, n, l,i_left, i_right - integer :: map_dst_xsize, map_dst_ysize - integer :: i_left1, i_left2, i_right1, i_right2 - integer :: map_src_size, step, step_size, bound, bound_start, bound_end - logical :: continue_search, result, continue_radial_search - real :: d, res - !------------------------------------------------------------------ - map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) - map_src_size = map_src_xsize*map_src_ysize - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - continue_search=.true. - step = 1 - step_size = int( sqrt(real(map_src_size) )) - do while (continue_search .and. step_size > 0) - do while (step <= map_src_size .and. continue_search) - ! count land points as nearest neighbors - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) - if (d <= max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - step,d, num_found(i,j), num_neighbors ) - if (result) then - n = 0 - i0 = mod(step,map_src_xsize) - - if (i0 == 0) i0 = map_src_xsize - res = float(step)/float(map_src_xsize) - j0 = ceiling(res) - continue_radial_search = .true. - do while (continue_radial_search) - continue_radial_search = .false. - n = n+1 ! radial counter - if(n > max_nbrs) exit - ! ************** left boundary ******************************* - i_left = i0-n - if (i_left <= 0) then - if (src_is_modulo) then - i_left = map_src_xsize + i_left - else - i_left = 1 - endif - endif - - do l = 0, 2*n - jj = j0 - n - 1 + l - if( jj < 0) then - bound = ( 1 - jj )*map_src_xsize - i_left - else if ( jj >= map_src_ysize ) then - bound = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left - else - bound = jj * map_src_xsize + i_left - endif - - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - enddo - - ! ***************************right boundary ******************************* - i_right = i0+n - if (i_right > map_src_xsize) then - if (src_is_modulo) then - i_right = i_right - map_src_xsize - else - i_right = map_src_xsize - endif - endif - - do l = 0, 2*n - jj = j0 - n - 1 + l - if( jj < 0) then - bound = ( 1 - jj )*map_src_xsize - i_right - else if ( jj >= map_src_ysize ) then - bound = ( 2*map_src_ysize - jj) * map_src_xsize - i_right - - else - bound = jj * map_src_xsize + i_right - endif - - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - enddo - - ! ************************* bottom boundary ********************************** - i_left2 = 0 - if( i_left > i_right) then - i_left1 = 1 - i_right1 = i_right - i_left2 = i_left - i_right2 = map_src_xsize - else - i_left1 = i_left - i_right1 = i_right - endif - - jj = j0 - n - 1 - if( jj < 0 ) then - bound_start = ( 1 - jj)*map_src_xsize - i_right1 - bound_end = ( 1 - jj)*map_src_xsize - i_left1 - else - bound_start = jj * map_src_xsize + i_left1 - bound_end = jj * map_src_xsize + i_right1 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - - enddo - - if(i_left2 > 0 ) then - if( jj < 0 ) then - bound_start = ( 1 - jj)*map_src_xsize - i_right2 - bound_end = ( 1 - jj)*map_src_xsize - i_left2 - else - bound_start = jj * map_src_xsize + i_left2 - bound_end = jj * map_src_xsize + i_right2 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - enddo - endif - - ! ************************** top boundary ************************************ - jj = j0 + n - 1 - if( jj >= map_src_ysize) then - bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right1 - bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left1 - else - bound_start = jj * map_src_xsize + i_left1 - bound_end = jj * map_src_xsize + i_right1 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - enddo - - if(i_left2 > 0) then - if( jj >= map_src_ysize) then - bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right2 - bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left2 - else - bound_start = jj * map_src_xsize + i_left2 - bound_end = jj * map_src_xsize + i_right2 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - enddo - endif - - enddo - continue_search = .false. ! stop looking - endif - endif - step=step+step_size - enddo ! search loop - step = 1 - step_size = step_size/2 - enddo - enddo - enddo - - return - - end subroutine radial_search - - - !##################################################################### - - function update_dest_neighbors(map_src_add, map_src_dist, src_add,d, num_found, min_nbrs) - - integer, intent(inout), dimension(:) :: map_src_add - real, intent(inout), dimension(:) :: map_src_dist - integer, intent(in) :: src_add - real, intent(in) :: d - integer, intent(inout) :: num_found - integer, intent(in) :: min_nbrs - - logical :: update_dest_neighbors, already_exist = .false. - - integer :: n,m - - update_dest_neighbors = .false. - - n = 0 - NLOOP : do while ( n .le. num_found ) - n = n + 1 - DIST_CHK : if (d .le. map_src_dist(n)) then - do m=n,num_found - if (src_add == map_src_add(m)) then - already_exist = .true. - exit NLOOP - endif - enddo - if(num_found < max_neighbors) then - num_found = num_found + 1 - else - call mpp_error(FATAL,'update_dest_neighbors: '// & - 'number of neighbor points found is greated than maxium neighbor points' ) - endif - do m=num_found,n+1,-1 - map_src_add(m) = map_src_add(m-1) - map_src_dist(m) = map_src_dist(m-1) - enddo - map_src_add(n) = src_add - map_src_dist(n) = d - update_dest_neighbors = .true. - if( num_found > min_nbrs ) then - if( map_src_dist(num_found) > map_src_dist(num_found-1) ) then - num_found = num_found - 1 - endif - if( map_src_dist(min_nbrs+1) > map_src_dist(min_nbrs) ) then - num_found = min_nbrs - endif - endif - exit NLOOP ! n loop - endif DIST_CHK - end do NLOOP - if(already_exist) return - - if( .not. update_dest_neighbors ) then - if( num_found < min_nbrs ) then - num_found = num_found + 1 - update_dest_neighbors = .true. - map_src_add(num_found) = src_add - map_src_dist(num_found) = d - endif - endif + Interp%horizInterpReals4_type%is_allocated = .false. + Interp%horizInterpReals8_type%is_allocated = .false. - - return - - end function update_dest_neighbors - - !######################################################################## -! function spherical_distance(theta1,phi1,theta2,phi2) - -! real, intent(in) :: theta1, phi1, theta2, phi2 -! real :: spherical_distance - -! real :: r1(3), r2(3), cross(3), s, dot, ang - - ! this is a simple, enough way to calculate distance on the sphere - ! first, construct cartesian vectors r1 and r2 - ! then calculate the cross-product which is proportional to the area - ! between the 2 vectors. The angular distance is arcsin of the - ! distancealong the sphere - ! - ! theta is longitude and phi is latitude - ! - - -! r1(1) = cos(theta1)*cos(phi1);r1(2)=sin(theta1)*cos(phi1);r1(3)=sin(phi1) -! r2(1) = cos(theta2)*cos(phi2);r2(2)=sin(theta2)*cos(phi2);r2(3)=sin(phi2) - -! cross(1) = r1(2)*r2(3)-r1(3)*r2(2) -! cross(2) = r1(3)*r2(1)-r1(1)*r2(3) -! cross(3) = r1(1)*r2(2)-r1(2)*r2(1) - -! s = sqrt(cross(1)**2.+cross(2)**2.+cross(3)**2.) - -! s = min(s,1.0-epsln) - -! dot = r1(1)*r2(1) + r1(2)*r2(2) + r1(3)*r2(3) - -! if (dot > 0) then -! ang = asin(s) -! else if (dot < 0) then -! ang = pi + asin(s) !? original is pi - asin(s) -! else -! ang = pi/2. -! endif - -! spherical_distance = abs(ang) ! in radians - -! return - -! end function spherical_distance - ! The great cycle distance - function spherical_distance(theta1,phi1,theta2,phi2) - - real, intent(in) :: theta1, phi1, theta2, phi2 - real :: spherical_distance, dot - - if(theta1 == theta2 .and. phi1 == phi2) then - spherical_distance = 0.0 - return - endif - - dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2) - if(dot > 1. ) dot = 1. - if(dot < -1.) dot = -1. - spherical_distance = acos(dot) - - return - - end function spherical_distance - - - !####################################################################### - - subroutine full_search(theta_src,phi_src,theta_dst,phi_dst,map_src_add, map_src_dist,num_found, & - num_neighbors,max_src_dist) - real, intent(in), dimension(:) :: theta_src, phi_src - real, intent(in), dimension(:,:) :: theta_dst, phi_dst - integer, intent(out), dimension(:,:,:) :: map_src_add - real, intent(out), dimension(:,:,:) :: map_src_dist - integer, intent(out), dimension(:,:) :: num_found - integer, intent(in) :: num_neighbors - real, intent(in) :: max_src_dist - - integer :: i,j,map_src_size, step - integer :: map_dst_xsize,map_dst_ysize - real :: d - logical :: found - - map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) - map_src_size =size(theta_src(:)) - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - do step = 1, map_src_size - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) - if( d <= max_src_dist) then - found = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - step,d,num_found(i,j), num_neighbors ) - endif - enddo - enddo - enddo - - end subroutine full_search + end subroutine horiz_interp_spherical_del !####################################################################### +#include "horiz_interp_spherical_r4.fh" +#include "horiz_interp_spherical_r8.fh" end module horiz_interp_spherical_mod !> @} diff --git a/horiz_interp/horiz_interp_type.F90 b/horiz_interp/horiz_interp_type.F90 index 634244a2f5..ec2773f860 100644 --- a/horiz_interp/horiz_interp_type.F90 +++ b/horiz_interp/horiz_interp_type.F90 @@ -29,6 +29,7 @@ module horiz_interp_type_mod use mpp_mod, only : mpp_send, mpp_recv, mpp_sync_self, mpp_error, FATAL use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes use mpp_mod, only : COMM_TAG_1, COMM_TAG_2 +use platform_mod, only: r4_kind, r8_kind implicit none private @@ -50,29 +51,80 @@ module horiz_interp_type_mod module procedure horiz_interp_type_eq end interface -! +!> @ingroup horiz_interp_type_mod +interface stats + module procedure stats_r4 + module procedure stats_r8 +end interface + + +!> real(8) pointers for use in horiz_interp_type +type horizInterpReals8_type + real(kind=r8_kind), dimension(:,:), allocatable :: faci !< weights for conservative scheme + real(kind=r8_kind), dimension(:,:), allocatable :: facj !< weights for conservative scheme + real(kind=r8_kind), dimension(:,:), allocatable :: area_src !< area of the source grid + real(kind=r8_kind), dimension(:,:), allocatable :: area_dst !< area of the destination grid + real(kind=r8_kind), dimension(:,:,:), allocatable :: wti !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r8_kind), dimension(:,:,:), allocatable :: wtj !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r8_kind), dimension(:,:,:), allocatable :: src_dist !< distance between destination grid and + !! neighbor source grid. + real(kind=r8_kind), dimension(:,:), allocatable :: rat_x !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r8_kind), dimension(:,:), allocatable :: rat_y !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r8_kind), dimension(:), allocatable :: lon_in !< the coordinates of the source grid + real(kind=r8_kind), dimension(:), allocatable :: lat_in !< the coordinates of the source grid + real(kind=r8_kind), dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. + real(kind=r8_kind), dimension(:,:), allocatable :: mask_in + real(kind=r8_kind) :: max_src_dist + logical :: is_allocated !< set to true upon field allocation + +end type horizInterpReals8_type + +!> holds real(4) pointers for use in horiz_interp_type +type horizInterpReals4_type + real(kind=r4_kind), dimension(:,:), allocatable :: faci !< weights for conservative scheme + real(kind=r4_kind), dimension(:,:), allocatable :: facj !< weights for conservative scheme + real(kind=r4_kind), dimension(:,:), allocatable :: area_src !< area of the source grid + real(kind=r4_kind), dimension(:,:), allocatable :: area_dst !< area of the destination grid + real(kind=r4_kind), dimension(:,:,:), allocatable :: wti !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r4_kind), dimension(:,:,:), allocatable :: wtj !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r4_kind), dimension(:,:,:), allocatable :: src_dist !< distance between destination grid and + !! neighbor source grid. + real(kind=r4_kind), dimension(:,:), allocatable :: rat_x !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r4_kind), dimension(:,:), allocatable :: rat_y !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r4_kind), dimension(:), allocatable :: lon_in !< the coordinates of the source grid + real(kind=r4_kind), dimension(:), allocatable :: lat_in !< the coordinates of the source grid + real(kind=r4_kind), dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. + real(kind=r4_kind), dimension(:,:), allocatable :: mask_in + real(kind=r4_kind) :: max_src_dist + logical :: is_allocated !< set to true upon field allocation + +end type horizInterpReals4_type + +!> Holds data pointers and metadata for horizontal interpolations, passed between the horiz_interp modules !> @ingroup horiz_interp_type_mod type horiz_interp_type - real, dimension(:,:), allocatable :: faci !< weights for conservative scheme - real, dimension(:,:), allocatable :: facj !< weights for conservative scheme integer, dimension(:,:), allocatable :: ilon !< indices for conservative scheme integer, dimension(:,:), allocatable :: jlat !< indices for conservative scheme - real, dimension(:,:), allocatable :: area_src !< area of the source grid - real, dimension(:,:), allocatable :: area_dst !< area of the destination grid - real, dimension(:,:,:), allocatable :: wti !< weights for bilinear interpolation - !! wti ist used for derivative "weights" in bicubic - real, dimension(:,:,:), allocatable :: wtj !< weights for bilinear interpolation !! wti ist used for derivative "weights" in bicubic integer, dimension(:,:,:), allocatable :: i_lon !< indices for bilinear interpolation !! and spherical regrid integer, dimension(:,:,:), allocatable :: j_lat !< indices for bilinear interpolation !! and spherical regrid - real, dimension(:,:,:), allocatable :: src_dist !< distance between destination grid and - !! neighbor source grid. - logical, dimension(:,:), allocatable :: found_neighbors !< indicate whether destination grid - !! has some source grid around it. - real :: max_src_dist - integer, dimension(:,:), allocatable :: num_found + logical, dimension(:,:), allocatable :: found_neighbors !< indicate whether destination grid + !! has some source grid around it. + integer, dimension(:,:), allocatable :: num_found integer :: nlon_src !< size of source grid integer :: nlat_src !< size of source grid integer :: nlon_dst !< size of destination grid @@ -82,14 +134,6 @@ module horiz_interp_type_mod !! =2, bilinear interpolation !! =3, spherical regrid !! =4, bicubic regrid - real, dimension(:,:), allocatable :: rat_x !< the ratio of coordinates of the dest grid - !! (x_dest -x_src_r)/(x_src_l -x_src_r) - !! and (y_dest -y_src_r)/(y_src_l -y_src_r) - real, dimension(:,:), allocatable :: rat_y !< the ratio of coordinates of the dest grid - !! (x_dest -x_src_r)/(x_src_l -x_src_r) - !! and (y_dest -y_src_r)/(y_src_l -y_src_r) - real, dimension(:), allocatable :: lon_in !< the coordinates of the source grid - real, dimension(:), allocatable :: lat_in !< the coordinates of the source grid logical :: I_am_initialized=.false. integer :: version !< indicate conservative !! interpolation version with value 1 or 2 @@ -100,86 +144,16 @@ module horiz_interp_type_mod integer, dimension(:), allocatable :: j_src !< indices in source grid. integer, dimension(:), allocatable :: i_dst !< indices in destination grid. integer, dimension(:), allocatable :: j_dst !< indices in destination grid. - real, dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. - real, dimension(:,:), allocatable :: mask_in + type(horizInterpReals8_type) :: horizInterpReals8_type !< derived type holding kind 8 real data pointers + !! if compiled with r8_kind + type(horizInterpReals4_type) :: horizInterpReals4_type !< derived type holding kind 4 real data pointers + !! if compiled with r8_kind end type -! !> @addtogroup horiz_interp_type_mod !> @{ contains -!####################################################################### - !> @brief This statistics is for bilinear interpolation and spherical regrid. - subroutine stats ( dat, low, high, avg, miss, missing_value, mask ) - real, intent(in) :: dat(:,:) - real, intent(out) :: low, high, avg - integer, intent(out) :: miss - real, intent(in), optional :: missing_value - real, intent(in), optional :: mask(:,:) - - real :: dsum, buffer_real(3) - integer :: pe, root_pe, npes, p, buffer_int(2), npts - - pe = mpp_pe() - root_pe = mpp_root_pe() - npes = mpp_npes() - - dsum = 0.0 - miss = 0 - - if (present(missing_value)) then - miss = count(dat(:,:) == missing_value) - low = minval(dat(:,:), dat(:,:) /= missing_value) - high = maxval(dat(:,:), dat(:,:) /= missing_value) - dsum = sum(dat(:,:), dat(:,:) /= missing_value) - else if(present(mask)) then - miss = count(mask(:,:) <= 0.5) - low = minval(dat(:,:),mask=mask(:,:) > 0.5) - high = maxval(dat(:,:),mask=mask(:,:) > 0.5) - dsum = sum(dat(:,:), mask=mask(:,:) > 0.5) - else - miss = 0 - low = minval(dat(:,:)) - high = maxval(dat(:,:)) - dsum = sum(dat(:,:)) - endif - avg = 0.0 - - npts = size(dat(:,:)) - miss - if(pe == root_pe) then - do p = 1, npes - 1 ! root_pe receive data from other pe - ! Force use of "scalar", integer pointer mpp interface - call mpp_recv(buffer_real(1),glen=3, from_pe=p+root_pe, tag=COMM_TAG_1) - dsum = dsum + buffer_real(1) - low = min(low, buffer_real(2)) - high = max(high, buffer_real(3)) - call mpp_recv(buffer_int(1), glen=2, from_pe=p+root_pe, tag=COMM_TAG_2) - miss = miss + buffer_int(1) - npts = npts + buffer_int(2) - enddo - if(npts == 0) then - print*, 'Warning: no points is valid' - else - avg = dsum/real(npts) - endif - else ! other pe send data to the root_pe. - buffer_real(1) = dsum - buffer_real(2) = low - buffer_real(3) = high - ! Force use of "scalar", integer pointer mpp interface - call mpp_send(buffer_real(1),plen=3,to_pe=root_pe, tag=COMM_TAG_1) - buffer_int(1) = miss - buffer_int(2) = npts - call mpp_send(buffer_int(1), plen=2, to_pe=root_pe, tag=COMM_TAG_2) - endif - - call mpp_sync_self() - - return - - end subroutine stats - !###################################################################################################################### !> @brief horiz_interp_type_eq creates a copy of the horiz_interp_type object subroutine horiz_interp_type_eq(horiz_interp_out, horiz_interp_in) @@ -190,43 +164,74 @@ subroutine horiz_interp_type_eq(horiz_interp_out, horiz_interp_in) call mpp_error(FATAL,'horiz_interp_type_eq: horiz_interp_type variable on right hand side is unassigned') endif - horiz_interp_out%faci = horiz_interp_in%faci - horiz_interp_out%facj = horiz_interp_in%facj - horiz_interp_out%ilon = horiz_interp_in%ilon - horiz_interp_out%jlat = horiz_interp_in%jlat - horiz_interp_out%area_src = horiz_interp_in%area_src - horiz_interp_out%area_dst = horiz_interp_in%area_dst - horiz_interp_out%wti = horiz_interp_in%wti - horiz_interp_out%wtj = horiz_interp_in%wtj - horiz_interp_out%i_lon = horiz_interp_in%i_lon - horiz_interp_out%j_lat = horiz_interp_in%j_lat - horiz_interp_out%src_dist = horiz_interp_in%src_dist - if (allocated(horiz_interp_in%found_neighbors)) horiz_interp_out%found_neighbors = horiz_interp_in%found_neighbors - horiz_interp_out%max_src_dist = horiz_interp_in%max_src_dist - horiz_interp_out%num_found = horiz_interp_in%num_found + horiz_interp_out%ilon = horiz_interp_in%ilon + horiz_interp_out%jlat = horiz_interp_in%jlat + horiz_interp_out%i_lon = horiz_interp_in%i_lon + horiz_interp_out%j_lat = horiz_interp_in%j_lat + horiz_interp_out%found_neighbors = horiz_interp_in%found_neighbors + horiz_interp_out%num_found = horiz_interp_in%num_found horiz_interp_out%nlon_src = horiz_interp_in%nlon_src horiz_interp_out%nlat_src = horiz_interp_in%nlat_src horiz_interp_out%nlon_dst = horiz_interp_in%nlon_dst horiz_interp_out%nlat_dst = horiz_interp_in%nlat_dst horiz_interp_out%interp_method = horiz_interp_in%interp_method - horiz_interp_out%rat_x = horiz_interp_in%rat_x - horiz_interp_out%rat_y = horiz_interp_in%rat_y - horiz_interp_out%lon_in = horiz_interp_in%lon_in - horiz_interp_out%lat_in = horiz_interp_in%lat_in horiz_interp_out%I_am_initialized = .true. - horiz_interp_out%i_src = horiz_interp_in%i_src - horiz_interp_out%j_src = horiz_interp_in%j_src - horiz_interp_out%i_dst = horiz_interp_in%i_dst - horiz_interp_out%j_dst = horiz_interp_in%j_dst - horiz_interp_out%area_frac_dst = horiz_interp_in%area_frac_dst + horiz_interp_out%i_src = horiz_interp_in%i_src + horiz_interp_out%j_src = horiz_interp_in%j_src + horiz_interp_out%i_dst = horiz_interp_in%i_dst + horiz_interp_out%j_dst = horiz_interp_in%j_dst + + if(horiz_interp_in%horizInterpReals8_type%is_allocated) then + horiz_interp_out%horizInterpReals8_type%faci = horiz_interp_in%horizInterpReals8_type%faci + horiz_interp_out%horizInterpReals8_type%facj = horiz_interp_in%horizInterpReals8_type%facj + horiz_interp_out%horizInterpReals8_type%area_src = horiz_interp_in%horizInterpReals8_type%area_src + horiz_interp_out%horizInterpReals8_type%area_dst = horiz_interp_in%horizInterpReals8_type%area_dst + horiz_interp_out%horizInterpReals8_type%wti = horiz_interp_in%horizInterpReals8_type%wti + horiz_interp_out%horizInterpReals8_type%wtj = horiz_interp_in%horizInterpReals8_type%wtj + horiz_interp_out%horizInterpReals8_type%src_dist = horiz_interp_in%horizInterpReals8_type%src_dist + horiz_interp_out%horizInterpReals8_type%rat_x = horiz_interp_in%horizInterpReals8_type%rat_x + horiz_interp_out%horizInterpReals8_type%rat_y = horiz_interp_in%horizInterpReals8_type%rat_y + horiz_interp_out%horizInterpReals8_type%lon_in = horiz_interp_in%horizInterpReals8_type%lon_in + horiz_interp_out%horizInterpReals8_type%lat_in = horiz_interp_in%horizInterpReals8_type%lat_in + horiz_interp_out%horizInterpReals8_type%area_frac_dst = horiz_interp_in%horizInterpReals8_type%area_frac_dst + horiz_interp_out%horizInterpReals8_type%max_src_dist = horiz_interp_in%horizInterpReals8_type%max_src_dist + horiz_interp_out%horizInterpReals8_type%is_allocated = .true. + ! this was left out previous to mixed mode + horiz_interp_out%horizInterpReals8_type%mask_in = horiz_interp_in%horizInterpReals8_type%mask_in + + else if (horiz_interp_in%horizInterpReals4_type%is_allocated) then + horiz_interp_out%horizInterpReals4_type%faci = horiz_interp_in%horizInterpReals4_type%faci + horiz_interp_out%horizInterpReals4_type%facj = horiz_interp_in%horizInterpReals4_type%facj + horiz_interp_out%horizInterpReals4_type%area_src = horiz_interp_in%horizInterpReals4_type%area_src + horiz_interp_out%horizInterpReals4_type%area_dst = horiz_interp_in%horizInterpReals4_type%area_dst + horiz_interp_out%horizInterpReals4_type%wti = horiz_interp_in%horizInterpReals4_type%wti + horiz_interp_out%horizInterpReals4_type%wtj = horiz_interp_in%horizInterpReals4_type%wtj + horiz_interp_out%horizInterpReals4_type%src_dist = horiz_interp_in%horizInterpReals4_type%src_dist + horiz_interp_out%horizInterpReals4_type%rat_x = horiz_interp_in%horizInterpReals4_type%rat_x + horiz_interp_out%horizInterpReals4_type%rat_y = horiz_interp_in%horizInterpReals4_type%rat_y + horiz_interp_out%horizInterpReals4_type%lon_in = horiz_interp_in%horizInterpReals4_type%lon_in + horiz_interp_out%horizInterpReals4_type%lat_in = horiz_interp_in%horizInterpReals4_type%lat_in + horiz_interp_out%horizInterpReals4_type%area_frac_dst = horiz_interp_in%horizInterpReals4_type%area_frac_dst + horiz_interp_out%horizInterpReals4_type%max_src_dist = horiz_interp_in%horizInterpReals4_type%max_src_dist + horiz_interp_out%horizInterpReals4_type%is_allocated = .true. + ! this was left out previous to mixed mode + horiz_interp_out%horizInterpReals4_type%mask_in = horiz_interp_in%horizInterpReals4_type%mask_in + + else + call mpp_error(FATAL, "horiz_interp_type_eq: cannot assign unallocated real values from horiz_interp_in") + endif + if(horiz_interp_in%interp_method == CONSERVE) then - horiz_interp_out%version = horiz_interp_in%version - if(horiz_interp_in%version==2) horiz_interp_out%nxgrid = horiz_interp_in%nxgrid + horiz_interp_out%version = horiz_interp_in%version + if(horiz_interp_in%version==2) horiz_interp_out%nxgrid = horiz_interp_in%nxgrid end if end subroutine horiz_interp_type_eq !###################################################################################################################### +#include "horiz_interp_type_r4.fh" +#include "horiz_interp_type_r8.fh" + end module horiz_interp_type_mod !> @} ! close documentation grouping diff --git a/horiz_interp/include/horiz_interp.inc b/horiz_interp/include/horiz_interp.inc new file mode 100644 index 0000000000..ec0540b442 --- /dev/null +++ b/horiz_interp/include/horiz_interp.inc @@ -0,0 +1,843 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_mod +!> @{ + !> @brief Creates a 1D @ref horiz_interp_type with the given parameters + subroutine HORIZ_INTERP_NEW_1D_ (Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + grid_at_center, mask_in, mask_out) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< dummy variable + real(FMS_HI_KIND_), intent(inout),dimension(:,:), optional :: mask_out !< dummy variable + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(:,:), allocatable :: lon_src, lat_src, lon_dst, lat_dst + real(FMS_HI_KIND_), dimension(:), allocatable :: lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d + integer :: i, j, nlon_in, nlat_in, nlon_out, nlat_out + logical :: center + character(len=40) :: method + integer, parameter :: kindl = FMS_HI_KIND_ !> real kind size currently compiling + !----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) + case ("bilinear") + Interp%interp_method = BILINEAR + center = .false. + if(present(grid_at_center) ) center = grid_at_center + if(center) then + nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_out + lon_dst(i,:) = lon_out(i) + enddo + do j = 1, nlat_out + lat_dst(:,j) = lat_out(j) + enddo + + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & + verbose, src_modulo) + deallocate(lon_dst, lat_dst) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + do i = 1, nlon_out + lon_dst(i,:) = (lon_out(i) + lon_out(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_out + lat_dst(:,j) = (lat_out(j) + lat_out(j+1)) * 0.5_kindl + enddo + call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_dst, lat_dst, & + verbose, src_modulo) + deallocate(lon_src_1d, lat_src_1d, lon_dst, lat_dst) + endif + case ("bicubic") + Interp%interp_method = BICUBIC + center = .false. + if(present(grid_at_center) ) center = grid_at_center + !No need to expand to 2d, horiz_interp_bicubic_new does 1d-1d + if(center) then + call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + allocate(lon_dst_1d(nlon_out), lat_dst_1d(nlat_out)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + do i = 1, nlon_out + lon_dst_1d(i) = (lon_out(i) + lon_out(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_out + lat_dst_1d(j) = (lat_out(j) + lat_out(j+1)) * 0.5_kindl + enddo + call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d, & + verbose, src_modulo) + deallocate(lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d) + endif + case ("spherical") + Interp%interp_method = SPHERICA + nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) + nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) + allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_in + lon_src(i,:) = lon_in(i) + enddo + do j = 1, nlat_in + lat_src(:,j) = lat_in(j) + enddo + do i = 1, nlon_out + lon_dst(i,:) = lon_out(i) + enddo + do j = 1, nlat_out + lat_dst(:,j) = lat_out(j) + enddo + call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_dst, lat_dst, & + num_nbrs, max_dist, src_modulo) + deallocate(lon_src, lat_src, lon_dst, lat_dst) + case default + call mpp_error(FATAL,'horiz_interp_mod: interp_method should be conservative, bilinear, bicubic, spherical') + end select + + !----------------------------------------------------------------------- + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_1D_ + +!####################################################################### + + subroutine HORIZ_INTERP_NEW_1D_SRC_ (Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, grid_at_center, mask_in, mask_out, is_latlon_out ) + + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs !< minimum number of neighbors + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out),dimension(:,:), optional :: mask_out + logical, intent(in), optional :: is_latlon_out + + real(FMS_HI_KIND_), dimension(:,:), allocatable :: lon_src, lat_src + real(FMS_HI_KIND_), dimension(:), allocatable :: lon_src_1d, lat_src_1d + integer :: i, j, nlon_in, nlat_in + character(len=40) :: method + logical :: center + logical :: dst_is_latlon + integer, parameter :: kindl = FMS_HI_KIND_ !< real kind size currently compiling + !----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + !--- check to see if the source grid is regular lat-lon grid or not. + if(PRESENT(is_latlon_out)) then + dst_is_latlon = is_latlon_out + else + dst_is_latlon = is_lat_lon(lon_out, lat_out) + end if + if(dst_is_latlon ) then + if(present(mask_in)) then + if ( ANY(mask_in < -.0001_kindl) .or. ANY(mask_in > 1.0001_kindl)) & + call mpp_error(FATAL, & + 'horiz_interp_conserve_new_1d_src(horiz_interp_conserve_mod): input mask not between 0,1') + allocate(Interp%HI_KIND_TYPE_%mask_in(size(mask_in,1), size(mask_in,2)) ) + Interp%HI_KIND_TYPE_%mask_in = mask_in + end if + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & + verbose=verbose ) + else + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + end if + case ("bilinear") + Interp%interp_method = BILINEAR + center = .false. + if(present(grid_at_center) ) center = grid_at_center + if(center) then + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & + verbose, src_modulo ) + deallocate(lon_src_1d,lat_src_1d) + endif + case ("bicubic") + Interp%interp_method = BICUBIC + center = .false. + if(present(grid_at_center) ) center = grid_at_center + if(center) then + call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & + verbose, src_modulo ) + deallocate(lon_src_1d,lat_src_1d) + endif + case ("spherical") + Interp%interp_method = SPHERICA + nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) + allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) + do i = 1, nlon_in + lon_src(i,:) = lon_in(i) + enddo + do j = 1, nlat_in + lat_src(:,j) = lat_in(j) + enddo + call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_out, lat_out, & + num_nbrs, max_dist, src_modulo) + deallocate(lon_src, lat_src) + case default + call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') + end select + + !----------------------------------------------------------------------- + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_1D_SRC_ + +!####################################################################### + + subroutine HORIZ_INTERP_NEW_2D_ (Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, is_latlon_in, is_latlon_out ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out),dimension(:,:), optional :: mask_out + logical, intent(in), optional :: is_latlon_in, is_latlon_out + logical :: src_is_latlon, dst_is_latlon + character(len=40) :: method + integer, parameter :: kindl = FMS_HI_KIND_ !< real kind size currently compiling +!----------------------------------------------------------------------- + call horiz_interp_init + + method = 'bilinear' + if(present(interp_method)) method = interp_method + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + if(PRESENT(is_latlon_in)) then + src_is_latlon = is_latlon_in + else + src_is_latlon = is_lat_lon(lon_in, lat_in) + end if + if(PRESENT(is_latlon_out)) then + dst_is_latlon = is_latlon_out + else + dst_is_latlon = is_lat_lon(lon_out, lat_out) + end if + if(src_is_latlon .AND. dst_is_latlon) then + if(present(mask_in)) then + if ( ANY(mask_in < -0.0001_kindl) .or. ANY(mask_in > 1.0001_kindl)) then + call mpp_error(FATAL, 'horiz_interp_conserve_new_2d(horiz_interp_conserve_mod):' // & + ' input mask not between 0,1') + endif + allocate(Interp%HI_KIND_TYPE_%mask_in(size(mask_in,1), size(mask_in,2)) ) + Interp%HI_KIND_TYPE_%mask_in = mask_in + end if + call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out(:,1), lat_out(1,:), & + verbose=verbose ) + else if(src_is_latlon) then + call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + else if(dst_is_latlon) then + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + else + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + end if + + case ("spherical") + Interp%interp_method = SPHERICA + call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + num_nbrs, max_dist, src_modulo ) + case ("bilinear") + Interp%interp_method = BILINEAR + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + case default + call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') + end select + + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_2D_ + +!####################################################################### + subroutine HORIZ_INTERP_NEW_1D_DST_ (Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, src_modulo, mask_in, mask_out, is_latlon_in ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out),dimension(:,:), optional :: mask_out + logical, intent(in), optional :: is_latlon_in + + character(len=40) :: method + integer, parameter :: kindl = FMS_HI_KIND_ !< real kind size currently compiling + !-------------some local variables----------------------------------------------- + integer :: i, j, nlon_out, nlat_out + real(FMS_HI_KIND_), dimension(:,:), allocatable :: lon_dst, lat_dst + logical :: src_is_latlon + !----------------------------------------------------------------------- + call horiz_interp_init + + method = 'bilinear' + if(present(interp_method)) method = interp_method + + nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_out + lon_dst(i,:) = lon_out(i) + enddo + do j = 1, nlat_out + lat_dst(:,j) = lat_out(j) + enddo + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + if(PRESENT(is_latlon_in)) then + src_is_latlon = is_latlon_in + else + src_is_latlon = is_lat_lon(lon_in, lat_in) + end if + + if(src_is_latlon) then + if(present(mask_in)) then + if ( ANY(mask_in < -0.0001_kindl) .or. ANY(mask_in > 1.0001_kindl)) & + call mpp_error(FATAL, & + 'horiz_interp_conserve_new_1d_dst(horiz_interp_conserve_mod): input mask not between 0,1') + allocate(Interp%HI_KIND_TYPE_%mask_in(size(mask_in,1), size(mask_in,2)) ) + Interp%HI_KIND_TYPE_%mask_in = mask_in + end if + call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & + verbose=verbose) + else + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + end if + case ("bilinear") + Interp%interp_method = BILINEAR + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & + verbose, src_modulo ) + case ("spherical") + Interp%interp_method = SPHERICA + call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & + num_nbrs, max_dist, src_modulo) + case default + call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') + end select + + deallocate(lon_dst,lat_dst) + + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_1D_DST_ + +!####################################################################### + + subroutine HORIZ_INTERP_BASE_2D_ ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle ) +!----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + character(len=*), intent(out), optional :: err_msg + logical, intent(in), optional :: new_missing_handle +!----------------------------------------------------------------------- + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return + endif + + select case(Interp%interp_method) + case(CONSERVE) + call horiz_interp_conserve(Interp,data_in, data_out, verbose, mask_in, mask_out) + case(BILINEAR) + call horiz_interp_bilinear(Interp,data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, new_missing_handle ) + case(BICUBIC) + call horiz_interp_bicubic(Interp,data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit ) + case(SPHERICA) + call horiz_interp_spherical(Interp,data_in, data_out, verbose, mask_in, mask_out, & + missing_value ) + case default + call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') + end select + + return + + end subroutine HORIZ_INTERP_BASE_2D_ + +!####################################################################### + + !> Overload of interface HORIZ_INTERP_BASE_2D_ + !! uses 3d arrays for data and mask + !! this allows for multiple interpolations with one call + subroutine HORIZ_INTERP_BASE_3D_ ( Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg ) + !----------------------------------------------------------------------- + ! overload of interface HORIZ_INTERP_BASE_2D_ + ! uses 3d arrays for data and mask + ! this allows for multiple interpolations with one call + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + character(len=*), intent(out), optional :: err_msg + !----------------------------------------------------------------------- + integer :: n + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return + endif + + do n = 1, size(data_in,3) + if (present(mask_in))then + if(present(mask_out)) then + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, mask_in(:,:,n), mask_out(:,:,n), & + missing_value, missing_permit ) + else + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, mask_in(:,:,n), missing_value = missing_value, & + missing_permit = missing_permit ) + endif + else + if(present(mask_out)) then + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, mask_out=mask_out(:,:,n), missing_value = missing_value, & + missing_permit = missing_permit ) + else + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, missing_value = missing_value, & + missing_permit = missing_permit ) + endif + endif + enddo + + return +!----------------------------------------------------------------------- + end subroutine HORIZ_INTERP_BASE_3D_ + +!####################################################################### + +!> Interpolates from a rectangular grid to rectangular grid. +!! interp_method can be the value conservative, bilinear or spherical. +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_1D_ ( data_in, lon_in, lat_in, lon_out, lat_out, & + data_out, verbose, mask_in, mask_out, & + interp_method, missing_value, missing_permit, & + num_nbrs, max_dist,src_modulo, grid_at_center ) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp +!----------------------------------------------------------------------- + call horiz_interp_init + + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, grid_at_center ) + + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + + call horiz_interp_del ( Interp ) +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_1D_ + +!####################################################################### + +!> Interpolates from a uniformly spaced grid to any output grid. +!! interp_method can be the value "onservative","bilinear" or "spherical". +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_1D_SRC_ ( data_in, lon_in, lat_in, lon_out, lat_out, & + data_out, verbose, mask_in, mask_out, & + interp_method, missing_value, missing_permit, & + num_nbrs, max_dist, src_modulo, grid_at_center ) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center + +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp + logical :: dst_is_latlon + character(len=128) :: method +!----------------------------------------------------------------------- + call horiz_interp_init + method = 'conservative' + if(present(interp_method)) method = interp_method + dst_is_latlon = .true. + if(trim(method) == 'conservative') dst_is_latlon = is_lat_lon(lon_out, lat_out) + + if(dst_is_latlon) then + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + grid_at_center, is_latlon_out = dst_is_latlon ) + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + else + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + grid_at_center, mask_in, mask_out, is_latlon_out = dst_is_latlon) + + call horiz_interp ( Interp, data_in, data_out, verbose, & + missing_value=missing_value, missing_permit=missing_permit ) + end if + + call horiz_interp_del ( Interp ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_1D_SRC_ + + +!####################################################################### + +!> Interpolates from any grid to any grid. interp_method should be "spherical" +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_2D_ ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & + verbose, mask_in, mask_out, interp_method, missing_value,& + missing_permit, num_nbrs, max_dist, src_modulo ) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp + logical :: dst_is_latlon, src_is_latlon + character(len=128) :: method +!----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + dst_is_latlon = .true. + src_is_latlon = .true. + if(trim(method) == 'conservative') then + dst_is_latlon = is_lat_lon(lon_out, lat_out) + src_is_latlon = is_lat_lon(lon_in, lat_in) + end if + + if(dst_is_latlon .and. src_is_latlon) then + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon ) + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + else + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + mask_in, mask_out, & + is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon) + call horiz_interp ( Interp, data_in, data_out, verbose, & + missing_value=missing_value, missing_permit=missing_permit ) + end if + + call horiz_interp_del ( Interp ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_2D_ + +!####################################################################### + +!> interpolates from any grid to rectangular longitude/latitude grid. +!! interp_method should be "spherical". +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_1D_DST_ ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & + verbose, mask_in, mask_out,interp_method,missing_value, & + missing_permit, num_nbrs, max_dist, src_modulo) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp + logical :: src_is_latlon + character(len=128) :: method +!----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + src_is_latlon = .true. + if(trim(method) == 'conservative') src_is_latlon = is_lat_lon(lon_in, lat_in) + + if(src_is_latlon) then + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + is_latlon_in = src_is_latlon ) + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + else + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + mask_in, mask_out, is_latlon_in = src_is_latlon) + + call horiz_interp ( Interp, data_in, data_out, verbose, & + missing_value=missing_value, missing_permit=missing_permit ) + end if + + call horiz_interp_del ( Interp ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_1D_DST_ + +!####################################################################### + +!> Overloaded version of interface horiz_interp_solo_2 + subroutine HORIZ_INTERP_SOLO_OLD_ (data_in, wb, sb, dx, dy, & + lon_out, lat_out, data_out, & + verbose, mask_in, mask_out) + +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< Global input data stored from west to east + !! (1st dimension), south to north (2nd dimension) + real(FMS_HI_KIND_), intent(in) :: wb !< Longitude (radians) that correspond to western-most + !! boundary of grid box j=1 in array data_in + real(FMS_HI_KIND_), intent(in) :: sb !< Latitude (radians) that correspond to western-most + !! boundary of grid box j=1 in array data_in + real(FMS_HI_KIND_), intent(in) :: dx !< Grid spacing (in radians) for the longitude axis + !! (first dimension) for the input data + real(FMS_HI_KIND_), intent(in) :: dy !< Grid spacing (in radians) for the latitude axis + !! (first dimension) for the input data + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out !< The longitude edges (in radians) for output + !! data grid boxes. The values are for adjacent grid boxes + !! and must increase in value. If there are MLON grid boxes + !! there must be MLON+1 edge values + real(FMS_HI_KIND_), intent(in), dimension(:) :: lat_out !< The latitude edges (in radians) for output + !! data grid boxes. The values are for adjacent grid boxes + !! and may increase or decrease in value. If there are NLAT + !! grid boxes there must be NLAT+1 edge values + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< Output data on the output grid defined by grid box + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(size(data_in,1)+1) :: blon_in + real(FMS_HI_KIND_), dimension(size(data_in,2)+1) :: blat_in + integer :: i, j, nlon_in, nlat_in + real(FMS_HI_KIND_) :: tpi + integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time +!----------------------------------------------------------------------- + call horiz_interp_init + + tpi = 2.0_kindl * real(pi, FMS_HI_KIND_) + nlon_in = size(data_in,1) + nlat_in = size(data_in,2) + + do i = 1, nlon_in+1 + blon_in(i) = wb + real(i-1, FMS_HI_KIND_)*dx + enddo + if (abs(blon_in(nlon_in+1)-blon_in(1)-tpi) < epsilon(blon_in)) & + blon_in(nlon_in+1)=blon_in(1)+tpi + + do j = 2, nlat_in + blat_in(j) = sb + real(j-1, FMS_HI_KIND_)*dy + enddo + blat_in(1) = -0.5_kindl * real(pi, FMS_HI_KIND_) + blat_in(nlat_in+1) = 0.5_kindl * real(pi, FMS_HI_KIND_) + + + call horiz_interp_solo_1d (data_in, blon_in, blat_in, & + lon_out, lat_out, data_out, & + verbose, mask_in, mask_out ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_OLD_ + +!####################################################################### + + + !#################################################################### + function IS_LAT_LON_(lon, lat) + real(FMS_HI_KIND_), dimension(:,:), intent(in) :: lon, lat + logical :: IS_LAT_LON_ + integer :: i, j, nlon, nlat, num + + IS_LAT_LON_ = .true. + nlon = size(lon,1) + nlat = size(lon,2) + LOOP_LAT: do j = 1, nlat + do i = 2, nlon + if(lat(i,j) .NE. lat(1,j)) then + IS_LAT_LON_ = .false. + exit LOOP_LAT + end if + end do + end do LOOP_LAT + + if(IS_LAT_LON_) then + LOOP_LON: do i = 1, nlon + do j = 2, nlat + if(lon(i,j) .NE. lon(i,1)) then + IS_LAT_LON_ = .false. + exit LOOP_LON + end if + end do + end do LOOP_LON + end if + + num = 0 + if(IS_LAT_LON_) num = 1 + call mpp_min(num) + if(num == 1) then + IS_LAT_LON_ = .true. + else + IS_LAT_LON_ = .false. + end if + + return + end function IS_LAT_LON_ +!> @} diff --git a/horiz_interp/include/horiz_interp_bicubic.inc b/horiz_interp/include/horiz_interp_bicubic.inc new file mode 100644 index 0000000000..1c2f744f2b --- /dev/null +++ b/horiz_interp/include/horiz_interp_bicubic.inc @@ -0,0 +1,663 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bicubic_mod +!> @{ + + !> @brief Creates a new @ref horiz_interp_type + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_BICUBIC_NEW_1D_S_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp !< A derived-type variable containing indices + !! and weights used for subsequent interpolations. To + !! reinitialize this variable for a different grid-to-grid + !! interpolation you must first use the + !! @ref HORIZ_INTERP_BICUBIC_NEW__del interface. + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in !< Longitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:) :: lat_in !< Latitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid + integer, intent(in), optional :: verbose !< flag for print output amount + logical, intent(in), optional :: src_modulo !< indicates if the boundary condition along + !! zonal boundary is cyclic or not. Zonal boundary condition + !!is cyclic when true + integer :: i, j, ip1, im1, jp1, jm1 + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: jcl, jcu, icl, icu, jj + real(FMS_HI_KIND_) :: xz, yz + integer :: unit + integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time + + if(present(verbose)) verbose_bicubic = verbose + src_is_modulo = .false. + if (present(src_modulo)) src_is_modulo = src_modulo + + if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & + 'interplation, the output grids should be geographical grids') + + !--- get the grid size + nlon_in = size(lon_in) ; nlat_in = size(lat_in) + nlon_out = size(lon_out,1); nlat_out = size(lat_out,2) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out +! use wti(:,:,1) for x-derivative, wti(:,:,2) for y-derivative, wti(:,:,3) for xy-derivative + allocate ( Interp%HI_KIND_TYPE_%wti (nlon_in, nlat_in, 3) ) + allocate ( Interp%HI_KIND_TYPE_%lon_in (nlon_in) ) + allocate ( Interp%HI_KIND_TYPE_%lat_in (nlat_in) ) + allocate ( Interp%HI_KIND_TYPE_%rat_x (nlon_out, nlat_out) ) + allocate ( Interp%HI_KIND_TYPE_%rat_y (nlon_out, nlat_out) ) + allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) + allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) + + Interp%HI_KIND_TYPE_%lon_in = lon_in + Interp%HI_KIND_TYPE_%lat_in = lat_in + + if ( verbose_bicubic > 0 ) then + unit = stdout() + write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d_s")') + write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) + write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) + do i=1, Interp%nlat_dst + write (unit,*) + write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst + write (unit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst) + enddo + do i=1, Interp%nlon_dst + write (unit,*) + write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst + write (unit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst) + enddo + endif + + +!--------------------------------------------------------------------------- +! Find the x-derivative. Use central differences and forward or +! backward steps at the boundaries + + do j=1,nlat_in + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,1) = 1.0_kindl/(Interp%HI_KIND_TYPE_%lon_in(ip1)-Interp%HI_KIND_TYPE_%lon_in(im1)) + enddo + enddo + + +!--------------------------------------------------------------------------- + +! Find the y-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + Interp%HI_KIND_TYPE_%wti(i,j,2) =1.0_kindl/(Interp%HI_KIND_TYPE_%lat_in(jp1)-Interp%HI_KIND_TYPE_%lat_in(jm1)) + enddo + enddo + +!--------------------------------------------------------------------------- + +! Find the xy-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,3) = 1.0_kindl / & + ((Interp%HI_KIND_TYPE_%lon_in(ip1)-Interp%HI_KIND_TYPE_%lon_in(im1)) * & + (Interp%HI_KIND_TYPE_%lat_in(jp1)-Interp%HI_KIND_TYPE_%lat_in(jm1))) + enddo + enddo +!--------------------------------------------------------------------------- +! Now for each point at the dest-grid find the boundary points of +! the source grid + do j=1, nlat_out + do i=1,nlon_out + yz = lat_out(i,j) + xz = lon_out(i,j) + + jcl = 0 + jcu = 0 + if( yz .le. Interp%HI_KIND_TYPE_%lat_in(1) ) then + jcl = 1 + jcu = 1 + else if( yz .ge. Interp%HI_KIND_TYPE_%lat_in(nlat_in) ) then + jcl = nlat_in + jcu = nlat_in + else + jcl = indl(Interp%HI_KIND_TYPE_%lat_in, yz) + jcu = indu(Interp%HI_KIND_TYPE_%lat_in, yz) + endif + + icl = 0 + icu = 0 + !--- cyclic condition, do we need to use do while + if( xz .gt. Interp%HI_KIND_TYPE_%lon_in(nlon_in) ) xz = xz - real(tpi,FMS_HI_KIND_) + if( xz .le. Interp%HI_KIND_TYPE_%lon_in(1) ) xz = xz + real(tpi,FMS_HI_KIND_) + if( xz .ge. Interp%HI_KIND_TYPE_%lon_in(nlon_in) ) then + icl = nlon_in + icu = 1 + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl) + real(tpi,FMS_HI_KIND_)) + else + icl = indl(Interp%HI_KIND_TYPE_%lon_in, xz) + icu = indu(Interp%HI_KIND_TYPE_%lon_in, xz) + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl)) + endif + Interp%j_lat(i,j,1) = jcl + Interp%j_lat(i,j,2) = jcu + Interp%i_lon(i,j,1) = icl + Interp%i_lon(i,j,2) = icu + if(jcl == jcu) then + Interp%HI_KIND_TYPE_%rat_y(i,j) = 0.0_kindl + else + Interp%HI_KIND_TYPE_%rat_y(i,j) = (yz-Interp%HI_KIND_TYPE_%lat_in(jcl))/(Interp%HI_KIND_TYPE_%lat_in(jcu)& + & - Interp%HI_KIND_TYPE_%lat_in(jcl)) + endif +! if(yz.gt.Interp%HI_KIND_TYPE_%lat_in(jcu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! yf < ycl, no valid boundary point') +! if(yz.lt.Interp%HI_KIND_TYPE_%lat_in(jcl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! yf > ycu, no valid boundary point') +! if(xz.gt.Interp%HI_KIND_TYPE_%lon_in(icu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! xf < xcl, no valid boundary point') +! if(xz.lt.Interp%HI_KIND_TYPE_%lon_in(icl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! xf > xcu, no valid boundary point') + enddo + enddo + end subroutine HORIZ_INTERP_BICUBIC_NEW_1D_S_ + + !> @brief Creates a new @ref horiz_interp_type + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_BICUBIC_NEW_1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + logical, intent(in), optional :: src_modulo + integer :: i, j, ip1, im1, jp1, jm1 + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: jcl, jcu, icl, icu, jj + real(FMS_HI_KIND_) :: xz, yz + integer :: unit + integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time + + if(present(verbose)) verbose_bicubic = verbose + src_is_modulo = .false. + if (present(src_modulo)) src_is_modulo = src_modulo + + !--- get the grid size + nlon_in = size(lon_in) ; nlat_in = size(lat_in) + nlon_out = size(lon_out); nlat_out = size(lat_out) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + allocate ( Interp%HI_KIND_TYPE_%wti (nlon_in, nlat_in, 3) ) + allocate ( Interp%HI_KIND_TYPE_%lon_in (nlon_in) ) + allocate ( Interp%HI_KIND_TYPE_%lat_in (nlat_in) ) + allocate ( Interp%HI_KIND_TYPE_%rat_x (nlon_out, nlat_out) ) + allocate ( Interp%HI_KIND_TYPE_%rat_y (nlon_out, nlat_out) ) + allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) + allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) + + Interp%HI_KIND_TYPE_%lon_in = lon_in + Interp%HI_KIND_TYPE_%lat_in = lat_in + + if ( verbose_bicubic > 0 ) then + unit = stdout() + write (unit,'(/,"Initialising bicubic interpolation, interface HORIZ_INTERP_BICUBIC_NEW_1D_")') + write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) + write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) + write (unit,*) + write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst + write (unit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst) + write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst + write (unit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst) + endif + + +!--------------------------------------------------------------------------- +! Find the x-derivative. Use central differences and forward or +! backward steps at the boundaries + + do j=1,nlat_in + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,1) = 1.0_kindl /(lon_in(ip1)-lon_in(im1)) + enddo + enddo + + +!--------------------------------------------------------------------------- + +! Find the y-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + Interp%HI_KIND_TYPE_%wti(i,j,2) = 1.0_kindl /(lat_in(jp1)-lat_in(jm1)) + enddo + enddo + +!--------------------------------------------------------------------------- + +! Find the xy-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,3) = 1.0_kindl /((lon_in(ip1)-lon_in(im1))*(lat_in(jp1)-lat_in(jm1))) + enddo + enddo +!--------------------------------------------------------------------------- +! Now for each point at the dest-grid find the boundary points of +! the source grid + do j=1, nlat_out + yz = lat_out(j) + jcl = 0 + jcu = 0 + if( yz .le. lat_in(1) ) then + jcl = 1 + jcu = 1 + else if( yz .ge. lat_in(nlat_in) ) then + jcl = nlat_in + jcu = nlat_in + else + jcl = indl(lat_in, yz) + jcu = indu(lat_in, yz) + endif + do i=1,nlon_out + xz = lon_out(i) + icl = 0 + icu = 0 + !--- cyclic condition, do we need to use do while + if( xz .gt. lon_in(nlon_in) ) xz = xz - real(tpi,FMS_HI_KIND_) + if( xz .le. lon_in(1) ) xz = xz + real(tpi, FMS_HI_KIND_) + if( xz .ge. lon_in(nlon_in) ) then + icl = nlon_in + icu = 1 + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl) + real(tpi,FMS_HI_KIND_)) + else + icl = indl(lon_in, xz) + icu = indu(lon_in, xz) + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl)) + endif + icl = indl(lon_in, xz) + icu = indu(lon_in, xz) + Interp%j_lat(i,j,1) = jcl + Interp%j_lat(i,j,2) = jcu + Interp%i_lon(i,j,1) = icl + Interp%i_lon(i,j,2) = icu + if(jcl == jcu) then + Interp%HI_KIND_TYPE_%rat_y(i,j) = 0.0_kindl + else + Interp%HI_KIND_TYPE_%rat_y(i,j) = (yz- Interp%HI_KIND_TYPE_%lat_in(jcl))/(Interp%HI_KIND_TYPE_%lat_in(jcu)& + & - Interp%HI_KIND_TYPE_%lat_in(jcl)) + endif +! if(yz.gt.lat_in(jcu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: yf < +! ycl, no valid boundary point') +! if(yz.lt.lat_in(jcl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: yf > +! ycu, no valid boundary point') +! if(xz.gt.lon_in(icu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: xf < +! xcl, no valid boundary point') +! if(xz.lt.lon_in(icl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: xf > +! xcu, no valid boundary point') + enddo + enddo + + end subroutine HORIZ_INTERP_BICUBIC_NEW_1D_ + + !> @brief Perform bicubic horizontal interpolation + subroutine HORIZ_INTERP_BICUBIC_NEW_( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value, & + & missing_permit) + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + real(FMS_HI_KIND_) :: yz, ycu, ycl + real(FMS_HI_KIND_) :: xz, xcu, xcl + real(FMS_HI_KIND_) :: val, val1, val2 + real(FMS_HI_KIND_), dimension(4) :: y, y1, y2, y12 + integer :: icl, icu, jcl, jcu + integer :: iclp1, icup1, jclp1, jcup1 + integer :: iclm1, icum1, jclm1, jcum1 + integer :: i,j + integer, parameter :: kindl = FMS_HI_KIND_ !< set kind size at compile time + + if ( present(verbose) ) verbose_bicubic = verbose + + do j=1, Interp%nlat_dst + do i=1, Interp%nlon_dst + yz = Interp%HI_KIND_TYPE_%rat_y(i,j) + xz = Interp%HI_KIND_TYPE_%rat_x(i,j) + jcl = Interp%j_lat(i,j,1) + jcu = Interp%j_lat(i,j,2) + icl = Interp%i_lon(i,j,1) + icu = Interp%i_lon(i,j,2) + if( icl > icu ) then + iclp1 = icu + icum1 = icl + xcl = Interp%HI_KIND_TYPE_%lon_in(icl) + xcu = Interp%HI_KIND_TYPE_%lon_in(icu)+real(tpi, FMS_HI_KIND_) + else + iclp1 = min(icl+1,Interp%nlon_src) + icum1 = max(icu-1,1) + xcl = Interp%HI_KIND_TYPE_%lon_in(icl) + xcu = Interp%HI_KIND_TYPE_%lon_in(icu) + endif + iclm1 = max(icl-1,1) + icup1 = min(icu+1,Interp%nlon_src) + jclp1 = min(jcl+1,Interp%nlat_src) + jclm1 = max(jcl-1,1) + jcup1 = min(jcu+1,Interp%nlat_src) + jcum1 = max(jcu-1,1) + ycl = Interp%HI_KIND_TYPE_%lat_in(jcl) + ycu = Interp%HI_KIND_TYPE_%lat_in(jcu) +! xcl = Interp%HI_KIND_TYPE_%lon_in(icl) +! xcu = Interp%HI_KIND_TYPE_%lon_in(icu) + y(1) = data_in(icl,jcl) + y(2) = data_in(icu,jcl) + y(3) = data_in(icu,jcu) + y(4) = data_in(icl,jcu) + y1(1) = ( data_in(iclp1,jcl) - data_in(iclm1,jcl) ) * Interp%HI_KIND_TYPE_%wti(icl,jcl,1) + y1(2) = ( data_in(icup1,jcl) - data_in(icum1,jcl) ) * Interp%HI_KIND_TYPE_%wti(icu,jcl,1) + y1(3) = ( data_in(icup1,jcu) - data_in(icum1,jcu) ) * Interp%HI_KIND_TYPE_%wti(icu,jcu,1) + y1(4) = ( data_in(iclp1,jcu) - data_in(iclm1,jcu) ) * Interp%HI_KIND_TYPE_%wti(icl,jcu,1) + y2(1) = ( data_in(icl,jclp1) - data_in(icl,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcl,2) + y2(2) = ( data_in(icu,jclp1) - data_in(icu,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcl,2) + y2(3) = ( data_in(icu,jcup1) - data_in(icu,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcu,2) + y2(4) = ( data_in(icl,jcup1) - data_in(icl,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcu,2) + y12(1)= ( data_in(iclp1,jclp1) + data_in(iclm1,jclm1) - data_in(iclm1,jclp1) & + - data_in(iclp1,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcl,3) + y12(2)= ( data_in(icup1,jclp1) + data_in(icum1,jclm1) - data_in(icum1,jclp1) & + - data_in(icup1,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcl,3) + y12(3)= ( data_in(icup1,jcup1) + data_in(icum1,jcum1) - data_in(icum1,jcup1) & + - data_in(icup1,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcu,3) + y12(4)= ( data_in(iclp1,jcup1) + data_in(iclm1,jcum1) - data_in(iclm1,jcup1) & + - data_in(iclp1,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcu,3) + + call bcuint(y,y1,y2,y12,xcl,xcu,ycl,ycu,xz,yz,val,val1,val2) + data_out (i,j) = val + if(present(mask_out)) mask_out(i,j) = 1.0_kindl +!! dff_x(i,j) = val1 +!! dff_y(i,j) = val2 + enddo + enddo + return + end subroutine HORIZ_INTERP_BICUBIC_NEW_ + +!--------------------------------------------------------------------------- + + subroutine BCUINT_(y,y1,y2,y12,x1l,x1u,x2l,x2u,t,u,ansy,ansy1,ansy2) + real(FMS_HI_KIND_) ansy,ansy1,ansy2,x1l,x1u,x2l,x2u,y(4),y1(4),y12(4),y2(4) +! uses BCUCOF_ + integer i + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + real(FMS_HI_KIND_) t,u,c(4,4) + call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c) + ansy=0.0_kindl + ansy2=0.0_kindl + ansy1=0.0_kindl + do i=4,1,-1 + ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1) +! ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2) +! ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i) + enddo +! ansy1=ansy1/(x1u-x1l) ! could be used for accuracy checks +! ansy2=ansy2/(x2u-x2l) ! could be used for accuracy checks + return +! (c) copr. 1986-92 numerical recipes software -3#(-)f. + end subroutine BCUINT_ +!--------------------------------------------------------------------------- + + subroutine BCUCOF_(y,y1,y2,y12,d1,d2,c) + real(FMS_HI_KIND_) d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4) + integer i,j,k,l + real(FMS_HI_KIND_) d1d2,xx,cl(16),x(16) + integer, parameter :: kindl = FMS_HI_KIND_!< compiled kind type + !! n*0.0 represents n consecutive 0.0's + real(FMS_HI_KIND_), save, dimension(16,16) :: wt !< weights use + data wt/1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl, 4*0.0_kindl, -3.0_kindl, 0.0_kindl, 9.0_kindl, -6.0_kindl, & + 2.0_kindl, 0.0_kindl, -6.0_kindl, 4.0_kindl, 8*0.0_kindl, 3.0_kindl, 0.0_kindl, -9.0_kindl, 6.0_kindl, & + -2.0_kindl, 0.0_kindl, 6.0_kindl, -4.0_kindl, 10*0.0_kindl, 9.0_kindl, -6.0_kindl, 2*0.0_kindl, & + -6.0_kindl, 4.0_kindl, 2*0.0_kindl, 3.0_kindl, -2.0_kindl, 6*0.0_kindl, -9.0_kindl, 6.0_kindl, & + 2*0.0_kindl, 6.0_kindl, -4.0_kindl, 4*0.0_kindl, 1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl,-2.0_kindl,& + 0.0_kindl, 6.0_kindl, -4.0_kindl, 1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl, 8*0.0_kindl, -1.0_kindl, & + 0.0_kindl, 3.0_kindl, -2.0_kindl, 1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl, 10*0.0_kindl, -3.0_kindl,& + 2.0_kindl, 2*0.0_kindl, 3.0_kindl, -2.0_kindl, 6*0.0_kindl, 3.0_kindl, -2.0_kindl, 2*0.0_kindl, & + -6.0_kindl, 4.0_kindl, 2*0.0_kindl, 3.0_kindl, -2.0_kindl, 0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl, & + 5*0.0_kindl, -3.0_kindl, 6.0_kindl, -3.0_kindl, 0.0_kindl, 2.0_kindl, -4.0_kindl, 2.0_kindl,9*0.0_kindl,& + 3.0_kindl, -6.0_kindl, 3.0_kindl, 0.0_kindl, -2.0_kindl, 4.0_kindl, -2.0_kindl, 10*0.0_kindl,-3.0_kindl,& + 3.0_kindl, 2*0.0_kindl, 2.0_kindl, -2.0_kindl, 2*0.0_kindl, -1.0_kindl, 1.0_kindl,6*0.0_kindl,3.0_kindl,& + -3.0_kindl, 2*0.0_kindl, -2.0_kindl, 2.0_kindl, 5*0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl,0.0_kindl,& + -2.0_kindl, 4.0_kindl, -2.0_kindl, 0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl, 9*0.0_kindl, -1.0_kindl,& + 2.0_kindl, -1.0_kindl, 0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl, 10*0.0_kindl, 1.0_kindl, -1.0_kindl,& + 2*0.0_kindl, -1.0_kindl, 1.0_kindl, 6*0.0_kindl, -1.0_kindl, 1.0_kindl, 2*0.0_kindl, 2.0_kindl, & + -2.0_kindl, 2*0.0_kindl, -1.0_kindl, 1.0_kindl/ + + + + d1d2=d1*d2 + do i=1,4 + x(i)=y(i) + x(i+4)=y1(i)*d1 + x(i+8)=y2(i)*d2 + x(i+12)=y12(i)*d1d2 + enddo + do i=1,16 + xx=0.0_kindl + do k=1,16 + xx=xx+wt(i,k)*x(k) + enddo + cl(i)=xx + enddo + l=0 + do i=1,4 + do j=1,4 + l=l+1 + c(i,j)=cl(l) + enddo + enddo + return +! (c) copr. 1986-92 numerical recipes software -3#(-)f. + end subroutine BCUCOF_ + +!----------------------------------------------------------------------- + +!! TODO These routines are redundant, we can find the lower neighbor and add 1 +!> find the lower neighbour of xf in field xc, return is the index + function INDL_(xc, xf) + real(FMS_HI_KIND_), intent(in) :: xc(1:) + real(FMS_HI_KIND_), intent(in) :: xf + integer :: INDL_ + integer :: ii + INDL_ = 1 + do ii=1, size(xc) + if(xc(ii).gt.xf) return + INDL_ = ii + enddo + call mpp_error(FATAL,'Error in INDL_') + return + end function INDL_ + +!----------------------------------------------------------------------- + +!> find the upper neighbour of xf in field xc, return is the index + function INDU_(xc, xf) + real(FMS_HI_KIND_), intent(in) :: xc(1:) + real(FMS_HI_KIND_), intent(in) :: xf + integer :: INDU_ + integer :: ii + do ii=1, size(xc) + INDU_ = ii + if(xc(ii).gt.xf) return + enddo + call mpp_error(FATAL,'Error in INDU_') + return + end function INDU_ + +!----------------------------------------------------------------------- + + subroutine FILL_XY_(fi, ics, ice, jcs, jce, mask, maxpass) + integer, intent(in) :: ics,ice,jcs,jce + real(FMS_HI_KIND_), intent(inout) :: fi(ics:ice,jcs:jce) + real(FMS_HI_KIND_), intent(in), optional :: mask(ics:ice,jcs:jce) + integer, intent(in) :: maxpass + real(FMS_HI_KIND_) :: work_old(ics:ice,jcs:jce) + real(FMS_HI_KIND_) :: work_new(ics:ice,jcs:jce) + logical :: ready + integer, parameter :: kindl = FMS_HI_KIND_ + real(FMS_HI_KIND_), parameter :: blank = real(-1.e30, FMS_HI_KIND_) + real(FMS_HI_KIND_) :: tavr + integer :: ipass + integer :: inl, inr, jnl, jnu, i, j, is, js, iavr + + + ready = .false. + + work_new(:,:) = fi(:,:) + work_old(:,:) = work_new(:,:) + ipass = 0 + if ( present(mask) ) then + do while (.not.ready) + ipass = ipass+1 + ready = .true. + do j=jcs, jce + do i=ics, ice + if (work_old(i,j).le.blank) then + tavr=0.0_kindl + iavr=0 + inl = max(i-1,ics) + inr = min(i+1,ice) + jnl = max(j-1,jcs) + jnu = min(j+1,jce) + do js=jnl,jnu + do is=inl,inr + if (work_old(is,js) .ne. blank .and. mask(is,js).ne.0.0_kindl) then + tavr = tavr + work_old(is,js) + iavr = iavr+1 + endif + enddo + enddo + if (iavr.gt.0) then + if (iavr.eq.1) then +! spreading is not allowed if the only valid neighbor is a corner point +! otherwise an ill posed cellular automaton is established leading to +! a spreading of constant values in diagonal direction +! if all corner points are blanked the valid neighbor must be a direct one +! and spreading is allowed + if (work_old(inl,jnu).eq.blank.and.& + work_old(inr,jnu).eq.blank.and.& + work_old(inr,jnl).eq.blank.and.& + work_old(inl,jnl).eq.blank) then + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + else + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + endif + endif + enddo ! j + enddo ! i +! save changes made during this pass to work_old + work_old(:,:)=work_new(:,:) + if(ipass.eq.maxpass) ready=.true. + enddo !while (.not.ready) + fi(:,:) = work_new(:,:) + else + do while (.not.ready) + ipass = ipass+1 + ready = .true. + do j=jcs, jce + do i=ics, ice + if (work_old(i,j).le.blank) then + tavr=0.0_kindl + iavr=0 + inl = max(i-1,ics) + inr = min(i+1,ice) + jnl = max(j-1,jcs) + jnu = min(j+1,jce) + do is=inl,inr + do js=jnl,jnu + if (work_old(is,js).gt.blank) then + tavr = tavr + work_old(is,js) + iavr = iavr+1 + endif + enddo + enddo + if (iavr.gt.0) then + if (iavr.eq.1) then +! spreading is not allowed if the only valid neighbor is a corner point +! otherwise an ill posed cellular automaton is established leading to +! a spreading of constant values in diagonal direction +! if all corner points are blanked the valid neighbor must be a direct one +! and spreading is allowed + if (work_old(inl,jnu).le.blank.and. & + work_old(inr,jnu).le.blank.and. & + work_old(inr,jnl).le.blank.and. & + work_old(inl,jnl).le.blank) then + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + else + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + endif + endif + enddo ! j + enddo ! i +! save changes made during this pass to work_old + work_old(:,:)=work_new(:,:) + if(ipass.eq.maxpass) ready=.true. + enddo !while (.not.ready) + fi(:,:) = work_new(:,:) + endif + return + end subroutine FILL_XY_ +!> @} diff --git a/horiz_interp/include/horiz_interp_bicubic_r4.fh b/horiz_interp/include/horiz_interp_bicubic_r4.fh new file mode 100644 index 0000000000..a76afa5758 --- /dev/null +++ b/horiz_interp/include/horiz_interp_bicubic_r4.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bicubic +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_S_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_S_ horiz_interp_bicubic_new_1d_s_r4 + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_ horiz_interp_bicubic_new_1d_r4 + +#undef HORIZ_INTERP_BICUBIC_NEW_ +#define HORIZ_INTERP_BICUBIC_NEW_ horiz_interp_bicubic_r4 + +#undef BCUINT_ +#define BCUINT_ bcuint_r4 + +#undef BCUCOF_ +#define BCUCOF_ bcucof_r4 + +#undef INDL_ +#define INDL_ indl_r4 + +#undef INDU_ +#define INDU_ indu_r4 + +#undef FILL_XY_ +#define FILL_XY_ fill_xy_r4 + +#include "horiz_interp_bicubic.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_bicubic_r8.fh b/horiz_interp/include/horiz_interp_bicubic_r8.fh new file mode 100644 index 0000000000..4d0bac58db --- /dev/null +++ b/horiz_interp/include/horiz_interp_bicubic_r8.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bicubic +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_S_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_S_ horiz_interp_bicubic_new_1d_s_r8 + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_ horiz_interp_bicubic_new_1d_r8 + +#undef HORIZ_INTERP_BICUBIC_NEW_ +#define HORIZ_INTERP_BICUBIC_NEW_ horiz_interp_bicubic_r8 + +#undef BCUINT_ +#define BCUINT_ bcuint_r8 + +#undef BCUCOF_ +#define BCUCOF_ bcucof_r8 + +#undef INDL_ +#define INDL_ indl_r8 + +#undef INDU_ +#define INDU_ indu_r8 + +#undef FILL_XY_ +#define FILL_XY_ fill_xy_r8 + +#include "horiz_interp_bicubic.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_bilinear.inc b/horiz_interp/include/horiz_interp_bilinear.inc new file mode 100644 index 0000000000..7b6fcd7ed2 --- /dev/null +++ b/horiz_interp/include/horiz_interp_bilinear.inc @@ -0,0 +1,1230 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bilinear_mod +!> @{ + subroutine HORIZ_INTERP_BILINEAR_NEW_1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + logical, intent(in), optional :: src_modulo + + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m + integer :: ie, is, je, js, ln_err, lt_err, warns, unit + real(FMS_HI_KIND_) :: wtw, wte, wts, wtn, lon, lat, tpi, hpi + real(FMS_HI_KIND_) :: glt_min, glt_max, gln_min, gln_max, min_lon, max_lon + integer,parameter :: kindl = FMS_HI_KIND_ + + warns = 0 + if(present(verbose)) warns = verbose + src_is_modulo = .true. + if (present(src_modulo)) src_is_modulo = src_modulo + + hpi = 0.5_kindl * real(pi, FMS_HI_KIND_) + tpi = 4.0_kindl * hpi + glt_min = hpi + glt_max = -hpi + gln_min = tpi + gln_max = -tpi + min_lon = 0.0_kindl + max_lon = tpi + ln_err = 0 + lt_err = 0 + !----------------------------------------------------------------------- + + allocate ( Interp % HI_KIND_TYPE_ % wti (size(lon_out,1),size(lon_out,2),2), & + Interp % HI_KIND_TYPE_ % wtj (size(lon_out,1),size(lon_out,2),2), & + Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & + Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) + !----------------------------------------------------------------------- + + nlon_in = size(lon_in(:)) ; nlat_in = size(lat_in(:)) + nlon_out = size(lon_out, 1); nlat_out = size(lon_out, 2) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + + if(src_is_modulo) then + if(lon_in(nlon_in) - lon_in(1) .gt. tpi + real(epsln, FMS_HI_KIND_)) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: '// & + 'The range of source grid longitude should be no larger than tpi') + + if(lon_in(1) .lt. 0.0_kindl .OR. lon_in(nlon_in) > tpi ) then + min_lon = lon_in(1) + max_lon = lon_in(nlon_in) + endif + endif + + do n = 1, nlat_out + do m = 1, nlon_out + lon = lon_out(m,n) + lat = lat_out(m,n) + + if(src_is_modulo) then + if(lon .lt. min_lon) then + lon = lon + tpi + else if(lon .gt. max_lon) then + lon = lon - tpi + endif + else ! when the input grid is in not cyclic, the output grid should located inside + ! the input grid + if((lon .lt. lon_in(1)) .or. (lon .gt. lon_in(nlon_in))) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& + 'when input grid is not modulo, output grid should locate inside input grid') + endif + + glt_min = min(lat,glt_min); glt_max = max(lat,glt_max) + gln_min = min(lon,gln_min); gln_max = max(lon,gln_max) + + is = indp(lon, lon_in ) + if( lon_in(is) .gt. lon ) is = max(is-1,1) + if( lon_in(is) .eq. lon .and. is .eq. nlon_in) is = max(is - 1,1) + ie = min(is+1,nlon_in) + if(lon_in(is) .ne. lon_in(ie) .and. lon_in(is) .le. lon) then + wtw = ( lon_in(ie) - lon) / (lon_in(ie) - lon_in(is) ) + else + ! east or west of the last data value. this could be because a + ! cyclic condition is needed or the dataset is too small. + ln_err = 1 + ie = 1 + is = nlon_in + if (lon_in(ie) .ge. lon ) then + wtw = (lon_in(ie) -lon)/(lon_in(ie)-lon_in(is)+tpi+real(epsln,FMS_HI_KIND_)) + else + wtw = (lon_in(ie)-lon+tpi+real(epsln,FMS_HI_KIND_))/(lon_in(ie)-lon_in(is)+tpi+real(epsln,FMS_HI_KIND_)) + endif + endif + wte = 1.0_kindl - wtw + + js = indp(lat, lat_in ) + + if( lat_in(js) .gt. lat ) js = max(js - 1, 1) + if( lat_in(js) .eq. lat .and. js .eq. nlat_in) js = max(js - 1, 1) + je = min(js + 1, nlat_in) + + if ( lat_in(js) .ne. lat_in(je) .and. lat_in(js) .le. lat) then + wts = ( lat_in(je) - lat )/(lat_in(je)-lat_in(js)) + else + ! north or south of the last data value. this could be because a + ! pole is not included in the data set or the dataset is too small. + ! in either case extrapolate north or south + lt_err = 1 + wts = 1.0_kindl + endif + + wtn = 1.0_kindl - wts + + Interp % i_lon (m,n,1) = is; Interp % i_lon (m,n,2) = ie + Interp % j_lat (m,n,1) = js; Interp % j_lat (m,n,2) = je + Interp % HI_KIND_TYPE_ % wti (m,n,1) = wtw + Interp % HI_KIND_TYPE_ % wti (m,n,2) = wte + Interp % HI_KIND_TYPE_ % wtj (m,n,1) = wts + Interp % HI_KIND_TYPE_ % wtj (m,n,2) = wtn + + enddo + enddo + + unit = stdout() + + if (ln_err .eq. 1 .and. warns > 0) then + write (unit,'(/,(1x,a))') & + '==> Warning: the geographic data set does not extend far ', & + ' enough east or west - a cyclic boundary ', & + ' condition was applied. check if appropriate ' + write (unit,'(/,(1x,a,2f8.4))') & + ' data required between longitudes:', gln_min, gln_max, & + ' data set is between longitudes:', lon_in(1), lon_in(nlon_in) + warns = warns - 1 + endif + + if (lt_err .eq. 1 .and. warns > 0) then + write (unit,'(/,(1x,a))') & + '==> Warning: the geographic data set does not extend far ',& + ' enough north or south - extrapolation from ',& + ' the nearest data was applied. this may create ',& + ' artificial gradients near a geographic pole ' + write (unit,'(/,(1x,a,2f8.4))') & + ' data required between latitudes:', glt_min, glt_max, & + ' data set is between latitudes:', lat_in(1), lat_in(nlat_in) + endif + + return + + end subroutine HORIZ_INTERP_BILINEAR_NEW_1D_ + + !####################################################################### + + !> Initialization routine. + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_BILINEAR_NEW_2D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo, new_search, no_crash_when_not_found ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices + !! and weights for subsequent interpolations. To + !! reinitialize for different grid-to-grid interpolation + !! @ref horiz_interp_del must be used first. + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid + integer, intent(in), optional :: verbose !< flag for amount of print output + logical, intent(in), optional :: src_modulo !< indicates if the boundary condition + !! along zonal boundary is cyclic or not. Cyclic when true + logical, intent(in), optional :: new_search + logical, intent(in), optional :: no_crash_when_not_found + integer :: warns + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: m, n, is, ie, js, je, num_solution + real(FMS_HI_KIND_) :: lon, lat, quadra, x, y, y1, y2 + real(FMS_HI_KIND_) :: a1, b1, c1, d1, a2, b2, c2, d2, a, b, c + real(FMS_HI_KIND_) :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 + real(FMS_HI_KIND_) :: tpi, lon_min, lon_max + real(FMS_HI_KIND_) :: epsln2 + logical :: use_new_search, no_crash + + integer, parameter :: kindl=FMS_HI_KIND_ + + tpi = 2.0_kindl * real(pi, FMS_HI_KIND_) + + warns = 0 + if(present(verbose)) warns = verbose + src_is_modulo = .true. + if (present(src_modulo)) src_is_modulo = src_modulo + use_new_search = .false. + if (present(new_search)) use_new_search = new_search + no_crash = .false. + if(present(no_crash_when_not_found)) no_crash = no_crash_when_not_found + + ! make sure lon and lat has the same dimension + if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & + 'interplation, the output grids should be geographical grids') + + if(size(lon_in,1) /= size(lat_in,1) .or. size(lon_in,2) /= size(lat_in,2) ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear '// & + 'interplation, the input grids should be geographical grids') + + !--- get the grid size + nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) + nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + + allocate ( Interp % HI_KIND_TYPE_ % wti (size(lon_out,1),size(lon_out,2),2), & + Interp % HI_KIND_TYPE_ % wtj (size(lon_out,1),size(lon_out,2),2), & + Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & + Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) + + !--- first fine the neighbor points for the destination points. + if(use_new_search) then + epsln2 = real(epsln,FMS_HI_KIND_)* 1.0e5_kindl + call FIND_NEIGHBOR_NEW_(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo, no_crash) + else + epsln2 = real(epsln,FMS_HI_KIND_) + call FIND_NEIGHBOR_(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo) + endif + + !*************************************************************************** + ! Algorithm explanation (from disscussion with Steve Garner ) * + ! * + ! lon(x,y) = a1*x + b1*y + c1*x*y + d1 (1) * + ! lat(x,y) = a2*x + b2*y + c2*x*y + d2 (2) * + ! f (x,y) = a3*x + b3*y + c3*x*y + d3 (3) * + ! with x and y is between 0 and 1. * + ! lon1 = lon(0,0) = d1, lat1 = lat(0,0) = d2 * + ! lon2 = lon(1,0) = a1+d1, lat2 = lat(1,0) = a2+d2 * + ! lon3 = lon(1,1) = a1+b1+c1+d1, lat3 = lat(1,1) = a2+b2+c2+d2 * + ! lon4 = lon(0,1) = b1+d1, lat4 = lat(0,1) = b2+d2 * + ! where (lon1,lat1),(lon2,lat2),(lon3,lat3),(lon4,lat4) represents * + ! the four corners starting from the left lower corner of grid box * + ! that encloses a destination grid ( the rotation direction is * + ! counterclockwise ). With these conditions, we get * + ! a1 = lon2-lon1, a2 = lat2-lat1 * + ! b1 = lon4-lon1, b2 = lat4-lat1 * + ! c1 = lon3-lon2-lon4+lon1, c2 = lat3-lat2-lat4+lat1 * + ! d1 = lon1 d2 = lat1 * + ! So given any point (lon,lat), from equation (1) and (2) we can * + ! solve (x,y). * + ! From equation (3) * + ! f1 = f(0,0) = d3, f2 = f(1,0) = a3+d3 * + ! f3 = f(1,1) = a3+b3+c3+d3, f4 = f(0,1) = b3+d3 * + ! we obtain * + ! a3 = f2-f1, b3 = f4-f1 * + ! c3 = f3-f2-f4+f1, d3 = f1 * + ! at point (lon,lat) ---> (x,y) * + ! f(x,y) = (f2-f1)x + (f4-f1)y + (f3-f2-f4+f1)xy + f1 * + ! = f1*(1-x)*(1-y) + f2*x*(1-y) + f3*x*y + f4*y*(1-x) * + ! wtw=1-x; wte=x; wts=1-y; xtn=y * + ! * + !*************************************************************************** + + lon_min = minval(lon_in); + lon_max = maxval(lon_in); + !--- calculate the weight + do n = 1, nlat_out + do m = 1, nlon_out + lon = lon_out(m,n) + lat = lat_out(m,n) + if(lon .lt. lon_min) then + lon = lon + tpi + else if(lon .gt. lon_max) then + lon = lon - tpi + endif + is = Interp%i_lon(m,n,1); ie = Interp%i_lon(m,n,2) + js = Interp%j_lat(m,n,1); je = Interp%j_lat(m,n,2) + if( is == DUMMY) cycle + lon1 = lon_in(is,js); lat1 = lat_in(is,js); + lon2 = lon_in(ie,js); lat2 = lat_in(ie,js); + lon3 = lon_in(ie,je); lat3 = lat_in(ie,je); + lon4 = lon_in(is,je); lat4 = lat_in(is,je); + if(lon .lt. lon_min) then + lon1 = lon1 -tpi; lon4 = lon4 - tpi + else if(lon .gt. lon_max) then + lon2 = lon2 +tpi; lon3 = lon3 + tpi + endif + a1 = lon2-lon1 + b1 = lon4-lon1 + c1 = lon1+lon3-lon4-lon2 + d1 = lon1 + a2 = lat2-lat1 + b2 = lat4-lat1 + c2 = lat1+lat3-lat4-lat2 + d2 = lat1 + !--- the coefficient of the quadratic equation + a = b2*c1-b1*c2 + b = a1*b2-a2*b1+c1*d2-c2*d1+c2*lon-c1*lat + c = a2*lon-a1*lat+a1*d2-a2*d1 + quadra = b*b-4._kindl*a*c + if(abs(quadra) < real(epsln, FMS_HI_KIND_)) quadra = 0.0_kindl + if(quadra < 0.0_kindl) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: No solution existed for this quadratic equation") + if ( abs(a) .lt. epsln2) then ! a = 0 is a linear equation + if( abs(b) .lt. real(epsln,FMS_HI_KIND_)) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: no unique solution existed for this linear equation") + y = -c/b + else + y1 = 0.5_kindl*(-b+sqrt(quadra))/a + y2 = 0.5_kindl*(-b-sqrt(quadra))/a + if(abs(y1) < epsln2) y1 = 0.0_kindl + if(abs(y2) < epsln2) y2 = 0.0_kindl + if(abs(1.0_kindl-y1) < epsln2) y1 = 1.0_kindl + if(abs(1.0_kindl-y2) < epsln2) y2 = 1.0_kindl + num_solution = 0 + if(y1 >= 0.0_kindl .and. y1 <= 1.0_kindl) then + y = y1 + num_solution = num_solution +1 + endif + if(y2 >= 0.0_kindl .and. y2 <= 1.0_kindl) then + y = y2 + num_solution = num_solution + 1 + endif + if(num_solution == 0) then + call mpp_error(FATAL, "horiz_interp_bilinear_mod: No solution found") + else if(num_solution == 2) then + call mpp_error(FATAL, "horiz_interp_bilinear_mod: Two solutions found") + endif + endif + if(abs(a1+c1*y) < real(epsln,FMS_HI_KIND_)) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: the denomenator is 0") + if(abs(y) < epsln2) y = 0.0_kindl + if(abs(1.0_kindl-y) < epsln2) y = 1.0_kindl + x = (lon-b1*y-d1)/(a1+c1*y) + if(abs(x) < epsln2) x = 0.0_kindl + if(abs(1.0_kindl-x) < epsln2) x = 1.0_kindl + ! x and y should be between 0 and 1. + !! Added for ECDA + if(use_new_search) then + if (x < 0.0_kindl) x = 0.0_kindl ! snz + if (y < 0.0_kindl) y = 0.0_kindl ! snz + if (x > 1.0_kindl) x = 1.0_kindl + if (y > 1.0_kindl) y = 1.0_kindl + endif + if( x>1.0_kindl .or. x<0.0_kindl .or. y>1.0_kindl .or. y < 0.0_kindl) & + call mpp_error(FATAL, "horiz_interp_bilinear_mod: weight should be between 0 and 1") + Interp % HI_KIND_TYPE_ % wti(m,n,1)=1.0_kindl-x + Interp % HI_KIND_TYPE_ % wti(m,n,2)=x + Interp % HI_KIND_TYPE_ % wtj(m,n,1)=1.0_kindl-y + Interp % HI_KIND_TYPE_ % wtj(m,n,2)=y + enddo + enddo + + end subroutine + + !####################################################################### + !> this routine will search the source grid to fine the grid box that encloses + !! each destination grid. + subroutine FIND_NEIGHBOR_ ( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + logical, intent(in) :: src_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: max_step, n, m, l, i, j, ip1, jp1, step + integer :: is, js, jstart, jend, istart, iend, npts + integer, allocatable, dimension(:) :: ilon, jlat + real(FMS_HI_KIND_) :: lon_min, lon_max, lon, lat, tpi + logical :: found + real(FMS_HI_KIND_) :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 + + integer, parameter :: kindl=FMS_HI_KIND_ + + tpi = 2.0_kindl*real(pi, FMS_HI_KIND_) + nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) + nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) + + lon_min = minval(lon_in); + lon_max = maxval(lon_in); + + max_step = max(nlon_in,nlat_in) ! can be adjusted if needed + allocate(ilon(5*max_step), jlat(5*max_step) ) + + do n = 1, nlat_out + do m = 1, nlon_out + found = .false. + lon = lon_out(m,n) + lat = lat_out(m,n) + + if(src_modulo) then + if(lon .lt. lon_min) then + lon = lon + tpi + else if(lon .gt. lon_max) then + lon = lon - tpi + endif + else + if(lon .lt. lon_min .or. lon .gt. lon_max ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& + 'when input grid is not modulo, output grid should locate inside input grid') + endif + !--- search for the surrounding four points locatioon. + if(m==1 .and. n==1) then + J_LOOP: do j = 1, nlat_in-1 + do i = 1, nlon_in + ip1 = i+1 + jp1 = j+1 + if(i==nlon_in) then + if(src_modulo)then + ip1 = 1 + else + cycle + endif + endif + lon1 = lon_in(i, j); lat1 = lat_in(i,j) + lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) + lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) + lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) + + if(lon .lt. lon_min .or. lon .gt. lon_max) then + if(i .ne. nlon_in) then + cycle + else + if(lon .lt. lon_min) then + lon1 = lon1 -tpi; lon4 = lon4 - tpi + else if(lon .gt. lon_max) then + lon2 = lon2 +tpi; lon3 = lon3 + tpi + endif + endif + endif + + if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south + if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east + if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then ! north + if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west + found = .true. + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit J_LOOP + endif + endif + endif + endif + enddo + enddo J_LOOP + else + step = 0 + do while ( .not. found .and. step .lt. max_step ) + !--- take the adajcent point as the starting point + if(m == 1) then + is = Interp % i_lon (m,n-1,1) + js = Interp % j_lat (m,n-1,1) + else + is = Interp % i_lon (m-1,n,1) + js = Interp % j_lat (m-1,n,1) + endif + if(step==0) then + npts = 1 + ilon(1) = is + jlat(1) = js + else + npts = 0 + !--- bottom boundary + jstart = max(js-step,1) + jend = min(js+step,nlat_in) + + do l = -step, step + i = is+l + if(src_modulo)then + if( i < 1) then + i = i + nlon_in + else if (i > nlon_in) then + i = i - nlon_in + endif + if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) + else + if( i < 1 .or. i > nlon_in) cycle + endif + + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jstart + enddo + + !--- right and left boundary ----------------------------------------------- + istart = is - step + iend = is + step + if(src_modulo) then + if( istart < 1) istart = istart + nlon_in + if( iend > nlon_in) iend = iend - nlon_in + else + istart = max(istart,1) + iend = min(iend, nlon_in) + endif + do l = -step, step + j = js+l + if( j < 1 .or. j > nlat_in .or. j==jstart .or. j==jend) cycle + npts = npts+1 + ilon(npts) = istart + jlat(npts) = j + npts = npts+1 + ilon(npts) = iend + jlat(npts) = j + end do + + !--- top boundary + + do l = -step, step + i = is+l + if(src_modulo)then + if( i < 1) then + i = i + nlon_in + else if (i > nlon_in) then + i = i - nlon_in + endif + if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) + else + if( i < 1 .or. i > nlon_in) cycle + endif + + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jend + enddo + + + end if + + !--- find the surrouding points + do l = 1, npts + i = ilon(l) + j = jlat(l) + ip1 = i+1 + if(ip1>nlon_in) then + if(src_modulo) then + ip1 = 1 + else + cycle + endif + endif + jp1 = j+1 + if(jp1>nlat_in) cycle + lon1 = lon_in(i, j); lat1 = lat_in(i,j) + lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) + lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) + lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) + + if(lon .lt. lon_min .or. lon .gt. lon_max) then + if(i .ne. nlon_in) then + cycle + else + if(lon .lt. lon_min) then + lon1 = lon1 -tpi; lon4 = lon4 - tpi + else if(lon .gt. lon_max) then + lon2 = lon2 +tpi; lon3 = lon3 + tpi + endif + endif + endif + + if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south + if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east + if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then !north + if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west + found = .true. + is=i; js=j + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit + endif + endif + endif + endif + enddo + step = step + 1 + enddo + endif + if(.not.found) then + print *,'lon,lat=',lon*180.0_kindl/real(PI,FMS_HI_KIND_),lat*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'npts=',npts + print *,'is,ie= ',istart,iend + print *,'js,je= ',jstart,jend + print *,'lon_in(is,js)=',lon_in(istart,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lon_in(ie,js)=',lon_in(iend,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(is,js)=',lat_in(istart,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(ie,js)=',lat_in(iend,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lon_in(is,je)=',lon_in(istart,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lon_in(ie,je)=',lon_in(iend,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(is,je)=',lat_in(istart,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(ie,je)=',lat_in(iend,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + + call mpp_error(FATAL, & + 'FIND_NEIGHBOR_: the destination point is not inside the source grid' ) + endif + enddo + enddo + + end subroutine + + !####################################################################### + + !> The function will return true if the point x,y is inside a polygon, or + !! false if it is not. If the point is exactly on the edge of a polygon, + !! the function will return .true. + function INSIDE_POLYGON_(polyx, polyy, x, y) + real(FMS_HI_KIND_), dimension(:), intent(in) :: polyx !< longitude coordinates of corners + real(FMS_HI_KIND_), dimension(:), intent(in) :: polyy !< latitude coordinates of corners + real(FMS_HI_KIND_), intent(in) :: x !< x coordinate of point to be tested + real(FMS_HI_KIND_), intent(in) :: y !< y coordinate of point to be tested + logical :: INSIDE_POLYGON_ + integer :: i, j, nedges + real(FMS_HI_KIND_) :: xx + + INSIDE_POLYGON_ = .false. + nedges = size(polyx(:)) + j = nedges + do i = 1, nedges + if( (polyy(i) < y .AND. polyy(j) >= y) .OR. (polyy(j) < y .AND. polyy(i) >= y) ) then + xx = polyx(i)+(y-polyy(i))/(polyy(j)-polyy(i))*(polyx(j)-polyx(i)) + if( xx == x ) then + INSIDE_POLYGON_ = .true. + return + else if( xx < x ) then + INSIDE_POLYGON_ = .not. INSIDE_POLYGON_ + endif + endif + j = i + enddo + + return + + end function + + !####################################################################### + !> this routine will search the source grid to fine the grid box that encloses + !! each destination grid. + subroutine FIND_NEIGHBOR_NEW_( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo, no_crash ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + logical, intent(in) :: src_modulo, no_crash + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: max_step, n, m, l, i, j, ip1, jp1, step + integer :: is, js, jstart, jend, istart, iend, npts + integer, allocatable, dimension(:) :: ilon, jlat + real(FMS_HI_KIND_) :: lon_min, lon_max, lon, lat, tpi + logical :: found + real(FMS_HI_KIND_) :: polyx(4), polyy(4) + real(FMS_HI_KIND_) :: min_lon, min_lat, max_lon, max_lat + + integer, parameter :: step_div=8, kindl = FMS_HI_KIND_ + + tpi = 2.0_kindl * real(pi, FMS_HI_KIND_) + nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) + nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) + + lon_min = minval(lon_in); + lon_max = maxval(lon_in); + + max_step = min(nlon_in,nlat_in)/step_div ! can be adjusted if needed + allocate(ilon(step_div*max_step), jlat(step_div*max_step) ) + + do n = 1, nlat_out + do m = 1, nlon_out + found = .false. + lon = lon_out(m,n) + lat = lat_out(m,n) + + if(src_modulo) then + if(lon .lt. lon_min) then + lon = lon + tpi + else if(lon .gt. lon_max) then + lon = lon - tpi + endif + else + if(lon .lt. lon_min .or. lon .gt. lon_max ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& + 'when input grid is not modulo, output grid should locate inside input grid') + endif + !--- search for the surrounding four points locatioon. + if(m==1 .and. n==1) then + J_LOOP: do j = 1, nlat_in-1 + do i = 1, nlon_in + ip1 = i+1 + jp1 = j+1 + if(i==nlon_in) then + if(src_modulo)then + ip1 = 1 + else + cycle + endif + endif + + polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) + polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) + polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) + polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) + if(lon .lt. lon_min .or. lon .gt. lon_max) then + if(i .ne. nlon_in) then + cycle + else + if(lon .lt. lon_min) then + polyx(1) = polyx(1) -tpi; polyx(4) = polyx(4) - tpi + else if(lon .gt. lon_max) then + polyx(2) = polyx(2) +tpi; polyx(3) = polyx(3) + tpi + endif + endif + endif + + min_lon = minval(polyx) + max_lon = maxval(polyx) + min_lat = minval(polyy) + max_lat = maxval(polyy) +! if( lon .GE. min_lon .AND. lon .LE. max_lon .AND. & +! lat .GE. min_lat .AND. lat .LE. max_lat ) then +! print*, 'i =', i, 'j = ', j +! print '(5f15.11)', lon, polyx +! print '(5f15.11)', lat, polyy +! endif + + if(INSIDE_POLYGON_(polyx, polyy, lon, lat)) then + found = .true. +! print*, " found ", i, j + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit J_LOOP + endif + enddo + enddo J_LOOP + else + step = 0 + do while ( .not. found .and. step .lt. max_step ) + !--- take the adajcent point as the starting point + if(m == 1) then + is = Interp % i_lon (m,n-1,1) + js = Interp % j_lat (m,n-1,1) + else + is = Interp % i_lon (m-1,n,1) + js = Interp % j_lat (m-1,n,1) + endif + if(step==0) then + npts = 1 + ilon(1) = is + jlat(1) = js + else + npts = 0 + !--- bottom and top boundary + jstart = max(js-step,1) + jend = min(js+step,nlat_in) + + do l = -step, step + i = is+l + if(src_modulo)then + if( i < 1) then + i = i + nlon_in + else if (i > nlon_in) then + i = i - nlon_in + endif + if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) + else + if( i < 1 .or. i > nlon_in) cycle + endif + + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jstart + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jend + enddo + + !--- right and left boundary ----------------------------------------------- + istart = is - step + iend = is + step + if(src_modulo) then + if( istart < 1) istart = istart + nlon_in + if( iend > nlon_in) iend = iend - nlon_in + else + istart = max(istart,1) + iend = min(iend, nlon_in) + endif + do l = -step, step + j = js+l + if( j < 1 .or. j > nlat_in) cycle + npts = npts+1 + ilon(npts) = istart + jlat(npts) = j + npts = npts+1 + ilon(npts) = iend + jlat(npts) = j + end do + end if + + !--- find the surrouding points + do l = 1, npts + i = ilon(l) + j = jlat(l) + ip1 = i+1 + if(ip1>nlon_in) then + if(src_modulo) then + ip1 = 1 + else + cycle + endif + endif + jp1 = j+1 + if(jp1>nlat_in) cycle + polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) + polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) + polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) + polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) + if(INSIDE_POLYGON_(polyx, polyy, lon, lat)) then + found = .true. + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit + endif + enddo + step = step + 1 + enddo + endif + if(.not.found) then + if(no_crash) then + Interp % i_lon (m,n,1:2) = DUMMY + Interp % j_lat (m,n,1:2) = DUMMY + print*,'lon,lat=',lon,lat ! snz + else + call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: the destination point is not inside the source grid' ) + endif + endif + enddo + enddo + + end subroutine + + !####################################################################### + function INTERSECT_(x1, y1, x2, y2, x) + real(FMS_HI_KIND_), intent(in) :: x1, y1, x2, y2, x + real(FMS_HI_KIND_) :: INTERSECT_ + + INTERSECT_ = (y2-y1)*(x-x1)/(x2-x1) + y1 + + return + + end function INTERSECT_ + + !####################################################################### + + !> Subroutine for performing the horizontal interpolation between two grids + !! + !! @ref horiz_interp_bilinear_new must be called before calling this routine. + subroutine HORIZ_INTERP_BILINEAR_ ( Interp, data_in, data_out, verbose, mask_in,mask_out, & + missing_value, missing_permit, new_handle_missing ) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp !< Derived type variable containing + !! interpolation indices and weights. Returned by a + !! previous call to horiz_interp_bilinear_new + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< input data on source grid + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< output data on source grid + integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = + !! all output + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as + !! the input data. The real(FMS_HI_KIND_) value of mask_in must be in the + !! range (0.,1.). Set mask_in=0.0 for data points + !! that should not be used or have missing data + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out !< output mask that specifies whether + !! data was computed + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + logical, intent(in), optional :: new_handle_missing + !----------------------------------------------------------------------- + integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m, & + is, ie, js, je, iverbose, max_missing, num_missing, & + miss_in, miss_out, unit + real(FMS_HI_KIND_) :: dwtsum, wtsum, min_in, max_in, avg_in, & + min_out, max_out, avg_out, wtw, wte, wts, wtn + real(FMS_HI_KIND_) :: mask(size(data_in,1), size(data_in,2) ) + logical :: set_to_missing, is_missing(4), new_handler + real(FMS_HI_KIND_) :: f1, f2, f3, f4, middle, w, s + integer, parameter :: kindl = FMS_HI_KIND_ + + num_missing = 0 + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + if(present(mask_in)) then + mask = mask_in + else + mask = 1.0_kindl + endif + + if (present(verbose)) then + iverbose = verbose + else + iverbose = 0 + endif + + if(present(missing_permit)) then + max_missing = missing_permit + else + max_missing = 0 + endif + + if(present(new_handle_missing)) then + new_handler = new_handle_missing + else + new_handler = .false. + endif + + if(max_missing .gt. 3 .or. max_missing .lt. 0) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: missing_permit should be between 0 and 3') + + if (size(data_in,1) /= nlon_in .or. size(data_in,2) /= nlat_in) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of input array incorrect') + + if (size(data_out,1) /= nlon_out .or. size(data_out,2) /= nlat_out) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of output array incorrect') + + if(new_handler) then + if( .not. present(missing_value) ) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: misisng_value must be present when new_handle_missing is .true.") + if( present(mask_in) ) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: mask_in should not be present when new_handle_missing is .true.") + do n = 1, nlat_out + do m = 1, nlon_out + is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) + js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) + wtw = Interp % HI_KIND_TYPE_ % wti (m,n,1) + wte = Interp % HI_KIND_TYPE_ % wti (m,n,2) + wts = Interp % HI_KIND_TYPE_ % wtj (m,n,1) + wtn = Interp % HI_KIND_TYPE_ % wtj (m,n,2) + + is_missing = .false. + num_missing = 0 + set_to_missing = .false. + if(data_in(is,js) == missing_value) then + num_missing = num_missing+1 + is_missing(1) = .true. + if(wtw .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl) set_to_missing = .true. + endif + + if(data_in(ie,js) == missing_value) then + num_missing = num_missing+1 + is_missing(2) = .true. + if(wte .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl ) set_to_missing = .true. + endif + if(data_in(ie,je) == missing_value) then + num_missing = num_missing+1 + is_missing(3) = .true. + if(wte .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl ) set_to_missing = .true. + endif + if(data_in(is,je) == missing_value) then + num_missing = num_missing+1 + is_missing(4) = .true. + if(wtw .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl) set_to_missing = .true. + endif + + if( num_missing == 4 .OR. set_to_missing ) then + data_out(m,n) = missing_value + if(present(mask_out)) mask_out(m,n) = 0.0_kindl + cycle + else if(num_missing == 0) then + f1 = data_in(is,js) + f2 = data_in(ie,js) + f3 = data_in(ie,je) + f4 = data_in(is,je) + w = wtw + s = wts + else if(num_missing == 3) then !--- three missing value + if(.not. is_missing(1) ) then + data_out(m,n) = data_in(is,js) + else if(.not. is_missing(2) ) then + data_out(m,n) = data_in(ie,js) + else if(.not. is_missing(3) ) then + data_out(m,n) = data_in(ie,je) + else if(.not. is_missing(4) ) then + data_out(m,n) = data_in(is,je) + endif + if(present(mask_out) ) mask_out(m,n) = 1.0_kindl + cycle + else !--- one or two missing value + if( num_missing == 1) then + if( is_missing(1) .OR. is_missing(3) ) then + middle = 0.5_kindl *(data_in(ie,js)+data_in(is,je)) + else + middle = 0.5_kindl *(data_in(is,js)+data_in(ie,je)) + endif + else ! num_missing = 2 + if( is_missing(1) .AND. is_missing(2) ) then + middle = 0.5_kindl *(data_in(ie,je)+data_in(is,je)) + else if( is_missing(1) .AND. is_missing(3) ) then + middle = 0.5_kindl *(data_in(ie,js)+data_in(is,je)) + else if( is_missing(1) .AND. is_missing(4) ) then + middle = 0.5_kindl *(data_in(ie,js)+data_in(ie,je)) + else if( is_missing(2) .AND. is_missing(3) ) then + middle = 0.5_kindl *(data_in(is,js)+data_in(is,je)) + else if( is_missing(2) .AND. is_missing(4) ) then + middle = 0.5_kindl*(data_in(is,js)+data_in(ie,je)) + else if( is_missing(3) .AND. is_missing(4) ) then + middle = 0.5_kindl*(data_in(is,js)+data_in(ie,js)) + endif + endif + + if( wtw .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl ) then ! zone 1 + w = 2.0_kindl*(wtw-0.5_kindl) + s = 2.0_kindl*(wts-0.5_kindl) + f1 = data_in(is,js) + if(is_missing(2)) then + f2 = f1 + else + f2 = 0.5_kindl*(data_in(is,js)+data_in(ie,js)) + endif + f3 = middle + if(is_missing(4)) then + f4 = f1 + else + f4 = 0.5_kindl*(data_in(is,js)+data_in(is,je)) + endif + else if( wte .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl ) then ! zone 2 + w = 2.0_kindl*(1.0_kindl-wte) + s = 2.0_kindl*(wts-0.5_kindl) + f2 = data_in(ie,js) + if(is_missing(1)) then + f1 = f2 + else + f1 = 0.5_kindl*(data_in(is,js)+data_in(ie,js)) + endif + f4 = middle + if(is_missing(3)) then + f3 = f2 + else + f3 = 0.5_kindl*(data_in(ie,js)+data_in(ie,je)) + endif + else if( wte .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl ) then ! zone 3 + w = 2.0_kindl*(1.0_kindl-wte) + s = 2.0_kindl*(1.0_kindl-wtn) + f3 = data_in(ie,je) + if(is_missing(2)) then + f2 = f3 + else + f2 = 0.5_kindl*(data_in(ie,js)+data_in(ie,je)) + endif + f1 = middle + if(is_missing(4)) then + f4 = f3 + else + f4 = 0.5_kindl*(data_in(ie,je)+data_in(is,je)) + endif + else if( wtw .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl ) then ! zone 4 + w = 2.0_kindl*(wtw-0.5_kindl) + s = 2.0_kindl*(1.0_kindl-wtn) + f4 = data_in(is,je) + if(is_missing(1)) then + f1 = f4 + else + f1 = 0.5_kindl*(data_in(is,js)+data_in(is,je)) + endif + f2 = middle + if(is_missing(3)) then + f3 = f4 + else + f3 = 0.5_kindl*(data_in(ie,je)+data_in(is,je)) + endif + else + call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: the point should be in one of the four zone") + endif + endif + + data_out(m,n) = f3 + (f4-f3)*w + (f2-f3)*s + ((f1-f2)+(f3-f4))*w*s + if(present(mask_out)) mask_out(m,n) = 1.0_kindl + enddo + enddo + else + do n = 1, nlat_out + do m = 1, nlon_out + is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) + js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) + wtw = Interp % HI_KIND_TYPE_ % wti (m,n,1) + wte = Interp % HI_KIND_TYPE_ % wti (m,n,2) + wts = Interp % HI_KIND_TYPE_ % wtj (m,n,1) + wtn = Interp % HI_KIND_TYPE_ % wtj (m,n,2) + + if(present(missing_value) ) then + num_missing = 0 + if(data_in(is,js) == missing_value) then + num_missing = num_missing+1 + mask(is,js) = 0.0_kindl + endif + if(data_in(ie,js) == missing_value) then + num_missing = num_missing+1 + mask(ie,js) = 0.0_kindl + endif + if(data_in(ie,je) == missing_value) then + num_missing = num_missing+1 + mask(ie,je) = 0.0_kindl + endif + if(data_in(is,je) == missing_value) then + num_missing = num_missing+1 + mask(is,je) = 0.0_kindl + endif + endif + + dwtsum = data_in(is,js)*mask(is,js)*wtw*wts & + + data_in(ie,js)*mask(ie,js)*wte*wts & + + data_in(ie,je)*mask(ie,je)*wte*wtn & + + data_in(is,je)*mask(is,je)*wtw*wtn + wtsum = mask(is,js)*wtw*wts + mask(ie,js)*wte*wts & + + mask(ie,je)*wte*wtn + mask(is,je)*wtw*wtn + + if(.not. present(mask_in) .and. .not. present(missing_value)) wtsum = 1.0_kindl + + if(num_missing .gt. max_missing ) then + data_out(m,n) = missing_value + if(present(mask_out)) mask_out(m,n) = 0.0_kindl + else if(wtsum .lt. real(epsln, FMS_HI_KIND_)) then + if(present(missing_value)) then + data_out(m,n) = missing_value + else + data_out(m,n) = 0.0_kindl + endif + if(present(mask_out)) mask_out(m,n) = 0.0_kindl + else + data_out(m,n) = dwtsum/wtsum + if(present(mask_out)) mask_out(m,n) = wtsum + endif + enddo + enddo + endif + !*********************************************************************** + ! compute statistics: minimum, maximum, and mean + !----------------------------------------------------------------------- + if (iverbose > 0) then + + ! compute statistics of input data + + call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask_in) + + ! compute statistics of output data + call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask_out) + + !---- output statistics ---- + unit = stdout() + write (unit,900) + write (unit,901) min_in ,max_in, avg_in + if (present(mask_in)) write (unit,903) miss_in + write (unit,902) min_out,max_out,avg_out + if (present(mask_out)) write (unit,903) miss_out + +900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) +901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) +902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) +903 format (' number of missing points = ',i6) + + endif + + return + + end subroutine + + + !####################################################################### + !> @returns index of nearest data point to "value" + !! if "value" is outside the domain of "array" then INDP_ = 1 + !! or "ia" depending on whether array(1) or array(ia) is + !! closest to "value" + function INDP_ (value, array) + integer :: INDP_ !< index of nearest data point within "array" + !! corresponding to "value". + real(FMS_HI_KIND_), dimension(:), intent(in) :: array !< array of data points (must be monotonically increasing) + real(FMS_HI_KIND_), intent(in) :: value !< arbitrary data, same units as elements in 'array' + + !======================================================================= + + integer i, ia, unit + logical keep_going + ! + ia = size(array(:)) + do i=2,ia + if (array(i) .lt. array(i-1)) then + unit = stdout() + write (unit,*) & + ' => Error: array must be monotonically increasing in "INDP_"' , & + ' when searching for nearest element to value=',value + write (unit,*) ' array(i) < array(i-1) for i=',i + write (unit,*) ' array(i) for i=1..ia follows:' + call mpp_error() + endif + enddo + if (value .lt. array(1) .or. value .gt. array(ia)) then + if (value .lt. array(1)) INDP_ = 1 + if (value .gt. array(ia)) INDP_ = ia + else + i=1 + keep_going = .true. + do while (i .le. ia .and. keep_going) + i = i+1 + if (value .le. array(i)) then + INDP_ = i + if (array(i)-value .gt. value-array(i-1)) INDP_ = i-1 + keep_going = .false. + endif + enddo + endif + return + end function INDP_ +!> @} diff --git a/horiz_interp/include/horiz_interp_bilinear_r4.fh b/horiz_interp/include/horiz_interp_bilinear_r4.fh new file mode 100644 index 0000000000..bcb96fcdec --- /dev/null +++ b/horiz_interp/include/horiz_interp_bilinear_r4.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bilinear +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_BILINEAR_NEW_1D_ +#define HORIZ_INTERP_BILINEAR_NEW_1D_ horiz_interp_bilinear_new_1d_r4 + +#undef HORIZ_INTERP_BILINEAR_NEW_2D_ +#define HORIZ_INTERP_BILINEAR_NEW_2D_ horiz_interp_bilinear_new_2d_r4 + +#undef HORIZ_INTERP_BILINEAR_ +#define HORIZ_INTERP_BILINEAR_ horiz_interp_bilinear_r4 + +#undef FIND_NEIGHBOR_ +#define FIND_NEIGHBOR_ find_neighbor_r4 + +#undef FIND_NEIGHBOR_NEW_ +#define FIND_NEIGHBOR_NEW_ find_neighbor_new_r4 + +#undef INSIDE_POLYGON_ +#define INSIDE_POLYGON_ inside_polygon_r4 + +#undef INTERSECT_ +#define INTERSECT_ intersect_r4 + +#undef INDP_ +#define INDP_ indp_r4 + +#include "horiz_interp_bilinear.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_bilinear_r8.fh b/horiz_interp/include/horiz_interp_bilinear_r8.fh new file mode 100644 index 0000000000..af68b4c454 --- /dev/null +++ b/horiz_interp/include/horiz_interp_bilinear_r8.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bilinear +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_BILINEAR_NEW_1D_ +#define HORIZ_INTERP_BILINEAR_NEW_1D_ horiz_interp_bilinear_new_1d_r8 + +#undef HORIZ_INTERP_BILINEAR_NEW_2D_ +#define HORIZ_INTERP_BILINEAR_NEW_2D_ horiz_interp_bilinear_new_2d_r8 + +#undef HORIZ_INTERP_BILINEAR_ +#define HORIZ_INTERP_BILINEAR_ horiz_interp_bilinear_r8 + +#undef FIND_NEIGHBOR_ +#define FIND_NEIGHBOR_ find_neighbor_r8 + +#undef FIND_NEIGHBOR_NEW_ +#define FIND_NEIGHBOR_NEW_ find_neighbor_new_r8 + +#undef INSIDE_POLYGON_ +#define INSIDE_POLYGON_ inside_polygon_r8 + +#undef INTERSECT_ +#define INTERSECT_ intersect_r8 + +#undef INDP_ +#define INDP_ indp_r8 + +#include "horiz_interp_bilinear.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_conserve.inc b/horiz_interp/include/horiz_interp_conserve.inc new file mode 100644 index 0000000000..3fe5168e4b --- /dev/null +++ b/horiz_interp/include/horiz_interp_conserve.inc @@ -0,0 +1,926 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_conserve_mod +!> @{ +subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(size(lat_out(:))-1,2) :: sph + real(FMS_HI_KIND_), dimension(size(lon_out(:))-1,2) :: theta + real(FMS_HI_KIND_), dimension(size(lat_in(:))) :: slat_in + real(FMS_HI_KIND_), dimension(size(lon_in(:))-1) :: dlon_in + real(FMS_HI_KIND_), dimension(size(lat_in(:))-1) :: dsph_in + real(FMS_HI_KIND_), dimension(size(lon_out(:))-1) :: dlon_out + real(FMS_HI_KIND_), dimension(size(lat_out(:))-1) :: dsph_out + real(FMS_HI_KIND_) :: blon, fac, hpi, tpi, eps + integer, parameter :: num_iters = 4 + integer :: i, j, m, n, nlon_in, nlat_in, nlon_out, nlat_out, & + iverbose, m2, n2, iter + logical :: s2n + character(len=64) :: mesg + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX1D_: horiz_interp_conserve_init is not called') + + if(great_circle_algorithm) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX1D_: great_circle_algorithm is not implemented, contact developer') + !----------------------------------------------------------------------- + iverbose = 0; if (present(verbose)) iverbose = verbose + + pe = mpp_pe() + root_pe = mpp_root_pe() + !----------------------------------------------------------------------- + hpi = 0.5_kindl * real(pi, FMS_HI_KIND_) + tpi = 4.0_kindl * real(hpi, FMS_HI_KIND_) + Interp%version = 1 + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 + + allocate ( Interp % HI_KIND_TYPE_ % facj (nlat_out,2), Interp % jlat (nlat_out,2), & + Interp % HI_KIND_TYPE_ % faci (nlon_out,2), Interp % ilon (nlon_out,2), & + Interp % HI_KIND_TYPE_ % area_src (nlon_in, nlat_in), & + Interp % HI_KIND_TYPE_ % area_dst (nlon_out, nlat_out) ) + + !----------------------------------------------------------------------- + ! --- set-up for input grid boxes --- + + do j = 1, nlat_in+1 + slat_in(j) = sin(lat_in(j)) + enddo + + do j = 1, nlat_in + dsph_in(j) = abs(slat_in(j+1)-slat_in(j)) + enddo + + do i = 1,nlon_in + dlon_in(i) = abs(lon_in(i+1)-lon_in(i)) + enddo + + ! set south to north flag + s2n = .true. + if (lat_in(1) > lat_in(nlat_in+1)) s2n = .false. + + !----------------------------------------------------------------------- + ! --- set-up for output grid boxes --- + + do n = 1, nlat_out + dsph_out(n) = abs(sin(lat_out(n+1))-sin(lat_out(n))) + enddo + + do m = 1,nlon_out + theta(m,1) = lon_out(m) + theta(m,2) = lon_out(m+1) + dlon_out(m) = abs(lon_out(m+1)-lon_out(m)) + enddo + + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + !*********************************************************************** + + !------ set up latitudinal indexing ------ + !------ make sure output grid goes south to north ------ + + do n = 1, nlat_out + if (lat_out(n) < lat_out(n+1)) then + sph(n,1) = sin(lat_out(n)) + sph(n,2) = sin(lat_out(n+1)) + else + sph(n,1) = sin(lat_out(n+1)) + sph(n,2) = sin(lat_out(n)) + endif + enddo + + Interp%jlat = 0 + do n2 = 1, 2 ! looping on grid box edges + do n = 1, nlat_out ! looping on output latitudes + eps = 0.0_kindl + do iter=1,num_iters + ! find indices from input latitudes + do j = 1, nlat_in + if ( (s2n .and. (slat_in(j)-sph(n,n2)) <= eps .and. & + (sph(n,n2)-slat_in(j+1)) <= eps) .or. & + (.not.s2n .and. (slat_in(j+1)-sph(n,n2)) <= eps .and. & + (sph(n,n2)-slat_in(j)) <= eps) ) then + Interp%jlat(n,n2) = j + ! weight with sin(lat) to exactly conserve area-integral + fac = (sph(n,n2)-slat_in(j))/(slat_in(j+1)-slat_in(j)) + if (s2n) then + if (n2 == 1) Interp%HI_KIND_TYPE_%facj(n,n2) = 1.0_kindl - fac + if (n2 == 2) Interp%HI_KIND_TYPE_%facj(n,n2) = fac + else + if (n2 == 1) Interp%HI_KIND_TYPE_%facj(n,n2) = fac + if (n2 == 2) Interp%HI_KIND_TYPE_%facj(n,n2) = 1.0_kindl - fac + endif + exit + endif + enddo + if ( Interp%jlat(n,n2) /= 0 ) exit + ! did not find this output grid edge in the input grid + ! increase tolerance for multiple passes + eps = epsilon(sph)*real(10.0_kindl**iter, kindl) + enddo + ! no match + if ( Interp%jlat(n,n2) == 0 ) then + write (mesg,710) n,sph(n,n2) +710 format (': n,sph=',i3,f14.7,40x) + call mpp_error(FATAL, 'horiz_interp_conserve_mod:no latitude index found'//trim(mesg)) + endif + enddo + enddo + + !------ set up longitudinal indexing ------ + + Interp%ilon = 0 + do m2 = 1, 2 ! looping on grid box edges + do m = 1, nlon_out ! looping on output longitudes + blon = theta(m,m2) + if ( blon < lon_in(1) ) blon = blon + tpi + if ( blon > lon_in(nlon_in+1) ) blon = blon - tpi + eps = 0.0_kindl + do iter=1,num_iters + ! find indices from input longitudes + do i = 1, nlon_in + if ( (lon_in(i)-blon) <= eps .and. & + (blon-lon_in(i+1)) <= eps ) then + Interp%ilon(m,m2) = i + fac = (blon-lon_in(i))/(lon_in(i+1)-lon_in(i)) + if (m2 == 1) Interp%HI_KIND_TYPE_%faci(m,m2) = 1.0_kindl - fac + if (m2 == 2) Interp%HI_KIND_TYPE_%faci(m,m2) = fac + exit + endif + enddo + if ( Interp%ilon(m,m2) /= 0 ) exit + ! did not find this output grid edge in the input grid + ! increase tolerance for multiple passes + eps = epsilon(blon)*real(10.0_kindl**iter, kindl) + enddo + ! no match + if ( Interp%ilon(m,m2) == 0 ) then + print *, 'lon_out,blon,blon_in,eps=', & + theta(m,m2),blon,lon_in(1),lon_in(nlon_in+1),eps + call mpp_error(FATAL, 'horiz_interp_conserve_mod: no longitude index found') + endif + enddo + enddo + + ! --- area of input grid boxes --- + + do j = 1,nlat_in + do i = 1,nlon_in + Interp%HI_KIND_TYPE_%area_src(i,j) = dlon_in(i) * dsph_in(j) + enddo + enddo + + ! --- area of output grid boxes --- + + do n = 1, nlat_out + do m = 1, nlon_out + Interp%HI_KIND_TYPE_%area_dst(m,n) = dlon_out(m) * dsph_out(n) + enddo + enddo + + !----------------------------------------------------------------------- + ! this output may be quite lengthy and is not recommended + ! when using more than one processor + if (iverbose > 2) then + write (*,801) (i,Interp%ilon(i,1),Interp%ilon(i,2), & + Interp%HI_KIND_TYPE_%faci(i,1),Interp%HI_KIND_TYPE_%faci(i,2),i=1,nlon_out) + write (*,802) (j,Interp%jlat(j,1),Interp%jlat(j,2), & + Interp%HI_KIND_TYPE_%facj(j,1),Interp%HI_KIND_TYPE_%facj(j,2),j=1,nlat_out) +801 format (/,2x,'i',4x,'is',5x,'ie',4x,'facis',4x,'facie', & + /,(i4,2i7,2f10.5)) +802 format (/,2x,'j',4x,'js',5x,'je',4x,'facjs',4x,'facje', & + /,(i4,2i7,2f10.5)) + endif + !----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ + + !####################################################################### + + subroutine HORIZ_INTERP_CONSERVE_NEW_1DX2D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + mask_in, mask_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(in), optional, dimension(:,:) :: mask_in + real(FMS_HI_KIND_), intent(inout), optional, dimension(:,:) :: mask_out + integer, intent(in), optional :: verbose + + + integer :: create_xgrid_1DX2D_order1, get_maxxgrid, maxxgrid + integer :: create_xgrid_great_circle + integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j + real(r8_kind), dimension(size(lon_in(:))-1, size(lat_in(:))-1) :: mask_src + integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst + real(r8_kind), allocatable, dimension(:) :: xgrid_area, clon, clat + real(r8_kind), allocatable, dimension(:,:) :: dst_area, lon_src, lat_src + real(r8_kind), allocatable, dimension(:) :: lat_in_flip + real(r8_kind), allocatable, dimension(:,:) :: mask_src_flip + real(r8_kind), allocatable, dimension(:) :: lon_in_r8, lat_in_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 + + integer :: nincrease, ndecrease + logical :: flip_lat + integer :: wordsz + integer(kind=1) :: one_byte(8) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX2D_: horiz_interp_conserve_init is not called') + + wordsz=size(transfer(lon_in(1), one_byte)) + if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX2D_: wordsz should be 4 or 8') + + if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') + nlon_in = size(lon_in(:)) - 1; nlat_in = size(lat_in(:)) - 1 + nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 + + mask_src = 1.0_r8_kind + if(present(mask_in)) then + if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') + mask_src = real(mask_in, r8_kind) + end if + + maxxgrid = get_maxxgrid() + allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) + allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) + + !--- check if source latitude is flipped + nincrease = 0 + ndecrease = 0 + do j = 1, nlat_in + if( lat_in(j+1) > lat_in(j) ) then + nincrease = nincrease + 1 + else if ( lat_in(j+1) < lat_in(j) ) then + ndecrease = ndecrease + 1 + endif + enddo + + if(nincrease == nlat_in) then + flip_lat = .false. + else if(ndecrease == nlat_in) then + flip_lat = .true. + else + call mpp_error(FATAL, 'horiz_interp_conserve_mod: nlat_in should be equal to nincreaase or ndecrease') + endif + + allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) + allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) + lon_out_r8 = real(lon_out, r8_kind) + lat_out_r8 = real(lat_out, r8_kind) + + if( .not. great_circle_algorithm ) then + if(flip_lat) then + allocate(lat_in_flip(nlat_in+1), mask_src_flip(nlon_in,nlat_in)) + do j = 1, nlat_in+1 + lat_in_flip(j) = real(lat_in(nlat_in+2-j), r8_kind) + enddo + do j = 1, nlat_in + mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) + enddo + allocate(lon_in_r8(size(lon_in))) + lon_in_r8 = real(lon_in, r8_kind) + nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_flip, & + lon_out_r8, lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area) + deallocate(lon_in_r8, lat_in_flip, mask_src_flip) + else + allocate(lon_in_r8(size(lon_in))) + allocate(lat_in_r8(size(lat_in))) + lon_in_r8 = real(lon_in, r8_kind) + lat_in_r8 = real(lat_in, r8_kind) + nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) + deallocate(lon_in_r8,lat_in_r8) + endif + else + allocate(lon_src(nlon_in+1,nlat_in+1), lat_src(nlon_in+1,nlat_in+1)) + allocate(clon(maxxgrid), clat(maxxgrid)) + if(flip_lat) then + allocate(mask_src_flip(nlon_in,nlat_in)) + do j = 1, nlat_in+1 + do i = 1, nlon_in+1 + lon_src(i,j) = real(lon_in(i), r8_kind) + lat_src(i,j) = real(lat_in(nlat_in+2-j), r8_kind) + enddo + enddo + do j = 1, nlat_in + mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) + enddo + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & + & lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + deallocate(mask_src_flip) + else + do j = 1, nlat_in+1 + do i = 1, nlon_in+1 + lon_src(i,j) = real(lon_in(i), r8_kind) + lat_src(i,j) = real(lat_in(j), r8_kind) + enddo + enddo + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + endif + deallocate(lon_src, lat_src, clon, clat) + endif + + deallocate(lon_out_r8, lat_out_r8) + + allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) + allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) + allocate(Interp%HI_KIND_TYPE_%area_frac_dst(nxgrid) ) + Interp%version = 2 + Interp%nxgrid = nxgrid + Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 + Interp%j_src = j_src(1:nxgrid)+1 + if(flip_lat) Interp%j_src = nlat_in+1-Interp%j_src + Interp%i_dst = i_dst(1:nxgrid)+1 + Interp%j_dst = j_dst(1:nxgrid)+1 + + ! sum over exchange grid area to get destination grid area + dst_area = 0.0_r8_kind + do i = 1, nxgrid + dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) + end do + + do i = 1, nxgrid + Interp%HI_KIND_TYPE_%area_frac_dst(i) = real(xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ), & + FMS_HI_KIND_) + end do + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + if(present(mask_out)) then + if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') + mask_out = 0.0_kindl + do i = 1, nxgrid + mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & + & Interp%j_dst(i)) + Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + end if + + deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) + + end subroutine HORIZ_INTERP_CONSERVE_NEW_1DX2D_ + + !####################################################################### + + subroutine HORIZ_INTERP_CONSERVE_NEW_2DX1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + mask_in, mask_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(in), optional, dimension(:,:) :: mask_in + real(FMS_HI_KIND_), intent(inout), optional, dimension(:,:) :: mask_out + integer, intent(in), optional :: verbose + + integer :: create_xgrid_2DX1D_order1, get_maxxgrid, maxxgrid + integer :: create_xgrid_great_circle + integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j + integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst + real(r8_kind), allocatable, dimension(:,:) :: dst_area + real(r8_kind), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src + real(r8_kind), allocatable, dimension(:) :: xgrid_area, clon, clat + real(r8_kind), allocatable, dimension(:) :: lon_out_r8, lat_out_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_dst, lat_dst + integer :: wordsz + integer(kind=1) :: one_byte(8) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX1D_: horiz_interp_conserve_init is not called') + + wordsz=size(transfer(lon_in(1,1), one_byte)) + if(wordsz .NE. 8) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX1D_: currently only support 64-bit real(FMS_HI_KIND_), contact developer') + + if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') + nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 + nlon_out = size(lon_out(:)) - 1; nlat_out = size(lat_out(:)) - 1 + + mask_src = 1.0_r8_kind + if(present(mask_in)) then + if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') + mask_src = real(mask_in, r8_kind) + end if + + maxxgrid = get_maxxgrid() + allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) + allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) + + allocate(lon_in_r8(size(lon_in,1), size(lon_in, 2))) + allocate(lat_in_r8(size(lat_in,1), size(lat_in, 2))) + allocate(lon_out_r8(size(lon_out))) + allocate(lat_out_r8(size(lat_out))) + lon_out_r8 = real(lon_out, r8_kind) + lat_out_r8 = real(lat_out, r8_kind) + lon_in_r8 = real(lon_in, r8_kind) + lat_in_r8 = real(lat_in, r8_kind) + + if( .not. great_circle_algorithm ) then + nxgrid = create_xgrid_2DX1D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, & + lon_out_r8, lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) + else + allocate(lon_dst(nlon_out+1, nlat_out+1), lat_dst(nlon_out+1, nlat_out+1) ) + allocate(clon(maxxgrid), clat(maxxgrid)) + do j = 1, nlat_out+1 + do i = 1, nlon_out+1 + lon_dst(i,j) = real(lon_out(i), r8_kind) + lat_dst(i,j) = real(lat_out(j), r8_kind) + enddo + enddo + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_dst, & + & lat_dst, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + endif + deallocate(lon_out_r8,lat_out_r8, lon_in_r8, lat_in_r8) + allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) + allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) + allocate(Interp%HI_KIND_TYPE_%area_frac_dst(nxgrid) ) + Interp%version = 2 + Interp%nxgrid = nxgrid + Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 + Interp%j_src = j_src(1:nxgrid)+1 + Interp%i_dst = i_dst(1:nxgrid)+1 + Interp%j_dst = j_dst(1:nxgrid)+1 + + ! sum over exchange grid area to get destination grid area + dst_area = 0.0_r8_kind + do i = 1, nxgrid + dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) + end do + + do i = 1, nxgrid + Interp%HI_KIND_TYPE_%area_frac_dst(i) = real(xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ), & + FMS_HI_KIND_) + end do + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + if(present(mask_out)) then + if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') + mask_out = 0.0_kindl + do i = 1, nxgrid + mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & + & Interp%j_dst(i)) + Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + end if + + deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area) + + end subroutine HORIZ_INTERP_CONSERVE_NEW_2DX1D_ + + !####################################################################### + + subroutine HORIZ_INTERP_CONSERVE_NEW_2DX2D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + mask_in, mask_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(in), optional, dimension(:,:) :: mask_in + real(FMS_HI_KIND_), intent(inout), optional, dimension(:,:) :: mask_out + integer, intent(in), optional :: verbose + + integer :: create_xgrid_2DX2D_order1, get_maxxgrid, maxxgrid + integer :: create_xgrid_great_circle + integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i + integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst + real(r8_kind), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src + real(r8_kind), allocatable, dimension(:) :: xgrid_area, clon, clat + real(r8_kind), allocatable, dimension(:,:) :: dst_area + real(r8_kind), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 + integer :: wordsz + integer(kind=1) :: one_byte(8) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX2D_: horiz_interp_conserve_init is not called') + + wordsz=size(transfer(lon_in(1,1), one_byte)) + if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX2D_: wordsz should be 4 or 8') + + if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') + if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') + nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 + nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 + + mask_src = 1.0_r8_kind + if(present(mask_in)) then + if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') + mask_src = real(mask_in, r8_kind) + end if + + maxxgrid = get_maxxgrid() + allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) + allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) + + allocate(lon_in_r8(size(lon_in,1),size(lon_in,2))) + allocate(lat_in_r8(size(lat_in,1),size(lat_in,2))) + allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) + allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) + lon_in_r8 = real(lon_in,r8_kind) + lat_in_r8 = real(lat_in, r8_kind) + lon_out_r8 = real(lon_out, r8_kind) + lat_out_r8 = real(lat_out, r8_kind) + + if( .not. great_circle_algorithm ) then + nxgrid = create_xgrid_2DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) + else + allocate(clon(maxxgrid), clat(maxxgrid)) + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + deallocate(clon, clat) + endif + + deallocate(lon_in_r8, lat_in_r8, lon_out_r8, lat_out_r8) + + allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) + allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) + allocate(Interp%HI_KIND_TYPE_%area_frac_dst(nxgrid) ) + Interp%version = 2 + Interp%nxgrid = nxgrid + Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 + Interp%j_src = j_src(1:nxgrid)+1 + Interp%i_dst = i_dst(1:nxgrid)+1 + Interp%j_dst = j_dst(1:nxgrid)+1 + + ! sum over exchange grid area to get destination grid area + dst_area = 0.0_r8_kind + do i = 1, nxgrid + dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) + end do + + do i = 1, nxgrid + Interp%HI_KIND_TYPE_%area_frac_dst(i) = real(xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i)), & + FMS_HI_KIND_) + end do + + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + if(present(mask_out)) then + if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') + mask_out = 0.0_kindl + do i = 1, nxgrid + mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & + & Interp%j_dst(i)) + Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + end if + + deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) + + end subroutine HORIZ_INTERP_CONSERVE_NEW_2DX2D_ + + !######################################################################## + + !> @brief Subroutine for performing the horizontal interpolation between two grids. + !! + !> Subroutine for performing the horizontal interpolation between two grids. + !! horiz_interp_conserve_new must be called before calling this routine. + subroutine HORIZ_INTERP_CONSERVE_( Interp, data_in, data_out, verbose, & + mask_in, mask_out) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< Input data on source grid + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< Output data on destination grid + integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; + !! 2 = max output + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as + !! the input data. The real value of mask_in must be in the range (0.,1.). + !! Set mask_in=0.0 for data points that should not be used or have missing + !! data. mask_in will be applied only when horiz_interp_conserve_new_1d is + !! called. mask_in will be passed into horiz_interp_conserve_new_2d + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether + !! data was computed. mask_out will be computed only when + !! horiz_interp_conserve_new_1d is called. mask_out will be computed in + !! horiz_interp_conserve_new_2d + + ! --- error checking --- + if (size(data_in,1) /= Interp%nlon_src .or. size(data_in,2) /= Interp%nlat_src) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of input array incorrect') + + if (size(data_out,1) /= Interp%nlon_dst .or. size(data_out,2) /= Interp%nlat_dst) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of output array incorrect') + + select case ( Interp%version) + case (1) + call horiz_interp_conserve_version1(Interp, data_in, data_out, verbose, mask_in, mask_out) + case (2) + if(present(mask_in) .OR. present(mask_out) ) call mpp_error(FATAL, 'HORIZ_INTERP_CONSERVE_:'// & + & ' for version 2, mask_in and mask_out must be passed in horiz_interp_new, not in horiz_interp') + call horiz_interp_conserve_version2(Interp, data_in, data_out, verbose) + end select + + end subroutine HORIZ_INTERP_CONSERVE_ + + !############################################################################## + subroutine HORIZ_INTERP_CONSERVE_VERSION1_ ( Interp, data_in, data_out, verbose, & + mask_in, mask_out) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + !----------local variables---------------------------------------------------- + integer :: m, n, nlon_in, nlat_in, nlon_out, nlat_out, & + miss_in, miss_out, is, ie, js, je, & + np, npass, iverbose + real(FMS_HI_KIND_) :: dsum, wsum, avg_in, min_in, max_in, & + avg_out, min_out, max_out, eps, asum, & + dwtsum, wtsum, arsum, fis, fie, fjs, fje + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + !----------------------------------------------------------------------- + iverbose = 0; if (present(verbose)) iverbose = verbose + + eps = epsilon(wtsum) + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + if (present(mask_in)) then + if ( COUNT(mask_in < -.0001_kindl .or. mask_in > 1.0001_kindl) > 0 ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: input mask not between 0,1') + endif + + !----------------------------------------------------------------------- + !---- loop through output grid boxes ---- + + data_out = 0.0_kindl + do n = 1, nlat_out + ! latitude window + ! setup ascending latitude indices and weights + if (Interp%jlat(n,1) <= Interp%jlat(n,2)) then + js = Interp%jlat(n,1); je = Interp%jlat(n,2) + fjs = Interp%HI_KIND_TYPE_%facj(n,1); fje = Interp%HI_KIND_TYPE_%facj(n,2) + else + js = Interp%jlat(n,2); je = Interp%jlat(n,1) + fjs = Interp%HI_KIND_TYPE_%facj(n,2); fje = Interp%HI_KIND_TYPE_%facj(n,1) + endif + + do m = 1, nlon_out + ! longitude window + is = Interp%ilon(m,1); ie = Interp%ilon(m,2) + fis = Interp%HI_KIND_TYPE_%faci(m,1); fie = Interp%HI_KIND_TYPE_%faci(m,2) + npass = 1 + dwtsum = 0.0_kindl + wtsum = 0.0_kindl + arsum = 0.0_kindl + + ! wrap-around on input grid + ! sum using 2 passes (pass 1: end of input grid) + if ( ie < is ) then + ie = nlon_in + fie = 1.0_kindl + npass = 2 + endif + + do np = 1, npass + ! pass 2: beginning of input grid + if ( np == 2 ) then + is = 1 + fis = 1.0_kindl + ie = Interp%ilon(m,2) + fie = Interp%HI_KIND_TYPE_%faci(m,2) + endif + + ! summing data*weight and weight for single grid point + if (present(mask_in)) then + call data_sum( data_in(is:ie,js:je), Interp%HI_KIND_TYPE_%area_src(is:ie,js:je), & + fis, fie, fjs,fje, dwtsum, wtsum, arsum, mask_in(is:ie,js:je) ) + else if( allocated(Interp%HI_KIND_TYPE_%mask_in) ) then + call data_sum( data_in(is:ie,js:je), Interp%HI_KIND_TYPE_%area_src(is:ie,js:je), & + fis, fie, fjs,fje, dwtsum, wtsum, arsum, Interp%HI_KIND_TYPE_%mask_in(is:ie,js:je) ) + else + call data_sum( data_in(is:ie,js:je), Interp%HI_KIND_TYPE_%area_src(is:ie,js:je), & + fis, fie, fjs,fje, dwtsum, wtsum, arsum ) + endif + enddo + + if (wtsum > eps) then + data_out(m,n) = dwtsum/wtsum + if (present(mask_out)) mask_out(m,n) = wtsum/arsum + else + data_out(m,n) = 0.0_kindl + if (present(mask_out)) mask_out(m,n) = 0.0_kindl + endif + + enddo + enddo + + !*********************************************************************** + ! compute statistics: minimum, maximum, and mean + !----------------------------------------------------------------------- + + if (iverbose > 0) then + + ! compute statistics of input data + + call stats(data_in, Interp%HI_KIND_TYPE_%area_src, asum, dsum, wsum, min_in, max_in, miss_in, mask_in) + ! diagnostic messages + ! on the root_pe, we can calculate the global mean, minimum and maximum. + if(pe == root_pe) then + if (wsum > 0.0_kindl) then + avg_in=dsum/wsum + else + print *, 'horiz_interp stats: input area equals zero ' + avg_in=0.0_kindl + endif + if (iverbose > 1) print '(2f16.11)', 'global sum area_in = ', asum, wsum + endif + + ! compute statistics of output data + call stats(data_out, Interp%HI_KIND_TYPE_%area_dst, asum, dsum, wsum, min_out, max_out, miss_out, mask_out) + ! diagnostic messages + if(pe == root_pe) then + if (wsum > 0.0_kindl ) then + avg_out=dsum/wsum + else + print *, 'horiz_interp stats: output area equals zero ' + avg_out=0.0_kindl + endif + if (iverbose > 1) print '(2f16.11)', 'global sum area_out = ', asum, wsum + endif + !---- output statistics ---- + ! the global mean, min and max are calculated on the root pe. + if(pe == root_pe) then + write (*,900) + write (*,901) min_in ,max_in ,avg_in + if (present(mask_in)) write (*,903) miss_in + write (*,902) min_out,max_out,avg_out + if (present(mask_out)) write (*,903) miss_out + endif + +900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) +901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) +902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) +903 format (' number of missing points = ',i6) + + endif + + !----------------------------------------------------------------------- + end subroutine HORIZ_INTERP_CONSERVE_VERSION1_ + + !############################################################################# + subroutine HORIZ_INTERP_CONSERVE_VERSION2_ ( Interp, data_in, data_out, verbose ) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + integer :: i, i_src, j_src, i_dst, j_dst + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + data_out = 0.0_kindl + do i = 1, Interp%nxgrid + i_src = Interp%i_src(i); j_src = Interp%j_src(i) + i_dst = Interp%i_dst(i); j_dst = Interp%j_dst(i) + data_out(i_dst, j_dst) = data_out(i_dst, j_dst) + data_in(i_src,j_src)*Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + + end subroutine HORIZ_INTERP_CONSERVE_VERSION2_ + + + !####################################################################### + !> This statistics is for conservative scheme + subroutine STATS_ ( dat, area, asum, dsum, wsum, low, high, miss, mask ) + real(FMS_HI_KIND_), intent(in) :: dat(:,:), area(:,:) + real(FMS_HI_KIND_), intent(out) :: asum, dsum, wsum, low, high + integer, intent(out) :: miss + real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + integer :: pe, root_pe, npes, p, buffer_int(1) + real(FMS_HI_KIND_) :: buffer_real(5) + + pe = mpp_pe() + root_pe = mpp_root_pe() + npes = mpp_npes() + + ! sum data, data*area; and find min,max on each pe. + + if (present(mask)) then + asum = sum(area(:,:)) + dsum = sum(area(:,:)*dat(:,:)*mask(:,:)) + wsum = sum(area(:,:)*mask(:,:)) + miss = count(mask(:,:) <= 0.5_kindl) + low = minval(dat(:,:),mask=mask(:,:) > 0.5_kindl ) + high = maxval(dat(:,:),mask=mask(:,:) > 0.5_kindl ) + else + asum = sum(area(:,:)) + dsum = sum(area(:,:)*dat(:,:)) + wsum = sum(area(:,:)) + miss = 0 + low = minval(dat(:,:)) + high = maxval(dat(:,:)) + endif + + ! other pe send local min, max, avg to the root pe and + ! root pe receive these information + + if(pe == root_pe) then + do p = 1, npes - 1 + ! Force use of "scalar", integer pointer mpp interface + call mpp_recv(buffer_real(1),glen=5,from_pe=root_pe+p, tag=COMM_TAG_1) + asum = asum + buffer_real(1) + dsum = dsum + buffer_real(2) + wsum = wsum + buffer_real(3) + low = min(low, buffer_real(4)) + high = max(high, buffer_real(5)) + call mpp_recv(buffer_int(1),glen=1,from_pe=root_pe+p, tag=COMM_TAG_2) + miss = miss + buffer_int(1) + enddo + else + buffer_real(1) = asum + buffer_real(2) = dsum + buffer_real(3) = wsum + buffer_real(4) = low + buffer_real(5) = high + ! Force use of "scalar", integer pointer mpp interface + call mpp_send(buffer_real(1),plen=5,to_pe=root_pe, tag=COMM_TAG_1) + buffer_int(1) = miss + call mpp_send(buffer_int(1),plen=1,to_pe=root_pe, tag=COMM_TAG_2) + endif + + call mpp_sync_self() + + end subroutine STATS_ + + !####################################################################### + + !> sums up the data and weights for a single output grid box + subroutine DATA_SUM_( data, area, facis, facie, facjs, facje, & + dwtsum, wtsum, arsum, mask ) + + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data, area + real(FMS_HI_KIND_), intent(in) :: facis, facie, facjs, facje + real(FMS_HI_KIND_), intent(inout) :: dwtsum, wtsum, arsum + real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) + + ! fac__ = fractional portion of each boundary grid box included + ! in the integral + ! dwtsum = sum(data*area*mask) + ! wtsum = sum(area*mask) + ! arsum = sum(area) + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(size(area,1),size(area,2)) :: wt + real(FMS_HI_KIND_) :: asum + integer :: id, jd + !----------------------------------------------------------------------- + + id=size(area,1); jd=size(area,2) + + wt=area + wt( 1,:)=wt( 1,:)*facis + wt(id,:)=wt(id,:)*facie + wt(:, 1)=wt(:, 1)*facjs + wt(:,jd)=wt(:,jd)*facje + + asum = sum(wt) + arsum = arsum + asum + + if (present(mask)) then + wt = wt * mask + dwtsum = dwtsum + sum(wt*data) + wtsum = wtsum + sum(wt) + else + dwtsum = dwtsum + sum(wt*data) + wtsum = wtsum + asum + endif + !----------------------------------------------------------------------- + + end subroutine DATA_SUM_ +!> @} diff --git a/horiz_interp/include/horiz_interp_conserve_r4.fh b/horiz_interp/include/horiz_interp_conserve_r4.fh new file mode 100644 index 0000000000..0cf1c9cce2 --- /dev/null +++ b/horiz_interp/include/horiz_interp_conserve_r4.fh @@ -0,0 +1,55 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_conserve +!> @{ +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX1D_ horiz_interp_conserve_new_1dx1d_r4 + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX2D_ horiz_interp_conserve_new_1dx2d_r4 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX1D_ horiz_interp_conserve_new_2dx1d_r4 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX2D_ horiz_interp_conserve_new_2dx2d_r4 + +#undef HORIZ_INTERP_CONSERVE_ +#define HORIZ_INTERP_CONSERVE_ horiz_interp_conserve_r4 + +#undef HORIZ_INTERP_CONSERVE_VERSION1_ +#define HORIZ_INTERP_CONSERVE_VERSION1_ horiz_interp_conserve_version1_r4 + +#undef HORIZ_INTERP_CONSERVE_VERSION2_ +#define HORIZ_INTERP_CONSERVE_VERSION2_ horiz_interp_conserve_version2_r4 + +#undef STATS_ +#define STATS_ stats_r4 + +#undef DATA_SUM_ +#define DATA_SUM_ data_sum_r4 + +#include "horiz_interp_conserve.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_conserve_r8.fh b/horiz_interp/include/horiz_interp_conserve_r8.fh new file mode 100644 index 0000000000..0b3b0d2ff4 --- /dev/null +++ b/horiz_interp/include/horiz_interp_conserve_r8.fh @@ -0,0 +1,55 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_conserve +!> @{ +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX1D_ horiz_interp_conserve_new_1dx1d_r8 + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX2D_ horiz_interp_conserve_new_1dx2d_r8 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX1D_ horiz_interp_conserve_new_2dx1d_r8 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX2D_ horiz_interp_conserve_new_2dx2d_r8 + +#undef HORIZ_INTERP_CONSERVE_ +#define HORIZ_INTERP_CONSERVE_ horiz_interp_conserve_r8 + +#undef HORIZ_INTERP_CONSERVE_VERSION1_ +#define HORIZ_INTERP_CONSERVE_VERSION1_ horiz_interp_conserve_version1_r8 + +#undef HORIZ_INTERP_CONSERVE_VERSION2_ +#define HORIZ_INTERP_CONSERVE_VERSION2_ horiz_interp_conserve_version2_r8 + +#undef STATS_ +#define STATS_ stats_r8 + +#undef DATA_SUM_ +#define DATA_SUM_ data_sum_r8 + +#include "horiz_interp_conserve.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_r4.fh b/horiz_interp/include/horiz_interp_r4.fh new file mode 100644 index 0000000000..40cd267bcb --- /dev/null +++ b/horiz_interp/include/horiz_interp_r4.fh @@ -0,0 +1,64 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_NEW_1D_ +#define HORIZ_INTERP_NEW_1D_ horiz_interp_new_1d_r4 + +#undef HORIZ_INTERP_NEW_1D_SRC_ +#define HORIZ_INTERP_NEW_1D_SRC_ horiz_interp_new_1d_src_r4 + +#undef HORIZ_INTERP_NEW_1D_DST_ +#define HORIZ_INTERP_NEW_1D_DST_ horiz_interp_new_1d_dst_r4 + +#undef HORIZ_INTERP_BASE_2D_ +#define HORIZ_INTERP_BASE_2D_ horiz_interp_base_2d_r4 + +#undef HORIZ_INTERP_BASE_3D_ +#define HORIZ_INTERP_BASE_3D_ horiz_interp_base_3d_r4 + +#undef HORIZ_INTERP_SOLO_1D_ +#define HORIZ_INTERP_SOLO_1D_ horiz_interp_solo_1d_r4 + +#undef HORIZ_INTERP_SOLO_1D_SRC_ +#define HORIZ_INTERP_SOLO_1D_SRC_ horiz_interp_solo_1d_src_r4 + +#undef HORIZ_INTERP_SOLO_1D_DST_ +#define HORIZ_INTERP_SOLO_1D_DST_ horiz_interp_solo_1d_dst_r4 + +#undef HORIZ_INTERP_SOLO_2D_ +#define HORIZ_INTERP_SOLO_2D_ horiz_interp_solo_2d_r4 + +#undef HORIZ_INTERP_SOLO_OLD_ +#define HORIZ_INTERP_SOLO_OLD_ horiz_interp_solo_old_r4 + +#undef HORIZ_INTERP_NEW_2D_ +#define HORIZ_INTERP_NEW_2D_ horiz_interp_new_2d_r4 + +#undef IS_LAT_LON_ +#define IS_LAT_LON_ is_lat_lon_r4 + +#include "horiz_interp.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_r8.fh b/horiz_interp/include/horiz_interp_r8.fh new file mode 100644 index 0000000000..a70bd1e3ef --- /dev/null +++ b/horiz_interp/include/horiz_interp_r8.fh @@ -0,0 +1,64 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_NEW_1D_ +#define HORIZ_INTERP_NEW_1D_ horiz_interp_new_1d_r8 + +#undef HORIZ_INTERP_NEW_1D_SRC_ +#define HORIZ_INTERP_NEW_1D_SRC_ horiz_interp_new_1d_src_r8 + +#undef HORIZ_INTERP_NEW_1D_DST_ +#define HORIZ_INTERP_NEW_1D_DST_ horiz_interp_new_1d_dst_r8 + +#undef HORIZ_INTERP_BASE_2D_ +#define HORIZ_INTERP_BASE_2D_ horiz_interp_base_2d_r8 + +#undef HORIZ_INTERP_BASE_3D_ +#define HORIZ_INTERP_BASE_3D_ horiz_interp_base_3d_r8 + +#undef HORIZ_INTERP_SOLO_1D_ +#define HORIZ_INTERP_SOLO_1D_ horiz_interp_solo_1d_r8 + +#undef HORIZ_INTERP_SOLO_1D_SRC_ +#define HORIZ_INTERP_SOLO_1D_SRC_ horiz_interp_solo_1d_src_r8 + +#undef HORIZ_INTERP_SOLO_1D_DST_ +#define HORIZ_INTERP_SOLO_1D_DST_ horiz_interp_solo_1d_dst_r8 + +#undef HORIZ_INTERP_SOLO_2D_ +#define HORIZ_INTERP_SOLO_2D_ horiz_interp_solo_2d_r8 + +#undef HORIZ_INTERP_SOLO_OLD_ +#define HORIZ_INTERP_SOLO_OLD_ horiz_interp_solo_old_r8 + +#undef HORIZ_INTERP_NEW_2D_ +#define HORIZ_INTERP_NEW_2D_ horiz_interp_new_2d_r8 + +#undef IS_LAT_LON_ +#define IS_LAT_LON_ is_lat_lon_r8 + +#include "horiz_interp.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_spherical.inc b/horiz_interp/include/horiz_interp_spherical.inc new file mode 100644 index 0000000000..cc00a4264e --- /dev/null +++ b/horiz_interp/include/horiz_interp_spherical.inc @@ -0,0 +1,821 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_spherical_mod +!> @{ + !> Initialization routine. + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_SPHERICAL_NEW_(Interp, lon_in,lat_in,lon_out,lat_out, & + num_nbrs, max_dist, src_modulo) + + type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices + !! and weights for subsequent interpolations. To + !! reinitialize for different grid-to-grid interpolation + !! @ref horiz_interp_del must be used first. + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid + logical, intent(in), optional :: src_modulo !< indicates if the boundary condition + !! along zonal boundary is cyclic or not. Cyclic when true + integer, intent(in), optional :: num_nbrs !< Number of nearest neighbors for regridding + !! When number of neighbors within the radius max_dist + !! is less than num_nbrs, All the neighbors will be used + !! to interpolate onto destination grid. when number of + !! neighbors within the radius max_dist is greater than + !! num_nbrs, at least "num_nbrs" + ! neighbors will be used to remap onto destination grid + real(FMS_HI_KIND_), optional, intent(in) :: max_dist !< Maximum region of influence around + !! destination grid points + + !------local variables --------------------------------------- + integer :: i, j, n + integer :: map_dst_xsize, map_dst_ysize, map_src_xsize, map_src_ysize + integer :: map_src_size, num_neighbors + real(FMS_HI_KIND_) :: max_src_dist, tpi, hpi + logical :: src_is_modulo + real(FMS_HI_KIND_) :: min_theta_dst, max_theta_dst, min_phi_dst, max_phi_dst + real(FMS_HI_KIND_) :: min_theta_src, max_theta_src, min_phi_src, max_phi_src + integer :: map_src_add(size(lon_out,1),size(lon_out,2),max_neighbors) + real(FMS_HI_KIND_) :: map_src_dist(size(lon_out,1),size(lon_out,2),max_neighbors) + integer :: num_found(size(lon_out,1),size(lon_out,2)) + integer :: ilon(max_neighbors), jlat(max_neighbors) + real(FMS_HI_KIND_), dimension(size(lon_out,1),size(lon_out,2)) :: theta_dst, phi_dst + real(FMS_HI_KIND_), dimension(size(lon_in,1)*size(lon_in,2)) :: theta_src, phi_src + integer, parameter :: kindl = FMS_HI_KIND_ + + !-------------------------------------------------------------- + + pe = mpp_pe() + root_pe = mpp_root_pe() + + tpi = 2.0_kindl*real(PI, FMS_HI_KIND_); hpi = 0.5_kindl*real(PI,FMS_HI_KIND_) + + num_neighbors = num_nbrs_default + if(present(num_nbrs)) num_neighbors = num_nbrs + if (num_neighbors <= 0) call mpp_error(FATAL,'horiz_interp_spherical_mod: num_neighbors must be > 0') + + max_src_dist = real(max_dist_default, FMS_HI_KIND_) + if (PRESENT(max_dist)) max_src_dist = max_dist + Interp%HI_KIND_TYPE_%max_src_dist = max_src_dist + + src_is_modulo = .true. + if (PRESENT(src_modulo)) src_is_modulo = src_modulo + + !--- check the grid size comformable + map_dst_xsize=size(lon_out,1);map_dst_ysize=size(lon_out,2) + map_src_xsize=size(lon_in,1); map_src_ysize=size(lon_in,2) + map_src_size = map_src_xsize*map_src_ysize + + if (map_dst_xsize /= size(lat_out,1) .or. map_dst_ysize /= size(lat_out,2)) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: destination grids not conformable') + if (map_src_xsize /= size(lat_in,1) .or. map_src_ysize /= size(lat_in,2)) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: source grids not conformable') + + theta_src = reshape(lon_in,(/map_src_size/)) + phi_src = reshape(lat_in,(/map_src_size/)) + theta_dst(:,:) = lon_out(:,:) + phi_dst(:,:) = lat_out(:,:) + + min_theta_dst=real(tpi, FMS_HI_KIND_);max_theta_dst=0.0_kindl + min_phi_dst=real(pi, FMS_HI_KIND_);max_phi_dst=real(-pi, FMS_HI_KIND_) + min_theta_src=real(tpi, FMS_HI_KIND_);max_theta_src=0.0_kindl + min_phi_src=real(pi, FMS_HI_KIND_);max_phi_src=real(-pi, FMS_HI_KIND_) + + where(theta_dst<0.0_kindl) theta_dst = theta_dst+real(tpi,FMS_HI_KIND_) + + where(theta_dst>real(tpi,FMS_HI_KIND_)) theta_dst = theta_dst-real(tpi,FMS_HI_KIND_) + where(theta_src<0.0_kindl) theta_src = theta_src+real(tpi,FMS_HI_KIND_) + where(theta_src>real(tpi,FMS_HI_KIND_)) theta_src = theta_src-real(tpi,FMS_HI_KIND_) + + where(phi_dst < -hpi) phi_dst = -hpi + where(phi_dst > hpi) phi_dst = hpi + where(phi_src < -hpi) phi_src = -hpi + where(phi_src > hpi) phi_src = hpi + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + min_theta_dst = min(min_theta_dst,theta_dst(i,j)) + max_theta_dst = max(max_theta_dst,theta_dst(i,j)) + min_phi_dst = min(min_phi_dst,phi_dst(i,j)) + max_phi_dst = max(max_phi_dst,phi_dst(i,j)) + enddo + enddo + + do i=1,map_src_size + min_theta_src = min(min_theta_src,theta_src(i)) + max_theta_src = max(max_theta_src,theta_src(i)) + min_phi_src = min(min_phi_src,phi_src(i)) + max_phi_src = max(max_phi_src,phi_src(i)) + enddo + + if (min_phi_dst < min_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' + if (max_phi_dst > max_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' + ! when src is cyclic, no need to print out the following warning. + if(.not. src_is_modulo) then + if (min_theta_dst < min_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' + if (max_theta_dst > max_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' + endif + + ! allocate memory to data type + if(ALLOCATED(Interp%i_lon)) then + if(size(Interp%i_lon,1) .NE. map_dst_xsize .OR. & + size(Interp%i_lon,2) .NE. map_dst_ysize ) call mpp_error(FATAL, & + 'horiz_interp_spherical_mod: size(Interp%i_lon(:),1) .NE. map_dst_xsize .OR. '// & + 'size(Interp%i_lon(:),2) .NE. map_dst_ysize') + else + allocate(Interp%i_lon(map_dst_xsize,map_dst_ysize,max_neighbors), & + Interp%j_lat(map_dst_xsize,map_dst_ysize,max_neighbors), & + Interp%HI_KIND_TYPE_%src_dist(map_dst_xsize,map_dst_ysize,max_neighbors), & + Interp%num_found(map_dst_xsize,map_dst_ysize) ) + endif + + map_src_add = 0 + map_src_dist = real(large, FMS_HI_KIND_) + num_found = 0 + + !using radial_search to find the nearest points and corresponding distance. + + select case(trim(search_method)) + case ("radial_search") ! will be efficient, but may be not so accurate for some cases + call radial_search(theta_src, phi_src, theta_dst, phi_dst, map_src_xsize, map_src_ysize, & + map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) + case ("full_search") ! always accurate, but less efficient. + call full_search(theta_src, phi_src, theta_dst, phi_dst, map_src_add, map_src_dist, & + num_found, num_neighbors,max_src_dist ) + case default + call mpp_error(FATAL,"HORIZ_INTERP_SPHERICAL_NEW_: nml search_method = "// & + trim(search_method)//" is not a valid namelist option") + end select + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + do n=1,num_found(i,j) + if(map_src_add(i,j,n) == 0) then + jlat(n) = 0; ilon(n) = 0 + else + jlat(n) = map_src_add(i,j,n)/map_src_xsize + 1 + ilon(n) = map_src_add(i,j,n) - (jlat(n)-1)*map_src_xsize + if(ilon(n) == 0) then + jlat(n) = jlat(n) - 1 + ilon(n) = map_src_xsize + endif + endif + enddo + Interp%i_lon(i,j,:) = ilon(:) + Interp%j_lat(i,j,:) = jlat(:) + Interp%num_found(i,j) = num_found(i,j) + Interp%HI_KIND_TYPE_%src_dist(i,j,:) = map_src_dist(i,j,:) + enddo + enddo + + Interp%nlon_src = map_src_xsize; Interp%nlat_src = map_src_ysize + Interp%nlon_dst = map_dst_xsize; Interp%nlat_dst = map_dst_ysize + + return + + end subroutine HORIZ_INTERP_SPHERICAL_NEW_ + + !####################################################################### + + !> Subroutine for performing the horizontal interpolation between two grids. + !! HORIZ_INTERP_SPHERICAL_NEW_ must be called before calling this routine. + subroutine HORIZ_INTERP_SPHERICAL_( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value) + type(horiz_interp_type), intent(in) :: Interp !< A derived type variable containing indices + !! and weights for subsequent interpolations. Returned + !! by a previous call to HORIZ_INTERP_SPHERICAL_NEW_ + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< Input data on source grid + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< Output data on destination grid + integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = most output + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as + !! the input data. The real(FMS_HI_KIND_) value of mask_in must be + !! in the range (0.,1.). Set mask_in=0.0 for data points + !! that should not be used or have missing data + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether data + !! was computed. + real(FMS_HI_KIND_), intent(in), optional :: missing_value !< Used to indicate missing data + + !--- some local variables ---------------------------------------- + real(FMS_HI_KIND_), dimension(Interp%nlon_dst, Interp%nlat_dst,size(Interp%HI_KIND_TYPE_%src_dist,3)) :: wt + real(FMS_HI_KIND_), dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src + real(FMS_HI_KIND_), dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst + integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found + integer :: m, n, i, j, k, miss_in, miss_out, i1, i2, j1, j2, iverbose + real(FMS_HI_KIND_) :: min_in, max_in, avg_in, min_out, max_out, avg_out, sum + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled real kind size + !----------------------------------------------------------------- + + iverbose = 0; if (present(verbose)) iverbose = verbose + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + if(size(data_in,1) .ne. nlon_in .or. size(data_in,2) .ne. nlat_in ) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: size of input array incorrect') + + if(size(data_out,1) .ne. nlon_out .or. size(data_out,2) .ne. nlat_out ) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: size of output array incorrect') + + mask_src = 1.0_kindl; mask_dst = 1.0_kindl + if(present(mask_in)) mask_src = mask_in + + do n=1,nlat_out + do m=1,nlon_out + ! neighbors are sorted nearest to farthest + ! check nearest to see if it is a land point + num_found = Interp%num_found(m,n) + if(num_found == 0 ) then + mask_dst(m,n) = 0.0_kindl + else + i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) + if (mask_src(i1,j1) .lt. 0.5_kindl ) then + mask_dst(m,n) = 0.0_kindl + endif + + if(num_found .gt. 1 ) then + i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) + ! compare first 2 nearest neighbors -- if they are nearly + ! equidistant then use this mask for robustness + if(abs(Interp%HI_KIND_TYPE_%src_dist(m,n,2)-Interp%HI_KIND_TYPE_%src_dist(m,n,1)) .lt. & + real(epsln,FMS_HI_KIND_)) then + if((mask_src(i1,j1) .lt. 0.5_kindl )) mask_dst(m,n) = 0.0_kindl + endif + endif + + sum=0.0_kindl + do k=1, num_found + if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5_kindl ) then + wt(m,n,k) = 0.0_kindl + else + if (Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= real(epsln,FMS_HI_KIND_)) then + wt(m,n,k) = real(large, FMS_HI_KIND_) + sum = sum + real(large, FMS_HI_KIND_) + else if(Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= Interp%HI_KIND_TYPE_%max_src_dist ) then + wt(m,n,k) = 1.0_kindl /Interp%HI_KIND_TYPE_%src_dist(m,n,k) + sum = sum+wt(m,n,k) + else + wt(m,n,k) = 0.0_kindl + endif + endif + enddo + if (sum > real(epsln,FMS_HI_KIND_)) then + do k = 1, num_found + wt(m,n,k) = wt(m,n,k)/sum + enddo + else + mask_dst(m,n) = 0.0_kindl + endif + endif + enddo + enddo + + data_out = 0.0_kindl + do n=1,nlat_out + do m=1,nlon_out + if(mask_dst(m,n) .gt. 0.5_kindl ) then + do k=1, Interp%num_found(m,n) + i = Interp%i_lon(m,n,k) + j = Interp%j_lat(m,n,k) + data_out(m,n) = data_out(m,n)+data_in(i,j)*wt(m,n,k) + enddo + else + if(present(missing_value)) then + data_out(m,n) = missing_value + else + data_out(m,n) = 0.0_kindl + endif + endif + enddo + enddo + + if(present(mask_out)) mask_out = mask_dst + + !*********************************************************************** + ! compute statistics: minimum, maximum, and mean + !----------------------------------------------------------------------- + + if (iverbose > 0) then + + ! compute statistics of input data + + call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask=mask_src) + + ! compute statistics of output data + call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask=mask_dst) + + !---- output statistics ---- + ! root_pe have the information of global mean, min and max + if(pe == root_pe) then + write (*,900) + write (*,901) min_in ,max_in, avg_in + if (present(mask_in)) write (*,903) miss_in + write (*,902) min_out,max_out,avg_out + if (present(mask_out)) write (*,903) miss_out + endif +900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) +901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) +902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) +903 format (' number of missing points = ',i6) + + endif + + return + end subroutine HORIZ_INTERP_SPHERICAL_ + + !####################################################################### + !> This routine isn't used internally + !! it's similar to the routine above, just gets the weights as an out variable + subroutine HORIZ_INTERP_SPHERICAL_WGHT_( Interp, wt, verbose, mask_in, mask_out, missing_value) + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: wt + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(inout), dimension(:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + + !--- some local variables ---------------------------------------- + real(FMS_HI_KIND_), dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src + real(FMS_HI_KIND_), dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst + integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found + integer :: m, n, k, i1, i2, j1, j2, iverbose + real(FMS_HI_KIND_) :: sum + integer, parameter :: kindl = FMS_HI_KIND_ + !----------------------------------------------------------------- + + iverbose = 0; if (present(verbose)) iverbose = verbose + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + mask_src = 1.0_kindl ; mask_dst = 1.0_kindl + if(present(mask_in)) mask_src = mask_in + + do n=1,nlat_out + do m=1,nlon_out + ! neighbors are sorted nearest to farthest + ! check nearest to see if it is a land point + num_found = Interp%num_found(m,n) + + if (num_found > num_nbrs_default) then + if( iverbose .gt. 0) print *,'pe=',mpp_pe(),'num_found=',num_found + num_found = num_nbrs_default + end if + + if(num_found == 0 ) then + mask_dst(m,n) = 0.0_kindl + else + i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) + if (mask_src(i1,j1) .lt. 0.5_kindl) then + mask_dst(m,n) = 0.0_kindl + endif + + if(num_found .gt. 1 ) then + i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) + ! compare first 2 nearest neighbors -- if they are nearly + ! equidistant then use this mask for robustness + if(abs(Interp%HI_KIND_TYPE_%src_dist(m,n,2)-Interp%HI_KIND_TYPE_%src_dist(m,n,1)) .lt. & + real(epsln,FMS_HI_KIND_)) then + if((mask_src(i1,j1) .lt. 0.5_kindl )) mask_dst(m,n) = 0.0_kindl + endif + endif + + sum=0.0_kindl + do k=1, num_found + if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5_kindl ) then + wt(m,n,k) = 0.0_kindl + else + if (Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= real(epsln, FMS_HI_KIND_)) then + wt(m,n,k) = real(large, FMS_HI_KIND_) + sum = sum + real(large, FMS_HI_KIND_) + else if(Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= Interp%HI_KIND_TYPE_%max_src_dist ) then + wt(m,n,k) = 1.0_kindl /Interp%HI_KIND_TYPE_%src_dist(m,n,k) + sum = sum+wt(m,n,k) + else + wt(m,n,k) = 0.0_kindl + endif + endif + enddo + if (sum > real(epsln,FMS_HI_KIND_)) then + do k = 1, num_found + wt(m,n,k) = wt(m,n,k)/sum + enddo + else + mask_dst(m,n) = 0.0_kindl + endif + endif + enddo + enddo + + return + end subroutine HORIZ_INTERP_SPHERICAL_WGHT_ + + !####################################################################### + + subroutine RADIAL_SEARCH_(theta_src,phi_src,theta_dst,phi_dst, map_src_xsize, map_src_ysize, & + map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) + real(FMS_HI_KIND_), intent(in), dimension(:) :: theta_src, phi_src + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: theta_dst, phi_dst + integer, intent(in) :: map_src_xsize, map_src_ysize + integer, intent(out), dimension(:,:,:) :: map_src_add + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: map_src_dist + integer, intent(inout), dimension(:,:) :: num_found + integer, intent(in) :: num_neighbors + real(FMS_HI_KIND_), intent(in) :: max_src_dist + logical, intent(in) :: src_is_modulo + + !---------- local variables ---------------------------------------- + integer, parameter :: max_nbrs = 50 + integer :: i, j, jj, i0, j0, n, l,i_left, i_right + integer :: map_dst_xsize, map_dst_ysize + integer :: i_left1, i_left2, i_right1, i_right2 + integer :: map_src_size, step, step_size, bound, bound_start, bound_end + logical :: continue_search, result, continue_radial_search + real(FMS_HI_KIND_) :: d, res + !------------------------------------------------------------------ + map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) + map_src_size = map_src_xsize*map_src_ysize + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + continue_search=.true. + step = 1 + step_size = int( sqrt(real(map_src_size, kind=FMS_HI_KIND_ ))) + do while (continue_search .and. step_size > 0) + do while (step <= map_src_size .and. continue_search) + ! count land points as nearest neighbors + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) + if (d <= max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + step,d, num_found(i,j), num_neighbors ) + if (result) then + n = 0 + i0 = mod(step,map_src_xsize) + + if (i0 == 0) i0 = map_src_xsize + res = real(step, FMS_HI_KIND_)/real(map_src_xsize, FMS_HI_KIND_) + j0 = ceiling(res) + continue_radial_search = .true. + do while (continue_radial_search) + continue_radial_search = .false. + n = n+1 ! radial counter + if(n > max_nbrs) exit + ! ************** left boundary ******************************* + i_left = i0-n + if (i_left <= 0) then + if (src_is_modulo) then + i_left = map_src_xsize + i_left + else + i_left = 1 + endif + endif + + do l = 0, 2*n + jj = j0 - n - 1 + l + if( jj < 0) then + bound = ( 1 - jj )*map_src_xsize - i_left + else if ( jj >= map_src_ysize ) then + bound = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left + else + bound = jj * map_src_xsize + i_left + endif + + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + enddo + + ! ***************************right boundary ******************************* + i_right = i0+n + if (i_right > map_src_xsize) then + if (src_is_modulo) then + i_right = i_right - map_src_xsize + else + i_right = map_src_xsize + endif + endif + + do l = 0, 2*n + jj = j0 - n - 1 + l + if( jj < 0) then + bound = ( 1 - jj )*map_src_xsize - i_right + else if ( jj >= map_src_ysize ) then + bound = ( 2*map_src_ysize - jj) * map_src_xsize - i_right + + else + bound = jj * map_src_xsize + i_right + endif + + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + enddo + + ! ************************* bottom boundary ********************************** + i_left2 = 0 + if( i_left > i_right) then + i_left1 = 1 + i_right1 = i_right + i_left2 = i_left + i_right2 = map_src_xsize + else + i_left1 = i_left + i_right1 = i_right + endif + + jj = j0 - n - 1 + if( jj < 0 ) then + bound_start = ( 1 - jj)*map_src_xsize - i_right1 + bound_end = ( 1 - jj)*map_src_xsize - i_left1 + else + bound_start = jj * map_src_xsize + i_left1 + bound_end = jj * map_src_xsize + i_right1 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + + enddo + + if(i_left2 > 0 ) then + if( jj < 0 ) then + bound_start = ( 1 - jj)*map_src_xsize - i_right2 + bound_end = ( 1 - jj)*map_src_xsize - i_left2 + else + bound_start = jj * map_src_xsize + i_left2 + bound_end = jj * map_src_xsize + i_right2 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + enddo + endif + + ! ************************** top boundary ************************************ + jj = j0 + n - 1 + if( jj >= map_src_ysize) then + bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right1 + bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left1 + else + bound_start = jj * map_src_xsize + i_left1 + bound_end = jj * map_src_xsize + i_right1 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + enddo + + if(i_left2 > 0) then + if( jj >= map_src_ysize) then + bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right2 + bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left2 + else + bound_start = jj * map_src_xsize + i_left2 + bound_end = jj * map_src_xsize + i_right2 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + enddo + endif + + enddo + continue_search = .false. ! stop looking + endif + endif + step=step+step_size + enddo ! search loop + step = 1 + step_size = step_size/2 + enddo + enddo + enddo + + return + + end subroutine RADIAL_SEARCH_ + + + !##################################################################### + + function UPDATE_DEST_NEIGHBORS_(map_src_add, map_src_dist, src_add,d, num_found, min_nbrs) + + integer, intent(inout), dimension(:) :: map_src_add + real(FMS_HI_KIND_), intent(inout), dimension(:) :: map_src_dist + integer, intent(in) :: src_add + real(FMS_HI_KIND_), intent(in) :: d + integer, intent(inout) :: num_found + integer, intent(in) :: min_nbrs + + logical :: UPDATE_DEST_NEIGHBORS_, already_exist = .false. + + integer :: n,m + + UPDATE_DEST_NEIGHBORS_ = .false. + + n = 0 + NLOOP : do while ( n .le. num_found ) + n = n + 1 + DIST_CHK : if (d .le. map_src_dist(n)) then + do m=n,num_found + if (src_add == map_src_add(m)) then + already_exist = .true. + exit NLOOP + endif + enddo + if(num_found < max_neighbors) then + num_found = num_found + 1 + else + call mpp_error(FATAL,'UPDATE_DEST_NEIGHBORS_: '// & + 'number of neighbor points found is greated than maxium neighbor points' ) + endif + do m=num_found,n+1,-1 + map_src_add(m) = map_src_add(m-1) + map_src_dist(m) = map_src_dist(m-1) + enddo + map_src_add(n) = src_add + map_src_dist(n) = d + UPDATE_DEST_NEIGHBORS_ = .true. + if( num_found > min_nbrs ) then + if( map_src_dist(num_found) > map_src_dist(num_found-1) ) then + num_found = num_found - 1 + endif + if( map_src_dist(min_nbrs+1) > map_src_dist(min_nbrs) ) then + num_found = min_nbrs + endif + endif + exit NLOOP ! n loop + endif DIST_CHK + end do NLOOP + if(already_exist) return + + if( .not. UPDATE_DEST_NEIGHBORS_ ) then + if( num_found < min_nbrs ) then + num_found = num_found + 1 + UPDATE_DEST_NEIGHBORS_ = .true. + map_src_add(num_found) = src_add + map_src_dist(num_found) = d + endif + endif + + + return + + end function UPDATE_DEST_NEIGHBORS_ + + !######################################################################## +! function HORIZ_INTERP_SPHERICAL_DISTANCE_(theta1,phi1,theta2,phi2) + +! real(FMS_HI_KIND_), intent(in) :: theta1, phi1, theta2, phi2 +! real(FMS_HI_KIND_) :: HORIZ_INTERP_SPHERICAL_DISTANCE_ + +! real(FMS_HI_KIND_) :: r1(3), r2(3), cross(3), s, dot, ang + + ! this is a simple, enough way to calculate distance on the sphere + ! first, construct cartesian vectors r1 and r2 + ! then calculate the cross-product which is proportional to the area + ! between the 2 vectors. The angular distance is arcsin of the + ! distancealong the sphere + ! + ! theta is longitude and phi is latitude + ! + + +! r1(1) = cos(theta1)*cos(phi1);r1(2)=sin(theta1)*cos(phi1);r1(3)=sin(phi1) +! r2(1) = cos(theta2)*cos(phi2);r2(2)=sin(theta2)*cos(phi2);r2(3)=sin(phi2) + +! cross(1) = r1(2)*r2(3)-r1(3)*r2(2) +! cross(2) = r1(3)*r2(1)-r1(1)*r2(3) +! cross(3) = r1(1)*r2(2)-r1(2)*r2(1) + +! s = sqrt(cross(1)**2.+cross(2)**2.+cross(3)**2.) + +! s = min(s,real(1.0, FMS_HI_KIND_)-epsln) + +! dot = r1(1)*r2(1) + r1(2)*r2(2) + r1(3)*r2(3) + +! if (dot > 0) then +! ang = asin(s) +! else if (dot < 0) then +! ang = pi + asin(s) !? original is pi - asin(s) +! else +! ang = pi/real(2., FMS_HI_KIND_) +! endif + +! HORIZ_INTERP_SPHERICAL_DISTANCE_ = abs(ang) ! in radians + +! return + +! end function HORIZ_INTERP_SPHERICAL_DISTANCE_ + ! The great cycle distance + function HORIZ_INTERP_SPHERICAL_DISTANCE_(theta1,phi1,theta2,phi2) + + real(FMS_HI_KIND_), intent(in) :: theta1, phi1, theta2, phi2 + real(FMS_HI_KIND_) :: HORIZ_INTERP_SPHERICAL_DISTANCE_, dot + integer, parameter :: kindl = FMS_HI_KIND_ + + if(theta1 == theta2 .and. phi1 == phi2) then + HORIZ_INTERP_SPHERICAL_DISTANCE_ = 0.0_kindl + return + endif + + dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2) + if(dot > 1.0_kindl) dot = 1.0_kindl + if(dot < real(-1.0_kindl, FMS_HI_KIND_)) dot = -1.0_kindl + HORIZ_INTERP_SPHERICAL_DISTANCE_ = acos(dot) + + return + + end function HORIZ_INTERP_SPHERICAL_DISTANCE_ + + + !####################################################################### + + subroutine FULL_SEARCH_(theta_src,phi_src,theta_dst,phi_dst,map_src_add, map_src_dist,num_found, & + num_neighbors,max_src_dist) + real(FMS_HI_KIND_), intent(in), dimension(:) :: theta_src, phi_src + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: theta_dst, phi_dst + integer, intent(out), dimension(:,:,:) :: map_src_add + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: map_src_dist + integer, intent(out), dimension(:,:) :: num_found + integer, intent(in) :: num_neighbors + real(FMS_HI_KIND_), intent(in) :: max_src_dist + + integer :: i,j,map_src_size, step + integer :: map_dst_xsize,map_dst_ysize + real(FMS_HI_KIND_) :: d + logical :: found + + map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) + map_src_size =size(theta_src(:)) + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + do step = 1, map_src_size + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) + if( d <= max_src_dist) then + found = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + step,d,num_found(i,j), num_neighbors ) + endif + enddo + enddo + enddo + + end subroutine FULL_SEARCH_ +!> @} diff --git a/horiz_interp/include/horiz_interp_spherical_r4.fh b/horiz_interp/include/horiz_interp_spherical_r4.fh new file mode 100644 index 0000000000..a4a0f3fd6b --- /dev/null +++ b/horiz_interp/include/horiz_interp_spherical_r4.fh @@ -0,0 +1,49 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_spherical +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_SPHERICAL_ +#define HORIZ_INTERP_SPHERICAL_ horiz_interp_spherical_r4 + +#undef HORIZ_INTERP_SPHERICAL_NEW_ +#define HORIZ_INTERP_SPHERICAL_NEW_ horiz_interp_spherical_new_r4 + +#undef HORIZ_INTERP_SPHERICAL_WGHT_ +#define HORIZ_INTERP_SPHERICAL_WGHT_ horiz_interp_spherical_wght_r4 + +#undef RADIAL_SEARCH_ +#define RADIAL_SEARCH_ radial_search_r4 + +#undef UPDATE_DEST_NEIGHBORS_ +#define UPDATE_DEST_NEIGHBORS_ update_dest_neighbors_r4 + +#undef HORIZ_INTERP_SPHERICAL_DISTANCE_ +#define HORIZ_INTERP_SPHERICAL_DISTANCE_ spherical_distance_r4 + +#undef FULL_SEARCH_ +#define FULL_SEARCH_ full_search_r4 + +#include "horiz_interp_spherical.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_spherical_r8.fh b/horiz_interp/include/horiz_interp_spherical_r8.fh new file mode 100644 index 0000000000..500e826ded --- /dev/null +++ b/horiz_interp/include/horiz_interp_spherical_r8.fh @@ -0,0 +1,49 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_spherical +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_SPHERICAL_ +#define HORIZ_INTERP_SPHERICAL_ horiz_interp_spherical_r8 + +#undef HORIZ_INTERP_SPHERICAL_NEW_ +#define HORIZ_INTERP_SPHERICAL_NEW_ horiz_interp_spherical_new_r8 + +#undef HORIZ_INTERP_SPHERICAL_WGHT_ +#define HORIZ_INTERP_SPHERICAL_WGHT_ horiz_interp_spherical_wght_r8 + +#undef RADIAL_SEARCH_ +#define RADIAL_SEARCH_ radial_search_r8 + +#undef UPDATE_DEST_NEIGHBORS_ +#define UPDATE_DEST_NEIGHBORS_ update_dest_neighbors_r8 + +#undef HORIZ_INTERP_SPHERICAL_DISTANCE_ +#define HORIZ_INTERP_SPHERICAL_DISTANCE_ spherical_distance_r8 + +#undef FULL_SEARCH_ +#define FULL_SEARCH_ full_search_r8 + +#include "horiz_interp_spherical.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_type.inc b/horiz_interp/include/horiz_interp_type.inc new file mode 100644 index 0000000000..4715143dac --- /dev/null +++ b/horiz_interp/include/horiz_interp_type.inc @@ -0,0 +1,90 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_type_mod +!> @{ +!> @brief This statistics is for bilinear interpolation and spherical regrid. + subroutine STATS_ ( dat, low, high, avg, miss, missing_value, mask ) + real(FMS_HI_KIND_), intent(in) :: dat(:,:) + real(FMS_HI_KIND_), intent(out) :: low, high, avg + integer, intent(out) :: miss + real(FMS_HI_KIND_), intent(in), optional :: missing_value + real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) + + real(FMS_HI_KIND_) :: dsum, buffer_real(3) + integer :: pe, root_pe, npes, p, buffer_int(2), npts + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + pe = mpp_pe() + root_pe = mpp_root_pe() + npes = mpp_npes() + + dsum = 0.0_kindl + miss = 0 + + if (present(missing_value)) then + miss = count(dat(:,:) == missing_value) + low = minval(dat(:,:), dat(:,:) /= missing_value) + high = maxval(dat(:,:), dat(:,:) /= missing_value) + dsum = sum(dat(:,:), dat(:,:) /= missing_value) + else if(present(mask)) then + miss = count(mask(:,:) <= 0.5_kindl ) + low = minval(dat(:,:),mask=mask(:,:) > 0.5_kindl) + high = maxval(dat(:,:),mask=mask(:,:) > 0.5_kindl) + dsum = sum(dat(:,:), mask=mask(:,:) > 0.5_kindl) + else + miss = 0 + low = minval(dat(:,:)) + high = maxval(dat(:,:)) + dsum = sum(dat(:,:)) + endif + avg = 0.0_kindl + + npts = size(dat(:,:)) - miss + if(pe == root_pe) then + do p = 1, npes - 1 ! root_pe receive data from other pe + ! Force use of "scalar", integer pointer mpp interface + call mpp_recv(buffer_real(1),glen=3, from_pe=p+root_pe, tag=COMM_TAG_1) + dsum = dsum + buffer_real(1) + low = min(low, buffer_real(2)) + high = max(high, buffer_real(3)) + call mpp_recv(buffer_int(1), glen=2, from_pe=p+root_pe, tag=COMM_TAG_2) + miss = miss + buffer_int(1) + npts = npts + buffer_int(2) + enddo + if(npts == 0) then + print*, 'Warning: no points is valid' + else + avg = dsum/real(npts, FMS_HI_KIND_) + endif + else ! other pe send data to the root_pe. + buffer_real(1) = dsum + buffer_real(2) = low + buffer_real(3) = high + ! Force use of "scalar", integer pointer mpp interface + call mpp_send(buffer_real(1),plen=3,to_pe=root_pe, tag=COMM_TAG_1) + buffer_int(1) = miss + buffer_int(2) = npts + call mpp_send(buffer_int(1), plen=2, to_pe=root_pe, tag=COMM_TAG_2) + endif + + call mpp_sync_self() + + return + + end subroutine STATS_ \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_type_r4.fh b/horiz_interp/include/horiz_interp_type_r4.fh new file mode 100644 index 0000000000..3b45c8eb29 --- /dev/null +++ b/horiz_interp/include/horiz_interp_type_r4.fh @@ -0,0 +1,28 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_type +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef STATS_ +#define STATS_ stats_r4 + +#include "horiz_interp_type.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_type_r8.fh b/horiz_interp/include/horiz_interp_type_r8.fh new file mode 100644 index 0000000000..67d496fa28 --- /dev/null +++ b/horiz_interp/include/horiz_interp_type_r8.fh @@ -0,0 +1,28 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_type +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef STATS_ +#define STATS_ stats_r8 + +#include "horiz_interp_type.inc" +!> @} \ No newline at end of file diff --git a/sat_vapor_pres/Makefile.am b/sat_vapor_pres/Makefile.am index 6a8546691b..2511061c62 100644 --- a/sat_vapor_pres/Makefile.am +++ b/sat_vapor_pres/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/28/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/sat_vapor_pres/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience library. @@ -31,16 +31,30 @@ noinst_LTLIBRARIES = libsat_vapor_pres.la # Each convenience library depends on its source. libsat_vapor_pres_la_SOURCES = \ - sat_vapor_pres.F90 \ - sat_vapor_pres_k.F90 + sat_vapor_pres.F90 \ + include/sat_vapor_pres_r4.fh \ + include/sat_vapor_pres_r8.fh \ + include/sat_vapor_pres.inc \ + sat_vapor_pres_k.F90 \ + include/sat_vapor_pres_k_r4.fh \ + include/sat_vapor_pres_k_r8.fh \ + include/sat_vapor_pres_k.inc # Some mods are dependant on other mods in this dir. -sat_vapor_pres_mod.$(FC_MODEXT): sat_vapor_pres_k_mod.$(FC_MODEXT) +sat_vapor_pres_mod.$(FC_MODEXT): \ + sat_vapor_pres_k_mod.$(FC_MODEXT) \ + include/sat_vapor_pres_r4.fh \ + include/sat_vapor_pres_r8.fh \ + include/sat_vapor_pres.inc +sat_vapor_pres_k_mod.$(FC_MODEXT): \ + include/sat_vapor_pres_k_r4.fh \ + include/sat_vapor_pres_k_r8.fh \ + include/sat_vapor_pres_k.inc # Mod files are built and then installed as headers. MODFILES = \ - sat_vapor_pres_k_mod.$(FC_MODEXT) \ - sat_vapor_pres_mod.$(FC_MODEXT) + sat_vapor_pres_k_mod.$(FC_MODEXT) \ + sat_vapor_pres_mod.$(FC_MODEXT) BUILT_SOURCES = $(MODFILES) nodist_include_HEADERS = $(MODFILES) diff --git a/sat_vapor_pres/include/sat_vapor_pres.inc b/sat_vapor_pres/include/sat_vapor_pres.inc new file mode 100644 index 0000000000..35a67fa8a2 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres.inc @@ -0,0 +1,1984 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_mod +!> @{ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_ES_0D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES_1D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES_2D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES_2D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES_3D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_ES_3D_ + + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_ES2_0D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES2_1D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES2_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES2_2D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES2_2D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES2_3D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_ES2_3D_ + + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_ES3_0D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES3_1D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES3_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES3_2D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES3_2D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES3_3D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_ES3_3D_ + + +!####################################################################### +! routines for computing derivative of es +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES_0D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des_k( temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_DES_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES_1D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if(present(err_msg)) err_msg='' + + call lookup_des_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES_2D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES_2D_ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_DES_3D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des_k( temp, desat, nbad ) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg='' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_DES_3D_ + + +! +! +! +! +! + subroutine LOOKUP_DES2_0D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des2_k( temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_DES2_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES2_1D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if(present(err_msg)) err_msg='' + + call lookup_des2_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES2_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES2_2D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des2_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES2_2D_ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_DES2_3D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des2_k( temp, desat, nbad ) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg='' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_DES2_3D_ + + +! +! +! +! +! + subroutine LOOKUP_DES3_0D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des3_k( temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_DES3_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES3_1D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if(present(err_msg)) err_msg='' + + call lookup_des3_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES3_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES3_2D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des3_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES3_2D_ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_DES3_3D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des3_k( temp, desat, nbad ) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg='' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_DES3_3D_ + +!======================================================================================================== + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_0D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_0D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_1D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_1D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_2D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_2D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_3D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_3D_ + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_0D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_0D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_1D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_1D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_2D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_2D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_3D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_3D_ + + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_0D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_0D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_1D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_1D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_2D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_2D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_3D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_3D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_0D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(in), optional :: q !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT !< d(qsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILO_loc=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + + call compute_qs_k (temp, press, EPSILO_loc, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_0D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_1D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat(:) !< specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: q(:) !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT(:) !< d(qsat)/dT + real(kind=FMS_SVP_KIND_),intent(out), optional :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) + call compute_qs_k (temp, press, EPSILOl, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_1D_ + + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_2D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat(:,:) !< specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: q(:,:) !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT(:,:) !< d(qsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) + call compute_qs_k (temp, press, EPSILOl, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_2D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_3D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat(:,:,:) !< specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: q(:,:,:) !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT(:,:,:) !< d(qsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) + call compute_qs_k (temp, press, EPSILOl, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_3D_ + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_0D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_0D_ + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_1D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat,& + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat(:) !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr(:) !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT(:) !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & +! nbad, mr, dmrsdT) + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_1D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_2D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat,& + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat(:,:) !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr(:,:) !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT(:,:) !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & +! nbad, mr, dmrsdT) + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_2D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_3D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat,& + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat(:,:,:) !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr(:,:,:) !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT(:,:,:) !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & +! nbad, mr, dmrsdT) + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_3D_ + + +!####################################################################### + + function CHECK_1D_ ( temp ) result ( nbad ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + integer :: nbad, ind, i + + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + ind = int( dtinvll*(temp(i)-tminll + tepsll) ) + if (ind < 0 .or. ind > nlim) nbad = nbad+1 + enddo + + end function CHECK_1D_ + +!------------------------------------------------ + + function CHECK_2D_ ( temp ) result ( nbad ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + integer :: nbad + integer :: j + + nbad = 0 + do j = 1, size(temp,2) + nbad = nbad + check_1d ( temp(:,j) ) + enddo + end function CHECK_2D_ + +!####################################################################### + + subroutine TEMP_CHECK_1D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + integer :: i, unit + + unit = stdoutunit + write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) + + end subroutine TEMP_CHECK_1D_ + +!-------------------------------------------------------------- + + subroutine TEMP_CHECK_2D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, unit + + unit = stdoutunit + write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) + write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) + + end subroutine TEMP_CHECK_2D_ + +!-------------------------------------------------------------- + + subroutine TEMP_CHECK_3D_ ( temp ) + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, k, unit + + unit = stdoutunit + write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) + write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) + write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) + + end subroutine TEMP_CHECK_3D_ + +!####################################################################### + + subroutine SHOW_ALL_BAD_0D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp !< temperature in degrees Kelvin (K) + integer :: ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + ind = int( dtinvll*(temp-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() + endif + + end subroutine SHOW_ALL_BAD_0D_ + +!-------------------------------------------------------------- + + subroutine SHOW_ALL_BAD_1D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + integer :: i, ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + do i=1,size(temp) + ind = int( dtinvll*(temp(i)-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() + endif + enddo + + end subroutine SHOW_ALL_BAD_1D_ + +!-------------------------------------------------------------- + + subroutine SHOW_ALL_BAD_2D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + do j=1,size(temp,2) + do i=1,size(temp,1) + ind = int( dtinvll*(temp(i,j)-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() + endif + enddo + enddo + + end subroutine SHOW_ALL_BAD_2D_ + +!-------------------------------------------------------------- + + subroutine SHOW_ALL_BAD_3D_ ( temp ) + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, k, ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + do k=1,size(temp,3) + do j=1,size(temp,2) + do i=1,size(temp,1) + ind = int( dtinvll*(temp(i,j,k)-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k, & + & ' pe=',mpp_pe() + endif + enddo + enddo + enddo + + end subroutine SHOW_ALL_BAD_3D_ + +!-------------------------------------------------------------- + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_k.inc b/sat_vapor_pres/include/sat_vapor_pres_k.inc new file mode 100644 index 0000000000..00ce7089d0 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_k.inc @@ -0,0 +1,2647 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_k_mod +!> @brief Kernel module to be used by @ref sat_vapor_pres_mod for +!> @{ + +!! table lookups and calculations + +!> This routine has been generalized to return tables for any temperature range and resolution +!! The TABLEs for saturation vapor pressure are computed with r8_kind precision since +!! these TABLES are module level variables that are decared as r8_kind. +!! The subroutines compute_es_k, compute_es_k, compute_es_liq_k, and compute_es_liq_ice_k +!! seem to be mostly used to compute the TABLE values (and thus all variables within them can be declared +!! as r8_kind). However, these compute* subroutines have been modified to accept both r4_kind and r8_kind arguments +!! for general usage and the math can be conducted in either r4_kind and r8_kind. +!! In this initialization routine, r8_kind arguments are passed to these compute* subroutines. +!! This routine does not assume the passed in arguments are in r8_precision. +!! Thus all variables used for the computation of the TABLES (e.g. TABLE, DTABLE*, D2TABLE*) are promoted +!! to r8_kind precision. All local variables used for computation are in r8_kind precision +!! Thus the TABLEs are constructed as accurately as possible and are promoted down to r4_kind when users +!! pass in r4_kind arguments to the LOOKUP* subroutines. + subroutine SAT_VAPOR_PRES_INIT_K_(table_size, tcmin, tcmax, TFREEZE, HLV, RVGAS, ES0, err_msg, & + use_exact_qs_input, do_simple, & + construct_table_wrt_liq, & + construct_table_wrt_liq_and_ice, & + teps, tmin, dtinv) + + integer, intent(in) :: table_size + real(kind=FMS_SVP_KIND_), intent(in) :: tcmin !< TABLE(1) = sat vapor pressure at temperature tcmin (deg C) + real(kind=FMS_SVP_KIND_), intent(in) :: tcmax !< TABLE(table_size) = sat vapor pressure at temperature tcmax (deg C) + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< Conversion to Kelvin + real(kind=FMS_SVP_KIND_), intent(in) :: HLV !< Latent heat of evaporation [J/kg] + real(kind=FMS_SVP_KIND_), intent(in) :: RVGAS !< Gas constant for water vapor + real(kind=FMS_SVP_KIND_), intent(in) :: ES0 !< Humidity factor [dimensionless] + logical, intent(in) :: use_exact_qs_input + logical, intent(in) :: do_simple + logical, intent(in) :: construct_table_wrt_liq + logical, intent(in) :: construct_table_wrt_liq_and_ice + character(len=*), intent(out) :: err_msg + real(kind=FMS_SVP_KIND_), intent(out), optional :: teps + real(kind=FMS_SVP_KIND_), intent(out), optional :: tmin + real(kind=FMS_SVP_KIND_), intent(out), optional :: dtinv + + +!> increment used to generate derivative table +!! the following variables are used in the computation +!! of the *TABLES* (which is defined in r8_kind in sat_vapor_pres_mod) +!! Thus these variables are declared with r8_kind + real(kind=r8_kind), dimension(3) :: tem(3), es(3) + real(kind=r8_kind) :: hdtinv, tinrc, tfact + integer :: i + + err_msg = '' + + if (module_is_initialized) return + + if(allocated(TABLE) .or. allocated(DTABLE) .or. allocated(D2TABLE)) then + err_msg = 'Attempt to allocate sat vapor pressure tables when already allocated' + return + else + allocate(TABLE(table_size), DTABLE(table_size), D2TABLE(table_size)) + endif + + if (construct_table_wrt_liq) then + if(allocated(TABLE2) .or. allocated(DTABLE2) .or. allocated(D2TABLE2)) then + err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' + return + else + allocate(TABLE2(table_size), DTABLE2(table_size), D2TABLE2(table_size)) + endif + endif + + if (construct_table_wrt_liq_and_ice) then + if(allocated(TABLE3) .or. allocated(DTABLE3) .or. allocated(D2TABLE3)) then + err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' + return + else + allocate(TABLE3(table_size), DTABLE3(table_size), D2TABLE3(table_size)) + endif + endif + + table_siz = table_size + dtres = (real(tcmax,r8_kind)-real(tcmin,r8_kind))/real(table_size-1,r8_kind) + tminl = real(tcmin,r8_kind)+real(TFREEZE,r8_kind) ! minimum valid temp in table + dtinvl = 1.0_r8_kind/dtres + tepsl = 0.5_r8_kind*dtres + tinrc = 0.1_r8_kind*dtres + if(present(teps )) teps =real(tepsl, FMS_SVP_KIND_) + if(present(tmin )) tmin =real(tminl, FMS_SVP_KIND_) + if(present(dtinv)) dtinv=real(dtinvl, FMS_SVP_KIND_) + +!> To be able to compute tables for any temperature range and resolution, +!! and at the same time exactly reproduce answers from memphis revision, +!! it is necessary to compute ftact differently than it is in memphis. + tfact = 5.0_r8_kind*dtinvl + + hdtinv = 0._r8_kind*dtinvl + +!> compute es tables from tcmin to tcmax +!> estimate es derivative with small +/- difference + + if (do_simple) then + + !> TABLE = 610.78ES0*exp(-HLV/RGAS[1/tem - 1.TFREEZE]) + !> DTABLE = HLV(TABLE/RVGAS)^2 + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + TABLE(i) = real(ES0,r8_kind)*610.78_r8_kind* & + exp( -real(HLV,r8_kind)/real(RVGAS,r8_kind) * (1.0_r8_kind/tem(1) - 1._r8_kind/real(TFREEZE,r8_kind)) ) + DTABLE(i) = real(HLV,r8_kind)*TABLE(i)/real(RVGAS,r8_kind)/tem(1)**2._r8_kind + enddo + + else + + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + es = compute_es_k (tem, real(TFREEZE,r8_kind)) + TABLE(i) = es(1) + DTABLE(i) = (es(3)-es(2))*tfact + enddo + + endif !if (do_simple) + +!> compute one-half second derivative using centered differences +!! differencing des values in the table + + do i = 2, table_size-1 + D2TABLE(i) = 0.25_r8_kind*dtinvl*(DTABLE(i+1)-DTABLE(i-1)) + enddo +!> one-sided derivatives at boundaries + + D2TABLE(1) = 0.50_r8_kind*dtinvl*(DTABLE(2)-DTABLE(1)) + + D2TABLE(table_size) = 0.50_r8_kind*dtinvl*(DTABLE(table_size)-DTABLE(table_size-1)) + + if (construct_table_wrt_liq) then +!> compute es tables from tcmin to tcmax +!> estimate es derivative with small +/- difference + + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc +!> pass in flag to force all values to be wrt liquid + es = compute_es_liq_k (tem, real(TFREEZE,r8_kind)) + TABLE2(i) = es(1) + DTABLE2(i) = (es(3)-es(2))*tfact + enddo + +!> compute one-half second derivative using centered differences +!! differencing des values in the table + + do i = 2, table_size-1 + D2TABLE2(i) = 0.25_r8_kind*dtinvl*(DTABLE2(i+1)-DTABLE2(i-1)) + enddo +!> one-sided derivatives at boundaries + + D2TABLE2(1) = 0.50_r8_kind*dtinvl*(DTABLE2(2)-DTABLE2(1)) + + D2TABLE2(table_size) = 0.50_r8_kind*dtinvl*(DTABLE2(table_size)-DTABLE2(table_size-1)) + endif + + + if (construct_table_wrt_liq_and_ice) then +!> compute es tables from tcmin to tcmax +!> estimate es derivative with small +/- difference + + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc +!> pass in flag to force all values to be wrt liquid + es = compute_es_liq_ice_k (tem, real(TFREEZE,r8_kind)) + TABLE3(i) = es(1) + DTABLE3(i) = (es(3)-es(2))*tfact + enddo + +!> compute one-half second derivative using centered differences +!! differencing des values in the table + + do i = 2, table_size-1 + D2TABLE3(i) = 0.25_r8_kind*dtinvl*(DTABLE3(i+1)-DTABLE3(i-1)) + enddo +!> one-sided derivatives at boundaries + + D2TABLE3(1) = 0.50_r8_kind*dtinvl*(DTABLE3(2)-DTABLE3(1)) + + D2TABLE3(table_size) = 0.50_r8_kind*dtinvl*(DTABLE3(table_size)-DTABLE3(table_size-1)) + endif + + use_exact_qs = use_exact_qs_input + module_is_initialized = .true. + + end subroutine SAT_VAPOR_PRES_INIT_K_ + +!####################################################################### + + function COMPUTE_ES_K_(tem, TFREEZE) result (es) + real(kind=FMS_SVP_KIND_), intent(in) :: tem(:) !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< conversion to Kelvin + real(kind=FMS_SVP_KIND_) :: es(size(tem,1)) !< saturation vapor pressure + + real(kind=FMS_SVP_KIND_) :: x + real(kind=FMS_SVP_KIND_) :: esice + real(kind=FMS_SVP_KIND_) :: esh2o + real(kind=FMS_SVP_KIND_) :: TBASW + real(kind=FMS_SVP_KIND_) :: TBASI + integer :: i + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local kind parameter + + real(kind=FMS_SVP_KIND_), parameter :: ESBASW = 101324.60_lkind + real(kind=FMS_SVP_KIND_), parameter :: ESBASI = 610.71_lkind + + !> one and ten are declared for code readability. For example, one is easier to read + !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code + real(FMS_SVP_KIND_), parameter :: one=1.0_lkind + real(FMS_SVP_KIND_), parameter :: ten=10.0_lkind + + TBASW = TFREEZE+100.0_lkind !to Kelvin + TBASI = TFREEZE + + do i = 1, size(tem) + +!> compute es over ice + + !> x = -9.09718(TBASI/tem-1) - 3.56654log(TBASI/tem) + 0.876793(1-tem/TBASI) + log(ESBASI) + !! the coded equation below is the commented equation above + if (tem(i) < TBASI) then + x = -9.09718_lkind*(TBASI/tem(i)-one) & + -3.56654_lkind*log10(TBASI/tem(i)) & + +0.876793_lkind*(one-tem(i)/TBASI) + log10(ESBASI) + esice =ten**(x) + else + esice = 0.0_lkind + endif + +!> compute es over water greater than -20 c. +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + + !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem) + !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1] + !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW) + !! the coded equation below is the commented equation above + if (tem(i) > -20.0_lkind+TBASI) then + x = -7.90298_lkind*(TBASW/tem(i)-one) & + +5.02808_lkind*log10(TBASW/tem(i)) & + -1.3816e-07_lkind*(ten**((one-tem(i)/TBASW)*11.344_lkind)-one) & + +8.1328e-03_lkind*(ten**((TBASW/tem(i)-one)*(-3.49149_lkind))-one) & + +log10(ESBASW) + esh2o = ten**(x) + else + esh2o = 0.0_lkind + endif + +!> derive blended es over ice and supercooled water between -20c and 0c + + !> es = 0.05*[esice*(TBASI-10)+esh2o*(tem-TBASI+20)] + !! the coded equation below is the commented equation above + if (tem(i) <= -20.0_lkind+TBASI) then + es(i) = esice + else if (tem(i) >= TBASI) then + es(i) = esh2o + else + es(i) = 0.05_lkind*((TBASI-tem(i))*esice + (tem(i)-TBASI+20.0_lkind)*esh2o) + endif + + enddo + + end function COMPUTE_ES_K_ + +!####################################################################### + + function COMPUTE_ES_LIQ_K_(tem, TFREEZE) result (es) + real(kind=FMS_SVP_KIND_), intent(in) :: tem(:) !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< conversion to Kelvin + real(kind=FMS_SVP_KIND_) :: es(size(tem,1)) !< saturation vapor pressure + + real(kind=FMS_SVP_KIND_) :: x + real(kind=FMS_SVP_KIND_) :: esh2o + real(kind=FMS_SVP_KIND_) :: TBASW + integer :: i + + !> local kind variable + !! one and ten are declared for code readability. For example, one is easier to read + !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code + integer, parameter :: lkind=FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: one=1.0_lkind + real(kind=FMS_SVP_KIND_), parameter :: ten=10.0_lkind + real(kind=FMS_SVP_KIND_), parameter :: ESBASW = 101324.60_lkind + + TBASW = TFREEZE+100.0_lkind + + do i = 1, size(tem) + +!> compute es over water for all temps. +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + + !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem) + !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1] + !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW) + !! the coded equation below is the commented equation above + x = -7.90298_lkind*(TBASW/tem(i)-one) & + +5.02808_lkind*log10(TBASW/tem(i)) & + -1.3816e-07_lkind*(ten**((one-tem(i)/TBASW)*11.344_lkind)-one) & + +8.1328e-03_lkind*(ten**((TBASW/tem(i)-one)*(-3.49149_lkind))-one)& + +log10(ESBASW) + esh2o = ten**(x) + + es(i) = esh2o + + enddo + + end function COMPUTE_ES_LIQ_K_ + +!####################################################################### + + function COMPUTE_ES_LIQ_ICE_K_(tem, TFREEZE) result (es) + real(kind=FMS_SVP_KIND_), intent(in) :: tem(:) !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< conversion to Kelvin + real(kind=FMS_SVP_KIND_) :: es(size(tem,1)) !< saturation vapor pressure + + real(kind=FMS_SVP_KIND_) :: x + real(kind=FMS_SVP_KIND_) :: TBASW + real(kind=FMS_SVP_KIND_) :: TBASI + integer :: i + + integer, parameter :: lkind=FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: ESBASW = 101324.60_lkind + real(kind=FMS_SVP_KIND_), parameter :: ESBASI = 610.71_lkind + !> one and ten are declared for code readability. For example, one is easier to read + !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code + real(kind=FMS_SVP_KIND_), parameter :: one=1.0_lkind + real(kind=FMS_SVP_KIND_), parameter :: ten=10.0_lkind + + TBASW = TFREEZE+100.0_lkind + TBASI = TFREEZE + + do i = 1, size(tem) + + if (tem(i) < TBASI) then + +!> compute es over ice + !> x= -9.09718(TBASI/tem-1) -3.56654log(TBASI/tem) +0.87679(1-tem/TBASI)+log(EBASI) + !! the coded equation below is the commented equation above + x = -9.09718_lkind*(TBASI/tem(i)-one) & + -3.56654_lkind*log10(TBASI/tem(i)) & + +0.876793_lkind*(one-tem(i)/TBASI) + log10(ESBASI) + es(i) =ten**(x) + else + +!> compute es over water +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem) + !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1] + !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW) + !! the coded equation below is the commented equation above + x = -7.90298_lkind*(TBASW/tem(i)-one) & + +5.02808_lkind*log10(TBASW/tem(i)) & + -1.3816e-07_lkind*(ten**((one-tem(i)/TBASW)*11.344_lkind)-one) & + +8.1328e-03_lkind*(ten**((TBASW/tem(i)-one)*(-3.49149_lkind))-one) & + +log10(ESBASW) + es(i) = ten**(x) + endif + enddo + + end function COMPUTE_ES_LIQ_ICE_K_ + +!####################################################################### + + subroutine COMPUTE_QS_K_3D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:), optional :: q !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: dqsdT !< d(qs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq !< use es table wrt liquid only + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_, either r4_kind or r8_kind + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: denom + integer :: i, j, k + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (q) .and. use_exact_qs) then + qs = (1.0_lkind + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0_lkind + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0_lkind - eps)*esloc + do k=1,size(qs,3) + do j=1,size(qs,2) + do i=1,size(qs,1) + if (denom(i,j,k) > 0.0_lkind) then + qs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) + else + qs(i,j,k) = eps + endif + end do + end do + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_3D_ + +!####################################################################### + + subroutine COMPUTE_QS_K_2D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:), optional :: q !< vapor specific humidty + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: dqsdT !< d(qs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: esat ! 0.0_lkind) then + qs(i,j) = eps*esloc(i,j)/denom(i,j) + else + qs(i,j) = eps + endif + end do + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_2D_ + +!####################################################################### + + subroutine COMPUTE_QS_K_1D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:), optional :: q !< vapor specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: dqsdT !< d(qs)/dt + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: denom + integer :: i + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (q) .and. use_exact_qs) then + qs = (1.0_lkind + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0_lkind + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0_lkind - eps)*esloc + do i=1,size(qs,1) + if (denom(i) > 0.0_lkind) then + qs(i) = eps*esloc(i)/denom(i) + else + qs(i) = eps + endif + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_1D_ + +!####################################################################### + + subroutine COMPUTE_QS_K_0D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), optional :: q !< vapor specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT !< d(qs)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_) :: esloc + real(kind=FMS_SVP_KIND_) :: desat + real(kind=FMS_SVP_KIND_) :: denom + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (q) .and. use_exact_qs) then + qs = (1.0_lkind + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0_lkind + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0_lkind - eps)*esloc + if (denom > 0.0_lkind) then + qs = eps*esloc/denom + else + qs = eps + endif + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_0D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_3D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: esloc + real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: desat + real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: denom + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + integer :: i, j, k + real(FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + do k=1,size(mrs,3) + do j=1,size(mrs,2) + do i=1,size(mrs,1) + if (denom(i,j,k) > 0.0_lkind) then + mrs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) + else + mrs(i,j,k) = eps + endif + end do + end do + end do + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + end subroutine COMPUTE_MRS_K_3D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_2D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2)) :: denom + integer :: i, j + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + do j=1,size(mrs,2) + do i=1,size(mrs,1) + if (denom(i,j) > 0.0_lkind) then + mrs(i,j) = eps*esloc(i,j)/denom(i,j) + else + mrs(i,j) = eps + endif + end do + end do + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + + end subroutine COMPUTE_MRS_K_2D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_1D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: denom + integer :: i + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + do i=1,size(mrs,1) + if (denom(i) > 0.0_lkind) then + mrs(i) = eps*esloc(i)/denom(i) + else + mrs(i) = eps + endif + end do + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + + end subroutine COMPUTE_MRS_K_1D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_0D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_) :: esloc + real(kind=FMS_SVP_KIND_) :: desat + real(kind=FMS_SVP_KIND_) :: denom + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + if (denom > 0.0_lkind) then + mrs = eps*esloc/denom + else + mrs = eps + endif + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + + end subroutine COMPUTE_MRS_K_0D_ + + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_3D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat ! dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-real(dtresl,FMS_SVP_KIND_)*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE(ind+1), FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES_DES_K_3D_ + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_2D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of the saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_ES_DES_K_2D_ + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_1D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of the saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_ES_DES_K_1D_ + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_0D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of the saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_ES_DES_K_0D_ + +!####################################################################### + + subroutine LOOKUP_ES_K_3D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturavation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES_K_3D_ + +!####################################################################### + + subroutine LOOKUP_DES_K_3D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_DES_K_3D_ + +!####################################################################### + subroutine LOOKUP_DES_K_2D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_DES_K_2D_ +!####################################################################### + subroutine LOOKUP_ES_K_2D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*(real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + + end subroutine LOOKUP_ES_K_2D_ +!####################################################################### + subroutine LOOKUP_DES_K_1D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_DES_K_1D_ +!####################################################################### + subroutine LOOKUP_ES_K_1D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*(real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + enddo + + end subroutine LOOKUP_ES_K_1D_ +!####################################################################### + subroutine LOOKUP_DES_K_0D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_DES_K_0D_ +!####################################################################### + subroutine LOOKUP_ES_K_0D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + + end subroutine LOOKUP_ES_K_0D_ +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_3D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES2_DES2_K_3D_ + +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_2D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_ES2_DES2_K_2D_ + +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_1D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + desat(i) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_ES2_DES2_K_1D_ + +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_0D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_ES2_DES2_K_0D_ + +!####################################################################### + + subroutine LOOKUP_ES2_K_3D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES2_K_3D_ + +!####################################################################### + + subroutine LOOKUP_DES2_K_3D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_DES2_K_3D_ + +!####################################################################### + subroutine LOOKUP_DES2_K_2D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_DES2_K_2D_ +!####################################################################### + subroutine LOOKUP_ES2_K_2D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,kind=FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + + end subroutine LOOKUP_ES2_K_2D_ +!####################################################################### + subroutine LOOKUP_DES2_K_1D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_DES2_K_1D_ +!####################################################################### + subroutine LOOKUP_ES2_K_1D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + enddo + + end subroutine LOOKUP_ES2_K_1D_ +!####################################################################### + subroutine LOOKUP_DES2_K_0D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_DES2_K_0D_ +!####################################################################### + subroutine LOOKUP_ES2_K_0D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + + end subroutine LOOKUP_ES2_K_0D_ +!####################################################################### + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_3D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of esat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES3_DES3_K_3D_ + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_2D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of desat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_ES3_DES3_K_2D_ + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_1D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of esat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_ES3_DES3_K_1D_ + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_0D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of esat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_ES3_DES3_K_0D_ + +!####################################################################### + + subroutine LOOKUP_ES3_K_3D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES3_K_3D_ + +!####################################################################### + + subroutine LOOKUP_DES3_K_3D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat!< derivatove of saturation vap pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_DES3_K_3D_ + +!####################################################################### + subroutine LOOKUP_DES3_K_2D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_DES3_K_2D_ +!####################################################################### + subroutine LOOKUP_ES3_K_2D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + + end subroutine LOOKUP_ES3_K_2D_ +!####################################################################### + subroutine LOOKUP_DES3_K_1D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_DES3_K_1D_ +!####################################################################### + subroutine LOOKUP_ES3_K_1D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + enddo + + end subroutine LOOKUP_ES3_K_1D_ +!####################################################################### + subroutine LOOKUP_DES3_K_0D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_DES3_K_0D_ +!####################################################################### + subroutine LOOKUP_ES3_K_0D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + + end subroutine LOOKUP_ES3_K_0D_ +!####################################################################### +!> @} +! close documentation grouping diff --git a/sat_vapor_pres/include/sat_vapor_pres_k_r4.fh b/sat_vapor_pres/include/sat_vapor_pres_k_r4.fh new file mode 100644 index 0000000000..e58285fc20 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_k_r4.fh @@ -0,0 +1,174 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_k_mod +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r4_kind + +#undef SAT_VAPOR_PRES_INIT_K_ +#define SAT_VAPOR_PRES_INIT_K_ sat_vapor_pres_init_k_r4 + +#undef COMPUTE_ES_K_ +#define COMPUTE_ES_K_ compute_es_k_r4 + +#undef COMPUTE_ES_LIQ_K_ +#define COMPUTE_ES_LIQ_K_ compute_es_liq_k_r4 + +#undef COMPUTE_ES_LIQ_ICE_K_ +#define COMPUTE_ES_LIQ_ICE_K_ compute_es_liq_ice_k_r4 + +#undef COMPUTE_QS_K_3D_ +#define COMPUTE_QS_K_3D_ compute_qs_k_3d_r4 + +#undef COMPUTE_QS_K_2D_ +#define COMPUTE_QS_K_2D_ compute_qs_k_2d_r4 + +#undef COMPUTE_QS_K_1D_ +#define COMPUTE_QS_K_1D_ compute_qs_k_1d_r4 + +#undef COMPUTE_QS_K_0D_ +#define COMPUTE_QS_K_0D_ compute_qs_k_0d_r4 + +#undef COMPUTE_MRS_K_3D_ +#define COMPUTE_MRS_K_3D_ compute_mrs_k_3d_r4 + +#undef COMPUTE_MRS_K_2D_ +#define COMPUTE_MRS_K_2D_ compute_mrs_k_2d_r4 + +#undef COMPUTE_MRS_K_1D_ +#define COMPUTE_MRS_K_1D_ compute_mrs_k_1d_r4 + +#undef COMPUTE_MRS_K_0D_ +#define COMPUTE_MRS_K_0D_ compute_mrs_k_0d_r4 + +#undef LOOKUP_ES_DES_K_3D_ +#define LOOKUP_ES_DES_K_3D_ lookup_es_des_k_3d_r4 + +#undef LOOKUP_ES_DES_K_2D_ +#define LOOKUP_ES_DES_K_2D_ lookup_es_des_k_2d_r4 + +#undef LOOKUP_ES_DES_K_1D_ +#define LOOKUP_ES_DES_K_1D_ lookup_es_des_k_1d_r4 + +#undef LOOKUP_ES_DES_K_0D_ +#define LOOKUP_ES_DES_K_0D_ lookup_es_des_k_0d_r4 + +#undef LOOKUP_ES_K_3D_ +#define LOOKUP_ES_K_3D_ lookup_es_k_3d_r4 + +#undef LOOKUP_DES_K_3D_ +#define LOOKUP_DES_K_3D_ lookup_des_k_3d_r4 + +#undef LOOKUP_DES_K_2D_ +#define LOOKUP_DES_K_2D_ lookup_des_k_2d_r4 + +#undef LOOKUP_ES_K_2D_ +#define LOOKUP_ES_K_2D_ lookup_es_k_2d_r4 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r4 + +#undef LOOKUP_ES_K_1D_ +#define LOOKUP_ES_K_1D_ lookup_es_k_1d_r4 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r4 + +#undef LOOKUP_ES_K_0D_ +#define LOOKUP_ES_K_0D_ lookup_es_k_0d_r4 + +#undef LOOKUP_DES_K_0D_ +#define LOOKUP_DES_K_0D_ lookup_des_k_0d_r4 + +#undef LOOKUP_ES2_DES2_K_3D_ +#define LOOKUP_ES2_DES2_K_3D_ lookup_es2_des2_k_3d_r4 + +#undef LOOKUP_ES2_DES2_K_2D_ +#define LOOKUP_ES2_DES2_K_2D_ lookup_es2_des2_k_2d_r4 + +#undef LOOKUP_ES2_DES2_K_1D_ +#define LOOKUP_ES2_DES2_K_1D_ lookup_es2_des2_k_1d_r4 + +#undef LOOKUP_ES2_DES2_K_0D_ +#define LOOKUP_ES2_DES2_K_0D_ lookup_es2_des2_k_0d_r4 + +#undef LOOKUP_ES2_K_3D_ +#define LOOKUP_ES2_K_3D_ lookup_es2_k_3d_r4 + +#undef LOOKUP_DES2_K_3D_ +#define LOOKUP_DES2_K_3D_ lookup_des2_k_3d_r4 + +#undef LOOKUP_DES2_K_2D_ +#define LOOKUP_DES2_K_2D_ lookup_des2_k_2d_r4 + +#undef LOOKUP_ES2_K_2D_ +#define LOOKUP_ES2_K_2D_ lookup_es2_k_2d_r4 + +#undef LOOKUP_DES2_K_1D_ +#define LOOKUP_DES2_K_1D_ lookup_des2_k_1d_r4 + +#undef LOOKUP_ES2_K_1D_ +#define LOOKUP_ES2_K_1D_ lookup_es2_k_1d_r4 + +#undef LOOKUP_DES2_K_0D_ +#define LOOKUP_DES2_K_0D_ lookup_des2_k_0d_r4 + +#undef LOOKUP_ES2_K_0D_ +#define LOOKUP_ES2_K_0D_ lookup_es2_k_0d_r4 + +#undef LOOKUP_ES3_DES3_K_3D_ +#define LOOKUP_ES3_DES3_K_3D_ lookup_es3_des3_k_3d_r4 + +#undef LOOKUP_ES3_DES3_K_2D_ +#define LOOKUP_ES3_DES3_K_2D_ lookup_es3_des3_k_2d_r4 + +#undef LOOKUP_ES3_DES3_K_1D_ +#define LOOKUP_ES3_DES3_K_1D_ lookup_es3_des3_k_1d_r4 + +#undef LOOKUP_ES3_DES3_K_0D_ +#define LOOKUP_ES3_DES3_K_0D_ lookup_es3_des3_k_0d_r4 + +#undef LOOKUP_ES3_K_3D_ +#define LOOKUP_ES3_K_3D_ lookup_es3_k_3d_r4 + +#undef LOOKUP_DES3_K_3D_ +#define LOOKUP_DES3_K_3D_ lookup_des3_k_3d_r4 + +#undef LOOKUP_DES3_K_2D_ +#define LOOKUP_DES3_K_2D_ lookup_des3_k_2d_r4 + +#undef LOOKUP_ES3_K_2D_ +#define LOOKUP_ES3_K_2D_ lookup_es3_k_2d_r4 + +#undef LOOKUP_DES3_K_1D_ +#define LOOKUP_DES3_K_1D_ lookup_des3_k_1d_r4 + +#undef LOOKUP_ES3_K_1D_ +#define LOOKUP_ES3_K_1D_ lookup_es3_k_1d_r4 + +#undef LOOKUP_DES3_K_0D_ +#define LOOKUP_DES3_K_0D_ lookup_des3_k_0d_r4 + +#undef LOOKUP_ES3_K_0D_ +#define LOOKUP_ES3_K_0D_ lookup_es3_k_0d_r4 + +#include "sat_vapor_pres_k.inc" + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_k_r8.fh b/sat_vapor_pres/include/sat_vapor_pres_k_r8.fh new file mode 100644 index 0000000000..247dd33d1f --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_k_r8.fh @@ -0,0 +1,174 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_k_mod +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r8_kind + +#undef SAT_VAPOR_PRES_INIT_K_ +#define SAT_VAPOR_PRES_INIT_K_ sat_vapor_pres_init_k_r8 + +#undef COMPUTE_ES_K_ +#define COMPUTE_ES_K_ compute_es_k_r8 + +#undef COMPUTE_ES_LIQ_K_ +#define COMPUTE_ES_LIQ_K_ compute_es_liq_k_r8 + +#undef COMPUTE_ES_LIQ_ICE_K_ +#define COMPUTE_ES_LIQ_ICE_K_ compute_es_liq_ice_k_r8 + +#undef COMPUTE_QS_K_3D_ +#define COMPUTE_QS_K_3D_ compute_qs_k_3d_r8 + +#undef COMPUTE_QS_K_2D_ +#define COMPUTE_QS_K_2D_ compute_qs_k_2d_r8 + +#undef COMPUTE_QS_K_1D_ +#define COMPUTE_QS_K_1D_ compute_qs_k_1d_r8 + +#undef COMPUTE_QS_K_0D_ +#define COMPUTE_QS_K_0D_ compute_qs_k_0d_r8 + +#undef COMPUTE_MRS_K_3D_ +#define COMPUTE_MRS_K_3D_ compute_mrs_k_3d_r8 + +#undef COMPUTE_MRS_K_2D_ +#define COMPUTE_MRS_K_2D_ compute_mrs_k_2d_r8 + +#undef COMPUTE_MRS_K_1D_ +#define COMPUTE_MRS_K_1D_ compute_mrs_k_1d_r8 + +#undef COMPUTE_MRS_K_0D_ +#define COMPUTE_MRS_K_0D_ compute_mrs_k_0d_r8 + +#undef LOOKUP_ES_DES_K_3D_ +#define LOOKUP_ES_DES_K_3D_ lookup_es_des_k_3d_r8 + +#undef LOOKUP_ES_DES_K_2D_ +#define LOOKUP_ES_DES_K_2D_ lookup_es_des_k_2d_r8 + +#undef LOOKUP_ES_DES_K_1D_ +#define LOOKUP_ES_DES_K_1D_ lookup_es_des_k_1d_r8 + +#undef LOOKUP_ES_DES_K_0D_ +#define LOOKUP_ES_DES_K_0D_ lookup_es_des_k_0d_r8 + +#undef LOOKUP_ES_K_3D_ +#define LOOKUP_ES_K_3D_ lookup_es_k_3d_r8 + +#undef LOOKUP_DES_K_3D_ +#define LOOKUP_DES_K_3D_ lookup_des_k_3d_r8 + +#undef LOOKUP_DES_K_2D_ +#define LOOKUP_DES_K_2D_ lookup_des_k_2d_r8 + +#undef LOOKUP_ES_K_2D_ +#define LOOKUP_ES_K_2D_ lookup_es_k_2d_r8 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r8 + +#undef LOOKUP_ES_K_1D_ +#define LOOKUP_ES_K_1D_ lookup_es_k_1d_r8 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r8 + +#undef LOOKUP_ES_K_0D_ +#define LOOKUP_ES_K_0D_ lookup_es_k_0d_r8 + +#undef LOOKUP_DES_K_0D_ +#define LOOKUP_DES_K_0D_ lookup_des_k_0d_r8 + +#undef LOOKUP_ES2_DES2_K_3D_ +#define LOOKUP_ES2_DES2_K_3D_ lookup_es2_des2_k_3d_r8 + +#undef LOOKUP_ES2_DES2_K_2D_ +#define LOOKUP_ES2_DES2_K_2D_ lookup_es2_des2_k_2d_r8 + +#undef LOOKUP_ES2_DES2_K_1D_ +#define LOOKUP_ES2_DES2_K_1D_ lookup_es2_des2_k_1d_r8 + +#undef LOOKUP_ES2_DES2_K_0D_ +#define LOOKUP_ES2_DES2_K_0D_ lookup_es2_des2_k_0d_r8 + +#undef LOOKUP_ES2_K_3D_ +#define LOOKUP_ES2_K_3D_ lookup_es2_k_3d_r8 + +#undef LOOKUP_DES2_K_3D_ +#define LOOKUP_DES2_K_3D_ lookup_des2_k_3d_r8 + +#undef LOOKUP_DES2_K_2D_ +#define LOOKUP_DES2_K_2D_ lookup_des2_k_2d_r8 + +#undef LOOKUP_ES2_K_2D_ +#define LOOKUP_ES2_K_2D_ lookup_es2_k_2d_r8 + +#undef LOOKUP_DES2_K_1D_ +#define LOOKUP_DES2_K_1D_ lookup_des2_k_1d_r8 + +#undef LOOKUP_ES2_K_1D_ +#define LOOKUP_ES2_K_1D_ lookup_es2_k_1d_r8 + +#undef LOOKUP_DES2_K_0D_ +#define LOOKUP_DES2_K_0D_ lookup_des2_k_0d_r8 + +#undef LOOKUP_ES2_K_0D_ +#define LOOKUP_ES2_K_0D_ lookup_es2_k_0d_r8 + +#undef LOOKUP_ES3_DES3_K_3D_ +#define LOOKUP_ES3_DES3_K_3D_ lookup_es3_des3_k_3d_r8 + +#undef LOOKUP_ES3_DES3_K_2D_ +#define LOOKUP_ES3_DES3_K_2D_ lookup_es3_des3_k_2d_r8 + +#undef LOOKUP_ES3_DES3_K_1D_ +#define LOOKUP_ES3_DES3_K_1D_ lookup_es3_des3_k_1d_r8 + +#undef LOOKUP_ES3_DES3_K_0D_ +#define LOOKUP_ES3_DES3_K_0D_ lookup_es3_des3_k_0d_r8 + +#undef LOOKUP_ES3_K_3D_ +#define LOOKUP_ES3_K_3D_ lookup_es3_k_3d_r8 + +#undef LOOKUP_DES3_K_3D_ +#define LOOKUP_DES3_K_3D_ lookup_des3_k_3d_r8 + +#undef LOOKUP_DES3_K_2D_ +#define LOOKUP_DES3_K_2D_ lookup_des3_k_2d_r8 + +#undef LOOKUP_ES3_K_2D_ +#define LOOKUP_ES3_K_2D_ lookup_es3_k_2d_r8 + +#undef LOOKUP_DES3_K_1D_ +#define LOOKUP_DES3_K_1D_ lookup_des3_k_1d_r8 + +#undef LOOKUP_ES3_K_1D_ +#define LOOKUP_ES3_K_1D_ lookup_es3_k_1d_r8 + +#undef LOOKUP_DES3_K_0D_ +#define LOOKUP_DES3_K_0D_ lookup_des3_k_0d_r8 + +#undef LOOKUP_ES3_K_0D_ +#define LOOKUP_ES3_K_0D_ lookup_es3_k_0d_r8 + +#include "sat_vapor_pres_k.inc" + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_r4.fh b/sat_vapor_pres/include/sat_vapor_pres_r4.fh new file mode 100644 index 0000000000..462a131f23 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_r4.fh @@ -0,0 +1,186 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r4_kind + +#undef LOOKUP_ES_0D_ +#define LOOKUP_ES_0D_ lookup_es_0d_r4 + +#undef LOOKUP_ES_1D_ +#define LOOKUP_ES_1D_ lookup_es_1d_r4 + +#undef LOOKUP_ES_2D_ +#define LOOKUP_ES_2D_ lookup_es_2d_r4 + +#undef LOOKUP_ES_3D_ +#define LOOKUP_ES_3D_ lookup_es_3d_r4 + +#undef LOOKUP_ES2_0D_ +#define LOOKUP_ES2_0D_ lookup_es2_0d_r4 + +#undef LOOKUP_ES2_1D_ +#define LOOKUP_ES2_1D_ lookup_es2_1d_r4 + +#undef LOOKUP_ES2_2D_ +#define LOOKUP_ES2_2D_ lookup_es2_2d_r4 + +#undef LOOKUP_ES2_3D_ +#define LOOKUP_ES2_3D_ lookup_es2_3d_r4 + +#undef LOOKUP_ES3_0D_ +#define LOOKUP_ES3_0D_ lookup_es3_0d_r4 + +#undef LOOKUP_ES3_1D_ +#define LOOKUP_ES3_1D_ lookup_es3_1d_r4 + +#undef LOOKUP_ES3_2D_ +#define LOOKUP_ES3_2D_ lookup_es3_2d_r4 + +#undef LOOKUP_ES3_3D_ +#define LOOKUP_ES3_3D_ lookup_es3_3d_r4 + +#undef LOOKUP_DES_0D_ +#define LOOKUP_DES_0D_ lookup_des_0d_r4 + +#undef LOOKUP_DES_1D_ +#define LOOKUP_DES_1D_ lookup_des_1d_r4 + +#undef LOOKUP_DES_2D_ +#define LOOKUP_DES_2D_ lookup_des_2d_r4 + +#undef LOOKUP_DES_3D_ +#define LOOKUP_DES_3D_ lookup_des_3d_r4 + +#undef LOOKUP_DES2_0D_ +#define LOOKUP_DES2_0D_ lookup_des2_0d_r4 + +#undef LOOKUP_DES2_1D_ +#define LOOKUP_DES2_1D_ lookup_des2_1d_r4 + +#undef LOOKUP_DES2_2D_ +#define LOOKUP_DES2_2D_ lookup_des2_2d_r4 + +#undef LOOKUP_DES2_3D_ +#define LOOKUP_DES2_3D_ lookup_des2_3d_r4 + +#undef LOOKUP_DES3_0D_ +#define LOOKUP_DES3_0D_ lookup_des3_0d_r4 + +#undef LOOKUP_DES3_1D_ +#define LOOKUP_DES3_1D_ lookup_des3_1d_r4 + +#undef LOOKUP_DES3_2D_ +#define LOOKUP_DES3_2D_ lookup_des3_2d_r4 + +#undef LOOKUP_DES3_3D_ +#define LOOKUP_DES3_3D_ lookup_des3_3d_r4 + +#undef LOOKUP_ES_DES_0D_ +#define LOOKUP_ES_DES_0D_ lookup_es_des_0d_r4 + +#undef LOOKUP_ES_DES_1D_ +#define LOOKUP_ES_DES_1D_ lookup_es_des_1d_r4 + +#undef LOOKUP_ES_DES_2D_ +#define LOOKUP_ES_DES_2D_ lookup_es_des_2d_r4 + +#undef LOOKUP_ES_DES_3D_ +#define LOOKUP_ES_DES_3D_ lookup_es_des_3d_r4 + +#undef LOOKUP_ES2_DES2_0D_ +#define LOOKUP_ES2_DES2_0D_ lookup_es2_des2_0d_r4 + +#undef LOOKUP_ES2_DES2_1D_ +#define LOOKUP_ES2_DES2_1D_ lookup_es2_des2_1d_r4 + +#undef LOOKUP_ES2_DES2_2D_ +#define LOOKUP_ES2_DES2_2D_ lookup_es2_des2_2d_r4 + +#undef LOOKUP_ES2_DES2_3D_ +#define LOOKUP_ES2_DES2_3D_ lookup_es2_des2_3d_r4 + +#undef LOOKUP_ES3_DES3_0D_ +#define LOOKUP_ES3_DES3_0D_ lookup_es3_des3_0d_r4 + +#undef LOOKUP_ES3_DES3_1D_ +#define LOOKUP_ES3_DES3_1D_ lookup_es3_des3_1d_r4 + +#undef LOOKUP_ES3_DES3_2D_ +#define LOOKUP_ES3_DES3_2D_ lookup_es3_des3_2d_r4 + +#undef LOOKUP_ES3_DES3_3D_ +#define LOOKUP_ES3_DES3_3D_ lookup_es3_des3_3d_r4 + +#undef COMPUTE_QS_0D_ +#define COMPUTE_QS_0D_ compute_qs_0d_r4 + +#undef COMPUTE_QS_1D_ +#define COMPUTE_QS_1D_ compute_qs_1d_r4 + +#undef COMPUTE_QS_2D_ +#define COMPUTE_QS_2D_ compute_qs_2d_r4 + +#undef COMPUTE_QS_3D_ +#define COMPUTE_QS_3D_ compute_qs_3d_r4 + +#undef COMPUTE_MRS_0D_ +#define COMPUTE_MRS_0D_ compute_mrs_0d_r4 + +#undef COMPUTE_MRS_1D_ +#define COMPUTE_MRS_1D_ compute_mrs_1d_r4 + +#undef COMPUTE_MRS_2D_ +#define COMPUTE_MRS_2D_ compute_mrs_2d_r4 + +#undef COMPUTE_MRS_3D_ +#define COMPUTE_MRS_3D_ compute_mrs_3d_r4 + +#undef CHECK_1D_ +#define CHECK_1D_ check_1d_r4 + +#undef CHECK_2D_ +#define CHECK_2D_ check_2d_r4 + +#undef TEMP_CHECK_1D_ +#define TEMP_CHECK_1D_ temp_check_1d_r4 + +#undef TEMP_CHECK_2D_ +#define TEMP_CHECK_2D_ temp_check_2d_r4 + +#undef TEMP_CHECK_3D_ +#define TEMP_CHECK_3D_ temp_checK_3d_r4 + +#undef SHOW_ALL_BAD_0D_ +#define SHOW_ALL_BAD_0D_ show_all_bad_0d_r4 + +#undef SHOW_ALL_BAD_1D_ +#define SHOW_ALL_BAD_1D_ show_all_bad_1d_r4 + +#undef SHOW_ALL_BAD_2D_ +#define SHOW_ALL_BAD_2D_ show_all_bad_2d_r4 + +#undef SHOW_ALL_BAD_3D_ +#define SHOW_ALL_BAD_3D_ show_all_bad_3d_r4 + +#include "sat_vapor_pres.inc" + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_r8.fh b/sat_vapor_pres/include/sat_vapor_pres_r8.fh new file mode 100644 index 0000000000..0f2e6a315f --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_r8.fh @@ -0,0 +1,186 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r8_kind + +#undef LOOKUP_ES_0D_ +#define LOOKUP_ES_0D_ lookup_es_0d_r8 + +#undef LOOKUP_ES_1D_ +#define LOOKUP_ES_1D_ lookup_es_1d_r8 + +#undef LOOKUP_ES_2D_ +#define LOOKUP_ES_2D_ lookup_es_2d_r8 + +#undef LOOKUP_ES_3D_ +#define LOOKUP_ES_3D_ lookup_es_3d_r8 + +#undef LOOKUP_ES2_0D_ +#define LOOKUP_ES2_0D_ lookup_es2_0d_r8 + +#undef LOOKUP_ES2_1D_ +#define LOOKUP_ES2_1D_ lookup_es2_1d_r8 + +#undef LOOKUP_ES2_2D_ +#define LOOKUP_ES2_2D_ lookup_es2_2d_r8 + +#undef LOOKUP_ES2_3D_ +#define LOOKUP_ES2_3D_ lookup_es2_3d_r8 + +#undef LOOKUP_ES3_0D_ +#define LOOKUP_ES3_0D_ lookup_es3_0d_r8 + +#undef LOOKUP_ES3_1D_ +#define LOOKUP_ES3_1D_ lookup_es3_1d_r8 + +#undef LOOKUP_ES3_2D_ +#define LOOKUP_ES3_2D_ lookup_es3_2d_r8 + +#undef LOOKUP_ES3_3D_ +#define LOOKUP_ES3_3D_ lookup_es3_3d_r8 + +#undef LOOKUP_DES_0D_ +#define LOOKUP_DES_0D_ lookup_des_0d_r8 + +#undef LOOKUP_DES_1D_ +#define LOOKUP_DES_1D_ lookup_des_1d_r8 + +#undef LOOKUP_DES_2D_ +#define LOOKUP_DES_2D_ lookup_des_2d_r8 + +#undef LOOKUP_DES_3D_ +#define LOOKUP_DES_3D_ lookup_des_3d_r8 + +#undef LOOKUP_DES2_0D_ +#define LOOKUP_DES2_0D_ lookup_des2_0d_r8 + +#undef LOOKUP_DES2_1D_ +#define LOOKUP_DES2_1D_ lookup_des2_1d_r8 + +#undef LOOKUP_DES2_2D_ +#define LOOKUP_DES2_2D_ lookup_des2_2d_r8 + +#undef LOOKUP_DES2_3D_ +#define LOOKUP_DES2_3D_ lookup_des2_3d_r8 + +#undef LOOKUP_DES3_0D_ +#define LOOKUP_DES3_0D_ lookup_des3_0d_r8 + +#undef LOOKUP_DES3_1D_ +#define LOOKUP_DES3_1D_ lookup_des3_1d_r8 + +#undef LOOKUP_DES3_2D_ +#define LOOKUP_DES3_2D_ lookup_des3_2d_r8 + +#undef LOOKUP_DES3_3D_ +#define LOOKUP_DES3_3D_ lookup_des3_3d_r8 + +#undef LOOKUP_ES_DES_0D_ +#define LOOKUP_ES_DES_0D_ lookup_es_des_0d_r8 + +#undef LOOKUP_ES_DES_1D_ +#define LOOKUP_ES_DES_1D_ lookup_es_des_1d_r8 + +#undef LOOKUP_ES_DES_2D_ +#define LOOKUP_ES_DES_2D_ lookup_es_des_2d_r8 + +#undef LOOKUP_ES_DES_3D_ +#define LOOKUP_ES_DES_3D_ lookup_es_des_3d_r8 + +#undef LOOKUP_ES2_DES2_0D_ +#define LOOKUP_ES2_DES2_0D_ lookup_es2_des2_0d_r8 + +#undef LOOKUP_ES2_DES2_1D_ +#define LOOKUP_ES2_DES2_1D_ lookup_es2_des2_1d_r8 + +#undef LOOKUP_ES2_DES2_2D_ +#define LOOKUP_ES2_DES2_2D_ lookup_es2_des2_2d_r8 + +#undef LOOKUP_ES2_DES2_3D_ +#define LOOKUP_ES2_DES2_3D_ lookup_es2_des2_3d_r8 + +#undef LOOKUP_ES3_DES3_0D_ +#define LOOKUP_ES3_DES3_0D_ lookup_es3_des3_0d_r8 + +#undef LOOKUP_ES3_DES3_1D_ +#define LOOKUP_ES3_DES3_1D_ lookup_es3_des3_1d_r8 + +#undef LOOKUP_ES3_DES3_2D_ +#define LOOKUP_ES3_DES3_2D_ lookup_es3_des3_2d_r8 + +#undef LOOKUP_ES3_DES3_3D_ +#define LOOKUP_ES3_DES3_3D_ lookup_es3_des3_3d_r8 + +#undef COMPUTE_QS_0D_ +#define COMPUTE_QS_0D_ compute_qs_0d_r8 + +#undef COMPUTE_QS_1D_ +#define COMPUTE_QS_1D_ compute_qs_1d_r8 + +#undef COMPUTE_QS_2D_ +#define COMPUTE_QS_2D_ compute_qs_2d_r8 + +#undef COMPUTE_QS_3D_ +#define COMPUTE_QS_3D_ compute_qs_3d_r8 + +#undef COMPUTE_MRS_0D_ +#define COMPUTE_MRS_0D_ compute_mrs_0d_r8 + +#undef COMPUTE_MRS_1D_ +#define COMPUTE_MRS_1D_ compute_mrs_1d_r8 + +#undef COMPUTE_MRS_2D_ +#define COMPUTE_MRS_2D_ compute_mrs_2d_r8 + +#undef COMPUTE_MRS_3D_ +#define COMPUTE_MRS_3D_ compute_mrs_3d_r8 + +#undef CHECK_1D_ +#define CHECK_1D_ check_1d_r8 + +#undef CHECK_2D_ +#define CHECK_2D_ check_2d_r8 + +#undef TEMP_CHECK_1D_ +#define TEMP_CHECK_1D_ temp_check_1d_r8 + +#undef TEMP_CHECK_2D_ +#define TEMP_CHECK_2D_ temp_check_2d_r8 + +#undef TEMP_CHECK_3D_ +#define TEMP_CHECK_3D_ temp_checK_3d_r8 + +#undef SHOW_ALL_BAD_0D_ +#define SHOW_ALL_BAD_0D_ show_all_bad_0d_r8 + +#undef SHOW_ALL_BAD_1D_ +#define SHOW_ALL_BAD_1D_ show_all_bad_1d_r8 + +#undef SHOW_ALL_BAD_2D_ +#define SHOW_ALL_BAD_2D_ show_all_bad_2d_r8 + +#undef SHOW_ALL_BAD_3D_ +#define SHOW_ALL_BAD_3D_ show_all_bad_3d_r8 + +#include "sat_vapor_pres.inc" + +!> @} diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index 1e29b8bc38..b5591e99d4 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -190,7 +190,6 @@ module sat_vapor_pres_mod lookup_es3_k, & lookup_des3_k, lookup_es3_des3_k, & compute_qs_k, compute_mrs_k - use platform_mod, only: r4_kind, r8_kind implicit none @@ -264,13 +263,19 @@ module sat_vapor_pres_mod !! then parameters in the module header must be modified. !> @ingroup sat_vapor_pres_mod interface lookup_es - module procedure lookup_es_0d, lookup_es_1d, lookup_es_2d, lookup_es_3d - end interface + module procedure lookup_es_0d_r4, lookup_es_0d_r8 + module procedure lookup_es_1d_r4, lookup_es_1d_r8 + module procedure lookup_es_2d_r4, lookup_es_2d_r8 + module procedure lookup_es_3d_r4, lookup_es_3d_r8 + end interface lookup_es !> Provided for backward compatibility (to be removed soon) !> @ingroup sat_vapor_pres_mod interface escomp - module procedure lookup_es_0d, lookup_es_1d, lookup_es_2d, lookup_es_3d - end interface + module procedure lookup_es_0d_r4, lookup_es_0d_r8 + module procedure lookup_es_1d_r4, lookup_es_1d_r8 + module procedure lookup_es_2d_r4, lookup_es_2d_r8 + module procedure lookup_es_3d_r4, lookup_es_3d_r8 + end interface escomp ! !----------------------------------------------------------------------- ! @@ -335,14 +340,20 @@ module sat_vapor_pres_mod !! @code{.F90} call lookup_des( temp, desat) @endcode !> @ingroup sat_vapor_pres_mod interface lookup_des - module procedure lookup_des_0d, lookup_des_1d, lookup_des_2d, lookup_des_3d - end interface + module procedure lookup_des_0d_r4, lookup_des_0d_r8 + module procedure lookup_des_1d_r4, lookup_des_1d_r8 + module procedure lookup_des_2d_r4, lookup_des_2d_r8 + module procedure lookup_des_3d_r4, lookup_des_3d_r8 + end interface lookup_des ! !> Provided for backward compatibility (to be removed soon) !> @ingroup sat_vapor_pres_mod interface descomp - module procedure lookup_des_0d, lookup_des_1d, lookup_des_2d, lookup_des_3d - end interface + module procedure lookup_des_0d_r4, lookup_des_0d_r8 + module procedure lookup_des_1d_r4, lookup_des_1d_r8 + module procedure lookup_des_2d_r4, lookup_des_2d_r8 + module procedure lookup_des_3d_r4, lookup_des_3d_r8 + end interface descomp !----------------------------------------------------------------------- @@ -419,38 +430,59 @@ module sat_vapor_pres_mod !! then parameters in the module header must be modified. !> @ingroup sat_vapor_pres_mod interface lookup_es_des - module procedure lookup_es_des_0d, lookup_es_des_1d, lookup_es_des_2d, lookup_es_des_3d - end interface + module procedure lookup_es_des_0d_r4, lookup_es_des_0d_r8 + module procedure lookup_es_des_1d_r4, lookup_es_des_1d_r8 + module procedure lookup_es_des_2d_r4, lookup_es_des_2d_r8 + module procedure lookup_es_des_3d_r4, lookup_es_des_3d_r8 + end interface lookup_es_des !> @ingroup sat_vapor_pres_mod interface lookup_es2 - module procedure lookup_es2_0d, lookup_es2_1d, lookup_es2_2d, lookup_es2_3d - end interface + module procedure lookup_es2_0d_r4, lookup_es2_0d_r8 + module procedure lookup_es2_1d_r4, lookup_es2_1d_r8 + module procedure lookup_es2_2d_r4, lookup_es2_2d_r8 + module procedure lookup_es2_3d_r4, lookup_es2_3d_r8 + end interface lookup_es2 !> @ingroup sat_vapor_pres_mod interface lookup_des2 - module procedure lookup_des2_0d, lookup_des2_1d, lookup_des2_2d, lookup_des2_3d - end interface + module procedure lookup_des2_0d_r4, lookup_des2_0d_r8 + module procedure lookup_des2_1d_r4, lookup_des2_1d_r8 + module procedure lookup_des2_2d_r4, lookup_des2_2d_r8 + module procedure lookup_des2_3d_r4, lookup_des2_3d_r8 + end interface lookup_des2 !> @ingroup sat_vapor_pres_mod interface lookup_es2_des2 - module procedure lookup_es2_des2_0d, lookup_es2_des2_1d, lookup_es2_des2_2d, lookup_es2_des2_3d - end interface + module procedure lookup_es2_des2_0d_r4, lookup_es2_des2_0d_r8 + module procedure lookup_es2_des2_1d_r4, lookup_es2_des2_1d_r8 + module procedure lookup_es2_des2_2d_r4, lookup_es2_des2_2d_r8 + module procedure lookup_es2_des2_3d_r4, lookup_es2_des2_3d_r8 + end interface lookup_es2_des2 !> @ingroup sat_vapor_pres_mod interface lookup_es3 - module procedure lookup_es3_0d, lookup_es3_1d, lookup_es3_2d, lookup_es3_3d - end interface + module procedure lookup_es3_0d_r4, lookup_es3_0d_r8 + module procedure lookup_es3_1d_r4, lookup_es3_1d_r8 + module procedure lookup_es3_2d_r4, lookup_es3_2d_r8 + module procedure lookup_es3_3d_r4, lookup_es3_3d_r8 + end interface lookup_es3 !> @ingroup sat_vapor_pres_mod interface lookup_des3 - module procedure lookup_des3_0d, lookup_des3_1d, lookup_des3_2d, lookup_des3_3d - end interface + module procedure lookup_des3_0d_r4, lookup_des3_0d_r8 + module procedure lookup_des3_1d_r4, lookup_des3_1d_r8 + module procedure lookup_des3_2d_r4, lookup_des3_2d_r8 + module procedure lookup_des3_3d_r4, lookup_des3_3d_r8 + end interface lookup_des3 !> @ingroup sat_vapor_pres_mod interface lookup_es3_des3 - module procedure lookup_es3_des3_0d, lookup_es3_des3_1d, lookup_es3_des3_2d, lookup_es3_des3_3d - end interface + module procedure lookup_es3_des3_0d_r4, lookup_es3_des3_0d_r8 + module procedure lookup_es3_des3_1d_r4, lookup_es3_des3_1d_r8 + module procedure lookup_es3_des3_2d_r4, lookup_es3_des3_2d_r8 + module procedure lookup_es3_des3_3d_r4, lookup_es3_des3_3d_r8 + end interface lookup_es3_des3 !----------------------------------------------------------------------- @@ -547,8 +579,11 @@ module sat_vapor_pres_mod !! !> @ingroup sat_vapor_pres_mod interface compute_qs - module procedure compute_qs_0d, compute_qs_1d, compute_qs_2d, compute_qs_3d - end interface + module procedure compute_qs_0d_r4, compute_qs_0d_r8 + module procedure compute_qs_1d_r4, compute_qs_1d_r8 + module procedure compute_qs_2d_r4, compute_qs_2d_r8 + module procedure compute_qs_3d_r4, compute_qs_3d_r8 + end interface compute_qs !----------------------------------------------------------------------- @@ -646,8 +681,11 @@ module sat_vapor_pres_mod !! err_msg ) @endcode !> @ingroup sat_vapor_pres_mod interface compute_mrs - module procedure compute_mrs_0d, compute_mrs_1d, compute_mrs_2d, compute_mrs_3d - end interface + module procedure compute_mrs_0d_r4, compute_mrs_0d_r8 + module procedure compute_mrs_1d_r4, compute_mrs_1d_r8 + module procedure compute_mrs_2d_r4, compute_mrs_2d_r8 + module procedure compute_mrs_3d_r4, compute_mrs_3d_r8 + end interface compute_mrs !----------------------------------------------------------------------- ! @@ -677,15 +715,29 @@ module sat_vapor_pres_mod !end interface ! !----------------------------------------------------------------------- + !> @ingroup sat_vapor_pres_mod + interface check_1d + module procedure check_1d_r4, check_1d_r8 + end interface check_1d + + interface check_2d + module procedure check_2d_r4, check_2d_r8 + end interface check_2d + !> @ingroup sat_vapor_pres_mod interface temp_check - module procedure temp_check_1d, temp_check_2d, temp_check_3d - end interface + module procedure temp_check_1d_r4, temp_check_1d_r8 + module procedure temp_check_2d_r4, temp_check_2d_r8 + module procedure temp_check_3d_r4, temp_check_3d_r8 + end interface temp_check !> @ingroup sat_vapor_pres_mod interface show_all_bad - module procedure show_all_bad_0d, show_all_bad_1d, show_all_bad_2d, show_all_bad_3d - end interface + module procedure show_all_bad_0d_r4, show_all_bad_0d_r8 + module procedure show_all_bad_1d_r4, show_all_bad_1d_r8 + module procedure show_all_bad_2d_r4, show_all_bad_2d_r8 + module procedure show_all_bad_3d_r4, show_all_bad_3d_r8 + end interface show_all_bad !> @addtogroup sat_vapor_pres_mod !> @{ @@ -698,8 +750,8 @@ module sat_vapor_pres_mod !----------------------------------------------------------------------- ! parameters for use in computing qs and mrs - real, parameter :: EPSILO = RDGAS/RVGAS - real, parameter :: ZVIR = RVGAS/RDGAS - 1.0 + real(r8_kind), parameter :: EPSILO = real(RDGAS,r8_kind)/real(RVGAS, r8_kind) + real(r8_kind), parameter :: ZVIR = real(RVGAS,r8_kind)/real(RDGAS,r8_kind) - 1.0_r8_kind !----------------------------------------------------------------------- ! parameters for table size and resolution @@ -713,7 +765,7 @@ module sat_vapor_pres_mod integer :: stdoutunit=0 !----------------------------------------------------------------------- ! variables needed by temp_check - real :: tmin, dtinv, teps + real(r8_kind) :: tmin, dtinv, teps ! The default values below preserve the behavior of omsk and earlier revisions. logical :: show_bad_value_count_by_slice=.true. @@ -730,1747 +782,6 @@ module sat_vapor_pres_mod contains -!####################################################################### -! -! -! -! -! - subroutine lookup_es_0d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp - class(*), intent(out) :: esat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es_1d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp(:) - class(*), intent(out) :: esat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es_2d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp(:,:) - class(*), intent(out) :: esat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es_2d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es_3d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp(:,:,:) - class(*), intent(out) :: esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_es_3d - - -!####################################################################### -! -! -! -! -! - subroutine lookup_es2_0d ( temp, esat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es2_1d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:) - real, intent(out) :: esat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es2_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es2_2d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:) - real, intent(out) :: esat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es2_2d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es2_3d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:,:) - real, intent(out) :: esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_es2_3d - - -!####################################################################### -! -! -! -! -! - subroutine lookup_es3_0d ( temp, esat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es3_1d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:) - real, intent(out) :: esat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es3_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es3_2d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:) - real, intent(out) :: esat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es3_2d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es3_3d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:,:) - real, intent(out) :: esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_es3_3d - - -!####################################################################### -! routines for computing derivative of es -!####################################################################### - -! -! -! -! -! - subroutine lookup_des_0d ( temp, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des_k( temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des',err_msg_local,err_msg)) return - endif - - end subroutine lookup_des_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des_1d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:) - real, intent(out) :: desat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if(present(err_msg)) err_msg='' - - call lookup_des_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des_2d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:) - real, intent(out) :: desat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des_2d - -!####################################################################### -! -! -! -! -! - subroutine lookup_des_3d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:,:) - real, intent(out) :: desat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des_k( temp, desat, nbad ) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg='' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_des_3d - - -! -! -! -! -! - subroutine lookup_des2_0d ( temp, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des2_k( temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_des2_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des2_1d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:) - real, intent(out) :: desat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if(present(err_msg)) err_msg='' - - call lookup_des2_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des2_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des2_2d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:) - real, intent(out) :: desat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des2_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des2_2d - -!####################################################################### -! -! -! -! -! - subroutine lookup_des2_3d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:,:) - real, intent(out) :: desat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des2_k( temp, desat, nbad ) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg='' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_des2_3d - - -! -! -! -! -! - subroutine lookup_des3_0d ( temp, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des3_k( temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_des3_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des3_1d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:) - real, intent(out) :: desat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if(present(err_msg)) err_msg='' - - call lookup_des3_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des3_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des3_2d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:) - real, intent(out) :: desat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des3_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des3_2d - -!####################################################################### -! -! -! -! -! - subroutine lookup_des3_3d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:,:) - real, intent(out) :: desat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des3_k( temp, desat, nbad ) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg='' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_des3_3d - -!======================================================================================================== - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_0d ( temp, esat, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_0d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_1d ( temp, esat, desat, err_msg ) - - real, dimension(:), intent(in) :: temp - real, dimension(:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_1d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_2d ( temp, esat, desat, err_msg ) - - real, dimension(:,:), intent(in) :: temp - real, dimension(:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_2d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_3d ( temp, esat, desat, err_msg ) - - real, dimension(:,:,:), intent(in) :: temp - real, dimension(:,:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_3d - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_0d ( temp, esat, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_0d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_1d ( temp, esat, desat, err_msg ) - - real, dimension(:), intent(in) :: temp - real, dimension(:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_1d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_2d ( temp, esat, desat, err_msg ) - - real, dimension(:,:), intent(in) :: temp - real, dimension(:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_2d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_3d ( temp, esat, desat, err_msg ) - - real, dimension(:,:,:), intent(in) :: temp - real, dimension(:,:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_3d - - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_0d ( temp, esat, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_0d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_1d ( temp, esat, desat, err_msg ) - - real, dimension(:), intent(in) :: temp - real, dimension(:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_1d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_2d ( temp, esat, desat, err_msg ) - - real, dimension(:,:), intent(in) :: temp - real, dimension(:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_2d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_3d ( temp, esat, desat, err_msg ) - - real, dimension(:,:,:), intent(in) :: temp - real, dimension(:,:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_3d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_0d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp, press - class(*), intent(out) :: qsat - class(*), intent(in), optional :: q, hc - class(*), intent(out), optional :: dqsdT, esat - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_0d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_1d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp(:), press(:) - class(*), intent(out) :: qsat(:) - class(*), intent(in), optional :: q(:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:), esat(:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_1d - - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_2d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp(:,:), press(:,:) - class(*), intent(out) :: qsat(:,:) - class(*), intent(in), optional :: q(:,:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:,:), esat(:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_2d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_3d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp(:,:,:), press(:,:,:) - class(*), intent(out) :: qsat(:,:,:) - class(*), intent(in), optional :: q(:,:,:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:,:,:), esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_3d - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_0d ( temp, press, mrsat, mr, hc, dmrsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp, press - real, intent(out) :: mrsat - real, intent(in), optional :: mr, hc - real, intent(out), optional :: dmrsdT, esat - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_0d - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_1d ( temp, press, mrsat, mr, hc, dmrsdT, esat,& - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp(:), press(:) - real, intent(out) :: mrsat(:) - real, intent(in), optional :: mr(:) - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT(:), esat(:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & -! nbad, mr, dmrsdT) - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_1d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_2d ( temp, press, mrsat, mr, hc, dmrsdT, esat,& - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp(:,:), press(:,:) - real, intent(out) :: mrsat(:,:) - real, intent(in), optional :: mr(:,:) - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT(:,:), esat(:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & -! nbad, mr, dmrsdT) - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_2d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_3d ( temp, press, mrsat, mr, hc, dmrsdT, esat,& - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp(:,:,:), press(:,:,:) - real, intent(out) :: mrsat(:,:,:) - real, intent(in), optional :: mr(:,:,:) - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT(:,:,:), esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & -! nbad, mr, dmrsdT) - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_3d - - -!####################################################################### - -!####################################################################### - -! - -! -! Initializes the lookup tables for saturation vapor pressure. -! -! -! Initializes the lookup tables for saturation vapor pressure. -! This routine will be called automatically the first time -! lookup_es or lookup_des is called, -! the user does not need to call this routine. -! There are no arguments. -! -! -! - -! subroutine sat_vapor_pres_init(err_msg) ! ================================================================= @@ -2511,8 +822,9 @@ subroutine sat_vapor_pres_init(err_msg) endif nsize = (tcmax-tcmin)*esres+1 nlim = nsize-1 - call sat_vapor_pres_init_k(nsize, real(tcmin), real(tcmax), TFREEZE, HLV, & - RVGAS, ES0, err_msg_local, use_exact_qs, do_simple, & + call sat_vapor_pres_init_k(nsize, real(tcmin,r8_kind), real(tcmax,r8_kind), & + real(TFREEZE,r8_kind), real(HLV,r8_kind),& + real(RVGAS,r8_kind), real(ES0,r8_kind), err_msg_local, use_exact_qs, do_simple,& construct_table_wrt_liq, & construct_table_wrt_liq_and_ice, & teps, tmin, dtinv) @@ -2526,6 +838,9 @@ subroutine sat_vapor_pres_init(err_msg) end subroutine sat_vapor_pres_init +#include "sat_vapor_pres_r4.fh" +#include "sat_vapor_pres_r8.fh" + !####################################################################### !####################################################################### !------------------------------------------------------------------- @@ -2604,253 +919,6 @@ end subroutine sat_vapor_pres_init !end function compute_es_3d -!####################################################################### - - function check_1d ( temp ) result ( nbad ) - class(*), intent(in) :: temp(:) - integer :: nbad, ind, i - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) nbad = nbad+1 - enddo - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) nbad = nbad+1 - enddo - class default - call error_mesg ('sat_vapor_pres_mod::check_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end function check_1d - -!------------------------------------------------ - - function check_2d ( temp ) result ( nbad ) - class(*), intent(in) :: temp(:,:) - integer :: nbad - integer :: j - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - nbad = nbad + check_1d ( temp(:,j) ) - enddo - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - nbad = nbad + check_1d ( temp(:,j) ) - enddo - class default - call error_mesg ('sat_vapor_pres_mod::check_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end function check_2d - -!####################################################################### - - subroutine temp_check_1d ( temp ) - class(*), intent(in) :: temp(:) - integer :: i, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine temp_check_1d - -!-------------------------------------------------------------- - - subroutine temp_check_2d ( temp ) - class(*), intent(in) :: temp(:,:) - integer :: i, j, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine temp_check_2d - -!-------------------------------------------------------------- - - subroutine temp_check_3d ( temp ) - class(*), intent(in) :: temp(:,:,:) - integer :: i, j, k, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) - write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) - write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_3d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine temp_check_3d - -!####################################################################### - -subroutine show_all_bad_0d ( temp ) - class(*), intent(in) :: temp - integer :: ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - ind = int(dtinv*(temp-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() - endif - type is (real(kind=r8_kind)) - ind = int(dtinv*(temp-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() - endif - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_0d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_0d - -!-------------------------------------------------------------- - - subroutine show_all_bad_1d ( temp ) - class(*), intent(in) :: temp(:) - integer :: i, ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do i=1,size(temp) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() - endif - enddo - type is (real(kind=r8_kind)) - do i=1,size(temp) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() - endif - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_1d - -!-------------------------------------------------------------- - - subroutine show_all_bad_2d ( temp ) - class(*), intent(in) :: temp(:,:) - integer :: i, j, ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() - endif - enddo - enddo - type is (real(kind=r8_kind)) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() - endif - enddo - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_2d - -!-------------------------------------------------------------- - - subroutine show_all_bad_3d ( temp ) - class(*), intent(in) :: temp(:,:,:) - integer :: i, j, k, ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do k=1,size(temp,3) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j,k)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),& - &' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe() - endif - enddo - enddo - enddo - type is (real(kind=r8_kind)) - do k=1,size(temp,3) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j,k)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),& - &' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe() - endif - enddo - enddo - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_3d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_3d - !####################################################################### end module sat_vapor_pres_mod !####################################################################### diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index a9b7a4aee2..03e3c72d12 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -69,4356 +69,185 @@ module sat_vapor_pres_k_mod public :: compute_qs_k public :: compute_mrs_k + !> @ingroup sat_vapor_pres_k_mod + interface sat_vapor_pres_init_k + module procedure sat_vapor_pres_init_k_r4 + module procedure sat_vapor_pres_init_k_r8 + end interface sat_vapor_pres_init_k + + !> @ingroup sat_vapor_pres_k_mod + interface compute_es_k + module procedure compute_es_k_r4 + module procedure compute_es_k_r8 + end interface compute_es_k + + interface compute_es_liq_k + module procedure compute_es_liq_k_r4 + module procedure compute_es_liq_k_r8 + end interface compute_es_liq_k + + interface compute_es_liq_ice_k + module procedure compute_es_liq_ice_k_r4 + module procedure compute_es_liq_ice_k_r8 + end interface compute_es_liq_ice_k + !> @ingroup sat_vapor_pres_k_mod interface lookup_es_k - module procedure lookup_es_k_0d - module procedure lookup_es_k_1d - module procedure lookup_es_k_2d - module procedure lookup_es_k_3d + module procedure lookup_es_k_0d_r4 + module procedure lookup_es_k_0d_r8 + module procedure lookup_es_k_1d_r4 + module procedure lookup_es_k_1d_r8 + module procedure lookup_es_k_2d_r4 + module procedure lookup_es_k_2d_r8 + module procedure lookup_es_k_3d_r4 + module procedure lookup_es_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_des_k - module procedure lookup_des_k_0d - module procedure lookup_des_k_1d - module procedure lookup_des_k_2d - module procedure lookup_des_k_3d + module procedure lookup_des_k_0d_r4 + module procedure lookup_des_k_0d_r8 + module procedure lookup_des_k_1d_r4 + module procedure lookup_des_k_1d_r8 + module procedure lookup_des_k_2d_r4 + module procedure lookup_des_k_2d_r8 + module procedure lookup_des_k_3d_r4 + module procedure lookup_des_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es_des_k - module procedure lookup_es_des_k_0d - module procedure lookup_es_des_k_1d - module procedure lookup_es_des_k_2d - module procedure lookup_es_des_k_3d + module procedure lookup_es_des_k_0d_r4 + module procedure lookup_es_des_k_0d_r8 + module procedure lookup_es_des_k_1d_r4 + module procedure lookup_es_des_k_1d_r8 + module procedure lookup_es_des_k_2d_r4 + module procedure lookup_es_des_k_2d_r8 + module procedure lookup_es_des_k_3d_r4 + module procedure lookup_es_des_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es2_k - module procedure lookup_es2_k_0d - module procedure lookup_es2_k_1d - module procedure lookup_es2_k_2d - module procedure lookup_es2_k_3d + module procedure lookup_es2_k_0d_r4 + module procedure lookup_es2_k_0d_r8 + module procedure lookup_es2_k_1d_r4 + module procedure lookup_es2_k_1d_r8 + module procedure lookup_es2_k_2d_r4 + module procedure lookup_es2_k_2d_r8 + module procedure lookup_es2_k_3d_r4 + module procedure lookup_es2_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_des2_k - module procedure lookup_des2_k_0d - module procedure lookup_des2_k_1d - module procedure lookup_des2_k_2d - module procedure lookup_des2_k_3d + module procedure lookup_des2_k_0d_r4 + module procedure lookup_des2_k_0d_r8 + module procedure lookup_des2_k_1d_r4 + module procedure lookup_des2_k_1d_r8 + module procedure lookup_des2_k_2d_r4 + module procedure lookup_des2_k_2d_r8 + module procedure lookup_des2_k_3d_r4 + module procedure lookup_des2_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es2_des2_k - module procedure lookup_es2_des2_k_0d - module procedure lookup_es2_des2_k_1d - module procedure lookup_es2_des2_k_2d - module procedure lookup_es2_des2_k_3d + module procedure lookup_es2_des2_k_0d_r4 + module procedure lookup_es2_des2_k_0d_r8 + module procedure lookup_es2_des2_k_1d_r4 + module procedure lookup_es2_des2_k_1d_r8 + module procedure lookup_es2_des2_k_2d_r4 + module procedure lookup_es2_des2_k_2d_r8 + module procedure lookup_es2_des2_k_3d_r4 + module procedure lookup_es2_des2_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es3_k - module procedure lookup_es3_k_0d - module procedure lookup_es3_k_1d - module procedure lookup_es3_k_2d - module procedure lookup_es3_k_3d + module procedure lookup_es3_k_0d_r4 + module procedure lookup_es3_k_0d_r8 + module procedure lookup_es3_k_1d_r4 + module procedure lookup_es3_k_1d_r8 + module procedure lookup_es3_k_2d_r4 + module procedure lookup_es3_k_2d_r8 + module procedure lookup_es3_k_3d_r4 + module procedure lookup_es3_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_des3_k - module procedure lookup_des3_k_0d - module procedure lookup_des3_k_1d - module procedure lookup_des3_k_2d - module procedure lookup_des3_k_3d + module procedure lookup_des3_k_0d_r4 + module procedure lookup_des3_k_0d_r8 + module procedure lookup_des3_k_1d_r4 + module procedure lookup_des3_k_1d_r8 + module procedure lookup_des3_k_2d_r4 + module procedure lookup_des3_k_2d_r8 + module procedure lookup_des3_k_3d_r4 + module procedure lookup_des3_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es3_des3_k - module procedure lookup_es3_des3_k_0d - module procedure lookup_es3_des3_k_1d - module procedure lookup_es3_des3_k_2d - module procedure lookup_es3_des3_k_3d + module procedure lookup_es3_des3_k_0d_r4 + module procedure lookup_es3_des3_k_0d_r8 + module procedure lookup_es3_des3_k_1d_r4 + module procedure lookup_es3_des3_k_1d_r8 + module procedure lookup_es3_des3_k_2d_r4 + module procedure lookup_es3_des3_k_2d_r8 + module procedure lookup_es3_des3_k_3d_r4 + module procedure lookup_es3_des3_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface compute_qs_k - module procedure compute_qs_k_0d - module procedure compute_qs_k_1d - module procedure compute_qs_k_2d - module procedure compute_qs_k_3d + module procedure compute_qs_k_0d_r4 + module procedure compute_qs_k_0d_r8 + module procedure compute_qs_k_1d_r4 + module procedure compute_qs_k_1d_r8 + module procedure compute_qs_k_2d_r4 + module procedure compute_qs_k_2d_r8 + module procedure compute_qs_k_3d_r4 + module procedure compute_qs_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface compute_mrs_k - module procedure compute_mrs_k_0d - module procedure compute_mrs_k_1d - module procedure compute_mrs_k_2d - module procedure compute_mrs_k_3d - end interface + module procedure compute_mrs_k_0d_r4 + module procedure compute_mrs_k_0d_r8 + module procedure compute_mrs_k_1d_r4 + module procedure compute_mrs_k_1d_r8 + module procedure compute_mrs_k_2d_r4 + module procedure compute_mrs_k_2d_r8 + module procedure compute_mrs_k_3d_r4 + module procedure compute_mrs_k_3d_r8 + end interface compute_mrs_k !> @addtogroup sat_vapor_pres_k_mod !> @{ - real :: dtres, tepsl, tminl, dtinvl + real(kind=r8_kind) :: dtres, tepsl, tminl, dtinvl integer :: table_siz - real, dimension(:), allocatable :: TABLE ! sat vapor pres (es) - real, dimension(:), allocatable :: DTABLE ! first derivative of es - real, dimension(:), allocatable :: D2TABLE ! second derivative of es - real, dimension(:), allocatable :: TABLE2 ! sat vapor pres (es) - real, dimension(:), allocatable :: DTABLE2 ! first derivative of es - real, dimension(:), allocatable :: D2TABLE2 ! second derivative of es - real, dimension(:), allocatable :: TABLE3 ! sat vapor pres (es) - real, dimension(:), allocatable :: DTABLE3 ! first derivative of es - real, dimension(:), allocatable :: D2TABLE3 ! second derivative of es + real(kind=r8_kind), dimension(:), allocatable :: TABLE ! sat vapor pres (es) + real(kind=r8_kind), dimension(:), allocatable :: DTABLE ! first derivative of es + real(kind=r8_kind), dimension(:), allocatable :: D2TABLE ! second derivative of es + real(kind=r8_kind), dimension(:), allocatable :: TABLE2 ! sat vapor pres (es) + real(kind=r8_kind), dimension(:), allocatable :: DTABLE2 ! first derivative of es + real(kind=r8_kind), dimension(:), allocatable :: D2TABLE2 ! second derivative of es + real(kind=r8_kind), dimension(:), allocatable :: TABLE3 ! sat vapor pres (es) + real(kind=r8_kind), dimension(:), allocatable :: DTABLE3 ! first derivative of es + real(kind=r8_kind), dimension(:), allocatable :: D2TABLE3 ! second derivative of es logical :: use_exact_qs logical :: module_is_initialized = .false. contains - subroutine sat_vapor_pres_init_k(table_size, tcmin, tcmax, TFREEZE, HLV, RVGAS, ES0, err_msg, & - use_exact_qs_input, do_simple, & - construct_table_wrt_liq, & - construct_table_wrt_liq_and_ice, & - teps, tmin, dtinv) - -! This routine has been generalized to return tables for any temperature range and resolution - - integer, intent(in) :: table_size - real, intent(in) :: tcmin ! TABLE(1) = sat vapor pressure at temperature tcmin (deg C) - real, intent(in) :: tcmax ! TABLE(table_size) = sat vapor pressure at temperature tcmax (deg C) - real, intent(in) :: TFREEZE, HLV, RVGAS, ES0 - logical, intent(in) :: use_exact_qs_input, do_simple - logical, intent(in) :: construct_table_wrt_liq - logical, intent(in) :: construct_table_wrt_liq_and_ice - character(len=*), intent(out) :: err_msg - real, intent(out), optional :: teps, tmin, dtinv - -! increment used to generate derivative table - real, dimension(3) :: tem(3), es(3) - real :: hdtinv, tinrc, tfact - integer :: i - - err_msg = '' - - if (module_is_initialized) return - - if(allocated(TABLE) .or. allocated(DTABLE) .or. allocated(D2TABLE)) then - err_msg = 'Attempt to allocate sat vapor pressure tables when already allocated' - return - else - allocate(TABLE(table_size), DTABLE(table_size), D2TABLE(table_size)) - endif - - if (construct_table_wrt_liq) then - if(allocated(TABLE2) .or. allocated(DTABLE2) .or. allocated(D2TABLE2)) then - err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' - return - else - allocate(TABLE2(table_size), DTABLE2(table_size), D2TABLE2(table_size)) - endif - endif - - if (construct_table_wrt_liq_and_ice) then - if(allocated(TABLE3) .or. allocated(DTABLE3) .or. allocated(D2TABLE3)) then - err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' - return - else - allocate(TABLE3(table_size), DTABLE3(table_size), D2TABLE3(table_size)) - endif - endif - - table_siz = table_size - dtres = (tcmax - tcmin)/real(table_size-1) - tminl = real(tcmin)+TFREEZE ! minimum valid temp in table - dtinvl = 1./dtres - tepsl = .5*dtres - tinrc = .1*dtres - if(present(teps )) teps =tepsl - if(present(tmin )) tmin =tminl - if(present(dtinv)) dtinv=dtinvl - -! To be able to compute tables for any temperature range and resolution, -! and at the same time exactly reproduce answers from memphis revision, -! it is necessary to compute ftact differently than it is in memphis. - tfact = 5.0*dtinvl - - hdtinv = dtinvl*0.5 - -! compute es tables from tcmin to tcmax -! estimate es derivative with small +/- difference - - if (do_simple) then - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - TABLE(i) = ES0*610.78*exp(-hlv/rvgas*(1./tem(1) - 1./tfreeze)) - DTABLE(i) = hlv*TABLE(i)/rvgas/tem(1)**2. - enddo - - else - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - tem(2) = tem(1)-tinrc - tem(3) = tem(1)+tinrc - es = compute_es_k (tem, TFREEZE) - TABLE(i) = es(1) - DTABLE(i) = (es(3)-es(2))*tfact - enddo - - endif !if (do_simple) - -! compute one-half second derivative using centered differences -! differencing des values in the table - - do i = 2, table_size-1 - D2TABLE(i) = 0.25*dtinvl*(DTABLE(i+1)-DTABLE(i-1)) - enddo - ! one-sided derivatives at boundaries - - D2TABLE(1) = 0.50*dtinvl*(DTABLE(2)-DTABLE(1)) - - D2TABLE(table_size) = 0.50*dtinvl*& - (DTABLE(table_size)-DTABLE(table_size-1)) - - if (construct_table_wrt_liq) then -! compute es tables from tcmin to tcmax -! estimate es derivative with small +/- difference - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - tem(2) = tem(1)-tinrc - tem(3) = tem(1)+tinrc -! pass in flag to force all values to be wrt liquid - es = compute_es_liq_k (tem, TFREEZE) - TABLE2(i) = es(1) - DTABLE2(i) = (es(3)-es(2))*tfact - enddo - -! compute one-half second derivative using centered differences -! differencing des values in the table - - do i = 2, table_size-1 - D2TABLE2(i) = 0.25*dtinvl*(DTABLE2(i+1)-DTABLE2(i-1)) - enddo -! one-sided derivatives at boundaries - - D2TABLE2(1) = 0.50*dtinvl*(DTABLE2(2)-DTABLE2(1)) - - D2TABLE2(table_size) = 0.50*dtinvl*& - (DTABLE2(table_size)-DTABLE2(table_size-1)) - endif - - - if (construct_table_wrt_liq_and_ice) then -! compute es tables from tcmin to tcmax -! estimate es derivative with small +/- difference - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - tem(2) = tem(1)-tinrc - tem(3) = tem(1)+tinrc -! pass in flag to force all values to be wrt liquid - es = compute_es_liq_ice_k (tem, TFREEZE) - TABLE3(i) = es(1) - DTABLE3(i) = (es(3)-es(2))*tfact - enddo - -! compute one-half second derivative using centered differences -! differencing des values in the table - - do i = 2, table_size-1 - D2TABLE3(i) = 0.25*dtinvl*(DTABLE3(i+1)-DTABLE3(i-1)) - enddo -! one-sided derivatives at boundaries - - D2TABLE3(1) = 0.50*dtinvl*(DTABLE3(2)-DTABLE3(1)) - - D2TABLE3(table_size) = 0.50*dtinvl*& - (DTABLE3(table_size)-DTABLE3(table_size-1)) - endif - - use_exact_qs = use_exact_qs_input - module_is_initialized = .true. - - end subroutine sat_vapor_pres_init_k - -!####################################################################### - - function compute_es_k(tem, TFREEZE) result (es) - real, intent(in) :: tem(:), TFREEZE - real :: es(size(tem,1)) - - real :: x, esice, esh2o, TBASW, TBASI - integer :: i - real, parameter :: ESBASW = 101324.60 - real, parameter :: ESBASI = 610.71 - - TBASW = TFREEZE+100. - TBASI = TFREEZE - - do i = 1, size(tem) - -! compute es over ice - - if (tem(i) < TBASI) then - x = -9.09718*(TBASI/tem(i)-1.0) - 3.56654*log10(TBASI/tem(i)) & - +0.876793*(1.0-tem(i)/TBASI) + log10(ESBASI) - esice =10.**(x) - else - esice = 0. - endif - -! compute es over water greater than -20 c. -! values over 100 c may not be valid -! see smithsonian meteorological tables page 350. - - if (tem(i) > -20.+TBASI) then - x = -7.90298*(TBASW/tem(i)-1.0) + 5.02808*log10(TBASW/tem(i)) & - -1.3816e-07*(10.0**((1.0-tem(i)/TBASW)*11.344)-1.0) & - +8.1328e-03*(10.0**((TBASW/tem(i)-1.0)*(-3.49149))-1.0) & - +log10(ESBASW) - esh2o = 10.**(x) - else - esh2o = 0. - endif - -! derive blended es over ice and supercooled water between -20c and 0c - - if (tem(i) <= -20.+TBASI) then - es(i) = esice - else if (tem(i) >= TBASI) then - es(i) = esh2o - else - es(i) = 0.05*((TBASI-tem(i))*esice + (tem(i)-TBASI+20.)*esh2o) - endif - - enddo - - end function compute_es_k - -!####################################################################### - - function compute_es_liq_k(tem, TFREEZE) result (es) - real, intent(in) :: tem(:), TFREEZE - real :: es(size(tem,1)) - - real :: x, esh2o, TBASW - integer :: i - real, parameter :: ESBASW = 101324.60 - - TBASW = TFREEZE+100. - - do i = 1, size(tem) - - -! compute es over water for all temps. -! values over 100 c may not be valid -! see smithsonian meteorological tables page 350. - - x = -7.90298*(TBASW/tem(i)-1.0) + 5.02808*log10(TBASW/tem(i)) & - -1.3816e-07*(10.0**((1.0-tem(i)/TBASW)*11.344)-1.0) & - +8.1328e-03*(10.0**((TBASW/tem(i)-1.0)*(-3.49149))-1.0) & - +log10(ESBASW) - esh2o = 10.**(x) - - - es(i) = esh2o - - enddo - - end function compute_es_liq_k - -!####################################################################### - - function compute_es_liq_ice_k(tem, TFREEZE) result (es) - real, intent(in) :: tem(:), TFREEZE - real :: es(size(tem,1)) - - real :: x, TBASW, TBASI - integer :: i - real, parameter :: ESBASW = 101324.60 - real, parameter :: ESBASI = 610.71 - - TBASW = TFREEZE+100. - TBASI = TFREEZE - - do i = 1, size(tem) - - if (tem(i) < TBASI) then - -! compute es over ice - - x = -9.09718*(TBASI/tem(i)-1.0) - 3.56654*log10(TBASI/tem(i)) & - +0.876793*(1.0-tem(i)/TBASI) + log10(ESBASI) - es(i) =10.**(x) - else - -! compute es over water -! values over 100 c may not be valid -! see smithsonian meteorological tables page 350. - - x = -7.90298*(TBASW/tem(i)-1.0) + 5.02808*log10(TBASW/tem(i)) & - -1.3816e-07*(10.0**((1.0-tem(i)/TBASW)*11.344)-1.0) & - +8.1328e-03*(10.0**((TBASW/tem(i)-1.0)*(-3.49149))-1.0) & - +log10(ESBASW) - es(i) = 10.**(x) - endif - - enddo - - end function compute_es_liq_ice_k - -!####################################################################### - - subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in), dimension(:,:,:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out), dimension(:,:,:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:,:,:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:,:,:), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:,:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use - !! when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:,:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use - !! when called with r8 arguments - integer :: i, j, k - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1), size(temp,2), size(temp,3))) - allocate(desat_r4(size(temp,1), size(temp,2), size(temp,3))) - allocate(denom_r4(size(temp,1), size(temp,2), size(temp,3))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1), size(temp,2), size(temp,3))) - allocate(desat_r8(size(temp,1), size(temp,2), size(temp,3))) - allocate(denom_r8(size(temp,1), size(temp,2), size(temp,3))) - end select - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do k=1,size(qs,3) - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r4(i,j,k) > 0.0_r4_kind) then - qs(i,j,k) = real(eps, kind=r4_kind)*esloc_r4(i,j,k)/denom_r4(i,j,k) - else - qs(i,j,k) = real(eps, kind=r4_kind) - endif - end do - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do k=1,size(qs,3) - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r8(i,j,k) > 0.0) then - qs(i,j,k) = eps*esloc_r8(i,j,k)/denom_r8(i,j,k) - else - qs(i,j,k) = eps - endif - end do - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select - - end subroutine compute_qs_k_3d - -!####################################################################### - - subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in), dimension(:,:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out), dimension(:,:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:,:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:,:), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use - !! when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use - !! when called with r8 arguments - integer :: i, j - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1), size(temp,2))) - allocate(desat_r4(size(temp,1), size(temp,2))) - allocate(denom_r4(size(temp,1), size(temp,2))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1), size(temp,2))) - allocate(desat_r8(size(temp,1), size(temp,2))) - allocate(denom_r8(size(temp,1), size(temp,2))) - end select - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r4(i,j) > 0.0_r4_kind) then - qs(i,j) = real(eps, kind=r4_kind)*esloc_r4(i,j)/denom_r4(i,j) - else - qs(i,j) = real(eps, kind=r4_kind) - endif - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r8(i,j) > 0.0) then - qs(i,j) = eps*esloc_r8(i,j)/denom_r8(i,j) - else - qs(i,j) = eps - endif - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select - - end subroutine compute_qs_k_2d - -!####################################################################### - - subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in), dimension(:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out),dimension(:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:),optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use - !! when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use - !! when called with r8 arguments - integer :: i - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1))) - allocate(desat_r4(size(temp,1))) - allocate(denom_r4(size(temp,1))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1))) - allocate(desat_r8(size(temp,1))) - allocate(denom_r8(size(temp,1))) - end select - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do i=1,size(qs,1) - if (denom_r4(i) > 0.0_r4_kind) then - qs(i) = real(eps, kind=r4_kind)*esloc_r4(i)/denom_r4(i) - else - qs(i) = real(eps, kind=r4_kind) - endif - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do i=1,size(qs,1) - if (denom_r8(i) > 0.0) then - qs(i) = eps*esloc_r8(i)/denom_r8(i) - else - qs(i) = eps - endif - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select - - end subroutine compute_qs_k_1d - -!####################################################################### - - subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out) :: qs - integer, intent(out) :: nbad - class(*), intent(in), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments - real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - if (denom_r4 > 0.0_r4_kind) then - qs = real(eps, kind=r4_kind)*esloc_r4/denom_r4 - else - qs = real(eps, kind=r4_kind) - endif - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - if (denom_r8 > 0.0) then - qs = eps*esloc_r8/denom_r8 - else - qs = eps - endif - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - end subroutine compute_qs_k_0d - -!####################################################################### - -!####################################################################### - - subroutine compute_mrs_k_3d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in), dimension(:,:,:) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out), dimension(:,:,:) :: mrs - integer, intent(out) :: nbad - real, intent(in), dimension(:,:,:), optional :: mr - real, intent(in), optional :: hc - real, intent(out), dimension(:,:,:), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real, dimension(size(temp,1), size(temp,2), size(temp,3)) :: & - esloc, desat, denom - integer :: i, j, k - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - do k=1,size(mrs,3) - do j=1,size(mrs,2) - do i=1,size(mrs,1) - if (denom(i,j,k) > 0.0) then - mrs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) - else - mrs(i,j,k) = eps - endif - end do - end do - end do - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_3d - -!####################################################################### - - subroutine compute_mrs_k_2d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in), dimension(:,:) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out), dimension(:,:) :: mrs - integer, intent(out) :: nbad - real, intent(in), dimension(:,:), optional :: mr - real, intent(in), optional :: hc - real, intent(out), dimension(:,:), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real, dimension(size(temp,1), size(temp,2)) :: esloc, desat, denom - integer :: i, j - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - do j=1,size(mrs,2) - do i=1,size(mrs,1) - if (denom(i,j) > 0.0) then - mrs(i,j) = eps*esloc(i,j)/denom(i,j) - else - mrs(i,j) = eps - endif - end do - end do - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_2d - -!####################################################################### - - subroutine compute_mrs_k_1d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in), dimension(:) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out), dimension(:) :: mrs - integer, intent(out) :: nbad - real, intent(in), dimension(:), optional :: mr - real, intent(in), optional :: hc - real, intent(out), dimension(:), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real, dimension(size(temp,1)) :: esloc, desat, denom - integer :: i - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - do i=1,size(mrs,1) - if (denom(i) > 0.0) then - mrs(i) = eps*esloc(i)/denom(i) - else - mrs(i) = eps - endif - end do - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_1d - -!####################################################################### - - subroutine compute_mrs_k_0d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out) :: mrs - integer, intent(out) :: nbad - real, intent(in), optional :: mr - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real :: esloc, desat, denom - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - if (denom > 0.0) then - mrs = eps*esloc/denom - else - mrs = eps - endif - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_0d - - - -!####################################################################### - - subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select - - end subroutine lookup_es_des_k_3d - -!####################################################################### - - subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - end select - end select - end select - - end subroutine lookup_es_des_k_2d - -!####################################################################### - - subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - end select - end select - end select - - end subroutine lookup_es_des_k_1d - -!####################################################################### - - subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es_des_k_0d - -!####################################################################### - - subroutine lookup_es_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_es_k_3d - -!####################################################################### - - subroutine lookup_des_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_des_k_3d - -!####################################################################### - subroutine lookup_des_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - end select - end select - - end subroutine lookup_des_k_2d -!####################################################################### - subroutine lookup_es_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - endif - enddo - enddo - end select - end select - - end subroutine lookup_es_k_2d -!####################################################################### - subroutine lookup_des_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - end select - end select - - end subroutine lookup_des_k_1d -!####################################################################### - subroutine lookup_es_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) - endif - enddo - end select - end select - - end subroutine lookup_es_k_1d -!####################################################################### - subroutine lookup_des_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_des_k_0d -!####################################################################### - subroutine lookup_es_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es_k_0d -!####################################################################### - - subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select - - end subroutine lookup_es2_des2_k_3d - -!####################################################################### - - subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - end select - end select - end select - - end subroutine lookup_es2_des2_k_2d - -!####################################################################### - - subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - end select - end select - end select - - end subroutine lookup_es2_des2_k_1d - -!####################################################################### - - subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es2_des2_k_0d - -!####################################################################### - - subroutine lookup_es2_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_es2_k_3d - -!####################################################################### - - subroutine lookup_des2_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_des2_k_3d - !####################################################################### - subroutine lookup_des2_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - end select - end select - - end subroutine lookup_des2_k_2d -!####################################################################### - subroutine lookup_es2_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - endif - enddo - enddo - end select - end select - - end subroutine lookup_es2_k_2d -!####################################################################### - subroutine lookup_des2_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - end select - end select - - end subroutine lookup_des2_k_1d -!####################################################################### - subroutine lookup_es2_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) - endif - enddo - end select - end select - - end subroutine lookup_es2_k_1d -!####################################################################### - subroutine lookup_des2_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_des2_k_0d -!####################################################################### - subroutine lookup_es2_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es2_k_0d -!####################################################################### - -!####################################################################### - - subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select - - end subroutine lookup_es3_des3_k_3d - -!####################################################################### - - subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - end select - end select - end select - - end subroutine lookup_es3_des3_k_2d - -!####################################################################### - - subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - end select - end select - end select - - end subroutine lookup_es3_des3_k_1d - -!####################################################################### - - subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es3_des3_k_0d - !####################################################################### - subroutine lookup_es3_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_es3_k_3d - -!####################################################################### - - subroutine lookup_des3_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_des3_k_3d - -!####################################################################### - subroutine lookup_des3_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - end select - end select +#include "sat_vapor_pres_k_r4.fh" +#include "sat_vapor_pres_k_r8.fh" - end subroutine lookup_des3_k_2d -!####################################################################### - subroutine lookup_es3_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - endif - enddo - enddo - end select - end select - - end subroutine lookup_es3_k_2d -!####################################################################### - subroutine lookup_des3_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - end select - end select - - end subroutine lookup_des3_k_1d -!####################################################################### - subroutine lookup_es3_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) - endif - enddo - end select - end select - - end subroutine lookup_es3_k_1d -!####################################################################### - subroutine lookup_des3_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_des3_k_0d -!####################################################################### - subroutine lookup_es3_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es3_k_0d -!####################################################################### end module sat_vapor_pres_k_mod !> @} ! close documentation grouping diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 4472863ad2..f37c4f984a 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -26,7 +26,7 @@ ACLOCAL_AMFLAGS = -I m4 # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = coupler diag_manager data_override exchange monin_obukhov drifters \ mosaic interpolator fms mpp mpp_io time_interp time_manager \ -horiz_interp field_manager axis_utils affinity fms2_io parser string_utils +horiz_interp field_manager axis_utils affinity fms2_io parser string_utils sat_vapor_pres # testing utility scripts to distribute EXTRA_DIST = test-lib.sh.in intel_coverage.sh.in tap-driver.sh diff --git a/test_fms/axis_utils/Makefile.am b/test_fms/axis_utils/Makefile.am index ffaa77421d..3db495ecd6 100644 --- a/test_fms/axis_utils/Makefile.am +++ b/test_fms/axis_utils/Makefile.am @@ -29,10 +29,16 @@ AM_CPPFLAGS = -I$(MODDIR) LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_axis_utils +check_PROGRAMS = \ + test_axis_utils_r4 \ + test_axis_utils_r8 # This is the source code for the test. -test_axis_utils_SOURCES = test_axis_utils.F90 +test_axis_utils_r4_SOURCES = test_axis_utils.F90 +test_axis_utils_r8_SOURCES = test_axis_utils.F90 + +test_axis_utils_r4_CPPFLAGS = $(AM_CPPFLAGS) -DAU_TEST_KIND_=r4_kind +test_axis_utils_r8_CPPFLAGS = $(AM_CPPFLAGS) -DAU_TEST_KIND_=r8_kind TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/axis_utils/test_axis_utils.F90 b/test_fms/axis_utils/test_axis_utils.F90 index d9e9c8477f..aac74de010 100644 --- a/test_fms/axis_utils/test_axis_utils.F90 +++ b/test_fms/axis_utils/test_axis_utils.F90 @@ -19,148 +19,776 @@ program test_axis_utils -use fms_mod, only : fms_init, fms_end, check_nml_error -use mpp_mod, only : mpp_sync, mpp_pe, mpp_root_pe, mpp_error, FATAL, stdout, & - mpp_get_current_pelist, mpp_npes -use mpp_mod, only : input_nml_file -use axis_utils2_mod, only : axis_edges -use fms2_io_mod, only : open_file, close_file, write_data, register_axis, register_field, & - FmsNetcdfFile_t, register_variable_attribute -use platform_mod, only : r8_kind +use fms_mod, only : fms_init, fms_end, lowercase +use fms2_io_mod, only: FmsNetcdfFile_t, open_file, close_file, register_axis, register_field, & + & register_variable_attribute, write_data +use platform_mod, only: r4_kind, r8_kind +use mpp_mod, only: mpp_error, fatal, stderr +use fms_string_utils_mod, only: string, stringify +use axis_utils2_mod implicit none -type data_type - real(kind=r8_kind) :: var(10) !< Axis data - real(kind=r8_kind) :: var_edges(2,10) !< The boundaries of the axis data - real(kind=r8_kind) :: answers(11) !< The expected result -end type data_type +type GetAxisCartTest_t + type(FmsNetcdfFile_t) :: fileobj + type(GetAxisCartTestCase_t), pointer :: test0, test1 +end type -type(data_type) :: data_in !< Data used to create the netcdf file -integer, allocatable :: pes(:) !< List of pes -type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj +type GetAxisCartTestCase_t + character(:), allocatable :: var + character(1) :: cart + type(GetAxisCartTestCase_t), pointer :: next => NULL() +end type -real(kind=r8_kind) :: answers(11) !< Results obtained from the axis_edges call +integer, parameter :: k = AU_TEST_KIND_ +real(k), parameter :: pi = 4._k * atan(1._k) + +integer :: i +character(100) :: arg call fms_init -!< Get the current pelist -allocate(pes(mpp_npes())) -call mpp_get_current_pelist(pes) +do i=1,command_argument_count() + call get_command_argument(i, arg) -call set_data(data_in) -call create_input_files(data_in) + select case (arg) + case ('--get-axis-modulo') + print "(A)", "Testing get_axis_modulo" + call test_get_axis_modulo -!< Test calls to axis_edges -if ( .not. open_file(fileobj, "test_axis_utils.nc", "read", pelist=pes)) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to read") -endif - -!< Case 1: Here the variable "axis" in the file does not have the attribute "bounds" or "edges", so -!! it calculates them from the data in "axis" -answers = 0.0 -call axis_edges(fileobj, "axis", answers) -call compare_answers(answers, data_in%answers, "1") - -!< Case 2: Here the variable "axis_with_bounds" in the file has the attribute -!! "bounds", so the data is read from the variable "bounds" -answers = 0.0 -call axis_edges(fileobj, "axis_with_bounds", answers) -call compare_answers(answers, data_in%answers, "2") - -!< Case 3: Here the variable "axis_with_edges" in the file has the attribute -!"edges", so the data is read from the variable "edges" -answers = 0.0 -call axis_edges(fileobj, "axis_with_edges", answers) -call compare_answers(answers, data_in%answers, "3") - -!< Case 4: Here the flag "reproduce_null_char_bug_flag" is turned on, so the -!! edges are calculated from the data in axis because edges has a null character -!! in the end -answers = 0.0 -call axis_edges(fileobj, "axis_with_edges", answers, reproduce_null_char_bug_flag=.true.) -call compare_answers(answers, data_in%answers, "4") - -call close_file(fileobj) -deallocate(pes) + case ('--get-axis-modulo-times') + print "(A)", "Testing get_axis_modulo_times" + call test_get_axis_modulo_times + + case ('--get-axis-cart') + print "(A)", "Testing get_axis_cart" + call test_get_axis_cart + + case ('--lon-in-range') + print "(A)", "Testing lon_in_range" + call test_lon_in_range + + case ('--frac-index') + print "(A)", "Testing frac_index" + call test_frac_index + + case ('--frac-index-fail') + print "(A)", "Testing frac_index (FAILURE)" + call test_frac_index_fail + + case ('--nearest-index') + print "(A)", "Testing nearest_index" + call test_nearest_index + + case ('--nearest-index-fail') + print "(A)", "Testing nearest_index (FAILURE)" + call test_nearest_index_fail + + case ('--axis-edges') + print "(A)", "Testing axis_edges" + call test_axis_edges + + case ('--tranlon') + print "(A)", "Testing tranlon" + call test_tranlon + + case ('--interp-1d-1d') + print "(A)", "Testing interp_1d_1d" + call test_interp_1d_1d + + case ('--interp-1d-2d') + print "(A)", "Testing interp_1d_2d" + call test_interp_1d_2d + + case ('--interp-1d-3d') + print "(A)", "Testing interp_1d_3d" + call test_interp_1d_3d + + case default + write(stderr(),"(A)") "Unrecognized command line option: " // trim(arg) + end select +enddo call fms_end contains -!> @brief Compares the values of two arrays -subroutine compare_answers(answers_in, answers_expected, test_case) -real(kind=r8_kind), intent(in) :: answers_in(:) !< Answer calculated -real(kind=r8_kind), intent(in) :: answers_expected(:) !< Answer expected -character(1), intent(in) :: test_case !< String indicating the case number +! Status: TODO +! function get_axis_modulo(fileobj, axisname) +subroutine test_get_axis_modulo + type(FmsNetcdfFile_t) :: fileobj + + write(stderr(), "(A)") "Warning: get_axis_modulo unit test not yet implemented" +end subroutine -integer :: i !< For do loop +! Status: TODO +! function get_axis_modulo_times(fileobj, axisname, tbeg, tend) +subroutine test_get_axis_modulo_times + type(FmsNetcdfFile_t) :: fileobj -do i = 1, size(answers_expected,1) - if(answers_in(i) .ne. answers_expected(i)) then - print *, "i=", i, " Answer in: ", answers_in(i), " Answer expected ", answers_expected(i) - call mpp_error(FATAL, "axis_edges case"//trim(test_case)//": Answers are not correct") - endif -enddo -end subroutine compare_answers + write(stderr(), "(A)") "Warning: get_axis_modulo_times unit test not yet implemented" +end subroutine + +subroutine test_get_axis_cart + type(GetAxisCartTest_t) :: test + type(GetAxisCartTestCase_t), pointer :: test_nonexistent_var + character(:), allocatable :: var_name, attr_name, attr_value + integer :: i, j + + character(*), parameter, dimension(*) :: & + & special_axis_names_x = [character(12) :: "lon", "x", "degrees_e", "degrees_east", "degreese"], & + & special_axis_names_y = [character(13) :: "lat", "y", "degrees_n", "degrees_north", "degreesn"], & + & special_axis_names_z = [character(6) :: "depth", "height", "z", "cm", "m", "pa", "hpa"], & + & special_axis_names_t = [character(4) :: "time", "t", "sec", "min", "hou", "day", "mon", "yea"], & + & attr_names = [character(14) :: "cartesian_axis", "axis"], & + & xyzt_uc = ["X", "Y", "Z", "T"] + + call open_netcdf_w(test%fileobj) + call register_axis(test%fileobj, "dim1", 1) + + ! Check a variable which does not exist + + allocate(test_nonexistent_var) + test_nonexistent_var%var = "does_not_exist" + test_nonexistent_var%cart = "N" + + test%test0 => test_nonexistent_var + test%test1 => test_nonexistent_var + + ! Check a variable which exists, but which has neither a "cartesian_axis" nor an "axis" attribute. + var_name = "exists_no_attributes" + call get_axis_cart_test_add(test, var_name, "N") + + do i=1,size(attr_names) + attr_name = trim(attr_names(i)) + + ! Check an unknown value on a "cartesian_axis" or "axis" attribute. + ! TODO: This test fails. It should be uncommented if/when get_axis_cart's behavior is fixed. + + !attr_value = "unexpected" + !var_name = attr_name // "_attr_value_" // attr_value + !call get_axis_cart_test_add(test, var_name, "N") + !call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + + do j=1,size(xyzt_uc) + ! Check upper-case "axis" attributes" + attr_value = xyzt_uc(j) + var_name = attr_name // "_attr_value_" // attr_value + call get_axis_cart_test_add(test, var_name, xyzt_uc(j)) + call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + + ! Check lower-case "axis" attributes" + attr_value = lowercase(xyzt_uc(j)) + var_name = attr_name // "_attr_value_" // attr_value + call get_axis_cart_test_add(test, var_name, xyzt_uc(j)) + call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + enddo + enddo + + call test_special_axis_names(test, special_axis_names_x, "X") + call test_special_axis_names(test, special_axis_names_y, "Y") + call test_special_axis_names(test, special_axis_names_z, "Z") + call test_special_axis_names(test, special_axis_names_t, "T") + + call close_file(test%fileobj) + + call get_axis_cart_tests_run(test) +end subroutine -!> @brief Sets the values of the data_type to be use to write the file, and to -!! compare answers -subroutine set_data(data_in) -type(data_type), intent(out) :: data_in !< data_type to set the expected values to +subroutine get_axis_cart_test_add(test, var_name, cart) + type(GetAxisCartTest_t), intent(inout) :: test + type(GetAxisCartTestCase_t), pointer :: test_case + character(*), intent(in) :: var_name + character(1), intent(in) :: cart + character(:), allocatable :: kind_str -integer :: i !< For do loop + if (k .eq. r4_kind) then + kind_str = "float" + else + kind_str = "double" + endif -do i=1,10 - data_in%var(i) = real(i, kind=r8_kind)-0.5_r8_kind + call register_field(test%fileobj, var_name, kind_str, dimensions=["dim1"]) - data_in%var_edges(1,i) = real(i-1, kind=r8_kind) - data_in%var_edges(2,i) = real(i, kind=r8_kind) + allocate(test_case) + test_case%var = var_name + test_case%cart = cart - data_in%answers(i) = real(i-1, kind=r8_kind) -enddo + test%test1%next => test_case + test%test1 => test_case +end subroutine + +subroutine get_axis_cart_tests_run(test) + type(GetAxisCartTest_t), intent(inout) :: test + type(GetAxisCartTestCase_t), pointer :: test_case, next + character(1) :: cart_test + integer :: i -data_in%answers(11) = real(10, kind=r8_kind) + call open_netcdf_r(test%fileobj) + test_case => test%test0 + + do while (associated(test_case)) + cart_test = " " + call get_axis_cart(test%fileobj, test_case%var, cart_test) + + if (cart_test .ne. test_case%cart) then + write(stderr(), "(A)") "get_axis_cart result for variable '" // test_case%var // "': " // cart_test + write(stderr(), "(A)") "Expected result: " // test_case%cart + call mpp_error(FATAL, "get_axis_cart unit test failed") + endif + + next => test_case%next + deallocate(test_case) + test_case => next + enddo + + call close_file(test%fileobj) end subroutine -!> @brief Creates a netcdf file to test the different test cases of -!!"axis_edges" -subroutine create_input_files(data_in) -type(data_type), intent(in) :: data_in !< data_type containing the values to be added to the file +subroutine test_special_axis_names(test, special_axis_names, ret_expected) + type(GetAxisCartTest_t), intent(inout) :: test + character(*), intent(in) :: special_axis_names(:), ret_expected + character(:), allocatable :: var_name + integer :: i + + do i=1,size(special_axis_names) + var_name = trim(special_axis_names(i)) + call get_axis_cart_test_add(test, var_name, ret_expected) + enddo +end subroutine + +subroutine test_lon_in_range + real(k), parameter :: eps_big = 1e-3_k, eps_tiny = 1e-5_k + real(k), parameter :: pi_plus_360 = 360._k + pi + + ! Test some cases where no translation is needed + call lon_in_range_assert(0._k, 0._k, 0._k) + call lon_in_range_assert(1._k, 0._k, 1._k) + call lon_in_range_assert(350._k, 0._k, 350._k) + call lon_in_range_assert(1._k, 1._k, 1._k) + call lon_in_range_assert(350._k, 1._k, 350._k) + call lon_in_range_assert(359._k, 0._k, 359._k) + call lon_in_range_assert(359._k, 1._k, 359._k) + call lon_in_range_assert(pi, 0._k, pi) + + ! Test up-translation + call lon_in_range_assert(-2._k, -1._k, 358._k) + call lon_in_range_assert(-2._k, 0._k, 358._k) + call lon_in_range_assert(-2._k, 5._k, 358._k) + call lon_in_range_assert(-1._k, 0._k, 359._k) + call lon_in_range_assert(-1._k, 5._k, 359._k) + call lon_in_range_assert(0._k, 5._k, 360._k) + call lon_in_range_assert(1._k, 5._k, 361._k) + call lon_in_range_assert(-pi, 0._k, 360._k - pi) + + ! Test down-translation + call lon_in_range_assert(359._k, -1._k, -1._k) + call lon_in_range_assert(360._k, -1._k, 0._k) + call lon_in_range_assert(360._k, 0._k, 0._k) + call lon_in_range_assert(361._k, -1._k, 1._k) + call lon_in_range_assert(361._k, 0._k, 1._k) + call lon_in_range_assert(362._k, -1._k, 2._k) + call lon_in_range_assert(362._k, 0._k, 2._k) + call lon_in_range_assert(pi_plus_360, 0._k, pi_plus_360 - 360._k) + + ! Test rounding behavior + call lon_in_range_assert(eps_tiny, 0._k, 0._k) + call lon_in_range_assert(eps_big, 0._k, eps_big) + call lon_in_range_assert(360._k - eps_tiny, 0._k, 0._k) + call lon_in_range_assert(360._k - eps_big, 0._k, 360._k - eps_big) +end subroutine + +subroutine lon_in_range_assert(lon, l_start, ret_expected) + real(k), intent(in) :: lon, l_start, ret_expected + real(k) :: ret_test + + ret_test = lon_in_range(lon, l_start) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "lon_in_range(" // string(lon) // ", " // string(l_start) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "lon_in_range unit test failed") + endif +end subroutine + +#define CALC_FRAC_INDEX_(i, v, values) real(i, k) + (v - values(i)) / (values(i + 1) - values(i)) + +subroutine test_frac_index + real(k) :: values(6), v, fi + integer :: i, n + real(k), parameter :: f10=.1_k, f25=.25_k, f50=.5_k, f99=.99_k + + values = [1._k, 2._k, 3._k, 5._k, 10._k, 11._k] + n = size(values) + + ! Test values outside of the input array + call frac_index_assert(real(values(1), k) - f50, values, -1._k) + call frac_index_assert(real(values(n), k) + f50, values, -1._k) + + ! Test the actual indices + do i=1,n + v = values(i) + call frac_index_assert(v, values, real(i, k)) + enddo + + ! Test the 10% point + do i=1,n-1 + v = values(i) + f10*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the 25% point + do i=1,n-1 + v = values(i) + f25*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the mid-point + do i=1,n-1 + v = values(i) + f50*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the 99% point + do i=1,n-1 + v = values(i) + f99*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo +end subroutine + +subroutine frac_index_assert(fval, arr, ret_expected) + real(k), intent(in) :: fval, arr(:), ret_expected + real(k) :: ret_test + + ret_test = frac_index(fval, arr) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "frac_index(" // string(fval) // ", " // stringify(arr) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "frac_index unit test failed") + endif +end subroutine + +! Test that frac_index fails with a non-monotonic array +subroutine test_frac_index_fail + real(k) :: values(5) + real(k) :: ret_test + + values = [1._k, 2._k, 4._k, 3._k, 5._k] + ret_test = frac_index(1.5_k, values) +end subroutine + +subroutine test_nearest_index + real(k) :: arr(5) + + arr = [5._k, 12._k, 20._k, 40._k, 100._k] + + ! Test values beyond array boundaries + call nearest_index_assert(4._k, arr, 1) + call nearest_index_assert(1000._k, arr, size(arr)) + + ! Test values actually in the array + call nearest_index_assert(5._k, arr, 1) + call nearest_index_assert(12._k, arr, 2) + call nearest_index_assert(20._k, arr, 3) + call nearest_index_assert(40._k, arr, 4) + call nearest_index_assert(100._k, arr, 5) + + ! Test the intervals between array values + call nearest_index_assert(6._k, arr, 1) + call nearest_index_assert(11._k, arr, 2) + call nearest_index_assert(15._k, arr, 2) + call nearest_index_assert(18._k, arr, 3) + call nearest_index_assert(29._k, arr, 3) +end subroutine + +subroutine nearest_index_assert(val, arr, ret_expected) + real(k), intent(in) :: val, arr(:) + integer, intent(in) :: ret_expected + integer :: ret_test + + ret_test = nearest_index(val, arr) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "nearest_index(" // string(val) // ", " // stringify(arr) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "nearest_index unit test failed") + endif +end subroutine + +! Test that nearest_index fails with a non-monotonic array +subroutine test_nearest_index_fail + real(k) :: arr(5) + integer :: ret_test + + arr=[5._k, 12._k, 40._k, 20._k, 100._k] + ret_test = nearest_index(5._k, arr) +end subroutine + +subroutine test_axis_edges + real(k) :: data_in_var(10) + real(k) :: data_in_var_edges(2,10) + real(k) :: data_in_answers(11) + type(FmsNetcdfFile_t) :: fileobj + real(k) :: answers(11) + integer :: i + + do i=1,10 + data_in_var(i) = real(i, k) - 0.5_k + + data_in_var_edges(1,i) = real(i-1, k) + data_in_var_edges(2,i) = real(i, k) + + data_in_answers(i) = real(i-1, k) + enddo + + data_in_answers(11) = 10._k -type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj + call open_netcdf_w(fileobj) -if (mpp_pe() .eq. mpp_root_pe()) then - if ( .not. open_file(fileobj, "test_axis_utils.nc", "overwrite")) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to write") - endif + call register_axis(fileobj, "dim1", 10) + call register_axis(fileobj, "dim2", 2) - call register_axis(fileobj, "dim1", 10) - call register_axis(fileobj, "dim2", 2) + call register_field(fileobj, "axis", "double", dimensions=["dim1"]) - call register_field(fileobj, "axis", "double", dimensions=(/"dim1"/)) + call register_field(fileobj, "axis_with_bounds", "double", dimensions=["dim1"]) + call register_variable_attribute(fileobj, "axis_with_bounds", "bounds", "bounds", str_len=6) + call register_field(fileobj, "bounds", "double", dimensions=["dim2", "dim1"]) - call register_field(fileobj, "axis_with_bounds", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_bounds", "bounds", "bounds", str_len=6) - call register_field(fileobj, "bounds", "double", dimensions=(/"dim2", "dim1"/)) + call register_field(fileobj, "axis_with_edges", "double", dimensions=["dim1"]) + call register_variable_attribute(fileobj, "axis_with_edges", "edges", "edges"//char(0), str_len=6) + call register_field(fileobj, "edges", "double", dimensions=["dim2", "dim1"]) - call register_field(fileobj, "axis_with_edges", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_edges", "edges", "edges"//char(0), str_len=6) - call register_field(fileobj, "edges", "double", dimensions=(/"dim2", "dim1"/)) + call write_data(fileobj, "axis", data_in_var) + call write_data(fileobj, "axis_with_bounds", data_in_var) + call write_data(fileobj, "axis_with_edges", data_in_var) + call write_data(fileobj, "bounds", data_in_var_edges) + call write_data(fileobj, "edges", data_in_var_edges) - call write_data(fileobj, "axis", data_in%var) - call write_data(fileobj, "axis_with_bounds", data_in%var) - call write_data(fileobj, "axis_with_edges", data_in%var) - call write_data(fileobj, "bounds", data_in%var_edges) - call write_data(fileobj, "edges", data_in%var_edges) + call close_file(fileobj) - call close_file(fileobj) -endif + call open_netcdf_r(fileobj) -!< Wait for root_pe to catch up! -call mpp_sync() + !< Case 1: Here the variable "axis" in the file does not have the attribute "bounds" or "edges", so + !! it calculates them from the data in "axis" + answers = 0._k + call axis_edges(fileobj, "axis", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 1)") -end subroutine create_input_files + !< Case 2: Here the variable "axis_with_bounds" in the file has the attribute + !! "bounds", so the data is read from the variable "bounds" + answers = 0._k + call axis_edges(fileobj, "axis_with_bounds", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 2)") + + !< Case 3: Here the variable "axis_with_edges" in the file has the attribute + !"edges", so the data is read from the variable "edges" + answers = 0._k + call axis_edges(fileobj, "axis_with_edges", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 3)") + + !< Case 4: Here the flag "reproduce_null_char_bug_flag" is turned on, so the + !! edges are calculated from the data in axis because edges has a null character + !! in the end + answers = 0._k + call axis_edges(fileobj, "axis_with_edges", answers, reproduce_null_char_bug_flag=.true.) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 4)") + + call close_file(fileobj) +end subroutine + +subroutine test_tranlon + real(k), dimension(5) :: lon1, lon2, lon3 + + lon1 = [1._k, 2._k, 3._k, 4._k, 5._k] + lon2 = [2._k, 3._k, 4._k, 5._k, 361._k] + lon3 = [3._k, 4._k, 5._k, 361._k, 362._k] + + ! The first two cases fail due to tranlon's unexpected behavior when no elements are translated. + ! TODO: Uncomment these tests if/when tranlon's behavior is fixed. + + !call tranlon_assert(lon1, lon1, 0.0_k, 1) + !call tranlon_assert(lon1, lon1, 1.0_k, 1) + + call tranlon_assert(lon1, lon2, 1.5_k, 2) + call tranlon_assert(lon1, lon2, 2.0_k, 2) + call tranlon_assert(lon1, lon3, 2.001_k, 3) +end subroutine + +subroutine tranlon_assert(lon0, lon_expected, lon_start, istrt_expected) + real(k), intent(in) :: lon0(:), lon_expected(:), lon_start + integer, intent(in) :: istrt_expected + integer :: istrt_test, i + real(k) :: lon_test(size(lon0)) + character(:), allocatable :: test_name + + test_name = "tranlon(" // stringify(lon0) // ", " // string(lon_start) // ", istrt)" + + lon_test = lon0 + call tranlon(lon_test, lon_start, istrt_test) + call array_compare_1d(lon_test, lon_expected, test_name // " unit test failed") + + if (istrt_test.ne.istrt_expected) then + write(stderr(), "(A)") test_name // " returned erroneous istrt value: " // string(istrt_test) + write(stderr(), "(A)") "Expected istrt value: " // string(istrt_expected) + call mpp_error(FATAL, "tranlon unit test failed") + endif +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_1d test +subroutine test_interp_1d_1d + real(k) :: grid1(8), grid2(5), data1(8), data2(5) + + grid1 = [1._k, 2._k, 3._k, 4._k, 5._k, 6._k, 7._k, 8._k] + grid2 = [2._k, 3._k, 4._k, 5._k, 6._k] + data1 = [101._k, 102._k, 103._k, 104._k, 105._k, 106._k, 107._k, 108._k] + data2 = [102._k, 103._k, 104._k, 105._k, 106._k] + + call interp_1d_1d_assert(grid1, grid2, data1, data2, "linear") + call interp_1d_1d_assert(grid1, grid2, data1, data2, "cubic_spline") +end subroutine + +subroutine interp_1d_1d_assert(grid1, grid2, data1, data2_expected, method, yp1, yp2) + real(k), intent(in), dimension(:) :: grid1, grid2, data1, data2_expected + character(*), intent(in), optional :: method + real(k), intent(in), optional :: yp1, yp2 + real(k) :: data2_test(size(data2_expected)) + character(:), allocatable :: test_name + + test_name = "interp_1d_1d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2" + + if (present(method)) then + test_name = test_name // ", method=" // method + endif + + if (present(yp1)) then + test_name = test_name // ", yp1=" // string(yp1) + endif + + if (present(yp2)) then + test_name = test_name // ", yp2=" // string(yp2) + endif + + test_name = test_name // ")" + + call interp_1d(grid1, grid2, data1, data2_test, method, yp1, yp2) + call array_compare_1d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_2d test +subroutine test_interp_1d_2d + real(k) :: grid1(2,4), grid2(2,2), data1(2,4), data2(2,2) + + grid1(1,:) = [1._k, 2._k, 3._k, 4._k] + grid1(2,:) = [5._k, 6._k, 7._k, 8._k] + + grid2(1,:) = [2._k, 3._k] + grid2(2,:) = [6._k, 7._k] + + data1(1,:) = [101._k, 102._k, 103._k, 104._k] + data1(2,:) = [105._k, 106._k, 107._k, 108._k] + + data2(1,:) = [102._k, 103._k] + data2(2,:) = [106._k, 107._k] + + call interp_1d_2d_assert(grid1, grid2, data1, data2) +end subroutine + +subroutine interp_1d_2d_assert(grid1, grid2, data1, data2_expected) + real(k), intent(in), dimension(:,:) :: grid1, grid2, data1, data2_expected + real(k) :: data2_test(size(data2_expected,1), size(data2_expected,2)) + character(:), allocatable :: test_name + + test_name = "interp_1d_2d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2)" + + call interp_1d(grid1, grid2, data1, data2_test) + call array_compare_2d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_3d test +subroutine test_interp_1d_3d + real(k) :: grid1(2,2,4), grid2(2,2,2), data1(2,2,4), data2(2,2,2) + + grid1(1,1,:) = [1._k, 2._k, 3._k, 4._k] + grid1(1,2,:) = [5._k, 6._k, 7._k, 8._k] + grid1(2,1,:) = [21._k, 22._k, 23._k, 24._k] + grid1(2,2,:) = [25._k, 26._k, 27._k, 28._k] + + grid2(1,1,:) = [2._k, 3._k] + grid2(1,2,:) = [6._k, 7._k] + grid2(2,1,:) = [22._k, 23._k] + grid2(2,2,:) = [26._k, 27._k] + + data1(1,1,:) = [101._k, 102._k, 103._k, 104._k] + data1(1,2,:) = [105._k, 106._k, 107._k, 108._k] + data1(2,1,:) = [201._k, 202._k, 203._k, 204._k] + data1(2,2,:) = [205._k, 206._k, 207._k, 208._k] + + data2(1,1,:) = [102._k, 103._k] + data2(1,2,:) = [106._k, 107._k] + data2(2,1,:) = [202._k, 203._k] + data2(2,2,:) = [206._k, 207._k] + + call interp_1d_3d_assert(grid1, grid2, data1, data2) + call interp_1d_3d_assert(grid1, grid2, data1, data2, "linear") + call interp_1d_3d_assert(grid1, grid2, data1, data2, "cubic_spline") +end subroutine + +subroutine interp_1d_3d_assert(grid1, grid2, data1, data2_expected, method, yp1, yp2) + real(k), intent(in), dimension(:,:,:) :: grid1, grid2, data1, data2_expected + character(*), intent(in), optional :: method + real(k), intent(in), optional :: yp1, yp2 + real(k) :: data2_test(size(data2_expected,1), size(data2_expected,2), size(data2_expected,3)) + integer :: i,i2,i3 + character(:), allocatable :: test_name + + test_name = "interp_1d_3d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2" + + if (present(method)) then + test_name = test_name // ", method=" // method + endif + + if (present(yp1)) then + test_name = test_name // ", yp1=" // string(yp1) + endif + + if (present(yp2)) then + test_name = test_name // ", yp2=" // string(yp2) + endif + + test_name = test_name // ")" + + call interp_1d(grid1, grid2, data1, data2_test, method, yp1, yp2) + call array_compare_3d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! +! Supporting utilities +! + +subroutine open_netcdf_w(fileobj) + type(FmsNetcdfFile_t), intent(out) :: fileobj + + if (.not.open_file(fileobj, "test_axis_utils.nc", "overwrite")) then + call mpp_error(FATAL, "Error opening test_axis_utils.nc to write") + endif +end subroutine + +subroutine open_netcdf_r(fileobj) + type(FmsNetcdfFile_t), intent(out) :: fileobj + + if (.not.open_file(fileobj, "test_axis_utils.nc", "read")) then + call mpp_error(FATAL, "Error opening test_axis_utils.nc to read") + endif +end subroutine + +subroutine array_compare_1d(arr1, arr2, msg) + real(k), intent(in), dimension(:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i, m, n + + m = size(arr1) + n = size(arr2) + + if (m.ne.n) then + write(stderr(), "(A)") "1D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m) // " and array 2 has size " // string(n) + call mpp_error(FATAL, msg) + endif + + do i=1,m + if (arr1(i).ne.arr2(i)) then + write(stderr(), "(A)") "1D array comparison failed due to element " // string(i) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i)) // & + & " and array 2 has value " // string(arr2(i)) + call mpp_error(FATAL, msg) + endif + enddo +end subroutine + +subroutine array_compare_2d(arr1, arr2, msg) + real(k), intent(in), dimension(:,:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i1, i2, m1, m2, n1, n2 + + m1 = size(arr1, 1) + m2 = size(arr1, 2) + + n1 = size(arr2, 1) + n2 = size(arr2, 2) + + if (m1.ne.n1 .or. m2.ne.n2) then + write(stderr(), "(A)") "2D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m1) // "x" // string(m2) // & + & " and array 2 has size " // string(n1) // "x" // string(n2) + call mpp_error(FATAL, msg) + endif + + do i2=1,m2 + do i1=1,m1 + if (arr1(i1,i2).ne.arr2(i1,i2)) then + write(stderr(), "(A)") "2D array comparison failed due to element " // string(i1) // "," // string(i2) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i1,i2)) // & + & " and array 2 has value " // string(arr2(i1,i2)) + call mpp_error(FATAL, msg) + endif + enddo + enddo +end subroutine + +subroutine array_compare_3d(arr1, arr2, msg) + real(k), intent(in), dimension(:,:,:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i1, i2, i3, m1, m2, m3, n1, n2, n3 + + m1 = size(arr1, 1) + m2 = size(arr1, 2) + m3 = size(arr1, 3) + + n1 = size(arr2, 1) + n2 = size(arr2, 2) + n3 = size(arr2, 3) + + if (m1.ne.n1 .or. m2.ne.n2 .or. m3.ne.n3) then + write(stderr(), "(A)") "3D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m1) // "x" // string(m2) // "x" // string(m3) // & + & " and array 2 has size " // string(n1) // "x" // string(n2) // "x" // string(n3) + call mpp_error(FATAL, msg) + endif + + do i3=1,m3 + do i2=1,m2 + do i1=1,m1 + if (arr1(i1,i2,i3).ne.arr2(i1,i2,i3)) then + write(stderr(), "(A)") "3D array comparison failed due to element " // & + & string(i1) // "," // string(i2) // "," // string(i3) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i1,i2,i3)) // & + & " and array 2 has value " // string(arr2(i1,i2,i3)) + call mpp_error(FATAL, msg) + endif + enddo + enddo + enddo +end subroutine end program test_axis_utils diff --git a/test_fms/axis_utils/test_axis_utils2.sh b/test_fms/axis_utils/test_axis_utils2.sh index f06e39ff6a..1288822481 100755 --- a/test_fms/axis_utils/test_axis_utils2.sh +++ b/test_fms/axis_utils/test_axis_utils2.sh @@ -27,9 +27,30 @@ # Prepare the directory to run the tests. touch input.nml -# Run the test. -test_expect_success "Test AXIS utils" ' - mpirun -n 2 ./test_axis_utils -' +TESTS_SUCCESS='--get-axis-modulo --get-axis-modulo-times --get-axis-cart --lon-in-range --frac-index --nearest-index --axis-edges --tranlon --interp-1d-1d --interp-1d-2d --interp-1d-3d' +TESTS_FAIL='--frac-index-fail --nearest-index-fail' + +# TODO: Enable these tests after tranlon's memory corruption bug is fixed. +SKIP_TESTS="test_axis_utils2.15 test_axis_utils2.16" + +# Run the tests + +for t in $TESTS_SUCCESS +do + r4cmd="./test_axis_utils_r4 $t" + r8cmd="./test_axis_utils_r8 $t" + + test_expect_success "Testing axis utils: $r4cmd" "mpirun -n 1 $r4cmd" + test_expect_success "Testing axis utils: $r8cmd" "mpirun -n 1 $r8cmd" +done + +for t in $TESTS_FAIL +do + r4cmd="./test_axis_utils_r4 $t" + r8cmd="./test_axis_utils_r8 $t" + + test_expect_failure "Testing axis utils: $r4cmd" "mpirun -n 1 $r4cmd" + test_expect_failure "Testing axis utils: $r8cmd" "mpirun -n 1 $r8cmd" +done test_done diff --git a/test_fms/fms/Makefile.am b/test_fms/fms/Makefile.am index 80e7a06264..f1ceef9ed9 100644 --- a/test_fms/fms/Makefile.am +++ b/test_fms/fms/Makefile.am @@ -23,7 +23,7 @@ # uramirez, Ed Hartnett # Find the fms_mod.mod file. -AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/test_fms/fms/include -I$(MODDIR) # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la @@ -32,7 +32,12 @@ LDADD = $(top_builddir)/libFMS/libFMS.la check_PROGRAMS = test_fms # These are the sources for the tests. -test_fms_SOURCES = test_fmsC.c test_fms.F90 +test_fms_SOURCES = \ + test_fmsC.c \ + test_fms.F90 \ + include/test_fms.inc \ + include/test_fms_r4.fh \ + include/test_fms_r8.fh TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/fms/include/test_fms.inc b/test_fms/fms/include/test_fms.inc new file mode 100644 index 0000000000..388a9279c3 --- /dev/null +++ b/test_fms/fms/include/test_fms.inc @@ -0,0 +1,111 @@ +subroutine TEST_MONOTONIC_ARRAY_ + integer, parameter :: k = FMS_MOD_TEST_KIND_ + real(FMS_MOD_TEST_KIND_) :: arr1(1), arr2(2), arr5(5) + + ! monotonic_array should return false when size=1 + + arr1 = [1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false., 0) + + arr1 = [-1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false., 0) + + ! size=2, increasing + arr2 = [-1._k, 1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., 1) + + ! size=2, decreasing + arr2 = [1._k, -1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., -1) + + ! size=2, very large numbers, increasing + arr2 = [1e10_k, 1e20_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., 1) + + ! size=2, very large numbers, decreasing + arr2 = [1e10_k, 1e-20_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., -1) + + ! Monotonically increasing, size=5 + arr5 = [-2._k, -1._k, 0._k, 1._k, 2._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., 1) + + ! Monotonically decreasing, size=5 + arr5 = [2._k, 1._k, 0._k, -1._k, -2._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., -1) + + ! Non-monotonic array, size=5 + arr5 = [1._k, 2._k, 3._k, 4._k, -5._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) + + ! Another permutation of non-monotonic array, size=5 + arr5 = [-5._k, 4._k, 3._k, 2._k, 1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) + + ! Monotonically increasing, size=5, small numbers + arr5 = [1e-8_k, 1e-6_k, 1e-4_k, 1e-2_k, 1e0_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., 1) + + ! Monotonically decreasing, size=5, small numbers + arr5 = [1e0_k, 1e-2_k, 1e-4_k, 1e-6_k, 1e-8_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., -1) + + ! Non-monotonic array, size=5, small numbers + arr5 = [1e0_k, 1e-8_k, 1e-2_k, 1e-4_k, 1e-6_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) + + ! Monotonically increasing, size=5, positive large numbers + arr5 = [1e10_k, 1e20_k, 1e30_k, 1e35_k, 9.99e37_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., 1) + + ! Monotonically decreasing, size=5, negative large numbers + arr5 = [-1e10_k, -1e20_k, -1e30_k, -1e35_k, -9.99e37_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., -1) + + ! Non-monotonic array, size=5, negative large numbers + arr5 = [-1e10_k, -1e20_k, -1e30_k, -9.99e37_k, -1e30_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) +end subroutine + +subroutine TEST_MONOTONIC_ARRAY_ASSERT_(arr, monotonic_expected, direction_expected) + real(FMS_MOD_TEST_KIND_), intent(in) :: arr(:) + logical, intent(in) :: monotonic_expected + integer, intent(in), optional :: direction_expected + integer :: direction_test + logical :: monotonic_test + + if (present(direction_expected)) then + monotonic_test = monotonic_array(arr, direction_test) + if (direction_test .ne. direction_expected) then + write(stderr(), "(A)") "monotonic_array(" // stringify(arr) // & + & ", direction) returned incorrect direction: " // string(direction_test) + write(stderr(), "(A)") "Expected direction: " // string(direction_expected) + call mpp_error(FATAL, "monotonic_array unit test failed") + endif + else + monotonic_test = monotonic_array(arr) + endif + + if (monotonic_test .neqv. monotonic_expected) then + write(stderr(), "(A)") "monotonic_array(" // stringify(arr) // & + & ") returned incorrect value: " // string(monotonic_test) + write(stderr(), "(A)") "Expected return value: " // string(monotonic_expected) + call mpp_error(FATAL, "monotonic_array unit test failed") + endif +end subroutine diff --git a/test_fms/fms/include/test_fms_r4.fh b/test_fms/fms/include/test_fms_r4.fh new file mode 100644 index 0000000000..92649727af --- /dev/null +++ b/test_fms/fms/include/test_fms_r4.fh @@ -0,0 +1,13 @@ +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ + +#define FMS_MOD_TEST_KIND_ r4_kind +#define TEST_MONOTONIC_ARRAY_ test_monotonic_array_r4 +#define TEST_MONOTONIC_ARRAY_ASSERT_ test_monotonic_array_assert_r4 + +#include "test_fms.inc" + +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ diff --git a/test_fms/fms/include/test_fms_r8.fh b/test_fms/fms/include/test_fms_r8.fh new file mode 100644 index 0000000000..170cebca85 --- /dev/null +++ b/test_fms/fms/include/test_fms_r8.fh @@ -0,0 +1,13 @@ +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ + +#define FMS_MOD_TEST_KIND_ r8_kind +#define TEST_MONOTONIC_ARRAY_ test_monotonic_array_r8 +#define TEST_MONOTONIC_ARRAY_ASSERT_ test_monotonic_array_assert_r8 + +#include "test_fms.inc" + +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ diff --git a/test_fms/fms/test_fms.F90 b/test_fms/fms/test_fms.F90 index 24918e849e..faffd998eb 100644 --- a/test_fms/fms/test_fms.F90 +++ b/test_fms/fms/test_fms.F90 @@ -11,10 +11,13 @@ end function strPoint end module test_fms_mod program test_fms - use mpp_mod, only : mpp_error, fatal, note, mpp_init - use fms_mod, only : fms_init, string, fms_end + use mpp_mod, only : mpp_error, fatal, note, mpp_init, stderr + use fms_mod, only : fms_init, fms_end use fms_mod, only : fms_c2f_string use fms_mod, only : fms_cstring2cpointer + use fms_mod, only : monotonic_array + use platform_mod, only : r4_kind, r8_kind + use fms_string_utils_mod, only : string, stringify use test_fms_mod use, intrinsic :: iso_c_binding @@ -69,9 +72,14 @@ program test_fms call mpp_error(FATAL, trim(test)//" does not match "//trim(answer)) endif + call test_monotonic_array_r4 + call test_monotonic_array_r8 + call fms_end() +contains - call fms_end() +#include "test_fms_r4.fh" +#include "test_fms_r8.fh" end program test_fms diff --git a/test_fms/horiz_interp/Makefile.am b/test_fms/horiz_interp/Makefile.am index 038549a87e..812ab6cccb 100644 --- a/test_fms/horiz_interp/Makefile.am +++ b/test_fms/horiz_interp/Makefile.am @@ -29,10 +29,14 @@ AM_CPPFLAGS = -I$(MODDIR) LDADD = $(top_builddir)/libFMS/libFMS.la # Build these test programs. -check_PROGRAMS = test_horiz_interp +check_PROGRAMS = test_horiz_interp_r4 test_horiz_interp_r8 # These are the sources for the tests. -test_horiz_interp_SOURCES = test_horiz_interp.F90 +test_horiz_interp_r4_SOURCES = test_horiz_interp.F90 +test_horiz_interp_r8_SOURCES = test_horiz_interp.F90 + +test_horiz_interp_r4_CPPFLAGS=-DHI_TEST_KIND=4 -I$(MODDIR) +test_horiz_interp_r8_CPPFLAGS=-DHI_TEST_KIND=8 -I$(MODDIR) TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/horiz_interp/test_horiz_interp.F90 b/test_fms/horiz_interp/test_horiz_interp.F90 index 34f8e76aed..c4e333b786 100644 --- a/test_fms/horiz_interp/test_horiz_interp.F90 +++ b/test_fms/horiz_interp/test_horiz_interp.F90 @@ -16,45 +16,56 @@ !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** +!> @author Ryan Mulhall 2023 +!> Original test is in test_conserve, modified to test the other 3 interp_method option and mixed precision reals +!! tests are split up by interp_method (same way the modules are broken up) and enabled via the nml flags. +!! Assignment test checks that the override is copying the data type properly +!! TODO some larger tests with different data sets + +!! defaults to 8 real kind, make check will compile with both 4 and 8 +#ifndef HI_TEST_KIND_ +#define HI_TEST_KIND_ 8 +#endif program horiz_interp_test -use mpp_mod, only : mpp_init, mpp_exit, mpp_error, FATAL, stdout, mpp_npes +use mpp_mod, only : mpp_init, mpp_exit, mpp_error, FATAL, stdout, mpp_npes, WARNING use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end use mpp_mod, only : mpp_pe, mpp_root_pe, NOTE, MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED -use mpp_mod, only : input_nml_file +use mpp_mod, only : input_nml_file, mpp_sync use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains, mpp_get_compute_domain use mpp_domains_mod, only : mpp_domains_init, domain2d use fms_mod, only : check_nml_error, fms_init use horiz_interp_mod, only : horiz_interp_init, horiz_interp_new, horiz_interp_del use horiz_interp_mod, only : horiz_interp, horiz_interp_type +use horiz_interp_spherical_mod, only: horiz_interp_spherical_wght +use horiz_interp_type_mod, only: SPHERICA use constants_mod, only : constants_init, PI +use platform_mod implicit none + logical :: test_conserve = .false. , test_bicubic = .false. , test_spherical =.false. , test_bilinear =.false. + logical :: test_assign = .false. + logical :: test_solo = .false.!< test with the 'solo' wrappers that hide the _new and _del calls for the derived type integer :: ni_src = 360, nj_src = 180 integer :: ni_dst = 144, nj_dst = 72 + integer, parameter :: max_neighbors = 400 !! took this from spherical mod + !! max amount found neighbors to loop through in spherical search + - namelist /test_horiz_interp_nml/ ni_src, nj_src, ni_dst, nj_dst + namelist /test_horiz_interp_nml/ test_conserve, test_bicubic, test_spherical, test_bilinear, test_assign, test_solo,& + ni_src, nj_src, ni_dst,nj_dst - real :: lon_src_beg = 0, lon_src_end = 360 - real :: lat_src_beg = -90, lat_src_end = 90 - real :: lon_dst_beg = -280, lon_dst_end = 80 - real :: lat_dst_beg = -90, lat_dst_end = 90 - real :: D2R = PI/180. - real, parameter :: SMALL = 1.0e-10 type(domain2d) :: domain - type(horiz_interp_type) :: Interp integer :: id1, id2, id3, id4 integer :: isc, iec, jsc, jec, i, j integer :: io, ierr, layout(2) - real :: dlon_src, dlat_src, dlon_dst, dlat_dst - real, allocatable, dimension(:) :: lon1D_src, lat1D_src, lon1D_dst, lat1D_dst - real, allocatable, dimension(:,:) :: lon2D_src, lat2D_src, lon2D_dst, lat2D_dst - real, allocatable, dimension(:,:) :: data_src, data1_dst, data2_dst, data3_dst, data4_dst + integer, parameter :: lkind = HI_TEST_KIND_ call fms_init + call mpp_init call constants_init call horiz_interp_init @@ -71,142 +82,1312 @@ program horiz_interp_test ! (0:360,-90:90) with grid size ni_src, nj_src ( default 360X180). and the destination ! is the region (-280:80, -90:90) with grid size ni_dstXnj_dst( default 144X72). ! integer checksum and global sum will be printed out for both the 1D and 2D version. - - allocate(lon2D_src(ni_src+1, nj_src+1), lat2D_src(ni_src+1, nj_src+1) ) - allocate(lon1D_src(ni_src+1), lat1D_src(nj_src+1), data_src(ni_src, nj_src) ) - - allocate(lon2D_dst(isc:iec+1, jsc:jec+1), lat2D_dst(isc:iec+1, jsc:jec+1) ) - allocate(lon1D_dst(isc:iec+1), lat1D_dst(jsc:jec+1) ) - allocate(data1_dst(isc:iec, jsc:jec), data2_dst(isc:iec, jsc:jec) ) - allocate(data3_dst(isc:iec, jsc:jec), data4_dst(isc:iec, jsc:jec) ) - - ! set up longitude and latitude of source/destination grid. - dlon_src = (lon_src_end-lon_src_beg)/ni_src - dlat_src = (lat_src_end-lat_src_beg)/nj_src - dlon_dst = (lon_dst_end-lon_dst_beg)/ni_dst - dlat_dst = (lat_dst_end-lat_dst_beg)/nj_dst - - do i = 1, ni_src+1 - lon1D_src(i) = lon_src_beg + (i-1)*dlon_src - end do - - do j = 1, nj_src+1 - lat1D_src(j) = lat_src_beg + (j-1)*dlat_src - end do - - do i = isc, iec+1 - lon1D_dst(i) = lon_dst_beg + (i-1)*dlon_dst - end do - - do j = jsc, jec+1 - lat1D_dst(j) = lat_dst_beg + (j-1)*dlat_dst - end do - - ! scale grid to radians. - lon1D_src = lon1D_src * D2R - lat1D_src = lat1D_src * D2R - lon1D_dst = lon1D_dst * D2R - lat1D_dst = lat1D_dst * D2R - - do i = 1, ni_src+1 - lon2D_src(i,:) = lon1D_src(i) - end do - - do j = 1, nj_src+1 - lat2D_src(:,j) = lat1D_src(j) - end do - - do i = isc, iec+1 - lon2D_dst(i,:) = lon1D_dst(i) - end do - - do j = jsc, jec+1 - lat2D_dst(:,j) = lat1D_dst(j) - end do - - !--- set up the source data - do j = 1, nj_src - do i = 1, ni_src - data_src(i,j) = i + j*0.001 - end do - end do - - id1 = mpp_clock_id( 'horiz_interp_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - id2 = mpp_clock_id( 'horiz_interp_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - id3 = mpp_clock_id( 'horiz_interp_2dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - id4 = mpp_clock_id( 'horiz_interp_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - - ! --- 1dx1d version conservative interpolation - call mpp_clock_begin(id1) - call horiz_interp_new(Interp, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data1_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id1) - - ! --- 1dx2d version conservative interpolation - call mpp_clock_begin(id2) - call horiz_interp_new(Interp, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data2_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id2) - - ! --- 2dx1d version conservative interpolation - call mpp_clock_begin(id3) - call horiz_interp_new(Interp, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data3_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id3) - - ! --- 2dx2d version conservative interpolation - call mpp_clock_begin(id4) - call horiz_interp_new(Interp, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data4_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id4) - - !--- compare the data after interpolation between 1-D and 2-D version interpolation - do j = jsc, jsc - do i = isc, iec - - if( abs(data1_dst(i,j)-data2_dst(i,j)) > SMALL ) then - print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & - ", data2 = ", data2_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data2_dst(i,j) - call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data2_dst") - end if - end do - end do - - if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & - "The test that verify 1dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") - - do j = jsc, jsc - do i = isc, iec - - if( abs(data1_dst(i,j)-data3_dst(i,j)) > SMALL ) then - print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & - ", data2 = ", data3_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data3_dst(i,j) - call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data3_dst") - end if - end do - end do - - if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & - "The test that verify 2dx1d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") - - do j = jsc, jsc - do i = isc, iec - - if( abs(data1_dst(i,j)-data4_dst(i,j)) > SMALL ) then - print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & - ", data2 = ", data4_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data4_dst(i,j) - call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data4_dst") - end if - end do - end do - - if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & - "The test that verify 2dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + if (test_conserve) then + call test_horiz_interp_conserve + else if(test_bicubic) then + call test_horiz_interp_bicubic + else if(test_bilinear) then + call test_horiz_interp_bilinear + else if(test_spherical) then + call test_horiz_interp_spherical + else if(test_assign) then + call test_assignment + else + call mpp_error(FATAL, "test_horiz_interp: no unit test enabled in namelist") + endif call mpp_exit + contains + + !> Tests spherical module interpolation with each dimension conversion + !! test without passing in the type when test_solo is true + !! The spherical module has a nml option for whether using a full or radially bounded search + !! for finding the nearest points and distances so this gets run for both + subroutine test_horiz_interp_spherical + !! grid data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_2D, lon_in_2D + type(horiz_interp_type) :: interp_t + !! input data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst + !! output data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_out_2D, lon_out_2D + real(HI_TEST_KIND_), allocatable, dimension(:,:,:) :: wghts + !! array sizes and number of lat/lon per index + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + !! parameters for lon/lat setup + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = -280._lkind, lon_dst_end = 80._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_) :: R2D = 180._lkind/real(PI,HI_TEST_KIND_) + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, HI_TEST_KIND_) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, HI_TEST_KIND_) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, HI_TEST_KIND_) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, HI_TEST_KIND_) + + ! set up 2d lon/lat + allocate(lon_in_2D(ni_src, nj_src), lat_in_2D(ni_src, nj_src)) + do i = 1, ni_src + lon_in_2D(i,:) = lon_src_beg + real(i-1, HI_TEST_KIND_)*dlon_src + end do + do j = 1, nj_src + lat_in_2D(:,j) = lat_src_beg + real(j-1, HI_TEST_KIND_)*dlat_src + end do + allocate(lon_out_2D(ni_dst, nj_dst), lat_out_2D(ni_dst, nj_dst)) + do i = 1, ni_dst + lon_out_2D(i,:) = lon_dst_beg + real(i-1, HI_TEST_KIND_)*dlon_dst + end do + do j = 1, nj_dst + lat_out_2D(:,j) = lat_src_beg + real(j-1, HI_TEST_KIND_)*dlat_dst + end do + + ! scale to radians + lat_in_2D = lat_in_2D * D2R + lon_in_2D = lon_in_2D * D2R + lat_out_2D = lat_out_2D * D2R + lon_out_2D = lon_out_2D * D2R + + + allocate(data_src(ni_src, nj_src)) + allocate(data_dst(ni_dst, nj_dst)) + allocate(wghts(ni_dst, nj_dst, max_neighbors)) + data_dst = 0.0_lkind ; data_src = 1.0_lkind + + id1 = mpp_clock_id( 'horiz_interp_spherical_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! 2D x 2D (only one supported for spherical) + call mpp_clock_begin(id1) + if(.not. test_solo) then + call horiz_interp_new(interp_t, lon_in_2d, lat_in_2d, lon_out_2d, lon_out_2d, interp_method="spherical") + call horiz_interp(interp_t, data_src, data_dst) + call horiz_interp_spherical_wght(interp_t, wghts, verbose=1) + else + call horiz_interp(data_src, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, data_dst, interp_method="spherical") + endif + call mpp_clock_end(id1) + do i=1, ni_dst-1 + do j=1, nj_dst-1 + if(data_dst(i,j) - 1.0_lkind .gt. SMALL) then + print *, 'data_dst(i=', i, ', j=', j, ')=', data_dst(i,j), ' Expected value: 1.0' + call mpp_error(FATAL, "test_horiz_interp_spherical: "// & + "invalid output data after interpolation") + endif + enddo + enddo + if(.not. test_solo) then + call horiz_interp_del(interp_t) + call check_dealloc(interp_t) + endif + deallocate(data_src, data_dst) + deallocate(lat_in_2D, lon_in_2D) + deallocate(lat_out_2D, lon_out_2D) + + end subroutine + + !> Tests bilinear module interpolation with each dimension conversion + !! test without passing in the type when test_solo is true + subroutine test_horiz_interp_bilinear + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + real(HI_TEST_KIND_), allocatable, dimension(:) :: lon1D_src, lat1D_src, lon1D_dst, lat1D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lon2D_src, lat2d_src, lon2D_dst, lat2D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst + real(HI_TEST_KIND_), parameter :: lon_src_beg = 0._lkind, lon_src_end = 360.0_lkind + real(HI_TEST_KIND_), parameter :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_), parameter :: D2R = real(PI,lkind)/180._lkind + + type(horiz_interp_type) :: interp + + allocate( lon1D_src(ni_src+1), lat1D_src(nj_src+1) ) + allocate( lon1D_dst(ni_src+1), lat1D_dst(nj_src+1) ) + allocate( lon2d_src(ni_src,nj_src), lat2d_src(ni_src,nj_src) ) + allocate( lon2d_dst(ni_src,nj_src), lat2d_dst(ni_src,nj_src) ) + allocate( data_src(ni_src, nj_src) ) + allocate( data_dst(ni_src,nj_src) ) + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src,HI_TEST_KIND_) ; dlon_dst = dlon_src + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src,HI_TEST_KIND_) ; dlat_dst = dlat_src + + ! set up 1d source grid + do i = 1, ni_src + lon1D_src(i) = ( lon_src_beg + real(i-1,HI_TEST_KIND_)*dlon_src ) * D2R + end do + lon1D_src(ni_src+1) = ( lon_src_beg + real(ni_src,HI_TEST_KIND_)*dlon_src ) * D2R + + do j = 1, nj_src + lat1D_src(j) = ( lat_src_beg + real(j-1,HI_TEST_KIND_)*dlat_src ) * D2R + end do + lat1D_src(nj_src+1) = ( lat_src_beg + real(nj_src,HI_TEST_KIND_)*dlat_src ) * D2R + + !--- set up the source data + do j = 1, nj_src + do i = 1, ni_src + data_src(i,j) = real(i,HI_TEST_KIND_) + real(j,HI_TEST_KIND_)*0.001_lkind + end do + end do + + id1 = mpp_clock_id( 'horiz_interp_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id2 = mpp_clock_id( 'horiz_interp_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id3 = mpp_clock_id( 'horiz_interp_2dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id4 = mpp_clock_id( 'horiz_interp_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! --- 1dx1d version bilinear interpolation + data_dst = 0.0_lkind + lon1d_dst = lon1d_src + lat1d_dst = lat1d_src + call mpp_clock_begin(id1) + if (.not. test_solo) then + call horiz_interp_new(interp, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, data_dst, interp_method = "bilinear") + endif + ! check weights + if( .not. test_solo) then + do j=1, nj_src-1 + do i=1, ni_src-1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + endif + end do + end do + endif + call mpp_clock_end(id1) + !checking to make sure data_src is equal to data_dst + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d data comparison") + end if + end do + end do + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + + ! --- 1dx2d version bilinear interpolation + data_dst = 0.0_lkind + ! taking the midpoint + do i = 1, ni_src + lon2D_dst(i,:) = (lon1D_src(i) + lon1D_src(i+1)) * 0.5_lkind + end do + do j = 1, nj_src + lat2D_dst(:,j) = (lat1D_src(j) + lat1D_src(j+1)) * 0.5_lkind + end do + call mpp_clock_begin(id2) + if(.not. test_solo) then + call horiz_interp_new(interp, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, data_dst,interp_method="bilinear") + endif + call mpp_clock_end(id2) + ! check weights + if(.not. test_solo) then + do j=1, nj_src-1 + do i=1, ni_src-1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti2") + end if + endif + end do + end do + endif + !check that data are equal + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d data comparison") + end if + end do + end do + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + + ! --- 2dx1d version bilinear interpolation + data_dst = 0.0_lkind + lon1d_dst = lon1d_src + lat1d_dst = lat1d_src + do i=1, ni_src + lon2d_src(i,:) = lon1d_dst(i) + end do + do j=1, nj_src + lat2d_src(:,j) = lat1d_dst(j) + end do + call mpp_clock_begin(id3) + if(.not. test_solo) then + call horiz_interp_new(interp,lon2D_src,lat2D_src,lon1D_dst(1:ni_src),lat1D_dst(1:nj_src), & + interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon2D_src, lat2d_src, lon1D_dst(1:ni_src),lat1D_dst(1:nj_src), data_dst, & + interp_method="bilinear") + endif + call mpp_clock_end(id3) + ! check weights + !j=1,i=1 is a special case; see subroutine find_neighbor + if(.not. test_solo) then + i=1 ; j=1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j,interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,1)") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,2)") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,1)") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,2)") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j,interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,1)") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,2)") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,1)") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,2)") + end if + endif + do j=2, nj_src + do i=2, ni_src + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j, & + interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j, & + interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti2") + end if + endif + end do + end do + endif + !check that data are equal + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d data comparison") + end if + end do + end do + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + + ! --- 2dx2d version bilinear interpolation + data_dst = 0.0_lkind + lon2D_dst = lon2D_src + lat2D_dst = lat2D_src + + call mpp_clock_begin(id4) + if(.not. test_solo) then + call horiz_interp_new(interp, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon2D_src, lat2d_src, lon2D_dst, lat2D_dst, data_dst, interp_method="bilinear") + endif + call mpp_clock_end(id4) + ! check weights + if(.not. test_solo) then + !j=1,i=1 is a special case; see subroutine find_neighbor + i=1 ; j=1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j,interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,1)") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,2)") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,1)") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,2)") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j,interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,1)") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,2)") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,1)") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,2)") + end if + endif + do j=2, nj_src + do i=2, ni_src + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j, & + interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j, & + interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti2") + end if + endif + end do + end do + endif + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + !check that data are equal + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d data comparison") + end if + end do + end do + + end subroutine test_horiz_interp_bilinear + + !> Tests bicubic module interpolation with each dimension conversion + !! test without passing in the type when test_solo is true + subroutine test_horiz_interp_bicubic + !! grid data + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_in_1D, lon_in_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_2D, lon_in_2D + type(horiz_interp_type) :: interp_t + !! input data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst + !! output data + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_out_1D, lon_out_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_out_2D, lon_out_2D + !! array sizes and number of lat/lon per index + real(HI_TEST_KIND_) :: nlon_in, nlat_in + real(HI_TEST_KIND_) :: nlon_out, nlat_out + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + !! parameters for lon/lat setup + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = -280._lkind, lon_dst_end = 80._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_) :: R2D = 180._lkind/real(PI,HI_TEST_KIND_) + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, lkind) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, lkind) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, lkind) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, lkind) + + allocate(lon_in_1D(ni_src+1), lat_in_1D(nj_src+1)) + do i = 1, ni_src+1 + lon_in_1D(i) = lon_src_beg + real(i-1, lkind)*dlon_src + end do + do j = 1, nj_src+1 + lat_in_1D(j) = lat_src_beg + real(j-1, lkind)*dlat_src + end do + allocate(lon_out_1D(isc:iec+1), lat_out_1D(jsc:jec+1)) + do i = isc, iec+1 + lon_out_1D(i) = lon_dst_beg + real(i-1,lkind)*dlon_dst + end do + do j = jsc, jec+1 + lat_out_1D(j) = lat_dst_beg + real(j-1,lkind)*dlat_dst + end do + ! convert to rads + lon_in_1D = lon_in_1D * D2R + lat_in_1D = lat_in_1D * D2R + lon_out_1D = lon_out_1D * D2R + lat_out_1D = lat_out_1D * D2R + + ! set up 2d lon/lat + allocate(lon_out_2D(isc:iec+1, jsc:jec+1), lat_out_2D(isc:iec+1, jsc:jec+1)) + do i = isc, iec+1 + lon_out_2D(i,:) = lon_out_1D(i) + end do + do j = jsc, jec+1 + lat_out_2D(:,j) = lat_out_1D(j) + end do + + nlon_in = real(ni_src, lkind); nlat_in = real(nj_src, lkind) + nlon_out = real(iec - isc, lkind); nlat_out = real(jec - jsc, lkind) + + ! allocate data + allocate(data_src(ni_src, nj_src)) + allocate(data_dst(isc:iec, jsc:jec)) + data_dst = 0.0_lkind ; data_src = 1.0_lkind + + id1 = mpp_clock_id( 'horiz_interp_bicubic_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id2 = mpp_clock_id( 'horiz_interp_bicubic_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! 1D x 1D + call mpp_clock_begin(id1) + if(.not. test_solo) then + call horiz_interp_new(interp_t, lon_in_1d, lat_in_1d, lon_out_1d, lat_out_1d, interp_method="bicubic") + call horiz_interp(interp_t, data_src, data_dst) + else + call horiz_interp(data_src, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, data_dst, interp_method="bicubic") + endif + call mpp_clock_end(id1) + call mpp_sync() + ! check weights (for last index, 1=x,2=y,3=xy derivatives) + ! 1 radian (in degrees) at edges, 0.5 otherwise + if( .not. test_solo) then + do i=1, ni_src-1 + do j=1, nj_src-1 + if( interp_t%horizInterpReals4_type%is_allocated) then + if( interp_t%horizInterpReals4_type%wti(i,j,1) * interp_t%horizInterpReals4_type%wti(i,j,2) & + - interp_t%horizInterpReals4_type%wti(i,j,3) .gt. SMALL .or. & + interp_t%horizInterpReals4_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals4_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + else + if( interp_t%horizInterpReals8_type%wti(i,j,1) * interp_t%horizInterpReals8_type%wti(i,j,2) & + - interp_t%horizInterpReals8_type%wti(i,j,3) .gt. SMALL .and. & + interp_t%horizInterpReals8_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals8_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + endif + enddo + enddo + call horiz_interp_del(interp_t) + call check_dealloc(interp_t) + endif + do i=isc, iec + do j=jsc, jec + if( data_dst(i,j) .ne. 1.0_lkind) call mpp_error(FATAL, "test_horiz_interp: error in 1Dx1D output data") + enddo + enddo + + ! 1D x 2D + deallocate(data_src, data_dst) + allocate(data_src(ni_src+1, nj_src+1)) + allocate(data_dst(isc:iec+1, jsc:jec+1)) + data_dst = 0.0_lkind ; data_src = 1.0_lkind + + call mpp_clock_begin(id2) + if(.not. test_solo) then + call horiz_interp_new(interp_t, lon_in_1d, lat_in_1d, lon_out_2d, lat_out_2d, interp_method="bicubic") + call horiz_interp(interp_t, data_src, data_dst) + else + call horiz_interp(data_src, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, data_dst, interp_method="bicubic") + endif + call mpp_clock_end(id2) + if( .not. test_solo) then + do i=1, ni_src-1 + do j=1, nj_src-1 + if( interp_t%horizInterpReals4_type%is_allocated) then + if( interp_t%horizInterpReals4_type%wti(i,j,1) * interp_t%horizInterpReals4_type%wti(i,j,2) & + - interp_t%horizInterpReals4_type%wti(i,j,3) .gt. SMALL .or. & + interp_t%horizInterpReals4_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals4_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + else + if( interp_t%horizInterpReals8_type%wti(i,j,1) * interp_t%horizInterpReals8_type%wti(i,j,2) & + - interp_t%horizInterpReals8_type%wti(i,j,3) .gt. SMALL .or. & + interp_t%horizInterpReals8_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals8_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + endif + enddo + enddo + call horiz_interp_del(interp_t) + call check_dealloc(interp_t) + endif + do i=isc, iec + do j=jsc, jec + if( data_dst(i,j) .ne. 1.0_lkind) call mpp_error(FATAL, "test_horiz_interp: error in 1Dx2D output data") + enddo + enddo + + deallocate(data_src, data_dst) + deallocate(lat_in_1D, lon_in_1D) + deallocate(lat_out_1D, lon_out_1D, lat_out_2D, lon_out_2D) + + end subroutine test_horiz_interp_bicubic + + !> Tests conservative (default) interpolation module and checks grids reproduce across 1/2d versions + subroutine test_horiz_interp_conserve + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + real(HI_TEST_KIND_), allocatable, dimension(:) :: lon1D_src, lat1D_src, lon1D_dst, lat1D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lon2D_src, lat2D_src, lon2D_dst, lat2D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data1_dst, data2_dst, data3_dst, data4_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data1_solo, data2_solo, data3_solo, data4_solo + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = -280._lkind, lon_dst_end = 80._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + type(horiz_interp_type) :: interp_conserve + + allocate(lon2D_src(ni_src+1, nj_src+1), lat2D_src(ni_src+1, nj_src+1) ) + allocate(lon1D_src(ni_src+1), lat1D_src(nj_src+1), data_src(ni_src, nj_src) ) + + allocate(lon2D_dst(isc:iec+1, jsc:jec+1), lat2D_dst(isc:iec+1, jsc:jec+1) ) + allocate(lon1D_dst(isc:iec+1), lat1D_dst(jsc:jec+1) ) + allocate(data1_dst(isc:iec, jsc:jec), data2_dst(isc:iec, jsc:jec) ) + allocate(data3_dst(isc:iec, jsc:jec), data4_dst(isc:iec, jsc:jec) ) + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, lkind) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, lkind) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, lkind) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, lkind) + + do i = 1, ni_src+1 + lon1D_src(i) = lon_src_beg + real(i-1, lkind)*dlon_src + end do + + do j = 1, nj_src+1 + lat1D_src(j) = lat_src_beg + real(j-1, lkind)*dlat_src + end do + + do i = isc, iec+1 + lon1D_dst(i) = lon_dst_beg + real(i-1, lkind)*dlon_dst + end do + + do j = jsc, jec+1 + lat1D_dst(j) = lat_dst_beg + real(j-1, lkind)*dlat_dst + end do + + ! scale grid to radians. + lon1D_src = lon1D_src * D2R + lat1D_src = lat1D_src * D2R + lon1D_dst = lon1D_dst * D2R + lat1D_dst = lat1D_dst * D2R + + do i = 1, ni_src+1 + lon2D_src(i,:) = lon1D_src(i) + end do + + do j = 1, nj_src+1 + lat2D_src(:,j) = lat1D_src(j) + end do + + do i = isc, iec+1 + lon2D_dst(i,:) = lon1D_dst(i) + end do + + do j = jsc, jec+1 + lat2D_dst(:,j) = lat1D_dst(j) + end do + + !--- set up the source data + do j = 1, nj_src + do i = 1, ni_src + data_src(i,j) = real(i,lkind) + real(j,lkind)*0.001_lkind + end do + end do + + id1 = mpp_clock_id( 'horiz_interp_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id2 = mpp_clock_id( 'horiz_interp_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id3 = mpp_clock_id( 'horiz_interp_2dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id4 = mpp_clock_id( 'horiz_interp_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! --- 1dx1d version conservative interpolation + call mpp_clock_begin(id1) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data1_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, data1_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id1) + + ! --- 1dx2d version conservative interpolation + call mpp_clock_begin(id2) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data2_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, data2_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id2) + + ! --- 2dx1d version conservative interpolation + call mpp_clock_begin(id3) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data3_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, data3_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id3) + + ! --- 2dx2d version conservative interpolation + call mpp_clock_begin(id4) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data4_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, data4_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id4) + + !--- compare the data after interpolation between 1-D and 2-D version interpolation + do j = jsc, jsc + do i = isc, iec + + if( abs(data1_dst(i,j)-data2_dst(i,j)) > SMALL ) then + print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & + ", data2 = ", data2_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data2_dst(i,j) + call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data2_dst") + end if + end do + end do + + if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & + "The test that verify 1dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + + do j = jsc, jsc + do i = isc, iec + + if( abs(data1_dst(i,j)-data3_dst(i,j)) > SMALL ) then + print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & + ", data2 = ", data3_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data3_dst(i,j) + call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data3_dst") + end if + end do + end do + + if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & + "The test that verify 2dx1d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + + do j = jsc, jsc + do i = isc, iec + + if( abs(data1_dst(i,j)-data4_dst(i,j)) > SMALL ) then + print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & + ", data2 = ", data4_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data4_dst(i,j) + call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data4_dst") + end if + end do + end do + + if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & + "The test that verify 2dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + + + end subroutine + + !> Tests the assignment overload for horiz_interp_type + !! creates some new instances of the derived type for the different methods + !! and tests equality of fields after initial weiht calculations + subroutine test_assignment() + type(horiz_interp_type) :: Interp_new1, Interp_new2, Interp_cp, intp_3 + !! grid data points + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_in_1D, lon_in_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_2D, lon_in_2D + !! output data points + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_out_1D, lon_out_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_out_2D, lon_out_2D + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_out_bil, lon_out_bil + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_bil, lon_in_bil + !! array sizes and number of lat/lon per index + real(HI_TEST_KIND_) :: nlon_in, nlat_in + real(HI_TEST_KIND_) :: nlon_out, nlat_out + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + !! parameters for lon/lat setup + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = 0.0_lkind, lon_dst_end = 360._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_) :: R2D = 180._lkind/real(PI,HI_TEST_KIND_) + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, lkind) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, lkind) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, lkind) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, lkind) + + allocate(lon_in_1D(ni_src+1), lat_in_1D(nj_src+1)) + allocate(lon_out_1D(isc:iec+1), lat_out_1D(jsc:jec+1)) + do i = 1, ni_src+1 + lon_in_1D(i) = lon_src_beg + real(i-1,HI_TEST_KIND_)*dlon_src + end do + do j = 1, nj_src+1 + lat_in_1D(j) = lat_src_beg + real(j-1,HI_TEST_KIND_)*dlat_src + end do + do i = isc, iec+1 + lon_out_1D(i) = lon_dst_beg + real(i-1,HI_TEST_KIND_)*dlon_dst + end do + do j = jsc, jec+1 + lat_out_1D(j) = lat_dst_beg + real(j-1, HI_TEST_KIND_)*dlat_dst + end do + + lon_in_1D = lon_in_1D * D2R + lat_in_1D = lat_in_1D * D2R + lon_out_1D = lon_out_1D * D2R + lat_out_1D = lat_out_1D * D2R + + allocate(lon_in_2D(ni_src+1, nj_src+1), lat_in_2D(ni_src+1, nj_src+1)) + do i = 1, ni_src+1 + lon_in_2D(i,:) = lon_in_1D(i) + end do + do j = 1, nj_src+1 + lat_in_2D(:,j) = lat_in_1D(j) + end do + allocate(lon_out_2D(isc:iec+1, jsc:jec+1), lat_out_2D(isc:iec+1, jsc:jec+1)) + do i = isc, iec+1 + lon_out_2D(i,:) = lon_out_1D(i) + end do + do j = jsc, jec+1 + lat_out_2D(:,j) = lat_out_1D(j) + end do + + ! conservative + ! 1dx1d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x1d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 1dx2d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx1d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 2x1d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx2d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 2x2d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + ! bicubic only works with 1d src + ! 1dx1d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="bicubic") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="bicubic") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x1d bicubic") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 1dx2d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="bicubic") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="bicubic") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bicubic") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + deallocate(lon_out_2D, lat_out_2D, lon_in_2D, lat_in_2D) + allocate(lon_out_2D(ni_dst, nj_dst), lat_out_2D(ni_dst, nj_dst)) + allocate(lon_in_2D(ni_src, nj_src), lat_in_2D(ni_src, nj_src)) + do i = 1, ni_dst + lon_out_2D(i,:) = lon_dst_beg + real(i-1, HI_TEST_KIND_)*dlon_dst + end do + do j = 1, nj_dst + lat_out_2D(:,j) = lat_dst_beg + real(j-1, HI_TEST_KIND_)*dlat_dst + end do + do i = 1, ni_src + lon_in_2D(i,:) = lon_src_beg + real(i-1, HI_TEST_KIND_)*dlon_src + end do + do j = 1, nj_src + lat_in_2D(:,j) = lat_src_beg + real(j-1, HI_TEST_KIND_)*dlat_src + end do + ! scale to radians + lat_in_2D = lat_in_2D * D2R + lon_in_2D = lon_in_2D * D2R + lat_out_2D = lat_out_2D * D2R + lon_out_2D = lon_out_2D * D2R + + ! spherical + ! only 2dx2d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="spherical") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="spherical") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new1) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + ! bilinear + ! 1dx1d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_in_1D, lat_in_1D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_in_1D, lat_in_1D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x1d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 1dx2d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_in_2D, lat_in_2D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_in_2D, lat_in_2D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx1d + deallocate(lon_out_1D, lat_out_1D) + allocate(lon_out_1D(ni_dst+1), lat_out_1D(nj_dst+1)) + do i=1, ni_dst + lon_out_1d(i) = real(i-1, HI_TEST_KIND_) * dlon_dst + lon_dst_beg + enddo + do j=1, nj_dst + lat_out_1d(j) = real(j-1, HI_TEST_KIND_) * dlat_dst + lat_dst_beg + enddo + lat_out_1d = lat_out_1D * D2R + lon_out_1d = lon_out_1D * D2R + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx2d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_in_2D, lat_in_2D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_in_2D, lat_in_2D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + end subroutine + !> helps assignment test with derived type comparisons + subroutine check_type_eq(interp_1, interp_2) + type(horiz_interp_type), intent(in) :: interp_1, interp_2 + integer :: k + if(interp_1%horizInterpReals4_type%is_allocated) then + if(allocated(interp_1%horizInterpReals4_type%faci)) then + if( ANY(interp_2%horizInterpReals4_type%faci .ne. interp_1%horizInterpReals4_type%faci)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: faci") + endif + if(allocated(interp_1%horizInterpReals4_type%facj)) then + if( ANY(interp_2%horizInterpReals4_type%facj .ne. interp_1%horizInterpReals4_type%facj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: facj") + endif + if(allocated(interp_1%horizInterpReals4_type%area_src)) then + if( ANY(interp_2%horizInterpReals4_type%area_src .ne. interp_1%horizInterpReals4_type%area_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_src") + endif + if(allocated(interp_1%horizInterpReals4_type%area_dst)) then + if( ANY(interp_2%horizInterpReals4_type%area_dst .ne. interp_1%horizInterpReals4_type%area_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%wti)) then + if( ANY(interp_2%horizInterpReals4_type%wti .ne. interp_1%horizInterpReals4_type%wti)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wti") + endif + if(allocated(interp_1%horizInterpReals4_type%wtj)) then + if( ANY(interp_2%horizInterpReals4_type%wtj .ne. interp_1%horizInterpReals4_type%wtj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wtj") + endif + if(allocated(interp_1%horizInterpReals4_type%src_dist)) then + if( ANY(interp_2%horizInterpReals4_type%src_dist .ne. interp_1%horizInterpReals4_type%src_dist)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%rat_x)) then + if( ANY(interp_2%horizInterpReals4_type%rat_x .ne. interp_1%horizInterpReals4_type%rat_x)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%rat_y)) then + if( ANY(interp_2%horizInterpReals4_type%rat_y .ne. interp_1%horizInterpReals4_type%rat_y)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%lon_in)) then + if( ANY(interp_2%horizInterpReals4_type%lon_in .ne. interp_1%horizInterpReals4_type%lon_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lon_in") + endif + if(allocated(interp_1%horizInterpReals4_type%lat_in)) then + if( ANY(interp_2%horizInterpReals4_type%lat_in .ne. interp_1%horizInterpReals4_type%lat_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lat_in") + endif + + if(allocated(interp_1%horizInterpReals4_type%area_frac_dst)) then + if(ANY(interp_2%horizInterpReals4_type%area_frac_dst.ne.interp_1%horizInterpReals4_type%area_frac_dst))& + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_frac_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%mask_in)) then + if(ANY(interp_2%horizInterpReals4_type%mask_in.ne.interp_1%horizInterpReals4_type%mask_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: mask_in") + endif + !! only set during spherical + if(interp_1%interp_method .eq. SPHERICA) then + if( interp_2%horizInterpReals4_type%max_src_dist .ne. interp_1%horizInterpReals4_type%max_src_dist) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: max_src_dist") + endif + + else if(interp_1%horizInterpReals8_type%is_allocated) then + !! + if(allocated(interp_1%horizInterpReals8_type%faci)) then + if( ANY(interp_2%horizInterpReals8_type%faci .ne. interp_1%horizInterpReals8_type%faci)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: faci") + endif + if(allocated(interp_1%horizInterpReals8_type%facj)) then + if( ANY(interp_2%horizInterpReals8_type%facj .ne. interp_1%horizInterpReals8_type%facj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: facj") + endif + if(allocated(interp_1%horizInterpReals8_type%area_src)) then + if( ANY(interp_2%horizInterpReals8_type%area_src .ne. interp_1%horizInterpReals8_type%area_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_src") + endif + if(allocated(interp_1%horizInterpReals8_type%area_dst)) then + if( ANY(interp_2%horizInterpReals8_type%area_dst .ne. interp_1%horizInterpReals8_type%area_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%wti)) then + if( ANY(interp_2%horizInterpReals8_type%wti .ne. interp_1%horizInterpReals8_type%wti)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wti") + endif + if(allocated(interp_1%horizInterpReals8_type%wtj)) then + if( ANY(interp_2%horizInterpReals8_type%wtj .ne. interp_1%horizInterpReals8_type%wtj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wtj") + endif + if(allocated(interp_1%horizInterpReals8_type%src_dist)) then + if( ANY(interp_2%horizInterpReals8_type%src_dist .ne. interp_1%horizInterpReals8_type%src_dist)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%rat_x)) then + if( ANY(interp_2%horizInterpReals8_type%rat_x .ne. interp_1%horizInterpReals8_type%rat_x)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%rat_y)) then + if( ANY(interp_2%horizInterpReals8_type%rat_y .ne. interp_1%horizInterpReals8_type%rat_y)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%lon_in)) then + if( ANY(interp_2%horizInterpReals8_type%lon_in .ne. interp_1%horizInterpReals8_type%lon_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lon_in") + endif + if(allocated(interp_1%horizInterpReals8_type%lat_in)) then + if( ANY(interp_2%horizInterpReals8_type%lat_in .ne. interp_1%horizInterpReals8_type%lat_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lat_in") + endif + + if(allocated(interp_1%horizInterpReals8_type%area_frac_dst)) then + if(ANY(interp_2%horizInterpReals8_type%area_frac_dst.ne.interp_1%horizInterpReals8_type%area_frac_dst))& + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_frac_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%mask_in)) then + if(ANY(interp_2%horizInterpReals8_type%mask_in.ne.interp_1%horizInterpReals8_type%mask_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: mask_in") + endif + + !! only set during spherical + if(interp_1%interp_method .eq. SPHERICA) then + if( interp_2%horizInterpReals8_type%max_src_dist .ne. interp_1%horizInterpReals8_type%max_src_dist) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: max_src_dist") + endif + else + call mpp_error(FATAL, "check_type.ne. both real kinds unallocated") + endif + ! non reals + if(allocated(interp_1%ilon)) then + if( ANY(interp_2%ilon .ne. interp_1%ilon)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: ilon") + endif + if(allocated(interp_1%jlat)) then + if( ANY(interp_2%jlat .ne. interp_1%jlat)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: ilon") + endif + if(allocated(interp_1%found_neighbors)) then + if( ANY(interp_2%found_neighbors .neqv. interp_1%found_neighbors)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: found_neighbors") + endif + if(allocated(interp_1%num_found)) then + if( ANY(interp_2%num_found .ne. interp_1%num_found)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: num_found") + endif + if(allocated(interp_1%i_src)) then + if(ANY(interp_2%i_src .ne. interp_1%i_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: i_src") + endif + if(allocated(interp_1%j_src)) then + if(ANY(interp_2%j_src .ne. interp_1%j_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: j_src") + endif + if(allocated(interp_1%i_dst)) then + if(ANY(interp_2%i_dst .ne. interp_1%i_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: i_dst") + endif + if(allocated(interp_1%j_dst)) then + if(ANY(interp_2%j_dst .ne. interp_1%j_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: j_dst") + endif + if(interp_2%nlon_src .ne. interp_1%nlon_src) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlon_src") + if(interp_2%nlat_src .ne. interp_1%nlat_src) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlat_src") + if(interp_2%nlon_dst .ne. interp_1%nlon_dst) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlon_dst") + if(interp_2%nlat_dst .ne. interp_1%nlat_dst) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlat_dst") + + ! these checks were giving me issues with the ALL comparison (gnu), seems to work here tho + if( allocated(interp_1%i_lon)) then + do i=1, SIZE(interp_1%i_lon, 1) + do j=1, SIZE(interp_1%i_lon, 2) + do k=1, SIZE(interp_1%i_lon, 3) + if(interp_1%i_lon(i,j,k) .ne. interp_2%i_lon(i,j,k)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: i_lon") + enddo + enddo + enddo + do i=1, SIZE(interp_1%j_lat, 1) + do j=1, SIZE(interp_1%j_lat, 2) + do k=1, SIZE(interp_1%j_lat, 3) + if(interp_1%j_lat(i,j,k) .ne. interp_2%j_lat(i,j,k)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: j_lat") + enddo + enddo + enddo + endif + end subroutine + + subroutine check_dealloc(hi_type) + type(horiz_interp_type), intent(in) :: hi_type + !! can only check the encapsulating real types, inner fields are inaccessible after deallocation + if(hi_type%horizInterpReals4_type%is_allocated) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: horizInterpReals4_type") + endif + if(hi_type%horizInterpReals8_type%is_allocated) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: horizInterpReals8_type") + endif + !! non reals + if(allocated(hi_type%ilon)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: ilon") + endif + if(allocated(hi_type%jlat)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: jlat") + endif + if(allocated(hi_type%found_neighbors)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: found_neighbors") + endif + if(allocated(hi_type%num_found)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: num_found") + endif + if(allocated(hi_type%i_src)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: i_src") + endif + if(allocated(hi_type%j_src)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: j_src") + endif + if(allocated(hi_type%i_dst)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: i_dst") + endif + if(allocated(hi_type%j_dst)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: j_dst") + endif + + end subroutine + + end program horiz_interp_test diff --git a/test_fms/horiz_interp/test_horiz_interp2.sh b/test_fms/horiz_interp/test_horiz_interp2.sh index f9554f9df9..485be882fd 100755 --- a/test_fms/horiz_interp/test_horiz_interp2.sh +++ b/test_fms/horiz_interp/test_horiz_interp2.sh @@ -23,6 +23,7 @@ # execute tests in the test_fms/horiz_interp directory. # Ed Hartnett 11/29/19 +# Ryan Mulhall 01/23 # Set common test settings. . ../test-lib.sh @@ -30,6 +31,7 @@ # Create file for test. cat <<_EOF > input.nml &test_horiz_interp_nml + test_conserve = .true. ni_src = 360 nj_src = 180 ni_dst = 144 @@ -37,8 +39,179 @@ cat <<_EOF > input.nml / _EOF -test_expect_success "Horiz_interp test" ' - mpirun -n 2 ./test_horiz_interp +test_expect_success "conservative method with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +test_expect_success "conservative method with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r4 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_conserve = .true. + test_solo = .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "conservative method solo wrappers with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +test_expect_success "conservative method solo wrappers with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r4 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bicubic= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bicubic method with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bicubic method with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bicubic= .true. + test_solo = .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bicubic method solo wrappers with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bicubic method solo wrappers with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bilinear= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bilinear method with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bilinear method with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bilinear= .true. + test_solo = .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bilinear method solo wrapper with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bilinear method solo wrapper with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +# the spherical module has a namelist with an option for the search algorithm used +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_spherical= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ + +&horiz_interp_sherical_nml + search_method = "radial search" +/ +_EOF + +test_expect_success "spherical method (radial search) with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "spherical method (radial search) with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_spherical= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ + +&horiz_interp_sherical_nml + search_method = "full search" +/ +_EOF + +test_expect_success "spherical method (full search) with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "spherical method (full search) with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_spherical= .true. + test_solo= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ +_EOF + +test_expect_success "spherical method solo wrappers with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "spherical method solo wrappers with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_assign= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ +_EOF + +test_expect_success "assignment overloads with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "assignment overloads with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 ' test_done diff --git a/test_fms/sat_vapor_pres/Makefile.am b/test_fms/sat_vapor_pres/Makefile.am new file mode 100644 index 0000000000..974b6fbab1 --- /dev/null +++ b/test_fms/sat_vapor_pres/Makefile.am @@ -0,0 +1,50 @@ +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is an automake file for the test_fms/time_manager directory of the FMS +# package. + + +# Find the fms_mod.mod file. +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) + +# Link to the FMS library. +LDADD = $(top_builddir)/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_sat_vapor_pres_r4 test_sat_vapor_pres_r8 + +# This is the source code for the test. +test_sat_vapor_pres_r4_SOURCES = test_sat_vapor_pres.F90 +test_sat_vapor_pres_r8_SOURCES = test_sat_vapor_pres.F90 + +test_sat_vapor_pres_r4_CPPFLAGS=-DTEST_SVP_KIND_=4 -I$(MODDIR) +test_sat_vapor_pres_r8_CPPFLAGS=-DTEST_SVP_KIND_=8 -I$(MODDIR) + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh + +# Run the test program. +TESTS = test_sat_vapor_pres.sh + +# These files will be included in the distribution. +EXTRA_DIST = test_sat_vapor_pres.sh + +# Clean up +CLEANFILES = *.nml *.out* *.dpi *.spi *.dyn *.spl diff --git a/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 b/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 new file mode 100644 index 0000000000..a05fc9811c --- /dev/null +++ b/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 @@ -0,0 +1,1010 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!! @brief unit test for the mpp_root_pe() function +!! @author MiKyung Lee +!! @email gfdl.climate.model.info@noaa.gov +!! @description This program tests mainly the lookup* procedures in sat_vapor_pres_mod. +!! The compute_tables, compute_es_k, and compute_es_liq_k subroutines found in +!! this file are copied from sat_vapor_pres_k.F90 in order to generate answers. +!! TODO: A more comprehensive testing suite for the subroutine compute_qd +!! TODO: A more comprehensive testing suite for the compute_mrs +!! TODO: A test to check computation of TABLE and DTABLE when do_simple=.true. +!! (see subroutine sat_vapor_press_k_init) +!! TODO: Testing suite to test computations involving D2TABLE, D2TABLE2, D2TABLE3 +!! Current tests for the lookup* subroutines only checks esat and desat for temperatures +!! = TCMIN and TCMAX. The D2* tables are not involved in the computation for these two cases. +!! Thus, testing suite that involves these D2* table values should be incorporated here. +!! TODO: Test the computation of nbads and test to to see if the expected error occurs if the temperature +!! is less than TCMIN or higher than TCMAX + +program test_sat_vap_pressure + +use fms_mod, only: fms_init, fms_end +use mpp_mod, only: mpp_error, FATAL +use platform_mod, only: r4_kind, r8_kind +use constants_mod, only: RDGAS, RVGAS, TFREEZE +use sat_vapor_pres_mod, only: TCMIN, TCMAX, sat_vapor_pres_init, & + compute_qs, compute_mrs, & + lookup_es, lookup_des, lookup_es_des, & + lookup_es2, lookup_des2, lookup_es2_des2, & + lookup_es3, lookup_des3, lookup_es3_des3 + +implicit none + +integer, parameter :: ESRES=10 !> taken from sat_vapor_pres_mod +real(r8_kind), dimension(:), allocatable :: TABLE, DTABLE, TABLE2, DTABLE2, TABLE3, DTABLE3 +integer :: io, N + +integer, parameter :: nml_unit_var=100 +character(100) :: nml_file +logical :: test1, test2, test3, test4, test5 +NAMELIST / test_sat_vapor_pres_nml/ test1, test2, test3, test4, test5 + +N=(TCMAX-TCMIN)*ESRES+1 +allocate( TABLE(N),DTABLE(N),TABLE2(N),DTABLE2(N),TABLE3(N),DTABLE3(N) ) + +call fms_init() +call sat_vapor_pres_init() !> compute tables to be used for testing +call compute_tables() !> compute tables to generate answers/reference values + +nml_file='test_sat_vapor_pres.nml' +open(unit=nml_unit_var, file=trim(nml_file), action='read') +read(unit=nml_unit_var, nml=test_sat_vapor_pres_nml,iostat=io) +close(nml_unit_var) + +!CALL TESTS +if(test1) then + write(*,*)'***TEST COMPUTE_QS 1D-3D***' + call test_compute_qs() +end if +if(test2) then + write(*,*)'***TEST COMPUTE_MRS 1D-3D***' + call test_compute_mrs() +end if +if(test3) then + write(*,*)'***TEST LOOKUP_ES, LOOKUP_DES, LOOKUP_ES_DES, 1D-3D***' + call test_lookup_es_des() +end if +if(test4) then + write(*,*)'***TEST LOOKUP_ES2, LOOKUP_DES2, LOOKUP_ES2_DES2, 1D-3D***' + call test_lookup_es2_des2() +end if +if(test5) then + write(*,*)'***TEST_LOOKUP_ES3, LOOKUP_DES3, LOOKUP_ES3_DES3, 1D-3D***' + call test_lookup_es3_des3() +end if + +call fms_end() + +contains + !----------------------------------------------------------------------- + subroutine test_compute_qs() + + !> TEST: The qsat value should equal RDGAS/RVGAS as pressure is (hypothetically) zero. + !! The tests for this section is not comprehensive and more tests should be added. + + implicit none + + real(kind=TEST_SVP_KIND_) :: temp, press, answer, qsat + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, press_1d, answer_1d, qsat_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, press_2d, answer_2d, qsat_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, press_3d, answer_3d, qsat_3d + + real(kind=r8_kind), parameter :: EPSILO=real(RDGAS,r8_kind)/real(RVGAS, r8_kind) + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !---- 0d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp = 270.0_lkind ; press = 0.0_lkind ; answer=real(EPSILO,lkind) + call compute_qs(temp, press, qsat) + call check_answer_0d( answer, qsat, 'test_compute_qs_0d') + + !---- 1d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_1d = 270.0_lkind ; press_1d = 0.0_lkind ; answer_1d=real(EPSILO,lkind) + call compute_qs(temp_1d, press_1d, qsat_1d) + call check_answer_1d( answer_1d, qsat_1d, 'test_compute_qs_1d') + + !---- 2d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_2d = 270.0_lkind ; press_2d = 0.0_lkind ; answer_2d=real(EPSILO,lkind) + call compute_qs(temp_2d, press_2d, qsat_2d) + call check_answer_2d( answer_2d, qsat_2d, 'test_compute_qs_2d') + + !---- 3d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_3d = 270.0_lkind ; press_3d = 0.0_lkind ; answer_3d=real(EPSILO,lkind) + call compute_qs(temp_3d, press_3d, qsat_3d) + call check_answer_3d( answer_3d, qsat_3d, 'test_compute_qs_3d') + + end subroutine test_compute_qs + !----------------------------------------------------------------------- + subroutine test_compute_mrs() + + !> TEST: The qsat value should equal RDGAS/RVGAS as pressure is (hypothetically) zero. + !! The tests for this section is not comprehensive and more tests should be added. + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, press, answer, mrsat + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, press_1d, answer_1d, mrsat_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, press_2d, answer_2d, mrsat_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, press_3d, answer_3d, mrsat_3d + + real(kind=r8_kind), parameter :: EPSILO=real(RDGAS,r8_kind)/real(RVGAS, r8_kind) + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !--------0d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp= 270.0_lkind ; press= 0.0_lkind ; answer=real(EPSILO,lkind) + call compute_mrs(temp, press, mrsat) + call check_answer_0d(answer,mrsat,'test_compute_mrs_0d precision=TEST_SVP_KIND_') + + !--------1d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_1d = 270.0_lkind ; press_1d = 0.0_lkind ; answer_1d=real(EPSILO,lkind) + call compute_mrs(temp_1d, press_1d, mrsat_1d) + call check_answer_1d(answer_1d,mrsat_1d,'test_compute_mrs_1d precision=TEST_SVP_KIND_') + + !--------2d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_2d = 270.0_lkind ; press_2d = 0.0_lkind ; answer_2d=real(EPSILO,lkind) + call compute_mrs(temp_2d, press_2d, mrsat_2d) + call check_answer_2d(answer_2d,mrsat_2d,'test_compute_mrs_2d precision=TEST_SVP_KIND_') + + !--------3d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_3d = 270.0_lkind ; press_3d = 0.0_lkind ; answer_3d=real(EPSILO,lkind) + call compute_mrs(temp_3d, press_3d, mrsat_3d) + call check_answer_3d(answer_3d,mrsat_3d,'test_compute_mrs_3d precision=TEST_SVP_KIND_') + + end subroutine test_compute_mrs + !----------------------------------------------------------------------- + subroutine test_lookup_es_des + + !> TEST: at the minimum temperature (TCMIN), the pressures should correspond to the first element in the (D)TABLE + !! TEST: at the maximum temperature (TCMAX), the pressures should correspond to the last element in the (D)TABLE + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, esat, desat, esat_answer, desat_answer + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, esat_1d, desat_1d, esat_answer_1d, desat_answer_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, esat_2d, desat_2d, esat_answer_2d, desat_answer_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, esat_3d, desat_3d, esat_answer_3d, desat_answer_3d + + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers + + !-----0d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(1), lkind) + call lookup_es(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp=real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(N),lkind) + call lookup_es(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_0d precision TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer=real(DTABLE(1), lkind) + call lookup_des(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des_0d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp=real(TCMAX,lkind)+real(TFREEZE,lkind) + desat_answer = real(DTABLE(N),lkind) + call lookup_des(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_es_0d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(1), lkind) + desat_answer = real(DTABLE(1), lkind) + esat = 0._lkind ; desat = 0.0_lkind + call lookup_es_des(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_des_0d TCMIN') + call check_answer_0d(desat_answer, desat, 'test_lookup_es_des_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N), DTABLE(N) respectively + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(N), lkind) + desat_answer = real(DTABLE(N), lkind) + esat = 0._lkind ; desat = 0.0_lkind + call lookup_es_des(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_des_0d TCMAX') + call check_answer_0d(desat_answer, desat, 'test_lookup_es_des_0d TCMAX') + + + !-----1d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(1) + call lookup_es(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(N) + call lookup_es(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_1d TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE(1) + call lookup_des(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des_1d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE(N) + call lookup_des(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des_1d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(1) + desat_answer_1d = DTABLE(1) + call lookup_es_des(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_des_1d TCMIN') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es_des_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) and DTABLE(N) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(N) + desat_answer_1d = DTABLE(N) + call lookup_es_des(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_des_1d TCMAX') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es_des_1d TCMAX') + + !-----2d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE(1),lkind) + call lookup_es(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE(N),lkind) + call lookup_es(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_2d TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE(1) + call lookup_des(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des_2d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE(N) + call lookup_des(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des_2d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE(1) + desat_answer_2d = DTABLE(1) + call lookup_es_des(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_des_2d TCMIN') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es_des_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) and DTABLE(N) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE(N) + desat_answer_2d = DTABLE(N) + call lookup_es_des(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_des_2d TCMAX') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es_des_2d TCMAX') + + !-----3d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(1) + call lookup_es(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_3d precision TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(N) + call lookup_es(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_3d TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE(1) + call lookup_des(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des_3d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE(N) + call lookup_des(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des_3d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(1) + desat_answer_3d = DTABLE(1) + call lookup_es_des(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_des_3d TCMIN') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es_des_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) and DTABLE(N) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(N) + desat_answer_3d = DTABLE(N) + call lookup_es_des(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_des_3d TCMAX') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es_des_3d TCMAX') + + end subroutine test_lookup_es_des + !---------------------------------------------------------------------- + subroutine test_lookup_es2_des2 + + !> TEST: at the minimum temperature (TCMIN), the pressures should correspond to the first element in the (D)TABLE2 + !! TEST: at the maximum temperature (TCMAX), the pressures should correspond to the last element in the (D)TABLE2 + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, esat, desat, esat_answer, desat_answer + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, esat_1d, desat_1d, esat_answer_1d, desat_answer_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, esat_2d, desat_2d, esat_answer_2d, desat_answer_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, esat_3d, desat_3d, esat_answer_3d, desat_answer_3d + + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !-----0d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(1),lkind) + call lookup_es2(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(N),lkind) + !! test lookup_es2 + call lookup_es2(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_0d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer=real(DTABLE2(1),lkind) + call lookup_des2(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des2_0d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer=real(DTABLE2(N),lkind) + call lookup_des2(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des2_0d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(1),lkind) + desat_answer=real(DTABLE2(1),lkind) + call lookup_es2_des2(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_des2_0d TCMIN') + call check_answer_0d(desat_answer, desat, 'test_lookup_es2_des2_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(N),lkind) + desat_answer=real(DTABLE2(N),lkind) + call lookup_es2_des2(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_des2_0d TCMAX') + call check_answer_0d(desat_answer, desat, 'test_lookup_es2_des2_0d TCMAX') + + !-----1d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(1) + call lookup_es2(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(N) + call lookup_es2(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_1d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE2(1) + call lookup_des2(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des2_1d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE2(N) + call lookup_des2(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des2_1d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(1) + desat_answer_1d = DTABLE2(1) + call lookup_es2_des2(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_des2_1d TCMIN') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es2_des2_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(N) + desat_answer_1d = DTABLE2(N) + call lookup_es2_des2(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_des2_1d TCMAX') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es2_des2_1d TCMAX') + + + !-----2d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(1) + call lookup_es2(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(N) + call lookup_es2(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_2d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE2(1) + call lookup_des2(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des2_2d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE2(N) + call lookup_des2(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des2_2d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(1) + desat_answer_2d = DTABLE2(1) + call lookup_es2_des2(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_des2_2d TCMIN') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es2_des2_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(N) + desat_answer_2d = DTABLE2(N) + call lookup_es2_des2(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_des2_2d TCMAX') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es2_des2_2d TCMAX') + + + !-----3d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(1) + call lookup_es2(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(N) + call lookup_es2(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_3d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE2(1) + call lookup_des2(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des2_3d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE2(N) + call lookup_des2(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des2_3d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(1) + desat_answer_3d = DTABLE2(1) + call lookup_es2_des2(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_des2_3d TCMIN') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es2_des2_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(N) + desat_answer_3d = DTABLE2(N) + call lookup_es2_des2(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_des2_3d TCMAX') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es2_des2_3d TCMAX') + + end subroutine test_lookup_es2_des2 + !---------------------------------------------------------------------- + subroutine test_lookup_es3_des3 + + !> TEST: at the minimum temperature (TCMIN), the pressures should correspond to the first element in the (D)TABLE3 + !! TEST: at the maximum temperature (TCMAX), the pressures should correspond to the last element in the (D)TABLE3 + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, esat, desat, esat_answer, desat_answer + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, esat_1d, desat_1d, esat_answer_1d, desat_answer_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, esat_2d, desat_2d, esat_answer_2d, desat_answer_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, esat_3d, desat_3d, esat_answer_3d, desat_answer_3d + + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !-----0d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(1) + call lookup_es3(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(N) + call lookup_es3(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_0d TCMAX') + + !> test lookup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer=DTABLE3(1) + call lookup_des3(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des3_0d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer=DTABLE3(N) + call lookup_des3(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des3_0d TCMAX') + + !> test lookup_es3_des3 + !! at temp=TCMIN, the answers should be TABLE3(1) and DTABLE3(1) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(1) + desat_answer = DTABLE3(1) + call lookup_es3_des3(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_des3_0d TCMIN') + call check_answer_0d(desat_answer, desat, 'test_lookup_es3_des3_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(N) ; desat_answer=DTABLE3(N) + call lookup_es3_des3(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_des3_0d TCMAX') + call check_answer_0d(desat_answer, desat, 'test_lookup_es3_des3_0d TCMAX') + + !-----1d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(1),lkind) + call lookup_es3(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(N),lkind) + call lookup_es3(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_1d TCMAX') + + !> test looup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_1d = real(DTABLE3(1),lkind) + call lookup_des3(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des3_1d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_1d = real(DTABLE3(N),lkind) + call lookup_des3(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des3_1d TCMAX') + + !> test lookup_es3_des3 + !! at temp=TCMIN, the answers should be TABLE3(1) and DTABLE3(1) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(1),lkind) + desat_answer_1d = real(DTABLE3(1),lkind) + call lookup_es3_des3(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_des3_1d TCMIN') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es3_des3_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(N),lkind) + desat_answer_1d = real(DTABLE3(N),lkind) + call lookup_es3_des3(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_des3_1d TCMAX') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es3_des3_1d TCMAX') + + + !-----2d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(1),lkind) + call lookup_es3(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(N),lkind) + call lookup_es3(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_2d TCMAX') + + !> test lookup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_2d = real(DTABLE3(1),lkind) + call lookup_des3(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des3_2d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_2d = real(DTABLE3(N),lkind) + call lookup_des3(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des3_2d TCMAX') + + !> test lookup_es3_des3 + !! at temp=TCMIN, the answers should be TABLE3(1) and DTABLE3(1) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(1),lkind) + desat_answer_2d = real(DTABLE3(1),lkind) + call lookup_es3_des3(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_des3_2d TCMIN') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es3_des3_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(N),lkind) + desat_answer_2d = real(DTABLE3(N),lkind) + call lookup_es3_des3(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_des3_2d TCMAX') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es3_des3_2d TCMAX') + + !-----3d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(1) + call lookup_es3(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(N) + call lookup_es3(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_3d TCMAX') + + !> test lookup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE3(1) + call lookup_des3(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des3_3d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE3(N) + call lookup_des3(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des3_3d TCMAX') + + !> test lookup_es3_des3 + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(1) + desat_answer_3d = DTABLE3(1) + call lookup_es3_des3(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_des3_3d TCMIN') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es3_des3_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(N) + desat_answer_3d = DTABLE3(N) + call lookup_es3_des3(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_des3_3d TCMAX') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es3_des3_3d TCMAX') + + + end subroutine test_lookup_es3_des3 + !---------------------------------------------------------------------- + subroutine check_answer_0d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer .ne. fms_result) then + write(*,*) 'Expected ', answer, ' but got ', fms_result + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_0d + !----------------------------------------------------------------------- + subroutine check_answer_1d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), dimension(:), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer(1) .ne. fms_result(1)) then + write(*,*) 'Expected ', answer(1), ' but got ', fms_result(1) + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_1d + !----------------------------------------------------------------------- + subroutine check_answer_2d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), dimension(:,:), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer(1,1) .ne. fms_result(1,1)) then + write(*,*) 'Expected ', answer(1,1), ' but got ', fms_result(1,1) + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_2d + !----------------------------------------------------------------------- + subroutine check_answer_3d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), dimension(:,:,:), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer(1,1,1) .ne. fms_result(1,1,1)) then + write(*,*) 'Expected ', answer(1,1,1), ' but got ', fms_result(1,1,1) + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_3d + !----------------------------------------------------------------------- + subroutine compute_tables + + !> This subroutine is taken from the sat_vapor_pres_init_k subroutine in sat_vapor_pres/include + !! Thus, sat_vapor_pres_init_k subroutine is not tested and is assumed to be correct. + !! The TABLE* and DTABLE* values are required to test compute_qs, compute_mrs, and the 3 flavors of + !! loopup_es_des subroutines + !! The TABLE* and DTABLE* values are computed with r8_precision. + + + real(kind=r8_kind), dimension(3) :: tem, es + real(kind=r8_kind) :: dtres, tminl, dtinvl, tepsl, tinrc, tfact + integer :: i + + + !> TCMAX, TCMIN,TFREEZE are module level variables in sat_vapor_pres_mod + dtres = (real(TCMAX,r8_kind)-real(TCMIN,r8_kind))/real(N-1,r8_kind) + tminl = real(TCMIN,r8_kind)+real(TFREEZE,r8_kind) + dtinvl = 1.0_r8_kind/dtres + tepsl = 0.5_r8_kind*dtres + tinrc = 0.1_r8_kind*dtres + tfact = 5.0_r8_kind*dtinvl + + do i = 1, N + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + es = compute_es_k (tem, real(TFREEZE,r8_kind)) + TABLE(i) = es(1) + DTABLE(i) = (es(3)-es(2))*tfact + enddo + + do i = 1, N + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + !> pass in flag to force all values to be wrt liquid + es = compute_es_liq_k (tem, real(TFREEZE,r8_kind)) + TABLE2(i) = es(1) + DTABLE2(i) = (es(3)-es(2))*tfact + enddo + + do i = 1, N + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + !> pass in flag to force all values to be wrt liquid + es = compute_es_liq_ice_k (tem, real(TFREEZE,r8_kind)) + TABLE3(i) = es(1) + DTABLE3(i) = (es(3)-es(2))*tfact + enddo + + end subroutine compute_tables + !----------------------------------------------------------------------- + function compute_es_k(tem, TFREEZE) result (es) + + !> This subroutine is taken from the compute_es_k subroutine in sat_vapor_pres/include + !! and is required to compute the TABLE and DTABLE values. + !! Thus, compute_es_k subroutine is not tested and is assumed to be correct. + !! Since the TABLE and DTABLE values are computed with r8_precision, all variables here + !! are in r8_kind precision. + + + real(kind=r8_kind), intent(in) :: tem(:), TFREEZE + real(kind=r8_kind) :: es(size(tem,1)) + + real(kind=r8_kind) :: x, esice, esh2o, TBASW, TBASI + integer :: i + + real(kind=r8_kind), parameter :: ESBASW = 101324.60_r8_kind + real(kind=r8_kind), parameter :: ESBASI = 610.71_r8_kind + + real(r8_kind), parameter :: one=1.0_r8_kind + real(r8_kind), parameter :: ten=10.0_r8_kind + + TBASW = TFREEZE+100.0_r8_kind + TBASI = TFREEZE + do i = 1, size(tem) + + !> compute es over ice + + if (tem(i) < TBASI) then + x = -9.09718_r8_kind*(TBASI/tem(i)-one) & + -3.56654_r8_kind*log10(TBASI/tem(i)) & + +0.876793_r8_kind*(one-tem(i)/TBASI) + log10(ESBASI) + esice =ten**(x) + else + esice = 0.0_r8_kind + endif + + !> compute es over water greater than -20 c. + !! values over 100 c may not be valid + !! see smithsonian meteorological tables page 350. + + if (tem(i) > -20.0_r8_kind+TBASI) then + x = -7.90298_r8_kind*(TBASW/tem(i)-one) & + +5.02808_r8_kind*log10(TBASW/tem(i)) & + -1.3816e-07_r8_kind*(ten**((one-tem(i)/TBASW)*11.344d0)-one) & + +8.1328e-03_r8_kind*(ten**((TBASW/tem(i)-one)*(-3.49149d0))-one) & + +log10(ESBASW) + esh2o = ten**(x) + else + esh2o = 0.0_r8_kind + endif + + !> derive blended es over ice and supercooled water between -20c and 0c + + if (tem(i) <= -20.0_r8_kind+TBASI) then + es(i) = esice + else if (tem(i) >= TBASI) then + es(i) = esh2o + else + es(i) = 0.05_r8_kind*((TBASI-tem(i))*esice + (tem(i)-TBASI+20.0_r8_kind)*esh2o) + endif + + enddo + + end function compute_es_k +!----------------------------------------------------------------------- + function compute_es_liq_k(tem, TFREEZE) result (es) + + !> This subroutine is taken from the compute_es_liq_k subroutine in sat_vapor_pres/include + !! and is required to compute the TABLE2 and DTABLE2 values. + !! Thus, compute_es_liq_k subroutine is not tested and is assumed to be correct. + !! Since the TABLE2 and DTABLE2 values are computed with r8_precision, all variables here + !! are in r8_kind precision. + + real(kind=r8_kind), intent(in) :: tem(:), TFREEZE + real(kind=r8_kind) :: es(size(tem,1)) + + real(kind=r8_kind) :: x, esh2o, TBASW + integer :: i + + real(kind=r8_kind), parameter :: one=1.0_r8_kind + real(kind=r8_kind), parameter :: ten=10.0_r8_kind + real(kind=r8_kind), parameter :: ESBASW = 101324.60_r8_kind + + + TBASW = TFREEZE+100.0_r8_kind + + do i = 1, size(tem) +!> compute es over water for all temps. +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + x = -7.90298_r8_kind*(TBASW/tem(i)-one) & + +5.02808_r8_kind*log10(TBASW/tem(i)) & + -1.3816e-07_r8_kind*(ten**((one-tem(i)/TBASW)*11.344_r8_kind)-one) & + +8.1328e-03_r8_kind*(ten**((TBASW/tem(i)-one)*-3.49149_r8_kind)-one)& + +log10(ESBASW) + esh2o = ten**(x) + es(i) = esh2o + + enddo + + end function compute_es_liq_k + !----------------------------------------------------------------------- + function compute_es_liq_ice_k(tem, TFREEZE) result (es) + + !> This subroutine is taken from the compute_es_liq_ice_k subroutine in sat_vapor_pres/include + !! and is required to compute the TABLE3 and DTABLE3 values. + !! Thus, compute_es_liq_ice_k subroutine is not tested and is assumed to be correct. + !! Since the TABLE3 and DTABLE3 values are computed with r8_precision, all variables here + !! are in r8_kind precision. + + real(kind=r8_kind), intent(in) :: tem(:), TFREEZE + real(kind=r8_kind) :: es(size(tem,1)) + + real(kind=r8_kind) :: x, TBASW, TBASI + integer :: i + + real(kind=r8_kind), parameter :: ESBASW = 101324.60_r8_kind + real(kind=r8_kind), parameter :: ESBASI = 610.71_r8_kind + real(kind=r8_kind), parameter :: one= 1.0_r8_kind + real(kind=r8_kind), parameter :: ten= 10.0_r8_kind + + TBASW = TFREEZE+100.0_r8_kind + TBASI = TFREEZE + + do i = 1, size(tem) + + if (tem(i) < TBASI) then + +!> compute es over ice + + x = -9.09718_r8_kind*(TBASI/tem(i)-one) & + -3.56654_r8_kind*log10(TBASI/tem(i)) & + +0.876793_r8_kind*(one-tem(i)/TBASI) + log10(ESBASI) + es(i) =ten**(x) + else + +!> compute es over water +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + + x = -7.90298_r8_kind*(TBASW/tem(i)-one) & + +5.02808_r8_kind*log10(TBASW/tem(i)) & + -1.3816e-07_r8_kind*(ten**((one-tem(i)/TBASW)*11.344_r8_kind)-one) & + +8.1328e-03_r8_kind*(ten**((TBASW/tem(i)-one)*(-3.49149_r8_kind))-one) & + +log10(ESBASW) + es(i) = ten**(x) + endif + enddo + + end function compute_es_liq_ice_k + !----------------------------------------------------------------------- +end program test_sat_vap_pressure diff --git a/test_fms/sat_vapor_pres/test_sat_vapor_pres.sh b/test_fms/sat_vapor_pres/test_sat_vapor_pres.sh new file mode 100755 index 0000000000..7e22b88a8f --- /dev/null +++ b/test_fms/sat_vapor_pres/test_sat_vapor_pres.sh @@ -0,0 +1,116 @@ +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/horiz_interp directory. + +# Copyright 2021 Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +# Prepare the directory to run the tests. +cat << EOF > input.nml +&sat_vapor_pres_nml + construct_table_wrt_liq = .true., + construct_table_wrt_liq_and_ice = .true., + use_exact_qs = .true. +/ +EOF + + +##### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.true. + test2=.false. + test3=.false. + test4=.false. + test5=.false. + / +EOF +test_expect_success "test_compute_qs_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_compute_qs_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.true. + test3=.false. + test4=.false. + test5=.false. + / +EOF +test_expect_success "test_compute_mrs_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_compute_mrs_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.false. + test3=.true. + test4=.false. + test5=.false. + / +EOF +test_expect_success "test_lookup_es_des_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_lookup_es_des_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.false. + test3=.false. + test4=.true. + test5=.false. + / +EOF +test_expect_success "test_lookup_es2_des2_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_lookup_es2_des2_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.false. + test3=.false. + test4=.false. + test5=.true. + / +EOF +test_expect_success "test_lookup_es3_des3_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_lookup_es3_des3_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +test_done From af15993b06c8492813b4728a4d0eeed0550da616 Mon Sep 17 00:00:00 2001 From: dkokron Date: Fri, 16 Jun 2023 15:04:10 -0500 Subject: [PATCH 003/394] fix: replace current_peset_num with 'n' which should be the active pelist. (#1246) --- mpp/include/mpp_transmit_mpi.fh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpp/include/mpp_transmit_mpi.fh b/mpp/include/mpp_transmit_mpi.fh index 023c2d5124..fa820300c1 100644 --- a/mpp/include/mpp_transmit_mpi.fh +++ b/mpp/include/mpp_transmit_mpi.fh @@ -182,7 +182,7 @@ 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if - if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & + if( .NOT.ANY(from_pe.EQ.peset(n)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call SYSTEM_CLOCK(start_tick) From de0379877983bb75673ef7c555d1d5d55736ae9b Mon Sep 17 00:00:00 2001 From: laurenchilutti <60401591+laurenchilutti@users.noreply.github.com> Date: Fri, 16 Jun 2023 16:07:06 -0400 Subject: [PATCH 004/394] fix: gcc class(*) bug workaround for character arrays (#1163) --- fms2_io/include/array_utils_char.inc | 135 ++++++++++++++++++++- fms2_io/include/netcdf_read_data.inc | 165 +++++++++++++++----------- fms2_io/include/netcdf_write_data.inc | 152 ++++++++++++++---------- mosaic2/mosaic2.F90 | 15 +++ 4 files changed, 332 insertions(+), 135 deletions(-) diff --git a/fms2_io/include/array_utils_char.inc b/fms2_io/include/array_utils_char.inc index 884f1f3cda..528aa5520b 100644 --- a/fms2_io/include/array_utils_char.inc +++ b/fms2_io/include/array_utils_char.inc @@ -23,79 +23,202 @@ !> @{ !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_1d(buf, sizes) +subroutine allocate_array_char_1d(buf, sizes, initialize) character(len=*), dimension(:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(1), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1))) + + if (init) then + do i = 1, sizes(1) + do c = 1, len(buf(i)) + buf(i)(c:c) = " " + enddo + enddo + endif + end subroutine allocate_array_char_1d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_2d(buf, sizes) +subroutine allocate_array_char_2d(buf, sizes, initialize) character(len=*), dimension(:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(2), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2))) + + if (init) then + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j)) + buf(i,j)(c:c) = " " + enddo + enddo + enddo + endif + end subroutine allocate_array_char_2d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_3d(buf, sizes) +subroutine allocate_array_char_3d(buf, sizes, initialize) character(len=*), dimension(:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(3), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3))) + + if (init) then + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k)) + buf(i,j,k)(c:c) = " " + enddo + enddo + enddo + enddo + endif + end subroutine allocate_array_char_3d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_4d(buf, sizes) +subroutine allocate_array_char_4d(buf, sizes, initialize) character(len=*), dimension(:,:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(4), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, l, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3), sizes(4))) + + if (init) then + do l = 1, sizes(4) + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k,l)) + buf(i,j,k,l)(c:c) = " " + enddo + enddo + enddo + enddo + enddo + endif end subroutine allocate_array_char_4d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_5d(buf, sizes) +subroutine allocate_array_char_5d(buf, sizes, initialize) character(len=*), dimension(:,:,:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(5), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, l, m, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3), sizes(4), sizes(5))) + + if (init) then + do m = 1, sizes(5) + do l = 1, sizes(4) + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k,l,m)) + buf(i,j,k,l,m)(c:c) = " " + enddo + enddo + enddo + enddo + enddo + enddo + endif end subroutine allocate_array_char_5d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_6d(buf, sizes) +subroutine allocate_array_char_6d(buf, sizes, initialize) character(len=*), dimension(:,:,:,:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(6), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, l, m, n, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3), sizes(4), sizes(5), sizes(6))) + + if (init) then + do n = 1, sizes(6) + do m = 1, sizes(5) + do l = 1, sizes(4) + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k,l,m,n)) + buf(i,j,k,l,m,n)(c:c) = " " + enddo + enddo + enddo + enddo + enddo + enddo + enddo + endif end subroutine allocate_array_char_6d !> @} diff --git a/fms2_io/include/netcdf_read_data.inc b/fms2_io/include/netcdf_read_data.inc index 3a5e7e3733..66c1484f29 100644 --- a/fms2_io/include/netcdf_read_data.inc +++ b/fms2_io/include/netcdf_read_data.inc @@ -23,6 +23,102 @@ !> @addtogroup netcdf_io_mod !> @{ +!> @brief Character read 0d function. +subroutine char_read_0d(fileobj, variable_name, buf, corner, append_error_msg, err, varid) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), intent(inout) :: buf !< Array that the data will be read into + integer, intent(in), optional :: corner !< Index of the string to read if the variable + !! contains a 1D array of strings. + character(len=200), intent(in):: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer, dimension(2) :: start + integer :: ndims + character, dimension(:), allocatable :: charbuf + integer, dimension(:), allocatable :: dimsizes + integer :: i + + start(:) = 1 + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + allocate(dimsizes(ndims)) + call get_variable_size(fileobj, variable_name, dimsizes, broadcast=.false.) + allocate(charbuf(dimsizes(1))) + charbuf(:) = "" + if (ndims .eq. 2) then + if (present(corner)) then + start(2) = corner + endif + dimsizes(2) = 1 + elseif (ndims .gt. 2) then + call error("Only scalar and 1d string values are currently supported: "//trim(append_error_msg)) + endif + err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + if (len(buf) .lt. dimsizes(1)) then + call error("character buffer is too small; increase length: "//trim(append_error_msg)) + endif + buf = "" + do i = 1, dimsizes(1) + if (charbuf(i) .eq. char(0)) then + exit + endif + buf(i:i) = charbuf(i) + enddo + deallocate(charbuf) + deallocate(dimsizes) +end subroutine char_read_0d + +!> @brief Character read 1d function. +subroutine char_read_1d(fileobj, variable_name, buf, c, append_error_msg, err, varid) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), dimension(:), intent(inout) :: buf !< Array that the data + !! will be read into. + integer, dimension(2), intent(in) :: c + character(len=200), intent(in) :: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer :: ndims + integer, dimension(2) :: start + integer, dimension(2) :: dimsizes + character, dimension(:,:), allocatable :: charbuf + character(len=1024) :: sbuf + integer :: i + integer :: j + + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + if (ndims .ne. 2) then + call error(trim(variable_name)//"must be 2d dimensional in netcdf file.") + endif + start(1) = 1 + start(2) = c(1) + call get_variable_size(fileobj, variable_name, dimsizes, .false.) + dimsizes(2) = dimsizes(2) - start(2) + 1 + call allocate_array(charbuf, dimsizes, initialize=.true.) + err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + if (len(buf(1)) .lt. dimsizes(1)) then + call error("character buffer is too small; increase length: "//trim(append_error_msg)) + endif + if (size(buf) .lt. dimsizes(2)) then + call error("incorrect buffer array size:: "//trim(append_error_msg)) + endif + do i = start(2), start(2)+dimsizes(2)-1 + sbuf = "" + do j = 1, dimsizes(1) + if (charbuf(j, i-start(2)+1) .eq. char(0)) then + exit + endif + sbuf(j:j) = charbuf(j, i-start(2)+1) + enddo + call string_copy(buf(i-start(2)+1), sbuf) + enddo + deallocate(charbuf) + +end subroutine char_read_1d + !> @brief Read in data from a variable in a netcdf file. subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & corner, broadcast) @@ -45,11 +141,6 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & integer :: varid integer :: unlim_dim_index integer, dimension(1) :: c - integer, dimension(2) :: start - integer :: ndims - character, dimension(:), allocatable :: charbuf - integer, dimension(:), allocatable :: dimsizes - integer :: i character(len=1024), dimension(1) :: buf1d character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message @@ -81,33 +172,7 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & type is (real(kind=r8_kind)) err = nf90_get_var(fileobj%ncid, varid, buf, start=c) type is (character(len=*)) - start(:) = 1 - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - allocate(dimsizes(ndims)) - call get_variable_size(fileobj, variable_name, dimsizes, broadcast=.false.) - allocate(charbuf(dimsizes(1))) - charbuf(:) = "" - if (ndims .eq. 2) then - if (present(corner)) then - start(2) = corner - endif - dimsizes(2) = 1 - elseif (ndims .gt. 2) then - call error("Only scalar and 1d string values are currently supported: "//trim(append_error_msg)) - endif - err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - if (len(buf) .lt. dimsizes(1)) then - call error("character buffer is too small; increase length: "//trim(append_error_msg)) - endif - buf = "" - do i = 1, dimsizes(1) - if (charbuf(i) .eq. char(0)) then - exit - endif - buf(i:i) = charbuf(i) - enddo - deallocate(charbuf) - deallocate(dimsizes) + call char_read_0d(fileobj, variable_name, buf, corner, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select @@ -165,13 +230,6 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, & integer :: unlim_dim_index integer, dimension(2) :: c integer, dimension(2) :: e - integer :: ndims - integer, dimension(2) :: start - integer, dimension(2) :: dimsizes - character, dimension(:,:), allocatable :: charbuf - character(len=1024) :: sbuf - integer :: i - integer :: j character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message append_error_msg = "netcdf_read_data_1d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name) @@ -211,34 +269,7 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, & type is (real(kind=r8_kind)) err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e) type is (character(len=*)) - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - if (ndims .ne. 2) then - call error(trim(variable_name)//"must be 2d dimensional in netcdf file.") - endif - start(1) = 1 - start(2) = c(1) - call get_variable_size(fileobj, variable_name, dimsizes, .false.) - dimsizes(2) = dimsizes(2) - start(2) + 1 - call allocate_array(charbuf, dimsizes) - charbuf(:,:) = "" - err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - if (len(buf(1)) .lt. dimsizes(1)) then - call error("character buffer is too small; increase length: "//trim(append_error_msg)) - endif - if (size(buf) .lt. dimsizes(2)) then - call error("incorrect buffer array size:: "//trim(append_error_msg)) - endif - do i = start(2), start(2)+dimsizes(2)-1 - sbuf = "" - do j = 1, dimsizes(1) - if (charbuf(j, i-start(2)+1) .eq. char(0)) then - exit - endif - sbuf(j:j) = charbuf(j, i-start(2)+1) - enddo - call string_copy(buf(i-start(2)+1), sbuf) - enddo - deallocate(charbuf) + call char_read_1d(fileobj, variable_name, buf, c, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select diff --git a/fms2_io/include/netcdf_write_data.inc b/fms2_io/include/netcdf_write_data.inc index 22e3d11b67..0c5748bf3b 100644 --- a/fms2_io/include/netcdf_write_data.inc +++ b/fms2_io/include/netcdf_write_data.inc @@ -23,6 +23,94 @@ !> @addtogroup netcdf_io_mod !> @{ +!> @brief Character write 0d function. +subroutine char_write_0d(fileobj, variable_name, variable_data, append_error_msg, err, varid) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), intent(in) :: variable_data !< Data that will be written. + character(len=200), intent(in) :: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer :: ndims + integer, dimension(:), allocatable :: start + integer, dimension(:), allocatable :: dimsizes + character, dimension(:), allocatable :: charbuf + integer :: i + integer :: tlen + + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + if (ndims .ne. 1) then + call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) + endif + allocate(start(ndims)) + start(:) = 1 + allocate(dimsizes(ndims)) + call get_variable_size(fileobj, variable_name, dimsizes, .false.) + call allocate_array(charbuf, dimsizes) + charbuf(:) = "" + tlen = len_trim(variable_data) + if (tlen .gt. dimsizes(1)) then + call error("character buffer is too big; decrease length: "//trim(append_error_msg)) + endif + do i = 1, tlen + charbuf(i) = variable_data(i:i) + enddo + err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + deallocate(charbuf) + deallocate(dimsizes) + deallocate(start) +end subroutine char_write_0d + +!> @brief Character write 1d function. +subroutine character_write_1d(fileobj, variable_name, variable_data, append_error_msg, err, varid) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), dimension(:), intent(in) :: variable_data !< Data that will be written. + character(len=200), intent(in) :: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer :: ndims + integer, dimension(:), allocatable :: start + integer, dimension(:), allocatable :: dimsizes + character, dimension(:,:), allocatable :: charbuf + character(len=1024) :: sbuf + integer :: i + integer :: j + integer :: tlen + + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + if (ndims .ne. 2) then + call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) + endif + allocate(start(ndims)) + start(:) = 1 + allocate(dimsizes(ndims)) + call get_variable_size(fileobj, variable_name, dimsizes, .false.) + call allocate_array(charbuf, dimsizes) + charbuf(:,:) = "" + tlen = len(variable_data(1)) + if (tlen .gt. dimsizes(1)) then + call error("character buffer is too big; decrease length: "//trim(append_error_msg)) + endif + if (size(variable_data) .ne. dimsizes(2)) then + call error("incorrect size of variable_data array: "//trim(append_error_msg)) + endif + do j = 1, dimsizes(2) + call string_copy(sbuf, variable_data(j)) + do i = 1, tlen + charbuf(i,j) = sbuf(i:i) + enddo + enddo + err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + deallocate(charbuf) + deallocate(dimsizes) + deallocate(start) +end subroutine character_write_1d + !> @brief Write data to a variable in a netcdf file. subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim_level, & corner) @@ -40,12 +128,6 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim integer :: varid integer :: unlim_dim_index integer, dimension(1) :: c - integer :: ndims - integer, dimension(:), allocatable :: start - integer, dimension(:), allocatable :: dimsizes - character, dimension(:), allocatable :: charbuf - integer :: i - integer :: tlen character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message append_error_msg = "netcdf_write_data_0d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name) @@ -74,27 +156,7 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim type is (real(kind=r8_kind)) err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c) type is (character(len=*)) - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - if (ndims .ne. 1) then - call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) - endif - allocate(start(ndims)) - start(:) = 1 - allocate(dimsizes(ndims)) - call get_variable_size(fileobj, variable_name, dimsizes, .false.) - call allocate_array(charbuf, dimsizes) - charbuf(:) = "" - tlen = len_trim(variable_data) - if (tlen .gt. dimsizes(1)) then - call error("character buffer is too big; decrease length: "//trim(append_error_msg)) - endif - do i = 1, tlen - charbuf(i) = variable_data(i:i) - enddo - err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - deallocate(charbuf) - deallocate(dimsizes) - deallocate(start) + call char_write_0d(fileobj, variable_name, variable_data, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select @@ -125,14 +187,6 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim integer :: unlim_dim_index integer, dimension(2) :: c integer, dimension(2) :: e - integer :: ndims - integer, dimension(:), allocatable :: start - integer, dimension(:), allocatable :: dimsizes - character, dimension(:,:), allocatable :: charbuf - character(len=1024) :: sbuf - integer :: i - integer :: j - integer :: tlen character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message append_error_msg = "netcdf_write_data_1d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name) @@ -168,33 +222,7 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim type is (real(kind=r8_kind)) err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e) type is (character(len=*)) - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - if (ndims .ne. 2) then - call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) - endif - allocate(start(ndims)) - start(:) = 1 - allocate(dimsizes(ndims)) - call get_variable_size(fileobj, variable_name, dimsizes, .false.) - call allocate_array(charbuf, dimsizes) - charbuf(:,:) = "" - tlen = len(variable_data(1)) - if (tlen .gt. dimsizes(1)) then - call error("character buffer is too big; decrease length: "//trim(append_error_msg)) - endif - if (size(variable_data) .ne. dimsizes(2)) then - call error("incorrect size of variable_data array: "//trim(append_error_msg)) - endif - do j = 1, dimsizes(2) - call string_copy(sbuf, variable_data(j)) - do i = 1, tlen - charbuf(i,j) = sbuf(i:i) - enddo - enddo - err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - deallocate(charbuf) - deallocate(dimsizes) - deallocate(start) + call character_write_1d(fileobj, variable_name, variable_data, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select diff --git a/mosaic2/mosaic2.F90 b/mosaic2/mosaic2.F90 index ed225a07d2..9cb4584178 100644 --- a/mosaic2/mosaic2.F90 +++ b/mosaic2/mosaic2.F90 @@ -290,11 +290,26 @@ subroutine get_mosaic_contact( fileobj, tile1, tile2, istart1, iend1, jstart1, j ntiles = get_mosaic_ntiles(fileobj) allocate(gridtiles(ntiles)) + if(mpp_pe()==mpp_root_pe()) then + do n = 1, ntiles + do m = 1,MAX_NAME + gridtiles(n)(m:m) = " " + enddo + enddo + endif call read_data(fileobj, 'gridtiles', gridtiles) ncontacts = get_mosaic_ncontacts(fileobj) if(ncontacts>0) then allocate(contacts(ncontacts), contacts_index(ncontacts)) + if(mpp_pe()==mpp_root_pe()) then + do n = 1, ncontacts + do m = 1,MAX_NAME + contacts(n)(m:m) = " " + contacts_index(n)(m:m) = " " + enddo + enddo + endif call read_data(fileobj, "contacts", contacts) call read_data(fileobj, "contact_index", contacts_index) endif From 16d71a27c5948b972c7a63f9ee2ce61661d6db48 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 16 Jun 2023 16:07:50 -0400 Subject: [PATCH 005/394] fix: improve error messages in fms2_io (#1183) --- fms2_io/fms_netcdf_domain_io.F90 | 4 ++-- fms2_io/netcdf_io.F90 | 8 +++++--- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/fms2_io/fms_netcdf_domain_io.F90 b/fms2_io/fms_netcdf_domain_io.F90 index 57e61800c5..f592bd24c7 100644 --- a/fms2_io/fms_netcdf_domain_io.F90 +++ b/fms2_io/fms_netcdf_domain_io.F90 @@ -369,7 +369,7 @@ function open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, do !Get the path of a "distributed" file. io_domain => mpp_get_io_domain(domain) if (.not. associated(io_domain)) then - call error("The domain associated with the file:"//trim(fileobj%path)//" does not have an io_domain.") + call error("The domain associated with the file:"//trim(path)//" does not have an io_domain.") endif if (io_layout(1)*io_layout(2) .gt. 1) then tile_id = mpp_get_tile_id(io_domain) @@ -393,7 +393,7 @@ function open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, do success2 = netcdf_file_open(fileobj2, combined_filepath, mode, nc_format, pelist, & is_restart, dont_add_res_to_filename) if (success2) then - call error("The domain decomposed file:"//trim(fileobj%path)// & + call error("The domain decomposed file:"//trim(path)// & & " contains both combined (*.nc) and distributed files (*.nc.XXXX).") endif endif diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index b76042900a..15bd0cdeff 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -924,7 +924,7 @@ subroutine netcdf_add_variable(fileobj, variable_name, variable_type, dimensions integer :: i character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message - append_error_msg = "netcdf_add_variable: file:"//trim(fileobj%path)//"variable:"//trim(variable_name) + append_error_msg = "netcdf_add_variable: file:"//trim(fileobj%path)//" variable:"//trim(variable_name) if (fileobj%is_root) then call set_netcdf_mode(fileobj%ncid, define_mode) @@ -1057,7 +1057,8 @@ subroutine netcdf_save_restart(fileobj, unlim_dim_level) integer :: i if (.not. fileobj%is_restart) then - call error("file "//trim(fileobj%path)//" is not a restart file.") + call error("write_restart:: file "//trim(fileobj%path)//" is not a restart file."& + &" Be sure the file was opened with is_restart=.true.") endif do i = 1, fileobj%num_restart_vars if (associated(fileobj%restart_vars(i)%data0d)) then @@ -1098,7 +1099,8 @@ subroutine netcdf_restore_state(fileobj, unlim_dim_level) integer :: i if (.not. fileobj%is_restart) then - call error("file "//trim(fileobj%path)//" is not a restart file.") + call error("read_restart:: file "//trim(fileobj%path)//" is not a restart file."& + &" Be sure the file was opened with is_restart=.true.") endif do i = 1, fileobj%num_restart_vars if (associated(fileobj%restart_vars(i)%data0d)) then From 22c498ea613fe6290094cc829966411872c9241a Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 16 Jun 2023 17:00:43 -0400 Subject: [PATCH 006/394] feat: fms2_io unpack data (#1231) --- amip_interp/amip_interp.F90 | 5 +- fms2_io/Makefile.am | 5 +- fms2_io/include/netcdf_read_data.inc | 6 + fms2_io/include/unpack_data.inc | 286 +++++++++++++++++++++++++ fms2_io/netcdf_io.F90 | 1 + test_fms/fms2_io/Makefile.am | 4 +- test_fms/fms2_io/test_packed_reads.F90 | 198 +++++++++++++++++ 7 files changed, 501 insertions(+), 4 deletions(-) create mode 100644 fms2_io/include/unpack_data.inc create mode 100644 test_fms/fms2_io/test_packed_reads.F90 diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index 98914feaa3..d276052369 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -1353,7 +1353,10 @@ subroutine read_record (type, Date, Adate, dat) else call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) endif - idat = nint(dat, I2_KIND) ! reconstruct packed data for reproducibility + !TODO This assumes that the data is "packed" (has the scale_factor and add_offset attributes) + ! in fms2_io_read_data the data is unpacked (data_in_file*scale_factor + add_offset) + ! the line below "packs" the data again. This is needed for reproducibility + idat = nint(dat*100., I2_KIND) !---- unpacking of data ---- diff --git a/fms2_io/Makefile.am b/fms2_io/Makefile.am index c186d76678..3938fa4e71 100644 --- a/fms2_io/Makefile.am +++ b/fms2_io/Makefile.am @@ -54,7 +54,8 @@ libfms2_io_la_SOURCES = \ include/register_variable_attribute.inc \ include/unstructured_domain_write.inc \ include/gather_data_bc.inc \ - include/scatter_data_bc.inc + include/scatter_data_bc.inc \ + include/unpack_data.inc # Some mods are dependant on other mods in this dir. fms2_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) netcdf_io_mod.$(FC_MODEXT) fms_netcdf_domain_io_mod.$(FC_MODEXT) \ @@ -65,7 +66,7 @@ netcdf_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) include/netcdf_add_res include/netcdf_write_data.inc include/register_global_attribute.inc \ include/register_variable_attribute.inc include/get_global_attribute.inc \ include/get_variable_attribute.inc include/compressed_write.inc include/compressed_read.inc \ - include/gather_data_bc.inc include/scatter_data_bc.inc + include/gather_data_bc.inc include/scatter_data_bc.inc include/unpack_data.inc fms_netcdf_domain_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) netcdf_io_mod.$(FC_MODEXT) include/register_domain_restart_variable.inc \ include/domain_read.inc include/domain_write.inc include/compute_global_checksum.inc fms_netcdf_unstructured_domain_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) netcdf_io_mod.$(FC_MODEXT) \ diff --git a/fms2_io/include/netcdf_read_data.inc b/fms2_io/include/netcdf_read_data.inc index 66c1484f29..4bfd427970 100644 --- a/fms2_io/include/netcdf_read_data.inc +++ b/fms2_io/include/netcdf_read_data.inc @@ -177,6 +177,7 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_0d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -274,6 +275,7 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_1d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -367,6 +369,7 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_2d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -458,6 +461,7 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_3d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -549,6 +553,7 @@ subroutine netcdf_read_data_4d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_4d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -640,6 +645,7 @@ subroutine netcdf_read_data_5d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_5d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) diff --git a/fms2_io/include/unpack_data.inc b/fms2_io/include/unpack_data.inc new file mode 100644 index 0000000000..c3695c4793 --- /dev/null +++ b/fms2_io/include/unpack_data.inc @@ -0,0 +1,286 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!> @brief Routines for the @ref gather_data_bc interface + +!> @addtogroup netcdf_io_mod +!> @{ +subroutine unpack_data_0d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_1d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_2d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_3d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_4d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:,:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_5d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:,:,:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 15bd0cdeff..b66c6f0526 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -2001,6 +2001,7 @@ end subroutine compressed_start_and_count include "compressed_read.inc" include "scatter_data_bc.inc" include "gather_data_bc.inc" +include "unpack_data.inc" !> @brief Wrapper to distinguish interfaces. function netcdf_file_open_wrap(fileobj, path, mode, nc_format, pelist, is_restart, dont_add_res_to_filename) & diff --git a/test_fms/fms2_io/Makefile.am b/test_fms/fms2_io/Makefile.am index ee4fddbc0e..aa94b0c342 100644 --- a/test_fms/fms2_io/Makefile.am +++ b/test_fms/fms2_io/Makefile.am @@ -30,7 +30,8 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_get_is_valid test_file_appendix test_fms2_io test_atmosphere_io test_io_simple test_io_with_mask test_global_att \ - test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes test_domain_io test_compressed_writes + test_packed_reads test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes \ + test_domain_io test_compressed_writes # This is the source code for the test. test_get_is_valid_SOURCES = test_get_is_valid.F90 @@ -49,6 +50,7 @@ test_read_ascii_file_SOURCES=test_read_ascii_file.F90 test_file_appendix_SOURCES=test_file_appendix.F90 test_unlimit_compressed_SOURCES=test_unlimit_compressed.F90 test_chunksizes_SOURCES = test_chunksizes.F90 +test_packed_reads_SOURCES = test_packed_reads.F90 test_compressed_writes_SOURCES = test_compressed_writes.F90 test_domain_io_SOURCES = test_domain_io.F90 diff --git a/test_fms/fms2_io/test_packed_reads.F90 b/test_fms/fms2_io/test_packed_reads.F90 new file mode 100644 index 0000000000..bc2a1206a5 --- /dev/null +++ b/test_fms/fms2_io/test_packed_reads.F90 @@ -0,0 +1,198 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +program test_packed_reads + use fms_mod, only: fms_init, fms_end + use platform_mod, only: r8_kind, r4_kind, i8_kind + use mpp_mod, only: mpp_error, FATAL, mpp_chksum + use fms2_io_mod, only: open_file, close_file, FmsNetcdfFile_t, read_data + use netcdf + + implicit none + + real(kind=r8_kind) :: var_r8(10, 1, 1, 1, 1) !< original r8 data + real(kind=r8_kind) :: var_r8_out(10, 1, 1, 1, 1) !< expected r8 data + real(kind=r8_kind) :: var_r8_out2(10, 1, 1, 1, 1) !< r8 data from file + real(kind=r8_kind) :: scale_factor_r8 !< r8 scale factor + real(kind=r8_kind) :: add_offset_r8 !< r8 offset + + real(kind=r4_kind) :: var_r4(10, 1, 1, 1, 1) !< original r4 data + real(kind=r4_kind) :: var_r4_out(10, 1, 1, 1, 1) !< expected r4 data + real(kind=r4_kind) :: var_r4_out2(10, 1, 1, 1, 1) !< r4 data from file + real(kind=r4_kind) :: scale_factor_r4 !< r4 scale factor + real(kind=r4_kind) :: add_offset_r4 !< r4 offset + + type(FmsNetcdfFile_t) :: fileobj !< Fms2_io fileobj + + integer(2) :: packed_data_r8(10, 1, 1, 1, 1) !< Packed data calculated from r8 + integer(2) :: packed_data_r4(10, 1, 1, 1, 1) !< Packed data calculated from r4 + + integer :: ncid !< netcdf file id + integer :: varid1_r8, varid2_r8, varid3_r8, varid4_r8, varid5_r8 !< Variable ids + integer :: varid1_r4, varid2_r4, varid3_r4, varid4_r4, varid5_r4 !< variable ids + integer :: dimid1, dimid2, dimid3, dimid4, dimid5 !< Dimension ids + integer :: dim(5) !< Array of dimension ids + integer :: i !< For do loops + integer :: err !< netcdf error code + + call fms_init() + + do i = 1, size(var_r4, 1) + var_r4(i,:,:,:,:) = 90_r4_kind - real(i, kind=r4_kind)/13_r4_kind + real(i, kind=r4_kind) + var_r8(i,:,:,:,:) = 90_r8_kind - real(i, kind=r8_kind)/13_r8_kind + real(i, kind=r8_kind) + enddo + + scale_factor_r4 = real((maxval(var_r4) - minval(var_r4)) / (2**(16-1)), kind=r4_kind) + add_offset_r4 = real(minval(var_r4) + 2 ** (16 - 1) * scale_factor_r4, kind=r4_kind) + packed_data_r4 = nint((var_r4 - add_offset_r4) / scale_factor_r4, kind=2) + var_r4_out = packed_data_r4*scale_factor_r4 + add_offset_r4 + + scale_factor_r8 = real((maxval(var_r8) - minval(var_r8)) / (2**(16-1)), kind=r8_kind) + add_offset_r8 = real(minval(var_r8) + 2 ** (16 - 1) * scale_factor_r8, kind=r8_kind) + packed_data_r8 = nint((var_r8 - add_offset_r8) / scale_factor_r8, kind=2) + var_r8_out = packed_data_r8*scale_factor_r8 + add_offset_r8 + + err = nf90_create("short_file.nc", ior(nf90_clobber, nf90_64bit_offset), ncid) + err = nf90_def_dim(ncid, 'dim1', 10, dimid1) + err = nf90_def_dim(ncid, 'dim2', 1, dimid2) + err = nf90_def_dim(ncid, 'dim3', 1, dimid3) + err = nf90_def_dim(ncid, 'dim4', 1, dimid4) + err = nf90_def_dim(ncid, 'dim5', 1, dimid5) + + dim = (/dimid1, dimid2, dimid3, dimid4, dimid5/) + + call write_var_metadata(ncid, 'var_1d', dim(1:1), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid1_r8, varid1_r4) + call write_var_metadata(ncid, 'var_2d', dim(1:2), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid2_r8, varid2_r4) + call write_var_metadata(ncid, 'var_3d', dim(1:3), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid3_r8, varid3_r4) + call write_var_metadata(ncid, 'var_4d', dim(1:4), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid4_r8, varid4_r4) + call write_var_metadata(ncid, 'var_5d', dim(1:5), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid5_r8, varid5_r4) + + call check(nf90_enddef(ncid)) + + call check(nf90_put_var(ncid, varid1_r8, packed_data_r8(:,1,1,1,1))) + call check(nf90_put_var(ncid, varid2_r8, packed_data_r8(:,:,1,1,1))) + call check(nf90_put_var(ncid, varid3_r8, packed_data_r8(:,:,:,1,1))) + call check(nf90_put_var(ncid, varid4_r8, packed_data_r8(:,:,:,:,1))) + call check(nf90_put_var(ncid, varid5_r8, packed_data_r8(:,:,:,:,:))) + + call check(nf90_put_var(ncid, varid1_r4, packed_data_r4(:,1,1,1,1))) + call check(nf90_put_var(ncid, varid2_r4, packed_data_r4(:,:,1,1,1))) + call check(nf90_put_var(ncid, varid3_r4, packed_data_r4(:,:,:,1,1))) + call check(nf90_put_var(ncid, varid4_r4, packed_data_r4(:,:,:,:,1))) + call check(nf90_put_var(ncid, varid5_r4, packed_data_r4(:,:,:,:,:))) + + call check(nf90_close(ncid)) + + if (open_file(fileobj, "short_file.nc", "read")) then + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_1d_r8", var_r8_out2(:,1,1,1,1)) + call compare_data(mpp_chksum(var_r8_out2(:,1,1,1,1)), mpp_chksum(var_r8_out(:,1,1,1,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_2d_r8", var_r8_out2(:,:,1,1,1)) + call compare_data(mpp_chksum(var_r8_out2(:,:,1,1,1)), mpp_chksum(var_r8_out(:,:,1,1,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_3d_r8", var_r8_out2(:,:,:,1,1)) + call compare_data(mpp_chksum(var_r8_out2(:,:,:,1,1)), mpp_chksum(var_r8_out(:,:,:,1,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_4d_r8", var_r8_out2(:,:,:,:,1)) + call compare_data(mpp_chksum(var_r8_out2(:,:,:,:,1)), mpp_chksum(var_r8_out(:,:,:,:,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_5d_r8", var_r8_out2(:,:,:,:,:)) + call compare_data(mpp_chksum(var_r8_out2(:,:,:,:,:)), mpp_chksum(var_r8_out(:,:,:,:,:)), "var_1d_r8") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_1d_r4", var_r4_out2(:,1,1,1,1)) + call compare_data(mpp_chksum(var_r4_out2(:,1,1,1,1)), mpp_chksum(var_r4_out(:,1,1,1,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_2d_r4", var_r4_out2(:,:,1,1,1)) + call compare_data(mpp_chksum(var_r4_out2(:,:,1,1,1)), mpp_chksum(var_r4_out(:,:,1,1,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_3d_r4", var_r4_out2(:,:,:,1,1)) + call compare_data(mpp_chksum(var_r4_out2(:,:,:,1,1)), mpp_chksum(var_r4_out(:,:,:,1,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_4d_r4", var_r4_out2(:,:,:,:,1)) + call compare_data(mpp_chksum(var_r4_out2(:,:,:,:,1)), mpp_chksum(var_r4_out(:,:,:,:,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_5d_r4", var_r4_out2(:,:,:,:,:)) + call compare_data(mpp_chksum(var_r4_out2(:,:,:,:,:)), mpp_chksum(var_r4_out(:,:,:,:,:)), "var_1d_r4") + + + call close_file(fileobj) + endif + + call fms_end() + + contains + + !> @brief Write out the variable data + subroutine write_var_metadata(fileid, varname, dimids, sfactor_r4, sfactor_r8, & + offset_r4, offset_r8, varid_r4, varid_r8) + integer, intent(in) :: fileid !< netcdf file id + character(len=*), intent(in) :: varname !< variable name + integer, intent(in) :: dimids(:) !< array of the dimension ids + real(kind=r4_kind), intent(in) :: sfactor_r4 !< Scale factor in r4 precision + real(kind=r8_kind), intent(in) :: sfactor_r8 !< Scale factor in r8 precision + real(kind=r4_kind), intent(in) :: offset_r4 !< offset in r4 precision + real(kind=r8_kind), intent(in) :: offset_r8 !< offset in r8 precision + integer, intent(out) :: varid_r4 !< variable id for the r4 variable + integer, intent(out) :: varid_r8 !< variable id for the r8 variable + + call check(nf90_def_var(ncid, trim(varname)//"_r4", nf90_short, dimids, varid_r4)) + call check(nf90_put_att(ncid, varid_r4, "scale_factor", sfactor_r4)) + call check(nf90_put_att(ncid, varid_r4, "add_offset", offset_r4)) + + call check(nf90_def_var(ncid, trim(varname)//"_r8", nf90_short, dimids, varid_r8)) + call check(nf90_put_att(ncid, varid_r8, "scale_factor", sfactor_r8)) + call check(nf90_put_att(ncid, varid_r8, "add_offset", offset_r8)) + + end subroutine write_var_metadata + + !> @brief Compare two checksums + subroutine compare_data(checksum_in, checksum_out, varname) + integer(kind=i8_kind), intent(in) :: checksum_in !< The data checksum + integer(kind=i8_kind), intent(in) :: checksum_out !< The reference checksum + character(len=*), intent(in) :: varname !< The variable's name (for error messages) + + if (checksum_in .ne. checksum_out) call mpp_error(FATAL, & + "Checksums do not match for variable: "//trim(varname)) + end subroutine + + !> @brief Check the netcdf error code + subroutine check(status) + integer, intent ( in) :: status !< netcdf error code + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop "Stopped" + end if + end subroutine check + +end program test_packed_reads From cf5035f5e5410ebfdeed9c11fdc0e326da66d91b Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Tue, 20 Jun 2023 11:31:22 -0400 Subject: [PATCH 007/394] fix: improve doxygen comment for `tranlon` (#1257) --- axis_utils/include/axis_utils2.inc | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index 53707fcf78..21deca9fb4 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -165,28 +165,27 @@ end function LON_IN_RANGE_ - !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360. + !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) < lon_strt+360. !! - !>
The first istrt-1 entries are moved to the end of the array: + !! This may require that entries be moved from the beginning of the array to + !! the end. If no entries are moved (i.e., if lon(:) is already monotonic in + !! the range from lon_start to lon_start + 360), then istrt is set to 0. If + !! any entries are moved, then istrt is set to the original index of the entry + !! which becomes lon(1). !! - !! e.g. - !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - !! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + !! e.g., + !! + !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 + !! ==> lon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + !! + !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 0 + !! ==> lon = 0 1 2 3 4 5 ... 358 359; istrt = 0 subroutine TRANLON_(lon, lon_start, istrt) - - ! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360. - ! also, the first istrt-1 entries are moved to the end of the array - ! - ! e.g. - ! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - ! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 - real(kind=FMS_AU_KIND_), intent(inout), dimension(:) :: lon real(kind=FMS_AU_KIND_), intent(in) :: lon_start integer, intent(out) :: istrt - integer :: len, i real(kind=FMS_AU_KIND_) :: lon_strt, tmp(size(lon(:))-1) From ecc1361680b4ade6a5db60a1e7ef024e944c8fac Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Tue, 20 Jun 2023 13:35:31 -0400 Subject: [PATCH 008/394] fix: ifort 2022.3.0 & greater ICE bug in alltoall test + missing input nmls in mpp scripts (#1158) --- test_fms/mpp/Makefile.am | 6 ++++++ test_fms/mpp/test_clock_init.sh | 3 +++ test_fms/mpp/test_global_arrays.sh | 3 +++ test_fms/mpp/test_mpp_alltoall.sh | 3 +++ test_fms/mpp/test_mpp_global_sum_ad.sh | 3 +++ test_fms/mpp/test_mpp_npes.sh | 3 +++ test_fms/mpp/test_mpp_pe.sh | 2 ++ test_fms/mpp/test_mpp_root_pe.sh | 3 +++ test_fms/mpp/test_mpp_sum.sh | 3 +++ test_fms/mpp/test_mpp_transmit.sh | 3 +++ test_fms/mpp/test_stderr.sh | 3 +++ test_fms/mpp/test_stdin.sh | 3 +++ test_fms/mpp/test_stdout.sh | 3 +++ test_fms/mpp/test_system_clock.sh | 3 +++ test_fms/mpp/test_update_domains_performance.sh | 4 ++++ 15 files changed, 48 insertions(+) diff --git a/test_fms/mpp/Makefile.am b/test_fms/mpp/Makefile.am index 66f12d9d1e..1d44b9bc93 100644 --- a/test_fms/mpp/Makefile.am +++ b/test_fms/mpp/Makefile.am @@ -134,6 +134,12 @@ test_mpp_clock_begin_end_id_SOURCES=test_mpp_clock_begin_end_id.F90 test_super_grid_SOURCES = test_super_grid.F90 test_mpp_chksum_SOURCES = test_mpp_chksum.F90 +# ifort gets a internal error during compilation for this test, issue #1071 +# we'll just remove the openmp flag if present since it doesn't use openmp at all +test_mpp_alltoall.$(OBJEXT): FCFLAGS:= $(filter-out -fopenmp,$(FCFLAGS)) +test_mpp_alltoall.$(OBJEXT): CPPFLAGS:= $(filter-out -fopenmp,$(CPPFLAGS)) + + # Run the test programs. TESTS = test_mpp_domains2.sh \ test_redistribute_int.sh \ diff --git a/test_fms/mpp/test_clock_init.sh b/test_fms/mpp/test_clock_init.sh index 93b29c4172..7ce49da379 100755 --- a/test_fms/mpp/test_clock_init.sh +++ b/test_fms/mpp/test_clock_init.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "clock initialization" ' mpirun -n 1 ./test_clock_init ' diff --git a/test_fms/mpp/test_global_arrays.sh b/test_fms/mpp/test_global_arrays.sh index dc5cbce9ee..596d1ecb0a 100755 --- a/test_fms/mpp/test_global_arrays.sh +++ b/test_fms/mpp/test_global_arrays.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "global array functions with mixed precision" ' mpirun -n 8 ./test_global_arrays ' diff --git a/test_fms/mpp/test_mpp_alltoall.sh b/test_fms/mpp/test_mpp_alltoall.sh index f54dcde599..c186b11efb 100755 --- a/test_fms/mpp/test_mpp_alltoall.sh +++ b/test_fms/mpp/test_mpp_alltoall.sh @@ -26,6 +26,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for one processor test_expect_success "mpp all-to-all with mixed precision" ' mpirun -n 4 ./test_mpp_alltoall diff --git a/test_fms/mpp/test_mpp_global_sum_ad.sh b/test_fms/mpp/test_mpp_global_sum_ad.sh index 8c5b1b6cc2..71296789f7 100755 --- a/test_fms/mpp/test_mpp_global_sum_ad.sh +++ b/test_fms/mpp/test_mpp_global_sum_ad.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test test_expect_success "mpp global adjoint sum with mixed precision" ' mpirun -n 4 ./test_mpp_global_sum_ad diff --git a/test_fms/mpp/test_mpp_npes.sh b/test_fms/mpp/test_mpp_npes.sh index 23295e4e29..edc3e4997d 100755 --- a/test_fms/mpp/test_mpp_npes.sh +++ b/test_fms/mpp/test_mpp_npes.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + export NUM_PES=1 test_expect_success "get number of PEs single processor" ' mpirun -n 1 ./test_mpp_npes diff --git a/test_fms/mpp/test_mpp_pe.sh b/test_fms/mpp/test_mpp_pe.sh index dde00bfd99..8936de1174 100755 --- a/test_fms/mpp/test_mpp_pe.sh +++ b/test_fms/mpp/test_mpp_pe.sh @@ -27,6 +27,8 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml # Run the tests test_expect_success "get current PE single processor" ' diff --git a/test_fms/mpp/test_mpp_root_pe.sh b/test_fms/mpp/test_mpp_root_pe.sh index 23cd707a71..7970004172 100755 --- a/test_fms/mpp/test_mpp_root_pe.sh +++ b/test_fms/mpp/test_mpp_root_pe.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test test_expect_success "get correct root PE single processor" ' mpirun -n 1 ./test_mpp_root_pe diff --git a/test_fms/mpp/test_mpp_sum.sh b/test_fms/mpp/test_mpp_sum.sh index bd90ecb17a..fa00ea1e23 100755 --- a/test_fms/mpp/test_mpp_sum.sh +++ b/test_fms/mpp/test_mpp_sum.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for 5 processors test_expect_success "mpp_sum with mixed precision" ' mpirun -n 5 ./test_mpp_sum diff --git a/test_fms/mpp/test_mpp_transmit.sh b/test_fms/mpp/test_mpp_transmit.sh index a1c4483590..77f610f091 100755 --- a/test_fms/mpp/test_mpp_transmit.sh +++ b/test_fms/mpp/test_mpp_transmit.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for 5 processors test_expect_success "mpp transmit with mixed precision" ' mpirun -n 6 ./test_mpp_transmit diff --git a/test_fms/mpp/test_stderr.sh b/test_fms/mpp/test_stderr.sh index ebf8adc222..25f8190b65 100755 --- a/test_fms/mpp/test_stderr.sh +++ b/test_fms/mpp/test_stderr.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "get stderr" ' mpirun -n 1 ./test_stderr ' diff --git a/test_fms/mpp/test_stdin.sh b/test_fms/mpp/test_stdin.sh index f13d38df28..0a8df299dc 100755 --- a/test_fms/mpp/test_stdin.sh +++ b/test_fms/mpp/test_stdin.sh @@ -26,6 +26,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "correct STDIN writes" ' mpirun -n 1 ./test_stdin ' diff --git a/test_fms/mpp/test_stdout.sh b/test_fms/mpp/test_stdout.sh index 67befda83b..ddce1baf2a 100755 --- a/test_fms/mpp/test_stdout.sh +++ b/test_fms/mpp/test_stdout.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run test with one processor test_expect_success "get stdout with 1 PE" ' mpirun -n 2 ./test_stdout diff --git a/test_fms/mpp/test_system_clock.sh b/test_fms/mpp/test_system_clock.sh index cdc620adaa..0cf357e824 100755 --- a/test_fms/mpp/test_system_clock.sh +++ b/test_fms/mpp/test_system_clock.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for one processor test_expect_success "system clock functionality" ' mpirun -n 1 ./test_system_clock diff --git a/test_fms/mpp/test_update_domains_performance.sh b/test_fms/mpp/test_update_domains_performance.sh index 9efd622b61..36303abd53 100755 --- a/test_fms/mpp/test_update_domains_performance.sh +++ b/test_fms/mpp/test_update_domains_performance.sh @@ -26,6 +26,10 @@ # Set common test settings. . ../test-lib.sh + +# ensure input.nml file present +touch input.nml + # Run the test for one processor test_expect_success "domain update performance with 1 PE" ' mpirun -n 1 ./test_update_domains_performance From 783019fdec89a8db2b26247c2f63d4782e1495c0 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 20 Jun 2023 13:37:04 -0400 Subject: [PATCH 009/394] fix: checks placed before allocating pointers passed into routines (#1152) --- exchange/xgrid.F90 | 69 ++++++++++++++++++--- mpp/include/mpp_define_nest_domains.inc | 16 +++++ mpp/include/mpp_domains_define.inc | 80 +++++++++++++++++++++++++ mpp/include/mpp_domains_util.inc | 4 ++ mpp/include/mpp_unstruct_domain.inc | 7 +++ 5 files changed, 169 insertions(+), 7 deletions(-) diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90 index 54a32ec8e2..63991a8059 100644 --- a/exchange/xgrid.F90 +++ b/exchange/xgrid.F90 @@ -1087,6 +1087,7 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u grid%x(1:size_prev) = x_local deallocate(x_local) else + if(ASSOCIATED(grid%x)) deallocate(grid%x) !< Check if allocated allocate( grid%x( grid%size ) ) grid%x%di = 0.0; grid%x%dj = 0.0 end if @@ -1248,6 +1249,7 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u grid%x_repro(1:ll_repro) = x_local deallocate(x_local) else + if(ASSOCIATED(grid%x_repro)) deallocate(grid%x_repro) !< Check if allocated allocate( grid%x_repro( grid%size_repro ) ) grid%x_repro%di = 0.0; grid%x_repro%dj = 0.0 end if @@ -1318,7 +1320,8 @@ subroutine get_grid_version1(grid, grid_id, grid_file) endif call mpp_get_compute_domain(grid%domain, is, ie, js, je) - + if (associated(grid%lon)) deallocate(grid%lon) !< Check if allocated + if (associated(grid%lat)) deallocate(grid%lat) !< Check if allocated allocate(grid%lon(grid%im), grid%lat(grid%jm)) if(grid_id == 'ATM') then call read_data(fileobj, 'xta', lonb) @@ -1413,6 +1416,8 @@ subroutine get_grid_version2(grid, grid_id, grid_file) start(2) = 2; nread(1) = nlon*2+1 allocate(tmpx(nlon*2+1, 1), tmpy(1, nlat*2+1)) call read_data(fileobj, "x", tmpx, corner=start, edge_lengths=nread) + if (associated(grid%lon)) deallocate(grid%lon) !< Check if allocated + if (associated(grid%lat)) deallocate(grid%lat) !< Check if allocated allocate(grid%lon(grid%im), grid%lat(grid%jm)) do i = 1, grid%im grid%lon(i) = tmpx(2*i,1) * d2r @@ -1425,6 +1430,8 @@ subroutine get_grid_version2(grid, grid_id, grid_file) end do grid%is_latlon = .true. else + if (associated(grid%geolon)) deallocate(grid%geolon) !< Check if allocated + if (associated(grid%geolat)) deallocate(grid%geolat) !< Check if allocated allocate(grid%geolon(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me)) allocate(grid%geolat(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me)) grid%geolon = 1e10 @@ -1545,8 +1552,12 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ xmap%npes = mpp_npes() xmap%root_pe = mpp_root_pe() + if (associated(xmap%grids)) deallocate(xmap%grids) !< Check if allocated allocate( xmap%grids(1:size(grid_ids(:))) ) + if (associated(xmap%your1my2)) deallocate(xmap%your1my2) !< Check if allocated + if (associated(xmap%your2my1)) deallocate(xmap%your2my1) !< Check if allocated + if (associated(xmap%your2my1_size)) deallocate(xmap%your2my1_size) !< Check if allocated allocate ( xmap%your1my2(0:xmap%npes-1), xmap%your2my1(0:xmap%npes-1) ) allocate ( xmap%your2my1_size(0:xmap%npes-1) ) @@ -1589,6 +1600,11 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ grid%id = grid_ids (g) grid%domain = grid_domains(g) grid%on_this_pe = mpp_domain_is_initialized(grid_domains(g)) + if (associated(grid%is)) deallocate(grid%is) !< Check if allocated + if (associated(grid%ie)) deallocate(grid%ie) !< Check if allocated + if (associated(grid%js)) deallocate(grid%js) !< Check if allocated + if (associated(grid%je)) deallocate(grid%je) !< Check if allocated + if (associated(grid%tile)) deallocate(grid%tile) !< Check if allocated allocate ( grid%is(0:xmap%npes-1), grid%ie(0:xmap%npes-1) ) allocate ( grid%js(0:xmap%npes-1), grid%je(0:xmap%npes-1) ) allocate ( grid%tile(0:xmap%npes-1) ) @@ -1679,6 +1695,10 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ 'does not support unstructured grid for VERSION1 grid' ,FATAL) grid%is_ug = .true. grid%ug_domain = lnd_ug_domain + if (associated(grid%ls)) deallocate(grid%ls) !< Check if allocated + if (associated(grid%le)) deallocate(grid%le) !< Check if allocated + if (associated(grid%gs)) deallocate(grid%gs) !< Check if allocated + if (associated(grid%ge)) deallocate(grid%ge) !< Check if allocated allocate ( grid%ls(0:xmap%npes-1), grid%le(0:xmap%npes-1) ) allocate ( grid%gs(0:xmap%npes-1), grid%ge(0:xmap%npes-1) ) grid%ls = 0 @@ -1695,6 +1715,7 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ grid%gs_me => grid%gs(xmap%me-xmap%root_pe); grid%ge_me => grid%ge(xmap%me-xmap%root_pe) grid%tile_me => grid%tile(xmap%me-xmap%root_pe) grid%nxl_me = grid%le_me - grid%ls_me + 1 + if (associated(grid%l_index)) deallocate(grid%l_index) !< Check if allocated allocate(grid%l_index(grid%gs_me:grid%ge_me)) allocate(grid_index(grid%ls_me:grid%le_me)) call mpp_get_UG_domain_grid_index(grid%ug_domain, grid_index) @@ -1705,6 +1726,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ enddo if( grid%on_this_pe ) then + if (associated(grid%area)) deallocate(grid%area) !< Check if allocated + if (associated(grid%area_inv)) deallocate(grid%area_inv) !< Check if allocated allocate( grid%area (grid%ls_me:grid%le_me,1) ) allocate( grid%area_inv(grid%ls_me:grid%le_me,1) ) grid%area = 0.0 @@ -1712,6 +1735,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ grid%size_repro = 0 endif else if( grid%on_this_pe ) then + if (associated(grid%area)) deallocate(grid%area) !< Check if allocated + if (associated(grid%area_inv)) deallocate(grid%area_inv) !< Check if allocated allocate( grid%area (grid%is_me:grid%ie_me, grid%js_me:grid%je_me) ) allocate( grid%area_inv(grid%is_me:grid%ie_me, grid%js_me:grid%je_me) ) grid%area = 0.0 @@ -1783,6 +1808,17 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlon', FATAL) if(size(atm_grid%vlat,1) .NE. 3 .OR. size(atm_grid%vlat,2) .NE. nxc .OR. size(atm_grid%vlat,3) .NE. nyc)& call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlat', FATAL) + if (associated(grid%box%dx)) deallocate(grid%box%dx) !< Check if allocated + if (associated(grid%box%dy)) deallocate(grid%box%dy) !< Check if allocated + if (associated(grid%box%area)) deallocate(grid%box%area) !< Check if allocated + if (associated(grid%box%edge_w)) deallocate(grid%box%edge_w) !< Check if allocated + if (associated(grid%box%edge_e)) deallocate(grid%box%edge_e) !< Check if allocated + if (associated(grid%box%edge_s)) deallocate(grid%box%edge_s) !< Check if allocated + if (associated(grid%box%edge_n)) deallocate(grid%box%edge_n) !< Check if allocated + if (associated(grid%box%en1)) deallocate(grid%box%en1) !< Check if allocated + if (associated(grid%box%en2)) deallocate(grid%box%en2) !< Check if allocated + if (associated(grid%box%vlon)) deallocate(grid%box%vlon) !< Check if allocated + if (associated(grid%box%vlat)) deallocate(grid%box%vlat) !< Check if allocated allocate(grid%box%dx (grid%is_me:grid%ie_me, grid%js_me:grid%je_me+1 )) allocate(grid%box%dy (grid%is_me:grid%ie_me+1, grid%js_me:grid%je_me )) allocate(grid%box%area (grid%is_me:grid%ie_me, grid%js_me:grid%je_me )) @@ -1811,6 +1847,7 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ if(xmap%version==VERSION2) call close_file(mosaicfileobj) if (g>1) then if(grid%on_this_pe) then + if (associated(grid%frac_area)) deallocate(grid%frac_area) !< Check if allocated if(grid%is_ug) then allocate( grid%frac_area(grid%ls_me:grid%le_me, 1, grid%km) ) else @@ -1939,6 +1976,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ xmap%your2my1(xmap%me-xmap%root_pe) = .false. ! a PE from communicating with itself if (make_exchange_reproduce) then + if (associated(xmap%send_count_repro)) deallocate(xmap%send_count_repro) !< Check if allocated + if (associated(xmap%recv_count_repro)) deallocate(xmap%recv_count_repro) !< Check if allocated allocate( xmap%send_count_repro(0:xmap%npes-1) ) allocate( xmap%recv_count_repro(0:xmap%npes-1) ) xmap%send_count_repro = 0 @@ -1960,12 +1999,18 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ xmap%recv_count_repro_tot = 0 end if + if (associated(xmap%x1)) deallocate(xmap%x1) !< Check if allocated + if (associated(xmap%x2)) deallocate(xmap%x2) !< Check if allocated + if (associated(xmap%x1_put)) deallocate(xmap%x1_put) !< Check if allocated + if (associated(xmap%x2_get)) deallocate(xmap%x2_get) !< Check if allocated allocate( xmap%x1(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) allocate( xmap%x2(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) allocate( xmap%x1_put(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) allocate( xmap%x2_get(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) !--- The following will setup indx to be used in regen + if (associated(xmap%get1)) deallocate(xmap%get1) !< Check if allocated + if (associated(xmap%put1)) deallocate(xmap%put1) !< Check if allocated allocate(xmap%get1, xmap%put1) call mpp_clock_begin(id_set_comm) @@ -1974,6 +2019,7 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ call set_comm_put1(xmap) if(make_exchange_reproduce) then + if (associated(xmap%get1_repro)) deallocate(xmap%get1_repro) !< Check if allocated allocate(xmap%get1_repro) call set_comm_get1_repro(xmap) endif @@ -2174,6 +2220,7 @@ subroutine set_comm_get1_repro(xmap) comm%nrecv = nrecv if( nrecv > 0 ) then + if (associated(comm%recv)) deallocate(comm%recv) !< Check if allocated allocate(comm%recv(nrecv)) pos = 0 do n = 1, nrecv @@ -2200,6 +2247,7 @@ subroutine set_comm_get1_repro(xmap) comm%nsend = nsend if( nsend > 0 ) then + if (associated(comm%send)) deallocate(comm%send) !< Check if allocated allocate(comm%send(nsend)) pos = 0 cnt(:) = 0 @@ -2296,6 +2344,7 @@ subroutine set_comm_get1(xmap) if(max_size > 0) then allocate(pe_side1(max_size)) + if (associated(xmap%ind_get1)) deallocate(xmap%ind_get1) !< Check if allocated allocate(xmap%ind_get1(max_size)) !--- find the recv_indx @@ -2399,6 +2448,7 @@ subroutine set_comm_get1(xmap) nsend = count( send_size> 0) comm%nsend = nsend if(nsend>0) then + if (associated(comm%send)) deallocate(comm%send) !< Check if allocated allocate(comm%send(nsend)) comm%send(:)%count = 0 endif @@ -2474,6 +2524,7 @@ subroutine set_comm_get1(xmap) comm%recvsize = 0 if(nrecv >0) then + if (associated(comm%recv)) deallocate(comm%recv) !< Check if allocated allocate(comm%recv(nrecv)) comm%recv(:)%count = 0 !--- set up the buffer pos for each receiving @@ -2526,6 +2577,7 @@ subroutine set_comm_get1(xmap) endif endif enddo + if (associated(comm%unpack_ind)) deallocate(comm%unpack_ind) !< Check if allocated allocate(comm%unpack_ind(nrecv)) pos = 0 do p = 0, npes-1 @@ -2604,6 +2656,7 @@ subroutine set_comm_put1(xmap) if(max_size > 0) then allocate(pe_put1(max_size)) + if (associated(xmap%ind_put1)) deallocate(xmap%ind_put1) !< Check if allocated allocate(xmap%ind_put1(max_size)) !--- find the recv_indx @@ -2724,6 +2777,7 @@ subroutine set_comm_put1(xmap) nrecv = count( send_size> 0) comm%nrecv = nrecv if(nrecv>0) then + if (associated(comm%recv)) deallocate(comm%recv) !< Check if allocated allocate(comm%recv(nrecv)) comm%recv(:)%count = 0 endif @@ -2798,6 +2852,7 @@ subroutine set_comm_put1(xmap) comm%sendsize = 0 if(nsend >0) then + if (associated(comm%send)) deallocate(comm%send) !< Check if allocated allocate(comm%send(nsend)) comm%send(:)%count = 0 pos = 0 @@ -2864,8 +2919,8 @@ subroutine regen(xmap) end do if (max_size>size(xmap%x1(:))) then - deallocate(xmap%x1) - deallocate(xmap%x2) + if (associated(xmap%x1)) deallocate(xmap%x1) !< Check x1 if allocated + if (associated(xmap%x2)) deallocate(xmap%x2) !< Check x2 if allocated allocate( xmap%x1(1:max_size) ) allocate( xmap%x2(1:max_size) ) endif @@ -2933,11 +2988,11 @@ subroutine regen(xmap) if (max_size>size(xmap%x1_put(:))) then - deallocate(xmap%x1_put) + if (associated(xmap%x1_put)) deallocate(xmap%x1_put) !< Check if allocated allocate( xmap%x1_put(1:max_size) ) endif if (max_size>size(xmap%x2_get(:))) then - deallocate(xmap%x2_get) + if (associated(xmap%x2_get)) deallocate(xmap%x2_get) !< Check if allocated allocate( xmap%x2_get(1:max_size) ) endif @@ -3067,7 +3122,7 @@ subroutine set_frac_area_sg(f, grid_id, xmap) grid => xmap%grids(g) if (grid_id==grid%id) then if (size(f,3)/=size(grid%frac_area,3)) then - deallocate (grid%frac_area) + if (associated(grid%frac_area)) deallocate (grid%frac_area) !< Check if allocated grid%km = size(f,3); allocate( grid%frac_area(grid%is_me:grid%ie_me, grid%js_me:grid%je_me, & grid%km) ) @@ -3101,7 +3156,7 @@ subroutine set_frac_area_ug(f, grid_id, xmap) grid => xmap%grids(g) if (grid_id==grid%id) then if (size(f,2)/=size(grid%frac_area,3)) then - deallocate (grid%frac_area) + if (associated(grid%frac_area)) deallocate (grid%frac_area) !< Check if allocated grid%km = size(f,2); allocate( grid%frac_area(grid%ls_me:grid%le_me, 1, grid%km) ) end if diff --git a/mpp/include/mpp_define_nest_domains.inc b/mpp/include/mpp_define_nest_domains.inc index cbcefd8927..e8eea60d00 100644 --- a/mpp/include/mpp_define_nest_domains.inc +++ b/mpp/include/mpp_define_nest_domains.inc @@ -196,6 +196,7 @@ subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, ti allocate(nest_domain%jstart_coarse(num_nest), nest_domain%jend_coarse(num_nest) ) !---Added to enable moving nests + if (associated(nest_domain%nest_level)) deallocate(nest_domain%nest_level) !< Check if allocated allocate(nest_domain%nest_level(num_nest)) nest_domain%tile_fine = tile_fine(1:num_nest) @@ -253,6 +254,7 @@ subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, ti enddo nest_domain%num_level = nlevels + if (associated(nest_domain%nest)) deallocate(nest_domain%nest) !< Check if allocated allocate(nest_domain%nest(nlevels)) allocate(pelist_level(mpp_npes())) allocate(is_nest_fine(nlevels)) @@ -297,6 +299,7 @@ subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, ti endif enddo + if (associated(nest_domain%nest(l)%pelist)) deallocate(nest_domain%nest(l)%pelist) !< Check if allocated allocate(nest_domain%nest(l)%pelist(npes_level)) nest_domain%nest(l)%pelist(:) = pelist_level(1:npes_level) @@ -490,7 +493,9 @@ subroutine define_nest_level_type(nest_domain, x_refine, y_refine, extra_halo) endif enddo + if (associated(nest_domain%pelist_fine)) deallocate(nest_domain%pelist_fine) !< Check if allocated allocate(nest_domain%pelist_fine(npes_fine)) + if (associated(nest_domain%pelist_coarse)) deallocate(nest_domain%pelist_coarse) !< Check if allocated allocate(nest_domain%pelist_coarse(npes_coarse)) nest_domain%pelist_fine = pes_fine nest_domain%pelist_coarse = pes_coarse @@ -564,11 +569,19 @@ subroutine define_nest_level_type(nest_domain, x_refine, y_refine, extra_halo) nest_domain%x_refine = x_refine nest_domain%y_refine = y_refine + if (associated(nest_domain%C2F_T)) deallocate(nest_domain%C2F_T) !< Check if allocated + if (associated(nest_domain%C2F_C)) deallocate(nest_domain%C2F_C) !< Check if allocated + if (associated(nest_domain%C2F_E)) deallocate(nest_domain%C2F_E) !< Check if allocated + if (associated(nest_domain%C2F_N)) deallocate(nest_domain%C2F_N) !< Check if allocated allocate( nest_domain%C2F_T, nest_domain%C2F_C, nest_domain%C2F_E, nest_domain%C2F_N ) nest_domain%C2F_T%next => NULL() nest_domain%C2F_C%next => NULL() nest_domain%C2F_N%next => NULL() nest_domain%C2F_E%next => NULL() + if (associated(nest_domain%F2C_T)) deallocate(nest_domain%F2C_T) !< Check if allocated + if (associated(nest_domain%F2C_C)) deallocate(nest_domain%F2C_C) !< Check if allocated + if (associated(nest_domain%F2C_E)) deallocate(nest_domain%F2C_E) !< Check if allocated + if (associated(nest_domain%F2C_N)) deallocate(nest_domain%F2C_N) !< Check if allocated allocate( nest_domain%F2C_T, nest_domain%F2C_C, nest_domain%F2C_E, nest_domain%F2C_N ) call compute_overlap_fine_to_coarse(nest_domain, nest_domain%F2C_T, CENTER, "F2C T-cell") @@ -1029,6 +1042,7 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi !--- copy the overlapping into nest_domain data. overlap%nrecv = nrecv if( nrecv > 0 ) then + if (associated(overlap%recv)) deallocate(overlap%recv) !< Check if allocated allocate(overlap%recv(nrecv)) do n = 1, nrecv call copy_nest_overlap( overlap%recv(n), overLaplist(n) ) @@ -1039,6 +1053,7 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi overlap%nsend = nsend if( nsend > 0 ) then + if (associated(overlap%send)) deallocate(overlap%send) !< Check if allocated allocate(overlap%send(nsend)) do n = 1, nsend call copy_nest_overlap( overlap%send(n), overLaplist(n) ) @@ -1256,6 +1271,7 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) enddo overlap%nsend = nsend if(nsend > 0) then + if (associated(overlap%send)) deallocate(overlap%send) !< Check if allocated allocate(overlap%send(nsend)) do n = 1, nsend call copy_nest_overlap(overlap%send(n), overlaplist(n) ) diff --git a/mpp/include/mpp_domains_define.inc b/mpp/include/mpp_domains_define.inc index f3d6eff63a..5da34c5c47 100644 --- a/mpp/include/mpp_domains_define.inc +++ b/mpp/include/mpp_domains_define.inc @@ -490,6 +490,7 @@ "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// & ": multiple tile per pe is not supported yet for this routine") + if (associated(domain%io_domain)) deallocate(domain%io_domain) !< Check if associated allocate(domain%io_domain) domain%io_layout = io_layout io_domain => domain%io_domain @@ -516,6 +517,7 @@ io_domain%ntiles = 1 io_domain%pe = domain%pe io_domain%symmetry = domain%symmetry + if (associated(io_domain%list)) deallocate(io_domain%list) !< Check if associated allocate(io_domain%list(0:npes_in_group-1)) do i = 0, npes_in_group-1 allocate( io_domain%list(i)%x(1), io_domain%list(i)%y(1), io_domain%list(i)%tile_id(1) ) @@ -550,6 +552,9 @@ enddo deallocate(posarray) + if (associated(io_domain%x)) deallocate(io_domain%x) !< Check if associated + if (associated(io_domain%y)) deallocate(io_domain%y) !< Check if associated + if (associated(io_domain%tile_id)) deallocate(io_domain%tile_id) !< Check if associated allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) ) allocate(io_domain%x(1)%list(0:npes_x-1), io_domain%y(1)%list(0:npes_y-1) ) n = -1 @@ -858,6 +863,7 @@ !--- when tile is not equal to 1, the layout for that tile always ( 1, 1), so no need for pearray in domain if( tile == 1 ) then + if (associated(domain%pearray)) deallocate(domain%pearray) !< Check if allocated allocate( domain%pearray(0:ndivx-1,0:ndivy-1) ) domain%pearray = pearray end if @@ -1010,11 +1016,18 @@ if(is_complete) then domain%whalo = whalosz; domain%ehalo = ehalosz domain%shalo = shalosz; domain%nhalo = nhalosz + if (associated(domain%update_T)) deallocate(domain%update_T) !< Check if associated + if (associated(domain%update_E)) deallocate(domain%update_E) !< Check if associated + if (associated(domain%update_C)) deallocate(domain%update_C) !< Check if associated + if (associated(domain%update_N)) deallocate(domain%update_N) !< Check if associated allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N) domain%update_T%next => NULL() domain%update_E%next => NULL() domain%update_C%next => NULL() domain%update_N%next => NULL() + if (associated(domain%check_E)) deallocate(domain%check_E) !< Check if associated + if (associated(domain%check_C)) deallocate(domain%check_C) !< Check if associated + if (associated(domain%check_N)) deallocate(domain%check_N) !< Check if associated allocate(domain%check_E, domain%check_C, domain%check_N ) domain%update_T%nsend = 0 domain%update_T%nrecv = 0 @@ -1061,6 +1074,9 @@ call set_check_overlap( domain, CORNER ) call set_check_overlap( domain, EAST ) call set_check_overlap( domain, NORTH ) + if (associated(domain%bound_E)) deallocate(domain%bound_E) !< Check if associated + if (associated(domain%bound_C)) deallocate(domain%bound_C) !< Check if associated + if (associated(domain%bound_N)) deallocate(domain%bound_N) !< Check if associated allocate(domain%bound_E, domain%bound_C, domain%bound_N ) call set_bound_overlap( domain, CORNER ) call set_bound_overlap( domain, EAST ) @@ -1297,6 +1313,7 @@ end subroutine check_message_size 'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile') end if + if (associated(domain%tileList)) deallocate(domain%tileList) !< Check if associated allocate(domain%tileList(num_tile)) do n = 1, num_tile domain%tileList(n)%xbegin = global_indices(1,n) @@ -1306,6 +1323,10 @@ end subroutine check_message_size enddo !--- define some mosaic information in domain type nt = ntile_per_pe(mpp_pe()-mpp_root_pe()) + if (associated(domain%tile_id)) deallocate(domain%tile_id) !< Check if associated + if (associated(domain%x)) deallocate(domain%x) !< Check if associated + if (associated(domain%y)) deallocate(domain%y) !< Check if associated + if (associated(domain%list)) deallocate(domain%list) !< Check if associated allocate(domain%tile_id(nt), domain%x(nt), domain%y(nt) ) allocate(domain%list(0:nlist-1)) @@ -1344,6 +1365,7 @@ end subroutine check_message_size end if end do + if (associated(domain%tile_id_all)) deallocate(domain%tile_id_all) !< Check if associated allocate(domain%tile_id_all(num_tile)) domain%tile_id_all(:) = tile_id_local(:) @@ -1518,6 +1540,9 @@ end subroutine check_message_size call set_check_overlap( domain, NORTH ) endif if(domain%symmetry) then + if (associated(domain%bound_E)) deallocate(domain%bound_E) !< Check if associated + if (associated(domain%bound_C)) deallocate(domain%bound_C) !< Check if associated + if (associated(domain%bound_N)) deallocate(domain%bound_N) !< Check if associated allocate(domain%bound_E, domain%bound_C, domain%bound_N ) call set_bound_overlap( domain, CORNER ) call set_bound_overlap( domain, EAST ) @@ -2128,6 +2153,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) update%nsend = nsend do m = 1, nsend @@ -2137,6 +2163,7 @@ end subroutine check_message_size if(nsend_check>0) then check%nsend = nsend_check + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) do m = 1, nsend_check call add_check_overlap( check%send(m), checkList(m) ) @@ -2705,6 +2732,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) update%nrecv = nrecv do m = 1, nrecv @@ -2720,6 +2748,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -3296,6 +3325,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) update%nsend = nsend do m = 1, nsend @@ -3304,6 +3334,7 @@ end subroutine check_message_size endif if(nsend_check>0) then + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) check%nsend = nsend_check do m = 1, nsend_check @@ -3568,6 +3599,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then update%nrecv = nrecv + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) do m = 1, nrecv call add_update_overlap( update%recv(m), overlapList(m) ) @@ -3582,6 +3614,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -3931,6 +3964,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then update%nsend = nsend + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) do m = 1, nsend call add_update_overlap( update%send(m), overlapList(m) ) @@ -3939,6 +3973,7 @@ end subroutine check_message_size if(nsend_check>0) then check%nsend = nsend_check + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) do m = 1, nsend_check call add_check_overlap( check%send(m), checkList(m) ) @@ -4195,6 +4230,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then update%nrecv = nrecv + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) do m = 1, nrecv call add_update_overlap( update%recv(m), overlapList(m) ) @@ -4209,6 +4245,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -4543,6 +4580,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then update%nsend = nsend + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) do m = 1, nsend call add_update_overlap( update%send(m), overlapList(m) ) @@ -4551,6 +4589,7 @@ end subroutine check_message_size if(nsend_check>0) then check%nsend = nsend_check + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) do m = 1, nsend_check call add_check_overlap( check%send(m), checkList(m) ) @@ -4794,6 +4833,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then update%nrecv = nrecv + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) do m = 1, nrecv call add_update_overlap( update%recv(m), overlapList(m) ) @@ -4808,6 +4848,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -5065,6 +5106,7 @@ end subroutine check_message_size if(nsend>0) then overlap_out%nsend = nsend + if (associated(overlap_out%send)) deallocate(overlap_out%send) !< Check if associated allocate(overlap_out%send(nsend)); do n = 1, nsend call add_update_overlap(overlap_out%send(n), send(n) ) @@ -5154,6 +5196,7 @@ end subroutine check_message_size if(nrecv>0) then overlap_out%nrecv = nrecv + if (associated(overlap_out%recv)) deallocate(overlap_out%recv) !< Check if associated allocate(overlap_out%recv(nrecv)); do n = 1, nrecv call add_update_overlap(overlap_out%recv(n), recv(n) ) @@ -6053,6 +6096,7 @@ subroutine set_contact_point(domain, position) update_out%nsend = nsend if(nsend>0) then + if (associated(update_out%send)) deallocate(update_out%send) !< Check if associated allocate(update_out%send(nsend)) pos = 0 do list = 0, nlist-1 @@ -6135,6 +6179,7 @@ subroutine set_contact_point(domain, position) update_out%nrecv = nrecv if(nrecv>0) then + if (associated(update_out%recv)) deallocate(update_out%recv) !< Check if associated allocate(update_out%recv(nrecv)) pos = 0 do list = 0, nlist-1 @@ -6204,6 +6249,7 @@ do m = 1, update%nsend enddo if(nsend>0) then + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend)) call allocate_check_overlap(overlap, maxsize) endif @@ -6280,6 +6326,7 @@ enddo if(nsend>0) call deallocate_overlap_type(overlap) if(nrecv>0) then + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv)) call allocate_check_overlap(overlap, maxsize) endif @@ -6378,10 +6425,12 @@ subroutine set_bound_overlap( domain, position ) bound%nsend = nlist_send bound%nrecv = nlist_recv if(nlist_send >0) then + if (associated(bound%send)) deallocate(bound%send) !< Check if associated allocate(bound%send(nlist_send)) bound%send(:)%count = 0 endif if(nlist_recv >0) then + if (associated(bound%recv)) deallocate(bound%recv) !< Check if associated allocate(bound%recv(nlist_recv)) bound%recv(:)%count = 0 endif @@ -6522,6 +6571,13 @@ subroutine set_bound_overlap( domain, position ) if(nsend > nlist_send) call mpp_error(FATAL, "set_bound_overlap: nsend > nlist_send") bound%send(nsend)%count = count bound%send(nsend)%pe = my_pe + if (associated(bound%send(nsend)%is)) deallocate(bound%send(nsend)%is) !< Check if allocated + if (associated(bound%send(nsend)%ie)) deallocate(bound%send(nsend)%ie) !< Check if allocated + if (associated(bound%send(nsend)%js)) deallocate(bound%send(nsend)%js) !< Check if allocated + if (associated(bound%send(nsend)%je)) deallocate(bound%send(nsend)%je) !< Check if allocated + if (associated(bound%send(nsend)%dir)) deallocate(bound%send(nsend)%dir) !< Check if allocated + if (associated(bound%send(nsend)%rotation)) deallocate(bound%send(nsend)%rotation) !< Check if allocated + if (associated(bound%send(nsend)%tileMe)) deallocate(bound%send(nsend)%tileMe) !< Check if allocated allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) ) allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) ) allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) ) @@ -6621,6 +6677,13 @@ subroutine set_bound_overlap( domain, position ) nsend = nsend + 1 bound%send(nsend)%count = count bound%send(nsend)%pe = overlap%pe + if (associated(bound%send(nsend)%is)) deallocate(bound%send(nsend)%is) !< Check if allocated + if (associated(bound%send(nsend)%ie)) deallocate(bound%send(nsend)%ie) !< Check if allocated + if (associated(bound%send(nsend)%js)) deallocate(bound%send(nsend)%js) !< Check if allocated + if (associated(bound%send(nsend)%je)) deallocate(bound%send(nsend)%je) !< Check if allocated + if (associated(bound%send(nsend)%dir)) deallocate(bound%send(nsend)%dir) !< Check if allocated + if (associated(bound%send(nsend)%rotation)) deallocate(bound%send(nsend)%rotation) !< Check if allocated + if (associated(bound%send(nsend)%tileMe)) deallocate(bound%send(nsend)%tileMe) !< Check if allocated allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) ) allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) ) allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) ) @@ -6770,6 +6833,14 @@ subroutine set_bound_overlap( domain, position ) if(nrecv > nlist_recv) call mpp_error(FATAL, "set_bound_overlap: nrecv > nlist_recv") bound%recv(nrecv)%count = count bound%recv(nrecv)%pe = my_pe + if (associated(bound%recv(nrecv)%is)) deallocate(bound%recv(nrecv)%is) !< Check if allocated + if (associated(bound%recv(nrecv)%ie)) deallocate(bound%recv(nrecv)%ie) !< Check if allocated + if (associated(bound%recv(nrecv)%js)) deallocate(bound%recv(nrecv)%js) !< Check if allocated + if (associated(bound%recv(nrecv)%je)) deallocate(bound%recv(nrecv)%je) !< Check if allocated + if (associated(bound%recv(nrecv)%dir)) deallocate(bound%recv(nrecv)%dir) !< Check if allocated + if (associated(bound%recv(nrecv)%index)) deallocate(bound%recv(nrecv)%index) !< Check if allocated + if (associated(bound%recv(nrecv)%tileMe)) deallocate(bound%recv(nrecv)%tileMe) !< Check if allocated + if (associated(bound%recv(nrecv)%rotation)) deallocate(bound%recv(nrecv)%rotation) !< Check if allocated allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) ) allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) ) allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) ) @@ -6865,6 +6936,14 @@ subroutine set_bound_overlap( domain, position ) nrecv = nrecv + 1 bound%recv(nrecv)%count = count bound%recv(nrecv)%pe = overlap%pe + if (associated(bound%recv(nrecv)%is)) deallocate(bound%recv(nrecv)%is) !< Check if allocated + if (associated(bound%recv(nrecv)%ie)) deallocate(bound%recv(nrecv)%ie) !< Check if allocated + if (associated(bound%recv(nrecv)%js)) deallocate(bound%recv(nrecv)%js) !< Check if allocated + if (associated(bound%recv(nrecv)%je)) deallocate(bound%recv(nrecv)%je) !< Check if allocated + if (associated(bound%recv(nrecv)%dir)) deallocate(bound%recv(nrecv)%dir) !< Check if allocated + if (associated(bound%recv(nrecv)%index)) deallocate(bound%recv(nrecv)%index) !< Check if allocated + if (associated(bound%recv(nrecv)%tileMe)) deallocate(bound%recv(nrecv)%tileMe) !< Check if allocated + if (associated(bound%recv(nrecv)%rotation)) deallocate(bound%recv(nrecv)%rotation) !< Check if allocated allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) ) allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) ) allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) ) @@ -7531,6 +7610,7 @@ if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) else call mpp_define_null_domain(domain_out) nlist = size(domain_in%list(:)) + if (associated(domain_out%list)) deallocate(domain_out%list) !< Check if allocated allocate(domain_out%list(0:nlist-1) ) do i = 0, nlist-1 allocate(domain_out%list(i)%tile_id(1)) diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc index c27af7c093..3d72df4a43 100644 --- a/mpp/include/mpp_domains_util.inc +++ b/mpp/include/mpp_domains_util.inc @@ -1738,6 +1738,7 @@ end subroutine mpp_get_tile_compute_domains if (associated(domain_in%list)) then starting = lbound(domain_in%list, 1) ending = ubound(domain_in%list, 1) + if (associated(domain_out%list)) deallocate(domain_out%list) !< Check if allocated allocate(domain_out%list(starting:ending)) do i = starting, ending @@ -1843,6 +1844,7 @@ end subroutine mpp_get_tile_compute_domains starting = lbound(domain2D_spec_in%tile_id,1) ending = ubound(domain2D_spec_in%tile_id,1) + if (associated(domain2D_spec_out%tile_id)) deallocate(domain2D_spec_out%tile_id) !< Check if allocated allocate(domain2D_spec_out%tile_id(starting:ending)) domain2D_spec_out%tile_id = domain2D_spec_in%tile_id endif @@ -1851,6 +1853,7 @@ end subroutine mpp_get_tile_compute_domains starting = lbound(domain2D_spec_in%x,1) ending = ubound(domain2D_spec_in%x,1) + if (associated(domain2D_spec_out%x)) deallocate(domain2D_spec_out%x) !< Check if allocated allocate(domain2D_spec_out%x(starting:ending)) do i = starting, ending call mpp_copy_domain1D_spec(domain2D_spec_in%x(i), domain2D_spec_out%x(i)) @@ -1861,6 +1864,7 @@ end subroutine mpp_get_tile_compute_domains starting = lbound(domain2D_spec_in%y,1) ending = ubound(domain2D_spec_in%y,1) + if (associated(domain2D_spec_out%y)) deallocate(domain2D_spec_out%y) !< Check if allocated allocate(domain2D_spec_out%y(starting:ending)) do i = starting, ending call mpp_copy_domain1D_spec(domain2D_spec_in%y(i), domain2D_spec_out%y(i)) diff --git a/mpp/include/mpp_unstruct_domain.inc b/mpp/include/mpp_unstruct_domain.inc index a074cc3f03..2b88c630a1 100644 --- a/mpp/include/mpp_unstruct_domain.inc +++ b/mpp/include/mpp_unstruct_domain.inc @@ -137,6 +137,7 @@ pe_end(n) = te ioff = ioff+ npts_tile(n) enddo + if (associated(UG_domain%list)) deallocate(UG_domain%list) !< Check if allocated allocate(UG_domain%list(0:ndivs-1)) do p = 0, ndivs-1 UG_domain%list(p)%compute%begin = ibegin(p) @@ -185,12 +186,14 @@ UG_domain%global%begin_index = grid_index(pos+1) UG_domain%global%end_index = grid_index(pos+npts_tile(n)) + if (associated(UG_domain%grid_index)) deallocate(UG_domain%grid_index) !< Check if allocated allocate(UG_domain%grid_index(UG_domain%compute%size)) do n = 1, UG_domain%compute%size UG_domain%grid_index(n) = grid_index(pos+UG_domain%compute%begin+n-1) enddo !--- define io_domain + if (associated(UG_domain%io_domain)) deallocate(UG_domain%io_domain) !< Check if allocated allocate(UG_domain%io_domain) tile_id = UG_domain%tile_id UG_domain%io_domain%pe = UG_domain%pe @@ -230,6 +233,7 @@ UG_domain%io_domain%global%size = UG_domain%io_domain%global%end - UG_domain%io_domain%global%begin + 1 npes_in_group = iend(group_id) - ibegin(group_id) + 1 + if (associated(UG_domain%io_domain%list)) deallocate(UG_domain%io_domain%list) !< Check if allocated allocate(UG_domain%io_domain%list(0:npes_in_group-1)) do n = 0, npes_in_group-1 pos = UG_domain%io_domain%tile_root_pe - mpp_root_pe() + n @@ -307,6 +311,7 @@ nrecv = count( recv_cnt > 0 ) UG_domain%SG2UG%nrecv = nrecv + if (associated(UG_domain%SG2UG%recv)) deallocate(UG_domain%SG2UG%recv) !< Check if allocated allocate(UG_domain%SG2UG%recv(nrecv)) nrecv = 0 pos = 0 @@ -351,6 +356,7 @@ nsend = count( recv_cnt(:) > 0 ) UG_domain%SG2UG%nsend = nsend + if (associated(UG_domain%SG2UG%send)) deallocate(UG_domain%SG2UG%send) !< Check if allocated allocate(UG_domain%SG2UG%send(nsend)) nsend = 0 isc = SG_domain%x(1)%compute%begin @@ -610,6 +616,7 @@ return if( .NOT.native )then !initialize domain%list and set null values in message + if (associated(domain%list)) deallocate(domain%list) !< Check if allocated allocate( domain%list(0:listsize-1) ) domain%pe = NULL_PE domain%pos = -1 From 5e130efb968f360a6d6b0dfe6366d9f88520e3d1 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Tue, 27 Jun 2023 11:46:49 -0400 Subject: [PATCH 010/394] fix: continuation line syntax for fms2_io error messages (#1265) --- fms2_io/include/unpack_data.inc | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/fms2_io/include/unpack_data.inc b/fms2_io/include/unpack_data.inc index c3695c4793..23bc19f8bd 100644 --- a/fms2_io/include/unpack_data.inc +++ b/fms2_io/include/unpack_data.inc @@ -59,8 +59,8 @@ subroutine unpack_data_0d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -103,8 +103,8 @@ subroutine unpack_data_1d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -147,8 +147,8 @@ subroutine unpack_data_2d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -191,8 +191,8 @@ subroutine unpack_data_3d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -235,8 +235,8 @@ subroutine unpack_data_4d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -279,8 +279,8 @@ subroutine unpack_data_5d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine From 84b330a9f78a1fe7997dca39ff56d6f000a9c3d6 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 29 Jun 2023 08:48:14 -0400 Subject: [PATCH 011/394] fix: update doc site deployment action(#1078) --- .github/workflows/update_docs.yml | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/.github/workflows/update_docs.yml b/.github/workflows/update_docs.yml index 6a4b4bf917..bbf2335811 100644 --- a/.github/workflows/update_docs.yml +++ b/.github/workflows/update_docs.yml @@ -6,7 +6,7 @@ on: types: [published] workflow_dispatch: jobs: - update_docs: + build: runs-on: ubuntu-latest steps: - name: Checkout code @@ -23,8 +23,26 @@ jobs: run: | sudo apt -y install doxygen graphviz doxygen gen_docs/Doxyfile - - name: Deploy - uses: peaceiris/actions-gh-pages@v3 + - name: Upload Pages Artifact + uses: actions/upload-pages-artifact@v1 with: - github_token: ${{ secrets.GITHUB_TOKEN }} - publish_dir: ./gen_docs/html + path: 'gen_docs/html' + deploy: + needs: build + + # Grant GITHUB_TOKEN the permissions required to make a Pages deployment + permissions: + pages: write # to deploy to Pages + id-token: write # to verify the deployment originates from an appropriate source + + # Deploy to the github-pages environment + environment: + name: github-pages + url: ${{ steps.deployment.outputs.page_url }} + + # Specify runner + deployment step + runs-on: ubuntu-latest + steps: + - name: Deploy to GitHub Pages + id: deployment + uses: actions/deploy-pages@v1 From ef8b5e317f2904945da40abfd95021e903a8e401 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 29 Jun 2023 09:00:44 -0400 Subject: [PATCH 012/394] fix: warnings in test_mpp_nesting.F90 (#1118) --- test_fms/mpp/test_mpp_nesting.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/test_fms/mpp/test_mpp_nesting.F90 b/test_fms/mpp/test_mpp_nesting.F90 index d086992c4b..201fd217f0 100644 --- a/test_fms/mpp/test_mpp_nesting.F90 +++ b/test_fms/mpp/test_mpp_nesting.F90 @@ -1406,10 +1406,10 @@ subroutine test_update_nest_domain_r8( type ) if( isw_f .NE. isw_f2 .OR. iew_f .NE. iew_f2 .OR. jsw_f .NE. jsw_f2 .OR. jew_f .NE. jew_f2 .OR. & isw_c .NE. isw_c2 .OR. iew_c .NE. iew_c2 .OR. jsw_c .NE. jsw_c2 .OR. jew_c .NE. jew_c2 ) then - write(5000+mpp_pe(),*), "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f - write(5000+mpp_pe(),*), "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 - write(5000+mpp_pe(),*), "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c - write(5000+mpp_pe(),*), "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 + write(5000+mpp_pe(),*) "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f + write(5000+mpp_pe(),*) "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 + write(5000+mpp_pe(),*) "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c + write(5000+mpp_pe(),*) "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 call mpp_error(FATAL, "test_mpp_domains: west buffer index mismatch for coarse to fine scalar") endif if( ise_f .NE. ise_f2 .OR. iee_f .NE. iee_f2 .OR. jse_f .NE. jse_f2 .OR. jee_f .NE. jee_f2 .OR. & @@ -3433,10 +3433,10 @@ subroutine test_update_nest_domain_r4( type ) if( isw_f .NE. isw_f2 .OR. iew_f .NE. iew_f2 .OR. jsw_f .NE. jsw_f2 .OR. jew_f .NE. jew_f2 .OR. & isw_c .NE. isw_c2 .OR. iew_c .NE. iew_c2 .OR. jsw_c .NE. jsw_c2 .OR. jew_c .NE. jew_c2 ) then - write(5000+mpp_pe(),*), "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f - write(5000+mpp_pe(),*), "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 - write(5000+mpp_pe(),*), "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c - write(5000+mpp_pe(),*), "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 + write(5000+mpp_pe(),*) "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f + write(5000+mpp_pe(),*) "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 + write(5000+mpp_pe(),*) "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c + write(5000+mpp_pe(),*) "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 call mpp_error(FATAL, "test_mpp_domains: west buffer index mismatch for coarse to fine scalar") endif if( ise_f .NE. ise_f2 .OR. iee_f .NE. iee_f2 .OR. jse_f .NE. jse_f2 .OR. jee_f .NE. jee_f2 .OR. & From 3138e4ae1f165a8585cdb87834c5e1a0ae0c81db Mon Sep 17 00:00:00 2001 From: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com> Date: Fri, 30 Jun 2023 14:22:31 -0400 Subject: [PATCH 013/394] chore!: deprecate fms/mpp_io with use_deprecated_io macro (#1064) BREAKING CHANGE: This commit removes mpp_io_mod and fms_io_mod, along with other routines that use the modules, from default compilation. The -Duse_deprecated_io CPP flag or --enable-deprecated-io configure time flag can be used to enable their compilation. --- axis_utils/axis_utils.F90 | 3 +- coupler/coupler_types.F90 | 14 +++- coupler/ensemble_manager.F90 | 4 + fms/fms.F90 | 27 +++++-- fms/fms_io.F90 | 3 +- mosaic/grid.F90 | 3 +- mosaic/mosaic.F90 | 3 +- mpp/mpp_io.F90 | 3 +- test_fms/data_override/test_data_override.F90 | 78 +++++++++++-------- test_fms/diag_manager/test_diag_manager.F90 | 15 ++-- test_fms/fms/test_fms.F90 | 1 + test_fms/interpolator/test_interpolator.F90 | 13 +++- test_fms/mpp/test_global_arrays.F90 | 2 - test_fms/mpp/test_mpp.F90 | 2 - test_fms/mpp/test_mpp_gatscat.F90 | 2 - test_fms/mpp/test_mpp_global_sum_ad.F90 | 2 - test_fms/mpp/test_mpp_sendrecv.F90 | 2 - test_fms/mpp/test_mpp_update_domains_ad.F90 | 2 - test_fms/mpp/test_mpp_update_domains_int.F90 | 1 - test_fms/mpp/test_mpp_update_domains_main.F90 | 2 - .../mpp/test_update_domains_performance.F90 | 2 - test_fms/mpp_io/test_io_R4_R8.F90 | 3 +- test_fms/mpp_io/test_io_mosaic_R4_R8.F90 | 3 +- test_fms/mpp_io/test_mpp_io.F90 | 4 +- test_fms/parser/parser_demo.F90 | 1 - time_interp/time_interp_external.F90 | 3 +- 26 files changed, 122 insertions(+), 76 deletions(-) diff --git a/axis_utils/axis_utils.F90 b/axis_utils/axis_utils.F90 index 3947e370e3..4d746be7f3 100644 --- a/axis_utils/axis_utils.F90 +++ b/axis_utils/axis_utils.F90 @@ -27,6 +27,7 @@ !> @addtogroup axis_utils_mod !> @{ module axis_utils_mod +#ifdef use_deprecated_io use netcdf use mpp_io_mod, only: axistype, atttype, default_axis, default_att, & mpp_get_atts, mpp_get_axis_data, mpp_modify_meta, & @@ -787,7 +788,7 @@ subroutine find_index(grid1, xs, xe, ks, ke) if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') end subroutine find_index - +#endif end module axis_utils_mod !> @} ! close documentation grouping diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 82d0c97082..d059fe8a27 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -31,8 +31,10 @@ module coupler_types_mod use fms2_io_mod, only: get_variable_attribute, get_dimension_size, get_dimension_names use fms2_io_mod, only: register_variable_attribute, get_variable_dimension_names use fms2_io_mod, only: get_variable_num_dimensions +#ifdef use_deprecated_io use fms_io_mod, only: restart_file_type, fms_io_register_restart_field=>register_restart_field use fms_io_mod, only: query_initialized, restore_state +#endif use time_manager_mod, only: time_type use diag_manager_mod, only: register_diag_field, send_data use data_override_mod, only: data_override @@ -95,8 +97,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -149,8 +153,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -319,9 +325,10 @@ module coupler_types_mod !! in restart files. !> @ingroup coupler_types_mod interface coupler_type_register_restarts +#ifdef use_deprecated_io module procedure mpp_io_CT_register_restarts_2d, mpp_io_CT_register_restarts_3d module procedure mpp_io_CT_register_restarts_to_file_2d, mpp_io_CT_register_restarts_to_file_3d - +#endif module procedure CT_register_restarts_2d, CT_register_restarts_3d end interface coupler_type_register_restarts @@ -329,7 +336,9 @@ module coupler_types_mod !! been saved in restart files. !> @ingroup coupler_types_mod interface coupler_type_restore_state +#ifdef use_deprecated_io module procedure mpp_io_CT_restore_state_2d, mpp_io_CT_restore_state_3d +#endif module procedure CT_restore_state_2d, CT_restore_state_3d end interface coupler_type_restore_state @@ -3743,6 +3752,7 @@ end subroutine CT_destructor_3d !! !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files !! specified in the field table. +#ifdef use_deprecated_io subroutine mpp_io_CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files @@ -4056,7 +4066,7 @@ subroutine mpp_io_CT_restore_state_3d(var, directory, all_or_nothing, all_requir endif endif end subroutine mpp_io_CT_restore_state_3d - +#endif end module coupler_types_mod !> @} ! close documentation grouping diff --git a/coupler/ensemble_manager.F90 b/coupler/ensemble_manager.F90 index 944e859455..257dfed54e 100644 --- a/coupler/ensemble_manager.F90 +++ b/coupler/ensemble_manager.F90 @@ -30,7 +30,9 @@ module ensemble_manager_mod use mpp_mod, only : mpp_pe, mpp_declare_pelist use mpp_mod, only : input_nml_file use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix +#ifdef use_deprecated_io use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix +#endif IMPLICIT NONE @@ -408,7 +410,9 @@ subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, !< Both calls are needed for cases where both fms2io/fmsio are used call fms2_io_set_filename_appendix(trim(text)) +#ifdef use_deprecated_io call fms_io_set_filename_appendix(trim(text)) +#endif endif end subroutine ensemble_pelist_setup diff --git a/fms/fms.F90 b/fms/fms.F90 index 7067b86aee..3ec8052148 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -143,7 +143,8 @@ module fms_mod mpp_get_compute_domain, mpp_get_global_domain, & mpp_get_data_domain -use mpp_io_mod, only: mpp_io_init, mpp_open, mpp_close, & +#ifdef use_deprecated_io +use mpp_io_mod, only: mpp_io_init, mpp_open, mpp_close, & MPP_ASCII, MPP_NATIVE, MPP_IEEE32, MPP_NETCDF, & MPP_RDONLY, MPP_WRONLY, MPP_APPEND, MPP_OVERWR, & MPP_SEQUENTIAL, MPP_DIRECT, & @@ -158,6 +159,7 @@ module fms_mod open_file, open_direct_file, get_mosaic_tile_grid, & get_mosaic_tile_file, get_global_att_value, file_exist, field_exist, & set_domain, nullify_domain +#endif use fms2_io_mod, only: fms2_io_init use memutils_mod, only: print_memuse_stats, memutils_init use grid2_mod, only: grid_init, grid_end @@ -173,6 +175,7 @@ module fms_mod public :: fms_init, fms_end ! routines for opening/closing specific types of file +#ifdef use_deprecated_io public :: open_namelist_file, open_restart_file, & open_ieee32_file, close_file, & open_file, open_direct_file @@ -186,15 +189,19 @@ module fms_mod public :: get_mosaic_tile_grid, get_mosaic_tile_file ! miscellaneous i/o routines -public :: file_exist, check_nml_error, field_exist, & - error_mesg, fms_error_handler +public :: file_exist, field_exist +#endif +public ::check_nml_error, error_mesg, fms_error_handler + ! version logging routine (originally from fms_io) public :: write_version_number ! miscellaneous utilities (non i/o) public :: lowercase, uppercase, & - string_array_index, monotonic_array, & - set_domain, nullify_domain + string_array_index, monotonic_array +#ifdef use_deprecated_io +public :: set_domain, nullify_domain +#endif ! public mpp interfaces public :: mpp_error, NOTE, WARNING, FATAL, & @@ -213,7 +220,9 @@ module fms_mod public :: string ! public mpp-io interfaces +#ifdef use_deprecated_io public :: do_cf_compliance +#endif interface monotonic_array module procedure :: monotonic_array_r4, monotonic_array_r8 @@ -323,7 +332,9 @@ subroutine fms_init (localcomm, alt_input_nml_path) !--- needed to output the version number of constants_mod to the logfile --- use constants_mod, only: constants_version=>version !pjp: PI not computed +#ifdef use_deprecated_io use fms_io_mod, only: fms_io_version +#endif integer, intent(in), optional :: localcomm character(len=*), intent(in), optional :: alt_input_nml_path @@ -348,10 +359,14 @@ subroutine fms_init (localcomm, alt_input_nml_path) endif endif call mpp_domains_init() +#ifdef use_deprecated_io call fms_io_init() +#endif !! write_version_number is inaccesible from fms_io_mod so write it from here if not written if(.not.fms_io_initialized) then +#ifdef use_deprecated_io call write_version_number("FMS_IO_MOD", fms_io_version) +#endif fms_io_initialized = .true. endif call fms2_io_init() @@ -446,7 +461,9 @@ subroutine fms_end ( ) if (.not.module_is_initialized) return ! return silently ! call fms_io_exit ! now called from coupler_end call grid_end +#ifdef use_deprecated_io call mpp_io_exit +#endif call mpp_domains_exit call mpp_exit module_is_initialized =.FALSE. diff --git a/fms/fms_io.F90 b/fms/fms_io.F90 index ce1069948e..06ca5a0627 100644 --- a/fms/fms_io.F90 +++ b/fms/fms_io.F90 @@ -86,6 +86,7 @@ !> @addtogroup fms_io_mod !> @{ module fms_io_mod +#ifdef use_deprecated_io #include @@ -8706,7 +8707,7 @@ end function get_great_circle_algorithm #include #include !---------- - +#endif end module fms_io_mod !> @} ! close documentation grouping diff --git a/mosaic/grid.F90 b/mosaic/grid.F90 index 6c94e1b733..84fd0d8cb0 100644 --- a/mosaic/grid.F90 +++ b/mosaic/grid.F90 @@ -21,6 +21,7 @@ !> @brief Routines for grid calculations module grid_mod +#ifdef use_deprecated_io use mpp_mod, only : mpp_root_pe, uppercase, lowercase, FATAL, NOTE, mpp_error use constants_mod, only : PI, radius @@ -1030,7 +1031,7 @@ subroutine define_cube_mosaic ( component, domain, layout, halo, maskmap ) deallocate(is2,ie2,js2,je2) end subroutine define_cube_mosaic - +#endif end module grid_mod !> @} ! close documentation grouping diff --git a/mosaic/mosaic.F90 b/mosaic/mosaic.F90 index e8558fc8fa..eb8a698de4 100644 --- a/mosaic/mosaic.F90 +++ b/mosaic/mosaic.F90 @@ -28,6 +28,7 @@ !> @addtogroup mosaic_mod !> @{ module mosaic_mod +#ifdef use_deprecated_io use mpp_mod, only : mpp_error, FATAL, mpp_pe, mpp_root_pe use mpp_io_mod, only : MPP_MULTI @@ -488,7 +489,7 @@ function parse_string(string, set, value) return end function parse_string - +#endif end module mosaic_mod diff --git a/mpp/mpp_io.F90 b/mpp/mpp_io.F90 index 4a8fc1bb0b..297f2df41e 100644 --- a/mpp/mpp_io.F90 +++ b/mpp/mpp_io.F90 @@ -309,6 +309,7 @@ !> @{ module mpp_io_mod +#ifdef use_deprecated_io #define _MAX_FILE_UNITS 1024 @@ -1203,7 +1204,7 @@ module mpp_io_mod #include #include !---------- - +#endif end module mpp_io_mod !> @} ! close documentation grouping diff --git a/test_fms/data_override/test_data_override.F90 b/test_fms/data_override/test_data_override.F90 index eee88eddca..36f22b3143 100644 --- a/test_fms/data_override/test_data_override.F90 +++ b/test_fms/data_override/test_data_override.F90 @@ -46,12 +46,15 @@ program test use mpp_mod, only: input_nml_file, stdout, mpp_chksum use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, & & mpp_define_layout - use fms_mod, only: fms_init, fms_end, mpp_npes, file_exist, check_nml_error - use fms_mod, only: error_mesg, FATAL, file_exist, field_exist, field_size + use fms_mod, only: fms_init, fms_end, mpp_npes, check_nml_error, error_mesg, FATAL +#ifdef use_deprecated_io + use fms_mod, only: field_exist, field_size, file_exist +#endif use fms_affinity_mod, only: fms_affinity_set - use fms_io_mod, only: read_data, fms_io_exit + use fms2_io_mod, only: read_data, variable_exists, get_variable_size, FmsNetcdfFile_t, open_file use constants_mod, only: constants_init, pi - use time_manager_mod, only: time_type, set_calendar_type, set_date, NOLEAP, JULIAN, operator(+), set_time, print_time + use time_manager_mod, only: time_type, set_calendar_type, set_date, NOLEAP, JULIAN, operator(+), & + set_time, print_time use diag_manager_mod, only: diag_manager_init, diag_manager_end, register_static_field, register_diag_field use diag_manager_mod, only: send_data, diag_axis_init use data_override_mod, only: data_override_init, data_override, data_override_UG @@ -98,7 +101,7 @@ program test integer, allocatable :: is_win(:), js_win(:) integer :: nx_dom, ny_dom, nx_win, ny_win type(domain2d) :: Domain - integer :: nlon, nlat, siz(4) + integer :: nlon, nlat, siz(2) real, allocatable, dimension(:) :: x, y real, allocatable, dimension(:,:) :: lon, lat real, allocatable, dimension(:,:) :: sst, ice @@ -117,6 +120,9 @@ program test integer :: nwindows integer :: nx_cubic=90, ny_cubic=90, nx_latlon=90, ny_latlon=90 integer :: test_num=1 !* 1 for unstruct cubic grid, 2 for unstruct latlon-grid + + type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile + namelist / test_data_override_nml / layout, window, nthreads, nx_cubic, ny_cubic, nx_latlon, ny_latlon, test_num call fms_init @@ -131,23 +137,27 @@ program test read (input_nml_file, test_data_override_nml, iostat=io) ierr = check_nml_error(io, 'test_data_override_nml') - if(field_exist(grid_file, "x_T" ) ) then - call field_size(grid_file, 'x_T', siz) + if (.not. open_file(fileobj_grid, grid_file, "read")) call error_mesg('test_data_override', & + 'The grid_file does not exist', FATAL) + if(variable_exists(fileobj_grid, "x_T" ) ) then + call get_variable_size(fileobj_grid, 'x_T', siz) nlon = siz(1) nlat = siz(2) - else if(field_exist(grid_file, "geolon_t" ) ) then - call field_size(grid_file, 'geolon_t', siz) + else if(variable_exists(fileobj_grid, "geolon_t" ) ) then + call get_variable_size(fileobj_grid, 'geolon_t', siz) nlon = siz(1) nlat = siz(2) - else if (field_exist(grid_file, "ocn_mosaic_file" )) then - call read_data(grid_file, 'ocn_mosaic_file', solo_mosaic_file) + else if (variable_exists(fileobj_grid, "ocn_mosaic_file" )) then + call read_data(fileobj_grid, 'ocn_mosaic_file', solo_mosaic_file) solo_mosaic_file = 'INPUT/'//trim(solo_mosaic_file) - call field_size(solo_mosaic_file, 'gridfiles', siz) - if( siz(2) .NE. 1) & - call error_mesg('test_data_override', 'only support single tile mosaic, contact developer', FATAL) - call read_data(solo_mosaic_file, 'gridfiles', tile_file) + if (.not. open_file(fileobj_solo_mosaic, solo_mosaic_file, "read")) call error_mesg('test_data_override', & + 'The solo_mosaic fike does not exist', FATAL) + call get_variable_size(fileobj_solo_mosaic, 'gridfiles', siz) + call read_data(fileobj_solo_mosaic, 'gridfiles', tile_file) tile_file = 'INPUT/'//trim(tile_file) - call field_size(tile_file, 'area', siz) + if(.not. open_file(fileobj_tile, tile_file, "read")) call error_mesg('test_data_override', & + 'The tile_file does not exist', FATAL) + call get_variable_size(fileobj_tile, 'area', siz) if(mod(siz(1),2) .NE. 0 .OR. mod(siz(2),2) .NE. 0 ) call error_mesg('test_data_override', & "test_data_override: supergrid size can not be divided by 2", FATAL) nlon = siz(1)/2 @@ -306,41 +316,43 @@ program test !------------------------------------------------------------------------------------------------------- call diag_manager_end(Time) - call fms_io_exit call fms_end contains -!====================================================================================================================== +!==================================================================================================================== subroutine get_grid real, allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo real, allocatable, dimension(:,:) :: lon_global, lat_global - integer, dimension(4) :: siz + integer, dimension(2) :: siz character(len=128) :: message + type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile - if(field_exist(grid_file, 'x_T')) then - call field_size(grid_file, 'x_T', siz) + if (.not. open_file(fileobj_grid, grid_file, "read")) call error_mesg('test_data_override', & + 'The grid_file does not exist', FATAL) + if(variable_exists(fileobj_grid, 'x_T')) then + call get_variable_size(fileobj_grid, 'x_T', siz) if(siz(1) /= nlon .or. siz(2) /= nlat) then write(message,'(a,2i4)') 'x_T is wrong shape. shape(x_T)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(nlon,nlat,4), lat_vert_glo(nlon,nlat,4) ) allocate(lon_global (nlon,nlat ), lat_global (nlon,nlat ) ) - call read_data(trim(grid_file), 'x_vert_T', lon_vert_glo, no_domain=.true.) - call read_data(trim(grid_file), 'y_vert_T', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_grid, 'x_vert_T', lon_vert_glo) + call read_data(fileobj_grid, 'y_vert_T', lat_vert_glo) lon_global(:,:) = (lon_vert_glo(:,:,1) + lon_vert_glo(:,:,2) + lon_vert_glo(:,:,3) + lon_vert_glo(:,:,4))*0.25 lat_global(:,:) = (lat_vert_glo(:,:,1) + lat_vert_glo(:,:,2) + lat_vert_glo(:,:,3) + lat_vert_glo(:,:,4))*0.25 - else if(field_exist(grid_file, "geolon_t" ) ) then - call field_size(grid_file, 'geolon_vert_t', siz) + else if(variable_exists(fileobj_grid, "geolon_t" ) ) then + call get_variable_size(fileobj_grid, 'geolon_vert_t', siz) if(siz(1) /= nlon+1 .or. siz(2) /= nlat+1) then write(message,'(a,2i4)') 'geolon_vert_t is wrong shape. shape(geolon_vert_t)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(nlon+1,nlat+1,1), lat_vert_glo(nlon+1,nlat+1,1)) allocate(lon_global (nlon, nlat ), lat_global (nlon, nlat )) - call read_data(trim(grid_file), 'geolon_vert_t', lon_vert_glo, no_domain=.true.) - call read_data(trim(grid_file), 'geolat_vert_t', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_grid, 'geolon_vert_t', lon_vert_glo) + call read_data(fileobj_grid, 'geolat_vert_t', lat_vert_glo) do i = 1, nlon do j = 1, nlat @@ -350,16 +362,18 @@ subroutine get_grid lat_vert_glo(i+1,j+1,1) + lat_vert_glo(i,j+1,1))*0.25 enddo enddo - else if( field_exist(grid_file, "ocn_mosaic_file") ) then ! reading from mosaic file - call field_size(tile_file, 'area', siz) + else if( variable_exists(fileobj_grid, "ocn_mosaic_file") ) then ! reading from mosaic file + if(.not. open_file(fileobj_tile, tile_file, "read")) call error_mesg('test_data_override', & + 'The tile_file does not exist', FATAL) + call get_variable_size(fileobj_tile, 'area', siz) if(siz(1) /= nlon*2 .or. siz(2) /= nlat*2) then write(message,'(a,2i4)') 'area is wrong shape. shape(area)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(siz(1)+1,siz(2)+1,1), lat_vert_glo(siz(1)+1,siz(2)+1,1)) allocate(lon_global (nlon, nlat ), lat_global (nlon, nlat )) - call read_data( tile_file, 'x', lon_vert_glo, no_domain=.true.) - call read_data( tile_file, 'y', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_tile, 'x', lon_vert_glo) + call read_data(fileobj_tile, 'y', lat_vert_glo) do j = 1, nlat do i = 1, nlon lon_global(i,j) = lon_vert_glo(i*2,j*2,1) @@ -824,5 +838,5 @@ subroutine define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_ end subroutine define_cubic_mosaic -!====================================================================================================================== +!==================================================================================================================== end program test diff --git a/test_fms/diag_manager/test_diag_manager.F90 b/test_fms/diag_manager/test_diag_manager.F90 index b943cb38af..8c6ef4745c 100644 --- a/test_fms/diag_manager/test_diag_manager.F90 +++ b/test_fms/diag_manager/test_diag_manager.F90 @@ -223,15 +223,16 @@ PROGRAM test ! Because of this, the calls to all of those routines differ depending on the test. USE mpp_mod, ONLY: mpp_pe, mpp_root_pe, mpp_debug, mpp_set_stack_size - USE mpp_io_mod, ONLY: mpp_io_init USE mpp_domains_mod, ONLY: domain2d, mpp_define_domains, mpp_get_compute_domain USE mpp_domains_mod, ONLY: mpp_define_io_domain, mpp_define_layout USE mpp_domains_mod, ONLY: mpp_domains_init, mpp_domains_set_stack_size - USE fms_mod, ONLY: fms_init, fms_end, mpp_npes, file_exist, check_nml_error, open_file + USE fms_mod, ONLY: fms_init, fms_end, mpp_npes, check_nml_error USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdlog, stdout USE mpp_mod, ONLY: input_nml_file - USE fms_io_mod, ONLY: fms_io_init +#ifdef use_deprecated_io + USE fms_io_mod, ONLY: fms_io_init, file_exist, open_file USE fms_io_mod, ONLY: fms_io_exit, set_filename_appendix +#endif USE constants_mod, ONLY: constants_init, PI, RAD_TO_DEG USE time_manager_mod, ONLY: time_type, set_calendar_type, set_date, decrement_date, OPERATOR(+), set_time @@ -374,14 +375,13 @@ PROGRAM test endif !Initialize the mpp_io module. +#ifdef use_deprecated_io if (debug) then call mpp_io_init(MPP_DEBUG) else call mpp_io_init() endif - - !Initialize the fms_io module. - call fms_io_init() +#endif !Set the mpp and mpp_domains stack sizes. call mpp_set_stack_size(stackmax) @@ -546,7 +546,9 @@ PROGRAM test IF ( test_number == 16 ) THEN ! Test 16 tests the filename appendix +#ifdef use_deprecated_io CALL set_filename_appendix('g01') +#endif END IF id_dat1 = register_diag_field('test_diag_manager_mod', 'dat1', (/id_lon1,id_lat1,id_pfull/), Time, 'sample data','K') IF ( test_number == 18 ) THEN @@ -1002,7 +1004,6 @@ PROGRAM test CALL diag_manager_end(Time) END SELECT ! End of case handling opened for test 12. - CALL fms_io_exit CALL fms_end CONTAINS diff --git a/test_fms/fms/test_fms.F90 b/test_fms/fms/test_fms.F90 index faffd998eb..0827e3c91c 100644 --- a/test_fms/fms/test_fms.F90 +++ b/test_fms/fms/test_fms.F90 @@ -79,6 +79,7 @@ program test_fms contains + #include "test_fms_r4.fh" #include "test_fms_r8.fh" diff --git a/test_fms/interpolator/test_interpolator.F90 b/test_fms/interpolator/test_interpolator.F90 index 367ceefa4a..6a5c0b5f02 100644 --- a/test_fms/interpolator/test_interpolator.F90 +++ b/test_fms/interpolator/test_interpolator.F90 @@ -43,6 +43,7 @@ program test_interpolator use interpolator_mod use constants_mod use time_interp_mod, only : time_interp_init +use fms2_io_mod, only : open_file, FmsNetcdfFile_t implicit none integer, parameter :: nsteps_per_day = 8, ndays = 16 @@ -255,8 +256,12 @@ subroutine sulfate_init(aerosol,lonb, latb, names, data_out_of_bounds, vert_inte integer, intent(in) :: data_out_of_bounds(:) integer, intent(in), optional :: vert_interp(:) character(len=*), intent(out),optional :: units(:) +character(len=128) :: filename_aerosol -if (.not. file_exist("INPUT/aerosol.climatology.nc") ) return +type(FmsNetcdfFile_t) :: fileobj_aerosol + +filename_aerosol = "INPUT/aerosol.climatology.nc" +if (.not. open_file(fileobj_aerosol, filename_aerosol, "read") ) return call interpolator_init( aerosol, "aerosol.climatology.nc", lonb, latb, & data_names=names, data_out_of_bounds=data_out_of_bounds, & vert_interp=vert_interp, clim_units=units ) @@ -287,8 +292,12 @@ subroutine ozone_init( o3, lonb, latb, axes, model_time, data_out_of_bounds, ver type(interpolate_type),intent(inout) :: o3 integer, intent(in) :: data_out_of_bounds(:) integer, intent(in), optional :: vert_interp(:) +character(len=128) :: filename_o3 + +type(FmsNetcdfFile_t) :: fileobj_o3 -if (.not. file_exist("INPUT/o3.climatology.nc") ) return +filename_o3 = "INPUT/o3.climatology.nc" +if (.not. open_file(fileobj_o3, filename_o3, "read") ) return call interpolator_init( o3, "o3.climatology.nc", lonb, latb, & data_out_of_bounds=data_out_of_bounds, vert_interp=vert_interp ) diff --git a/test_fms/mpp/test_global_arrays.F90 b/test_fms/mpp/test_global_arrays.F90 index edb3605df6..ce2b125cb4 100644 --- a/test_fms/mpp/test_global_arrays.F90 +++ b/test_fms/mpp/test_global_arrays.F90 @@ -28,7 +28,6 @@ program test_global_arrays use mpp_mod, only: mpp_set_stack_size, mpp_sync, mpp_sync_self use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_send, mpp_recv, WARNING use mpp_mod, only: mpp_init_test_init_true_only, mpp_set_root_pe - use mpp_io_mod, only: mpp_io_init use mpp_domains_mod, only: mpp_domains_init, mpp_define_domains, domain2d use mpp_domains_mod, only: mpp_define_layout, mpp_domains_set_stack_size use mpp_domains_mod, only: mpp_get_global_domain, mpp_global_max @@ -58,7 +57,6 @@ program test_global_arrays real(r8_kind), parameter :: tol4 = 1e-4, tol8 = 1e-6!> tolerance for real comparisons call mpp_init(mpp_init_test_init_true_only) - call mpp_io_init() call mpp_domains_init() call mpp_set_stack_size(3145746) call mpp_domains_set_stack_size(3145746) diff --git a/test_fms/mpp/test_mpp.F90 b/test_fms/mpp/test_mpp.F90 index 6e0e609f92..034ff3a850 100644 --- a/test_fms/mpp/test_mpp.F90 +++ b/test_fms/mpp/test_mpp.F90 @@ -27,7 +27,6 @@ program test !test various aspects of mpp_mod use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_broadcast, mpp_transmit, mpp_sum, mpp_max, mpp_chksum, ALL_PES use mpp_mod, only : mpp_gather, mpp_error, FATAL, mpp_sync_self - use mpp_io_mod, only: mpp_io_init, mpp_flush use platform_mod implicit none @@ -42,7 +41,6 @@ program test !test various aspects of mpp_mod real :: dt call mpp_init() - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_gatscat.F90 b/test_fms/mpp/test_mpp_gatscat.F90 index 47ff6cf81c..d5709b91c7 100644 --- a/test_fms/mpp/test_mpp_gatscat.F90 +++ b/test_fms/mpp/test_mpp_gatscat.F90 @@ -34,7 +34,6 @@ program test_mpp_gatscat use mpp_mod, only : mpp_sync use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_gather, mpp_scatter, mpp_error, FATAL - use mpp_io_mod, only: mpp_io_init, mpp_flush use mpp_mod, only : mpp_init_test_requests_allocated use platform_mod @@ -59,7 +58,6 @@ program test_mpp_gatscat integer :: ierr call mpp_init(mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_global_sum_ad.F90 b/test_fms/mpp/test_mpp_global_sum_ad.F90 index 696d732d40..c50f9a060e 100644 --- a/test_fms/mpp/test_mpp_global_sum_ad.F90 +++ b/test_fms/mpp/test_mpp_global_sum_ad.F90 @@ -38,7 +38,6 @@ program test_mpp_global_sum_ad use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains use mpp_domains_mod, only : NORTH, EAST, CORNER, CENTER use mpp_domains_mod, only : mpp_global_sum_ad - use mpp_io_mod, only : mpp_io_init use platform_mod @@ -51,7 +50,6 @@ program test_mpp_global_sum_ad call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DEBUG) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() diff --git a/test_fms/mpp/test_mpp_sendrecv.F90 b/test_fms/mpp/test_mpp_sendrecv.F90 index d6c315994e..5f82683e14 100644 --- a/test_fms/mpp/test_mpp_sendrecv.F90 +++ b/test_fms/mpp/test_mpp_sendrecv.F90 @@ -34,7 +34,6 @@ program test_mpp_sendrecv use mpp_mod, only : mpp_sync use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_send, mpp_recv, mpp_error, FATAL - use mpp_io_mod, only: mpp_io_init, mpp_flush use mpp_mod, only : mpp_init_test_requests_allocated use platform_mod @@ -59,7 +58,6 @@ program test_mpp_sendrecv integer :: ierr call mpp_init(mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_update_domains_ad.F90 b/test_fms/mpp/test_mpp_update_domains_ad.F90 index 07739e8e65..aeaf253528 100644 --- a/test_fms/mpp/test_mpp_update_domains_ad.F90 +++ b/test_fms/mpp/test_mpp_update_domains_ad.F90 @@ -33,7 +33,6 @@ program test_mpp_update_domains_ad use mpp_domains_mod, only : mpp_update_domains, mpp_update_domains_ad, mpp_check_field use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains, mpp_modify_domain use mpp_domains_mod, only : mpp_get_global_domain - use mpp_io_mod, only : mpp_io_init use platform_mod, only : r4_kind, r8_kind implicit none @@ -48,7 +47,6 @@ program test_mpp_update_domains_ad !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DOMAIN_TIME) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_update_domains_int.F90 b/test_fms/mpp/test_mpp_update_domains_int.F90 index 611894af3f..11e3e80aa6 100644 --- a/test_fms/mpp/test_mpp_update_domains_int.F90 +++ b/test_fms/mpp/test_mpp_update_domains_int.F90 @@ -47,7 +47,6 @@ module test_mpp_update_domains_int use mpp_domains_mod, only : SOUTH, SOUTH_WEST, WEST, NORTH_WEST, mpp_define_mosaic_pelist use mpp_domains_mod, only : mpp_get_global_domain, ZERO, NINETY, MINUS_NINETY use mpp_domains_mod, only : mpp_deallocate_domain - use mpp_io_mod, only: mpp_io_init use platform_mod, only: i4_kind, i8_kind implicit none diff --git a/test_fms/mpp/test_mpp_update_domains_main.F90 b/test_fms/mpp/test_mpp_update_domains_main.F90 index 0eb5223df1..c1c094fbc9 100644 --- a/test_fms/mpp/test_mpp_update_domains_main.F90 +++ b/test_fms/mpp/test_mpp_update_domains_main.F90 @@ -31,7 +31,6 @@ program test_mpp_update_domains_main use mpp_mod, only : mpp_init_test_requests_allocated use mpp_domains_mod, only : MPP_DOMAIN_TIME, mpp_domains_set_stack_size use mpp_domains_mod, only : mpp_domains_init, mpp_domains_exit - use mpp_io_mod, only: mpp_io_init use platform_mod implicit none @@ -41,7 +40,6 @@ program test_mpp_update_domains_main !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DOMAIN_TIME) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) !> run the tests !> run the tests diff --git a/test_fms/mpp/test_update_domains_performance.F90 b/test_fms/mpp/test_update_domains_performance.F90 index 32bfcdd121..a0a81443e2 100644 --- a/test_fms/mpp/test_update_domains_performance.F90 +++ b/test_fms/mpp/test_update_domains_performance.F90 @@ -38,7 +38,6 @@ program test_update_domains_performance use mpp_domains_mod, only : NORTH, SOUTH, WEST, EAST, CENTER use mpp_domains_mod, only : mpp_get_global_domain, ZERO use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains - use mpp_io_mod, only: mpp_io_init use platform_mod implicit none @@ -65,7 +64,6 @@ program test_update_domains_performance logical :: mix_2D_3D = .false. !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_domains_init(MPP_DOMAIN_TIME) call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() diff --git a/test_fms/mpp_io/test_io_R4_R8.F90 b/test_fms/mpp_io/test_io_R4_R8.F90 index 49c17e0b4d..37282cf970 100644 --- a/test_fms/mpp_io/test_io_R4_R8.F90 +++ b/test_fms/mpp_io/test_io_R4_R8.F90 @@ -22,6 +22,7 @@ !> @description Tests mpp_write and mpp_read for reads/writes !> with mixed precision reals on non-mosaic files program test_io_R4_R8 +#ifdef use_deprecated_io use platform_mod, only : r4_kind, r8_kind, i8_kind use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self @@ -513,5 +514,5 @@ subroutine test_netcdf_io_R8(type) deallocate( rdata8, gdata8, data8) end subroutine test_netcdf_io_R8 - +#endif end program test_io_R4_R8 diff --git a/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 b/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 index 8360bd2523..b76dac7f77 100644 --- a/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 +++ b/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 @@ -23,6 +23,7 @@ !> @description Performs reads and writes on mosaic files using mpp_write !> and mpp_read using 32 and 64 bit reals program test_io_mosaic_R4_R8 +#ifdef use_deprecated_io use platform_mod use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self @@ -413,5 +414,5 @@ subroutine test_netcdf_io_mosaic_R8(type, layout, ntiles_x, ntiles_y, io_layout) call mpp_deallocate_domain(domain) end subroutine test_netcdf_io_mosaic_R8 - +#endif end program test_io_mosaic_R4_R8 diff --git a/test_fms/mpp_io/test_mpp_io.F90 b/test_fms/mpp_io/test_mpp_io.F90 index 907d45600b..46cefef2d7 100644 --- a/test_fms/mpp_io/test_mpp_io.F90 +++ b/test_fms/mpp_io/test_mpp_io.F90 @@ -17,7 +17,7 @@ !* License along with FMS. If not, see . !*********************************************************************** program test - +#ifdef use_deprecated_io use platform_mod, only : i8_kind, r8_kind use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self use mpp_mod, only : FATAL, NOTE, mpp_chksum, MPP_DEBUG, mpp_set_stack_size, MPP_CLOCK_SYNC @@ -565,5 +565,5 @@ subroutine test_netcdf_io_mosaic(type, layout, ntiles_x, ntiles_y, io_layout) call mpp_deallocate_domain(domain) end subroutine test_netcdf_io_mosaic - +#endif end program test diff --git a/test_fms/parser/parser_demo.F90 b/test_fms/parser/parser_demo.F90 index 16bc1c81ac..5b4ccfd88e 100644 --- a/test_fms/parser/parser_demo.F90 +++ b/test_fms/parser/parser_demo.F90 @@ -115,5 +115,4 @@ program parser_demo deallocate(file_ids) #endif - end program parser_demo diff --git a/time_interp/time_interp_external.F90 b/time_interp/time_interp_external.F90 index c25f694dea..7c446f4c52 100644 --- a/time_interp/time_interp_external.F90 +++ b/time_interp/time_interp_external.F90 @@ -32,6 +32,7 @@ !> @addtogroup time_interp_external_mod !> @{ module time_interp_external_mod +#ifdef use_deprecated_io #include ! !M.J. Harrison @@ -1417,7 +1418,7 @@ subroutine time_interp_external_exit() end subroutine time_interp_external_exit ! NAME="time_interp_external_exit" - +#endif end module time_interp_external_mod !> @} ! close documentation grouping From cbceb9fe72fe6f67a8c9b75cdc6dd8ce1be1c59a Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Fri, 30 Jun 2023 14:34:15 -0400 Subject: [PATCH 014/394] fix: field exists check for io update (#1193) --- time_interp/time_interp_external2.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/time_interp/time_interp_external2.F90 b/time_interp/time_interp_external2.F90 index fbe2f9e6f1..7716e17ea4 100644 --- a/time_interp/time_interp_external2.F90 +++ b/time_interp/time_interp_external2.F90 @@ -408,15 +408,6 @@ function init_external_field(file,fieldname,domain,desired_units,& init_external_field = -1 nfields_orig = num_fields - tavg = -1.0 - tstart = tstamp - tend = tstamp - if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then - if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) - if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) - if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) - endif - if (.not. variable_exists(fileobj, fieldname) ) then if (present(ierr)) then ierr = ERR_FIELD_NOT_FOUND @@ -426,6 +417,15 @@ function init_external_field(file,fieldname,domain,desired_units,& endif endif + tavg = -1.0 + tstart = tstamp + tend = tstamp + if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then + if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) + if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) + if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) + endif + num_fields = num_fields + 1 if(num_fields > max_fields) then !--- z1l: For the case of multiple thread, realoc_fields will cause memory leak. From 46e55f2b1bb8fa998ae8f9ae66042ba2dd9092bd Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Fri, 30 Jun 2023 14:48:29 -0400 Subject: [PATCH 015/394] fix: diag_fieldbuff_update module dependency in Makefile.am (#1266) --- diag_manager/Makefile.am | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 37759e838f..13ea77d8b7 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -57,8 +57,9 @@ fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_ fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) -fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) +fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ From 8c73bd18dc1d580f2ee524c37cf903ff54d40501 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 30 Jun 2023 15:17:46 -0400 Subject: [PATCH 016/394] chore: add deprecated io options to build systems and CI (#1063) --- .github/workflows/build_cmake_gnu.yml | 3 ++- .github/workflows/build_ubuntu_gnu.yml | 3 ++- CMakeLists.txt | 5 +++++ configure.ac | 17 ++++++++++++++++- test_fms/mpp_io/Makefile.am | 4 ++++ 5 files changed, 29 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build_cmake_gnu.yml b/.github/workflows/build_cmake_gnu.yml index f649345d8a..d4f7e2a248 100644 --- a/.github/workflows/build_cmake_gnu.yml +++ b/.github/workflows/build_cmake_gnu.yml @@ -9,10 +9,11 @@ jobs: matrix: omp-flags: [ -DOPENMP=on, -DOPENMP=off ] libyaml-flag: [ "", -DWITH_YAML=on ] + io-flag: [ "", -DUSE_DEPRECATED_IO=on ] container: image: noaagfdl/hpc-me.ubuntu-minimal:cmake env: - CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.libyaml-flag }} -D64BIT=on" + CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.io-flag }} ${{ matrix.libyaml-flag }} -D64BIT=on" steps: - name: Checkout code uses: actions/checkout@v2 diff --git a/.github/workflows/build_ubuntu_gnu.yml b/.github/workflows/build_ubuntu_gnu.yml index f4dc48225f..7c53895b15 100644 --- a/.github/workflows/build_ubuntu_gnu.yml +++ b/.github/workflows/build_ubuntu_gnu.yml @@ -12,11 +12,12 @@ jobs: matrix: conf-flags: [--disable-openmp, --enable-mixed-mode, --disable-setting-flags, --with-mpi=no] input-flag: [--with-yaml, --enable-test-input=/home/unit_tests_input] + io-flag: [ --enable-deprecated-io, --disable-deprecated-io] container: image: noaagfdl/hpc-me.ubuntu-minimal:gnu-input env: TEST_VERBOSE: 1 - DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flags }} ${{ matrix.input-flag }}" + DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flags }} ${{ matrix.input-flag }} ${{ matrix.io-flag }}" steps: - name: Checkout code uses: actions/checkout@v2 diff --git a/CMakeLists.txt b/CMakeLists.txt index cc60d914c2..270539cd4d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -66,6 +66,7 @@ option(ENABLE_QUAD_PRECISION "Enable compiler definition -DENABLE_QUAD_PRECISION option(GFS_PHYS "Enable compiler definition -DGFS_PHYS" OFF) option(LARGEFILE "Enable compiler definition -Duse_LARGEFILE" OFF) option(WITH_YAML "Enable compiler definition -Duse_yaml" OFF) +option(USE_DEPRECATED_IO "Enable compiler definition -Duse_deprecated_io (compile with fms_io/mpp_io)" OFF) if(32BIT) list(APPEND kinds "r4") @@ -246,6 +247,10 @@ if(WITH_YAML) list(APPEND fms_defs use_yaml) endif() +if(USE_DEPRECATED_IO) + list(APPEND fms_defs use_deprecated_io) +endif() + if(INTERNAL_FILE_NML) list(APPEND fms_defs INTERNAL_FILE_NML) endif() diff --git a/configure.ac b/configure.ac index 241e08d079..82588b6c84 100644 --- a/configure.ac +++ b/configure.ac @@ -110,6 +110,13 @@ AS_IF([test ${enable_8byte_int:-no} = yes], [enable_8byte_int=yes], [enable_8byte_int=no]) +AC_ARG_ENABLE([deprecated-io], + [AS_HELP_STRING([--enable-deprecated-io], + [Enables compilation of deprecated mpp_io and fms_io modules in addition to the updated fms2_io modules (default no)])]) +AS_IF([test ${enable_deprecated_io:-no} = yes], + [enable_deprecated_io=yes], + [enable_deprecated_io=no]) + # user enabled testing with input files AC_MSG_CHECKING([whether to enable tests with input files]) AC_ARG_ENABLE([test-input], @@ -203,7 +210,6 @@ AC_MSG_CHECKING([if netCDF was built with HDF5]) AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ #include #if !(NC_HAS_NC4) - choke me #endif]])], [nc_has_nc4=yes], [nc_has_nc4=no]) AC_MSG_RESULT([$nc_has_nc4]) if test $nc_has_nc4 = no; then @@ -281,6 +287,15 @@ if test $with_mpi = yes; then AC_DEFINE([use_libMPI], [1], [This is required for the library to build]) fi +# check if compiling old io +if test $enable_deprecated_io = yes; then + #If the test pass, define use_deprecated_io macro and skip it's unit tests + AC_DEFINE([use_deprecated_io], [1], [This is required to use mpp_io and fms_io modules]) + AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], true) +else + AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], false) +fi + # Set any required compile flags. This will not be done if the user wants to # define all their own flags. if test $enable_setting_flags = yes; then diff --git a/test_fms/mpp_io/Makefile.am b/test_fms/mpp_io/Makefile.am index af5ec8d488..2357549cfa 100644 --- a/test_fms/mpp_io/Makefile.am +++ b/test_fms/mpp_io/Makefile.am @@ -38,6 +38,10 @@ test_mpp_io_SOURCES = test_mpp_io.F90 test_io_R4_R8_SOURCES = test_io_R4_R8.F90 test_io_mosaic_R4_R8_SOURCES = test_io_mosaic_R4_R8.F90 +if SKIP_DEPRECATED_IO_TESTS +TESTS_ENVIRONMENT= SKIP_TESTS="test_mpp_io2.1 test_io_R4_R8.1 test_io_mosaic_R4_R8.1" +endif + # Run the test program. TESTS = test_mpp_io2.sh \ test_io_R4_R8.sh \ From dbed2ceb9c9acfd392eb18bd00e758cde31b55df Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Wed, 5 Jul 2023 13:50:17 -0400 Subject: [PATCH 017/394] fix: test errors from io flag (#1271) --- test_fms/diag_manager/test_diag_manager.F90 | 1 + test_fms/interpolator/test_interpolator.F90 | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/test_fms/diag_manager/test_diag_manager.F90 b/test_fms/diag_manager/test_diag_manager.F90 index 8c6ef4745c..dd263d2e3f 100644 --- a/test_fms/diag_manager/test_diag_manager.F90 +++ b/test_fms/diag_manager/test_diag_manager.F90 @@ -232,6 +232,7 @@ PROGRAM test #ifdef use_deprecated_io USE fms_io_mod, ONLY: fms_io_init, file_exist, open_file USE fms_io_mod, ONLY: fms_io_exit, set_filename_appendix + use mpp_io_mod, only: mpp_io_init #endif USE constants_mod, ONLY: constants_init, PI, RAD_TO_DEG diff --git a/test_fms/interpolator/test_interpolator.F90 b/test_fms/interpolator/test_interpolator.F90 index 6a5c0b5f02..4636cde918 100644 --- a/test_fms/interpolator/test_interpolator.F90 +++ b/test_fms/interpolator/test_interpolator.F90 @@ -37,7 +37,11 @@ program test_interpolator use mpp_mod use mpp_domains_mod +#ifdef use_deprecated_io +use fms_mod, old_open_file => open_file +#else use fms_mod +#endif use time_manager_mod use diag_manager_mod use interpolator_mod From 7831d2e036c9f3920b2304677454d2e1e58d6798 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Tue, 11 Jul 2023 09:43:17 -0400 Subject: [PATCH 018/394] CI: update oneapi container version (#1277) --- .github/workflows/intel_pr.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/intel_pr.yml b/.github/workflows/intel_pr.yml index d95519fbf2..62a15361ea 100644 --- a/.github/workflows/intel_pr.yml +++ b/.github/workflows/intel_pr.yml @@ -3,7 +3,7 @@ jobs: intel-autotools: runs-on: ubuntu-latest container: - image: intel/oneapi-hpckit:2022.2-devel-ubuntu20.04 + image: intel/oneapi-hpckit:2023.1.0-devel-ubuntu20.04 env: CC: mpiicc FC: mpiifort @@ -22,7 +22,7 @@ jobs: path: /libs key: ${{ runner.os }}-intel-libs - name: Install packages for building - run: apt update && apt install -y autoconf libtool automake zlibc zlib1g-dev + run: apt-get update && apt-get install -y autoconf libtool automake zlibc zlib1g-dev - if: steps.cache.outputs.cache-hit != 'true' name: Build netcdf run: | @@ -50,4 +50,4 @@ jobs: - name: Compile run: make -j || make - name: Run test suite - run: make check LD_LIBRARY_PATH="/libs/lib:$LD_LIBRARY_PATH" SKIP_TESTS="$SKIP_TESTS" VERBOSE=1 + run: make check LD_LIBRARY_PATH="/libs/lib:$LD_LIBRARY_PATH" TEST_VERBOSE=1 From 05337ea4e9f9e01339dce8149d2ac033c04d90c5 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:16:11 -0400 Subject: [PATCH 019/394] refactor: `monin_obukhov_stable_mix` calls from `stable_mix_1d` (#1268) --- monin_obukhov/monin_obukhov.F90 | 53 ++++++++++++++++----------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/monin_obukhov/monin_obukhov.F90 b/monin_obukhov/monin_obukhov.F90 index 883e4cbe34..ac8a89075f 100644 --- a/monin_obukhov/monin_obukhov.F90 +++ b/monin_obukhov/monin_obukhov.F90 @@ -274,16 +274,18 @@ subroutine stable_mix_3d(rich, mix) real, intent(in) , dimension(:,:,:) :: rich real, intent(out), dimension(:,:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: n3 !< Size of dimension 3 of mix and rich +integer :: i, j !< Loop indices -integer :: n, ier - -if(.not.module_is_initialized) call error_mesg('stable_mix_3d in monin_obukhov_mod', & - 'monin_obukhov_init has not been called', FATAL) - -n = size(rich,1)*size(rich,2)*size(rich,3) -call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & - & n, rich, mix, ier) +n2 = size(mix, 2) +n3 = size(mix, 3) +do j=1, n3 + do i=1, n2 + call stable_mix(rich(:, i, j), mix(:, i, j)) + enddo +enddo end subroutine stable_mix_3d @@ -943,16 +945,15 @@ subroutine stable_mix_2d(rich, mix) real, intent(in) , dimension(:,:) :: rich real, intent(out), dimension(:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: i !< Loop index -real, dimension(size(rich,1),size(rich,2),1) :: rich_3d, mix_3d - -rich_3d(:,:,1) = rich +n2 = size(mix, 2) -call stable_mix_3d(rich_3d, mix_3d) - -mix = mix_3d(:,:,1) +do i=1, n2 + call stable_mix(rich(:, i), mix(:, i)) +enddo -return end subroutine stable_mix_2d @@ -962,16 +963,17 @@ subroutine stable_mix_1d(rich, mix) real, intent(in) , dimension(:) :: rich real, intent(out), dimension(:) :: mix +integer :: n !< Size of mix and rich +integer :: ierr !< Error code set by monin_obukhov_stable_mix -real, dimension(size(rich),1,1) :: rich_3d, mix_3d - -rich_3d(:,1,1) = rich +if (.not.module_is_initialized) call error_mesg('stable_mix in monin_obukhov_mod', & + 'monin_obukhov_init has not been called', FATAL) -call stable_mix_3d(rich_3d, mix_3d) +n = size(mix) -mix = mix_3d(:,1,1) +call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & + & n, rich, mix, ierr) -return end subroutine stable_mix_1d !======================================================================= @@ -981,15 +983,12 @@ subroutine stable_mix_0d(rich, mix) real, intent(in) :: rich real, intent(out) :: mix -real, dimension(1,1,1) :: rich_3d, mix_3d - -rich_3d(1,1,1) = rich +real, dimension(1) :: mix_1d !< Representation of mix as a dimension(1) array -call stable_mix_3d(rich_3d, mix_3d) +call stable_mix([rich], mix_1d) -mix = mix_3d(1,1,1) +mix = mix_1d(1) -return end subroutine stable_mix_0d !======================================================================= From 0463dd122cb53418848a9798e12fa6641d8c2483 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:30:34 -0400 Subject: [PATCH 020/394] fix: out-of-bounds memory access in axis_utils2 (#1157) --- axis_utils/include/axis_utils2.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index 21deca9fb4..3acd69b28c 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -213,7 +213,7 @@ endif lon_strt = lon(1) - do i=2,len+1 + do i=2,len lon(i) = lon_in_range(lon(i),lon_strt) lon_strt = lon(i) enddo From 8eb24f8bcdd65d1e061bff5578b928013e375de2 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:44:53 -0400 Subject: [PATCH 021/394] fix: maximize system stacksize limit in fms_init (#1233) --- fms/Makefile.am | 1 + fms/fms.F90 | 9 +++++++++ fms/fms_stacksize.c | 33 +++++++++++++++++++++++++++++++++ 3 files changed, 43 insertions(+) create mode 100644 fms/fms_stacksize.c diff --git a/fms/Makefile.am b/fms/Makefile.am index 8f8c58525b..ca8b107941 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -32,6 +32,7 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ fms.F90 \ + fms_stacksize.c \ include/fms.inc \ include/fms_r4.fh \ include/fms_r8.fh \ diff --git a/fms/fms.F90 b/fms/fms.F90 index 3ec8052148..2ac9393b48 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -336,6 +336,11 @@ subroutine fms_init (localcomm, alt_input_nml_path) use fms_io_mod, only: fms_io_version #endif + interface + subroutine maximize_system_stacksize_limit() bind(C) + end subroutine + end interface + integer, intent(in), optional :: localcomm character(len=*), intent(in), optional :: alt_input_nml_path integer :: ierr, io @@ -344,6 +349,10 @@ subroutine fms_init (localcomm, alt_input_nml_path) if (module_is_initialized) return ! return silently if already called module_is_initialized = .true. + +!---- Raise the system stack size limit to its maximum permissible value ---- + call maximize_system_stacksize_limit + !---- initialize mpp routines ---- if(present(localcomm)) then if(present(alt_input_nml_path)) then diff --git a/fms/fms_stacksize.c b/fms/fms_stacksize.c new file mode 100644 index 0000000000..7631656475 --- /dev/null +++ b/fms/fms_stacksize.c @@ -0,0 +1,33 @@ +/*********************************************************************** + * GNU Lesser General Public License + * + * This file is part of the GFDL Flexible Modeling System (FMS). + * + * FMS is free software: you can redistribute it and/or modify it under + * the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or (at + * your option) any later version. + * + * FMS is distributed in the hope that it will be useful, but WITHOUT + * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + * for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with FMS. If not, see . + **********************************************************************/ + +#include + +/* + * Set the stack size limit to its maximum permissible value + */ + +void maximize_system_stacksize_limit() +{ + struct rlimit stacksize; + + getrlimit(RLIMIT_STACK, &stacksize); + stacksize.rlim_cur = stacksize.rlim_max; + setrlimit(RLIMIT_STACK, &stacksize); +} From a2471c86e7b0c4596428f36a31de8ce13727db1a Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:14:55 -0400 Subject: [PATCH 022/394] test: remove stack limit checks in test scripts (#1280) --- test_fms/fms2_io/test_fms2_io.sh | 10 ---------- test_fms/mpp/test_mpp_chksum.sh | 5 ----- test_fms/test-lib.sh.in | 5 ----- 3 files changed, 20 deletions(-) diff --git a/test_fms/fms2_io/test_fms2_io.sh b/test_fms/fms2_io/test_fms2_io.sh index 8a604e6655..5e0bd31c0e 100755 --- a/test_fms/fms2_io/test_fms2_io.sh +++ b/test_fms/fms2_io/test_fms2_io.sh @@ -31,16 +31,6 @@ # Create and enter output directory output_dir -# use smaller arrays if system stack size is limited -if [ $STACK_LIMITED ]; then - cat <<_EOF > input.nml -&test_fms2_io_nml - nx = 32 - ny = 32 - nz = 10 -/ -_EOF -fi touch input.nml # run the tests diff --git a/test_fms/mpp/test_mpp_chksum.sh b/test_fms/mpp/test_mpp_chksum.sh index 03d252794b..bea691aa5f 100755 --- a/test_fms/mpp/test_mpp_chksum.sh +++ b/test_fms/mpp/test_mpp_chksum.sh @@ -29,11 +29,6 @@ echo "&test_mpp_chksum_nml" > input.nml echo "test_num = 1" >> input.nml -# replaces defaults with smaller sizes if stack size is limited -if [ $STACK_LIMITED ]; then - echo "nx = 64" >> input.nml - echo "ny = 64" >> input.nml -fi echo "/" >> input.nml test_expect_success "mpp_chksum simple functionality" ' diff --git a/test_fms/test-lib.sh.in b/test_fms/test-lib.sh.in index a2cfe8ebf8..b983b48d84 100644 --- a/test_fms/test-lib.sh.in +++ b/test_fms/test-lib.sh.in @@ -33,11 +33,6 @@ TEST_NAME="$(basename "$0" .sh)" TEST_NUMBER="${TEST_NAME%%-*}" TEST_NUMBER="${TEST_NUMBER#t}" -# if using intel with a limited stack size, sets to run smaller tests -if [ "$($FC --version | grep ifort)" -a "$(ulimit -s)" != "unlimited" 2> /dev/null ]; then - STACK_LIMITED=1 -fi - exec 7>&2 # For now, write all output #if test -n "$VERBOSE" From 6693a4fdd67e490864c55b05c2ec5bf699341c45 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:37:47 -0400 Subject: [PATCH 023/394] fix: mpp global arrays test fixes (#1174) --- test_fms/mpp/test_global_arrays.F90 | 491 +++++++++++++--------------- test_fms/mpp/test_global_arrays.sh | 22 +- test_fms/mpp/test_mpp_domains.F90 | 117 ------- 3 files changed, 246 insertions(+), 384 deletions(-) diff --git a/test_fms/mpp/test_global_arrays.F90 b/test_fms/mpp/test_global_arrays.F90 index ce2b125cb4..4f27b0c666 100644 --- a/test_fms/mpp/test_global_arrays.F90 +++ b/test_fms/mpp/test_global_arrays.F90 @@ -34,21 +34,24 @@ program test_global_arrays use mpp_domains_mod, only: mpp_global_min, mpp_get_data_domain,mpp_get_compute_domain use mpp_domains_mod, only: mpp_domains_exit, mpp_update_domains use mpp_domains_mod, only: mpp_get_domain_shift, mpp_global_sum + use mpp_domains_mod, only: CYCLIC_GLOBAL_DOMAIN, NORTH, EAST, CENTER, CORNER, BITWISE_EXACT_SUM + use mpp_mod, only: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, mpp_clock_id, mpp_clock_begin, mpp_clock_end + use fms_mod, only: check_nml_error, input_nml_file implicit none integer, parameter :: length=64 - integer :: id, pe, npes, root, i, j, icount, jcount - integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d - integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d - integer(i4_kind), allocatable :: dataI4(:,:), dataI4_5d(:,:,:,:,:), dataI4_shuf(:,:) - integer(i8_kind), allocatable :: dataI8(:,:), dataI8_5d(:,:,:,:,:), dataI8_shuf(:,:) - real(r4_kind), allocatable :: dataR4(:,:), dataR4_5d(:,:,:,:,:), dataR4_shuf(:,:) - real(r8_kind), allocatable :: dataR8(:,:), dataR8_5d(:,:,:,:,:), dataR8_shuf(:,:) + integer :: id, pe, npes, root, i, j, icount, jcount, io + integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d, sumI4_shuf + integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d, sumI8_shuf + integer(i4_kind), allocatable :: dataI4(:,:), dataI4_shuf(:,:), recv_data_i4(:,:) + integer(i8_kind), allocatable :: dataI8(:,:), dataI8_shuf(:,:), recv_data_i8(:,:) + real(r4_kind), allocatable :: dataR4(:,:), dataR4_shuf(:,:), recv_data_r4(:,:) + real(r8_kind), allocatable :: dataR8(:,:), dataR8_shuf(:,:), recv_data_r8(:,:) real, allocatable :: rands(:) type(domain2D) :: domain - real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_5d - real(r4_kind) :: maxR4, minR4, sumR4, sumR4_5d + real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_shuf + real(r4_kind) :: maxR4, minR4, sumR4, sumR4_shuf integer :: isc, iec, jsc, jec integer :: isd, ied, jsd, jed character(len=32) :: strTmp1, strTmp2 @@ -56,22 +59,60 @@ program test_global_arrays integer(i8_kind), parameter :: randmaxI8 = 4096 real(r8_kind), parameter :: tol4 = 1e-4, tol8 = 1e-6!> tolerance for real comparisons - call mpp_init(mpp_init_test_init_true_only) + ! namelist variables - just logicals to enable individual tests + ! simple just does normal max/min + sums across a domain + ! full does max/min+sums with halos and symmetry + logical :: test_simple= .false. , test_full = .false. + namelist / test_global_arrays_nml / test_simple, test_full + + call mpp_init() + call mpp_domains_init() - call mpp_set_stack_size(3145746) - call mpp_domains_set_stack_size(3145746) + !call mpp_set_stack_size(3145746) + call mpp_domains_set_stack_size(4000000) + + read(input_nml_file, nml=test_global_arrays_nml, iostat=io) + ierr = check_nml_error(io, 'test_global_arrays_nml') pe = mpp_pe() npes = mpp_npes() call mpp_set_root_pe(0) root = mpp_root_pe() + if( test_simple) then + call test_mpp_global_simple() + deallocate(dataI4, dataI8, dataR4, dataR8, rands) + deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) + else if(test_full) then + call test_global_reduce( 'Simple') + call test_global_reduce( 'Simple symmetry center') + call test_global_reduce( 'Simple symmetry corner') + call test_global_reduce( 'Simple symmetry east') + call test_global_reduce( 'Simple symmetry north') + call test_global_reduce( 'Cyclic symmetry center') + call test_global_reduce( 'Cyclic symmetry corner') + call test_global_reduce( 'Cyclic symmetry east') + call test_global_reduce( 'Cyclic symmetry north') + else + call mpp_error(FATAL, "test_global_arrays: either test_sum or test_max_min must be true in input.nml") + endif + call mpp_sync() + + call mpp_domains_exit() + call MPI_FINALIZE(ierr) + + contains + +subroutine test_mpp_global_simple() + !> define domains and allocate - call mpp_define_domains( (/1,length,1,length/), (/4,2/), domain, xhalo=0) + call mpp_define_domains( (/1,length,1,length/), (/1,8/), domain, xhalo=0) call mpp_get_compute_domain(domain, jsc, jec, isc, iec) call mpp_get_data_domain(domain, jsd, jed, isd, ied) allocate(dataI4(jsd:jed, isd:ied),dataI8(jsd:jed, isd:ied), rands(length*length)) allocate(dataR4(jsd:jed, isd:ied), dataR8(jsd:jed, isd:ied)) allocate(dataR4_shuf(jsd:jed, isd:ied), dataR8_shuf(jsd:jed, isd:ied)) allocate(dataI4_shuf(jsd:jed, isd:ied), dataI8_shuf(jsd:jed, isd:ied)) + allocate(recv_data_r4(jsd:jed, isd:ied), recv_data_r8(jsd:jed, isd:ied)) + allocate(recv_data_i4(jsd:jed, isd:ied), recv_data_i8(jsd:jed, isd:ied)) dataI4 = 0; dataI8 = 0; dataR4 = 0.0; dataR8 = 0.0 dataR8_shuf=0.0; dataR4_shuf=0.0;dataI8_shuf=0; dataI4_shuf=0 @@ -166,97 +207,92 @@ program test_global_arrays NEW_LINE('a')//"Sum: "// strTmp1 ) endif - !> shuffle real data ordering and copy into array with 5 ranks - dataR4_shuf = dataR4 - dataR8_shuf = dataR8 - call shuffleDataR4(dataR4_shuf) - call shuffleDataR8(dataR8_shuf) - allocate(dataR4_5d(jsd:jed, isd:ied, 1, 1, 1), dataR8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataR4_5d = 0.0 - dataR8_5d = 0.0 - - do i=isc,iec - do j=jsc,jec - dataR4_5d(j, i, 1, 1, 1) = dataR4_shuf(j, i) - dataR8_5d(j, i, 1, 1, 1) = dataR8_shuf(j, i) - end do - end do + !> moves the data into different pe's and checks the sum still matches + dataR4_shuf = dataR4 ; dataR8_shuf = dataR8 + dataI4_shuf = dataI4 ; dataI8_shuf = dataI8 + !! swap data with neighboring pe + if(modulo(pe, 2) .eq. 0) then + print *, pe, pe+1, SUM(dataR8_shuf) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe+1) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe+1) + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe+1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe+1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe+1) + else + print *, pe, pe-1, SUM(dataR8_shuf) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe-1) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe-1) + call mpp_sync() + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe-1) + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe-1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe-1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe-1) + endif call mpp_sync() + dataR4_shuf = recv_data_r4 + dataR8_shuf = recv_data_r8 - call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR4_5d, domain) - sumR4_5d = mpp_global_sum(domain, dataR4_5d) + call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR4_shuf, domain) + sumR4_shuf = mpp_global_sum(domain, dataR4_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR4-sumR4_5d) .gt. 1E-4 ) then + if(abs(sumR4-sumR4_shuf) .gt. 1E-4 ) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR4_5d + write(strTmp1,*) sumR4_shuf write(strTmp2,*) sumR4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR8_5d, domain) - sumR8_5d = mpp_global_sum(domain, dataR8_5d) + call mpp_sync() + call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR8_shuf, domain) + sumR8_shuf = mpp_global_sum(domain, dataR8_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR8-sumR8_5d) .gt. 1E-7) then + if(abs(sumR8-sumR8_shuf) .gt. 1E-7) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR8_5d + write(strTmp1,*) sumR8_shuf write(strTmp2,*) sumR8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - !> shuffle integer data ordering and copy into array with 5 ranks - dataI4_shuf = dataI4 - dataI8_shuf = dataI8 - call shuffleDataI4(dataI4_shuf) - call shuffleDataI8(dataI8_shuf) - allocate(dataI4_5d(jsd:jed, isd:ied, 1, 1, 1), dataI8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataI4_5d = 0 - dataI8_5d = 0 - do i=isc,iec - do j=jsc,jec - dataI4_5d(j, i, 1, 1, 1) = dataI4_shuf(j, i) - dataI8_5d(j, i, 1, 1, 1) = dataI8_shuf(j, i) - end do - end do - call mpp_sync() - - call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI4_5d, domain) - sumI4_5d = mpp_global_sum(domain, dataI4_5d) + call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI4_shuf, domain) + sumI4_shuf = mpp_global_sum(domain, dataI4_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI4 .ne. sumI4_5d) then + if(sumI4 .ne. sumI4_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI4_5d + write(strTmp1,*) sumI4_shuf write(strTmp2,*) sumI4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI8_5d, domain) - sumI8_5d = mpp_global_sum(domain, dataI8_5d) + call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI8_shuf, domain) + sumI8_shuf = mpp_global_sum(domain, dataI8_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI8 .ne. sumI8_5d) then + if(sumI8 .ne. sumI8_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI8_5d + write(strTmp1,*) sumI8_shuf write(strTmp2,*) sumI8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - - deallocate(dataI4, dataI8, dataR4, dataR8, rands, dataI4_5d, dataI8_5d, dataR4_5d, dataR8_5d) - deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) - call mpp_domains_exit() - call MPI_FINALIZE(ierr) - - contains +end subroutine test_mpp_global_simple !> true if all pes return the same result and have a lower/higher local max/min function checkResultInt4(res) @@ -368,7 +404,6 @@ function checkSumReal4(gsum) real(r4_kind),intent(in) :: gsum real(r4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -402,7 +437,6 @@ function checkSumReal8(gsum) real(r8_kind),intent(in) :: gsum real(r8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -436,7 +470,6 @@ function checkSumInt4(gsum) integer(i4_kind),intent(in) :: gsum integer(i4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -470,7 +503,6 @@ function checkSumInt8(gsum) integer(i8_kind),intent(in) :: gsum integer(i8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -497,192 +529,123 @@ function checkSumInt8(gsum) deallocate(recv) end function checkSumInt8 -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI4(dataI4) - integer(i4_kind), intent(INOUT) :: dataI4(:,:) - integer(i4_kind), allocatable :: trans(:,:), shuffled(:),tmp - integer :: rind - - allocate(trans(SIZE(dataI4,1), SIZE(dataI4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI4)) = RESHAPE(dataI4, (/SIZE(dataI4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI4 = trans - endif - end do - else - call mpp_send(dataI4, SIZE(dataI4), root) - call mpp_recv(trans, SIZE(dataI4), root) - dataI4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI4 - -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI8(dataI8) - integer(i8_kind), intent(INOUT) :: dataI8(:,:) - integer(i8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataI8,1), SIZE(dataI8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI8)) = RESHAPE(dataI8, (/SIZE(dataI8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI8 = trans - endif - end do - else - call mpp_send(dataI8, SIZE(dataI8), root) - call mpp_recv(trans, SIZE(dataI8), root) - dataI8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI8 - -!> aggregates 32-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR4(dataR4) - real(r4_kind), intent(INOUT) :: dataR4(:,:) - real(r4_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR4,1), SIZE(dataR4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR4)) = RESHAPE(dataR4, (/SIZE(dataR4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR4 = trans - endif - end do - else - call mpp_send(dataR4, SIZE(dataR4), root) - call mpp_recv(trans, SIZE(dataR4), root) - dataR4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR4 - -!> aggregates 64-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR8(dataR8) - real(r8_kind), intent(INOUT) :: dataR8(:,:) - real(r8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR8,1), SIZE(dataR8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR8)) = RESHAPE(dataR8, (/SIZE(dataR8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR8 = trans - endif - end do - else - call mpp_send(dataR8, SIZE(dataR8), root) - call mpp_recv(trans, SIZE(dataR8), root) - dataR8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR8 + !--- test mpp_global_sum, mpp_global_min and mpp_global_max + subroutine test_global_reduce (type) + character(len=*), intent(in) :: type + real :: lsum, gsum, lmax, gmax, lmin, gmin + integer :: ni, nj, ishift, jshift, position, k + integer :: is, ie, js, je !, isd, ied, jsd, jed + integer :: nx=128, ny=128, nz=40, stackmax=4000000 + integer :: layout(2) + integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2 + real, allocatable, dimension(:,:,:) :: global1, x + real, allocatable, dimension(:,:) :: global2D + !--- set up domain + call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) + select case(type) + case( 'Simple' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type ) + case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) + case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& + name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & + & yflags=CYCLIC_GLOBAL_DOMAIN ) + case default + call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) + end select + call mpp_get_compute_domain( domain, is, ie, js, je ) + call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) + + !--- determine if an extra point is needed + ishift = 0; jshift = 0; position = CENTER + select case(type) + case ('Simple symmetry corner', 'Cyclic symmetry corner') + ishift = 1; jshift = 1; position = CORNER + case ('Simple symmetry east', 'Cyclic symmetry east' ) + ishift = 1; jshift = 0; position = EAST + case ('Simple symmetry north', 'Cyclic symmetry north') + ishift = 0; jshift = 1; position = NORTH + end select + + ie = ie+ishift; je = je+jshift + ied = ied+ishift; jed = jed+jshift + ni = nx+ishift; nj = ny+jshift + allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) + global1 = 0.0 + do k = 1,nz + do j = 1,nj + do i = 1,ni + global1(i,j,k) = k + i*1e-3 + j*1e-6 + end do + end do + enddo + + !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data + + allocate( x (isd:ied,jsd:jed,nz) ) + allocate( global2D(ni,nj)) + + x(:,:,:) = global1(isd:ied,jsd:jed,:) + do j = 1, nj + do i = 1, ni + global2D(i,j) = sum(global1(i,j,:)) + enddo + enddo + !test mpp_global_sum + + if(type(1:6) == 'Simple') then + gsum = sum( global2D(1:ni,1:nj) ) + else + gsum = sum( global2D(1:nx, 1:ny) ) + endif + id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, position = position ) + call mpp_clock_end (id) + if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum + + !test exact mpp_global_sum + id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) + call mpp_clock_end (id) + !--- The following check will fail on altix in normal mode, but it is ok + !--- in debugging mode. It is ok on irix. + call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') + + !test mpp_global_min + gmin = minval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmin = mpp_global_min( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') + + !test mpp_global_max + gmax = maxval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmax = mpp_global_max( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) + + deallocate(global1, x) + + end subroutine test_global_reduce + + subroutine compare_data_scalar( a, b, action, string ) + real, intent(in) :: a, b + integer, intent(in) :: action + character(len=*), intent(in) :: string + if( a .EQ. b)then + if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(string)//': data comparison are OK.' ) + else + call mpp_error( action, trim(string)//': data comparison are not OK.' ) + end if + + end subroutine compare_data_scalar end program test_global_arrays diff --git a/test_fms/mpp/test_global_arrays.sh b/test_fms/mpp/test_global_arrays.sh index 596d1ecb0a..18390415e5 100755 --- a/test_fms/mpp/test_global_arrays.sh +++ b/test_fms/mpp/test_global_arrays.sh @@ -27,10 +27,26 @@ # Set common test settings. . ../test-lib.sh -# ensure input.nml file present -touch input.nml +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .true. + test_full = .false. +/ +_EOF -test_expect_success "global array functions with mixed precision" ' +test_expect_success "mpp_global_sum/max/min with simple domain" ' mpirun -n 8 ./test_global_arrays ' + +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .false. + test_full = .true. +/ +_EOF + +test_expect_success "mpp_global_sum/max/min with symmetry and halos" ' + mpirun -n 6 ./test_global_arrays +' + test_done diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index ab9ba1a447..1ae1d904da 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -250,17 +250,6 @@ program test_mpp_domains call test_uniform_mosaic('Cubic-Grid') ! 6 tiles. call test_nonuniform_mosaic('Five-Tile') - if(.not. wide_halo) then - call test_global_reduce( 'Simple') - call test_global_reduce( 'Simple symmetry center') - call test_global_reduce( 'Simple symmetry corner') - call test_global_reduce( 'Simple symmetry east') - call test_global_reduce( 'Simple symmetry north') - call test_global_reduce( 'Cyclic symmetry center') - call test_global_reduce( 'Cyclic symmetry corner') - call test_global_reduce( 'Cyclic symmetry east') - call test_global_reduce( 'Cyclic symmetry north') - endif call test_redistribute( 'Complete pelist' ) call test_redistribute( 'Overlap pelist' ) @@ -6057,112 +6046,6 @@ subroutine test_cyclic_offset( type ) end subroutine test_cyclic_offset - !--- test mpp_global_sum, mpp_global_min and mpp_global_max - subroutine test_global_reduce (type) - character(len=*), intent(in) :: type - real :: lsum, gsum, lmax, gmax, lmin, gmin - integer :: ni, nj, ishift, jshift, position - integer :: is, ie, js, je, isd, ied, jsd, jed - - type(domain2D) :: domain - real, allocatable, dimension(:,:,:) :: global1, x - real, allocatable, dimension(:,:) :: global2D - !--- set up domain - call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) - select case(type) - case( 'Simple' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type ) - case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) - case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& - name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & - & yflags=CYCLIC_GLOBAL_DOMAIN ) - case default - call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) - end select - call mpp_get_compute_domain( domain, is, ie, js, je ) - call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) - - !--- determine if an extra point is needed - ishift = 0; jshift = 0; position = CENTER - select case(type) - case ('Simple symmetry corner', 'Cyclic symmetry corner') - ishift = 1; jshift = 1; position = CORNER - case ('Simple symmetry east', 'Cyclic symmetry east' ) - ishift = 1; jshift = 0; position = EAST - case ('Simple symmetry north', 'Cyclic symmetry north') - ishift = 0; jshift = 1; position = NORTH - end select - - ie = ie+ishift; je = je+jshift - ied = ied+ishift; jed = jed+jshift - ni = nx+ishift; nj = ny+jshift - allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) - global1 = 0.0 - do k = 1,nz - do j = 1,nj - do i = 1,ni - global1(i,j,k) = k + i*1e-3 + j*1e-6 - end do - end do - enddo - - !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data - - allocate( x (isd:ied,jsd:jed,nz) ) - allocate( global2D(ni,nj)) - - x(:,:,:) = global1(isd:ied,jsd:jed,:) - do j = 1, nj - do i = 1, ni - global2D(i,j) = sum(global1(i,j,:)) - enddo - enddo - !test mpp_global_sum - - if(type(1:6) == 'Simple') then - gsum = sum( global2D(1:ni,1:nj) ) - else - gsum = sum( global2D(1:nx, 1:ny) ) - endif - id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, position = position ) - call mpp_clock_end (id) - if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum - - !test exact mpp_global_sum - id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) - call mpp_clock_end (id) - !--- The following check will fail on altix in normal mode, but it is ok - !--- in debugging mode. It is ok on irix. - call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') - - !test mpp_global_min - gmin = minval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmin = mpp_global_min( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') - - !test mpp_global_max - gmax = maxval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmax = mpp_global_max( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) - - deallocate(global1, x) - - end subroutine test_global_reduce - subroutine test_parallel_2D ( ) integer :: npes, layout(2), i, j, k,is, ie, js, je, isd, ied, jsd, jed From e6225adaef3008355746a3a07fc0675b22132325 Mon Sep 17 00:00:00 2001 From: JONG KIM Date: Thu, 13 Jul 2023 14:53:04 -0400 Subject: [PATCH 024/394] feat: update mpp_do_update_ad.fh to resolve JEDI requirement (#1225) --- mpp/include/mpp_do_global_field_ad.fh | 4 +- mpp/include/mpp_do_updateV_ad.fh | 2 +- mpp/include/mpp_do_update_ad.fh | 173 ++++++++++++++++++------- mpp/include/mpp_get_boundary_ad.fh | 2 +- mpp/include/mpp_global_field_ad.fh | 4 +- mpp/include/mpp_sum_mpi_ad.fh | 2 +- mpp/include/mpp_sum_nocomm_ad.fh | 2 +- mpp/include/mpp_update_domains2D_ad.fh | 16 +-- 8 files changed, 143 insertions(+), 62 deletions(-) diff --git a/mpp/include/mpp_do_global_field_ad.fh b/mpp/include/mpp_do_global_field_ad.fh index 5c72b5adbf..d32e6aa4b8 100644 --- a/mpp/include/mpp_do_global_field_ad.fh +++ b/mpp/include/mpp_do_global_field_ad.fh @@ -22,8 +22,8 @@ !> @addtogroup mpp_domains_mod !> @{ - !> Gets a global field from a local field - !! local field may be on compute OR data domain + !> Gets a local ad field from a global field + !! global field may be on compute OR data domain subroutine MPP_DO_GLOBAL_FIELD_3D_AD_( domain, local, global, tile, ishift, jshift, flags, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(inout) :: local(:,:,:) diff --git a/mpp/include/mpp_do_updateV_ad.fh b/mpp/include/mpp_do_updateV_ad.fh index d6cce14abf..8d230f501c 100644 --- a/mpp/include/mpp_do_updateV_ad.fh +++ b/mpp/include/mpp_do_updateV_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_DO_UPDATE_AD_3D_V_(f_addrsx,f_addrsy, domain, update_x, update_y, & d_type, ke, gridtype, flags) integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) diff --git a/mpp/include/mpp_do_update_ad.fh b/mpp/include/mpp_do_update_ad.fh index 7afbe8317d..7e7382dcb8 100644 --- a/mpp/include/mpp_do_update_ad.fh +++ b/mpp/include/mpp_do_update_ad.fh @@ -1,6 +1,4 @@ ! -*-f90-*- - - !*********************************************************************** !* GNU Lesser General Public License !* @@ -21,8 +19,12 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed + !! @brief Applies linear adjoint operation to 3D field based on duality of MPP_DO_UPDATE_3D_ + !! @note Adjoint duality exists between MPI SEND and MPI_RECV. + !! However, checkpoint is needed for forward buffer information. + !! ref: BN. Cheng, A Duality between Forward and Adjoint MPI Communication Routines + !! COMPUTATIONAL METHODS IN SCIENCE AND TECHNOLOGY Special Issue 2006, 23-24 subroutine MPP_DO_UPDATE_AD_3D_( f_addrs, domain, update, d_type, ke, flags) integer(i8_kind), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain @@ -35,6 +37,7 @@ pointer(ptr_field, field) integer :: update_flags type(overlap_type), pointer :: overPtr => NULL() + character(len=8) :: text !equate to mpp_domains_stack MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) @@ -43,13 +46,16 @@ !receive domains saved here for unpacking !for non-blocking version, could be recomputed - integer, allocatable :: msg1(:), msg2(:) + integer, allocatable :: msg1(:), msg2(:), msg3(:) logical :: send(8), recv(8), update_edge_only - integer :: to_pe, from_pe, pos, msgsize, msgsize_send + integer :: to_pe, from_pe, pos, msgsize integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir integer :: buffer_recv_size, nlist, outunit - + integer :: send_start_pos !>Send buffer start location + !!This serves as ad recv buffer start location + integer :: send_msgsize(MAXLIST) !>Send buffer msg size storage + !!This should be checkpointed for reverse ad communication outunit = stdout() ptr = LOC(mpp_domains_stack) @@ -80,9 +86,10 @@ if(debug_message_passing) then nlist = size(domain%list(:)) - allocate(msg1(0:nlist-1), msg2(0:nlist-1) ) + allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) ) msg1 = 0 msg2 = 0 + msg3 = 0 do m = 1, update%nrecv overPtr => update%recv(m) msgsize = 0 @@ -96,7 +103,6 @@ end do from_pe = update%recv(m)%pe l = from_pe-mpp_root_pe() - call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1 ) msg2(l) = msgsize enddo @@ -111,9 +117,13 @@ msgsize = msgsize + (ie-is+1)*(je-js+1) end if end do - call mpp_send( msgsize, plen=1, to_pe=overPtr%pe, tag=COMM_TAG_1 ) + l = overPtr%pe - mpp_root_pe() + msg3(l) = msgsize enddo - call mpp_sync_self(check=EVENT_RECV) + ! mpp_sync_self is desirable but keep mpp_alltoall + ! to exactly follow the duality of mpp_do_update.fh + ! all-to-all may have scaling issues on very large systems + call mpp_alltoall(msg3, 1, msg1, 1) do m = 0, nlist-1 if(msg1(m) .NE. msg2(m)) then @@ -122,14 +132,16 @@ call mpp_error(FATAL, "mpp_do_update: mismatch on send and recv size") endif enddo - call mpp_sync_self() write(outunit,*)"NOTE from mpp_do_update: message sizes are matched between send and recv for domain " & //trim(domain%name) - deallocate(msg1, msg2) + deallocate(msg1, msg2, msg3) endif - !recv + ! Duality of ad code requires checkpoint info: buffer recv size and send pos and msgsize + ! from the forward recv portion of mpp_do_update.fh + ! ref above in line 26 buffer_pos = 0 + do m = 1, update%nrecv overPtr => update%recv(m) if( overPtr%count == 0 )cycle @@ -137,38 +149,24 @@ do n = 1, overPtr%count dir = overPtr%dir(n) if(recv(dir)) then - tMe = overPtr%tileMe(n) is = overPtr%is(n); ie = overPtr%ie(n) js = overPtr%js(n); je = overPtr%je(n) msgsize = msgsize + (ie-is+1)*(je-js+1) - msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size - pos = buffer_pos + msgsize_send - do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) - do k = ke,1,-1 - do j = je, js, -1 - do i = ie, is, -1 - buffer(pos) = field(i,j,k) - field(i,j,k) = 0. - pos = pos - 1 - end do - end do - end do - end do end if end do msgsize = msgsize*ke*l_size if( msgsize.GT.0 )then - to_pe = overPtr%pe - call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=to_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do m = 1, update%nrecv + end do buffer_recv_size = buffer_pos + send_start_pos = buffer_pos - ! send + ! checkpoint send_msgsize + buffer_pos = buffer_recv_size do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -179,19 +177,99 @@ enddo if( msgsize.GT.0 )then msgsize = msgsize*ke*l_size - msgsize_send = msgsize + end if + + do n = 1, overPtr%count + dir = overPtr%dir(n) + if( send(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + pos = pos + (ie-is+1)*(je-js+1)*ke*l_size + endif + end do + + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do + + ! bufferize for backward communication + ! using pack procedures of recv in mpp_do_update.fh + buffer_pos = buffer_recv_size + do m = update%nrecv, 1, -1 + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + pos = buffer_pos + do n = overPtr%count, 1, -1 + dir = overPtr%dir(n) + if( recv(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = (ie-is+1)*(je-js+1)*ke*l_size + pos = buffer_pos - msgsize + buffer_pos = pos + do l=1,l_size ! loop over number of fields + ptr_field = f_addrs(l, tMe) + do k = 1,ke + do j = js, je + do i = is, ie + pos = pos + 1 + buffer(pos) = field(i,j,k) + end do + end do + end do + end do + endif + end do + end do + + ! for duality, mpp_send of mpp_do_update.sh becomes mpp_recv in adjoint + buffer_pos = send_start_pos + do m = 1, update%nsend + msgsize = send_msgsize(m) + if(msgsize == 0) cycle + to_pe = update%send(m)%pe + call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.FALSE., tag=COMM_TAG_2 ) + buffer_pos = buffer_pos + msgsize + end do + + ! for duality, mpp_recv of mpp_do_update.sh becomes mpp_send in adjoint + buffer_pos = 0 + do m = 1, update%nrecv + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + msgsize = 0 + do n = 1, overPtr%count + dir = overPtr%dir(n) + if(recv(dir)) then + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = msgsize + (ie-is+1)*(je-js+1) + end if + end do + + msgsize = msgsize*ke*l_size + if( msgsize.GT.0 )then from_pe = overPtr%pe - call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_2 ) + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_DO_UPDATE: mpp_domains_stack overflow, '// & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' ) + end if + call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do ist = 0,nlist-1 + end do call mpp_sync_self(check=EVENT_RECV) + ! unpack and linear adjoint operation + ! in reverse order of pack process of mpp_do_update.fh buffer_pos = buffer_recv_size - - ! send do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -201,7 +279,13 @@ if( send(dir) ) msgsize = msgsize + overPtr%msgsize(n) enddo if( msgsize.GT.0 )then - buffer_pos = pos + msgsize = msgsize*ke*l_size + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos+msgsize ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS: mpp_domains_stack overflow, ' // & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.') + end if end if do n = 1, overPtr%count @@ -259,15 +343,12 @@ end do end do end do - end select + end select endif end do ! do n = 1, overPtr%count - - msgsize = pos - buffer_pos - if( msgsize.GT.0 )then - buffer_pos = pos - end if - end do ! end do ist = 0,nlist-1 + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do call mpp_sync_self() diff --git a/mpp/include/mpp_get_boundary_ad.fh b/mpp/include/mpp_get_boundary_ad.fh index 56a18120e6..6701d375dd 100644 --- a/mpp/include/mpp_get_boundary_ad.fh +++ b/mpp/include/mpp_get_boundary_ad.fh @@ -21,7 +21,7 @@ !> @addtogroup mpp_domains_mod !> @{ -!> This routine is used to retrieve scalar boundary data for symmetric domain. +!> This routine is used to retrieve scalar ad boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) type(domain2D), intent(in) :: domain diff --git a/mpp/include/mpp_global_field_ad.fh b/mpp/include/mpp_global_field_ad.fh index 7d948f9366..712d12e48e 100644 --- a/mpp/include/mpp_global_field_ad.fh +++ b/mpp/include/mpp_global_field_ad.fh @@ -21,8 +21,8 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Get a global field from a local field - !! local field may be on compute OR data domain + !> Get a local ad field from a global ad field + !! global field may be on compute OR data domain subroutine MPP_GLOBAL_FIELD_2D_AD_( domain, local, global, flags, position,tile_count, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(out) :: local(:,:) diff --git a/mpp/include/mpp_sum_mpi_ad.fh b/mpp/include/mpp_sum_mpi_ad.fh index 9b61b9457b..ee28d6c4bf 100644 --- a/mpp/include/mpp_sum_mpi_ad.fh +++ b/mpp/include/mpp_sum_mpi_ad.fh @@ -20,7 +20,7 @@ !* License along with FMS. If not, see . !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. !> @ingroup mpp_mod diff --git a/mpp/include/mpp_sum_nocomm_ad.fh b/mpp/include/mpp_sum_nocomm_ad.fh index 9a427aa9d0..263bfde8d6 100644 --- a/mpp/include/mpp_sum_nocomm_ad.fh +++ b/mpp/include/mpp_sum_nocomm_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. subroutine MPP_SUM_AD_( a, length, pelist ) diff --git a/mpp/include/mpp_update_domains2D_ad.fh b/mpp/include/mpp_update_domains2D_ad.fh index e5fc6e7af3..8a876fdba5 100644 --- a/mpp/include/mpp_update_domains2D_ad.fh +++ b/mpp/include/mpp_update_domains2D_ad.fh @@ -19,7 +19,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 2D field whose computational domains have been computed + !> Updates data domain of 2D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_2D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:) @@ -39,7 +39,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_2D_ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_3D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:,:) @@ -176,7 +176,7 @@ end subroutine MPP_UPDATE_DOMAINS_AD_3D_ - !> Updates data domain of 4D field whose computational domains have been computed + !> Updates data domain of 4D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_4D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:) @@ -196,7 +196,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_4D_ - !> Updates data domain of 5D field whose computational domains have been computed + !> Updates data domain of 5D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_5D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) @@ -224,7 +224,7 @@ !vector fields subroutine MPP_UPDATE_DOMAINS_AD_2D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 2D field whose computational domains have been computed +!updates data domain of 2D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -247,7 +247,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_3D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 3D field whose computational domains have been computed +!updates data domain of 3D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -422,7 +422,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_4D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 4D field whose computational domains have been computed +!updates data domain of 4D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -445,7 +445,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_5D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 5D field whose computational domains have been computed +!updates data domain of 5D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype From 2be8aa452ad3e5f43e92c38a64f12d1ae6c43fb8 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:57:40 -0400 Subject: [PATCH 025/394] chore: add prefixed aliases for libfms routines (#1262) BREAKING CHANGE: Any code using the global fms module (libFMS.F90) will break as this adds prefixes to all names in that module. --- libFMS.F90 | 947 +++++++++++++++------- test_fms/mpp/test_domains_utility_mod.F90 | 4 +- test_fms/mpp/test_mpp_chksum.F90 | 5 +- test_fms/mpp/test_mpp_domains.F90 | 2 +- test_fms/mpp/test_mpp_nesting.F90 | 4 +- 5 files changed, 682 insertions(+), 280 deletions(-) diff --git a/libFMS.F90 b/libFMS.F90 index 872c587a8c..02b54df82a 100644 --- a/libFMS.F90 +++ b/libFMS.F90 @@ -28,11 +28,18 @@ !! and routines. Overloaded type operators/assignments cannot be imported individually !! (ie. `use fms, only: OPERATOR(*)` includes any defined '*' operators within FMS). !! -!! Remappings due to conflicts: +!! Renaming scheme: +!! Routines and variables: fms__routine_name +!! Types: FmsModuleNameTypeName !! -!! get_mosaic_tile_grid from mosaic2(fms2_io) => mosaic2_get_mosaic_tile_grid +!! Exceptions (mainly for rep: +!! - Parameter values are kept their original names +!! - If module name is already included (like in init routines) only fms prefix will be added. +!! - Similarly if theres a redundant module name included already included it will not be repeated +!! (ie. mpp_update_domains => fms_mpp_domains_update_domains) +!! - Override interfaces for operators and assignment are provided !! -!! read_data from interpolator_mod(fms2_io) => interpolator_read_data +!! Remappings due to name conflicts: !! !! ZERO from interpolator_mod(mpp_parameter) => INTERPOLATOR_ZERO !! @@ -41,7 +48,7 @@ !! Not in this module: !! !! axis_utils_mod, fms_io_mod, time_interp_external_mod -!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, +!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, & !! fms_mod(partial, old io excluded), drifters modules !! constants_mod (FMSconstants should be used externally) !! grid_mod, mosaic_mod @@ -65,215 +72,458 @@ module fms fms_affinity_set !> amip_interp - use amip_interp_mod, only: amip_interp_init, get_amip_sst, get_amip_ice, & - amip_interp_new,amip_interp_del, amip_interp_type, & - assignment(=), i_sst, j_sst, sst_ncep, sst_anom, & - forecast_mode, use_ncep_sst + use amip_interp_mod, only: fms_amip_interp_init => amip_interp_init, & + fms_amip_interp_get_amip_sst => get_amip_sst, & + fms_amip_interp_get_amip_ice => get_amip_ice, & + fms_amip_interp_new => amip_interp_new, & + fms_amip_interp_del => amip_interp_del, & + FmsAmipInterp_type => amip_interp_type, & + assignment(=), & + fms_amip_interp_i_sst => i_sst, & + fms_amip_interp_j_sst => j_sst, & + fms_amip_interp_sst_ncep => sst_ncep, & + fms_amip_interp_sst_anom => sst_anom, & + fms_amip_interp_forecast_mode=> forecast_mode, & + fms_amip_interp_use_ncep_sst => use_ncep_sst !> astronomy - use astronomy_mod, only: astronomy_init, get_period, set_period, & - set_orbital_parameters, get_orbital_parameters, & - set_ref_date_of_ae, get_ref_date_of_ae, & - diurnal_solar, daily_mean_solar, annual_mean_solar, & - astronomy_end, universal_time, orbital_time + use astronomy_mod, only: fms_astronomy_init => astronomy_init, & + fms_astronomy_get_period => get_period, & + fms_astronomy_set_period => set_period, & + fms_astronomy_set_orbital_parameters => set_orbital_parameters, & + fms_astronomy_get_orbital_parameters => get_orbital_parameters, & + fms_astronomy_set_ref_date_of_ae => set_ref_date_of_ae, & + fms_astronomy_get_ref_date_of_ae => get_ref_date_of_ae, & + fms_astronomy_diurnal_solar => diurnal_solar, & + fms_astronomy_daily_mean_solar => daily_mean_solar, & + fms_astronomy_annual_mean_solar => annual_mean_solar, & + fms_astronomy_end => astronomy_end, & + fms_astronomy_universal_time => universal_time, & + fms_astronomy_orbital_time => orbital_time !> axis_utils - use axis_utils2_mod, only: get_axis_cart, get_axis_modulo, lon_in_range, & - tranlon, frac_index, nearest_index, interp_1d, & - get_axis_modulo_times, axis_edges + use axis_utils2_mod, only: fms_axis_utils2_get_axis_cart => get_axis_cart, & + fms_axis_utils2_get_axis_modulo => get_axis_modulo, & + fms_axis_utils2_lon_in_range => lon_in_range, & + fms_axis_utils2_tranlon => tranlon, & + fms_axis_utils2_frac_index => frac_index, & + fms_axis_utils2_nearest_index => nearest_index, & + fms_axis_utils2_interp_1d => interp_1d, & + fms_axis_utils2_get_axis_modulo_times => get_axis_modulo_times, & + fms_axis_utils2_axis_edges => axis_edges !>block_control - use block_control_mod, only: block_control_type, define_blocks, & - define_blocks_packed + use block_control_mod, only: FmsBlockControl_type => block_control_type, & + fms_block_control_define_blocks => define_blocks, & + fms_block_control_define_blocks_packed => define_blocks_packed !> column_diagnostics - use column_diagnostics_mod, only: column_diagnostics_init, & - initialize_diagnostic_columns, & - column_diagnostics_header, & - close_column_diagnostics_units + use column_diagnostics_mod, only: fms_column_diagnostics_init => column_diagnostics_init, & + fms_column_diagnostics_initialize_diagnostic_columns => & + initialize_diagnostic_columns, & + fms_column_diagnostics_header => column_diagnostics_header, & + fms_column_diagnostics_close_units => close_column_diagnostics_units !> coupler - use coupler_types_mod, only: coupler_types_init, coupler_type_copy, & - coupler_type_spawn, coupler_type_set_diags, & - coupler_type_write_chksums, coupler_type_send_data, & - coupler_type_data_override, coupler_type_register_restarts, & - coupler_type_restore_state, coupler_type_increment_data, & - coupler_type_rescale_data, coupler_type_copy_data, & - coupler_type_redistribute_data, coupler_type_destructor, & - coupler_type_initialized, coupler_type_extract_data, & - coupler_type_set_data,coupler_type_copy_1d_2d, & - coupler_type_copy_1d_3d, coupler_3d_values_type, & - coupler_3d_field_type, coupler_3d_bc_type, & - coupler_2d_values_type, coupler_2d_field_type, & - coupler_2d_bc_type, coupler_1d_values_type, & - coupler_1d_field_type, coupler_1d_bc_type, & - ind_pcair, ind_u10, ind_psurf, ind_alpha, ind_csurf, & - ind_sc_no, ind_flux, ind_deltap, ind_kw, ind_flux0, & - ind_deposition, ind_runoff - use ensemble_manager_mod, only: ensemble_manager_init, get_ensemble_id, get_ensemble_size, & - get_ensemble_pelist, ensemble_pelist_setup, & - get_ensemble_filter_pelist - use atmos_ocean_fluxes_mod, only: atmos_ocean_fluxes_init, atmos_ocean_type_fluxes_init, & - aof_set_coupler_flux + use coupler_types_mod, only: fms_coupler_types_init => coupler_types_init, & + fms_coupler_type_copy => coupler_type_copy, & + fms_coupler_type_spawn => coupler_type_spawn, & + fms_coupler_type_set_diags => coupler_type_set_diags, & + fms_coupler_type_write_chksums => coupler_type_write_chksums, & + fms_coupler_type_send_data => coupler_type_send_data, & + fms_coupler_type_data_override => coupler_type_data_override, & + fms_coupler_type_register_restarts => coupler_type_register_restarts, & + fms_coupler_type_restore_state => coupler_type_restore_state, & + fms_coupler_type_increment_data => coupler_type_increment_data, & + fms_coupler_type_rescale_data => coupler_type_rescale_data, & + fms_coupler_type_copy_data => coupler_type_copy_data, & + fms_coupler_type_redistribute_data => coupler_type_redistribute_data, & + fms_coupler_type_destructor => coupler_type_destructor, & + fms_coupler_type_initialized => coupler_type_initialized, & + fms_coupler_type_extract_data => coupler_type_extract_data, & + fms_coupler_type_set_data => coupler_type_set_data, & + fms_coupler_type_copy_1d_2d => coupler_type_copy_1d_2d, & + fms_coupler_type_copy_1d_3d => coupler_type_copy_1d_3d, & + FmsCoupler3dValues_type => coupler_3d_values_type, & + FmsCoupler3dField_type => coupler_3d_field_type, & + FmsCoupler3dBC_type => coupler_3d_bc_type, & + FmsCoupler2dValues_type => coupler_2d_values_type, & + FmsCoupler2dField_type => coupler_2d_field_type, & + FmsCoupler2dBC_type => coupler_2d_bc_type, & + FmsCoupler1dValues_type => coupler_1d_values_type, & + FmsCoupler1dField_type => coupler_1d_field_type, & + FmsCoupler1dBC_type => coupler_1d_bc_type, & + fms_coupler_ind_pcair => ind_pcair, & + fms_coupler_ind_u10 => ind_u10, & + fms_coupler_ind_psurf => ind_psurf, & + fms_coupler_ind_alpha => ind_alpha, & + fms_coupler_ind_csurf => ind_csurf, & + fms_coupler_ind_sc_no => ind_sc_no, & + fms_coupler_ind_flux => ind_flux, & + fms_coupler_ind_deltap => ind_deltap, & + fms_coupler_ind_kw => ind_kw, & + fms_coupler_ind_flux0 => ind_flux0, & + fms_coupler_ind_deposition => ind_deposition,& + fms_coupler_ind_runoff => ind_runoff + use ensemble_manager_mod, only: fms_ensemble_manager_init => ensemble_manager_init, & + fms_ensemble_manager_get_ensemble_id => get_ensemble_id, & + fms_ensemble_manager_get_ensemble_size => get_ensemble_size, & + fms_ensemble_manager_get_ensemble_pelist => get_ensemble_pelist, & + fms_ensemble_manager_ensemble_pelist_setup => ensemble_pelist_setup, & + fms_ensemble_manager_get_ensemble_filter_pelist => get_ensemble_filter_pelist + use atmos_ocean_fluxes_mod, only: fms_atmos_ocean_fluxes_init => atmos_ocean_fluxes_init, & + fms_atmos_ocean_type_fluxes_init => atmos_ocean_type_fluxes_init, & + fms_atmos_ocean_fluxes_set_coupler_flux => aof_set_coupler_flux !> data_override - use data_override_mod, only: data_override_init, data_override, & - data_override_unset_domains, data_override_UG + use data_override_mod, only: fms_data_override_init => data_override_init, & + fms_data_override => data_override, & + fms_data_override_unset_domains => data_override_unset_domains, & + fms_data_override_UG => data_override_UG !> diag_integral - use diag_integral_mod, only: diag_integral_init, diag_integral_field_init, & - sum_diag_integral_field, diag_integral_output, & - diag_integral_end + use diag_integral_mod, only: fms_diag_integral_init => diag_integral_init, & + fms_diag_integral_field_init => diag_integral_field_init, & + fms_sum_diag_integral_field => sum_diag_integral_field, & + fms_diag_integral_output => diag_integral_output, & + fms_diag_integral_end => diag_integral_end !> diag_manager !! includes imports from submodules made public - use diag_manager_mod, only: diag_manager_init, send_data, send_tile_averaged_data, & - diag_manager_end, register_diag_field, register_static_field, & - diag_axis_init, get_base_time, get_base_date, need_data, & - DIAG_ALL, DIAG_OCEAN, DIAG_OTHER, get_date_dif, DIAG_SECONDS,& - DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, & - get_diag_global_att, set_diag_global_att, diag_field_add_attribute, & - diag_field_add_cell_measures, get_diag_field_id, & - diag_axis_add_attribute, diag_grid_init, diag_grid_end, & - diag_manager_set_time_end, diag_send_complete, & - diag_send_complete_instant, DIAG_FIELD_NOT_FOUND, & - CMOR_MISSING_VALUE, null_axis_id + use diag_manager_mod, only: fms_diag_init => diag_manager_init, & + fms_diag_send_data => send_data, & + fms_diag_send_tile_averaged_data => send_tile_averaged_data, & + fms_diag_end => diag_manager_end, & + fms_diag_register_diag_field => register_diag_field, & + fms_diag_register_static_field => register_static_field, & + fms_diag_axis_init => diag_axis_init, & + fms_diag_get_base_time => get_base_time, & + fms_diag_get_base_date => get_base_date, & + fms_diag_need_data => need_data, & + DIAG_ALL, & + DIAG_OCEAN, & + DIAG_OTHER, & + fms_get_date_dif => get_date_dif, & + DIAG_SECONDS,& + DIAG_MINUTES, & + DIAG_HOURS, & + DIAG_DAYS, & + DIAG_MONTHS, & + DIAG_YEARS, & + fms_diag_get_global_att => get_diag_global_att, & + fms_diag_set_global_att => set_diag_global_att, & + fms_diag_field_add_attribute => diag_field_add_attribute, & + fms_diag_field_add_cell_measures => diag_field_add_cell_measures, & + fms_diag_get_field_id => get_diag_field_id, & + fms_diag_axis_add_attribute => diag_axis_add_attribute, & + fms_diag_grid_init => diag_grid_init, & + fms_diag_grid_end => diag_grid_end, & + fms_diag_set_time_end => diag_manager_set_time_end, & + fms_diag_send_complete => diag_send_complete, & + fms_diag_send_complete_instant => diag_send_complete_instant, & + DIAG_FIELD_NOT_FOUND, & + CMOR_MISSING_VALUE, & + null_axis_id !> exchange - use xgrid_mod, only: xmap_type, setup_xmap, set_frac_area, put_to_xgrid, & - get_from_xgrid, xgrid_count, some, conservation_check, & - xgrid_init, AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, & - AREA_OCN_MODEL, get_ocean_model_area_elements, grid_box_type, & - get_xmap_grid_area, put_to_xgrid_ug, get_from_xgrid_ug, & - set_frac_area_ug, FIRST_ORDER, SECOND_ORDER, stock_move_ug, & - stock_move, stock_type, stock_print, get_index_range, & - stock_integrate_2d + use xgrid_mod, only: FmsXgridXmap_type => xmap_type, & + fms_xgrid_setup_xmap => setup_xmap, & + fms_xgrid_set_frac_area => set_frac_area, & + fms_xgrid_put_to_xgrid => put_to_xgrid, & + fms_xgrid_get_from_xgrid => get_from_xgrid, & + fms_xgrid_count => xgrid_count, & + fms_xgrid_some => some, & + fms_xgrid_conservation_check => conservation_check, & + fms_xgrid_init => xgrid_init, & + AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, AREA_OCN_MODEL, & + fms_xgrid_get_ocean_model_area_elements => get_ocean_model_area_elements, & + FmsXgridGridBox_type => grid_box_type, & + fms_xgrid_get_xmap_grid_area => get_xmap_grid_area, & + fms_xgrid_put_to_xgrid_ug => put_to_xgrid_ug, & + fms_xgrid_get_from_xgrid_ug => get_from_xgrid_ug, & + fms_xgrid_set_frac_area_ug => set_frac_area_ug, & + FIRST_ORDER, SECOND_ORDER, & + fms_xgrid_stock_move_ug => stock_move_ug, & + fms_xgrid_stock_move => stock_move, & + FmsXgridStock_type => stock_type, & + fms_xgrid_stock_print => stock_print, & + fms_xgrid_get_index_range => get_index_range, & + fms_xgrid_stock_integrate_2d => stock_integrate_2d use stock_constants_mod, only: NELEMS, ISTOCK_WATER, ISTOCK_HEAT, ISTOCK_SALT, & - ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, stocks_file, & - stocks_report, stocks_report_init, stocks_set_init_time, & - atm_stock, ocn_stock, lnd_stock, ice_stock + ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, & + fms_stock_constants_stocks_file => stocks_file, & + fms_stock_constants_stocks_report => stocks_report, & + fms_stocks_report_init => stocks_report_init, & + fms_stocks_set_init_time => stocks_set_init_time, & + fms_stock_constants_atm_stock => atm_stock, & + fms_stock_constants_ocn_stock => ocn_stock, & + fms_stock_constants_lnd_stock => lnd_stock, & + fms_stock_constants_ice_stock => ice_stock !> field manager - use field_manager_mod, only: field_manager_init, field_manager_end, find_field_index, & - get_field_info, & - get_field_method, get_field_methods, parse, fm_change_list, & - fm_change_root, fm_dump_list, fm_exists, fm_get_index, & - fm_get_current_list, fm_get_length, fm_get_type, fm_get_value, & - fm_init_loop, & - fm_loop_over_list, fm_new_list, fm_new_value, & - fm_reset_loop, fm_return_root, & - fm_modify_name, fm_query_method, fm_find_methods, fm_copy_list, & - fm_field_name_len, fm_path_name_len, & - fm_string_len, fm_type_name_len, NUM_MODELS, NO_FIELD, & - MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & - method_type, method_type_short, & - method_type_very_short, fm_list_iter_type, default_method - use fm_util_mod, only: fm_util_start_namelist, fm_util_end_namelist, & - fm_util_check_for_bad_fields, fm_util_set_caller, & - fm_util_reset_caller, fm_util_set_no_overwrite, & - fm_util_reset_no_overwrite, fm_util_set_good_name_list, & - fm_util_reset_good_name_list, fm_util_get_length, & - fm_util_get_integer, fm_util_get_logical, fm_util_get_real, & - fm_util_get_string, fm_util_get_integer_array, & - fm_util_get_logical_array, fm_util_get_real_array, & - fm_util_get_string_array, fm_util_set_value, & - fm_util_set_value_integer_array, fm_util_set_value_logical_array, & - fm_util_set_value_real_array, fm_util_set_value_string_array, & - fm_util_set_value_integer, fm_util_set_value_logical, & - fm_util_set_value_real, fm_util_set_value_string, & - fm_util_get_index_list, fm_util_get_index_string, & - fm_util_default_caller + use field_manager_mod, only: fms_field_manager_init => field_manager_init, & + fms_field_manager_end => field_manager_end, & + fms_field_manager_find_field_index => find_field_index, & + fms_field_manager_get_field_info => get_field_info, & + fms_field_manager_get_field_method => get_field_method, & + fms_field_manager_get_field_methods => get_field_methods, & + fms_field_manager_parse => parse, & + fms_field_manager_fm_change_list => fm_change_list, & + fms_field_manager_fm_change_root => fm_change_root, & + fms_field_manager_fm_dump_list => fm_dump_list, & + fms_field_manager_fm_exists => fm_exists, & + fms_field_manager_fm_get_index => fm_get_index, & + fms_field_manager_fm_get_current_list => fm_get_current_list, & + fms_field_manager_fm_get_length => fm_get_length, & + fms_field_manager_fm_get_type => fm_get_type, & + fms_field_manager_fm_get_value => fm_get_value, & + fms_field_manager_fm_init_loop => fm_init_loop, & + fms_field_manager_fm_loop_over_list => fm_loop_over_list, & + fms_field_manager_fm_new_list => fm_new_list, & + fms_field_manager_fm_new_value => fm_new_value, & + fms_field_manager_fm_reset_loop => fm_reset_loop, & + fms_field_manager_fm_return_root => fm_return_root, & + fms_field_manager_fm_modify_name => fm_modify_name, & + fms_field_manager_fm_query_method => fm_query_method, & + fms_field_manager_fm_find_methods => fm_find_methods, & + fms_field_manager_fm_copy_list => fm_copy_list, & + fms_field_manager_fm_field_name_len => fm_field_name_len, & + fms_field_manager_fm_path_name_len => fm_path_name_len, & + fms_field_manager_fm_string_len => fm_string_len, & + fms_field_manager_fm_type_name_len => fm_type_name_len, & + NUM_MODELS, NO_FIELD, MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & + FmsFieldManagerMethod_type => method_type, & + FmsFieldManagerMethodShort_type => method_type_short, & + FmsFieldManagerMethodVeryShort_type => method_type_very_short, & + FmsFieldManagerListIterator_type => fm_list_iter_type, & + fms_field_manager_default_method => default_method + use fm_util_mod, only: fms_fm_util_start_namelist => fm_util_start_namelist, & + fms_fm_util_end_namelist => fm_util_end_namelist, & + fms_fm_util_check_for_bad_fields => fm_util_check_for_bad_fields, & + fms_fm_util_set_caller => fm_util_set_caller, & + fms_fm_util_reset_caller => fm_util_reset_caller, & + fms_fm_util_set_no_overwrite => fm_util_set_no_overwrite, & + fms_fm_util_reset_no_overwrite => fm_util_reset_no_overwrite, & + fms_fm_util_set_good_name_list => fm_util_set_good_name_list, & + fms_fm_util_reset_good_name_list => fm_util_reset_good_name_list, & + fms_fm_util_get_length => fm_util_get_length, & + fms_fm_util_get_integer => fm_util_get_integer, & + fms_fm_util_get_logical => fm_util_get_logical, & + fms_fm_util_get_real => fm_util_get_real, & + fms_fm_util_get_string => fm_util_get_string, & + fms_fm_util_get_integer_array => fm_util_get_integer_array, & + fms_fm_util_get_logical_array => fm_util_get_logical_array, & + fms_fm_util_get_real_array => fm_util_get_real_array, & + fms_fm_util_get_string_array => fm_util_get_string_array, & + fms_fm_util_set_value => fm_util_set_value, & + fms_fm_util_set_value_integer_array => fm_util_set_value_integer_array, & + fms_fm_util_set_value_logical_array => fm_util_set_value_logical_array, & + fms_fm_util_set_value_real_array => fm_util_set_value_real_array, & + fms_fm_util_set_value_string_array => fm_util_set_value_string_array, & + fms_fm_util_set_value_integer => fm_util_set_value_integer, & + fms_fm_util_set_value_logical => fm_util_set_value_logical, & + fms_fm_util_set_value_real => fm_util_set_value_real, & + fms_fm_util_set_value_string => fm_util_set_value_string, & + fms_fm_util_get_index_list => fm_util_get_index_list, & + fms_fm_util_get_index_string => fm_util_get_index_string, & + fms_fm_util_default_caller => fm_util_default_caller !> fms2_io + !! TODO need to see opinions on these + !! not sure if we need fms_ prefix for routines + !! types do not follow our typical naming convention(no _type and uses camel case instead of _ spacing) use fms2_io_mod, only: unlimited, FmsNetcdfFile_t, FmsNetcdfDomainFile_t, & - FmsNetcdfUnstructuredDomainFile_t, open_file, open_virtual_file, & - close_file, register_axis, register_field, register_restart_field, & - write_data, read_data, write_restart, write_new_restart, & - read_restart, read_new_restart, global_att_exists, & - variable_att_exists, register_global_attribute, & - register_variable_attribute, get_global_attribute, & - get_variable_attribute, get_num_dimensions, & - get_dimension_names, dimension_exists, is_dimension_unlimited, & - get_dimension_size, get_num_variables, get_variable_names, & - variable_exists, get_variable_num_dimensions, & - get_variable_dimension_names, get_variable_size, & - get_compute_domain_dimension_indices, & - get_global_io_domain_indices, Valid_t, get_valid, is_valid, & - get_unlimited_dimension_name, get_variable_unlimited_dimension_index, & - file_exists, compressed_start_and_count, get_variable_sense, & - get_variable_missing, get_variable_units, get_time_calendar, & - open_check, is_registered_to_restart, check_if_open, & - set_fileobj_time_name, is_dimension_registered, & - fms2_io_init, get_mosaic_tile_grid, & - write_restart_bc, read_restart_bc, get_filename_appendix, & !> 2021.02-a1 - set_filename_appendix, get_instance_filename, & - nullify_filename_appendix, ascii_read, get_mosaic_tile_file, & - parse_mask_table + FmsNetcdfUnstructuredDomainFile_t, & + Valid_t, & + fms2_io_open_file => open_file, & + fms2_io_open_virtual_file => open_virtual_file, & + fms2_io_close_file => close_file, & + fms2_io_register_axis => register_axis, & + fms2_io_register_field => register_field, & + fms2_io_register_restart_field => register_restart_field, & + fms2_io_write_data => write_data, & + fms2_io_read_data => read_data, & + fms2_io_write_restart => write_restart, & + fms2_io_write_new_restart => write_new_restart, & + fms2_io_read_restart => read_restart, & + fms2_io_read_new_restart => read_new_restart, & + fms2_io_global_att_exists => global_att_exists, & + fms2_io_variable_att_exists => variable_att_exists, & + fms2_io_register_global_attribute => register_global_attribute, & + fms2_io_register_variable_attribute => register_variable_attribute, & + fms2_io_get_global_attribute => get_global_attribute, & + fms2_io_get_variable_attribute => get_variable_attribute, & + fms2_io_get_num_dimensions => get_num_dimensions, & + fms2_io_get_dimension_names => get_dimension_names, & + fms2_io_dimension_exists => dimension_exists, & + fms2_io_is_dimension_unlimited => is_dimension_unlimited, & + fms2_io_get_dimension_size => get_dimension_size, & + fms2_io_get_num_variables => get_num_variables, & + fms2_io_get_variable_names => get_variable_names, & + fms2_io_variable_exists => variable_exists, & + fms2_io_get_variable_num_dimensions => get_variable_num_dimensions, & + fms2_io_get_variable_dimension_names => get_variable_dimension_names, & + fms2_io_get_variable_size => get_variable_size, & + fms2_io_get_compute_domain_dimension_indices => get_compute_domain_dimension_indices, & + fms2_io_get_global_io_domain_indices => get_global_io_domain_indices, & + fms2_io_get_valid => get_valid, & + fms2_io_is_valid => is_valid, & + fms2_io_get_unlimited_dimension_name => get_unlimited_dimension_name, & + fms2_io_get_variable_unlimited_dimension_index => get_variable_unlimited_dimension_index, & + fms2_io_file_exists => file_exists, & + fms2_io_compressed_start_and_count => compressed_start_and_count, & + fms2_io_get_variable_sense => get_variable_sense, & + fms2_io_get_variable_missing => get_variable_missing, & + fms2_io_get_variable_units => get_variable_units, & + fms2_io_get_time_calendar => get_time_calendar, & + fms2_io_open_check => open_check, & + fms2_io_is_registered_to_restart => is_registered_to_restart, & + fms2_io_check_if_open => check_if_open, & + fms2_io_set_fileobj_time_name => set_fileobj_time_name, & + fms2_io_is_dimension_registered => is_dimension_registered, & + fms2_io_fms2_io_init => fms2_io_init, & + fms2_io_get_mosaic_tile_grid => get_mosaic_tile_grid, & + fms2_io_write_restart_bc => write_restart_bc, & + fms2_io_read_restart_bc => read_restart_bc, & + fms2_io_get_filename_appendix => get_filename_appendix, & + fms2_io_set_filename_appendix => set_filename_appendix, & + fms2_io_get_instance_filename => get_instance_filename, & + fms2_io_nullify_filename_appendix => nullify_filename_appendix, & + fms2_io_ascii_read => ascii_read, & + fms2_io_get_mosaic_tile_file => get_mosaic_tile_file, & + fms2_io_parse_mask_table => parse_mask_table ! used via fms2_io - ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, + ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, & ! fms_netcdf_unstructured_domain_io_mod, blackboxio !> fms !! routines that don't conflict with fms2_io - use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, check_nml_error, & - monotonic_array, string_array_index, clock_flag_default, & - print_memory_usage, write_version_number + use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, & + check_nml_error, & + fms_monotonic_array => monotonic_array, fms_string_array_index => string_array_index, & + fms_clock_flag_default => clock_flag_default, fms_print_memory_usage => print_memory_usage, & + fms_write_version_number => write_version_number !> horiz_interp - use horiz_interp_mod, only: horiz_interp, horiz_interp_new, horiz_interp_del, & - horiz_interp_init, horiz_interp_end - use horiz_interp_type_mod, only: horiz_interp_type, assignment(=), CONSERVE, & - BILINEAR, SPHERICA, BICUBIC, stats + use horiz_interp_mod, only: fms_horiz_interp => horiz_interp, fms_horiz_interp_new => horiz_interp_new, & + fms_horiz_interp_del => horiz_interp_del, fms_horiz_interp_init => horiz_interp_init, & + fms_horiz_interp_end => horiz_interp_end + use horiz_interp_type_mod, only: FmsHorizInterp_type => horiz_interp_type, & + assignment(=), CONSERVE, BILINEAR, SPHERICA, BICUBIC, & + fms_horiz_interp_type_stats => stats !! used via horiz_interp ! horiz_interp_bicubic_mod, horiz_interp_bilinear_mod ! horiz_interp_conserve_mod, horiz_interp_spherical_mod !> interpolator - use interpolator_mod, only: interpolator_init, interpolator, interpolate_type_eq, & - obtain_interpolator_time_slices, unset_interpolator_time_flag, & - interpolator_end, init_clim_diag, query_interpolator, & - interpolate_type, CONSTANT, & - INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & - INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO - interpolator_read_data=>read_data !! conflicts with fms2_io interface + use interpolator_mod, only: fms_interpolator_init => interpolator_init, & + fms_interpolator => interpolator, & + fms_interpolate_type_eq => interpolate_type_eq, & + fms_interpolator_obtain_interpolator_time_slices => obtain_interpolator_time_slices, & + fms_interpolator_unset_interpolator_time_flag => unset_interpolator_time_flag, & + fms_interpolator_end => interpolator_end, & + fms_interpolator_init_clim_diag => init_clim_diag, & + fms_interpolator_query_interpolator => query_interpolator, & + FmsInterpolate_type => interpolate_type, & + CONSTANT, INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & + FMS_INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO + fms_interpolator_read_data=>read_data !> memutils - use memutils_mod, only: memutils_init, print_memuse_stats + use memutils_mod, only: fms_memutils_init => memutils_init, & + fms_memutils_print_memuse_stats => print_memuse_stats !> monin_obukhov - use monin_obukhov_mod, only: monin_obukhov_init, monin_obukhov_end, & - mo_drag, mo_profile, mo_diff, stable_mix - use monin_obukhov_inter, only: monin_obukhov_diff, monin_obukhov_drag_1d, & - monin_obukhov_solve_zeta, monin_obukhov_derivative_t, & - monin_obukhov_derivative_m, monin_obukhov_profile_1d, & - monin_obukhov_integral_m, monin_obukhov_integral_tq, & - monin_obukhov_stable_mix + use monin_obukhov_mod, only: fms_monin_obukhov_init => monin_obukhov_init, & + fms_monin_obukhov_end => monin_obukhov_end, & + fms_monin_obukhov_mo_drag => mo_drag, & + fms_monin_obukhov_mo_profile => mo_profile, & + fms_monin_obukhov_mo_diff => mo_diff, & + fms_monin_obukhov_stable_mix => stable_mix + use monin_obukhov_inter, only: fms_monin_obukhov_inter_diff => monin_obukhov_diff, & + fms_monin_obukhov_inter_drag_1d => monin_obukhov_drag_1d, & + fms_monin_obukhov_inter_solve_zeta => monin_obukhov_solve_zeta, & + fms_monin_obukhov_inter_derivative_t => monin_obukhov_derivative_t, & + fms_monin_obukhov_inter_derivative_m => monin_obukhov_derivative_m, & + fms_monin_obukhov_inter_profile_1d => monin_obukhov_profile_1d, & + fms_monin_obukhov_inter_integral_m => monin_obukhov_integral_m, & + fms_monin_obukhov_inter_integral_tq => monin_obukhov_integral_tq, & + fms_monin_obukhov_inter_stable_mix => monin_obukhov_stable_mix !> mosaic - use mosaic2_mod, only: get_mosaic_ntiles, get_mosaic_ncontacts, & - get_mosaic_grid_sizes, get_mosaic_contact, & - get_mosaic_xgrid_size, get_mosaic_xgrid, & - calc_mosaic_grid_area, calc_mosaic_grid_great_circle_area, & - is_inside_polygon, & - mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io - use grid2_mod, only: get_grid_ntiles, get_grid_size, get_grid_cell_centers, & - get_grid_cell_vertices, get_grid_cell_Area, get_grid_comp_area, & - define_cube_mosaic, get_great_circle_algorithm, grid_init, grid_end - use gradient_mod, only: gradient_cubic, calc_cubic_grid_info + use mosaic2_mod, only: fms_mosaic2_get_mosaic_ntiles => get_mosaic_ntiles, & + fms_mosaic2_get_mosaic_ncontacts => get_mosaic_ncontacts, & + fms_mosaic2_get_mosaic_grid_sizes => get_mosaic_grid_sizes, & + fms_mosaic2_get_mosaic_contact => get_mosaic_contact, & + fms_mosaic2_get_mosaic_xgrid_size => get_mosaic_xgrid_size, & + fms_mosaic2_get_mosaic_xgrid => get_mosaic_xgrid, & + fms_mosaic2_calc_mosaic_grid_area => calc_mosaic_grid_area, & + fms_mosaic2_calc_mosaic_grid_great_circle_area => calc_mosaic_grid_great_circle_area, & + fms_mosaic2_is_inside_polygon => is_inside_polygon, & + fms_mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io + use grid2_mod, only: fms_grid2_get_grid_ntiles => get_grid_ntiles, & + fms_grid2_get_grid_size => get_grid_size, & + fms_grid2_get_grid_cell_centers => get_grid_cell_centers, & + fms_grid2_get_grid_cell_vertices => get_grid_cell_vertices, & + fms_grid2_get_grid_cell_Area => get_grid_cell_Area, & + fms_grid2_get_grid_comp_area => get_grid_comp_area, & + fms_grid2_define_cube_mosaic => define_cube_mosaic, & + fms_grid2_get_great_circle_algorithm => get_great_circle_algorithm, & + fms_grid2_grid_init => grid_init, & + fms_grid2_end => grid_end + use gradient_mod, only: fms_gradient_cubic => gradient_cubic, & + fms_gradient_calc_cubic_grid_info => calc_cubic_grid_info !> mpp - use mpp_mod, only: stdin, stdout, stderr, & - stdlog, lowercase, uppercase, mpp_error, mpp_error_state, & - mpp_set_warn_level, mpp_sync, mpp_sync_self, mpp_set_stack_size, & - mpp_pe, mpp_npes, mpp_root_pe, mpp_set_root_pe, mpp_declare_pelist, & - mpp_get_current_pelist, mpp_set_current_pelist, & - mpp_get_current_pelist_name, mpp_clock_id, mpp_clock_set_grain, & - mpp_record_timing_data, get_unit, read_ascii_file, read_input_nml, & - mpp_clock_begin, mpp_clock_end, get_ascii_file_num_lines, & - mpp_record_time_start, mpp_record_time_end, mpp_chksum, & - mpp_max, mpp_min, mpp_sum, mpp_transmit, mpp_send, mpp_recv, & - mpp_sum_ad, mpp_broadcast, mpp_init, mpp_exit, mpp_gather, & - mpp_scatter, mpp_alltoall, mpp_type, mpp_byte, mpp_type_create, & - mpp_type_free, input_nml_file + use mpp_mod, only: fms_mpp_stdin => stdin, & + fms_mpp_stdout => stdout, & + fms_mpp_stderr => stderr, & + fms_mpp_stdlog => stdlog, & + fms_mpp_lowercase => lowercase, & + fms_mpp_uppercase => uppercase, & + fms_mpp_error => mpp_error, & + fms_mpp_error_state => mpp_error_state, & + fms_mpp_set_warn_level => mpp_set_warn_level, & + fms_mpp_sync => mpp_sync, & + fms_mpp_sync_self => mpp_sync_self, & + fms_mpp_set_stack_size => mpp_set_stack_size, & + fms_mpp_pe => mpp_pe, & + fms_mpp_npes => mpp_npes, & + fms_mpp_root_pe => mpp_root_pe, & + fms_mpp_set_root_pe => mpp_set_root_pe, & + fms_mpp_declare_pelist => mpp_declare_pelist, & + fms_mpp_get_current_pelist => mpp_get_current_pelist, & + fms_mpp_set_current_pelist => mpp_set_current_pelist, & + fms_mpp_get_current_pelist_name => mpp_get_current_pelist_name, & + fms_mpp_clock_id => mpp_clock_id, & + fms_mpp_clock_set_grain => mpp_clock_set_grain, & + fms_mpp_record_timing_data => mpp_record_timing_data, & + fms_mpp_get_unit => get_unit, & + fms_mpp_read_ascii_file => read_ascii_file, & + fms_mpp_read_input_nml => read_input_nml, & + fms_mpp_clock_begin => mpp_clock_begin, & + fms_mpp_clock_end => mpp_clock_end, & + fms_mpp_get_ascii_file_num_lines => get_ascii_file_num_lines, & + fms_mpp_record_time_start => mpp_record_time_start, & + fms_mpp_record_time_end => mpp_record_time_end, & + fms_mpp_chksum => mpp_chksum, & + fms_mpp_max => mpp_max, & + fms_mpp_min => mpp_min, & + fms_mpp_sum => mpp_sum, & + fms_mpp_transmit => mpp_transmit, & + fms_mpp_send => mpp_send, & + fms_mpp_recv => mpp_recv, & + fms_mpp_sum_ad => mpp_sum_ad, & + fms_mpp_broadcast => mpp_broadcast, & + fms_mpp_init => mpp_init, & + fms_mpp_exit => mpp_exit, & + fms_mpp_gather => mpp_gather, & + fms_mpp_scatter => mpp_scatter, & + fms_mpp_alltoall => mpp_alltoall, & + FmsMpp_type => mpp_type, & + FmsMpp_byte => mpp_byte, & + fms_mpp_type_create => mpp_type_create, & + fms_mpp_type_free => mpp_type_free, & + fms_mpp_input_nml_file => input_nml_file use mpp_parameter_mod,only:MAXPES, MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, & NOTE, WARNING, FATAL, MPP_WAIT, MPP_READY, MAX_CLOCKS, & MAX_EVENT_TYPES, MAX_EVENTS, MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, & @@ -298,74 +548,161 @@ module fms MAX_DOMAIN_FIELDS, MAX_TILES, ZERO, NINETY, MINUS_NINETY, & ONE_HUNDRED_EIGHTY, NONBLOCK_UPDATE_TAG, EDGEUPDATE, EDGEONLY, & NONSYMEDGEUPDATE, NONSYMEDGE - use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & - ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & - ptr_remote, mpp_domains_stack, ptr_domains_stack, & - mpp_domains_stack_nonblock, ptr_domains_stack_nonblock - use mpp_utilities_mod, only: mpp_array_global_min_max - use mpp_memutils_mod, only: mpp_print_memuse_stats, mpp_mem_dump, & - mpp_memuse_begin, mpp_memuse_end - use mpp_efp_mod, only: mpp_reproducing_sum, mpp_efp_list_sum_across_PEs, & - mpp_efp_plus, mpp_efp_minus, mpp_efp_to_real, & - mpp_real_to_efp, mpp_efp_real_diff, operator(+), & - operator(-), assignment(=), mpp_query_efp_overflow_error, & - mpp_reset_efp_overflow_error, mpp_efp_type - use mpp_domains_mod, only: domain_axis_spec, domain1D, domain2D, DomainCommunicator2D, & - nest_domain_type, mpp_group_update_type, & - mpp_domains_set_stack_size, mpp_get_compute_domain, & - mpp_get_compute_domains, mpp_get_data_domain, & - mpp_get_global_domain, mpp_get_domain_components, & - mpp_get_layout, mpp_get_pelist, operator(.EQ.), operator(.NE.), & - mpp_domain_is_symmetry, mpp_domain_is_initialized, & - mpp_get_neighbor_pe, mpp_nullify_domain_list, & - mpp_set_compute_domain, mpp_set_data_domain, mpp_set_global_domain, & - mpp_get_memory_domain, mpp_get_domain_shift, & - mpp_domain_is_tile_root_pe, mpp_get_tile_id, & - mpp_get_domain_extents, mpp_get_current_ntile, & - mpp_get_ntile_count, mpp_get_tile_list, mpp_get_tile_npes, & - mpp_get_domain_root_pe, mpp_get_tile_pelist, & - mpp_get_tile_compute_domains, mpp_get_num_overlap, & - mpp_get_overlap, mpp_get_io_domain, mpp_get_domain_pe, & - mpp_get_domain_tile_root_pe, mpp_get_domain_name, & - mpp_get_io_domain_layout, mpp_copy_domain, mpp_set_domain_symmetry, & - mpp_get_update_pelist, mpp_get_update_size, & - mpp_get_domain_npes, mpp_get_domain_pelist, & - mpp_clear_group_update, mpp_group_update_initialized, & - mpp_group_update_is_set, mpp_get_global_domains, & - mpp_global_field, mpp_global_max, mpp_global_min, mpp_global_sum, & - mpp_global_sum_tl, mpp_global_sum_ad, mpp_broadcast_domain, & - mpp_domains_init, mpp_domains_exit, mpp_redistribute, & - mpp_update_domains, mpp_check_field, mpp_start_update_domains, & - mpp_complete_update_domains, mpp_create_group_update, & - mpp_do_group_update, mpp_start_group_update, & - mpp_complete_group_update, mpp_reset_group_update_field, & - mpp_update_nest_fine, mpp_update_nest_coarse, mpp_get_boundary, & - mpp_update_domains_ad, mpp_get_boundary_ad, mpp_pass_SG_to_UG, & - mpp_pass_UG_to_SG, mpp_define_layout, mpp_define_domains, & - mpp_modify_domain, mpp_define_mosaic, mpp_define_mosaic_pelist, & - mpp_define_null_domain, mpp_mosaic_defined, & - mpp_define_io_domain, mpp_deallocate_domain, & - mpp_compute_extent, mpp_compute_block_extent, & - mpp_define_unstruct_domain, domainUG, mpp_get_UG_io_domain, & - mpp_get_UG_domain_npes, mpp_get_UG_compute_domain, & - mpp_get_UG_domain_tile_id, mpp_get_UG_domain_pelist, & - mpp_get_ug_domain_grid_index, mpp_get_UG_domain_ntiles, & - mpp_get_UG_global_domain, mpp_global_field_ug, & - mpp_get_ug_domain_tile_list, mpp_get_UG_compute_domains, & - mpp_define_null_UG_domain, NULL_DOMAINUG, mpp_get_UG_domains_index, & - mpp_get_UG_SG_domain, mpp_get_UG_domain_tile_pe_inf, & - mpp_define_nest_domains, mpp_get_C2F_index, mpp_get_F2C_index, & - mpp_get_nest_coarse_domain, mpp_get_nest_fine_domain, & - mpp_is_nest_coarse, mpp_is_nest_fine, & - mpp_get_nest_pelist, mpp_get_nest_npes, & - mpp_get_nest_fine_pelist, mpp_get_nest_fine_npes, & - mpp_domain_UG_is_tile_root_pe, mpp_deallocate_domainUG, & - mpp_get_io_domain_UG_layout, NULL_DOMAIN1D, NULL_DOMAIN2D, & - mpp_create_super_grid_domain, mpp_shift_nest_domains + ! this should really only be used internally + !use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & + ! ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & + ! ptr_remote, mpp_domains_stack, ptr_domains_stack, & + ! mpp_domains_stack_nonblock, ptr_domains_stack_nonblock + use mpp_utilities_mod, only: fms_mpp_utilities_array_global_min_max => mpp_array_global_min_max + use mpp_memutils_mod, only: fms_mpp_memutils_print_memuse_stats => mpp_print_memuse_stats, & + fms_mpp_memutils_mem_dump => mpp_mem_dump, & + fms_mpp_memutils_memuse_begin => mpp_memuse_begin, & + fms_mpp_memutils_memuse_end => mpp_memuse_end + use mpp_efp_mod, only: fms_mpp_efp_reproducing_sum => mpp_reproducing_sum, & + fms_mpp_efp_list_sum_across_PEs => mpp_efp_list_sum_across_PEs, & + fms_mpp_efp_plus => mpp_efp_plus, & + fms_mpp_efp_minus => mpp_efp_minus, & + fms_mpp_efp_to_real => mpp_efp_to_real, & + fms_mpp_efp_real_to_efp => mpp_real_to_efp, & + fms_mpp_efp_real_diff => mpp_efp_real_diff, & + operator(+), operator(-), assignment(=), & + fms_mpp_efp_query_overflow_error => mpp_query_efp_overflow_error, & + fms_mpp_efp_reset_overflow_error => mpp_reset_efp_overflow_error, & + FmsMppEfp_type => mpp_efp_type + use mpp_domains_mod, only: FmsMppDomains_axis_spec => domain_axis_spec, & + FmsMppDomain1D => domain1D, & + FmsMppDomain2D => domain2D, & + FmsMppDomainCommunicator2D => DomainCommunicator2D, & + FmsMppDomainsNestDomain_type => nest_domain_type, & + FmsMppDomainsGroupUpdate_type => mpp_group_update_type, & + fms_mpp_domains_domains_set_stack_size => mpp_domains_set_stack_size, & + fms_mpp_domains_get_compute_domain => mpp_get_compute_domain, & + fms_mpp_domains_get_compute_domains => mpp_get_compute_domains, & + fms_mpp_domains_get_data_domain => mpp_get_data_domain, & + fms_mpp_domains_get_global_domain => mpp_get_global_domain, & + fms_mpp_domains_get_domain_components => mpp_get_domain_components, & + fms_mpp_domains_get_layout => mpp_get_layout, & + fms_mpp_domains_get_pelist => mpp_get_pelist, & + operator(.EQ.), operator(.NE.), & + fms_mpp_domains_domain_is_symmetry => mpp_domain_is_symmetry, & + fms_mpp_domains_domain_is_initialized => mpp_domain_is_initialized, & + fms_mpp_domains_get_neighbor_pe => mpp_get_neighbor_pe, & + fms_mpp_domains_nullify_domain_list => mpp_nullify_domain_list, & + fms_mpp_domains_set_compute_domain => mpp_set_compute_domain, & + fms_mpp_domains_set_data_domain => mpp_set_data_domain, & + fms_mpp_domains_set_global_domain => mpp_set_global_domain, & + fms_mpp_domains_get_memory_domain => mpp_get_memory_domain, & + fms_mpp_domains_get_domain_shift => mpp_get_domain_shift, & + fms_mpp_domains_domain_is_tile_root_pe => mpp_domain_is_tile_root_pe, & + fms_mpp_domains_get_tile_id => mpp_get_tile_id, & + fms_mpp_domains_get_domain_extents => mpp_get_domain_extents, & + fms_mpp_domains_get_current_ntile => mpp_get_current_ntile, & + fms_mpp_domains_get_ntile_count => mpp_get_ntile_count, & + fms_mpp_domains_get_tile_list => mpp_get_tile_list, & + fms_mpp_domains_get_tile_npes => mpp_get_tile_npes, & + fms_mpp_domains_get_domain_root_pe => mpp_get_domain_root_pe, & + fms_mpp_domains_get_tile_pelist => mpp_get_tile_pelist, & + fms_mpp_domains_get_tile_compute_domains => mpp_get_tile_compute_domains, & + fms_mpp_domains_get_num_overlap => mpp_get_num_overlap, & + fms_mpp_domains_get_overlap => mpp_get_overlap, & + fms_mpp_domains_get_io_domain => mpp_get_io_domain, & + fms_mpp_domains_get_domain_pe => mpp_get_domain_pe, & + fms_mpp_domains_get_domain_tile_root_pe => mpp_get_domain_tile_root_pe, & + fms_mpp_domains_get_domain_name => mpp_get_domain_name, & + fms_mpp_domains_get_io_domain_layout => mpp_get_io_domain_layout, & + fms_mpp_domains_copy_domain => mpp_copy_domain, & + fms_mpp_domains_set_domain_symmetry => mpp_set_domain_symmetry, & + fms_mpp_domains_get_update_pelist => mpp_get_update_pelist, & + fms_mpp_domains_get_update_size => mpp_get_update_size, & + fms_mpp_domains_get_domain_npes => mpp_get_domain_npes, & + fms_mpp_domains_get_domain_pelist => mpp_get_domain_pelist, & + fms_mpp_domains_clear_group_update => mpp_clear_group_update, & + fms_mpp_domains_group_update_initialized => mpp_group_update_initialized, & + fms_mpp_domains_group_update_is_set => mpp_group_update_is_set, & + fms_mpp_domains_get_global_domains => mpp_get_global_domains, & + fms_mpp_domains_global_field => mpp_global_field, & + fms_mpp_domains_global_max => mpp_global_max, & + fms_mpp_domains_global_min => mpp_global_min, & + fms_mpp_domains_global_sum => mpp_global_sum, & + fms_mpp_domains_global_sum_tl => mpp_global_sum_tl, & + fms_mpp_domains_global_sum_ad => mpp_global_sum_ad, & + fms_mpp_domains_broadcast_domain => mpp_broadcast_domain, & + fms_mpp_domains_init => mpp_domains_init, & + fms_mpp_domains_exit => mpp_domains_exit, & + fms_mpp_domains_redistribute => mpp_redistribute, & + fms_mpp_domains_update_domains => mpp_update_domains, & + fms_mpp_domains_check_field => mpp_check_field, & + fms_mpp_domains_start_update_domains => mpp_start_update_domains, & + fms_mpp_domains_complete_update_domains => mpp_complete_update_domains, & + fms_mpp_domains_create_group_update => mpp_create_group_update, & + fms_mpp_domains_do_group_update => mpp_do_group_update, & + fms_mpp_domains_start_group_update => mpp_start_group_update, & + fms_mpp_domains_complete_group_update => mpp_complete_group_update, & + fms_mpp_domains_reset_group_update_field => mpp_reset_group_update_field, & + fms_mpp_domains_update_nest_fine => mpp_update_nest_fine, & + fms_mpp_domains_update_nest_coarse => mpp_update_nest_coarse, & + fms_mpp_domains_get_boundary => mpp_get_boundary, & + fms_mpp_domains_update_domains_ad => mpp_update_domains_ad, & + fms_mpp_domains_get_boundary_ad => mpp_get_boundary_ad, & + fms_mpp_domains_pass_SG_to_UG => mpp_pass_SG_to_UG, & + fms_mpp_domains_pass_UG_to_SG => mpp_pass_UG_to_SG, & + fms_mpp_domains_define_layout => mpp_define_layout, & + fms_mpp_domains_define_domains => mpp_define_domains, & + fms_mpp_domains_modify_domain => mpp_modify_domain, & + fms_mpp_domains_define_mosaic => mpp_define_mosaic, & + fms_mpp_domains_define_mosaic_pelist => mpp_define_mosaic_pelist, & + fms_mpp_domains_define_null_domain => mpp_define_null_domain, & + fms_mpp_domains_mosaic_defined => mpp_mosaic_defined, & + fms_mpp_domains_define_io_domain => mpp_define_io_domain, & + fms_mpp_domains_deallocate_domain => mpp_deallocate_domain, & + fms_mpp_domains_compute_extent => mpp_compute_extent, & + fms_mpp_domains_compute_block_extent => mpp_compute_block_extent, & + fms_mpp_domains_define_unstruct_domain => mpp_define_unstruct_domain, & + fmsMppDomainUG => domainUG, & + fms_mpp_domains_get_UG_io_domain => mpp_get_UG_io_domain, & + fms_mpp_domains_get_UG_domain_npes => mpp_get_UG_domain_npes, & + fms_mpp_domains_get_UG_compute_domain => mpp_get_UG_compute_domain, & + fms_mpp_domains_get_UG_domain_tile_id => mpp_get_UG_domain_tile_id, & + fms_mpp_domains_get_UG_domain_pelist => mpp_get_UG_domain_pelist, & + fms_mpp_domains_get_ug_domain_grid_index => mpp_get_ug_domain_grid_index, & + fms_mpp_domains_get_UG_domain_ntiles => mpp_get_UG_domain_ntiles, & + fms_mpp_domains_get_UG_global_domain => mpp_get_UG_global_domain, & + fms_mpp_domains_global_field_ug => mpp_global_field_ug, & + fms_mpp_domains_get_ug_domain_tile_list => mpp_get_ug_domain_tile_list, & + fms_mpp_domains_get_UG_compute_domains => mpp_get_UG_compute_domains, & + fms_mpp_domains_define_null_UG_domain => mpp_define_null_UG_domain, & + fms_mpp_domains_NULL_DOMAINUG => NULL_DOMAINUG, & + fms_mpp_domains_get_UG_domains_index => mpp_get_UG_domains_index, & + fms_mpp_domains_get_UG_SG_domain => mpp_get_UG_SG_domain, & + fms_mpp_domains_get_UG_domain_tile_pe_inf => mpp_get_UG_domain_tile_pe_inf, & + fms_mpp_domains_define_nest_domains => mpp_define_nest_domains, & + fms_mpp_domains_get_C2F_index => mpp_get_C2F_index, & + fms_mpp_domains_get_F2C_index => mpp_get_F2C_index, & + fms_mpp_domains_get_nest_coarse_domain => mpp_get_nest_coarse_domain, & + fms_mpp_domains_get_nest_fine_domain => mpp_get_nest_fine_domain, & + fms_mpp_domains_is_nest_coarse => mpp_is_nest_coarse, & + fms_mpp_domains_is_nest_fine => mpp_is_nest_fine, & + fms_mpp_domains_get_nest_pelist => mpp_get_nest_pelist, & + fms_mpp_domains_get_nest_npes => mpp_get_nest_npes, & + fms_mpp_domains_get_nest_fine_pelist => mpp_get_nest_fine_pelist, & + fms_mpp_domains_get_nest_fine_npes => mpp_get_nest_fine_npes, & + fms_mpp_domains_domain_UG_is_tile_root_pe => mpp_domain_UG_is_tile_root_pe, & + fms_mpp_domains_deallocate_domainUG => mpp_deallocate_domainUG, & + fms_mpp_domains_get_io_domain_UG_layout => mpp_get_io_domain_UG_layout, & + NULL_DOMAIN1D, & + NULL_DOMAIN2D, & + fms_mpp_domains_create_super_grid_domain => mpp_create_super_grid_domain, & + fms_mpp_domains_shift_nest_domains => mpp_shift_nest_domains !> parser #ifdef use_yaml - use yaml_parser_mod, only: open_and_parse_file, get_num_blocks, get_block_ids, get_value_from_key, & - get_nkeys, get_key_ids, get_key_name, get_key_value + use yaml_parser_mod, only: fms_yaml_parser_open_and_parse_file => open_and_parse_file, & + fms_yaml_parser_get_num_blocks => get_num_blocks, & + fms_yaml_parser_get_block_ids => get_block_ids, & + fms_yaml_parser_get_value_from_key => get_value_from_key, & + fms_yaml_parser_get_nkeys => get_nkeys, & + fms_yaml_parser_get_key_ids => get_key_ids, & + fms_yaml_parser_get_key_name => get_key_name, & + fms_yaml_parser_get_key_value => get_key_value #endif !> platform @@ -373,64 +710,124 @@ module fms l8_kind, l4_kind, i2_kind, ptr_kind !> random_numbers - use random_numbers_mod, only: randomNumberStream, initializeRandomNumberStream, & - getRandomNumbers, constructSeed + use random_numbers_mod, only: fms_random_numbers_randomNumberStream => randomNumberStream, & + fms_random_numbers_initializeRandomNumbersStream => initializeRandomNumberStream, & + fms_random_numbers_getRandomNumbers => getRandomNumbers, & + fms_random_numbers_constructSeed => constructSeed !> sat_vapor_pres - use sat_vapor_pres_mod, only: lookup_es, lookup_des, sat_vapor_pres_init, & - lookup_es2, lookup_des2, lookup_es2_des2, & - lookup_es3, lookup_des3, lookup_es3_des3, & - lookup_es_des, compute_qs, compute_mrs, & - escomp, descomp + use sat_vapor_pres_mod, only: fms_sat_vapor_pres_lookup_es => lookup_es, & + fms_sat_vapor_pres_lookup_des => lookup_des, & + fms_sat_vapor_pres_init => sat_vapor_pres_init, & + fms_sat_vapor_pres_lookup_es2 => lookup_es2, & + fms_sat_vapor_pres_lookup_des2 => lookup_des2, & + fms_sat_vapor_pres_lookup_es2_des2 => lookup_es2_des2, & + fms_sat_vapor_pres_lookup_es3 => lookup_es3, & + fms_sat_vapor_pres_lookup_des3 => lookup_des3, & + fms_sat_vapor_pres_lookup_es3_des3 => lookup_es3_des3, & + fms_sat_vapor_pres_lookup_es_des => lookup_es_des, & + fms_sat_vapor_pres_compute_qs => compute_qs, & + fms_sat_vapor_pres_compute_mrs => compute_mrs, & + fms_sat_vapor_pres_escomp => escomp, & + fms_sat_vapor_pres_descomp => descomp !> string_utils - use fms_string_utils_mod, only: string, fms_array_to_pointer, fms_pointer_to_array, fms_sort_this, & - fms_find_my_string, fms_find_unique, fms_c2f_string, fms_cstring2cpointer, & - string_copy + use fms_string_utils_mod, only: fms_string_utils_string => string, & + fms_string_utils_array_to_pointer => fms_array_to_pointer, & + fms_string_utils_fms_pointer_to_array => fms_pointer_to_array, & + fms_string_utils_sort_this => fms_sort_this, & + fms_string_utils_find_my_string => fms_find_my_string, & + fms_string_utils_find_unique => fms_find_unique, & + fms_string_utils_c2f_string => fms_c2f_string, & + fms_string_utils_cstring2cpointer => fms_cstring2cpointer, & + fms_string_utils_copy => string_copy !> time_interp - use time_interp_mod, only: time_interp_init, time_interp, fraction_of_year, & + use time_interp_mod, only: fms_time_interp_init => time_interp_init, & + fms_time_interp => time_interp, fms_fraction_of_year=> fraction_of_year, & NONE, YEAR, MONTH, DAY - use time_interp_external2_mod, only: init_external_field, time_interp_external, & - time_interp_external_init, time_interp_external_exit, & - get_external_field_size, get_time_axis, & - get_external_field_missing, set_override_region, & - reset_src_data_region, get_external_fileobj, & + use time_interp_external2_mod, only: fms_time_interp_external_init_external_field => init_external_field, & + fms_time_interp_external => time_interp_external, & + fms_time_interp_external_init => time_interp_external_init, & + fms_time_interp_external_exit => time_interp_external_exit, & + fms_time_interp_external_get_external_field_size => get_external_field_size, & + fms_time_interp_external_get_time_axis => get_time_axis, & + fms_time_interp_external_get_external_field_missing => get_external_field_missing, & + fms_time_interp_external_set_override_region => set_override_region, & + fms_time_interp_external_reset_src_data_region => reset_src_data_region, & + fms_time_interp_external_get_external_fileobj => get_external_fileobj, & NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & SUCCESS, ERR_FIELD_NOT_FOUND !> time_manager - use time_manager_mod, only: time_type, operator(+), operator(-), operator(*), & + use time_manager_mod, only: FmsTime_type => time_type, & + operator(+), operator(-), operator(*), assignment(=),& operator(/), operator(>), operator(>=), operator(==), & operator(/=), operator(<), operator(<=), operator(//), & - assignment(=), set_time, increment_time, decrement_time, & - get_time, interval_alarm, repeat_alarm, time_type_to_real, & - real_to_time_type, time_list_error, THIRTY_DAY_MONTHS, & - JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & - set_calendar_type, get_calendar_type, set_ticks_per_second, & - get_ticks_per_second, set_date, get_date, increment_date, & - decrement_date, days_in_month, leap_year, length_of_year, & - days_in_year, day_of_year, month_name, valid_calendar_types, & - time_manager_init, print_time, print_date, set_date_julian, & - get_date_julian, get_date_no_leap, date_to_string - use get_cal_time_mod, only: get_cal_time + fms_time_manager_set_time => set_time, & + fms_time_manager_increment_time => increment_time, & + fms_time_manager_decrement_time => decrement_time, & + fms_time_manager_get_time => get_time, & + fms_time_manager_interval_alarm => interval_alarm, & + fms_time_manager_repeat_alarm => repeat_alarm, & + fms_time_manager_time_type_to_real => time_type_to_real, & + fms_time_manager_real_to_time_type => real_to_time_type, & + fms_time_manager_time_list_error => time_list_error, & + THIRTY_DAY_MONTHS, JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & + fms_time_manager_set_calendar_type => set_calendar_type, & + fms_time_manager_get_calendar_type => get_calendar_type, & + fms_time_manager_set_ticks_per_second => set_ticks_per_second, & + fms_time_manager_get_ticks_per_second => get_ticks_per_second, & + fms_time_manager_set_date => set_date, & + fms_time_manager_get_date => get_date, & + fms_time_manager_increment_date => increment_date, & + fms_time_manager_decrement_date => decrement_date, & + fms_time_manager_days_in_month => days_in_month, & + fms_time_manager_leap_year => leap_year, & + fms_time_manager_length_of_year => length_of_year, & + fms_time_manager_days_in_year => days_in_year, & + fms_time_manager_day_of_year => day_of_year, & + fms_time_manager_month_name => month_name, & + fms_time_manager_valid_calendar_types => valid_calendar_types, & + fms_time_manager_init => time_manager_init, & + fms_time_manager_print_time => print_time, & + fms_time_manager_print_date => print_date, & + fms_time_manager_set_date_julian => set_date_julian, & + fms_time_manager_get_date_julian => get_date_julian, & + fms_time_manager_get_date_no_leap => get_date_no_leap, & + fms_time_manager_date_to_string => date_to_string + use get_cal_time_mod, only: fms_get_cal_time => get_cal_time !> topography - use gaussian_topog_mod, only: gaussian_topog_init, get_gaussian_topog - use topography_mod, only: topography_init, get_topog_mean, get_topog_stdev, & - get_ocean_frac, get_ocean_mask, get_water_frac, & - get_water_mask + use gaussian_topog_mod, only: fms_gaussian_topog_init => gaussian_topog_init, & + fms_get_gaussian_topog => get_gaussian_topog + use topography_mod, only: fms_topography_init => topography_init, & + fms_topography_get_topog_mean => get_topog_mean, & + fms_topography_get_topog_stdev => get_topog_stdev, & + fms_topography_get_ocean_frac => get_ocean_frac, & + fms_topography_get_ocean_mask => get_ocean_mask, & + fms_topography_get_water_frac => get_water_frac, & + fms_topography_get_water_mask => get_water_mask !> tracer_manager - use tracer_manager_mod, only: tracer_manager_init, tracer_manager_end, & - check_if_prognostic, get_tracer_indices, & - get_tracer_index, get_tracer_names, & - get_tracer_name, query_method, & - set_tracer_atts, set_tracer_profile, & - register_tracers, get_number_tracers, & - adjust_mass, adjust_positive_def, NO_TRACER, MAX_TRACER_FIELDS + use tracer_manager_mod, only: fms_tracer_manager_init => tracer_manager_init, & + fms_tracer_manager_end => tracer_manager_end, & + fms_tracer_manager_check_if_prognostic => check_if_prognostic, & + fms_tracer_manager_get_tracer_indices => get_tracer_indices, & + fms_tracer_manager_get_tracer_index => get_tracer_index, & + fms_tracer_manager_get_tracer_names => get_tracer_names, & + fms_tracer_manager_get_tracer_name => get_tracer_name, & + fms_tracer_manager_query_method => query_method, & + fms_tracer_manager_set_tracer_atts => set_tracer_atts, & + fms_tracer_manager_set_tracer_profile => set_tracer_profile, & + fms_tracer_manager_register_tracers => register_tracers, & + fms_tracer_manager_get_number_tracers => get_number_tracers, & + fms_tracer_manager_adjust_mass => adjust_mass, & + fms_tracer_manager_adjust_positive_def => adjust_positive_def, & + NO_TRACER, MAX_TRACER_FIELDS !> tridiagonal - use tridiagonal_mod, only: tri_invert, close_tridiagonal + use tridiagonal_mod, only: fms_tridiagonal_tri_invert => tri_invert, & + fms_tridiagonal_close_tridiagonal => close_tridiagonal implicit none diff --git a/test_fms/mpp/test_domains_utility_mod.F90 b/test_fms/mpp/test_domains_utility_mod.F90 index 43271e053f..f88054b9f5 100644 --- a/test_fms/mpp/test_domains_utility_mod.F90 +++ b/test_fms/mpp/test_domains_utility_mod.F90 @@ -22,9 +22,9 @@ module test_domains_utility_mod use mpp_mod, only : FATAL, WARNING, MPP_DEBUG, NOTE use mpp_mod, only : mpp_error - use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY + use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY, & + domain2d, mpp_define_mosaic use platform_mod, only: r4_kind, r8_kind - use fms interface fill_coarse_data module procedure fill_coarse_data_r8 diff --git a/test_fms/mpp/test_mpp_chksum.F90 b/test_fms/mpp/test_mpp_chksum.F90 index a63ee7d22e..5810e42cab 100644 --- a/test_fms/mpp/test_mpp_chksum.F90 +++ b/test_fms/mpp/test_mpp_chksum.F90 @@ -23,7 +23,10 @@ !> single pe and distributed checksums program test_mpp_chksum - use fms + use mpp_mod + use mpp_domains_mod + use fms_mod + use platform_mod implicit none diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index 1ae1d904da..3ca557788f 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -54,7 +54,7 @@ program test_mpp_domains NONSYMEDGEUPDATE use mpp_domains_mod, only : domainUG, mpp_define_unstruct_domain, mpp_get_UG_domain_tile_id use mpp_domains_mod, only : mpp_get_UG_compute_domain, mpp_pass_SG_to_UG, mpp_pass_UG_to_SG - use mpp_domains_mod, only : mpp_global_field_ug + use mpp_domains_mod, only : mpp_global_field_ug, mpp_get_ug_global_domain use compare_data_checksums use test_domains_utility_mod diff --git a/test_fms/mpp/test_mpp_nesting.F90 b/test_fms/mpp/test_mpp_nesting.F90 index 201fd217f0..833c580bf5 100644 --- a/test_fms/mpp/test_mpp_nesting.F90 +++ b/test_fms/mpp/test_mpp_nesting.F90 @@ -19,7 +19,9 @@ !> Tests nested domain operations and routines in mpp_domains program test_mpp_nesting - use fms + use fms_mod + use mpp_domains_mod + use mpp_mod use compare_data_checksums use test_domains_utility_mod use platform_mod From 0e4a6754db0f3bbbcf8c76f003d0df974928c30f Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 27 Jul 2023 13:21:57 -0400 Subject: [PATCH 026/394] fix: add fms_stacksize.c to fms_c_src_files in CMakeLists.txt (#1285) --- CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 270539cd4d..b2db09eace 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -196,6 +196,7 @@ list(APPEND fms_fortran_src_files # Collect FMS C source 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 From c7a70e7de670962a6cc2ee1d0b667966c32bab8d Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 28 Jul 2023 08:35:41 -0400 Subject: [PATCH 027/394] chore: update changelog for 2023.02 release (#1306) --- CHANGELOG.md | 39 +++++++++++++++++++++++++++++++++++++++ CMakeLists.txt | 2 +- configure.ac | 2 +- libFMS/Makefile.am | 2 +- 4 files changed, 42 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0cc9802f8f..32cc50cd27 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,45 @@ and this project uses `yyyy.rr[.pp]`, where `yyyy` is the year a patch is releas `rr` is a sequential release number (starting from `01`), and an optional two-digit sequential patch number (starting from `01`). +## [2023.02] - 2023-07-27 +### Known Issues +- GCC 11.1.0 is unsupported due to compilation issues with select type. The issue is resolved in later GCC releases. +- When outputting sub-region diagnostics, the current diag_manager does not add "tileX" to the filename when using a cube sphere. This leads to trouble when trying to combine the files and regrid them (if the region is in two different tiles) +- GCC 10 and greater causing io issues when compiled using O2 optimization flags +- GNU compilers prior to the GCC 9.0 release are unsupported for this release due to lack of support for the findloc intrinsic function. This will result in an error saying 'findloc' has no IMPLICIT type and can be resolved by compiling with gcc version 9.0 or greater. + +### Added +- MPP/EXCHANGE: Adds association checks before pointer deallocations in mpp includes and xgrid + +### Changed +- LIBFMS: The libFMS.F90 file (module name `fms`) meant to provide global access has been updated to include 'fms' and it's module/subdirectory name as prefixes for all names. This will only affect external codes that are already using the global module (via `use fms`) and not individual modules. +- MIXED PRECISION: Updates the axis_utils2, horiz_interp, sat_vapor_pressure, and axis_utils subdirectories to support mixed precision real values. +- FMS2_IO: Added in mpp_scatter and mpp_gather performance changes from the 2023.01.01 patch. See below for more details. +- FMS2_IO: Improved error messages to give more debugging information +- FMS_MOD: Changed fms_init to include a system call to set the stack size to unlimited, removed previously added stack size fixes +- MONIN_OBUKHOV: Restructures the subroutines in `stable_mix` interface so that 1d calls the underlying implementation, and 2 and 3d call it on 1d slices of the data as opposed to passing in mismatched arrays. +- MPP: Updates from JEDI for ajoint version the mpp halo filling (mpp_do_update_ad.fh), adds checkpoint for forward buffer information. + +### Fixed +- MPP: mpp_broadcast causing an unintended error message due to checking the wrong pe value +- MPP: Added workaround for GCC 12 issues causing errors with string lengths in fms2_io +- FMS2_IO: Fixed support for 'packed' data when using NF_SHORT variables. Scale_factor and add_offset attributes will now be applied if present. +- DOCS: Improved doxygen comments for tranlon, updated deployment action for site +- TESTS: Workaround added for ICE coming from mpp_alltoall test with intel 2022.3, and fixes for any test scripts missing input.nml creation. Fixes for mpp/test_global_array failures. +- TIME_INTERP: Fixes crashes when calling with a non-existant field +- DIAG_MANAGER: Fixes a module dependency issue causing failures during parallel builds +- AXIS_UTILS2: Fixes an out of bounds memory index + +### Removed +- FMS_IO/MPP_IO: The two older io modules, fms_io_mod and mpp_io_mod, have been deprecated and will not be compiled by default. If you wish to compile these modules, you must use the -Duse_deprecated_io CPP flag or the --enable-deprecated-io configure option if building with autotools. + +### Tag Commit Hashes +- 2023.02-beta1 2be8aa452ad3e5f43e92c38a64f12d1ae6c43fb8 +- 2023.02-alpha3 8c73bd18dc1d580f2ee524c37cf903ff54d40501 +- 2023.02-alpha2 783019fdec89a8db2b26247c2f63d4782e1495c0 +- 2023.02-alpga1 419c66be31f82ebb13a91ea5e837c707eb54473b + + ## [2023.01.01] - 2023-06-06 ### Changed - FMS2_IO: Performance changes for domain_reads_2d and domain_reads_3d: diff --git a/CMakeLists.txt b/CMakeLists.txt index b2db09eace..ff75d3cf90 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ set(CMAKE_Fortran_FLAGS_DEBUG) # Define the CMake project project(FMS - VERSION 2023.01.0 + VERSION 2023.02.0 DESCRIPTION "GFDL FMS Library" HOMEPAGE_URL "https://www.gfdl.noaa.gov/fms" LANGUAGES C Fortran) diff --git a/configure.ac b/configure.ac index 82588b6c84..f7f0fea4aa 100644 --- a/configure.ac +++ b/configure.ac @@ -25,7 +25,7 @@ AC_PREREQ([2.69]) # Initialize with name, version, and support email address. AC_INIT([GFDL FMS Library], - [2023.01.00-dev], + [2023.02.00], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index e56820e701..db57f86562 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -28,7 +28,7 @@ lib_LTLIBRARIES = libFMS.la # These linker flags specify libtool version info. # See http://www.gnu.org/software/libtool/manual/libtool.html#Libtool-versioning # for information regarding incrementing `-version-info`. -libFMS_la_LDFLAGS = -version-info 15:0:0 +libFMS_la_LDFLAGS = -version-info 16:0:0 # Add the convenience libraries to the FMS library. libFMS_la_LIBADD = $(top_builddir)/platform/libplatform.la From c9824565cef3dfa298fb12305f0f317ed60b5169 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 28 Jul 2023 10:51:08 -0400 Subject: [PATCH 028/394] chore: append dev to version number post-release (#1308) --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index f7f0fea4aa..74aac31cde 100644 --- a/configure.ac +++ b/configure.ac @@ -25,7 +25,7 @@ AC_PREREQ([2.69]) # Initialize with name, version, and support email address. AC_INIT([GFDL FMS Library], - [2023.02.00], + [2023.02.00-dev], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) From 0efc2e5c57d080d16fb3e076e9edc21a860992fa Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 28 Jul 2023 11:58:26 -0400 Subject: [PATCH 029/394] CI: update gnu image and add dockerfile (#1206) --- .github/workflows/Dockerfile.gnu | 68 +++++++++++++++++++ .github/workflows/build_ubuntu_gnu.yml | 37 ---------- .github/workflows/github_autotools_gnu.yml | 39 +++++++++++ ...ntel_pr.yml => github_autotools_intel.yml} | 0 ...ild_cmake_gnu.yml => github_cmake_gnu.yml} | 0 .../{coupler.yml => github_coupler_gnu.yml} | 0 .../{update_docs.yml => github_doc_site.yml} | 0 .../{lint_fms.yml => github_linter.yml} | 0 ...el_tag.yml => parallelworks_am4_intel.yml} | 0 .github/workflows/spack.env | 17 +++++ .github/workflows/version.yml | 4 +- CI.md | 22 +++--- 12 files changed, 141 insertions(+), 46 deletions(-) create mode 100644 .github/workflows/Dockerfile.gnu delete mode 100644 .github/workflows/build_ubuntu_gnu.yml create mode 100644 .github/workflows/github_autotools_gnu.yml rename .github/workflows/{intel_pr.yml => github_autotools_intel.yml} (100%) rename .github/workflows/{build_cmake_gnu.yml => github_cmake_gnu.yml} (100%) rename .github/workflows/{coupler.yml => github_coupler_gnu.yml} (100%) rename .github/workflows/{update_docs.yml => github_doc_site.yml} (100%) rename .github/workflows/{lint_fms.yml => github_linter.yml} (100%) rename .github/workflows/{am4_regression_parallelWorks_intel_tag.yml => parallelworks_am4_intel.yml} (100%) create mode 100644 .github/workflows/spack.env diff --git a/.github/workflows/Dockerfile.gnu b/.github/workflows/Dockerfile.gnu new file mode 100644 index 0000000000..3506c2b9ee --- /dev/null +++ b/.github/workflows/Dockerfile.gnu @@ -0,0 +1,68 @@ +#*********************************************************************** +#* 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 . +#*********************************************************************** +# FMS CI image recipefile for GNU +# Runs on centos stream (builder has same base from redhat registry) +# +# arguments to specify versions to build can be given to docker or changed here (--build-arg name=val) +FROM spack/rockylinux9:latest as builder + +ARG gcc_version=12.3.0 +ARG netcdfc_version=4.9.0 +ARG netcdff_version=4.6.0 +ARG libyaml_version=0.2.5 +ARG mpich_version=4.0.2 + +COPY spack.env /opt/deps/spack.env + +# perl's download kept timing out +RUN sed -i 's/connect_timeout: 10/connect_timeout: 600/' /opt/spack/etc/spack/defaults/config.yaml && \ + spack install gcc@${gcc_version} && \ + source /opt/spack/share/spack/setup-env.sh && \ + spack load gcc@${gcc_version} && \ + spack compiler find && \ + sed "s/COMPILER/gcc@$gcc_version/" /opt/deps/spack.env > spack.yaml && \ + sed -i "s/NETCDF_C_VERSION/$netcdfc_version/" spack.yaml && \ + sed -i "s/NETCDF_F_VERSION/$netcdff_version/" spack.yaml && \ + sed -i "s/LIBYAML_VERSION/$libyaml_version/" spack.yaml && \ + sed -i "s/MPI_LIB/mpich@$mpich_version/" spack.yaml && \ + spack env activate -d . && \ + spack -e . concretize -f > /opt/deps/deps.log && \ + spack install --fail-fast + +# copy built software to base from first image +FROM rockylinux:9 + +COPY --from=builder /opt/view/ /opt/view/ +COPY --from=builder /opt/deps/ /opt/deps/ + +# input files used with --enable-input-tests +# need to be on the dev boxes if building +COPY ./fms_test_input /home/unit_tests_input + +RUN dnf install -y autoconf make automake m4 libtool pkg-config zip + +ENV FC="mpifort" +ENV CC="mpicc" +ENV MPICH_FC="/opt/view/bin/gfortran" +ENV MPICH_CC="/opt/view/bin/gcc" +ENV FCFLAGS="-I/opt/view/include" +ENV CFLAGS="-I/opt/view/include" +ENV LDFLAGS="-L/opt/view/lib" +ENV LD_LIBRARY_PATH="/opt/view/lib:/opt/view/lib64:/usr/local/lib:/usr/local/lib64" +ENV PATH="/opt/view/bin:/usr/local/bin:/usr/bin:/usr/local/sbin:/usr/sbin" diff --git a/.github/workflows/build_ubuntu_gnu.yml b/.github/workflows/build_ubuntu_gnu.yml deleted file mode 100644 index 7c53895b15..0000000000 --- a/.github/workflows/build_ubuntu_gnu.yml +++ /dev/null @@ -1,37 +0,0 @@ -name: Build libFMS test with autotools - -on: [push, pull_request] - -jobs: - build: - runs-on: ubuntu-latest - defaults: - run: - shell: bash - strategy: - matrix: - conf-flags: [--disable-openmp, --enable-mixed-mode, --disable-setting-flags, --with-mpi=no] - input-flag: [--with-yaml, --enable-test-input=/home/unit_tests_input] - io-flag: [ --enable-deprecated-io, --disable-deprecated-io] - container: - image: noaagfdl/hpc-me.ubuntu-minimal:gnu-input - env: - TEST_VERBOSE: 1 - DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flags }} ${{ matrix.input-flag }} ${{ matrix.io-flag }}" - steps: - - name: Checkout code - uses: actions/checkout@v2 - - name: Prepare GNU autoconf for build - run: autoreconf -if - - name: Configure the build - if: ${{ matrix.conf-flags != '--disable-setting-flags' }} - run: ./configure ${DISTCHECK_CONFIGURE_FLAGS} || cat config.log - - name: Configure the build with compiler flags - if: ${{ matrix.conf-flags == '--disable-setting-flags' }} - run: ./configure ${DISTCHECK_CONFIGURE_FLAGS} FCFLAGS="-fdefault-real-8 -fdefault-double-8 -fcray-pointer -ffree-line-length-none -I/usr/include $FCFLAGS" || cat config.log - - name: Build the library - run: make distcheck - if: ${{ matrix.conf-flags != '--with-mpi=no' }} - - name: Build the library (without test suite for serial build) - run: make - if: ${{ matrix.conf-flags == '--with-mpi=no' }} diff --git a/.github/workflows/github_autotools_gnu.yml b/.github/workflows/github_autotools_gnu.yml new file mode 100644 index 0000000000..d25f440959 --- /dev/null +++ b/.github/workflows/github_autotools_gnu.yml @@ -0,0 +1,39 @@ +# 'main' required ci, does a distcheck (builds, tests, check install) +# image created off dockerfile in repo, compile/link flags are set there +name: Build libFMS test with autotools + +on: [push, pull_request] + +jobs: + build: + runs-on: ubuntu-latest + strategy: + matrix: + conf-flag: [ --disable-openmp, --enable-mixed-mode, --disable-setting-flags, --with-mpi=no] + input-flag: [--with-yaml, --enable-test-input=/home/unit_tests_input] + exclude: + - conf-flag: --with-mpi=no + input-flag: --enable-test-input=/home/unit_tests_input + container: + image: noaagfdl/fms-ci-rocky-gnu:12.3.0 + env: + TEST_VERBOSE: 1 + DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flag }} ${{ matrix.input-flag }} ${{ matrix.io-flag }}" + SKIP_TESTS: "test_mpp_domains2.14 test_horiz_interp2.9 test_horiz_interp2.10 test_yaml_parser.5" # temporary till fixes are in + steps: + - name: Checkout code + uses: actions/checkout@v2 + - name: Prepare GNU autoconf for build + run: autoreconf -if + - name: Configure the build + if: ${{ matrix.conf-flag != '--disable-setting-flags' }} + run: ./configure ${DISTCHECK_CONFIGURE_FLAGS} || cat config.log + - name: Configure the build with compiler flags + if: ${{ matrix.conf-flag == '--disable-setting-flags' }} + run: ./configure ${DISTCHECK_CONFIGURE_FLAGS} FCFLAGS="-fdefault-real-8 -fdefault-double-8 -fcray-pointer -ffree-line-length-none -I/usr/include $FCFLAGS" || cat config.log + - name: Build the library + run: make distcheck + if: ${{ matrix.conf-flag != '--with-mpi=no' }} + - name: Build the library (without test suite for serial build) + run: make + if: ${{ matrix.conf-flag == '--with-mpi=no' }} diff --git a/.github/workflows/intel_pr.yml b/.github/workflows/github_autotools_intel.yml similarity index 100% rename from .github/workflows/intel_pr.yml rename to .github/workflows/github_autotools_intel.yml diff --git a/.github/workflows/build_cmake_gnu.yml b/.github/workflows/github_cmake_gnu.yml similarity index 100% rename from .github/workflows/build_cmake_gnu.yml rename to .github/workflows/github_cmake_gnu.yml diff --git a/.github/workflows/coupler.yml b/.github/workflows/github_coupler_gnu.yml similarity index 100% rename from .github/workflows/coupler.yml rename to .github/workflows/github_coupler_gnu.yml diff --git a/.github/workflows/update_docs.yml b/.github/workflows/github_doc_site.yml similarity index 100% rename from .github/workflows/update_docs.yml rename to .github/workflows/github_doc_site.yml diff --git a/.github/workflows/lint_fms.yml b/.github/workflows/github_linter.yml similarity index 100% rename from .github/workflows/lint_fms.yml rename to .github/workflows/github_linter.yml diff --git a/.github/workflows/am4_regression_parallelWorks_intel_tag.yml b/.github/workflows/parallelworks_am4_intel.yml similarity index 100% rename from .github/workflows/am4_regression_parallelWorks_intel_tag.yml rename to .github/workflows/parallelworks_am4_intel.yml diff --git a/.github/workflows/spack.env b/.github/workflows/spack.env new file mode 100644 index 0000000000..69a3bdcbd0 --- /dev/null +++ b/.github/workflows/spack.env @@ -0,0 +1,17 @@ +# template for spack environment yaml +# uppercase words get replaced before activating +spack: + specs: + - COMPILER + - MPI_LIB + - netcdf-c@NETCDF_C_VERSION ^MPI_LIB + - netcdf-fortran@NETCDF_F_VERSION + - libyaml@LIBYAML_VERSION + concretizer: + unify: true + packages: + all: + compiler: [ COMPILER ] + config: + install_tree: /opt/deps + view: /opt/view diff --git a/.github/workflows/version.yml b/.github/workflows/version.yml index 1e71236386..31641aea69 100644 --- a/.github/workflows/version.yml +++ b/.github/workflows/version.yml @@ -1,3 +1,5 @@ +# appends -dev to the version upon release and opens pr +# CI won't run on generated PR, easiest workaround is to close + reopen on: release: types: [published] @@ -16,4 +18,4 @@ jobs: branch-suffix: timestamp # add a timestamp to branch name delete-branch: true # delete afer merge title: Append dev to version number post-release - body: automated change, adds '-dev' to the version number upon releases + body: automated change, adds '-dev' to the version number upon releases. This PR will need to be closed and reopened to run CI testing. diff --git a/CI.md b/CI.md index 225b25129b..89b4db256e 100644 --- a/CI.md +++ b/CI.md @@ -8,24 +8,30 @@ Required CI for pull requests are listed first. ## Pull Request CI and checks ### Build libFMS with autotools + Required GNU build test for all pull requests/pushes. Runs `make distcheck` after configuring via GNU autotools. +Runs on a container image with spack installed dependencies, on top a rocky linux base. + +Dockerfile for image is stored at .github/workflows/Dockerfile.gnu for more specific information on the CI environment. + Container environment: -gcc v7.3.0 -mpich v3.3a2 -netcdf v4.6.0 -netcdf-fortran v4.4.4 +gcc v12.3.0 +mpich v4.0.2 +netcdf v4.9.0 +netcdf-fortran v4.6.0 autoconf v2.69 +libyaml v0.2.5 -container hosted at [noaagfdl/ubuntu_libfms_gnu:latest](https://hub.docker.com/r/noaagfdl/ubuntu_libfms_gnu) - -`./configure` flags: -- `--enable-openmp` +`./configure` flags tested: - `--disable-openmp` - `--enable-mixed-mode` +- `--with-mpi=no` (disables unit testing) - `--disable-setting-flags` - `--with-yaml` +- `--enable-test-input=/home/unit_tests_input` + ### Build libfms with cmake Required GNU build test for all pull requests/pushes. From 6b699a1526e696c4327fab8a39df584bd6b5c723 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti <60401591+laurenchilutti@users.noreply.github.com> Date: Fri, 4 Aug 2023 15:11:46 -0400 Subject: [PATCH 030/394] fix: test_read_input_nml2 failure and test_diag_update_buffer.F90 seg fault with Cray (#1302) --- test_fms/diag_manager/test_diag_manager2.sh | 4 +++- test_fms/diag_manager/test_diag_update_buffer.F90 | 8 ++++---- test_fms/mpp/test_read_input_nml.F90 | 2 +- test_fms/mpp/test_read_input_nml2.sh | 4 ++-- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 747be8e691..a625db4d1e 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -460,6 +460,7 @@ test_expect_success "Unstructured grid (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' +my_test_count=24 # test_diag_manager_time cat <<_EOF > diag_table test_diag_manager @@ -478,6 +479,7 @@ test_diag_manager "test_diag_manager_mod", "sst", "sst", "ocn_end%4yr%2mo%2dy%2hr", "all", .true., "none", 2 _EOF +my_test_count=25 rm -f input.nml && touch input.nml test_expect_success "wildcard filenames (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time @@ -501,7 +503,7 @@ test_expect_success "diurnal test (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time ' setup_test -my_test_count=`expr $my_test_count + 1` +my_test_count=26 test_expect_success "Test the diag update_buffer (test $my_test_count)" ' mpirun -n 1 ../test_diag_update_buffer ' diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 67de3ec665..9ca4f93198 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -282,12 +282,12 @@ SUBROUTINE init_field_values (field) DO k = 1, NZ DO j = 1, NY DO i = 1, NX + itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) SELECT TYPE ( field) TYPE IS (real(kind=r4_kind)) - itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) - field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) -1 TYPE IS (integer(kind=i8_kind)) - field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + field(i,j,k,l) = real(itemp, kind=r4_kind) + TYPE IS (integer(kind=i8_kind)) + field(i,j,k,l) = int(itemp, kind=i8_kind) END SELECT END DO END DO diff --git a/test_fms/mpp/test_read_input_nml.F90 b/test_fms/mpp/test_read_input_nml.F90 index 15e6e4697b..9a28e601fe 100644 --- a/test_fms/mpp/test_read_input_nml.F90 +++ b/test_fms/mpp/test_read_input_nml.F90 @@ -68,7 +68,7 @@ program test_read_input_nml n = 1 do read(1, '(A)', iostat=stat) line - if (stat.eq.-1) then + if (is_iostat_end(stat)) then exit end if if (input_nml_file(n).ne.line) then diff --git a/test_fms/mpp/test_read_input_nml2.sh b/test_fms/mpp/test_read_input_nml2.sh index 5750f641b9..5eb411429b 100755 --- a/test_fms/mpp/test_read_input_nml2.sh +++ b/test_fms/mpp/test_read_input_nml2.sh @@ -31,11 +31,11 @@ # create and enter directory for in/output output_dir -touch input.nml touch test_numb_base.nml echo "&test_read_input_nml_nml" > test_numb_base.nml echo "test_numb = 0" >> test_numb_base.nml echo "/" >> test_numb_base.nml +cp test_numb_base.nml input.nml # Test 1 sed "s/test_numb = [0-9]/test_numb = 1/" test_numb_base.nml > test_numb.nml @@ -45,7 +45,7 @@ test_expect_success "read input nml" ' # Test 2 sed "s/test_numb = [0-9]/test_numb = 2/" test_numb_base.nml > test_numb.nml -sed "s/1/2/" $top_srcdir/test_fms/mpp/input_base.nml > input_alternative.nml +cp input.nml input_alternative.nml test_expect_success "read input nml with file name" ' mpirun -n 1 ../test_read_input_nml ' From db92c30d0987fc6e618ed39e25d9d87ca9c44cf4 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti <60401591+laurenchilutti@users.noreply.github.com> Date: Fri, 4 Aug 2023 15:13:06 -0400 Subject: [PATCH 031/394] fix: initialize nest_level pointer in the nest_domain_type declaration to null (#1294) --- mpp/mpp_domains.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpp/mpp_domains.F90 b/mpp/mpp_domains.F90 index b2ccf3540f..02db652bc3 100644 --- a/mpp/mpp_domains.F90 +++ b/mpp/mpp_domains.F90 @@ -452,7 +452,7 @@ module mpp_domains_mod type :: nest_domain_type character(len=NAME_LENGTH) :: name integer :: num_level - integer, pointer :: nest_level(:) !< Added for moving nest functionality + integer, pointer :: nest_level(:) => NULL() !< Added for moving nest functionality type(nest_level_type), pointer :: nest(:) => NULL() integer :: num_nest integer, pointer :: tile_fine(:), tile_coarse(:) From a0e2128f7f54fdff3f8b4d988b6e1ad672c1f442 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Fri, 4 Aug 2023 15:14:21 -0400 Subject: [PATCH 032/394] fix: sat_vapor_pres test failure with Cray (#1299) --- test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 b/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 index a05fc9811c..7d3ae2d834 100644 --- a/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 +++ b/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 @@ -52,8 +52,8 @@ program test_sat_vap_pressure real(r8_kind), dimension(:), allocatable :: TABLE, DTABLE, TABLE2, DTABLE2, TABLE3, DTABLE3 integer :: io, N -integer, parameter :: nml_unit_var=100 -character(100) :: nml_file +integer :: nml_unit_var +character(*), parameter :: nml_file = 'test_sat_vapor_pres.nml' logical :: test1, test2, test3, test4, test5 NAMELIST / test_sat_vapor_pres_nml/ test1, test2, test3, test4, test5 @@ -64,8 +64,7 @@ program test_sat_vap_pressure call sat_vapor_pres_init() !> compute tables to be used for testing call compute_tables() !> compute tables to generate answers/reference values -nml_file='test_sat_vapor_pres.nml' -open(unit=nml_unit_var, file=trim(nml_file), action='read') +open(newunit=nml_unit_var, file=nml_file, action='read') read(unit=nml_unit_var, nml=test_sat_vapor_pres_nml,iostat=io) close(nml_unit_var) From a13de5b2da49d8ceb8ab2005f61ce43f44ad745b Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 4 Aug 2023 15:15:22 -0400 Subject: [PATCH 033/394] fix: initialize logicals in horiz_interp_type declaration (#1283) --- horiz_interp/horiz_interp_type.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/horiz_interp/horiz_interp_type.F90 b/horiz_interp/horiz_interp_type.F90 index ec2773f860..7f8b300a99 100644 --- a/horiz_interp/horiz_interp_type.F90 +++ b/horiz_interp/horiz_interp_type.F90 @@ -81,7 +81,7 @@ module horiz_interp_type_mod real(kind=r8_kind), dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. real(kind=r8_kind), dimension(:,:), allocatable :: mask_in real(kind=r8_kind) :: max_src_dist - logical :: is_allocated !< set to true upon field allocation + logical :: is_allocated = .false. !< set to true upon field allocation end type horizInterpReals8_type @@ -108,7 +108,7 @@ module horiz_interp_type_mod real(kind=r4_kind), dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. real(kind=r4_kind), dimension(:,:), allocatable :: mask_in real(kind=r4_kind) :: max_src_dist - logical :: is_allocated !< set to true upon field allocation + logical :: is_allocated = .false. !< set to true upon field allocation end type horizInterpReals4_type From 01d73fb33e2931679186a782276a483cb5da9328 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti <60401591+laurenchilutti@users.noreply.github.com> Date: Tue, 8 Aug 2023 11:23:09 -0400 Subject: [PATCH 034/394] fix: mpp_check_field fix for test_mpp_domains2 (#1292) --- mpp/include/mpp_domains_misc.inc | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/mpp/include/mpp_domains_misc.inc b/mpp/include/mpp_domains_misc.inc index 683ffd18a2..2c8de69237 100644 --- a/mpp/include/mpp_domains_misc.inc +++ b/mpp/include/mpp_domains_misc.inc @@ -419,6 +419,13 @@ end subroutine init_nonblock_type field2(isd:ied, jsd:jed) = field_in(:,:) endif +! allocate field1 on pelist1 +! if field1 is left unallocated, the code will try to access unallocated memory +! when field1 is set to 0 in mpp_redistribute + if(any(pelist1 == pe)) then + allocate(field1(1,1)) + endif + ! broadcast domain call mpp_broadcast_domain(domain1) call mpp_broadcast_domain(domain2) @@ -443,6 +450,8 @@ end subroutine init_nonblock_type if(any(pelist2 == pe)) deallocate(field1, field2) + if(any(pelist1 == pe)) deallocate(field1) + call mpp_sync() return From 5326fd97e189f643f4725635fea504df11e151a7 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti <60401591+laurenchilutti@users.noreply.github.com> Date: Wed, 16 Aug 2023 14:58:58 -0400 Subject: [PATCH 035/394] fix: unallocated variable access in test_mpp_nesting (#1336) --- test_fms/mpp/test_mpp_nesting.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/test_fms/mpp/test_mpp_nesting.F90 b/test_fms/mpp/test_mpp_nesting.F90 index 833c580bf5..8808f0e9c8 100644 --- a/test_fms/mpp/test_mpp_nesting.F90 +++ b/test_fms/mpp/test_mpp_nesting.F90 @@ -950,15 +950,15 @@ subroutine test_update_nest_domain_r8( type ) !--- loop over nest level do l = 1, num_nest_level npes_my_level = mpp_get_nest_npes(nest_domain, l) - npes_my_fine = mpp_get_nest_fine_npes(nest_domain,l) allocate(my_pelist(npes_my_level)) - allocate(my_pelist_fine(npes_my_fine)) call mpp_get_nest_pelist(nest_domain, l, my_pelist) call mpp_declare_pelist(my_pelist(:)) write(type2, '(a,I2)')trim(type)//" nest_level = ",l if(ANY(my_pelist(:)==mpp_pe())) then + npes_my_fine = mpp_get_nest_fine_npes(nest_domain,l) + allocate(my_pelist_fine(npes_my_fine)) call mpp_get_nest_fine_pelist(nest_domain, l, my_pelist_fine) call mpp_set_current_pelist(my_pelist) @@ -2625,7 +2625,8 @@ subroutine test_update_nest_domain_r8( type ) deallocate(wbuffery2, ebuffery2, sbuffery2, nbuffery2) endif endif - deallocate(my_pelist, my_pelist_fine) + if(ANY(my_pelist(:)==mpp_pe())) deallocate(my_pelist_fine) + deallocate(my_pelist) call mpp_set_current_pelist() enddo @@ -2984,15 +2985,15 @@ subroutine test_update_nest_domain_r4( type ) !--- loop over nest level do l = 1, num_nest_level npes_my_level = mpp_get_nest_npes(nest_domain, l) - npes_my_fine = mpp_get_nest_fine_npes(nest_domain,l) allocate(my_pelist(npes_my_level)) - allocate(my_pelist_fine(npes_my_fine)) call mpp_get_nest_pelist(nest_domain, l, my_pelist) call mpp_declare_pelist(my_pelist(:)) write(type2, '(a,I2)')trim(type)//" nest_level = ",l if(ANY(my_pelist(:) == mpp_pe())) then + npes_my_fine = mpp_get_nest_fine_npes(nest_domain,l) + allocate(my_pelist_fine(npes_my_fine)) call mpp_get_nest_fine_pelist(nest_domain, l, my_pelist_fine) call mpp_set_current_pelist(my_pelist) @@ -4655,7 +4656,8 @@ subroutine test_update_nest_domain_r4( type ) endif endif - deallocate(my_pelist, my_pelist_fine) + if(ANY(my_pelist(:)==mpp_pe())) deallocate(my_pelist_fine) + deallocate(my_pelist) call mpp_set_current_pelist() enddo From e1543156298eca64ef677b9d3497e7fc6a3e86ff Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 17 Aug 2023 11:02:32 -0400 Subject: [PATCH 036/394] fix: mpp_clock test failures (#1338) --- .github/workflows/github_autotools_gnu.yml | 2 +- test_fms/mpp/test_mpp_clock_begin_end_id.sh | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/github_autotools_gnu.yml b/.github/workflows/github_autotools_gnu.yml index d25f440959..b7008a0814 100644 --- a/.github/workflows/github_autotools_gnu.yml +++ b/.github/workflows/github_autotools_gnu.yml @@ -19,7 +19,7 @@ jobs: env: TEST_VERBOSE: 1 DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flag }} ${{ matrix.input-flag }} ${{ matrix.io-flag }}" - SKIP_TESTS: "test_mpp_domains2.14 test_horiz_interp2.9 test_horiz_interp2.10 test_yaml_parser.5" # temporary till fixes are in + SKIP_TESTS: "test_yaml_parser.5" # temporary till fixes are in steps: - name: Checkout code uses: actions/checkout@v2 diff --git a/test_fms/mpp/test_mpp_clock_begin_end_id.sh b/test_fms/mpp/test_mpp_clock_begin_end_id.sh index 39e5f3ffee..beeeb287e1 100755 --- a/test_fms/mpp/test_mpp_clock_begin_end_id.sh +++ b/test_fms/mpp/test_mpp_clock_begin_end_id.sh @@ -26,6 +26,7 @@ # Set common test settings. . ../test-lib.sh +touch input.nml touch clock.nml echo "&test_mpp_clock_begin_end_id_nml" > clock.nml echo "test_number = 0" >> clock.nml From 8d75797ded3faca28fb450558e5898a1e53d9dbe Mon Sep 17 00:00:00 2001 From: Lauren Chilutti <60401591+laurenchilutti@users.noreply.github.com> Date: Thu, 17 Aug 2023 12:25:41 -0400 Subject: [PATCH 037/394] fix: replacing cray pointers with fortran pointers in mpp_scatter and gather (#1312) --- fms2_io/include/compressed_write.inc | 24 ++++++++--------- mpp/include/mpp_gather.fh | 29 ++++++++++++--------- mpp/include/mpp_scatter.fh | 19 ++++++++------ test_fms/fms2_io/test_bc_restart.sh | 2 +- test_fms/fms2_io/test_compressed_writes.F90 | 8 +++--- test_fms/fms2_io/test_domain_io.F90 | 14 +++++----- 6 files changed, 51 insertions(+), 45 deletions(-) diff --git a/fms2_io/include/compressed_write.inc b/fms2_io/include/compressed_write.inc index cd2919c162..e284a0892a 100644 --- a/fms2_io/include/compressed_write.inc +++ b/fms2_io/include/compressed_write.inc @@ -144,22 +144,22 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, & type is (integer(kind=i4_kind)) call mpp_gather(cdata, size(cdata), buf_i4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & unlim_dim_level=unlim_dim_level) type is (integer(kind=i8_kind)) call mpp_gather(cdata, size(cdata), buf_i8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r4_kind)) call mpp_gather(cdata, size(cdata), buf_r4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r8_kind)) call mpp_gather(cdata, size(cdata), buf_r8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & fileobj%pelist) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & unlim_dim_level=unlim_dim_level) class default call error("unsupported variable type: "//trim(append_error_msg)) @@ -266,19 +266,19 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, & select type(cdata) type is (integer(kind=i4_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & unlim_dim_level=unlim_dim_level) type is (integer(kind=i8_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r4_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r8_kind)) call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & unlim_dim_level=unlim_dim_level) class default call error("unsupported variable type: "//trim(append_error_msg)) @@ -391,22 +391,22 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, & type is (integer(kind=i4_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & unlim_dim_level=unlim_dim_level) type is (integer(kind=i8_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r4_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & unlim_dim_level=unlim_dim_level) type is (real(kind=r8_kind)) call mpp_gather(is, ie, js, je, size(cdata,3), & fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + if (fileobj%is_root) call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & unlim_dim_level=unlim_dim_level) class default call error("unsupported variable type: "//trim(append_error_msg)) diff --git a/mpp/include/mpp_gather.fh b/mpp/include/mpp_gather.fh index 17b09c0312..8ead643f3a 100644 --- a/mpp/include/mpp_gather.fh +++ b/mpp/include/mpp_gather.fh @@ -111,19 +111,22 @@ end subroutine MPP_GATHER_1DV_ subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_root_pe, & ishift, jshift) - integer, intent(in) :: is, ie, js, je - integer, dimension(:), intent(in) :: pelist - MPP_TYPE_, dimension(is:ie,js:je), intent(in) :: array_seg - MPP_TYPE_, dimension(:,:), intent(inout) :: data - logical, intent(in) :: is_root_pe - integer, optional, intent(in) :: ishift, jshift - - MPP_TYPE_ :: arr3D(size(array_seg,1),size(array_seg,2),1) - MPP_TYPE_ :: data3D(size( data,1),size( data,2),1) - pointer( aptr, arr3D ) - pointer( dptr, data3D ) - aptr = LOC(array_seg) - dptr = LOC( data) + integer, intent(in) :: is, ie, js, je + integer, dimension(:), intent(in) :: pelist + MPP_TYPE_, dimension(is:ie,js:je), target, intent(in) :: array_seg + MPP_TYPE_, dimension(:,:), contiguous, target, intent(inout) :: data + logical, intent(in) :: is_root_pe + integer, optional, intent(in) :: ishift, jshift + + MPP_TYPE_, pointer :: arr3D(:,:,:) + MPP_TYPE_, pointer :: data3D(:,:,:) + + arr3D(1:size(array_seg,1),1:size(array_seg,2),1:1) => array_seg + if (is_root_pe) then + data3D(1:size(data,1),1:size(data,2),1:1) => data + else + data3D => null() + endif call mpp_gather(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) diff --git a/mpp/include/mpp_scatter.fh b/mpp/include/mpp_scatter.fh index 4223f79c39..fce54f5a78 100644 --- a/mpp/include/mpp_scatter.fh +++ b/mpp/include/mpp_scatter.fh @@ -29,17 +29,20 @@ subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_ro integer, intent(in) :: is, ie, js, je !< indices of segment array integer, dimension(:), intent(in) :: pelist ! array_seg + if (is_root_pe) then + data3D(1:size(data,1),1:size(data,2),1:1) => data + else + data3D => null() + endif call mpp_scatter(is, ie, js, je, 1, pelist, arr3D, data3D, is_root_pe, & ishift, jshift) diff --git a/test_fms/fms2_io/test_bc_restart.sh b/test_fms/fms2_io/test_bc_restart.sh index 07b0081c8f..faac53e0cb 100755 --- a/test_fms/fms2_io/test_bc_restart.sh +++ b/test_fms/fms2_io/test_bc_restart.sh @@ -43,7 +43,7 @@ test_expect_failure "bad checksum" ' ' # run test 3 - test for ignoring a bad checksum -printf "&test_bc_restart_nml\n bad_checksum=.true.\n ignore_checksum=.true./" | cat > input.nml +printf "&test_bc_restart_nml\n bad_checksum=.true.\n ignore_checksum=.true.\n /" | cat > input.nml test_expect_success "ignore bad checksum" ' mpirun -n 16 ../test_bc_restart ' diff --git a/test_fms/fms2_io/test_compressed_writes.F90 b/test_fms/fms2_io/test_compressed_writes.F90 index b905be70d7..38d44f6392 100644 --- a/test_fms/fms2_io/test_compressed_writes.F90 +++ b/test_fms/fms2_io/test_compressed_writes.F90 @@ -112,10 +112,10 @@ subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim) character(len=*), intent(in) :: dimension_names(:) !< dimension names integer, intent(in) :: ndim !< Number of dimension - call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i8", "int64", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i4", "int", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r8", "double", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int64", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int", dimension_names(1:ndim)) end subroutine register_field_wrapper !> @brief Allocates the variable to be the size of data compute domain for x and y diff --git a/test_fms/fms2_io/test_domain_io.F90 b/test_fms/fms2_io/test_domain_io.F90 index 07a3e2845a..5b00d8c9fe 100644 --- a/test_fms/fms2_io/test_domain_io.F90 +++ b/test_fms/fms2_io/test_domain_io.F90 @@ -46,7 +46,7 @@ program test_domain_read integer :: xhalo = 3 !< Number of halo points in X integer :: yhalo = 2 !< Number of halo points in Y integer :: nz = 2 !< Number of points in the z dimension - character(len=20) :: filename="test.nc" !< Name of the file + character(len=32) :: filename="test.nc" !< Name of the file logical :: use_edges=.false. !< Use North and East domain positions integer :: ndim4 !< Number of points in dim4 @@ -64,7 +64,7 @@ program test_domain_read namelist /test_domain_io_nml/ layout, io_layout, nx, ny, nz, mask_table, xhalo, yhalo, nz, filename, use_edges - call fms_init + call fms_init() read(input_nml_file, nml=test_domain_io_nml, iostat=io) ierr = check_nml_error(io, 'test_domain_io_nml') @@ -134,7 +134,7 @@ program test_domain_read call close_file(fileobj) endif - call fms_end + call fms_end() contains @@ -146,10 +146,10 @@ subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim) character(len=*), intent(in) :: dimension_names(:) !< dimension names integer, intent(in) :: ndim !< Number of dimension - call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i8", "int", names(1:ndim)) - call register_field(fileob, trim(var_name)//"_i4", "int64", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r8", "double", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int", dimension_names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int64", dimension_names(1:ndim)) end subroutine register_field_wrapper !> @brief Allocates the variable to be the size of data compute domain for x and y From 0fb9bd07b10b3cfc2212a6cb10c9a30e689ba47a Mon Sep 17 00:00:00 2001 From: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com> Date: Thu, 17 Aug 2023 12:28:21 -0400 Subject: [PATCH 038/394] chore!: adds ifdef use_drifters in all drifter modules (#1329) BREAKING CHANGE: Deprecates the modules in the `drifters` subdirectory. If using the modules, you must compile FMS with the `-Duse_drifters` CPP flag. --- drifters/cloud_interpolator.F90 | 2 ++ drifters/drifters.F90 | 3 ++- drifters/drifters_comm.F90 | 3 ++- drifters/drifters_core.F90 | 3 ++- drifters/drifters_input.F90 | 3 ++- drifters/drifters_io.F90 | 3 ++- test_fms/drifters/test_cloud_interpolator.F90 | 2 ++ test_fms/drifters/test_drifters.F90 | 3 ++- test_fms/drifters/test_drifters_comm.F90 | 2 ++ test_fms/drifters/test_drifters_core.F90 | 2 ++ test_fms/drifters/test_drifters_input.F90 | 2 ++ test_fms/drifters/test_drifters_io.F90 | 2 ++ test_fms/drifters/test_quicksort.F90 | 2 ++ 13 files changed, 26 insertions(+), 6 deletions(-) diff --git a/drifters/cloud_interpolator.F90 b/drifters/cloud_interpolator.F90 index f83f66274e..ef2ca004b2 100644 --- a/drifters/cloud_interpolator.F90 +++ b/drifters/cloud_interpolator.F90 @@ -25,6 +25,7 @@ !> @addtogroup cloud_interpolator_mod !> @{ MODULE cloud_interpolator_mod +#ifdef use_drifters implicit none private @@ -284,6 +285,7 @@ pure subroutine cld_ntrp_get_cell_values(nsizes, fnodes, indices, fvals, ier) end subroutine cld_ntrp_get_cell_values +#endif end MODULE cloud_interpolator_mod !=============================================================================== !> @} diff --git a/drifters/drifters.F90 b/drifters/drifters.F90 index eac1d6cbd8..2afd7068ac 100644 --- a/drifters/drifters.F90 +++ b/drifters/drifters.F90 @@ -60,6 +60,7 @@ !> @addtogroup drifters_mod !> @{ module drifters_mod +#ifdef use_drifters #ifdef _SERIAL @@ -947,7 +948,7 @@ subroutine drifters_reset_rk4(self, ermesg) endif end subroutine drifters_reset_rk4 - +#endif end module drifters_mod !> @} ! close documentation grouping diff --git a/drifters/drifters_comm.F90 b/drifters/drifters_comm.F90 index 5319e19934..e94e2a7f23 100644 --- a/drifters/drifters_comm.F90 +++ b/drifters/drifters_comm.F90 @@ -23,6 +23,7 @@ !> @brief Routines and types to update drifter positions across processor domains module drifters_comm_mod +#ifdef use_drifters #ifdef _SERIAL @@ -769,7 +770,7 @@ subroutine drifters_comm_gather(self, drfts, dinp, & end subroutine drifters_comm_gather - +#endif end module drifters_comm_mod !=============================================================================== diff --git a/drifters/drifters_core.F90 b/drifters/drifters_core.F90 index c25dd85e54..8d35d05cf4 100644 --- a/drifters/drifters_core.F90 +++ b/drifters/drifters_core.F90 @@ -21,6 +21,7 @@ !> @brief Handles the mechanics for adding and removing drifters module drifters_core_mod +#ifdef use_drifters use platform_mod implicit none private @@ -272,7 +273,7 @@ subroutine drifters_core_print(self1, ermesg1) end subroutine drifters_core_print - +#endif end module drifters_core_mod !############################################################################### !> @} diff --git a/drifters/drifters_input.F90 b/drifters/drifters_input.F90 index 0327f67053..157d12b215 100644 --- a/drifters/drifters_input.F90 +++ b/drifters/drifters_input.F90 @@ -23,6 +23,7 @@ !> @addtogroup drifters_input_mod !> @{ module drifters_input_mod +#ifdef use_drifters implicit none private @@ -444,7 +445,7 @@ subroutine drifters_input_save(self, filename, geolon, geolat, ermesg) & //nf_strerror(ier) end subroutine drifters_input_save - +#endif end module drifters_input_mod !> @} ! close documentation grouping diff --git a/drifters/drifters_io.F90 b/drifters/drifters_io.F90 index 3592da9603..e9754f4487 100644 --- a/drifters/drifters_io.F90 +++ b/drifters/drifters_io.F90 @@ -23,6 +23,7 @@ !> @addtogroup drifters_io_mod !> @{ module drifters_io_mod +#ifdef use_drifters use netcdf use netcdf_nf_data @@ -307,7 +308,7 @@ subroutine drifters_io_write(self, time, np, nd, nf, ids, positions, fields, erm self%it_id = self%it_id + np end subroutine drifters_io_write - +#endif end module drifters_io_mod !> @} ! close documentation grouping diff --git a/test_fms/drifters/test_cloud_interpolator.F90 b/test_fms/drifters/test_cloud_interpolator.F90 index e11d480587..204e5d545e 100644 --- a/test_fms/drifters/test_cloud_interpolator.F90 +++ b/test_fms/drifters/test_cloud_interpolator.F90 @@ -18,6 +18,7 @@ !*********************************************************************** program test_cloud_interpolator +#ifdef use_drifters use cloud_interpolator_mod use mpp_mod, only : mpp_error, FATAL, stdout, mpp_init, mpp_exit @@ -215,4 +216,5 @@ subroutine test_get_node_values end subroutine test_get_node_values +#endif end program test_cloud_interpolator diff --git a/test_fms/drifters/test_drifters.F90 b/test_fms/drifters/test_drifters.F90 index 0bfe4bb685..ab6cb91c89 100644 --- a/test_fms/drifters/test_drifters.F90 +++ b/test_fms/drifters/test_drifters.F90 @@ -18,6 +18,7 @@ !*********************************************************************** program test_drifters +#ifdef use_drifters !* contents of input file: drifters_inp_test_3d.nc !!$netcdf drifters_inp_test_3d { @@ -336,7 +337,7 @@ program test_drifters !#ifndef _SERIAL call mpp_exit !#endif - +#endif end program test_drifters subroutine my_error_handler(mesg) diff --git a/test_fms/drifters/test_drifters_comm.F90 b/test_fms/drifters/test_drifters_comm.F90 index 25b1e532d3..85108fa4d2 100644 --- a/test_fms/drifters/test_drifters_comm.F90 +++ b/test_fms/drifters/test_drifters_comm.F90 @@ -19,6 +19,7 @@ !********************************************************************** program test_drifters_comm +#ifdef use_drifters use drifters_core_mod use drifters_comm_mod @@ -143,4 +144,5 @@ program test_drifters_comm call mpp_domains_exit call mpp_exit +#endif end program test_drifters_comm diff --git a/test_fms/drifters/test_drifters_core.F90 b/test_fms/drifters/test_drifters_core.F90 index b2b93a5e82..51e81efc72 100644 --- a/test_fms/drifters/test_drifters_core.F90 +++ b/test_fms/drifters/test_drifters_core.F90 @@ -19,6 +19,7 @@ !********************************************************************** program test_drifters_core +#ifdef use_drifters use drifters_core_mod use fms_mod, only : fms_init, fms_end @@ -111,4 +112,5 @@ program test_drifters_core !!$ print *,'Sucessful test ier=', ier !!$ end if call fms_end() +#endif end program test_drifters_core diff --git a/test_fms/drifters/test_drifters_input.F90 b/test_fms/drifters/test_drifters_input.F90 index 64a887856d..297b751493 100644 --- a/test_fms/drifters/test_drifters_input.F90 +++ b/test_fms/drifters/test_drifters_input.F90 @@ -19,6 +19,7 @@ !*********************************************************************** program test_drifters_input +#ifdef use_drifters use drifters_input_mod use fms_mod, only : fms_init, fms_end use mpp_mod, only : mpp_error, FATAL, stdout @@ -54,4 +55,5 @@ program test_drifters_input call drifters_input_del(obj, ermesg) call fms_end() +#endif end program test_drifters_input diff --git a/test_fms/drifters/test_drifters_io.F90 b/test_fms/drifters/test_drifters_io.F90 index 989141b8f7..f74e8cb500 100644 --- a/test_fms/drifters/test_drifters_io.F90 +++ b/test_fms/drifters/test_drifters_io.F90 @@ -18,6 +18,7 @@ !*********************************************************************** program test_drifters_io +#ifdef use_drifters use drifters_io_mod use mpp_mod, only : mpp_error, FATAL, stdout, mpp_init, mpp_exit @@ -156,4 +157,5 @@ program test_drifters_io call mpp_error(FATAL, ermesg) endif call mpp_exit() +#endif end program test_drifters_io diff --git a/test_fms/drifters/test_quicksort.F90 b/test_fms/drifters/test_quicksort.F90 index 4ad7701a50..04cb268112 100644 --- a/test_fms/drifters/test_quicksort.F90 +++ b/test_fms/drifters/test_quicksort.F90 @@ -19,9 +19,11 @@ !*********************************************************************** program test_quicksort +#ifdef use_drifters implicit none integer :: list(16) = (/6, 2, 3, 4, 1, 45, 3432, 3245, 32545, 66555, 32, 1,3, -43254, 324, 54/) print *,'before list=', list call qksrt_quicksort(size(list), list, 1, size(list)) print *,'after list=', list +#endif end program test_quicksort From a46bd94fd8dd1f6f021501e29179003ff28180ec Mon Sep 17 00:00:00 2001 From: Rusty Benson <6594772+bensonr@users.noreply.github.com> Date: Thu, 17 Aug 2023 13:09:11 -0400 Subject: [PATCH 039/394] fix: cleanup of mpp::get_peset function (#1275) --- mpp/include/mpp_util_mpi.inc | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/mpp/include/mpp_util_mpi.inc b/mpp/include/mpp_util_mpi.inc index ef9443783a..7d235be83b 100644 --- a/mpp/include/mpp_util_mpi.inc +++ b/mpp/include/mpp_util_mpi.inc @@ -93,7 +93,6 @@ function get_peset(pelist) integer, intent(in), optional :: pelist(:) integer :: errunit integer :: i, n - integer, allocatable :: sorted(:) if( .NOT.PRESENT(pelist) )then !set it to current_peset_num get_peset = current_peset_num; return @@ -106,17 +105,14 @@ function get_peset(pelist) enddo endif - allocate( sorted(size(pelist(:))) ) - sorted = pelist errunit = stderr() if( debug )write( errunit,* )'pelist=', pelist !find if this array matches any existing peset do i = 1,peset_num if( debug )write( errunit,'(a,3i6)' )'pe, i, peset_num=', pe, i, peset_num - if( size(sorted(:)).EQ.size(peset(i)%list(:)) )then - if( ALL(sorted.EQ.peset(i)%list) )then - deallocate(sorted) + if( size(pelist(:)).EQ.size(peset(i)%list(:)) )then + if( ALL(pelist.EQ.peset(i)%list) )then get_peset = i; return end if end if @@ -126,14 +122,13 @@ function get_peset(pelist) if( peset_num > current_peset_max ) call expand_peset() i = peset_num !shorthand !create list - allocate( peset(i)%list(size(sorted(:))) ) - peset(i)%list(:) = sorted(:) - peset(i)%count = size(sorted(:)) + allocate( peset(i)%list(size(pelist(:))) ) + peset(i)%list(:) = pelist(:) + peset(i)%count = size(pelist(:)) - call MPI_GROUP_INCL( peset(current_peset_num)%group, size(sorted(:)), sorted-mpp_root_pe(), peset(i)%group, error ) + call MPI_GROUP_INCL( peset(current_peset_num)%group, size(pelist(:)), pelist-mpp_root_pe(), peset(i)%group, error ) call MPI_COMM_CREATE_GROUP(peset(current_peset_num)%id, peset(i)%group, & DEFAULT_TAG, peset(i)%id, error ) - deallocate(sorted) get_peset = i return From d520e5a1fd0223b0a56d6d63df09d44749b119ca Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 17 Aug 2023 15:14:01 -0400 Subject: [PATCH 040/394] ci: add io flag to intel test(#1282) --- .github/workflows/github_autotools_intel.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/github_autotools_intel.yml b/.github/workflows/github_autotools_intel.yml index 62a15361ea..851ad71520 100644 --- a/.github/workflows/github_autotools_intel.yml +++ b/.github/workflows/github_autotools_intel.yml @@ -2,13 +2,16 @@ on: pull_request jobs: intel-autotools: runs-on: ubuntu-latest + strategy: + matrix: + io-flag: ["--disable-deprecated-io", "--enable-deprecated-io"] container: image: intel/oneapi-hpckit:2023.1.0-devel-ubuntu20.04 env: CC: mpiicc FC: mpiifort CFLAGS: "-I/libs/include" - FCFLAGS: "-I/libs/include -g -traceback" + FCFLAGS: "-I/libs/include -g -traceback ${{ matrix.io-flag }}" LDFLAGS: "-L/libs/lib" TEST_VERBOSE: 1 I_MPI_FABRICS: "shm" # needed for mpi in image From 3ffc427eda66ea80eff58e4cd422eebc37f1bad6 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Wed, 23 Aug 2023 14:01:26 -0400 Subject: [PATCH 041/394] fix: remove isspace function call for parser(#1349) --- parser/yaml_output_functions.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser/yaml_output_functions.c b/parser/yaml_output_functions.c index edf381e0ea..e748a82729 100644 --- a/parser/yaml_output_functions.c +++ b/parser/yaml_output_functions.c @@ -363,7 +363,7 @@ void write_yaml_from_struct_3 (char *yamlname, int asize, struct fmsyamloutkeys // trim any trailing whitespace int ws_ind = strlen(yamlname)-1; - while(isspace(*(yamlname+ws_ind))) ws_ind--; + while(*(yamlname+ws_ind) == ' ') ws_ind--; if( ws_ind != strlen(yamlname)-1) yamlname[ws_ind+1] = '\0'; /* open the yaml output file. Only 1 core should do this */ From dd53551c20345bd902786ec84a0e37a1820b0df3 Mon Sep 17 00:00:00 2001 From: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Date: Thu, 24 Aug 2023 09:54:45 -0400 Subject: [PATCH 042/394] fix: deallocate arrays in interpolator_end (#1297) --- interpolator/interpolator.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index 843f6e7cdf..48acc46ccd 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -3423,6 +3423,8 @@ subroutine interpolator_end(clim_type) if (allocated (clim_type%field_name)) deallocate(clim_type%field_name) if (allocated (clim_type%time_init )) deallocate(clim_type%time_init) if (allocated (clim_type%mr )) deallocate(clim_type%mr) +if (allocated (clim_type%out_of_bounds )) deallocate(clim_type%out_of_bounds) +if (allocated (clim_type%vert_interp )) deallocate(clim_type%vert_interp) if (allocated (clim_type%data)) then deallocate(clim_type%data) endif @@ -3432,6 +3434,10 @@ subroutine interpolator_end(clim_type) deallocate(clim_type%nmon_nyear) deallocate(clim_type%nmon_pyear) endif +if (allocated(clim_type%indexm)) deallocate(clim_type%indexm) +if (allocated(clim_type%indexp)) deallocate(clim_type%indexp) +if (allocated(clim_type%climatology)) deallocate(clim_type%climatology) +if (allocated(clim_type%clim_times)) deallocate(clim_type%clim_times) !! RSH mod if( .not. (clim_type%TIME_FLAG .eq. LINEAR .and. & From 4b9e0e8110c6944b400af53c25cc0edd359ffeda Mon Sep 17 00:00:00 2001 From: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Date: Thu, 31 Aug 2023 13:01:02 -0400 Subject: [PATCH 043/394] feat: add assignment override in fms2_io for interpolator_type_eq (#1287) --- fms2_io/fms2_io.F90 | 1 + fms2_io/netcdf_io.F90 | 93 +++++++++++++++++++++++++++++++++++ interpolator/interpolator.F90 | 3 +- 3 files changed, 96 insertions(+), 1 deletion(-) diff --git a/fms2_io/fms2_io.F90 b/fms2_io/fms2_io.F90 index 00f6046a67..4d26b2d4a5 100644 --- a/fms2_io/fms2_io.F90 +++ b/fms2_io/fms2_io.F90 @@ -99,6 +99,7 @@ module fms2_io_mod public :: get_instance_filename public :: nullify_filename_appendix public :: flush_file +public :: assignment(=) !> @} !> @brief Opens a given netcdf or domain file. diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index b66c6f0526..27f2ace499 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -240,6 +240,7 @@ module netcdf_io_mod public :: write_restart_bc public :: read_restart_bc public :: flush_file +public :: assignment(=) !> @ingroup netcdf_io_mod interface netcdf_add_restart_variable @@ -331,6 +332,12 @@ module netcdf_io_mod module procedure is_valid_r4 end interface is_valid +!> @brief "=" operator for FmsNetcdfFile_t type +interface assignment(=) + module procedure FmsNetcdfFile_t_eq +end interface assignment(=) + + !> @addtogroup netcdf_io_mod !> @{ @@ -2357,6 +2364,92 @@ subroutine flush_file(fileobj) endif end subroutine flush_file +!> @brief "=" operator for FmsNetcdfFile_t type +subroutine FmsNetcdfFile_t_eq(FmsNetcdfFile_out, FmsNetcdfFile_in) + + type(FmsNetcdfFile_t), intent(out) :: FmsNetcdfFile_out + type(FmsNetcdfFile_t), intent(in) :: FmsNetcdfFile_in + + FmsNetcdfFile_out%path = FmsNetcdfFile_in%path + FmsNetcdfFile_out%is_readonly = FmsNetcdfFile_in%is_readonly + FmsNetcdfFile_out%ncid = FmsNetcdfFile_in%ncid + FmsNetcdfFile_out%nc_format = FmsNetcdfFile_in%nc_format + FmsNetcdfFile_out%is_netcdf4 = FmsNetcdfFile_in%is_netcdf4 + if(allocated(FmsNetcdfFile_in%pelist)) FmsNetcdfFile_out%pelist = FmsNetcdfFile_in%pelist + FmsNetcdfFile_out%io_root = FmsNetcdfFile_in%io_root + FmsNetcdfFile_out%is_root = FmsNetcdfFile_in%is_root + FmsNetcdfFile_out%is_restart = FmsNetcdfFile_in%is_restart + FmsNetcdfFile_out%mode_is_append = FmsNetcdfFile_out%mode_is_append + if(allocated(FmsNetcdfFile_in%is_open)) FmsNetcdfFile_out%is_open = FmsNetcdfFile_in%is_open + FmsNetcdfFile_out%num_restart_vars = FmsNetcdfFile_in%num_restart_vars + FmsNetcdfFile_out%num_compressed_dims = FmsNetcdfFile_in%num_compressed_dims + FmsNetcdfFile_out%is_diskless = FmsNetcdfFile_in%is_diskless + FmsNetcdfFile_out%time_name = FmsNetcdfFile_in%time_name + + FmsNetcdfFile_out%bc_dimensions = dimension_information_copy(FmsNetcdfFile_in%bc_dimensions) + + if(allocated(FmsNetcdfFile_in%compressed_dims)) & + FmsNetcdfFile_out%compressed_dims = CompressedDimension_copy(FmsNetcdfFile_in%compressed_dims) + + if(allocated(FmsNetcdfFile_in%restart_vars)) then + allocate(FmsNetcdfFile_out%restart_vars(size(FmsNetcdfFile_in%restart_vars))) + call RestartVariable_copy(FmsNetcdfFile_in%restart_vars,FmsNetcdfFile_out%restart_vars) + end if + + +end subroutine FmsNetcdfFile_t_eq + +!> @brief copies the type RestartVariable_t +!! Note, RestartVariable_copy cannot be declared as an elemental function +!! due to pointer assignments +subroutine RestartVariable_copy(RestartVariable_in,RestartVariable_out) + + implicit none + type(RestartVariable_t), intent(in), dimension(:) :: RestartVariable_in + type(RestartVariable_t), intent(out), dimension(:) :: RestartVariable_out + + integer :: i + + do i=1, size(RestartVariable_in) + RestartVariable_out(i)%varname = RestartVariable_in(i)%varname + if(associated(RestartVariable_in(i)%data1d)) RestartVariable_out(i)%data1d => RestartVariable_in(i)%data1d + if(associated(RestartVariable_in(i)%data2d)) RestartVariable_out(i)%data2d => RestartVariable_in(i)%data2d + if(associated(RestartVariable_in(i)%data3d)) RestartVariable_out(i)%data3d => RestartVariable_in(i)%data3d + if(associated(RestartVariable_in(i)%data4d)) RestartVariable_out(i)%data4d => RestartVariable_in(i)%data4d + if(associated(RestartVariable_in(i)%data5d)) RestartVariable_out(i)%data5d => RestartVariable_in(i)%data5d + end do + +end subroutine RestartVariable_copy + +!> @brief copies the type CompressedDimension_t +elemental function CompressedDimension_copy(CompressedDimension_in) + + implicit none + type(CompressedDimension_t), intent(in) :: CompressedDimension_in + type(CompressedDimension_t) :: CompressedDimension_copy + + CompressedDimension_copy%dimname = CompressedDimension_in%dimname + if(allocated(CompressedDimension_copy%npes_corner)) & + CompressedDimension_copy%npes_corner = CompressedDimension_in%npes_corner + if(allocated(CompressedDimension_in%npes_nelems)) & + CompressedDimension_copy%npes_nelems = CompressedDimension_in%npes_nelems + +end function CompressedDimension_copy + +!> @brief copies the type dimension information +elemental function dimension_information_copy(dimension_information_in) + + implicit none + type(dimension_information), intent(in) :: dimension_information_in + type(dimension_information) :: dimension_information_copy + + dimension_information_copy%xlen = dimension_information_in%xlen + dimension_information_copy%ylen = dimension_information_in%ylen + dimension_information_copy%zlen = dimension_information_in%zlen + dimension_information_copy%cur_dim_len = dimension_information_in%cur_dim_len + +end function dimension_information_copy + end module netcdf_io_mod !> @} ! close documentation grouping diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index 48acc46ccd..a066a31e6e 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -52,7 +52,7 @@ module interpolator_mod get_num_variables, get_dimension_size, & get_variable_units, get_variable_names, & get_time_calendar, close_file, & - get_variable_dimension_names, get_variable_sense + get_variable_dimension_names, get_variable_sense, assignment(=) use horiz_interp_mod, only : horiz_interp_type, & horiz_interp_new, & @@ -346,6 +346,7 @@ subroutine interpolate_type_eq (Out, In) Out%interph = In%interph if (allocated(In%time_slice)) Out%time_slice = In%time_slice + Out%fileobj = In%fileobj Out%file_name = In%file_name Out%time_flag = In%time_flag Out%level_type = In%level_type From 61cc3b9fd3b6978c2e0b383cc45831e4b2745919 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 14 Sep 2023 14:13:50 -0400 Subject: [PATCH 044/394] Revert: "feat: add assignment override in fms2_io for interpolator_type_eq (#1287)" (#1360) This reverts commit 4b9e0e8110c6944b400af53c25cc0edd359ffeda. --- fms2_io/fms2_io.F90 | 1 - fms2_io/netcdf_io.F90 | 93 ----------------------------------- interpolator/interpolator.F90 | 3 +- 3 files changed, 1 insertion(+), 96 deletions(-) diff --git a/fms2_io/fms2_io.F90 b/fms2_io/fms2_io.F90 index 4d26b2d4a5..00f6046a67 100644 --- a/fms2_io/fms2_io.F90 +++ b/fms2_io/fms2_io.F90 @@ -99,7 +99,6 @@ module fms2_io_mod public :: get_instance_filename public :: nullify_filename_appendix public :: flush_file -public :: assignment(=) !> @} !> @brief Opens a given netcdf or domain file. diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 27f2ace499..b66c6f0526 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -240,7 +240,6 @@ module netcdf_io_mod public :: write_restart_bc public :: read_restart_bc public :: flush_file -public :: assignment(=) !> @ingroup netcdf_io_mod interface netcdf_add_restart_variable @@ -332,12 +331,6 @@ module netcdf_io_mod module procedure is_valid_r4 end interface is_valid -!> @brief "=" operator for FmsNetcdfFile_t type -interface assignment(=) - module procedure FmsNetcdfFile_t_eq -end interface assignment(=) - - !> @addtogroup netcdf_io_mod !> @{ @@ -2364,92 +2357,6 @@ subroutine flush_file(fileobj) endif end subroutine flush_file -!> @brief "=" operator for FmsNetcdfFile_t type -subroutine FmsNetcdfFile_t_eq(FmsNetcdfFile_out, FmsNetcdfFile_in) - - type(FmsNetcdfFile_t), intent(out) :: FmsNetcdfFile_out - type(FmsNetcdfFile_t), intent(in) :: FmsNetcdfFile_in - - FmsNetcdfFile_out%path = FmsNetcdfFile_in%path - FmsNetcdfFile_out%is_readonly = FmsNetcdfFile_in%is_readonly - FmsNetcdfFile_out%ncid = FmsNetcdfFile_in%ncid - FmsNetcdfFile_out%nc_format = FmsNetcdfFile_in%nc_format - FmsNetcdfFile_out%is_netcdf4 = FmsNetcdfFile_in%is_netcdf4 - if(allocated(FmsNetcdfFile_in%pelist)) FmsNetcdfFile_out%pelist = FmsNetcdfFile_in%pelist - FmsNetcdfFile_out%io_root = FmsNetcdfFile_in%io_root - FmsNetcdfFile_out%is_root = FmsNetcdfFile_in%is_root - FmsNetcdfFile_out%is_restart = FmsNetcdfFile_in%is_restart - FmsNetcdfFile_out%mode_is_append = FmsNetcdfFile_out%mode_is_append - if(allocated(FmsNetcdfFile_in%is_open)) FmsNetcdfFile_out%is_open = FmsNetcdfFile_in%is_open - FmsNetcdfFile_out%num_restart_vars = FmsNetcdfFile_in%num_restart_vars - FmsNetcdfFile_out%num_compressed_dims = FmsNetcdfFile_in%num_compressed_dims - FmsNetcdfFile_out%is_diskless = FmsNetcdfFile_in%is_diskless - FmsNetcdfFile_out%time_name = FmsNetcdfFile_in%time_name - - FmsNetcdfFile_out%bc_dimensions = dimension_information_copy(FmsNetcdfFile_in%bc_dimensions) - - if(allocated(FmsNetcdfFile_in%compressed_dims)) & - FmsNetcdfFile_out%compressed_dims = CompressedDimension_copy(FmsNetcdfFile_in%compressed_dims) - - if(allocated(FmsNetcdfFile_in%restart_vars)) then - allocate(FmsNetcdfFile_out%restart_vars(size(FmsNetcdfFile_in%restart_vars))) - call RestartVariable_copy(FmsNetcdfFile_in%restart_vars,FmsNetcdfFile_out%restart_vars) - end if - - -end subroutine FmsNetcdfFile_t_eq - -!> @brief copies the type RestartVariable_t -!! Note, RestartVariable_copy cannot be declared as an elemental function -!! due to pointer assignments -subroutine RestartVariable_copy(RestartVariable_in,RestartVariable_out) - - implicit none - type(RestartVariable_t), intent(in), dimension(:) :: RestartVariable_in - type(RestartVariable_t), intent(out), dimension(:) :: RestartVariable_out - - integer :: i - - do i=1, size(RestartVariable_in) - RestartVariable_out(i)%varname = RestartVariable_in(i)%varname - if(associated(RestartVariable_in(i)%data1d)) RestartVariable_out(i)%data1d => RestartVariable_in(i)%data1d - if(associated(RestartVariable_in(i)%data2d)) RestartVariable_out(i)%data2d => RestartVariable_in(i)%data2d - if(associated(RestartVariable_in(i)%data3d)) RestartVariable_out(i)%data3d => RestartVariable_in(i)%data3d - if(associated(RestartVariable_in(i)%data4d)) RestartVariable_out(i)%data4d => RestartVariable_in(i)%data4d - if(associated(RestartVariable_in(i)%data5d)) RestartVariable_out(i)%data5d => RestartVariable_in(i)%data5d - end do - -end subroutine RestartVariable_copy - -!> @brief copies the type CompressedDimension_t -elemental function CompressedDimension_copy(CompressedDimension_in) - - implicit none - type(CompressedDimension_t), intent(in) :: CompressedDimension_in - type(CompressedDimension_t) :: CompressedDimension_copy - - CompressedDimension_copy%dimname = CompressedDimension_in%dimname - if(allocated(CompressedDimension_copy%npes_corner)) & - CompressedDimension_copy%npes_corner = CompressedDimension_in%npes_corner - if(allocated(CompressedDimension_in%npes_nelems)) & - CompressedDimension_copy%npes_nelems = CompressedDimension_in%npes_nelems - -end function CompressedDimension_copy - -!> @brief copies the type dimension information -elemental function dimension_information_copy(dimension_information_in) - - implicit none - type(dimension_information), intent(in) :: dimension_information_in - type(dimension_information) :: dimension_information_copy - - dimension_information_copy%xlen = dimension_information_in%xlen - dimension_information_copy%ylen = dimension_information_in%ylen - dimension_information_copy%zlen = dimension_information_in%zlen - dimension_information_copy%cur_dim_len = dimension_information_in%cur_dim_len - -end function dimension_information_copy - end module netcdf_io_mod !> @} ! close documentation grouping diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index a066a31e6e..48acc46ccd 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -52,7 +52,7 @@ module interpolator_mod get_num_variables, get_dimension_size, & get_variable_units, get_variable_names, & get_time_calendar, close_file, & - get_variable_dimension_names, get_variable_sense, assignment(=) + get_variable_dimension_names, get_variable_sense use horiz_interp_mod, only : horiz_interp_type, & horiz_interp_new, & @@ -346,7 +346,6 @@ subroutine interpolate_type_eq (Out, In) Out%interph = In%interph if (allocated(In%time_slice)) Out%time_slice = In%time_slice - Out%fileobj = In%fileobj Out%file_name = In%file_name Out%time_flag = In%time_flag Out%level_type = In%level_type From b25a7c52a27dfd52edc10bc0ebe12776af0f03df Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Wed, 20 Sep 2023 11:37:54 -0400 Subject: [PATCH 045/394] feat: expand mixed precision support to most modules (#1366) BREAKING CHANGE: In coupler_types.F90, `coupler_nd_field_type` and `coupler_nd_values_type` have been renamed to indicate real kind value: `coupler_nd_real4/8_field_type` and `coupler_nd_real4/8_values_type`. The `bc` field within `coupler_nd_bc_type` was modified to use r8_kind within the value and field types, and an additional field added `bc_r4` to use r4_kind values. Includes: * feat: eliminate use of real numbers for mixed precision in `block_control` (#1195) * feat: mixed precision field_manager (#1205) * feat: mixed precision random_numbers_mod (#1191) * feat: mixed precision time_manager reals to r8 and clean up (#1196) * feat: mixed Precision tracer_manager (#1212) * Mixed precision monin_obukhov (#1116) * Mixed precision: `monin_obukhov` unit tests (#1272) * mixed-precision diag_integral_mod (#1217) * mixed precision time_interp (#1252) * mixed precision interpolator_mod (#1305) * Mixed precision astronomy (#1092) * Mixed precision `data_override_mod` (#1323) * mixed precision exchange (#1341) * coupler mixed precision (#1353) * Mixed precision topography_mod (#1250) --------- Co-authored-by: rem1776 Co-authored-by: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Co-authored-by: mlee03 Co-authored-by: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com> Co-authored-by: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> --- CHANGELOG.md | 2 +- CMakeLists.txt | 32 +- astronomy/Makefile.am | 13 +- astronomy/astronomy.F90 | 2425 ++-------- astronomy/include/astronomy.inc | 1595 ++++++ astronomy/include/astronomy_r4.fh | 107 + astronomy/include/astronomy_r8.fh | 107 + axis_utils/include/axis_utils2.inc | 5 - axis_utils/include/axis_utils2_r4.fh | 2 +- axis_utils/include/axis_utils2_r8.fh | 2 +- block_control/block_control.F90 | 7 +- configure.ac | 11 + coupler/Makefile.am | 8 +- coupler/atmos_ocean_fluxes.F90 | 549 ++- coupler/coupler_types.F90 | 4277 +++++++++-------- coupler/include/coupler_types.inc | 1211 +++++ coupler/include/coupler_types_r4.fh | 53 + coupler/include/coupler_types_r8.fh | 53 + data_override/Makefile.am | 10 +- data_override/data_override.F90 | 1331 +---- data_override/get_grid_version.F90 | 242 +- data_override/include/data_override.inc | 1245 +++++ data_override/include/data_override_r4.fh | 65 + data_override/include/data_override_r8.fh | 65 + data_override/include/get_grid_version.inc | 246 + data_override/include/get_grid_version_r4.fh | 33 + data_override/include/get_grid_version_r8.fh | 33 + diag_integral/Makefile.am | 12 +- diag_integral/diag_integral.F90 | 465 +- diag_integral/include/diag_integral.inc | 403 ++ diag_integral/include/diag_integral_r4.fh | 44 + diag_integral/include/diag_integral_r8.fh | 44 + exchange/stock_constants.F90 | 41 +- exchange/xgrid.F90 | 901 ++-- field_manager/Makefile.am | 30 +- field_manager/field_manager.F90 | 319 +- field_manager/fm_util.F90 | 365 +- field_manager/include/field_manager.inc | 246 + field_manager/include/field_manager_r4.fh | 40 + field_manager/include/field_manager_r8.fh | 40 + field_manager/include/fm_util.inc | 356 ++ field_manager/include/fm_util_r4.fh | 31 + field_manager/include/fm_util_r8.fh | 31 + .../include/horiz_interp_bicubic_r4.fh | 2 +- .../include/horiz_interp_bicubic_r8.fh | 2 +- .../include/horiz_interp_bilinear_r4.fh | 2 +- .../include/horiz_interp_bilinear_r8.fh | 2 +- .../include/horiz_interp_conserve_r4.fh | 2 +- .../include/horiz_interp_conserve_r8.fh | 2 +- horiz_interp/include/horiz_interp_r4.fh | 2 +- horiz_interp/include/horiz_interp_r8.fh | 2 +- .../include/horiz_interp_spherical_r4.fh | 2 +- .../include/horiz_interp_spherical_r8.fh | 2 +- horiz_interp/include/horiz_interp_type.inc | 2 +- horiz_interp/include/horiz_interp_type_r4.fh | 2 +- horiz_interp/include/horiz_interp_type_r8.fh | 2 +- interpolator/Makefile.am | 7 +- interpolator/include/interpolator.inc | 3411 +++++++++++++ interpolator/include/interpolator_r4.fh | 70 + interpolator/include/interpolator_r8.fh | 70 + interpolator/interpolator.F90 | 3527 +------------- libFMS.F90 | 18 +- m4/gx_fortran_legacy_options.m4 | 2 +- monin_obukhov/Makefile.am | 29 +- monin_obukhov/include/monin_obukhov.inc | 852 ++++ monin_obukhov/include/monin_obukhov_inter.inc | 722 +++ .../include/monin_obukhov_inter_r4.fh | 59 + .../include/monin_obukhov_inter_r8.fh | 59 + monin_obukhov/include/monin_obukhov_r4.fh | 108 + monin_obukhov/include/monin_obukhov_r8.fh | 112 + monin_obukhov/monin_obukhov.F90 | 903 +--- monin_obukhov/monin_obukhov_inter.F90 | 712 +-- platform/platform.F90 | 2 +- random_numbers/Makefile.am | 7 +- random_numbers/include/random_numbers.inc | 52 + random_numbers/include/random_numbers_r4.fh | 35 + random_numbers/include/random_numbers_r8.fh | 35 + random_numbers/mersennetwister.F90 | 14 +- random_numbers/random_numbers.F90 | 53 +- sat_vapor_pres/sat_vapor_pres_k.F90 | 2 +- test_fms/Makefile.am | 7 +- test_fms/astronomy/Makefile.am | 55 + test_fms/astronomy/test_astronomy.F90 | 284 ++ test_fms/astronomy/test_astronomy.sh | 47 + test_fms/coupler/Makefile.am | 22 +- test_fms/coupler/test_atmos_ocean_fluxes.F90 | 218 + test_fms/coupler/test_coupler.sh | 36 +- test_fms/coupler/test_coupler_2d.F90 | 127 +- test_fms/coupler/test_coupler_3d.F90 | 128 +- test_fms/coupler/test_coupler_utils.inc | 271 ++ test_fms/data_override/Makefile.am | 28 +- test_fms/data_override/test_data_override.F90 | 106 +- test_fms/data_override/test_data_override2.sh | 34 +- .../test_data_override_ongrid.F90 | 85 +- test_fms/data_override/test_get_grid_v1.F90 | 46 +- test_fms/diag_integral/Makefile.am | 49 + test_fms/diag_integral/test_diag_integral.F90 | 225 + test_fms/diag_integral/test_diag_integral2.sh | 40 + test_fms/exchange/test_xgrid.F90 | 8 +- test_fms/field_manager/Makefile.am | 11 +- test_fms/field_manager/test_field_manager.F90 | 51 +- test_fms/field_manager/test_field_manager2.sh | 6 +- test_fms/interpolator/Makefile.am | 11 +- test_fms/interpolator/test_interpolator2.F90 | 309 ++ test_fms/interpolator/test_interpolator2.sh | 9 +- .../test_interpolator_write_climatology.inc | 286 ++ test_fms/monin_obukhov/Makefile.am | 10 +- test_fms/monin_obukhov/input.r4.nml | 35 + test_fms/monin_obukhov/input.r8.nml | 17 + test_fms/monin_obukhov/test_monin_obukhov.F90 | 740 ++- test_fms/monin_obukhov/test_monin_obukhov2.sh | 20 +- test_fms/mpp/test_mpp_update_domains_main.F90 | 2 +- test_fms/random_numbers/Makefile.am | 52 + .../random_numbers/test_random_numbers.F90 | 279 ++ .../random_numbers/test_random_numbers.sh | 37 + test_fms/time_interp/Makefile.am | 15 +- test_fms/time_interp/test_time_interp.F90 | 91 +- test_fms/time_interp/test_time_interp2.sh | 32 +- .../time_interp/test_time_interp_external.F90 | 528 +- test_fms/time_manager/test_time_manager.F90 | 16 +- test_fms/tracer_manager/Makefile.am | 51 + .../tracer_manager/test_tracer_manager.F90 | 116 + .../tracer_manager/test_tracer_manager2.sh | 109 + time_interp/Makefile.am | 10 +- time_interp/include/time_interp.inc | 475 ++ time_interp/include/time_interp_external.inc | 1424 ++++++ time_interp/include/time_interp_external2.inc | 303 ++ .../include/time_interp_external2_r4.fh | 31 + .../include/time_interp_external2_r8.fh | 31 + time_interp/include/time_interp_r4.fh | 43 + time_interp/include/time_interp_r8.fh | 43 + time_interp/time_interp.F90 | 744 +-- time_interp/time_interp_external2.F90 | 880 ++-- time_manager/get_cal_time.F90 | 97 +- time_manager/time_manager.F90 | 1149 +---- topography/Makefile.am | 26 +- topography/gaussian_topog.F90 | 237 +- topography/include/gaussian_topog.inc | 148 + topography/include/gaussian_topog_r4.fh | 44 + topography/include/gaussian_topog_r8.fh | 43 + topography/include/topography.inc | 593 +++ topography/include/topography_r4.fh | 95 + topography/include/topography_r8.fh | 95 + topography/topography.F90 | 737 +-- tracer_manager/Makefile.am | 9 +- tracer_manager/include/tracer_manager.inc | 147 + tracer_manager/include/tracer_manager_r4.fh | 28 + tracer_manager/include/tracer_manager_r8.fh | 28 + tracer_manager/tracer_manager.F90 | 172 +- 149 files changed, 24296 insertions(+), 15969 deletions(-) create mode 100644 astronomy/include/astronomy.inc create mode 100644 astronomy/include/astronomy_r4.fh create mode 100644 astronomy/include/astronomy_r8.fh create mode 100644 coupler/include/coupler_types.inc create mode 100644 coupler/include/coupler_types_r4.fh create mode 100644 coupler/include/coupler_types_r8.fh create mode 100644 data_override/include/data_override.inc create mode 100644 data_override/include/data_override_r4.fh create mode 100644 data_override/include/data_override_r8.fh create mode 100644 data_override/include/get_grid_version.inc create mode 100644 data_override/include/get_grid_version_r4.fh create mode 100644 data_override/include/get_grid_version_r8.fh create mode 100644 diag_integral/include/diag_integral.inc create mode 100644 diag_integral/include/diag_integral_r4.fh create mode 100644 diag_integral/include/diag_integral_r8.fh create mode 100644 field_manager/include/field_manager.inc create mode 100644 field_manager/include/field_manager_r4.fh create mode 100644 field_manager/include/field_manager_r8.fh create mode 100644 field_manager/include/fm_util.inc create mode 100644 field_manager/include/fm_util_r4.fh create mode 100644 field_manager/include/fm_util_r8.fh create mode 100644 interpolator/include/interpolator.inc create mode 100644 interpolator/include/interpolator_r4.fh create mode 100644 interpolator/include/interpolator_r8.fh create mode 100644 monin_obukhov/include/monin_obukhov.inc create mode 100644 monin_obukhov/include/monin_obukhov_inter.inc create mode 100644 monin_obukhov/include/monin_obukhov_inter_r4.fh create mode 100644 monin_obukhov/include/monin_obukhov_inter_r8.fh create mode 100644 monin_obukhov/include/monin_obukhov_r4.fh create mode 100644 monin_obukhov/include/monin_obukhov_r8.fh create mode 100644 random_numbers/include/random_numbers.inc create mode 100644 random_numbers/include/random_numbers_r4.fh create mode 100644 random_numbers/include/random_numbers_r8.fh create mode 100644 test_fms/astronomy/Makefile.am create mode 100644 test_fms/astronomy/test_astronomy.F90 create mode 100755 test_fms/astronomy/test_astronomy.sh create mode 100644 test_fms/coupler/test_atmos_ocean_fluxes.F90 create mode 100644 test_fms/coupler/test_coupler_utils.inc create mode 100644 test_fms/diag_integral/Makefile.am create mode 100644 test_fms/diag_integral/test_diag_integral.F90 create mode 100755 test_fms/diag_integral/test_diag_integral2.sh create mode 100644 test_fms/interpolator/test_interpolator2.F90 create mode 100644 test_fms/interpolator/test_interpolator_write_climatology.inc create mode 100644 test_fms/monin_obukhov/input.r4.nml create mode 100644 test_fms/monin_obukhov/input.r8.nml create mode 100644 test_fms/random_numbers/Makefile.am create mode 100644 test_fms/random_numbers/test_random_numbers.F90 create mode 100755 test_fms/random_numbers/test_random_numbers.sh create mode 100644 test_fms/tracer_manager/Makefile.am create mode 100644 test_fms/tracer_manager/test_tracer_manager.F90 create mode 100755 test_fms/tracer_manager/test_tracer_manager2.sh create mode 100644 time_interp/include/time_interp.inc create mode 100644 time_interp/include/time_interp_external.inc create mode 100644 time_interp/include/time_interp_external2.inc create mode 100644 time_interp/include/time_interp_external2_r4.fh create mode 100644 time_interp/include/time_interp_external2_r8.fh create mode 100644 time_interp/include/time_interp_r4.fh create mode 100644 time_interp/include/time_interp_r8.fh create mode 100644 topography/include/gaussian_topog.inc create mode 100644 topography/include/gaussian_topog_r4.fh create mode 100644 topography/include/gaussian_topog_r8.fh create mode 100644 topography/include/topography.inc create mode 100644 topography/include/topography_r4.fh create mode 100644 topography/include/topography_r8.fh create mode 100644 tracer_manager/include/tracer_manager.inc create mode 100644 tracer_manager/include/tracer_manager_r4.fh create mode 100644 tracer_manager/include/tracer_manager_r8.fh diff --git a/CHANGELOG.md b/CHANGELOG.md index 32cc50cd27..2c616e647d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,7 +20,7 @@ sequential patch number (starting from `01`). - LIBFMS: The libFMS.F90 file (module name `fms`) meant to provide global access has been updated to include 'fms' and it's module/subdirectory name as prefixes for all names. This will only affect external codes that are already using the global module (via `use fms`) and not individual modules. - MIXED PRECISION: Updates the axis_utils2, horiz_interp, sat_vapor_pressure, and axis_utils subdirectories to support mixed precision real values. - FMS2_IO: Added in mpp_scatter and mpp_gather performance changes from the 2023.01.01 patch. See below for more details. -- FMS2_IO: Improved error messages to give more debugging information +- FMS2_IO: Improved error messages to give more debugging information - FMS_MOD: Changed fms_init to include a system call to set the stack size to unlimited, removed previously added stack size fixes - MONIN_OBUKHOV: Restructures the subroutines in `stable_mix` interface so that 1d calls the underlying implementation, and 2 and 3d call it on 1d slices of the data as opposed to passing in mismatched arrays. - MPP: Updates from JEDI for ajoint version the mpp halo filling (mpp_do_update_ad.fh), adds checkpoint for forward buffer information. diff --git a/CMakeLists.txt b/CMakeLists.txt index ff75d3cf90..f5ef9a7d38 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -305,12 +305,26 @@ foreach(kind ${kinds}) fms2_io/include string_utils/include mpp/include + column_diagnostics/include + monin_obukhov/include sat_vapor_pres/include horiz_interp/include + diag_integral/include + random_numbers/include diag_manager/include constants4 + topography/include + axis_utils/include + mosaic2/include constants - axis_utils/include) + astronomy/include + field_manager/include + time_interp/include + tracer_manager/include + interpolator/include + coupler/include + data_override/include) + target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") @@ -346,11 +360,25 @@ foreach(kind ${kinds}) $ $ $ + $ + $ + $ $ + $ $ + $ $ $ - $) + $ + $ + $ + $ + $ + $ + $ + $ + $ + $) target_include_directories(${libTgt} INTERFACE $ diff --git a/astronomy/Makefile.am b/astronomy/Makefile.am index 33d4acaf3c..50a1449412 100644 --- a/astronomy/Makefile.am +++ b/astronomy/Makefile.am @@ -23,14 +23,23 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/astronomy/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. noinst_LTLIBRARIES = libastronomy.la # The convenience library depends on its source. -libastronomy_la_SOURCES = astronomy.F90 +libastronomy_la_SOURCES = \ + astronomy.F90 \ + include/astronomy_r4.fh \ + include/astronomy_r8.fh \ + include/astronomy.inc + +astronomy.$(FC_MODEXT): \ +include/astronomy_r4.fh \ +include/astronomy_r8.fh \ +include/astronomy.inc BUILT_SOURCES = astronomy_mod.$(FC_MODEXT) nodist_include_HEADERS = astronomy_mod.$(FC_MODEXT) diff --git a/astronomy/astronomy.F90 b/astronomy/astronomy.F90 index 192fc8f22a..48e314efd8 100644 --- a/astronomy/astronomy.F90 +++ b/astronomy/astronomy.F90 @@ -29,296 +29,321 @@ module astronomy_mod -use fms_mod, only: fms_init, & - mpp_pe, mpp_root_pe, stdlog, & - write_version_number, & - check_nml_error, error_mesg, & - FATAL, NOTE, WARNING -use time_manager_mod, only: time_type, set_time, get_time, & - get_date_julian, set_date_julian, & - set_date, length_of_year, & - time_manager_init, & - operator(-), operator(+), & - operator( // ), operator(<) -use constants_mod, only: constants_init, PI -use mpp_mod, only: input_nml_file - -!-------------------------------------------------------------------- - -implicit none -private - -!--------------------------------------------------------------------- -!----------- version number for this module -------------------------- + use fms_mod, only: fms_init, & + mpp_pe, mpp_root_pe, stdlog, & + write_version_number, & + check_nml_error, error_mesg, & + FATAL, NOTE, WARNING + use time_manager_mod, only: time_type, set_time, get_time, & + get_date_julian, set_date_julian, & + set_date, length_of_year, & + time_manager_init, & + operator(-), operator(+), & + operator( // ), operator(<) + use fms_io_utils_mod, only: get_data_type_string + use constants_mod, only: constants_init, PI + use mpp_mod, only: input_nml_file + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind + + !-------------------------------------------------------------------- + + implicit none + private + + !--------------------------------------------------------------------- + !----------- version number for this module -------------------------- ! Include variable "version" to be written to log file. #include -!--------------------------------------------------------------------- -!------- interfaces -------- - -public & - astronomy_init, get_period, set_period, & - set_orbital_parameters, get_orbital_parameters, & - set_ref_date_of_ae, get_ref_date_of_ae, & - diurnal_solar, daily_mean_solar, annual_mean_solar, & - astronomy_end, universal_time, orbital_time - -!> @} - -!> @brief Calculates solar information for the given location(lat & lon) and time -!! -!> ~~~~~~~~~~{.f90} -!! call diurnal_solar (lat, lon, time, cosz, fracday, rrsun, dt_time) -!! call diurnal_solar (lat, lon, gmt, time_since_ae, cosz, fracday, rrsun, dt) -!! ~~~~~~~~~~ -!! -!! The first option (used in conjunction with time_manager_mod) -!! generates the real variables gmt and time_since_ae from the -!! time_type input, and then calls diurnal_solar with these real inputs. -!! -!! The time of day is set by -!! ~~~~~~~~~~{.f90} -!! real, intent(in) :: gmt -!! ~~~~~~~~~~ -!! The time of year is set by -!! ~~~~~~~~~~{.f90} -!! real, intent(in) :: time_since_ae -!! ~~~~~~~~~~ -!! with time_type input, both of these are extracted from -!! ~~~~~~~~~~{.f90} -!! type(time_type), intent(in) :: time -!! ~~~~~~~~~~ -!! -!! Separate routines exist within this interface for scalar, -!! 1D or 2D input and output fields: -!! -!! ~~~~~~~~~~{.f90} -!! real, intent(in), dimension(:,:) :: lat, lon -!! real, intent(in), dimension(:) :: lat, lon -!! real, intent(in) :: lat, lon -!! -!! real, intent(out), dimension(:,:) :: cosz, fracday -!! real, intent(out), dimension(:) :: cosz, fracday -!! real, intent(out) :: cosz, fracday -!! ~~~~~~~~~~ -!! -!! One may also average the output fields over the time interval -!! between gmt and gmt + dt by including the optional argument dt (or -!! dt_time). dt is measured in radians and must be less than pi -!! (1/2 day). This average is computed analytically, and should be -!! exact except for the fact that changes in earth-sun distance over -!! the time interval dt are ignored. In the context of a diurnal GCM, -!! this option should always be employed to insure that the total flux -!! at the top of the atmosphere is not modified by time truncation error. -!! -!! ~~~~~~~~~~{.f90} -!! real, intent(in), optional :: dt -!! type(time_type), optional :: dt_time -!! ~~~~~~~~~~ -!! -!! @param [in] Latitudes of model grid points [radians] -!! @param [in] Longitudes of model grid points [radians] -!! @param [in] Time of day at longitude 0.0; midnight = 0.0, one day = 2 * pi [radians] -!! @param [in] Time of year; autumnal equinox = 0.0, one year = 2 * pi [radians] -!! @param [in]