diff --git a/CMakeLists.txt b/CMakeLists.txt index f5ef9a7d38..a70abe14da 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -321,9 +321,11 @@ foreach(kind ${kinds}) field_manager/include time_interp/include tracer_manager/include + tridiagonal/include interpolator/include coupler/include - data_override/include) + data_override/include + amip_interp/include) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") @@ -378,7 +380,9 @@ foreach(kind ${kinds}) $ $ $ - $) + $ + $ + $) target_include_directories(${libTgt} INTERFACE $ diff --git a/Makefile.am b/Makefile.am index ffb12344ea..dd1d27696d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -35,8 +35,8 @@ endif # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = \ platform \ - tridiagonal \ mpp \ + tridiagonal \ constants \ constants4 \ memutils \ diff --git a/amip_interp/Makefile.am b/amip_interp/Makefile.am index f5358101d4..27f50fcbf8 100644 --- a/amip_interp/Makefile.am +++ b/amip_interp/Makefile.am @@ -23,14 +23,18 @@ # 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)/amip_interp/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. noinst_LTLIBRARIES = libamip_interp.la # The convenience library depends on its source. -libamip_interp_la_SOURCES = amip_interp.F90 +libamip_interp_la_SOURCES = \ + amip_interp.F90 \ + include/amip_interp.inc \ + include/amip_interp_r4.fh \ + include/amip_interp_r8.fh BUILT_SOURCES = amip_interp_mod.$(FC_MODEXT) nodist_include_HEADERS = amip_interp_mod.$(FC_MODEXT) diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index d276052369..a28073e48b 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -135,7 +135,7 @@ module amip_interp_mod NOTE, mpp_error, fms_error_handler use constants_mod, only: TFREEZE, pi -use platform_mod, only: R4_KIND, I2_KIND +use platform_mod, only: r4_kind, r8_kind, i2_kind use mpp_mod, only: input_nml_file use fms2_io_mod, only: FmsNetcdfFile_t, fms2_io_file_exists=>file_exists, open_file, close_file, & get_dimension_size, fms2_io_read_data=>read_data @@ -147,15 +147,15 @@ module amip_interp_mod !----------------- Public interfaces ----------------------------------- public amip_interp_init, get_amip_sst, get_amip_ice, amip_interp_new, & - amip_interp_del, amip_interp_type, assignment(=) + & amip_interp_del, amip_interp_type, assignment(=) !----------------------------------------------------------------------- !----------------- Public Data ----------------------------------- integer :: i_sst = 1200 integer :: j_sst = 600 -real, parameter:: big_number = 1.E30 +real(r8_kind), parameter:: big_number = 1.E30_r8_kind logical :: forecast_mode = .false. -real, allocatable, dimension(:,:) :: sst_ncep, sst_anom +real(r8_kind), allocatable, dimension(:,:) :: sst_ncep, sst_anom public i_sst, j_sst, sst_ncep, sst_anom, forecast_mode, use_ncep_sst @@ -167,9 +167,8 @@ module amip_interp_mod ! Include variable "version" to be written to log file. #include - real, allocatable:: temp1(:,:), temp2(:,:) ! add by JHC - real, allocatable, dimension(:,:) :: tempamip + real(r8_kind), allocatable, dimension(:,:) :: tempamip ! end add by JHC !----------------------------------------------------------------------- !------ private defined data type -------- @@ -186,7 +185,7 @@ module amip_interp_mod !> Assignment overload to allow native assignment between amip_interp_type variables. !> @ingroup amip_interp_mod interface assignment(=) - module procedure amip_interp_type_eq + module procedure amip_interp_type_eq end interface !> Private logical equality overload for amip_interp_type @@ -207,6 +206,15 @@ module amip_interp_mod module procedure date_gt end interface +!> Retrieve sea surface temperature data and interpolated grid +interface get_amip_sst + module procedure get_amip_sst_r4, get_amip_sst_r8 +end interface + +!> AMIP interpolation for ice +interface get_amip_ice + module procedure get_amip_ice_r4, get_amip_ice_r8 +end interface !> Initializes data needed for the horizontal !! interpolation between the sst data and model grid. @@ -265,23 +273,24 @@ module amip_interp_mod !! !> @ingroup amip_interp_mod interface amip_interp_new - module procedure amip_interp_new_1d - module procedure amip_interp_new_2d + module procedure amip_interp_new_1d_r4, amip_interp_new_1d_r8 + module procedure amip_interp_new_2d_r4, amip_interp_new_2d_r8 end interface - !----- public data type ------ -!> @brief Contains information needed by the interpolation module (exchange_mod) and buffers data. +!> @brief Contains information needed by the interpolation module (exchange_mod) and buffers +!! data (r4_kind flavor). !> @ingroup amip_interp_mod type amip_interp_type private - type (horiz_interp_type) :: Hintrp, Hintrp2 ! add by JHC - real, allocatable :: data1(:,:), data2(:,:) - type (date_type) :: Date1, Date2 - logical :: use_climo, use_annual - logical :: I_am_initialized=.false. -end type + type (horiz_interp_type) :: Hintrp, Hintrp2 ! add by JHC + real(r4_kind), dimension(:,:), allocatable :: data1_r4, data2_r4 + real(r8_kind), dimension(:,:), allocatable :: data1_r8, data2_r8 + type (date_type) :: Date1, Date2 + logical :: use_climo, use_annual + logical :: I_am_initialized=.false. +end type amip_interp_type !> @addtogroup amip_interp_mod !> @{ @@ -289,7 +298,7 @@ module amip_interp_mod ! ---- resolution/grid variables ---- integer :: mobs, nobs - real, allocatable :: lon_bnd(:), lat_bnd(:) + real(r8_kind), allocatable, dimension(:) :: lon_bnd, lat_bnd ! ---- global unit & date ---- @@ -301,8 +310,8 @@ module amip_interp_mod type (date_type) :: Curr_date = date_type( -99, -99, -99 ) type (date_type) :: Date_end = date_type( -99, -99, -99 ) - real :: tice_crit_k - integer(I2_KIND) :: ice_crit + real(r8_kind) :: tice_crit_k + integer(i2_kind) :: ice_crit logical :: module_is_initialized = .false. @@ -316,19 +325,19 @@ module amip_interp_mod character(len=16) :: date_out_of_range = 'fail' !< use 'fail', 'initclimo', or 'climo' - real :: tice_crit = -1.80 !< in degC or degK + real(r8_kind) :: tice_crit = -1.80_r8_kind !< in degC or degK integer :: verbose = 0 !< 0 <= verbose <= 3 logical :: use_zonal = .false. !< parameters for prescribed zonal sst option - real :: teq = 305. !< parameters for prescribed zonal sst option - real :: tdif = 50. !< parameters for prescribed zonal sst option - real :: tann = 20. !< parameters for prescribed zonal sst option - real :: tlag = 0.875 !< parameters for prescribed zonal sst option + real(r8_kind) :: teq = 305._r8_kind !< parameters for prescribed zonal sst option + real(r8_kind) :: tdif = 50._r8_kind !< parameters for prescribed zonal sst option + real(r8_kind) :: tann = 20._r8_kind !< parameters for prescribed zonal sst option + real(r8_kind) :: tlag = 0.875_r8_kind !< parameters for prescribed zonal sst option integer :: amip_date(3)=(/-1,-1,-1/) !< amip date for repeating single day (rsd) option - real :: sst_pert = 0. !< global temperature perturbation used for sensitivity experiments + real(r8_kind) :: sst_pert = 0._r8_kind !< global temperature perturbation used for sensitivity experiments character(len=6) :: sst_pert_type = 'fixed' !< use 'random' or 'fixed' logical :: do_sst_pert = .false. @@ -356,507 +365,8 @@ module amip_interp_mod contains -! modified by JHC -!> Retrieve sea surface temperature data and interpolated grid -subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) - - type (time_type), intent(in) :: Time !< Time to interpolate - type (amip_interp_type), intent(inout) :: Interp !< Holds data for interpolation - real, intent(out) :: sst(:,:) !< Sea surface temperature data - character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present - - real, dimension(mobs,nobs) :: sice - - integer :: year1, year2, month1, month2 - real :: fmonth - type (date_type) :: Date1, Date2, Udate1, Udate2 - - type(time_type) :: Amip_Time - integer :: tod(3),dum(3) - -! add by JHC - real, intent(in), dimension(:,:), optional :: lon_model, lat_model - real :: pert - integer :: i, j, mobs_sst, nobs_sst - integer :: jhctod(6) - type (time_type) :: Udate - character(len=4) :: yyyy - integer :: nrecords, ierr, k, yr, mo, dy - integer, dimension(:), allocatable :: ryr, rmo, rdy - character(len=30) :: time_unit - real, dimension(:), allocatable :: timeval - character(len=maxc) :: ncfilename - type(FmsNetcdfFile_t) :: fileobj - logical :: the_file_exists -! end add by JHC - logical, parameter :: DEBUG = .false. !> switch for debugging output - !> These are fms_io specific - integer :: unit - - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('get_amip_sst','The amip_interp_type variable is not initialized',err_msg)) return - endif - -!----------------------------------------------------------------------- -!----- compute zonally symetric sst --------------- - - if ( use_ncep_sst .and. forecast_mode ) no_anom_sst = .false. - - if (all(amip_date>0)) then - call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) - Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) - else - Amip_Time = Time - endif - -! add by JHC -if ( .not.use_daily ) then -! end add by JHC - - if ( .not. allocated(temp1) ) allocate (temp1(mobs,nobs)) - if ( .not. allocated(temp2) ) allocate (temp2(mobs,nobs)) - - if (use_zonal) then - call zonal_sst (Amip_Time, sice, temp1) - call horiz_interp ( Interp%Hintrp, temp1, sst ) - else - -!----------------------------------------------------------------------- -!---------- get new observed sea surface temperature ------------------- - -! ---- time interpolation for months ----- - call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) -! ---- force climatology ---- - if (Interp % use_climo) then - year1=0; year2=0 - endif - if (Interp % use_annual) then - year1=0; year2=0 - month1=0; month2=0 - endif -! --------------------------- - - Date1 = date_type( year1, month1, 0 ) - Date2 = date_type( year2, month2, 0 ) - -! -- open/rewind file -- - unit = -1 -!----------------------------------------------------------------------- - - - if (Date1 /= Interp % Date1) then -! ---- use Date2 for Date1 ---- - if (Date1 == Interp % Date2) then - Interp % Date1 = Interp % Date2 - Interp % data1 = Interp % data2 - temp1(:,:) = temp2(:,:) ! SJL BUG fix: June 24, 2011 - else - call read_record ('sst', Date1, Udate1, temp1) - if ( use_ncep_sst .and. (.not. no_anom_sst) ) then - temp1(:,:) = temp1(:,:) + sst_anom(:,:) - endif - call horiz_interp ( Interp%Hintrp, temp1, Interp%data1 ) - call clip_data ('sst', Interp%data1) - Interp % Date1 = Date1 - endif - endif - -!----------------------------------------------------------------------- - - if (Date2 /= Interp % Date2) then - call read_record ('sst', Date2, Udate2, temp2) - if ( use_ncep_sst .and. (.not. no_anom_sst) ) then - temp2(:,:) = temp2(:,:) + sst_anom(:,:) - endif - call horiz_interp ( Interp%Hintrp, temp2, Interp%data2 ) - call clip_data ('sst', Interp%data2) - Interp % Date2 = Date2 - endif - -!----------------------------------------------------------------------- -!---------- time interpolation (between months) of sst's --------------- -!----------------------------------------------------------------------- - sst = Interp % data1 + fmonth * (Interp % data2 - Interp % data1) - -!------------------------------------------------------------------------------- -! SJL mods for NWP and TCSF --- -! Nudging runs: (Note: NCEP SST updated only every 6-hr) -! Compute SST anomaly from global SST datasets for subsequent forecast runs -!------------------------------------------------------------------------------- - if ( use_ncep_sst .and. no_anom_sst ) then - sst_anom(:,:) = sst_ncep(:,:) - (temp1(:,:) + fmonth*(temp2(:,:) - temp1(:,:)) ) - call horiz_interp ( Interp%Hintrp, sst_ncep, sst ) - call clip_data ('sst', sst) - endif - -!! DEBUG CODE - if (DEBUG) then - call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) - if (mpp_pe() == 0) then - write (*,200) 'JHC: use_daily = F, AMIP_Time: ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5), & - & jhctod(6) - write (*,300) 'JHC: use_daily = F, interped SST: ', sst(1,1),sst(5,5),sst(10,10) - endif - endif - - - endif - -! add by JHC -else - call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) - if (mpp_pe() == mpp_root_pe()) write(*,200) 'amip_interp_mod: use_daily = T, Amip_Time = ',jhctod(1), & - & jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) - - yr = jhctod(1); mo = jhctod(2); dy = jhctod(3) - - write (yyyy,'(i4)') jhctod(1) - - file_name_sst = 'INPUT/' // 'sst.day.mean.'//yyyy//'.v2.nc' - ncfilename = trim(file_name_sst) - time_unit = 'days since 1978-01-01 00:00:00' - - mobs_sst = 1440; nobs_sst = 720 - - call set_sst_grid_edges_daily(mobs_sst, nobs_sst) - call horiz_interp_new ( Interp%Hintrp2, lon_bnd, lat_bnd, & - lon_model, lat_model, interp_method="bilinear" ) - - the_file_exists = fms2_io_file_exists(ncfilename) - - if ( (.NOT. the_file_exists) ) then - call mpp_error ('amip_interp_mod', & - 'cannot find daily SST input data file: '//trim(ncfilename), NOTE) - else - if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & - 'Reading NetCDF formatted daily SST from: '//trim(ncfilename), NOTE) - - if(.not. open_file(fileobj, trim(ncfilename), 'read')) & - call error_mesg ('get_amip_sst', 'Error in opening file '//trim(ncfilename), FATAL) - - call get_dimension_size(fileobj, 'TIME', nrecords) - if (nrecords < 1) call mpp_error('amip_interp_mod', & - 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL) - allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords)) - call fms2_io_read_data(fileobj, 'TIME', timeval) -!!! DEBUG CODE - if(DEBUG) then - if (mpp_pe() == 0) then - print *, 'JHC: nrecords = ', nrecords - print *, 'JHC: TIME = ', timeval - endif - endif - - ierr = 1 - do k = 1, nrecords - - Udate = get_cal_time (timeval(k), time_unit, 'julian') - call get_date(Udate,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) - ryr(k) = jhctod(1); rmo(k) = jhctod(2); rdy(k) = jhctod(3) - - if ( yr == ryr(k) .and. mo == rmo(k) .and. dy == rdy (k) ) ierr = 0 - if (ierr==0) exit - - enddo - - if(DEBUG) then - if (mpp_pe() == 0) then - print *, 'JHC: k =', k - print *, 'JHC: ryr(k) rmo(k) rdy(k)',ryr(k), rmo(k), rdy(k) - print *, 'JHC: yr mo dy ',yr, mo, dy - endif - endif - - if (ierr .ne. 0) call mpp_error('amip_interp_mod', & - 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) - endif ! if(file_exist(ncfilename)) - - - !---- read NETCDF data ---- - if ( .not. allocated(tempamip) ) allocate (tempamip(mobs_sst,nobs_sst)) - - if (the_file_exists) then - call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k) - call close_file(fileobj) - tempamip = tempamip + TFREEZE - -!!! DEBUG CODE - if(DEBUG) then - if (mpp_pe() == 0) then - print*, 'JHC: TFREEZE = ', TFREEZE - print*, lbound(sst) - print*, ubound(sst) - print*, lbound(tempamip) - print*, ubound(tempamip) - write(*,300) 'JHC: tempamip : ', tempamip(100,100), tempamip(200,200), tempamip(300,300) - endif - endif - - call horiz_interp ( Interp%Hintrp2, tempamip, sst ) - call clip_data ('sst', sst) - - endif - - if(DEBUG) then - if (mpp_pe() == 400) then - write(*,300)'JHC: use_daily = T, daily SST: ', sst(1,1),sst(5,5),sst(10,10) - print *,'JHC: use_daily = T, daily SST: ', sst - endif - endif - -200 format(a35, 6(i5,1x)) -300 format(a35, 3(f7.3,2x)) - -endif -! end add by JHC - -! add by JHC: add on non-zero sea surface temperature perturbation (namelist option) -! This perturbation may be useful in accessing model sensitivities - - if ( do_sst_pert ) then - - if ( trim(sst_pert_type) == 'fixed' ) then - sst = sst + sst_pert - else if ( trim(sst_pert_type) == 'random' ) then - call random_seed() - - if(DEBUG) then - if (mpp_pe() == 0) then - print*, 'mobs = ', mobs - print*, 'nobs = ', nobs - print*, lbound(sst) - print*, ubound(sst) - endif - endif - - do i = 1, size(sst,1) - do j = 1, size(sst,2) - call random_number(pert) - sst (i,j) = sst (i,j) + sst_pert*((pert-0.5)*2) - end do - end do - endif - - endif -! end add by JHC - -!----------------------------------------------------------------------- - - end subroutine get_amip_sst - -!> AMIP interpolation for ice -subroutine get_amip_ice (Time, Interp, ice, err_msg) - - type (time_type), intent(in) :: Time !< Time to interpolate - type (amip_interp_type), intent(inout) :: Interp !< Holds data for interpolation - real, intent(out) :: ice(:,:) !< ice data - character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present - - real, dimension(mobs,nobs) :: sice, temp - - integer :: year1, year2, month1, month2 - real :: fmonth - type (date_type) :: Date1, Date2, Udate1, Udate2 - - type(time_type) :: Amip_Time - integer :: tod(3),dum(3) - - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('get_amip_ice','The amip_interp_type variable is not initialized',err_msg)) return - endif - -!----------------------------------------------------------------------- -!----- compute zonally symetric sst --------------- - - - if (any(amip_date>0)) then - - call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) - - Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) - - else - - Amip_Time = Time - - endif - - -if (use_zonal) then - call zonal_sst (Amip_Time, sice, temp) - call horiz_interp ( Interp%Hintrp, sice, ice ) -else - -!----------------------------------------------------------------------- -!---------- get new observed sea surface temperature ------------------- - -! ---- time interpolation for months ----- - - call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) - -! ---- force climatology ---- - if (Interp % use_climo) then - year1=0; year2=0 - endif - if (Interp % use_annual) then - year1=0; year2=0 - month1=0; month2=0 - endif -! --------------------------- - - Date1 = date_type( year1, month1, 0 ) - Date2 = date_type( year2, month2, 0 ) - - unit = -1 -!----------------------------------------------------------------------- - - if (Date1 /= Interp % Date1) then -! ---- use Date2 for Date1 ---- - if (Date1 == Interp % Date2) then - Interp % Date1 = Interp % Date2 - Interp % data1 = Interp % data2 - else -!-- SJL ------------------------------------------------------------- -! Can NOT use ncep_sst to determine sea_ice For seasonal forecast -! Use climo sea ice for seasonal runs - if ( use_ncep_sst .and. use_ncep_ice ) then - where ( sst_ncep <= (TFREEZE+tice_crit) ) - sice = 1. - elsewhere - sice = 0. - endwhere - else - call read_record ('ice', Date1, Udate1, sice) - endif -!-------------------------------------------------------------------- - call horiz_interp ( Interp%Hintrp, sice, Interp%data1 ) - call clip_data ('ice', Interp%data1) - Interp % Date1 = Date1 - endif - endif - -!----------------------------------------------------------------------- - - if (Date2 /= Interp % Date2) then - -!-- SJL ------------------------------------------------------------- - if ( use_ncep_sst .and. use_ncep_ice ) then - where ( sst_ncep <= (TFREEZE+tice_crit) ) - sice = 1. - elsewhere - sice = 0. - endwhere - else - call read_record ('ice', Date2, Udate2, sice) - endif -!-------------------------------------------------------------------- - call horiz_interp ( Interp%Hintrp, sice, Interp%data2 ) - call clip_data ('ice', Interp%data2) - Interp % Date2 = Date2 - - endif - -!----------------------------------------------------------------------- -!---------- time interpolation (between months) ------------------------ -!----------------------------------------------------------------------- - - ice = Interp % data1 + fmonth * (Interp % data2 - Interp % data1) - -endif - -!----------------------------------------------------------------------- - - end subroutine get_amip_ice - -!####################################################################### - - !> @return A newly created @ref amip_interp_type - function amip_interp_new_1d ( lon , lat , mask , use_climo, use_annual, & - interp_method ) result (Interp) - - real, intent(in), dimension(:) :: lon, lat - logical, intent(in), dimension(:,:) :: mask - character(len=*), intent(in), optional :: interp_method - logical, intent(in), optional :: use_climo, use_annual - - type (amip_interp_type) :: Interp - - if(.not.module_is_initialized) call amip_interp_init - - Interp % use_climo = .false. - if (present(use_climo)) Interp % use_climo = use_climo - Interp % use_annual = .false. - if (present(use_annual)) Interp % use_annual = use_annual - - if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & - call error_mesg ('amip_interp_new_1d', 'use_climo mismatch', FATAL) - - if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & - call error_mesg ('amip_interp_new_1d', 'use_annual(climo) mismatch', FATAL) - - Interp % Date1 = date_type( -99, -99, -99 ) - Interp % Date2 = date_type( -99, -99, -99 ) - -!----------------------------------------------------------------------- -! ---- initialization of horizontal interpolation ---- - - call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, & - lon, lat, interp_method= interp_method ) - - allocate ( Interp % data1 (size(lon(:))-1,size(lat(:))-1), & - Interp % data2 (size(lon(:))-1,size(lat(:))-1) ) - - Interp%I_am_initialized = .true. - - end function amip_interp_new_1d - - !> @return A newly created @ref amip_interp_type - function amip_interp_new_2d ( lon , lat , mask , use_climo, use_annual, & - interp_method ) result (Interp) - - real, intent(in), dimension(:,:) :: lon, lat - logical, intent(in), dimension(:,:) :: mask - character(len=*), intent(in), optional :: interp_method - logical, intent(in), optional :: use_climo, use_annual - - type (amip_interp_type) :: Interp - - if(.not.module_is_initialized) call amip_interp_init - - Interp % use_climo = .false. - if (present(use_climo)) Interp % use_climo = use_climo - Interp % use_annual = .false. - if (present(use_annual)) Interp % use_annual = use_annual - - if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & - call error_mesg ('amip_interp_new_2d', 'use_climo mismatch', FATAL) - - if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & - call error_mesg ('amip_interp_new_2d', 'use_annual(climo) mismatch', FATAL) - - Interp % Date1 = date_type( -99, -99, -99 ) - Interp % Date2 = date_type( -99, -99, -99 ) - -!----------------------------------------------------------------------- -! ---- initialization of horizontal interpolation ---- - - call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, & - lon, lat, interp_method = interp_method) - - allocate ( Interp % data1 (size(lon,1),size(lat,2)), & - Interp % data2 (size(lon,1),size(lat,2))) - - Interp%I_am_initialized = .true. - - end function amip_interp_new_2d - -!####################################################################### - !> initialize @ref amip_interp_mod for use - subroutine amip_interp_init() - + subroutine amip_interp_init integer :: unit,io,ierr !----------------------------------------------------------------------- @@ -887,8 +397,10 @@ subroutine amip_interp_init() ! ---- freezing point of sea water in deg K --- tice_crit_k = tice_crit - if ( tice_crit_k < 200. ) tice_crit_k = tice_crit_k + TFREEZE - ice_crit = nint((tice_crit_k-TFREEZE)*100., I2_KIND) + if ( tice_crit_k < 200._r8_kind ) then + tice_crit_k = tice_crit_k + TFREEZE + endif + ice_crit = nint((tice_crit_k-TFREEZE)*100._r8_kind, I2_KIND) ! ---- set up file dependent variable ---- ! ---- global file name ---- @@ -909,7 +421,7 @@ subroutine amip_interp_init() mobs = 360; nobs = 180 call set_sst_grid_edges_oi ! --- specfied min for amip2 --- - tice_crit_k = 271.38 + tice_crit_k = 271.38_r8_kind if (mpp_pe() == 0) & call error_mesg ('amip_interp_init', 'using AMIP 2 sst', NOTE) Date_end = date_type( 1996, 3, 0 ) @@ -919,7 +431,7 @@ subroutine amip_interp_init() mobs = 360; nobs = 180 call set_sst_grid_edges_oi ! --- specfied min for hurrell --- - tice_crit_k = 271.38 + tice_crit_k = 271.38_r8_kind if (mpp_pe() == 0) & call error_mesg ('amip_interp_init', 'using HURRELL sst', NOTE) Date_end = date_type( 2011, 8, 16 ) ! updated by JHC @@ -991,230 +503,96 @@ subroutine amip_interp_init() if (.not. open_file(fileobj_ice, trim(file_name_ice), 'read')) & call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_ice), FATAL) module_is_initialized = .true. - end subroutine amip_interp_init -!####################################################################### - -!> Frees data associated with a amip_interp_type variable. Should be used for any -!! variables initialized via @ref amip_interp_new. -!> @param[inout] Interp A defined data type variable initialized by amip_interp_new and used -!! when calling get_amip_sst and get_amip_ice. - subroutine amip_interp_del (Interp) - type (amip_interp_type), intent(inout) :: Interp - if(allocated(Interp%data1)) deallocate(Interp%data1) - if(allocated(Interp%data2)) deallocate(Interp%data2) - if(allocated(lon_bnd)) deallocate(lon_bnd) - if(allocated(lat_bnd)) deallocate(lat_bnd) - call horiz_interp_del ( Interp%Hintrp ) - - Interp%I_am_initialized = .false. - - end subroutine amip_interp_del - -!####################################################################### - subroutine set_sst_grid_edges_amip1 - integer :: i, j - real :: hpie, dlon, dlat, wb, sb + real(r8_kind) :: hpie, dlon, dlat, wb, sb - allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) ) + allocate(lon_bnd(mobs+1)) + allocate(lat_bnd(nobs+1)) ! ---- compute grid edges (do only once) ----- - hpie = 0.5*pi + hpie = pi / 2._r8_kind + + dlon = 4._r8_kind*hpie/real(mobs, r8_kind) + wb = -0.5_r8_kind*dlon - dlon = 4.*hpie/float(mobs); wb = -0.5*dlon do i = 1, mobs+1 - lon_bnd(i) = wb + dlon * float(i-1) + lon_bnd(i) = wb + dlon*real(i-1, r8_kind) enddo - lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie + lon_bnd(mobs+1) = lon_bnd(1) + 4._r8_kind*hpie - dlat = 2.*hpie/float(nobs-1); sb = -hpie + 0.5*dlat - lat_bnd(1) = -hpie; lat_bnd(nobs+1) = hpie + dlat = 2._r8_kind*hpie/real(nobs-1, r8_kind) + sb = -hpie + 0.5_r8_kind*dlat + + lat_bnd(1) = -hpie + lat_bnd(nobs+1) = hpie do j = 2, nobs - lat_bnd(j) = sb + dlat * float(j-2) + lat_bnd(j) = sb + dlat * real(j-2, r8_kind) enddo - end subroutine set_sst_grid_edges_amip1 -!####################################################################### subroutine set_sst_grid_edges_oi - integer :: i, j - real :: hpie, dlon, dlat, wb, sb + real(r8_kind) :: hpie, dlon, dlat, wb, sb ! add by JHC - if(allocated(lon_bnd)) deallocate(lon_bnd) - if(allocated(lat_bnd)) deallocate(lat_bnd) + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) ! end add by JHC - allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) ) + + allocate(lon_bnd(mobs+1)) + allocate(lat_bnd(nobs+1)) ! ---- compute grid edges (do only once) ----- - hpie = 0.5*pi + hpie = pi / 2._r8_kind + dlon = 4._r8_kind*hpie/real(mobs, r8_kind) + wb = 0.0_r8_kind - dlon = 4.*hpie/float(mobs); wb = 0.0 - lon_bnd(1) = wb + lon_bnd(1) = wb do i = 2, mobs+1 - lon_bnd(i) = wb + dlon * float(i-1) + lon_bnd(i) = wb + dlon * real(i-1, r8_kind) enddo - lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie + lon_bnd(mobs+1) = lon_bnd(1) + 4._r8_kind*hpie - dlat = 2.*hpie/float(nobs); sb = -hpie - lat_bnd(1) = sb; lat_bnd(nobs+1) = hpie + dlat = 2._r8_kind*hpie/real(nobs, r8_kind) + sb = -hpie + + lat_bnd(1) = sb + lat_bnd(nobs+1) = hpie do j = 2, nobs - lat_bnd(j) = sb + dlat * float(j-1) + lat_bnd(j) = sb + dlat * real(j-1, r8_kind) enddo - end subroutine set_sst_grid_edges_oi -!####################################################################### -! add by JHC - subroutine set_sst_grid_edges_daily(mobs_sst, nobs_sst) - - integer :: i, j, mobs_sst, nobs_sst - real :: hpie, dlon, dlat, wb, sb - - if(allocated(lon_bnd)) deallocate(lon_bnd) - if(allocated(lat_bnd)) deallocate(lat_bnd) - allocate ( lon_bnd(mobs_sst+1), lat_bnd(nobs_sst+1) ) - -! ---- compute grid edges (do only once) ----- - - hpie = 0.5*pi - - dlon = 4.*hpie/float(mobs_sst); wb = 0.0 - lon_bnd(1) = wb - do i = 2, mobs_sst+1 - lon_bnd(i) = wb + dlon * float(i-1) - enddo - lon_bnd(mobs_sst+1) = lon_bnd(1) + 4.*hpie - - dlat = 2.*hpie/float(nobs_sst); sb = -hpie - lat_bnd(1) = sb; lat_bnd(nobs_sst+1) = hpie - do j = 2, nobs_sst - lat_bnd(j) = sb + dlat * float(j-1) - enddo - - end subroutine set_sst_grid_edges_daily -! end add by JHC -!####################################################################### - - - subroutine a2a_bilinear(nx, ny, dat1, n1, n2, dat2) - integer, intent(in):: nx, ny - integer, intent(in):: n1, n2 - real, intent(in) :: dat1(nx,ny) - real, intent(out):: dat2(n1,n2) !> output interpolated data - -! local: - real:: lon1(nx), lat1(ny) - real:: lon2(n1), lat2(n2) - real:: dx1, dy1, dx2, dy2 - real:: xc, yc - real:: a1, b1, c1, c2, c3, c4 - integer i1, i2, jc, i0, j0, it, jt - integer i,j - - -!----------------------------------------------------------- -! * Interpolate from "FMS" 1x1 SST data grid to a finer grid -! lon: 0.5, 1.5, ..., 359.5 -! lat: -89.5, -88.5, ... , 88.5, 89.5 -!----------------------------------------------------------- - - dx1 = 360./real(nx) !> INput Grid - dy1 = 180./real(ny) !> INput Grid - - do i=1,nx - lon1(i) = 0.5*dx1 + real(i-1)*dx1 - enddo - do j=1,ny - lat1(j) = -90. + 0.5*dy1 + real(j-1)*dy1 - enddo - - dx2 = 360./real(n1) !> OutPut Grid: - dy2 = 180./real(n2) !> OutPut Grid: - - do i=1,n1 - lon2(i) = 0.5*dx2 + real(i-1)*dx2 - enddo - do j=1,n2 - lat2(j) = -90. + 0.5*dy2 + real(j-1)*dy2 - enddo - - jt = 1 - do 5000 j=1,n2 - - yc = lat2(j) - if ( yclat1(ny) ) then - jc = ny-1 - b1 = 1. - else - do j0=jt,ny-1 - if ( yc>=lat1(j0) .and. yc<=lat1(j0+1) ) then - jc = j0 - jt = j0 - b1 = (yc-lat1(jc)) / dy1 - go to 222 - endif - enddo - endif -222 continue - - it = 1 - do i=1,n1 - xc = lon2(i) - if ( xc>lon1(nx) ) then - i1 = nx; i2 = 1 - a1 = (xc-lon1(nx)) / dx1 - elseif ( xc=lon1(i0) .and. xc<=lon1(i0+1) ) then - i1 = i0; i2 = i0+1 - it = i0 - a1 = (xc-lon1(i1)) / dx1 - go to 111 - endif - enddo - endif -111 continue - -! Debug code: - if ( a1<-0.001 .or. a1>1.001 .or. b1<-0.001 .or. b1>1.001 ) then - write(*,*) i,j,a1, b1 - call mpp_error(FATAL,'a2a bilinear interpolation') - endif - - c1 = (1.-a1) * (1.-b1) - c2 = a1 * (1.-b1) - c3 = a1 * b1 - c4 = (1.-a1) * b1 -! Bilinear interpolation: - dat2(i,j) = c1*dat1(i1,jc) + c2*dat1(i2,jc) + c3*dat1(i2,jc+1) + c4*dat1(i1,jc+1) +!> Frees data associated with a amip_interp_type variable. Should be used for any +!! variables initialized via @ref amip_interp_new. +!> @param[inout] Interp A defined data type variable initialized by amip_interp_new and used +!! when calling get_amip_sst and get_amip_ice. + subroutine amip_interp_del (Interp) + type (amip_interp_type), intent(inout) :: Interp - enddo !i-loop + if(allocated(Interp%data1_r4)) deallocate(Interp%data1_r4) + if(allocated(Interp%data1_r8)) deallocate(Interp%data1_r8) + if(allocated(Interp%data2_r4)) deallocate(Interp%data2_r4) + if(allocated(Interp%data2_r8)) deallocate(Interp%data2_r8) -5000 continue ! j-loop + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) - end subroutine a2a_bilinear + call horiz_interp_del ( Interp%Hintrp ) -!####################################################################### + Interp%I_am_initialized = .false. + end subroutine amip_interp_del !> @brief Returns the size (i.e., number of longitude and latitude !! points) of the observed data grid. !! @throws FATAL have not called amip_interp_new !! Must call amip_interp_new before get_sst_grid_size. subroutine get_sst_grid_size (nlon, nlat) - integer, intent(out) :: nlon !> The number of longitude points (first dimension) in the !! observed data grid. For AMIP 1 nlon = 180, and the Reynolds nlon = 360. integer, intent(out) :: nlat !> The number of latitude points (second dimension) in the @@ -1223,182 +601,8 @@ subroutine get_sst_grid_size (nlon, nlat) if ( .not.module_is_initialized ) call amip_interp_init nlon = mobs; nlat = nobs - end subroutine get_sst_grid_size -!####################################################################### - -!> @brief Returns the grid box boundaries of the observed data grid. -!! -!! @throws FATAL, have not called amip_interp_new -!! Must call amip_interp_new before get_sst_grid_boundary. -!! -!! @throws FATAL, invalid argument dimensions -!! The size of the output argument arrays do not agree with -!! the size of the observed data. See the documentation for -!! interfaces get_sst_grid_size and get_sst_grid_boundary. - subroutine get_sst_grid_boundary (blon, blat, mask) - - real, intent(out) :: blon(:) !> The grid box edges (in radians) for longitude points of the - !! observed data grid. The size of this argument must be nlon+1. - real, intent(out) :: blat(:) !> The grid box edges (in radians) for latitude points of the - !! observed data grid. The size of this argument must be nlat+1. - logical, intent(out) :: mask(:,:) - - if ( .not.module_is_initialized ) call amip_interp_init - -! ---- check size of argument(s) ---- - - if (size(blon(:)) /= mobs+1 .or. size(blat(:)) /= nobs+1) & - call error_mesg ('get_sst_grid_boundary in amip_interp_mod', & - 'invalid argument dimensions', FATAL) - -! ---- return grid box edges ----- - - blon = lon_bnd - blat = lat_bnd - -! ---- masking (data exists at all points) ---- - - mask = .true. - - - end subroutine get_sst_grid_boundary - -!####################################################################### - - subroutine read_record (type, Date, Adate, dat) - - character(len=*), intent(in) :: type - type (date_type), intent(in) :: Date - type (date_type), intent(inout) :: Adate - real, intent(out) :: dat(mobs,nobs) - real :: tmp_dat(360,180) - - integer(I2_KIND) :: idat(mobs,nobs) - integer :: nrecords, yr, mo, dy, ierr, k - integer, dimension(:), allocatable :: ryr, rmo, rdy - character(len=maxc) :: ncfilename, ncfieldname - type(FmsNetcdfFile_t), pointer :: fileobj - - !---- set file and field name for NETCDF data sets ---- - - ncfieldname = 'sst' - if(type(1:3) == 'sst') then - ncfilename = trim(file_name_sst) - fileobj => fileobj_sst - else if(type(1:3) == 'ice') then - ncfilename = trim(file_name_ice) - fileobj => fileobj_ice - if (lowercase(trim(data_set)) == 'amip2' .or. & - lowercase(trim(data_set)) == 'hurrell' .or. & - lowercase(trim(data_set)) == 'daily') ncfieldname = 'ice' ! modified by JHC - endif - - dy = 0 ! only processing monthly data - - if (verbose > 2 .and. mpp_pe() == 0) & - print *, 'looking for date = ', Date - - ! This code can handle amip1, reynolds, or reyoi type SST data files in netCDF format - if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & - 'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE) - - call fms2_io_read_data (fileobj, 'nrecords', nrecords) - if (nrecords < 1) call mpp_error('amip_interp_mod', & - 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL) - allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords)) - call fms2_io_read_data(fileobj, 'yr', ryr) - call fms2_io_read_data(fileobj, 'mo', rmo) - call fms2_io_read_data(fileobj, 'dy', rdy) - - ierr = 1 - do k = 1, nrecords - yr = ryr(k); mo = rmo(k) - Adate = date_type( yr, mo, 0) - Curr_date = Adate - if (verbose > 2 .and. mpp_pe() == 0) & - print *, '....... checking ', Adate - if (Date == Adate) ierr = 0 - if (yr == 0 .and. mo == Date%month) ierr = 0 - if (ierr == 0) exit - enddo - if (ierr .ne. 0) call mpp_error('amip_interp_mod', & - 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) - deallocate(ryr, rmo, rdy) - !PRINT *, 'New SST data: ', k, yr, mo, dy, Date%year, Date%month, Date%day, ryr(1), rmo(1) - - !---- check if climatological data should be used ---- - - if (yr == 0 .or. mo == 0) then - ierr = 0 - if (date_out_of_range == 'fail' ) ierr = 1 - if (date_out_of_range == 'initclimo' .and. & - Date > Date_end ) ierr = 1 - if (ierr /= 0) call error_mesg & - ('read_record in amip_interp_mod', & - 'climo data read when NO climo data requested', FATAL) - endif - - !---- read NETCDF data ---- - - if ( interp_oi_sst ) then - call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k) -! interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation) - if ( mobs/=360 .or. nobs/=180 ) then - call a2a_bilinear(360, 180, tmp_dat, mobs, nobs, dat) - else - dat(:,:) = tmp_dat(:,:) - endif - else - call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) - endif - !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 ---- - - if (type(1:3) == 'ice') then - !---- create fractional [0,1] ice mask - if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then - where ( idat <= ice_crit ) - dat = 1. - elsewhere - dat = 0. - endwhere - else - dat = dat*0.01 - endif - else if (type(1:3) == 'sst') then - !---- unpack sst ---- - if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then - dat = real(idat)*0.01 + TFREEZE - endif - endif - - return - - end subroutine read_record - -!####################################################################### - - subroutine clip_data (type, dat) - - character(len=*), intent(in) :: type - real, intent(inout) :: dat(:,:) - - if (type(1:3) == 'ice') then - dat = min(max(dat,0.0),1.0) - else if (type(1:3) == 'sst') then - dat = max(tice_crit_k,dat) - endif - - end subroutine clip_data - -!####################################################################### - !> @return logical answer function date_equals (Left, Right) result (answer) type (date_type), intent(in) :: Left, Right @@ -1411,11 +615,8 @@ function date_equals (Left, Right) result (answer) else answer = .false. endif - end function date_equals -!####################################################################### - !> @return logical answer function date_not_equals (Left, Right) result (answer) type (date_type), intent(in) :: Left, Right @@ -1428,11 +629,8 @@ function date_not_equals (Left, Right) result (answer) else answer = .true. endif - end function date_not_equals -!####################################################################### - !> @return logical answer function date_gt (Left, Right) result (answer) type (date_type), intent(in) :: Left, Right @@ -1451,85 +649,9 @@ function date_gt (Left, Right) result (answer) exit endif enddo - end function date_gt -!####################################################################### - -subroutine print_dates (Time, Date1, Udate1, & - Date2, Udate2, fmonth) - - type (time_type), intent(in) :: Time - type (date_type), intent(in) :: Date1, Udate1, Date2, Udate2 - real, intent(in) :: fmonth - - integer :: year, month, day, hour, minute, second - - call get_date (Time, year, month, day, hour, minute, second) - - write (*,10) year,month,day, hour,minute,second - write (*,20) fmonth - write (*,30) Date1, Udate1 - write (*,40) Date2, Udate2 - -10 format (/,' date(y/m/d h:m:s) = ',i4,2('/',i2.2),1x,2(i2.2,':'),i2.2) -20 format (' fmonth = ',f9.7) -30 format (' date1(y/m/d) = ',i4,2('/',i2.2),6x, & - 'used = ',i4,2('/',i2.2),6x ) -40 format (' date2(y/m/d) = ',i4,2('/',i2.2),6x, & - 'used = ',i4,2('/',i2.2),6x ) - -end subroutine print_dates - -!####################################################################### - -subroutine zonal_sst (Time, ice, sst) - - type (time_type), intent(in) :: Time - real, intent(out) :: ice(mobs,nobs), sst(mobs,nobs) - - real :: tpi, fdate, eps, ph, sph, sph2, ts - integer :: j - -! namelist needed -! -! teq = sst at equator -! tdif = equator to pole sst difference -! tann = amplitude of annual cycle -! tlag = offset for time of year (for annual cycle) -! - - tpi = 2.0*pi - - fdate = fraction_of_year (Time) - - eps = sin( tpi*(fdate-tlag) ) * tann - - do j = 1, nobs - - ph = 0.5*(lat_bnd(j)+lat_bnd(j+1)) - sph = sin(ph) - sph2 = sph*sph - - ts = teq - tdif*sph2 - eps*sph - - sst(:,j) = ts - - enddo - - where ( sst < tice_crit_k ) - ice = 1.0 - sst = tice_crit_k - elsewhere - ice = 0.0 - endwhere - - -end subroutine zonal_sst - -!####################################################################### - -subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) +subroutine amip_interp_type_eq (amip_interp_out, amip_interp_in) type(amip_interp_type), intent(inout) :: amip_interp_out type(amip_interp_type), intent(in) :: amip_interp_in @@ -1539,8 +661,10 @@ subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) amip_interp_out%Hintrp = amip_interp_in%Hintrp amip_interp_out%Hintrp2 = amip_interp_in%Hintrp2 !< missing assignment statement; added by GPP - amip_interp_out%data1 = amip_interp_in%data1 - amip_interp_out%data2 = amip_interp_in%data2 + amip_interp_out%data1_r4 = amip_interp_in%data1_r4 + amip_interp_out%data1_r8 = amip_interp_in%data1_r8 + amip_interp_out%data2_r4 = amip_interp_in%data2_r4 + amip_interp_out%data2_r8 = amip_interp_in%data2_r8 amip_interp_out%Date1 = amip_interp_in%Date1 amip_interp_out%Date2 = amip_interp_in%Date2 amip_interp_out%Date1 = amip_interp_in%Date1 @@ -1548,10 +672,10 @@ subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) amip_interp_out%use_climo = amip_interp_in%use_climo amip_interp_out%use_annual = amip_interp_in%use_annual amip_interp_out%I_am_initialized = .true. - end subroutine amip_interp_type_eq -!####################################################################### +#include "amip_interp_r4.fh" +#include "amip_interp_r8.fh" end module amip_interp_mod !> @} diff --git a/amip_interp/include/amip_interp.inc b/amip_interp/include/amip_interp.inc new file mode 100644 index 0000000000..af8e7487b5 --- /dev/null +++ b/amip_interp/include/amip_interp.inc @@ -0,0 +1,810 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +! modified by JHC +!> Retrieve sea surface temperature data and interpolated grid +subroutine GET_AMIP_SST_ (Time, Interp, sst, err_msg, lon_model, lat_model) + type (time_type), intent(in) :: Time !< Time to interpolate + type (amip_interp_type), target, intent(inout) :: Interp !< Holds data for interpolation + real(FMS_AMIP_INTERP_KIND_), intent(out) :: sst(:,:) !< Sea surface temperature data + character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present + + real(FMS_AMIP_INTERP_KIND_), dimension(mobs,nobs) :: sice + real(FMS_AMIP_INTERP_KIND_), allocatable, save :: temp1(:,:), temp2(:,:) + + integer :: year1, year2, month1, month2 + real(FMS_AMIP_INTERP_KIND_) :: fmonth + type (date_type) :: Date1, Date2, Udate1, Udate2 + + type(time_type) :: Amip_Time + integer :: tod(3),dum(3) + +! add by JHC + real(FMS_AMIP_INTERP_KIND_), intent(in), dimension(:,:), optional :: lon_model, lat_model + real(FMS_AMIP_INTERP_KIND_) :: pert + integer :: i, j, mobs_sst, nobs_sst + integer :: jhctod(6) + type (time_type) :: Udate + character(len=4) :: yyyy + integer :: nrecords, ierr, k, yr, mo, dy + integer, dimension(:), allocatable :: ryr, rmo, rdy + character(len=30) :: time_unit + real(FMS_AMIP_INTERP_KIND_), dimension(:), allocatable :: timeval + character(len=maxc) :: ncfilename + type(FmsNetcdfFile_t) :: fileobj + logical :: the_file_exists +! end add by JHC + logical, parameter :: DEBUG = .false. !> switch for debugging output + !> These are fms_io specific + integer :: unit + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('get_amip_sst','The amip_interp_type variable is not initialized',err_msg)) return + endif + +!----------------------------------------------------------------------- +!----- compute zonally symetric sst --------------- + + if ( use_ncep_sst .and. forecast_mode ) no_anom_sst = .false. + + if (all(amip_date>0)) then + call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) + Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) + else + Amip_Time = Time + endif + +! add by JHC +if ( .not.use_daily ) then +! end add by JHC + + if ( .not. allocated(temp1) ) allocate (temp1(mobs,nobs)) + if ( .not. allocated(temp2) ) allocate (temp2(mobs,nobs)) + + if (use_zonal) then + call ZONAL_SST_ (Amip_Time, sice, temp1) + call horiz_interp (Interp%Hintrp, temp1, sst) + else + +!----------------------------------------------------------------------- +!---------- get new observed sea surface temperature ------------------- + +! ---- time interpolation for months ----- + call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) +! ---- force climatology ---- + if (Interp%use_climo) then + year1=0; year2=0 + endif + if (Interp%use_annual) then + year1=0; year2=0 + month1=0; month2=0 + endif +! --------------------------- + + Date1 = date_type( year1, month1, 0 ) + Date2 = date_type( year2, month2, 0 ) + +! -- open/rewind file -- + unit = -1 +!----------------------------------------------------------------------- + + if (Date1 /= Interp%Date1) then +! ---- use Date2 for Date1 ---- + if (Date1 == Interp%Date2) then + Interp%Date1 = Interp%Date2 + Interp%DATA1_ = Interp%DATA2_ + temp1(:,:) = temp2(:,:) ! SJL BUG fix: June 24, 2011 + else + call READ_RECORD_ ('sst', Date1, Udate1, temp1) + if ( use_ncep_sst .and. (.not. no_anom_sst) ) then + temp1 = temp1 + SST_ANOM_ + endif + call horiz_interp ( Interp%Hintrp, temp1, Interp%DATA1_) + call CLIP_DATA_ ('sst', Interp%DATA1_) + Interp%Date1 = Date1 + endif + endif + +!----------------------------------------------------------------------- + + if (Date2 /= Interp%Date2) then + call READ_RECORD_ ('sst', Date2, Udate2, temp2) + if ( use_ncep_sst .and. (.not. no_anom_sst) ) then + temp2 = temp2 + SST_ANOM_ + endif + call horiz_interp ( Interp%Hintrp, temp2, Interp%DATA2_) + call CLIP_DATA_ ('sst', Interp%DATA2_) + Interp%Date2 = Date2 + endif + +!----------------------------------------------------------------------- +!---------- time interpolation (between months) of sst's --------------- +!----------------------------------------------------------------------- + sst = Interp%DATA1_ + fmonth * (Interp%DATA2_ - Interp%DATA1_) + +!------------------------------------------------------------------------------- +! SJL mods for NWP and TCSF --- +! Nudging runs: (Note: NCEP SST updated only every 6-hr) +! Compute SST anomaly from global SST datasets for subsequent forecast runs +!------------------------------------------------------------------------------- + if ( use_ncep_sst .and. no_anom_sst ) then + sst_anom = SST_NCEP_ - (temp1 + fmonth*(temp2 - temp1)) + call horiz_interp (Interp%Hintrp, SST_NCEP_, sst) + call CLIP_DATA_ ('sst', sst) + endif + +!! DEBUG CODE + if (DEBUG) then + call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + if (mpp_pe() == 0) then + write (*,200) 'JHC: use_daily = F, AMIP_Time: ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5), & + & jhctod(6) + write (*,300) 'JHC: use_daily = F, interped SST: ', sst(1,1),sst(5,5),sst(10,10) + endif + endif + + + endif + +! add by JHC +else + call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + if (mpp_pe() == mpp_root_pe()) write(*,200) 'amip_interp_mod: use_daily = T, Amip_Time = ',jhctod(1), & + & jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) + + yr = jhctod(1); mo = jhctod(2); dy = jhctod(3) + + write (yyyy,'(i4)') jhctod(1) + + file_name_sst = 'INPUT/' // 'sst.day.mean.'//yyyy//'.v2.nc' + ncfilename = trim(file_name_sst) + time_unit = 'days since 1978-01-01 00:00:00' + + mobs_sst = 1440; nobs_sst = 720 + + call SET_SST_GRID_EDGES_DAILY_ (mobs_sst, nobs_sst) + call horiz_interp_new ( Interp%Hintrp2, LON_BND_, LAT_BND_, & + lon_model, lat_model, interp_method="bilinear" ) + + the_file_exists = fms2_io_file_exists(ncfilename) + + if ( (.NOT. the_file_exists) ) then + call mpp_error ('amip_interp_mod', & + 'cannot find daily SST input data file: '//trim(ncfilename), NOTE) + else + if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & + 'Reading NetCDF formatted daily SST from: '//trim(ncfilename), NOTE) + + if(.not. open_file(fileobj, trim(ncfilename), 'read')) & + call error_mesg ('get_amip_sst', 'Error in opening file '//trim(ncfilename), FATAL) + + call get_dimension_size(fileobj, 'TIME', nrecords) + if (nrecords < 1) call mpp_error('amip_interp_mod', & + 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL) + allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords)) + call fms2_io_read_data(fileobj, 'TIME', timeval) +!!! DEBUG CODE + if(DEBUG) then + if (mpp_pe() == 0) then + print *, 'JHC: nrecords = ', nrecords + print *, 'JHC: TIME = ', timeval + endif + endif + + ierr = 1 + do k = 1, nrecords + + Udate = get_cal_time (timeval(k), time_unit, 'julian') + call get_date(Udate,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + ryr(k) = jhctod(1); rmo(k) = jhctod(2); rdy(k) = jhctod(3) + + if ( yr == ryr(k) .and. mo == rmo(k) .and. dy == rdy (k) ) ierr = 0 + if (ierr==0) exit + + enddo + + if(DEBUG) then + if (mpp_pe() == 0) then + print *, 'JHC: k =', k + print *, 'JHC: ryr(k) rmo(k) rdy(k)',ryr(k), rmo(k), rdy(k) + print *, 'JHC: yr mo dy ',yr, mo, dy + endif + endif + + if (ierr .ne. 0) call mpp_error('amip_interp_mod', & + 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) + endif ! if(file_exist(ncfilename)) + + + !---- read NETCDF data ---- + if ( .not. allocated(tempamip) ) & + & allocate (tempamip(mobs_sst,nobs_sst)) + + if (the_file_exists) then + call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k) + call close_file(fileobj) + tempamip = tempamip + TFREEZE + +!!! DEBUG CODE + if(DEBUG) then + if (mpp_pe() == 0) then + print*, 'JHC: TFREEZE = ', real(TFREEZE, FMS_AMIP_INTERP_KIND_) + print*, lbound(sst) + print*, ubound(sst) + print*, lbound(tempamip) + print*, ubound(tempamip) + write(*,300) 'JHC: tempamip : ', tempamip(100,100), tempamip(200,200), tempamip(300,300) + endif + endif + + call horiz_interp ( Interp%Hintrp2, TEMPAMIP_, sst ) + call CLIP_DATA_ ('sst', sst) + + endif + + if(DEBUG) then + if (mpp_pe() == 400) then + write(*,300)'JHC: use_daily = T, daily SST: ', sst(1,1),sst(5,5),sst(10,10) + print *,'JHC: use_daily = T, daily SST: ', sst + endif + endif + +200 format(a35, 6(i5,1x)) +300 format(a35, 3(f7.3,2x)) + +endif +! end add by JHC + +! add by JHC: add on non-zero sea surface temperature perturbation (namelist option) +! This perturbation may be useful in accessing model sensitivities + + if ( do_sst_pert ) then + + if ( trim(sst_pert_type) == 'fixed' ) then + sst = sst + real(sst_pert, FMS_AMIP_INTERP_KIND_) + else if ( trim(sst_pert_type) == 'random' ) then + call random_seed() + + if(DEBUG) then + if (mpp_pe() == 0) then + print*, 'mobs = ', mobs + print*, 'nobs = ', nobs + print*, lbound(sst) + print*, ubound(sst) + endif + endif + + do i = 1, size(sst,1) + do j = 1, size(sst,2) + call random_number(pert) + sst (i,j) = sst (i,j) + real(sst_pert, FMS_AMIP_INTERP_KIND_)*((pert-0.5_lkind)*2) + end do + end do + endif + + endif +! end add by JHC + end subroutine GET_AMIP_SST_ + +!> AMIP interpolation for ice +subroutine GET_AMIP_ICE_ (Time, Interp, ice, err_msg) + type (time_type), intent(in) :: Time !< Time to interpolate + type (amip_interp_type), target, intent(inout) :: Interp !< Holds data for interpolation + real(FMS_AMIP_INTERP_KIND_), intent(out) :: ice(:,:) !< ice data + character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present + + real(FMS_AMIP_INTERP_KIND_), dimension(mobs,nobs) :: sice, temp + + integer :: year1, year2, month1, month2 + real(FMS_AMIP_INTERP_KIND_) :: fmonth + type (date_type) :: Date1, Date2, Udate1, Udate2 + + type(time_type) :: Amip_Time + integer :: tod(3),dum(3) + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('get_amip_ice','The amip_interp_type variable is not initialized',err_msg)) return + endif + +!----------------------------------------------------------------------- +!----- compute zonally symetric sst --------------- + + + if (any(amip_date>0)) then + + call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) + + Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) + + else + + Amip_Time = Time + + endif + + +if (use_zonal) then + call ZONAL_SST_ (Amip_Time, sice, temp) + call horiz_interp ( Interp%Hintrp, sice, ice ) +else + +!----------------------------------------------------------------------- +!---------- get new observed sea surface temperature ------------------- + +! ---- time interpolation for months ----- + + call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) + +! ---- force climatology ---- + if (Interp%use_climo) then + year1=0; year2=0 + endif + if (Interp%use_annual) then + year1=0; year2=0 + month1=0; month2=0 + endif +! --------------------------- + + Date1 = date_type( year1, month1, 0 ) + Date2 = date_type( year2, month2, 0 ) + + unit = -1 +!----------------------------------------------------------------------- + + if (Date1 /= Interp%Date1) then +! ---- use Date2 for Date1 ---- + if (Date1 == Interp%Date2) then + Interp%Date1 = Interp%Date2 + Interp%DATA1_ = Interp%DATA2_ + else +!-- SJL ------------------------------------------------------------- +! Can NOT use ncep_sst to determine sea_ice For seasonal forecast +! Use climo sea ice for seasonal runs + if ( use_ncep_sst .and. use_ncep_ice ) then + where ( SST_NCEP_ <= (real(TFREEZE, FMS_AMIP_INTERP_KIND_)+real(tice_crit, FMS_AMIP_INTERP_KIND_)) ) + sice = 1._lkind + elsewhere + sice = 0._lkind + endwhere + else + call READ_RECORD_ ('ice', Date1, Udate1, sice) + endif +!-------------------------------------------------------------------- + call horiz_interp ( Interp%Hintrp, sice, Interp%DATA1_) + call CLIP_DATA_ ('ice', Interp%DATA1_) + Interp%Date1 = Date1 + endif + endif + +!----------------------------------------------------------------------- + + if (Date2 /= Interp%Date2) then + +!-- SJL ------------------------------------------------------------- + if ( use_ncep_sst .and. use_ncep_ice ) then + where ( SST_NCEP_ <= (real(TFREEZE, FMS_AMIP_INTERP_KIND_)+real(tice_crit, FMS_AMIP_INTERP_KIND_)) ) + sice = 1._lkind + elsewhere + sice = 0._lkind + endwhere + else + call READ_RECORD_ ('ice', Date2, Udate2, sice) + endif +!-------------------------------------------------------------------- + call horiz_interp ( Interp%Hintrp, sice, Interp%DATA2_) + call CLIP_DATA_ ('ice', Interp%DATA2_) + Interp%Date2 = Date2 + + endif + +!----------------------------------------------------------------------- +!---------- time interpolation (between months) ------------------------ +!----------------------------------------------------------------------- + + ice = Interp%DATA1_ + fmonth * (Interp%DATA2_ - Interp%DATA1_) + +endif + end subroutine GET_AMIP_ICE_ + + !> @return A newly created @ref amip_interp_type + function AMIP_INTERP_NEW_1D_ ( lon , lat , mask , use_climo, use_annual, & + interp_method ) result (Interp) + real(FMS_AMIP_INTERP_KIND_), intent(in), dimension(:) :: lon, lat + logical, intent(in), dimension(:,:) :: mask + character(len=*), intent(in), optional :: interp_method + logical, intent(in), optional :: use_climo, use_annual + + type (amip_interp_type) :: Interp + + if(.not.module_is_initialized) call amip_interp_init + + Interp%use_climo = .false. + if (present(use_climo)) Interp%use_climo = use_climo + Interp%use_annual = .false. + if (present(use_annual)) Interp%use_annual = use_annual + + if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & + call error_mesg ('amip_interp_new_1d', 'use_climo mismatch', FATAL) + + if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & + call error_mesg ('amip_interp_new_1d', 'use_annual(climo) mismatch', FATAL) + + Interp%Date1 = date_type( -99, -99, -99 ) + Interp%Date2 = date_type( -99, -99, -99 ) + +!----------------------------------------------------------------------- +! ---- initialization of horizontal interpolation ---- + + call horiz_interp_new ( Interp%Hintrp, LON_BND_, LAT_BND_, & + lon, lat, interp_method= interp_method ) + + allocate(Interp%DATA1_ (size(lon(:))-1,size(lat(:))-1)) + allocate(Interp%DATA2_ (size(lon(:))-1,size(lat(:))-1)) + + Interp%I_am_initialized = .true. + end function AMIP_INTERP_NEW_1D_ + + !> @return A newly created @ref amip_interp_type + function AMIP_INTERP_NEW_2D_ ( lon , lat , mask , use_climo, use_annual, & + interp_method ) result (Interp) + real(FMS_AMIP_INTERP_KIND_), intent(in), dimension(:,:) :: lon, lat + logical, intent(in), dimension(:,:) :: mask + character(len=*), intent(in), optional :: interp_method + logical, intent(in), optional :: use_climo, use_annual + + type (amip_interp_type) :: Interp + + if(.not.module_is_initialized) call amip_interp_init + + Interp%use_climo = .false. + if (present(use_climo)) Interp%use_climo = use_climo + Interp%use_annual = .false. + if (present(use_annual)) Interp%use_annual = use_annual + + if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & + call error_mesg ('amip_interp_new_2d', 'use_climo mismatch', FATAL) + + if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & + call error_mesg ('amip_interp_new_2d', 'use_annual(climo) mismatch', FATAL) + + Interp%Date1 = date_type( -99, -99, -99 ) + Interp%Date2 = date_type( -99, -99, -99 ) + +!----------------------------------------------------------------------- +! ---- initialization of horizontal interpolation ---- + + call horiz_interp_new ( Interp%Hintrp, LON_BND_, LAT_BND_, & + lon, lat, interp_method = interp_method) + + allocate(Interp%DATA1_ (size(lon,1),size(lat,2))) + allocate(Interp%DATA2_ (size(lon,1),size(lat,2))) + + Interp%I_am_initialized = .true. + end function AMIP_INTERP_NEW_2D_ + +! add by JHC + subroutine SET_SST_GRID_EDGES_DAILY_ (mobs_sst, nobs_sst) + integer :: i, j, mobs_sst, nobs_sst + real(FMS_AMIP_INTERP_KIND_) :: hpie, dlon, dlat, wb, sb + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) + + allocate(lon_bnd(mobs_sst+1)) + allocate(lat_bnd(nobs_sst+1)) + +! ---- compute grid edges (do only once) ----- + + hpie = pi / 2._r8_kind + dlon = 4._r8_kind*hpie/real(mobs_sst, r8_kind) + wb = 0.0_r8_kind + + lon_bnd(1) = wb + do i = 2, mobs_sst+1 + lon_bnd(i) = wb + dlon * real(i-1, r8_kind) + enddo + lon_bnd(mobs_sst+1) = lon_bnd(1) + 4._r8_kind*hpie + + dlat = 2._r8_kind*hpie/real(nobs_sst, r8_kind) + sb = -hpie + + lat_bnd(1) = sb + lat_bnd(nobs_sst+1) = hpie + do j = 2, nobs_sst + lat_bnd(j) = sb + dlat * real(j-1, r8_kind) + enddo + end subroutine SET_SST_GRID_EDGES_DAILY_ +! end add by JHC + + subroutine A2A_BILINEAR_ (nx, ny, dat1, n1, n2, dat2) + integer, intent(in) :: nx, ny + integer, intent(in) :: n1, n2 + real(FMS_AMIP_INTERP_KIND_), intent(in) :: dat1(nx,ny) + real(FMS_AMIP_INTERP_KIND_), intent(out) :: dat2(n1,n2) !> output interpolated data + +! local: + real(FMS_AMIP_INTERP_KIND_) :: lon1(nx), lat1(ny) + real(FMS_AMIP_INTERP_KIND_) :: lon2(n1), lat2(n2) + real(FMS_AMIP_INTERP_KIND_) :: dx1, dy1, dx2, dy2 + real(FMS_AMIP_INTERP_KIND_) :: xc, yc + real(FMS_AMIP_INTERP_KIND_) :: a1, b1, c1, c2, c3, c4 + integer :: i1, i2, jc, i0, j0, it, jt + integer :: i, j + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + +!----------------------------------------------------------- +! * Interpolate from "FMS" 1x1 SST data grid to a finer grid +! lon: 0.5, 1.5, ..., 359.5 +! lat: -89.5, -88.5, ... , 88.5, 89.5 +!----------------------------------------------------------- + + dx1 = 360._lkind/real(nx, FMS_AMIP_INTERP_KIND_) !> INput Grid + dy1 = 180._lkind/real(ny, FMS_AMIP_INTERP_KIND_) !> INput Grid + + do i=1,nx + lon1(i) = 0.5_lkind*dx1 + real(i-1, FMS_AMIP_INTERP_KIND_)*dx1 + enddo + do j=1,ny + lat1(j) = -90._lkind + 0.5_lkind*dy1 + real(j-1, FMS_AMIP_INTERP_KIND_)*dy1 + enddo + + dx2 = 360._lkind/real(n1, FMS_AMIP_INTERP_KIND_) !> OutPut Grid: + dy2 = 180._lkind/real(n2, FMS_AMIP_INTERP_KIND_) !> OutPut Grid: + + do i=1,n1 + lon2(i) = 0.5_lkind*dx2 + real(i-1, FMS_AMIP_INTERP_KIND_)*dx2 + enddo + do j=1,n2 + lat2(j) = -90._lkind + 0.5_lkind*dy2 + real(j-1, FMS_AMIP_INTERP_KIND_)*dy2 + enddo + + jt = 1 + do 5000 j=1,n2 + + yc = lat2(j) + if ( yclat1(ny) ) then + jc = ny-1 + b1 = 1._lkind + else + do j0=jt,ny-1 + if ( yc>=lat1(j0) .and. yc<=lat1(j0+1) ) then + jc = j0 + jt = j0 + b1 = (yc-lat1(jc)) / dy1 + go to 222 + endif + enddo + endif +222 continue + + it = 1 + do i=1,n1 + xc = lon2(i) + if ( xc>lon1(nx) ) then + i1 = nx; i2 = 1 + a1 = (xc-lon1(nx)) / dx1 + elseif ( xc=lon1(i0) .and. xc<=lon1(i0+1) ) then + i1 = i0; i2 = i0+1 + it = i0 + a1 = (xc-lon1(i1)) / dx1 + go to 111 + endif + enddo + endif +111 continue + +! Debug code: + if ( a1<-0.001_lkind .or. a1>1.001_lkind .or. b1<-0.001_lkind .or. b1>1.001_lkind ) then + write(*,*) i,j,a1, b1 + call mpp_error(FATAL,'a2a bilinear interpolation') + endif + + c1 = (1._lkind-a1) * (1._lkind-b1) + c2 = a1 * (1._lkind-b1) + c3 = a1 * b1 + c4 = (1._lkind-a1) * b1 + +! Bilinear interpolation: + dat2(i,j) = c1*dat1(i1,jc) + c2*dat1(i2,jc) + c3*dat1(i2,jc+1) + c4*dat1(i1,jc+1) + + enddo !i-loop + +5000 continue ! j-loop + end subroutine A2A_BILINEAR_ + + subroutine READ_RECORD_ (type, Date, Adate, dat) + character(len=*), intent(in) :: type + type (date_type), intent(in) :: Date + type (date_type), intent(inout) :: Adate + real(FMS_AMIP_INTERP_KIND_), intent(out) :: dat(mobs,nobs) + real(FMS_AMIP_INTERP_KIND_) :: tmp_dat(360,180) + + integer(I2_KIND) :: idat(mobs,nobs) + integer :: nrecords, yr, mo, dy, ierr, k + integer, dimension(:), allocatable :: ryr, rmo, rdy + character(len=maxc) :: ncfilename, ncfieldname + type(FmsNetcdfFile_t), pointer :: fileobj + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + !---- set file and field name for NETCDF data sets ---- + + ncfieldname = 'sst' + if(type(1:3) == 'sst') then + ncfilename = trim(file_name_sst) + fileobj => fileobj_sst + else if(type(1:3) == 'ice') then + ncfilename = trim(file_name_ice) + fileobj => fileobj_ice + if (lowercase(trim(data_set)) == 'amip2' .or. & + lowercase(trim(data_set)) == 'hurrell' .or. & + lowercase(trim(data_set)) == 'daily') ncfieldname = 'ice' ! modified by JHC + endif + + dy = 0 ! only processing monthly data + + if (verbose > 2 .and. mpp_pe() == 0) & + print *, 'looking for date = ', Date + + ! This code can handle amip1, reynolds, or reyoi type SST data files in netCDF format + if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & + 'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE) + + call fms2_io_read_data (fileobj, 'nrecords', nrecords) + if (nrecords < 1) call mpp_error('amip_interp_mod', & + 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL) + allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords)) + call fms2_io_read_data(fileobj, 'yr', ryr) + call fms2_io_read_data(fileobj, 'mo', rmo) + call fms2_io_read_data(fileobj, 'dy', rdy) + + ierr = 1 + do k = 1, nrecords + yr = ryr(k); mo = rmo(k) + Adate = date_type( yr, mo, 0) + Curr_date = Adate + if (verbose > 2 .and. mpp_pe() == 0) & + print *, '....... checking ', Adate + if (Date == Adate) ierr = 0 + if (yr == 0 .and. mo == Date%month) ierr = 0 + if (ierr == 0) exit + enddo + if (ierr .ne. 0) call mpp_error('amip_interp_mod', & + 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) + deallocate(ryr, rmo, rdy) + !PRINT *, 'New SST data: ', k, yr, mo, dy, Date%year, Date%month, Date%day, ryr(1), rmo(1) + + !---- check if climatological data should be used ---- + + if (yr == 0 .or. mo == 0) then + ierr = 0 + if (date_out_of_range == 'fail' ) ierr = 1 + if (date_out_of_range == 'initclimo' .and. & + Date > Date_end ) ierr = 1 + if (ierr /= 0) call error_mesg & + ('read_record in amip_interp_mod', & + 'climo data read when NO climo data requested', FATAL) + endif + + !---- read NETCDF data ---- + + if ( interp_oi_sst ) then + call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k) +! interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation) + if ( mobs/=360 .or. nobs/=180 ) then + call A2A_BILINEAR_ (360, 180, tmp_dat, mobs, nobs, dat) + else + dat(:,:) = tmp_dat(:,:) + endif + else + call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) + endif + !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._lkind, I2_KIND) + + !---- unpacking of data ---- + + if (type(1:3) == 'ice') then + !---- create fractional [0,1] ice mask + if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then + where ( idat <= ice_crit ) + dat = 1._lkind + elsewhere + dat = 0._lkind + endwhere + else + dat = dat*0.01_lkind + endif + else if (type(1:3) == 'sst') then + !---- unpack sst ---- + if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then + dat = real(idat, FMS_AMIP_INTERP_KIND_)*0.01_lkind + real(TFREEZE, FMS_AMIP_INTERP_KIND_) + endif + endif + + return + end subroutine READ_RECORD_ + + subroutine CLIP_DATA_ (type, dat) + character(len=*), intent(in) :: type + real(FMS_AMIP_INTERP_KIND_), intent(inout) :: dat(:,:) + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if (type(1:3) == 'ice') then + dat = min(max(dat,0.0_lkind), 1.0_lkind) + else if (type(1:3) == 'sst') then + dat = max(real(tice_crit_k, FMS_AMIP_INTERP_KIND_),dat) + endif + end subroutine CLIP_DATA_ + +subroutine ZONAL_SST_ (Time, ice, sst) + type (time_type), intent(in) :: Time + real(FMS_AMIP_INTERP_KIND_), intent(out) :: ice(mobs,nobs), sst(mobs,nobs) + real(FMS_AMIP_INTERP_KIND_) :: tpi, fdate, eps, ph, sph, sph2, ts + integer :: j + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + +! namelist needed +! +! teq = sst at equator +! tdif = equator to pole sst difference +! tann = amplitude of annual cycle +! tlag = offset for time of year (for annual cycle) +! + + tpi = 2.0_lkind*real(pi, FMS_AMIP_INTERP_KIND_) + + fdate = fraction_of_year (Time) + + eps = sin( tpi*(fdate-real(tlag, FMS_AMIP_INTERP_KIND_)) ) * real(tann, FMS_AMIP_INTERP_KIND_) + + do j = 1, nobs + + ph = 0.5_lkind * real(lat_bnd(j)+lat_bnd(j+1), FMS_AMIP_INTERP_KIND_) + sph = sin(ph) + sph2 = sph*sph + + ts = real(teq, FMS_AMIP_INTERP_KIND_) - real(tdif, FMS_AMIP_INTERP_KIND_)*sph2 - eps*sph + + sst(:,j) = ts + + enddo + + where ( sst < real(tice_crit_k, FMS_AMIP_INTERP_KIND_) ) + ice = 1.0_lkind + sst = real(tice_crit_k, FMS_AMIP_INTERP_KIND_) + elsewhere + ice = 0.0_lkind + endwhere +end subroutine ZONAL_SST_ diff --git a/amip_interp/include/amip_interp_r4.fh b/amip_interp/include/amip_interp_r4.fh new file mode 100644 index 0000000000..ab4ddd3257 --- /dev/null +++ b/amip_interp/include/amip_interp_r4.fh @@ -0,0 +1,58 @@ +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ + +#define FMS_AMIP_INTERP_KIND_ r4_kind +#define SST_NCEP_ real(sst_ncep, r4_kind) +#define SST_ANOM_ real(sst_anom, r4_kind) +#define LON_BND_ real(lon_bnd, r4_kind) +#define LAT_BND_ real(lat_bnd, r4_kind) +#define TEMPAMIP_ real(tempamip, r4_kind) +#define DATA1_ data1_r4 +#define DATA2_ data2_r4 + +#define GET_AMIP_SST_ get_amip_sst_r4 +#define GET_AMIP_ICE_ get_amip_ice_r4 +#define AMIP_INTERP_NEW_1D_ amip_interp_new_1d_r4 +#define AMIP_INTERP_NEW_2D_ amip_interp_new_2d_r4 +#define SET_SST_GRID_EDGES_DAILY_ set_sst_grid_edges_daily_r4 +#define A2A_BILINEAR_ a2a_bilinear_r4 +#define READ_RECORD_ read_record_r4 +#define CLIP_DATA_ clip_data_r4 +#define ZONAL_SST_ zonal_sst_r4 + +#include "amip_interp.inc" + +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ diff --git a/amip_interp/include/amip_interp_r8.fh b/amip_interp/include/amip_interp_r8.fh new file mode 100644 index 0000000000..b132f64bd5 --- /dev/null +++ b/amip_interp/include/amip_interp_r8.fh @@ -0,0 +1,58 @@ +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ + +#define FMS_AMIP_INTERP_KIND_ r8_kind +#define SST_NCEP_ sst_ncep +#define SST_ANOM_ sst_anom +#define LON_BND_ lon_bnd +#define LAT_BND_ lat_bnd +#define TEMPAMIP_ tempamip +#define DATA1_ data1_r8 +#define DATA2_ data2_r8 + +#define GET_AMIP_SST_ get_amip_sst_r8 +#define GET_AMIP_ICE_ get_amip_ice_r8 +#define AMIP_INTERP_NEW_1D_ amip_interp_new_1d_r8 +#define AMIP_INTERP_NEW_2D_ amip_interp_new_2d_r8 +#define SET_SST_GRID_EDGES_DAILY_ set_sst_grid_edges_daily_r8 +#define A2A_BILINEAR_ a2a_bilinear_r8 +#define READ_RECORD_ read_record_r8 +#define CLIP_DATA_ clip_data_r8 +#define ZONAL_SST_ zonal_sst_r8 + +#include "amip_interp.inc" + +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ diff --git a/column_diagnostics/Makefile.am b/column_diagnostics/Makefile.am index af368bc14f..c205abbb4d 100644 --- a/column_diagnostics/Makefile.am +++ b/column_diagnostics/Makefile.am @@ -23,14 +23,22 @@ # 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)/column_diagnostics/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. noinst_LTLIBRARIES = libcolumn_diagnostics.la # The convenience library depends on its source. -libcolumn_diagnostics_la_SOURCES = column_diagnostics.F90 +libcolumn_diagnostics_la_SOURCES = column_diagnostics.F90 \ +include/column_diagnostics.inc \ +include/column_diagnostics_r4.fh \ +include/column_diagnostics_r8.fh + +column_diagnostics.$(FC_MOD_EXT):\ +include/column_diagnostics.inc \ +include/column_diagnostics_r4.fh \ +include/column_diagnostics_r8.fh BUILT_SOURCES = column_diagnostics_mod.$(FC_MODEXT) nodist_include_HEADERS = column_diagnostics_mod.$(FC_MODEXT) diff --git a/column_diagnostics/column_diagnostics.F90 b/column_diagnostics/column_diagnostics.F90 index 2254f32b6a..b75ffd3698 100644 --- a/column_diagnostics/column_diagnostics.F90 +++ b/column_diagnostics/column_diagnostics.F90 @@ -32,7 +32,7 @@ module column_diagnostics_mod get_date, time_type use constants_mod, only: constants_init, PI, RADIAN use mpp_mod, only: input_nml_file - +use platform_mod, only: r4_kind, r8_kind !------------------------------------------------------------------- implicit none @@ -64,23 +64,34 @@ module column_diagnostics_mod column_diagnostics_header, & close_column_diagnostics_units + +interface initialize_diagnostic_columns + module procedure initialize_diagnostic_columns_r4 + module procedure initialize_diagnostic_columns_r8 +end interface initialize_diagnostic_columns + +interface column_diagnostics_header + module procedure column_diagnostics_header_r4 + module procedure column_diagnostics_header_r8 +end interface column_diagnostics_header + !private !-------------------------------------------------------------------- !---- namelist ----- -real :: crit_xdistance = 4.0 !< model grid points must be within crit_xdistance in +real(kind=r8_kind) :: crit_xdistance = 4.0_r8_kind !< model grid points must be within crit_xdistance in !! longitude of the requested diagnostics point !! coordinates in order to be flagged as the desired !! point !! [ degrees ] -real :: crit_ydistance = 4.0 !< model grid points must be within crit_ydistance in +real(kind=r8_kind) :: crit_ydistance = 4.0_r8_kind !< model grid points must be within crit_ydistance in !! latitude of the requested diagnostics point !! coordinates in order to be flagged as the desired !! point !! [ degrees ] -namelist / column_diagnostics_nml / & +namelist / column_diagnostics_nml / & crit_xdistance, & crit_ydistance @@ -163,387 +174,6 @@ subroutine column_diagnostics_init end subroutine column_diagnostics_init - -!#################################################################### - -!> @brief initialize_diagnostic_columns returns the (i, j, lat, lon) coord- -!! inates of any diagnostic columns that are located on the current -!! processor. -subroutine initialize_diagnostic_columns & - (module, num_diag_pts_latlon, num_diag_pts_ij, & - global_i , global_j , global_lat_latlon, & - global_lon_latlon, lonb_in, latb_in, & - do_column_diagnostics, & - diag_lon, diag_lat, diag_i, diag_j, diag_units) - -!--------------------------------------------------------------------- -! initialize_diagnostic_columns returns the (i, j, lat, lon) coord- -! inates of any diagnostic columns that are located on the current -! processor. -!---------------------------------------------------------------------- - -!--------------------------------------------------------------------- -character(len=*), intent(in) :: module !< module calling this subroutine -integer, intent(in) :: num_diag_pts_latlon !< number of diagnostic columns specified - !! by lat-lon coordinates -integer, intent(in) :: num_diag_pts_ij !< number of diagnostic columns specified - !! by global (i,j) coordinates -integer, dimension(:), intent(in) :: global_i !< specified global i coordinates -integer, dimension(:), intent(in) :: global_j !< specified global j coordinates -real , dimension(:), intent(in) :: global_lat_latlon !< specified global lat coordinates -real , dimension(:), intent(in) :: global_lon_latlon !< specified global lon coordinates -real, dimension(:,:), intent(in) :: lonb_in, latb_in -logical, dimension(:,:), intent(out) :: do_column_diagnostics !< is a diagnostic column in this jrow ? -integer, dimension(:), intent(inout) :: diag_i !< processor i indices of diagnstic columns -integer, dimension(:), intent(inout) :: diag_j !< processor j indices of diagnstic columns -real , dimension(:), intent(out) :: diag_lat !< latitudes of diagnostic columns [ degrees ] -real , dimension(:), intent(out) :: diag_lon !< longitudes of diagnostic columns [ degrees ] -integer, dimension(:), intent(out) :: diag_units !< unit number for each diagnostic column -!--------------------------------------------------------------------- - -!--------------------------------------------------------------------- -! intent(in) variables: -! -! module module calling this subroutine -! num_diag_pts_latlon number of diagnostic columns specified -! by lat-lon coordinates -! num_diag_pts_ij number of diagnostic columns specified -! by global (i,j) coordinates -! global_i specified global i coordinates -! global_j specified global j coordinates -! global_lat_latlon specified global lat coordinates -! global_lon_latlon specified global lon coordinates -! -! intent(out) variables: -! -! do_column_diagnostics is a diagnostic column in this jrow ? -! diag_i processor i indices of diagnstic columns -! diag_j processor j indices of diagnstic columns -! diag_lat latitudes of diagnostic columns -! [ degrees ] -! diag_lon longitudes of diagnostic columns -! [ degrees ] -! diag_units unit number for each diagnostic column -! -!--------------------------------------------------------------------- - -!-------------------------------------------------------------------- -! local variables: - - real, dimension(size(diag_i,1)) :: global_lat !< latitudes for all diagnostic columns [ degrees ] - real, dimension(size(diag_i,1)) :: global_lon !< longitudes for all diagnostic columns [ degrees ] - real, dimension(size(latb_in,1)-1, size(latb_in,2)-1) :: & - distance, distance_x, distance_y, & - distance_x2, distance2 - real, dimension(size(latb_in,1), size(latb_in,2)) :: latb_deg - real, dimension(size(lonb_in,1), size(lonb_in,2)) :: lonb_deg - real :: dellat, dellon - real :: latb_max, latb_min, lonb_max, lonb_min - - integer :: num_diag_pts !< total number of diagnostic columns - integer :: i !< do loop indices - integer :: j !< do loop indices - integer :: nn !< do loop indices - real :: ref_lat - real :: current_distance - character(len=8) :: char !< character string for diaganostic column index - character(len=32) :: filename !< filename for output file for diagnostic column - logical :: allow_ij_input - logical :: open_file - integer :: io -!-------------------------------------------------------------------- -! local variables: -! -! global_lat latitudes for all diagnostic columns [ degrees ] -! global_lon longitudes for all diagnostic columns -! [ degrees ] -! num_diag_pts total number of diagnostic columns -! i, j, nn do loop indices -! char character string for diaganostic column index -! filename filename for output file for diagnostic column -! -!--------------------------------------------------------------------- - - if (.not. module_is_initialized) call column_diagnostics_init - -!-------------------------------------------------------------------- -! save the input lat and lon fields. define the delta of latitude -! and longitude. -!-------------------------------------------------------------------- - latb_deg = latb_in*RADIAN - lonb_deg = lonb_in*RADIAN - dellat = latb_in(1,2) - latb_in(1,1) - dellon = lonb_in(2,1) - lonb_in(1,1) - latb_max = MAXVAL (latb_deg(:,:)) - latb_min = MINVAL (latb_deg(:,:)) - lonb_max = MAXVAL (lonb_deg(:,:)) - lonb_min = MINVAL (lonb_deg(:,:)) - if (lonb_min < 10.0 .or. lonb_max > 350.) then - lonb_min = 0. - lonb_max = 360.0 - endif - - allow_ij_input = .true. - ref_lat = latb_in(1,1) - do i =2,size(latb_in,1) - if (latb_in(i,1) /= ref_lat) then - allow_ij_input = .false. - exit - endif - end do - - if ( .not. allow_ij_input .and. num_diag_pts_ij /= 0) then - call error_mesg ('column_diagnostics_mod', & - 'cannot specify column diagnostics column with (i,j) & - &coordinates when using cubed sphere -- must specify & - & lat/lon coordinates', FATAL) - endif - -!---------------------------------------------------------------------- -! initialize column_diagnostics flag and diag unit numbers. define -! total number of diagnostic columns. -!---------------------------------------------------------------------- - do_column_diagnostics = .false. - diag_units(:) = -1 - diag_i(:) = -99 - diag_j(:) = -99 - diag_lat(:) = -999. - diag_lon(:) = -999. - num_diag_pts = size(diag_i(:)) - -!-------------------------------------------------------------------- -! define an array of lat-lon values for all diagnostic columns. -!-------------------------------------------------------------------- - do nn = 1, num_diag_pts_latlon - global_lat(nn) = global_lat_latlon(nn) - global_lon(nn) = global_lon_latlon(nn) - end do - - do nn = 1, num_diag_pts_ij - global_lat(nn+num_diag_pts_latlon) = & - ((-0.5*acos(-1.0) + 0.5*dellat) + & - (global_j (nn)-1) *dellat)*RADIAN - global_lon(nn+num_diag_pts_latlon) = (0.5*dellon + & - (global_i (nn)-1)*dellon)*RADIAN - end do - -!---------------------------------------------------------------------- -! loop over all diagnostic points to check for their presence on -! this processor. -!---------------------------------------------------------------------- - do nn=1,num_diag_pts - open_file = .false. - -!---------------------------------------------------------------------- -! verify that the values of lat and lon are valid. -!---------------------------------------------------------------------- - if (global_lon(nn) >= 0. .and. global_lon(nn) <= 360.0) then - else - call error_mesg ('column_diagnostics_mod', & - ' invalid longitude', FATAL) - endif - if (global_lat(nn) >= -90.0 .and. global_lat(nn) <= 90.0) then - else - call error_mesg ('column_diagnostics_mod', & - ' invalid latitude', FATAL) - endif - -!-------------------------------------------------------------------- -! if the desired diagnostics column is within the current -! processor's domain, define the total and coordinate distances from -! each of the processor's grid points to the diagnostics point. -!-------------------------------------------------------------------- - - if (global_lat(nn) .ge. latb_min .and. & - global_lat(nn) .le. latb_max) then - if (global_lon(nn) .ge. lonb_min .and.& - global_lon(nn) .le. lonb_max) then - do j=1,size(latb_deg,2) - 1 - do i=1,size(lonb_deg,1) - 1 - distance_y(i,j) = ABS(global_lat(nn) - latb_deg(i,j)) - distance_x(i,j) = ABS(global_lon(nn) - lonb_deg(i,j)) - distance_x2(i,j) = ABS((global_lon(nn)-360.) - & - lonb_deg(i,j)) - distance(i,j) = (global_lat(nn) - latb_deg(i,j))**2 + & - (global_lon(nn) - lonb_deg(i,j))**2 - distance2(i,j) = (global_lat(nn) - latb_deg(i,j))**2 + & - ((global_lon(nn)-360.) - & - lonb_deg(i,j))**2 - end do - end do - -!-------------------------------------------------------------------- -! find the grid point on the processor that is within the specified -! critical distance and also closest to the requested diagnostics -! column. save the (i,j) coordinates and (lon,lat) of this model -! grid point. set a flag indicating that a disgnostics file should -! be opened on this processor for this diagnostic point. -!-------------------------------------------------------------------- - current_distance = distance(1,1) - do j=1,size(latb_deg,2) - 1 - do i=1,size(lonb_deg,1) - 1 - if (distance_x(i,j) <= crit_xdistance .and. & - distance_y(i,j) <= crit_ydistance ) then - if (distance(i,j) < current_distance) then - current_distance = distance(i,j) - do_column_diagnostics(i,j) = .true. - diag_j(nn) = j - diag_i(nn) = i - diag_lon(nn) = lonb_deg(i,j) - diag_lat(nn) = latb_deg(i,j) - open_file = .true. - endif - endif - -!--------------------------------------------------------------------- -! check needed because of the 0.0 / 360.0 longitude periodicity. -!--------------------------------------------------------------------- - if (distance_x2(i,j) <= crit_xdistance .and. & - distance_y(i,j) <= crit_ydistance ) then - if (distance2(i,j) < current_distance) then - current_distance = distance2(i,j) - do_column_diagnostics(i,j) = .true. - diag_j(nn) = j - diag_i(nn) = i - diag_lon(nn) = lonb_deg(i,j) - diag_lat(nn) = latb_deg(i,j) - open_file = .true. - endif - endif - end do - end do - -!-------------------------------------------------------------------- -! if the point has been found on this processor, open a diagnostics -! file. -!-------------------------------------------------------------------- - if (open_file) then - write (char, '(i2)') nn - filename = trim(module) // '_point' // & - trim(adjustl(char)) // '.out' - if(mpp_npes() > 10000) then - write( filename,'(a,i6.6)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() - else - write( filename,'(a,i4.4)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() - endif - open(newunit=diag_units(nn), file=trim(filename), action='WRITE', position='rewind', iostat=io) - if(io/=0) call error_mesg ('column_diagnostics_mod', 'Error in opening file '//trim(filename), FATAL) - endif ! (open_file) - endif - endif - end do - -!--------------------------------------------------------------------- - - -end subroutine initialize_diagnostic_columns - - - - -!#################################################################### -!> @brief column_diagnostics_header writes out information concerning -!! time and location of following data into the column_diagnostics -!! output file. -subroutine column_diagnostics_header & - (module, diag_unit, Time, nn, diag_lon, & - diag_lat, diag_i, diag_j) - -!-------------------------------------------------------------------- -! column_diagnostics_header writes out information concerning -! time and location of following data into the column_diagnostics -! output file. -!-------------------------------------------------------------------- - -!-------------------------------------------------------------------- -character(len=*), intent(in) :: module !< module name calling this subroutine -type(time_type), intent(in) :: Time !< current model time [ time_type ] -integer, intent(in) :: diag_unit !< unit number for column_diagnostics output -integer, intent(in) :: nn !< index of diagnostic column currently active -real, dimension(:), intent(in) :: diag_lon !< longitude of current diagnostic column [ degrees ] -real, dimension(:), intent(in) :: diag_lat !< latitude of current diagnostic column [ degrees ] -integer, dimension(:), intent(in) :: diag_i !< i coordinate of current diagnostic column -integer, dimension(:), intent(in) :: diag_j !< j coordinate of current diagnostic column - -!-------------------------------------------------------------------- -! intent(in) variables -! -! module module name calling this subroutine -! Time current model time [ time_type ] -! diag_unit unit number for column_diagnostics output -! nn index of diagnostic column currently active -! diag_lon longitude of current diagnostic column [ degrees ] -! diag_lat latitude of current diagnostic column [ degrees ] -! diag_i i coordinate of current diagnostic column -! diag_j j coordinate of current diagnostic column -! -!--------------------------------------------------------------------- - -!-------------------------------------------------------------------- -! local variables: - - integer :: year !< integers defining the current time - integer :: month !< integers defining the current time - integer :: day !< integers defining the current time - integer :: hour !< integers defining the current time - integer :: minute !< integers defining the current time - integer :: second !< integers defining the current time - character(len=9) :: mon !< character string for the current month - character(len=64) :: header !< title for the output - -!-------------------------------------------------------------------- -! local variables: -! -! year, month, day, hour, minute, seconds -! integers defining the current time -! mon character string for the current month -! header title for the output -! -!-------------------------------------------------------------------- - - if (.not. module_is_initialized) call column_diagnostics_init - -!-------------------------------------------------------------------- -! convert the time type to a date and time for printing. convert -! month to a character string. -!-------------------------------------------------------------------- - call get_date (Time, year, month, day, hour, minute, second) - mon = month_name(month) - -!--------------------------------------------------------------------- -! write timestamp and column location information to the diagnostic -! columns output unit. -!--------------------------------------------------------------------- - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a)') & - '======================================================' - write (diag_unit,'(a)') ' ' - header = ' PRINTING ' // module // ' DIAGNOSTICS' - write (diag_unit,'(a)') header - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a, i6,2x, a,i4,i4,i4,i4)') ' time stamp:', & - year, trim(mon), day, & - hour, minute, second - write (diag_unit,'(a, i4)') & - ' DIAGNOSTIC POINT COORDINATES, point #', nn - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a,f8.3,a,f8.3)') ' longitude = ', & - diag_lon(nn), ' latitude = ', diag_lat(nn) - write (diag_unit,'(a, i6, a,i6,a,i6)') & - ' on processor # ', mpp_pe(), & - ' : processor i =', diag_i(nn), & - ' , processor j =', diag_j(nn) - write (diag_unit,'(a)') ' ' - -!--------------------------------------------------------------------- - - - -end subroutine column_diagnostics_header - - - !###################################################################### !> @brief close_column_diagnostics_units closes any open column_diagnostics !! files associated with the calling module. @@ -588,7 +218,8 @@ end subroutine close_column_diagnostics_units !##################################################################### - +#include "column_diagnostics_r4.fh" +#include "column_diagnostics_r8.fh" end module column_diagnostics_mod diff --git a/column_diagnostics/include/column_diagnostics.inc b/column_diagnostics/include/column_diagnostics.inc new file mode 100644 index 0000000000..c2e18f2a7d --- /dev/null +++ b/column_diagnostics/include/column_diagnostics.inc @@ -0,0 +1,397 @@ +!*********************************************************************** +!* 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 initialize_diagnostic_columns returns the (i, j, lat, lon) coord- +!! inates of any diagnostic columns that are located on the current +!! processor. +subroutine INITIALIZE_DIAGNOSTIC_COLUMNS_ & + (module, num_diag_pts_latlon, num_diag_pts_ij, & + global_i , global_j , global_lat_latlon, & + global_lon_latlon, lonb_in, latb_in, & + do_column_diagnostics, & + diag_lon, diag_lat, diag_i, diag_j, diag_units) + +!--------------------------------------------------------------------- +! initialize_diagnostic_columns returns the (i, j, lat, lon) coord- +! inates of any diagnostic columns that are located on the current +! processor. +!---------------------------------------------------------------------- + +!--------------------------------------------------------------------- +character(len=*), intent(in) :: module !< module calling this subroutine +integer, intent(in) :: num_diag_pts_latlon !< number of diagnostic columns specified + !! by lat-lon coordinates +integer, intent(in) :: num_diag_pts_ij !< number of diagnostic columns specified + !! by global (i,j) coordinates +integer, dimension(:), intent(in) :: global_i !< specified global i coordinates +integer, dimension(:), intent(in) :: global_j !< specified global j coordinates +real(FMS_CD_KIND_), dimension(:), intent(in) :: global_lat_latlon !< specified global lat coordinates +real(FMS_CD_KIND_), dimension(:), intent(in) :: global_lon_latlon !< specified global lon coordinates +real(FMS_CD_KIND_), dimension(:,:), intent(in) :: lonb_in, latb_in +logical, dimension(:,:), intent(out) :: do_column_diagnostics !< is a diagnostic column in this jrow ? +integer, dimension(:), intent(inout) :: diag_i !< processor i indices of diagnstic columns +integer, dimension(:), intent(inout) :: diag_j !< processor j indices of diagnstic columns +real(FMS_CD_KIND_), dimension(:), intent(out) :: diag_lat !< latitudes of diagnostic columns [ degrees ] +real(FMS_CD_KIND_), dimension(:), intent(out) :: diag_lon !< longitudes of diagnostic columns [ degrees ] +integer, dimension(:), intent(out) :: diag_units !< unit number for each diagnostic column +!--------------------------------------------------------------------- + +!--------------------------------------------------------------------- +! intent(in) variables: +! +! module module calling this subroutine +! num_diag_pts_latlon number of diagnostic columns specified +! by lat-lon coordinates +! num_diag_pts_ij number of diagnostic columns specified +! by global (i,j) coordinates +! global_i specified global i coordinates +! global_j specified global j coordinates +! global_lat_latlon specified global lat coordinates +! global_lon_latlon specified global lon coordinates +! +! intent(out) variables: +! +! do_column_diagnostics is a diagnostic column in this jrow ? +! diag_i processor i indices of diagnstic columns +! diag_j processor j indices of diagnstic columns +! diag_lat latitudes of diagnostic columns +! [ degrees ] +! diag_lon longitudes of diagnostic columns +! [ degrees ] +! diag_units unit number for each diagnostic column +! +!--------------------------------------------------------------------- + +!-------------------------------------------------------------------- +! local variables: + + real(FMS_CD_KIND_), dimension(size(diag_i,1)) :: global_lat !< latitudes for all diagnostic columns [ degrees ] + real(FMS_CD_KIND_), dimension(size(diag_i,1)) :: global_lon !< longitudes for all diagnostic columns [ degrees ] + real(FMS_CD_KIND_), dimension(size(latb_in,1)-1, size(latb_in,2)-1) :: & + distance, distance_x, distance_y, & + distance_x2, distance2 + real(FMS_CD_KIND_), dimension(size(latb_in,1), size(latb_in,2)) :: latb_deg + real(FMS_CD_KIND_), dimension(size(lonb_in,1), size(lonb_in,2)) :: lonb_deg + real(FMS_CD_KIND_) :: dellat, dellon + real(FMS_CD_KIND_) :: latb_max, latb_min, lonb_max, lonb_min + + integer :: num_diag_pts !< total number of diagnostic columns + integer :: i !< do loop indices + integer :: j !< do loop indices + integer :: nn !< do loop indices + real(FMS_CD_KIND_) :: ref_lat + real(FMS_CD_KIND_) :: current_distance + character(len=8) :: char !< character string for diaganostic column index + character(len=32) :: filename !< filename for output file for diagnostic column + logical :: allow_ij_input + logical :: open_file + integer :: io + + integer, parameter :: lkind=FMS_CD_KIND_ + real(FMS_CD_KIND_) :: tmp +!-------------------------------------------------------------------- +! local variables: +! +! global_lat latitudes for all diagnostic columns [ degrees ] +! global_lon longitudes for all diagnostic columns +! [ degrees ] +! num_diag_pts total number of diagnostic columns +! i, j, nn do loop indices +! char character string for diaganostic column index +! filename filename for output file for diagnostic column +! +!--------------------------------------------------------------------- + + if (.not. module_is_initialized) call column_diagnostics_init + +!-------------------------------------------------------------------- +! save the input lat and lon fields. define the delta of latitude +! and longitude. +!-------------------------------------------------------------------- + latb_deg = real( real(latb_in,r8_kind)*RADIAN, FMS_CD_KIND_) !< unit conversion in r8_kind + lonb_deg = real( real(lonb_in,r8_kind)*RADIAN, FMS_CD_KIND_ ) !< unit conversion in r8_kind + dellat = latb_in(1,2) - latb_in(1,1) + dellon = lonb_in(2,1) - lonb_in(1,1) + latb_max = MAXVAL (latb_deg(:,:)) + latb_min = MINVAL (latb_deg(:,:)) + lonb_max = MAXVAL (lonb_deg(:,:)) + lonb_min = MINVAL (lonb_deg(:,:)) + if (lonb_min < 10.0_lkind .or. lonb_max > 350.0_lkind) then + lonb_min = 0.0_lkind + lonb_max = 360.0_lkind + endif + + allow_ij_input = .true. + ref_lat = latb_in(1,1) + do i =2,size(latb_in,1) + if (latb_in(i,1) /= ref_lat) then + allow_ij_input = .false. + exit + endif + end do + + if ( .not. allow_ij_input .and. num_diag_pts_ij /= 0) then + call error_mesg ('column_diagnostics_mod', & + 'cannot specify column diagnostics column with (i,j) & + &coordinates when using cubed sphere -- must specify & + & lat/lon coordinates', FATAL) + endif + +!---------------------------------------------------------------------- + +!---------------------------------------------------------------------- +! initialize column_diagnostics flag and diag unit numbers. define +! total number of diagnostic columns. +!---------------------------------------------------------------------- + do_column_diagnostics = .false. + diag_units(:) = -1 + diag_i(:) = -99 + diag_j(:) = -99 + diag_lat(:) = -999.0_lkind + diag_lon(:) = -999.0_lkind + num_diag_pts = size(diag_i(:)) + +!-------------------------------------------------------------------- +! define an array of lat-lon values for all diagnostic columns. +!-------------------------------------------------------------------- + do nn = 1, num_diag_pts_latlon + global_lat(nn) = global_lat_latlon(nn) + global_lon(nn) = global_lon_latlon(nn) + end do + + do nn = 1, num_diag_pts_ij + tmp = (-0.5_lkind*acos(-1.0_lkind) + 0.5_lkind*dellat) + real(global_j(nn)-1,FMS_CD_KIND_)*dellat + global_lat(nn+num_diag_pts_latlon) = real( real(tmp,r8_kind)*RADIAN, FMS_CD_KIND_ ) + tmp = 0.5_lkind*dellon + real(global_i(nn)-1,FMS_CD_KIND_)*dellon + global_lon(nn+num_diag_pts_latlon) = real( real(tmp,r8_kind)*RADIAN, FMS_CD_KIND_ ) + end do + +!---------------------------------------------------------------------- +! loop over all diagnostic points to check for their presence on +! this processor. +!---------------------------------------------------------------------- + do nn=1,num_diag_pts + open_file = .false. + +!---------------------------------------------------------------------- +! verify that the values of lat and lon are valid. +!---------------------------------------------------------------------- + if (global_lon(nn) >= 0.0_lkind .and. & + global_lon(nn) <= 360.0_lkind) then + else + call error_mesg ('column_diagnostics_mod', & + ' invalid longitude', FATAL) + endif + if (global_lat(nn) >= -90.0_lkind .and. & + global_lat(nn) <= 90.0_lkind) then + else + call error_mesg ('column_diagnostics_mod', & + ' invalid latitude', FATAL) + endif + +!-------------------------------------------------------------------- +! if the desired diagnostics column is within the current +! processor's domain, define the total and coordinate distances from +! each of the processor's grid points to the diagnostics point. +!-------------------------------------------------------------------- + + if (global_lat(nn) .ge. latb_min .and. & + global_lat(nn) .le. latb_max) then + if (global_lon(nn) .ge. lonb_min .and.& + global_lon(nn) .le. lonb_max) then + do j=1,size(latb_deg,2) - 1 + do i=1,size(lonb_deg,1) - 1 + distance_y(i,j) = ABS(global_lat(nn) - latb_deg(i,j)) + distance_x(i,j) = ABS(global_lon(nn) - lonb_deg(i,j)) + distance_x2(i,j) = ABS((global_lon(nn)-360.0_lkind) - lonb_deg(i,j)) + distance(i,j) = (global_lat(nn)-latb_deg(i,j))**2 + (global_lon(nn)-lonb_deg(i,j))**2 + distance2(i,j) = (global_lat(nn)-latb_deg(i,j))**2 + ((global_lon(nn)-360.0_lkind) - lonb_deg(i,j))**2 + end do + end do + +!-------------------------------------------------------------------- +! find the grid point on the processor that is within the specified +! critical distance and also closest to the requested diagnostics +! column. save the (i,j) coordinates and (lon,lat) of this model +! grid point. set a flag indicating that a disgnostics file should +! be opened on this processor for this diagnostic point. +!-------------------------------------------------------------------- + current_distance = distance(1,1) + do j=1,size(latb_deg,2) - 1 + do i=1,size(lonb_deg,1) - 1 + if (distance_x(i,j) <= real(crit_xdistance,FMS_CD_KIND_) .and. & + distance_y(i,j) <= real(crit_ydistance,FMS_CD_KIND_)) then + if (distance(i,j) < current_distance) then + current_distance = distance(i,j) + do_column_diagnostics(i,j) = .true. + diag_j(nn) = j + diag_i(nn) = i + diag_lon(nn) = lonb_deg(i,j) + diag_lat(nn) = latb_deg(i,j) + open_file = .true. + endif + endif + +!--------------------------------------------------------------------- +! check needed because of the 0.0 / 360.0 longitude periodicity. +!--------------------------------------------------------------------- + if (distance_x2(i,j)<= real(crit_xdistance,FMS_CD_KIND_) .and. & + distance_y(i,j) <= real(crit_ydistance,FMS_CD_KIND_)) then + if (distance2(i,j) < current_distance) then + current_distance = distance2(i,j) + do_column_diagnostics(i,j) = .true. + diag_j(nn) = j + diag_i(nn) = i + diag_lon(nn) = lonb_deg(i,j) + diag_lat(nn) = latb_deg(i,j) + open_file = .true. + endif + endif + end do + end do + +!-------------------------------------------------------------------- +! if the point has been found on this processor, open a diagnostics +! file. +!-------------------------------------------------------------------- + if (open_file) then + write (char, '(i2)') nn + filename = trim(module) // '_point' // & + trim(adjustl(char)) // '.out' + if(mpp_npes() > 10000) then + write( filename,'(a,i6.6)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() + else + write( filename,'(a,i4.4)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() + endif + open(newunit=diag_units(nn), file=trim(filename), action='WRITE', position='rewind', iostat=io) + if(io/=0) call error_mesg ('column_diagnostics_mod', 'Error in opening file '//trim(filename), FATAL) + endif ! (open_file) + endif + endif + end do + +!--------------------------------------------------------------------- + + +end subroutine INITIALIZE_DIAGNOSTIC_COLUMNS_ + + + + +!#################################################################### +!> @brief column_diagnostics_header writes out information concerning +!! time and location of following data into the column_diagnostics +!! output file. +subroutine COLUMN_DIAGNOSTICS_HEADER_ & + (module, diag_unit, Time, nn, diag_lon, & + diag_lat, diag_i, diag_j) + +!-------------------------------------------------------------------- +! column_diagnostics_header writes out information concerning +! time and location of following data into the column_diagnostics +! output file. +!-------------------------------------------------------------------- + +!-------------------------------------------------------------------- +character(len=*), intent(in) :: module !< module name calling this subroutine +type(time_type), intent(in) :: Time !< current model time [ time_type ] +integer, intent(in) :: diag_unit !< unit number for column_diagnostics output +integer, intent(in) :: nn !< index of diagnostic column currently active +real(FMS_CD_KIND_), dimension(:), intent(in) :: diag_lon !< longitude of current diagnostic column [ degrees ] +real(FMS_CD_KIND_), dimension(:), intent(in) :: diag_lat !< latitude of current diagnostic column [ degrees ] +integer, dimension(:), intent(in) :: diag_i !< i coordinate of current diagnostic column +integer, dimension(:), intent(in) :: diag_j !< j coordinate of current diagnostic column + +!-------------------------------------------------------------------- +! intent(in) variables +! +! module module name calling this subroutine +! Time current model time [ time_type ] +! diag_unit unit number for column_diagnostics output +! nn index of diagnostic column currently active +! diag_lon longitude of current diagnostic column [ degrees ] +! diag_lat latitude of current diagnostic column [ degrees ] +! diag_i i coordinate of current diagnostic column +! diag_j j coordinate of current diagnostic column +! +!--------------------------------------------------------------------- + + +!-------------------------------------------------------------------- +! local variables: + + integer :: year !< integers defining the current time + integer :: month !< integers defining the current time + integer :: day !< integers defining the current time + integer :: hour !< integers defining the current time + integer :: minute !< integers defining the current time + integer :: second !< integers defining the current time + character(len=9) :: mon !< character string for the current month + character(len=64) :: header !< title for the output + +!-------------------------------------------------------------------- +! local variables: +! +! year, month, day, hour, minute, seconds +! integers defining the current time +! mon character string for the current month +! header title for the output +! +!-------------------------------------------------------------------- + + if (.not. module_is_initialized) call column_diagnostics_init + +!-------------------------------------------------------------------- +! convert the time type to a date and time for printing. convert +! month to a character string. +!-------------------------------------------------------------------- + call get_date (Time, year, month, day, hour, minute, second) + mon = month_name(month) + +!--------------------------------------------------------------------- +! write timestamp and column location information to the diagnostic +! columns output unit. +!--------------------------------------------------------------------- + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a)') & + '======================================================' + write (diag_unit,'(a)') ' ' + header = ' PRINTING ' // module // ' DIAGNOSTICS' + write (diag_unit,'(a)') header + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a, i6,2x, a,i4,i4,i4,i4)') ' time stamp:', & + year, trim(mon), day, & + hour, minute, second + write (diag_unit,'(a, i4)') & + ' DIAGNOSTIC POINT COORDINATES, point #', nn + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a,f8.3,a,f8.3)') ' longitude = ', & + diag_lon(nn), ' latitude = ', diag_lat(nn) + write (diag_unit,'(a, i6, a,i6,a,i6)') & + ' on processor # ', mpp_pe(), & + ' : processor i =', diag_i(nn), & + ' , processor j =', diag_j(nn) + write (diag_unit,'(a)') ' ' + +!--------------------------------------------------------------------- + +end subroutine COLUMN_DIAGNOSTICS_HEADER_ +!@} diff --git a/column_diagnostics/include/column_diagnostics_r4.fh b/column_diagnostics/include/column_diagnostics_r4.fh new file mode 100644 index 0000000000..f8cdb30d9f --- /dev/null +++ b/column_diagnostics/include/column_diagnostics_r4.fh @@ -0,0 +1,34 @@ +!*********************************************************************** +!* 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 include file for column_diagnostics_mod to generate subroutine/functions +!! for r4_kind arguments + +#undef FMS_CD_KIND_ +#define FMS_CD_KIND_ r4_kind + +#undef INITIALIZE_DIAGNOSTIC_COLUMNS_ +#define INITIALIZE_DIAGNOSTIC_COLUMNS_ initialize_diagnostic_columns_r4 + +#undef COLUMN_DIAGNOSTICS_HEADER_ +#define COLUMN_DIAGNOSTICS_HEADER_ column_diagnostics_header_r4 + +#include "column_diagnostics.inc" + +!> @} diff --git a/column_diagnostics/include/column_diagnostics_r8.fh b/column_diagnostics/include/column_diagnostics_r8.fh new file mode 100644 index 0000000000..df0b4e2cf0 --- /dev/null +++ b/column_diagnostics/include/column_diagnostics_r8.fh @@ -0,0 +1,34 @@ +!*********************************************************************** +!* 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 include file for column_diagnostics_mod to generate subroutine/functions +!! for r8_kind arguments + +#undef FMS_CD_KIND_ +#define FMS_CD_KIND_ r8_kind + +#undef INITIALIZE_DIAGNOSTIC_COLUMNS_ +#define INITIALIZE_DIAGNOSTIC_COLUMNS_ initialize_diagnostic_columns_r8 + +#undef COLUMN_DIAGNOSTICS_HEADER_ +#define COLUMN_DIAGNOSTICS_HEADER_ column_diagnostics_header_r8 + +#include "column_diagnostics.inc" + +!> @} diff --git a/configure.ac b/configure.ac index 7600457ae4..ce24e3f2c2 100644 --- a/configure.ac +++ b/configure.ac @@ -498,15 +498,18 @@ AC_CONFIG_FILES([ test_fms/horiz_interp/Makefile test_fms/field_manager/Makefile test_fms/axis_utils/Makefile - test_fms/mosaic/Makefile + test_fms/mosaic2/Makefile test_fms/affinity/Makefile test_fms/coupler/Makefile test_fms/parser/Makefile test_fms/string_utils/Makefile + test_fms/tridiagonal/Makefile test_fms/sat_vapor_pres/Makefile test_fms/diag_integral/Makefile test_fms/tracer_manager/Makefile test_fms/random_numbers/Makefile + test_fms/topography/Makefile + test_fms/column_diagnostics/Makefile FMS.pc ]) diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 25ed6d108e..515eb8ed8f 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -2837,7 +2837,7 @@ end subroutine CT_increment_data_3d_3d !! @throw FATAL, "axes has less than 2 elements" subroutine CT_set_diags_2d(var, diag_name, axes, time) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + character(len=*), intent(in) :: diag_name !< Module name for diagnostic file--if blank, then !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -2893,7 +2893,7 @@ end subroutine CT_set_diags_2d !! @throw FATAL, "axes has less than 3 elements" subroutine CT_set_diags_3d(var, diag_name, axes, time) type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + character(len=*), intent(in) :: diag_name !< Module name for diagnostic file--if blank, then !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -3727,8 +3727,6 @@ subroutine CT_data_override_2d(gridname, var, Time) character(len=3), intent(in) :: gridname !< 3-character long model grid ID type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override type(time_type), intent(in) :: time !< The current model time - !! TODO remove this when data_override is merged in - real(r8_kind), allocatable :: r8_field_values(:,:) integer :: m, n if(var%set .and. var%num_bcs .gt. 0) then @@ -3752,10 +3750,7 @@ subroutine CT_data_override_2d(gridname, var, Time) else if(associated(var%bc_r4)) then do n = 1, var%num_bcs do m = 1, var%bc_r4(n)%num_fields - !! this should be removed when data override is updated - r8_field_values = real(var%bc_r4(n)%field(m)%values, r8_kind) - call data_override(gridname, var%bc_r4(n)%field(m)%name, r8_field_values, Time) - var%bc_r4(n)%field(m)%values = real(r8_field_values, r4_kind) + call data_override(gridname, var%bc_r4(n)%field(m)%name, var%bc_r4(n)%field(m)%values, Time) enddo enddo else @@ -3795,10 +3790,7 @@ subroutine CT_data_override_3d(gridname, var, Time) else if(associated(var%bc_r4)) then do n = 1, var%num_bcs do m = 1, var%bc_r4(n)%num_fields - !! this should be removed when data override is updated - r8_field_values = real(var%bc_r4(n)%field(m)%values, r8_kind) - call data_override(gridname, var%bc_r4(n)%field(m)%name, r8_field_values, Time) - var%bc_r4(n)%field(m)%values = real(r8_field_values, r4_kind) + call data_override(gridname, var%bc_r4(n)%field(m)%name, var%bc_r4(n)%field(m)%values, Time) enddo enddo else diff --git a/mosaic/Makefile.am b/mosaic/Makefile.am index d097207105..32166d34d3 100644 --- a/mosaic/Makefile.am +++ b/mosaic/Makefile.am @@ -51,9 +51,9 @@ grid_mod.$(FC_MODEXT): mosaic_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ - mosaic_mod.$(FC_MODEXT) \ - grid_mod.$(FC_MODEXT) \ - gradient_mod.$(FC_MODEXT) + mosaic_mod.$(FC_MODEXT) \ + grid_mod.$(FC_MODEXT) \ + gradient_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/mosaic/read_mosaic.c b/mosaic/read_mosaic.c index b855d4267b..cbbe4f4b58 100644 --- a/mosaic/read_mosaic.c +++ b/mosaic/read_mosaic.c @@ -258,11 +258,7 @@ void get_var_data(const char *file, const char *name, void *data) switch (vartype) { case NC_DOUBLE:case NC_FLOAT: -#ifdef OVERLOAD_R4 - status = nc_get_var_float(ncid, varid, (float *)data); -#else status = nc_get_var_double(ncid, varid, (double *)data); -#endif break; case NC_INT: status = nc_get_var_int(ncid, varid, (int *)data); @@ -318,11 +314,7 @@ void get_var_data_region(const char *file, const char *name, const size_t *start switch (vartype) { case NC_DOUBLE:case NC_FLOAT: -#ifdef OVERLOAD_R4 - status = nc_get_vara_float(ncid, varid, start, nread, (float *)data); -#else status = nc_get_vara_double(ncid, varid, start, nread, (double *)data); -#endif break; case NC_INT: status = nc_get_vara_int(ncid, varid, start, nread, (int *)data); @@ -400,59 +392,35 @@ int read_mosaic_xgrid_size( const char *xgrid_file ) return ncells; } -#ifdef OVERLOAD_R4 -float get_global_area(void) -{ - float garea; -#else double get_global_area(void) { double garea; -#endif garea = 4*M_PI*RADIUS*RADIUS; return garea; } -#ifdef OVERLOAD_R4 - float get_global_area_(void) + double get_global_area_(void) { - float garea; -#else - double get_global_area_(void) - { - double garea; -#endif - garea = 4*M_PI*RADIUS*RADIUS; + double garea; + garea = 4*M_PI*RADIUS*RADIUS; - return garea; - } + return garea; + } /****************************************************************************/ -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ) -#else - void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) -#endif + void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) { read_mosaic_xgrid_order1(xgrid_file, i1, j1, i2, j2, area); } -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ) -#else - void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) -#endif + void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) { int ncells, n; int *tile1_cell, *tile2_cell; -#ifdef OVERLOAD_R4 - float garea; -#else double garea; -#endif ncells = get_dimlen(xgrid_file, "ncells"); @@ -479,30 +447,18 @@ float get_global_area(void) } /* read_mosaic_xgrid_order1 */ -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ) -#else - void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) -#endif + void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) { read_mosaic_xgrid_order1_region(xgrid_file, i1, j1, i2, j2, area, isc, iec); } -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ) -#else - void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) -#endif + void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) { int ncells, n, i; int *tile1_cell, *tile2_cell; size_t start[4], nread[4]; -#ifdef OVERLOAD_R4 - float garea; -#else double garea; -#endif ncells = *iec-*isc+1; @@ -540,30 +496,17 @@ float get_global_area(void) /* NOTE: di, dj is for tile1, */ /****************************************************************************/ -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, float *di, float *dj ) -#else - void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) -#endif - { + void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) + { read_mosaic_xgrid_order2(xgrid_file, i1, j1, i2, j2, area, di, dj); } -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, float *di, float *dj ) -#else - void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) -#endif - + void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) { int ncells, n; int *tile1_cell, *tile2_cell; double *tile1_distance; -#ifdef OVERLOAD_R4 - float garea; -#else double garea; -#endif ncells = get_dimlen(xgrid_file, "ncells"); tile1_cell = (int *)malloc(ncells*2*sizeof(int )); diff --git a/mosaic/read_mosaic.h b/mosaic/read_mosaic.h index 3612fb7bcb..5f377641a7 100644 --- a/mosaic/read_mosaic.h +++ b/mosaic/read_mosaic.h @@ -44,19 +44,6 @@ void get_var_text_att(const char *file, const char *name, const char *attname, c int read_mosaic_xgrid_size( const char *xgrid_file ); -#ifdef OVERLOAD_R4 - -void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ); - -void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ); - -void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, - float *area, float *di, float *dj ); - -float get_global_area(void); - -#else - void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ); void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ); @@ -66,7 +53,6 @@ void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, double get_global_area(void); -#endif int read_mosaic_ntiles(const char *mosaic_file); @@ -94,17 +80,6 @@ int read_mosaic_ncontacts_(const char *mosaic_file); void read_mosaic_grid_sizes_(const char *mosaic_file, int *nx, int *ny); -#ifdef OVERLOAD_R4 - -float get_global_area_(void); - -void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ); - -void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ); - -void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, float *di, float *dj ); - -#else double get_global_area_(void); @@ -114,6 +89,4 @@ void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ); -#endif /* OVERLOAD_R4 */ - #endif diff --git a/mosaic2/Makefile.am b/mosaic2/Makefile.am index 4830823af2..8801461b03 100644 --- a/mosaic2/Makefile.am +++ b/mosaic2/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/mosaic +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/mosaic -I$(top_srcdir)/mosaic2/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -32,14 +32,17 @@ noinst_LTLIBRARIES = libmosaic2.la libmosaic2_la_SOURCES = \ mosaic2.F90 \ -grid2.F90 +grid2.F90 \ +include/mosaic2_r4.fh include/mosaic2_r8.fh include/mosaic2.inc \ +include/grid2_r4.fh include/grid2_r8.fh include/grid2.inc # Some mods are dependant on other mods in this dir. -grid2_mod.$(FC_MODEXT): mosaic2_mod.$(FC_MODEXT) +grid2_mod.$(FC_MODEXT): mosaic2_mod.$(FC_MODEXT) include/grid2_r4.fh include/grid2_r8.fh include/grid2.inc +mosaic2_mod.$(FC_MODEXT): include/mosaic2_r4.fh include/mosaic2_r8.fh include/mosaic2.inc MODFILES = \ - mosaic2_mod.$(FC_MODEXT) \ - grid2_mod.$(FC_MODEXT) + mosaic2_mod.$(FC_MODEXT) \ + grid2_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/mosaic2/grid2.F90 b/mosaic2/grid2.F90 index 357e875ebf..e486777744 100644 --- a/mosaic2/grid2.F90 +++ b/mosaic2/grid2.F90 @@ -20,6 +20,8 @@ !> @ingroup mosaic2 !> @brief Routines for grid calculations, using @ref fms2_io +!> @addtogroup grid2_mod +!> @{ module grid2_mod use mpp_mod, only : mpp_root_pe, mpp_error, uppercase, lowercase, FATAL, NOTE @@ -68,31 +70,41 @@ module grid2_mod !! mosaic tile number !> @ingroup grid2_mod interface get_grid_cell_vertices - module procedure get_grid_cell_vertices_1D - module procedure get_grid_cell_vertices_2D - module procedure get_grid_cell_vertices_UG + module procedure get_grid_cell_vertices_1D_r4 + module procedure get_grid_cell_vertices_1D_r8 + module procedure get_grid_cell_vertices_2D_r4 + module procedure get_grid_cell_vertices_2D_r8 + module procedure get_grid_cell_vertices_UG_r4 + module procedure get_grid_cell_vertices_UG_r8 end interface !> Gets grid cell centers !> @ingroup grid2_mod interface get_grid_cell_centers - module procedure get_grid_cell_centers_1D - module procedure get_grid_cell_centers_2D - module procedure get_grid_cell_centers_UG + module procedure get_grid_cell_centers_1D_r4 + module procedure get_grid_cell_centers_1D_r8 + module procedure get_grid_cell_centers_2D_r4 + module procedure get_grid_cell_centers_2D_r8 + module procedure get_grid_cell_centers_UG_r4 + module procedure get_grid_cell_centers_UG_r8 end interface !> Finds area of a grid cell !> @ingroup grid2_mod interface get_grid_cell_area - module procedure get_grid_cell_area_SG - module procedure get_grid_cell_area_UG + module procedure get_grid_cell_area_SG_r4 + module procedure get_grid_cell_area_SG_r8 + module procedure get_grid_cell_area_UG_r4 + module procedure get_grid_cell_area_UG_r8 end interface get_grid_cell_area !> Gets the area of a given component per grid cell !> @ingroup grid2_mod interface get_grid_comp_area - module procedure get_grid_comp_area_SG - module procedure get_grid_comp_area_UG + module procedure get_grid_comp_area_SG_r4 + module procedure get_grid_comp_area_SG_r8 + module procedure get_grid_comp_area_UG_r4 + module procedure get_grid_comp_area_UG_r8 end interface get_grid_comp_area !> @addtogroup grid2_mod @@ -338,1105 +350,6 @@ subroutine get_grid_size_for_one_tile(component,tile,nx,ny) endif end subroutine get_grid_size_for_one_tile -!> @brief return grid cell area for the specified model component and tile -subroutine get_grid_cell_area_SG(component, tile, cellarea, domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer , intent(in) :: tile !< Tile number - class(*) , intent(inout) :: cellarea(:,:) !< Cell area - type(domain2d) , intent(in), optional :: domain !< Domain - - ! local vars - integer :: nlon, nlat - real(r4_kind), allocatable :: glonb_r4(:,:), glatb_r4(:,:) - real(r8_kind), allocatable :: glonb_r8(:,:), glatb_r8(:,:) - - select type(cellarea) - !! R4 argument - type is (real(r4_kind)) - select case(grid_version) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_area_SG): grid_spec does not exist') - end if - select case(trim(component)) - case('LND') - call read_data(gridfileobj, 'AREA_LND_CELL', cellarea) - case('ATM','OCN') - call read_data(gridfileobj, 'AREA_'//trim(uppercase(component)),cellarea) - case default - call mpp_error(FATAL, module_name//'/get_grid_cell_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! convert area to m2 - cellarea = real(cellarea*4.*PI*radius**2, r4_kind) - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - if (present(domain)) then - call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) - else - call get_grid_size(component,tile,nlon,nlat) - endif - allocate(glonb_r4(nlon+1,nlat+1),glatb_r4(nlon+1,nlat+1)) - call get_grid_cell_vertices(component, tile, glonb_r4, glatb_r4, domain) - if (great_circle_algorithm) then - call calc_mosaic_grid_great_circle_area(glonb_r4*pi/180.0, glatb_r4*pi/180.0, cellarea) - else - call calc_mosaic_grid_area(glonb_r4*pi/180.0, glatb_r4*pi/180.0, cellarea) - end if - deallocate(glonb_r4,glatb_r4) - end select - !! R8 argument - type is (real(r8_kind)) - select case(grid_version) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_area_SG): grid_spec does not exist') - end if - select case(trim(component)) - case('LND') - call read_data(gridfileobj, 'AREA_LND_CELL', cellarea) - case('ATM','OCN') - call read_data(gridfileobj, 'AREA_'//trim(uppercase(component)),cellarea) - case default - call mpp_error(FATAL, module_name//'/get_grid_cell_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! convert area to m2 - cellarea = cellarea*4.*PI*radius**2 - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - if (present(domain)) then - call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) - else - call get_grid_size(component,tile,nlon,nlat) - endif - allocate(glonb_r8(nlon+1,nlat+1),glatb_r8(nlon+1,nlat+1)) - call get_grid_cell_vertices(component, tile, glonb_r8, glatb_r8, domain) - if (great_circle_algorithm) then - call calc_mosaic_grid_great_circle_area(glonb_r8*pi/180.0, glatb_r8*pi/180.0, cellarea) - else - call calc_mosaic_grid_area(glonb_r8*pi/180.0, glatb_r8*pi/180.0, cellarea) - end if - deallocate(glonb_r8,glatb_r8) - end select - class default - call mpp_error(FATAL, "get_grid_cell_area_SG: invalid type given for cellarea, must be r4_kind or r8_kind") - end select - -end subroutine get_grid_cell_area_SG - -!> @brief get the area of the component per grid cell -subroutine get_grid_comp_area_SG(component,tile,area,domain) - character(len=*) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - class(*), intent(inout) :: area(:,:) !< Area of grid cell - type(domain2d), intent(in), optional :: domain !< Domain - ! local vars - integer :: n_xgrid_files ! number of exchange grid files in the mosaic - integer :: siz(2), nxgrid - integer :: i,j,m,n - integer, allocatable :: i1(:), j1(:), i2(:), j2(:) - real(r4_kind), allocatable :: xgrid_area_r4(:) - real(r4_kind), allocatable :: rmask_r4(:,:) - real(r8_kind), allocatable :: xgrid_area_r8(:) - real(r8_kind), allocatable :: rmask_r8(:,:) - character(len=MAX_NAME) :: & - xgrid_name, & ! name of the variable holding xgrid names - tile_name, & ! name of the tile - mosaic_name ! name of the mosaic - character(len=MAX_FILE) :: & - tilefile, & ! name of current tile file - xgrid_file ! name of the current xgrid file - character(len=4096) :: attvalue - character(len=MAX_NAME), allocatable :: nest_tile_name(:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0, j0 ! offsets for x and y, respectively - integer :: num_nest_tile, ntiles - logical :: is_nest - integer :: found_xgrid_files ! how many xgrid files we actually found in the grid spec - integer :: ibegin, iend, bsize, l - type(FmsNetcdfFile_t) :: tilefileobj, xgrid_fileobj - - select type(area) - type is (real(r4_kind)) - select case (grid_version ) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - select case(component) - case('ATM') - call read_data(gridfileobj,'AREA_ATM',area) - case('OCN') - allocate(rmask_r4(size(area,1),size(area,2))) - call read_data(gridfileobj,'AREA_OCN',area) - call read_data(gridfileobj,'wet', rmask_r4) - area = area*rmask_r4 - deallocate(rmask_r4) - case('LND') - call read_data(gridfileobj,'AREA_LND',area) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic gridspec - select case (component) - case ('ATM') - ! just read the grid cell area and return - call get_grid_cell_area(component,tile,area) - return - case ('LND') - xgrid_name = 'aXl_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'lnd_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case ('OCN') - xgrid_name = 'aXo_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'ocn_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! get the boundaries of the requested domain - if(present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - i0 = 1-is ; j0=1-js - else - call get_grid_size(component,tile,ie,je) - is = 1 ; i0 = 0 - js = 1 ; j0 = 0 - endif - if (size(area,1)/=ie-is+1.or.size(area,2)/=je-js+1) & - call mpp_error(FATAL, module_name//'/get_grid_comp_area '//& - 'size of the output argument "area" is not consistent with the domain') - - ! find the nest tile - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'atm_mosaic', mosaic_name) - call get_grid_ntiles('atm', ntiles) - allocate(nest_tile_name(ntiles)) - num_nest_tile = 0 - do n = 1, ntiles - tilefile = read_file_name(mosaic_fileobj(1), 'gridfiles', n) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if (global_att_exists(tilefileobj, "nest_grid")) then - call get_global_attribute(tilefileobj, "nest_grid", attvalue) - if(trim(attvalue) == "TRUE") then - num_nest_tile = num_nest_tile + 1 - nest_tile_name(num_nest_tile) = trim(mosaic_name)//'_tile'//char(n+ichar('0')) - else if(trim(attvalue) .NE. "FALSE") then - call mpp_error(FATAL,module_name//'/get_grid_comp_area value of global attribute nest_grid in file'//& - trim(tilefile)//' should be TRUE or FALSE') - endif - end if - call close_file(tilefileobj) - end do - area(:,:) = 0. - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - if(variable_exists(gridfileobj,xgrid_name)) then - ! get the number of the exchange-grid files - call get_variable_size(gridfileobj,xgrid_name,siz) - n_xgrid_files = siz(2) - found_xgrid_files = 0 - ! loop through all exchange grid files - do n = 1, n_xgrid_files - ! get the name of the current exchange grid file - xgrid_file = read_file_name(gridfileobj,xgrid_name,n) - call open_grid_file(xgrid_fileobj, grid_dir//xgrid_file) - ! skip the rest of the loop if the name of the current tile isn't found - ! in the file name, but check this only if there is more than 1 tile - if(n_xgrid_files>1) then - if(index(xgrid_file,trim(tile_name))==0) cycle - endif - found_xgrid_files = found_xgrid_files + 1 - !---make sure the atmosphere grid is not a nested grid - is_nest = .false. - do m = 1, num_nest_tile - if(index(xgrid_file, trim(nest_tile_name(m))) .NE. 0) then - is_nest = .true. - exit - end if - end do - if(is_nest) cycle - - ! finally read the exchange grid - nxgrid = get_mosaic_xgrid_size(xgrid_fileobj) - if(nxgrid < BUFSIZE) then - allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area_r4(nxgrid)) - else - allocate(i1(BUFSIZE), j1(BUFSIZE), i2(BUFSIZE), j2(BUFSIZE), xgrid_area_r4(BUFSIZE)) - endif - ibegin = 1 - do l = 1,nxgrid,BUFSIZE - bsize = min(BUFSIZE, nxgrid-l+1) - iend = ibegin + bsize - 1 - call get_mosaic_xgrid(xgrid_fileobj, i1(1:bsize), j1(1:bsize), i2(1:bsize), j2(1:bsize), & - xgrid_area_r4(1:bsize), ibegin, iend) - ! and sum the exchange grid areas - do m = 1, bsize - i = i2(m); j = j2(m) - if (iie) cycle - if (jje) cycle - area(i+i0,j+j0) = area(i+i0,j+j0) + xgrid_area_r4(m) - end do - ibegin = iend + 1 - enddo - deallocate(i1, j1, i2, j2, xgrid_area_r4) - call close_file(xgrid_fileobj) - enddo - if (found_xgrid_files == 0) & - call mpp_error(FATAL, 'get_grid_comp_area no xgrid files were found for component '& - //trim(component)//' (mosaic name is '//trim(mosaic_name)//')') - - endif - deallocate(nest_tile_name) - end select ! version - ! convert area to m2 - area = real(area*4.*PI*radius**2, r4_kind) - !! R8 version ################################### - type is (real(r8_kind)) - select case (grid_version ) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - select case(component) - case('ATM') - call read_data(gridfileobj,'AREA_ATM',area) - case('OCN') - allocate(rmask_r8(size(area,1),size(area,2))) - call read_data(gridfileobj,'AREA_OCN',area) - call read_data(gridfileobj,'wet', rmask_r8) - area = area*rmask_r8 - deallocate(rmask_r8) - case('LND') - call read_data(gridfileobj,'AREA_LND',area) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic gridspec - select case (component) - case ('ATM') - ! just read the grid cell area and return - call get_grid_cell_area(component,tile,area) - return - case ('LND') - xgrid_name = 'aXl_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'lnd_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case ('OCN') - xgrid_name = 'aXo_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'ocn_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! get the boundaries of the requested domain - if(present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - i0 = 1-is ; j0=1-js - else - call get_grid_size(component,tile,ie,je) - is = 1 ; i0 = 0 - js = 1 ; j0 = 0 - endif - if (size(area,1)/=ie-is+1.or.size(area,2)/=je-js+1) & - call mpp_error(FATAL, module_name//'/get_grid_comp_area '//& - 'size of the output argument "area" is not consistent with the domain') - - ! find the nest tile - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'atm_mosaic', mosaic_name) - call get_grid_ntiles('atm', ntiles) - allocate(nest_tile_name(ntiles)) - num_nest_tile = 0 - do n = 1, ntiles - tilefile = read_file_name(mosaic_fileobj(1), 'gridfiles', n) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if (global_att_exists(tilefileobj, "nest_grid")) then - call get_global_attribute(tilefileobj, "nest_grid", attvalue) - if(trim(attvalue) == "TRUE") then - num_nest_tile = num_nest_tile + 1 - nest_tile_name(num_nest_tile) = trim(mosaic_name)//'_tile'//char(n+ichar('0')) - else if(trim(attvalue) .NE. "FALSE") then - call mpp_error(FATAL,module_name//'/get_grid_comp_area value of global attribute nest_grid in file'//& - trim(tilefile)//' should be TRUE or FALSE') - endif - end if - call close_file(tilefileobj) - end do - area(:,:) = 0. - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - if(variable_exists(gridfileobj,xgrid_name)) then - ! get the number of the exchange-grid files - call get_variable_size(gridfileobj,xgrid_name,siz) - n_xgrid_files = siz(2) - found_xgrid_files = 0 - ! loop through all exchange grid files - do n = 1, n_xgrid_files - ! get the name of the current exchange grid file - xgrid_file = read_file_name(gridfileobj,xgrid_name,n) - call open_grid_file(xgrid_fileobj, grid_dir//xgrid_file) - ! skip the rest of the loop if the name of the current tile isn't found - ! in the file name, but check this only if there is more than 1 tile - if(n_xgrid_files>1) then - if(index(xgrid_file,trim(tile_name))==0) cycle - endif - found_xgrid_files = found_xgrid_files + 1 - !---make sure the atmosphere grid is not a nested grid - is_nest = .false. - do m = 1, num_nest_tile - if(index(xgrid_file, trim(nest_tile_name(m))) .NE. 0) then - is_nest = .true. - exit - end if - end do - if(is_nest) cycle - - ! finally read the exchange grid - nxgrid = get_mosaic_xgrid_size(xgrid_fileobj) - if(nxgrid < BUFSIZE) then - allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area_r8(nxgrid)) - else - allocate(i1(BUFSIZE), j1(BUFSIZE), i2(BUFSIZE), j2(BUFSIZE), xgrid_area_r8(BUFSIZE)) - endif - ibegin = 1 - do l = 1,nxgrid,BUFSIZE - bsize = min(BUFSIZE, nxgrid-l+1) - iend = ibegin + bsize - 1 - call get_mosaic_xgrid(xgrid_fileobj, i1(1:bsize), j1(1:bsize), i2(1:bsize), j2(1:bsize), & - xgrid_area_r8(1:bsize), ibegin, iend) - ! and sum the exchange grid areas - do m = 1, bsize - i = i2(m); j = j2(m) - if (iie) cycle - if (jje) cycle - area(i+i0,j+j0) = area(i+i0,j+j0) + xgrid_area_r8(m) - end do - ibegin = iend + 1 - enddo - deallocate(i1, j1, i2, j2, xgrid_area_r8) - call close_file(xgrid_fileobj) - enddo - if (found_xgrid_files == 0) & - call mpp_error(FATAL, 'get_grid_comp_area no xgrid files were found for component '& - //trim(component)//' (mosaic name is '//trim(mosaic_name)//')') - - endif - deallocate(nest_tile_name) - end select ! version - ! convert area to m2 - area = area*4.*PI*radius**2 - class default - call mpp_error(FATAL, "get_grid_comp_area_SG: invalid type given for area argument, must be r4_kind or r8_kind") - end select -end subroutine get_grid_comp_area_SG - -!> @brief return grid cell area for the specified model component and tile on an -!! unstructured domain -subroutine get_grid_cell_area_UG(component, tile, cellarea, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer , intent(in) :: tile !< Tile number - real , intent(inout) :: cellarea(:) !< Cell area - type(domain2d) , intent(in) :: SG_domain !< Structured Domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured Domain - integer :: is, ie, js, je - real, allocatable :: SG_area(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_area(is:ie, js:je)) - call get_grid_cell_area_SG(component, tile, SG_area, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_area, cellarea) - deallocate(SG_area) -end subroutine get_grid_cell_area_UG - -!> @brief get the area of the component per grid cell for an unstructured domain -subroutine get_grid_comp_area_UG(component, tile, area, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer , intent(in) :: tile !< Tile number - real , intent(inout) :: area(:) !< Area of the component - type(domain2d) , intent(in) :: SG_domain !< Structured domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured domain - integer :: is, ie, js, je - real, allocatable :: SG_area(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_area(is:ie, js:je)) - call get_grid_comp_area_SG(component, tile, SG_area, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_area, area) - deallocate(SG_area) - -end subroutine get_grid_comp_area_UG - -!> @brief returns arrays of global grid cell boundaries for given model component and -!! mosaic tile number. -subroutine get_grid_cell_vertices_1D(component, tile, glonb, glatb) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: glonb(:),glatb(:) !< Grid cell vertices - - integer :: nlon, nlat - integer :: start(4), nread(4) - real, allocatable :: tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (size(glonb(:))/=nlon+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& - 'Size of argument "glonb" is not consistent with the grid size') - if (size(glatb(:))/=nlat+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& - 'Size of argument "glatb" is not consistent with the grid size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices_1D '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) - case('OCN') - call read_data(gridfileobj, "gridlon_vert_t", glonb) - call read_data(gridfileobj, "gridlat_vert_t", glatb) - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) - case('OCN') - allocate (x_vert_t(nlon,1,2), y_vert_t(1,nlat,2) ) - start = 1; nread = 1 - nread(1) = nlon; nread(2) = 1; start(3) = 1 - call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,1), corner=start, edge_lengths=nread) - nread(1) = nlon; nread(2) = 1; start(3) = 2 - call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,2), corner=start, edge_lengths=nread) - - nread(1) = 1; nread(2) = nlat; start(3) = 1 - call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,1), corner=start, edge_lengths=nread) - nread(1) = 1; nread(2) = nlat; start(3) = 4 - call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,2), corner=start, edge_lengths=nread) - glonb(1:nlon) = x_vert_t(1:nlon,1,1) - glonb(nlon+1) = x_vert_t(nlon,1,2) - glatb(1:nlat) = y_vert_t(1,1:nlat,1) - glatb(nlat+1) = y_vert_t(1,nlat,2) - deallocate(x_vert_t, y_vert_t) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - - start = 1; nread = 1 - nread(1) = 2*nlon+1 - allocate( tmp(2*nlon+1,1) ) - call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) - glonb(1:nlon+1) = tmp(1:2*nlon+1:2,1) - deallocate(tmp) - allocate(tmp(1,2*nlat+1)) - - start = 1; nread = 1 - nread(2) = 2*nlat+1 - call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) - glatb(1:nlat+1) = tmp(1,1:2*nlat+1:2) - deallocate(tmp) - call close_file(tilefileobj) - end select -end subroutine get_grid_cell_vertices_1D - -!> @brief returns cell vertices for the specified model component and mosaic tile number -subroutine get_grid_cell_vertices_2D(component, tile, lonb, latb, domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - class(*), intent(inout) :: lonb(:,:),latb(:,:) !< Cell vertices - type(domain2d), optional, intent(in) :: domain !< Domain - - ! local vars - integer :: nlon, nlat - integer :: i,j - real(r4_kind), allocatable :: buffer_r4(:), tmp_r4(:,:), x_vert_t_r4(:,:,:), y_vert_t_r4(:,:,:) - real(r8_kind), allocatable :: buffer_r8(:), tmp_r8(:,:), x_vert_t_r8(:,:,:), y_vert_t_r8(:,:,:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0,j0 ! offsets for coordinates - integer :: isg, jsg - integer :: start(4), nread(4) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - logical :: valid_types = .false. - - select type(lonb) - type is (real(r4_kind)) - select type(latb) - type is (real(r4_kind)) - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - valid_types = .true. - end select - type is (real(r8_kind)) - select type(latb) - type is (real(r8_kind)) - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - valid_types = .true. - end select - end select - if(.not. valid_types) call mpp_error(FATAL, & - & 'get_grid_cell_vertices_2D: invalid types, lonb/latb must be r4_kind or r8_kind') - - - if (present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - else - is = 1 ; ie = nlon - js = 1 ; je = nlat - !--- domain normally should be present - call mpp_error (NOTE, module_name//'/get_grid_cell_vertices '//& - 'domain is not present, global data will be read') - endif - i0 = -is+1; j0 = -js+1 - - ! verify that lonb and latb sizes are consistent with the size of domain - if (size(lonb,1)/=ie-is+2.or.size(lonb,2)/=je-js+2) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& - 'Size of argument "lonb" is not consistent with the domain size') - if (size(latb,1)/=ie-is+2.or.size(latb,2)/=je-js+2) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& - 'Size of argument "latb" is not consistent with the domain size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select type(lonb) - type is (real(r4_kind)) - select type(latb) - type is (real(r4_kind)) - - !! use lonb, latb as r4 - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r4(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r4(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r4(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r4(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r4(j) - enddo - enddo - deallocate(buffer_r4) - case('OCN') - if (present(domain)) then - start = 1; nread = 1 - start(1) = is; start(2) = js - nread(1) = ie-is+2; nread(2) = je-js+2 - call read_data(gridfileobj, "geolon_vert_t", lonb, corner=start, edge_lengths=nread) - call read_data(gridfileobj, "geolat_vert_t", latb, corner=start, edge_lengths=nread) - else - call read_data(gridfileobj, "geolon_vert_t", lonb) - call read_data(gridfileobj, "geolat_vert_t", latb) - endif - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r4(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r4(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r4(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r4(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r4(j) - enddo - enddo - deallocate(buffer_r4) - case('OCN') - nlon=ie-is+1; nlat=je-js+1 - allocate (x_vert_t_r4(nlon,nlat,4), y_vert_t_r4(nlon,nlat,4) ) - call read_data(gridfileobj, 'x_vert_T', x_vert_t_r4) - call read_data(gridfileobj, 'y_vert_T', y_vert_t_r4) - lonb(1:nlon,1:nlat) = x_vert_t_r4(1:nlon,1:nlat,1) - lonb(nlon+1,1:nlat) = x_vert_t_r4(nlon,1:nlat,2) - lonb(1:nlon,nlat+1) = x_vert_t_r4(1:nlon,nlat,4) - lonb(nlon+1,nlat+1) = x_vert_t_r4(nlon,nlat,3) - latb(1:nlon,1:nlat) = y_vert_t_r4(1:nlon,1:nlat,1) - latb(nlon+1,1:nlat) = y_vert_t_r4(nlon,1:nlat,2) - latb(1:nlon,nlat+1) = y_vert_t_r4(1:nlon,nlat,4) - latb(nlon+1,nlat+1) = y_vert_t_r4(nlon,nlat,3) - deallocate(x_vert_t_r4, y_vert_t_r4) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp_r4(nread(1), nread(2)) ) - call read_data(tilefileobj, "x", tmp_r4, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - lonb(i,j) = tmp_r4(2*i-1,2*j-1) - enddo - enddo - call read_data(tilefileobj, "y", tmp_r4, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - latb(i,j) = tmp_r4(2*i-1,2*j-1) - enddo - enddo - else - allocate(tmp_r4(2*nlon+1,2*nlat+1)) - call read_data(tilefileobj, "x", tmp_r4) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = tmp_r4(2*i-1,2*j-1) - end do - end do - call read_data(tilefileobj, "y", tmp_r4) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = tmp_r4(2*i-1,2*j-1) - end do - end do - endif - deallocate(tmp_r4) - call close_file(tilefileobj) - end select ! end grid_version - end select ! end latb r4 - - type is (real(r8_kind)) - select type(latb) - type is (real(r8_kind)) - - !! use lonb, latb as r8 - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r8(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r8(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r8(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r8(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r8(j) - enddo - enddo - deallocate(buffer_r8) - case('OCN') - if (present(domain)) then - start = 1; nread = 1 - start(1) = is; start(2) = js - nread(1) = ie-is+2; nread(2) = je-js+2 - call read_data(gridfileobj, "geolon_vert_t", lonb, corner=start, edge_lengths=nread) - call read_data(gridfileobj, "geolat_vert_t", latb, corner=start, edge_lengths=nread) - else - call read_data(gridfileobj, "geolon_vert_t", lonb) - call read_data(gridfileobj, "geolat_vert_t", latb) - endif - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r8(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r8(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r8(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r8(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r8(j) - enddo - enddo - deallocate(buffer_r8) - case('OCN') - nlon=ie-is+1; nlat=je-js+1 - allocate (x_vert_t_r8(nlon,nlat,4), y_vert_t_r8(nlon,nlat,4) ) - call read_data(gridfileobj, 'x_vert_T', x_vert_t_r8) - call read_data(gridfileobj, 'y_vert_T', y_vert_t_r8) - lonb(1:nlon,1:nlat) = x_vert_t_r8(1:nlon,1:nlat,1) - lonb(nlon+1,1:nlat) = x_vert_t_r8(nlon,1:nlat,2) - lonb(1:nlon,nlat+1) = x_vert_t_r8(1:nlon,nlat,4) - lonb(nlon+1,nlat+1) = x_vert_t_r8(nlon,nlat,3) - latb(1:nlon,1:nlat) = y_vert_t_r8(1:nlon,1:nlat,1) - latb(nlon+1,1:nlat) = y_vert_t_r8(nlon,1:nlat,2) - latb(1:nlon,nlat+1) = y_vert_t_r8(1:nlon,nlat,4) - latb(nlon+1,nlat+1) = y_vert_t_r8(nlon,nlat,3) - deallocate(x_vert_t_r8, y_vert_t_r8) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp_r8(nread(1), nread(2)) ) - call read_data(tilefileobj, "x", tmp_r8, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - lonb(i,j) = tmp_r8(2*i-1,2*j-1) - enddo - enddo - call read_data(tilefileobj, "y", tmp_r8, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - latb(i,j) = tmp_r8(2*i-1,2*j-1) - enddo - enddo - else - allocate(tmp_r8(2*nlon+1,2*nlat+1)) - call read_data(tilefileobj, "x", tmp_r8) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = tmp_r8(2*i-1,2*j-1) - end do - end do - call read_data(tilefileobj, "y", tmp_r8) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = tmp_r8(2*i-1,2*j-1) - end do - end do - endif - deallocate(tmp_r8) - call close_file(tilefileobj) - end select ! end grid_version - end select ! end latb r8 - end select ! end lonb -end subroutine get_grid_cell_vertices_2D - -!> @brief returns cell vertices for the specified model component and mosaic tile number for -!! an unstructured domain -subroutine get_grid_cell_vertices_UG(component, tile, lonb, latb, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: lonb(:,:),latb(:,:) ! The second dimension is 4 - type(domain2d) , intent(in) :: SG_domain !< Structured domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured domain - integer :: is, ie, js, je, i, j - real, allocatable :: SG_lonb(:,:), SG_latb(:,:), tmp(:,:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_lonb(is:ie+1, js:je+1)) - allocate(SG_latb(is:ie+1, js:je+1)) - allocate(tmp(is:ie,js:je,4)) - call get_grid_cell_vertices_2D(component, tile, SG_lonb, SG_latb, SG_domain) - do j = js, je - do i = is, ie - tmp(i,j,1) = SG_lonb(i,j) - tmp(i,j,2) = SG_lonb(i+1,j) - tmp(i,j,3) = SG_lonb(i+1,j+1) - tmp(i,j,4) = SG_lonb(i,j+1) - enddo - enddo - call mpp_pass_SG_to_UG(UG_domain, tmp, lonb) - do j = js, je - do i = is, ie - tmp(i,j,1) = SG_latb(i,j) - tmp(i,j,2) = SG_latb(i+1,j) - tmp(i,j,3) = SG_latb(i+1,j+1) - tmp(i,j,4) = SG_latb(i,j+1) - enddo - enddo - call mpp_pass_SG_to_UG(UG_domain, tmp, latb) - - - deallocate(SG_lonb, SG_latb, tmp) -end subroutine get_grid_cell_vertices_UG - -!> @brief returns grid cell centers given model component and mosaic tile number -subroutine get_grid_cell_centers_1D(component, tile, glon, glat) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: glon(:),glat(:) !< Grid cell centers - - integer :: nlon, nlat - integer :: start(4), nread(4) - real, allocatable :: tmp(:,:) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (size(glon(:))/=nlon) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& - 'Size of argument "glon" is not consistent with the grid size') - if (size(glat(:))/=nlat) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& - 'Size of argument "glat" is not consistent with the grid size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_centers_1D '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) - case('OCN') - call read_data(gridfileobj, "gridlon_t", glon) - call read_data(gridfileobj, "gridlat_t", glat) - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) - case('OCN') - call read_data(gridfileobj, "grid_x_T", glon) - call read_data(gridfileobj, "grid_y_T", glat) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - - start = 1; nread = 1 - nread(1) = 2*nlon+1; start(2) = 2 - allocate( tmp(2*nlon+1,1) ) - call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) - glon(1:nlon) = tmp(2:2*nlon:2,1) - deallocate(tmp) - allocate(tmp(1, 2*nlat+1)) - - start = 1; nread = 1 - nread(2) = 2*nlat+1; start(1) = 2 - call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) - glat(1:nlat) = tmp(1,2:2*nlat:2) - deallocate(tmp) - call close_file(tilefileobj) - end select -end subroutine get_grid_cell_centers_1D - -!> @brief returns grid cell centers given model component and mosaic tile number -subroutine get_grid_cell_centers_2D(component, tile, lon, lat, domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: lon(:,:),lat(:,:) !< Grid cell centers - type(domain2d), intent(in), optional :: domain !< Domain - ! local vars - integer :: nlon, nlat - integer :: i,j - real, allocatable :: buffer(:),tmp(:,:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0,j0 ! offsets for coordinates - integer :: isg, jsg - integer :: start(4), nread(4) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - else - is = 1 ; ie = nlon - js = 1 ; je = nlat - !--- domain normally should be present - call mpp_error (NOTE, module_name//'/get_grid_cell_centers '//& - 'domain is not present, global data will be read') - endif - i0 = -is+1; j0 = -js+1 - - ! verify that lon and lat sizes are consistent with the size of domain - if (size(lon,1)/=ie-is+1.or.size(lon,2)/=je-js+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& - 'Size of array "lon" is not consistent with the domain size') - if (size(lat,1)/=ie-is+1.or.size(lat,2)/=je-js+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& - 'Size of array "lat" is not consistent with the domain size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') - end if - select case (trim(component)) - case('ATM','LND') - allocate(buffer(max(nlon,nlat))) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - call read_data(gridfileobj, 'geolon_t', lon) - call read_data(gridfileobj, 'geolat_t', lat) - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - allocate(buffer(max(nlon,nlat))) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - call read_data(gridfileobj, 'x_T', lon) - call read_data(gridfileobj, 'y_T', lat) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic grid file - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp(nread(1), nread(2))) - call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) - do j = 1, je-js+1 - do i = 1, ie-is+1 - lon(i,j) = tmp(2*i,2*j) - enddo - enddo - call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) - do j = 1, je-js+1 - do i = 1, ie-is+1 - lat(i,j) = tmp(2*i,2*j) - enddo - enddo - else - allocate(tmp(2*nlon+1,2*nlat+1)) - call read_data(tilefileobj, 'x', tmp) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = tmp(2*i,2*j) - end do - end do - call read_data(tilefileobj, 'y', tmp) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = tmp(2*i,2*j) - end do - end do - deallocate(tmp) - endif - call close_file(tilefileobj) - end select -end subroutine get_grid_cell_centers_2D - -!> @brief returns grid cell centers given model component and mosaic tile number -!! for unstructured domain -subroutine get_grid_cell_centers_UG(component, tile, lon, lat, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: lon(:),lat(:) !< Grid cell centers - type(domain2d) , intent(in) :: SG_domain !< Structured domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured domain - integer :: is, ie, js, je - real, allocatable :: SG_lon(:,:), SG_lat(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_lon(is:ie, js:je)) - allocate(SG_lat(is:ie, js:je)) - call get_grid_cell_centers_2D(component, tile, SG_lon, SG_lat, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_lon, lon) - call mpp_pass_SG_to_UG(UG_domain, SG_lat, lat) - deallocate(SG_lon, SG_lat) -end subroutine get_grid_cell_centers_UG - !> @brief given a model component, a layout, and (optionally) a halo size, returns a !! domain for current processor subroutine define_cube_mosaic(component, domain, layout, halo, maskmap) @@ -1504,6 +417,9 @@ subroutine define_cube_mosaic(component, domain, layout, halo, maskmap) deallocate(is2,ie2,js2,je2) end subroutine define_cube_mosaic +#include "grid2_r4.fh" +#include "grid2_r8.fh" + end module grid2_mod !> @} ! close documentation grouping diff --git a/mosaic2/include/grid2.inc b/mosaic2/include/grid2.inc new file mode 100644 index 0000000000..6717ba530a --- /dev/null +++ b/mosaic2/include/grid2.inc @@ -0,0 +1,802 @@ +!*********************************************************************** +!* 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 return grid cell area for the specified model component and tile +subroutine GET_GRID_CELL_AREA_SG_(component, tile, cellarea, domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer , intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_) , intent(inout) :: cellarea(:,:) !< Cell area + type(domain2d) , intent(in), optional :: domain !< Domain + + ! local vars + integer :: nlon, nlat + real(kind=r8_kind), allocatable :: glonb(:,:), glatb(:,:) + real(kind=r8_kind), allocatable :: cellarea8(:,:) + + allocate(cellarea8(size(cellarea,1),size(cellarea,2))) + + select case(grid_version) + case(VERSION_GEOLON_T,VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_area_SG): grid_spec does not exist') + end if + select case(trim(component)) + case('LND') + call read_data(gridfileobj, 'AREA_LND_CELL', cellarea8) + case('ATM','OCN') + call read_data(gridfileobj, 'AREA_'//trim(uppercase(component)),cellarea8) + case default + call mpp_error(FATAL, module_name//'/get_grid_cell_area'//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + end select + ! convert area to m2 + cellarea = real( cellarea8*4.0_r8_kind*PI*RADIUS**2, FMS_MOS_KIND_) + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + if (present(domain)) then + call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) + else + call get_grid_size(component,tile,nlon,nlat) + endif + allocate(glonb(nlon+1,nlat+1),glatb(nlon+1,nlat+1)) + call get_grid_cell_vertices(component, tile, glonb, glatb, domain) + if (great_circle_algorithm) then + call calc_mosaic_grid_great_circle_area(glonb*PI/180.0_r8_kind, glatb*PI/180_r8_kind, cellarea8) + cellarea=real(cellarea8,FMS_MOS_KIND_) + else + call calc_mosaic_grid_area(glonb*PI/180.0_r8_kind, glatb*PI/180_r8_kind, cellarea8) + cellarea=real(cellarea8,FMS_MOS_KIND_) + end if + deallocate(glonb,glatb) + end select + + deallocate(cellarea8) + +end subroutine GET_GRID_CELL_AREA_SG_ + +!> @brief get the area of the component per grid cell +subroutine GET_GRID_COMP_AREA_SG_(component,tile,area,domain) + character(len=*) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: area(:,:) !< Area of grid cell + type(domain2d), intent(in), optional :: domain !< Domain + ! local vars + integer :: n_xgrid_files ! number of exchange grid files in the mosaic + integer :: siz(2), nxgrid + integer :: i,j,m,n + integer, allocatable :: i1(:), j1(:), i2(:), j2(:) + real(kind=r8_kind), allocatable :: xgrid_area(:) + real(kind=r8_kind), allocatable :: rmask(:,:) + character(len=MAX_NAME) :: & + xgrid_name, & ! name of the variable holding xgrid names + tile_name, & ! name of the tile + mosaic_name ! name of the mosaic + character(len=MAX_FILE) :: & + tilefile, & ! name of current tile file + xgrid_file ! name of the current xgrid file + character(len=4096) :: attvalue + character(len=MAX_NAME), allocatable :: nest_tile_name(:) + integer :: is,ie,js,je ! boundaries of our domain + integer :: i0, j0 ! offsets for x and y, respectively + integer :: num_nest_tile, ntiles + logical :: is_nest + integer :: found_xgrid_files ! how many xgrid files we actually found in the grid spec + integer :: ibegin, iend, bsize, l + type(FmsNetcdfFile_t) :: tilefileobj, xgrid_fileobj + + real(r8_kind),allocatable :: area8(:,:) + + allocate(area8(size(area,1),size(area,2))) + + select case (grid_version ) + case(VERSION_GEOLON_T,VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + select case(component) + case('ATM') + call read_data(gridfileobj,'AREA_ATM',area8) + case('OCN') + allocate(rmask(size(area8,1),size(area8,2))) + call read_data(gridfileobj,'AREA_OCN',area8) + call read_data(gridfileobj,'wet', rmask) + area = real(area8*rmask, FMS_MOS_KIND_) + deallocate(rmask) + case('LND') + call read_data(gridfileobj,'AREA_LND',area8) + case default + call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic gridspec + select case (component) + case ('ATM') + ! just read the grid cell area and return + call get_grid_cell_area(component,tile,area8) + area = real(area8, FMS_MOS_KIND_) + return + case ('LND') + xgrid_name = 'aXl_file' + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + call read_data(gridfileobj, 'lnd_mosaic', mosaic_name) + tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) + case ('OCN') + xgrid_name = 'aXo_file' + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + call read_data(gridfileobj, 'ocn_mosaic', mosaic_name) + tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) + case default + call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + end select + ! get the boundaries of the requested domain + if(present(domain)) then + call mpp_get_compute_domain(domain,is,ie,js,je) + i0 = 1-is ; j0=1-js + else + call get_grid_size(component,tile,ie,je) + is = 1 ; i0 = 0 + js = 1 ; j0 = 0 + endif + if (size(area8,1)/=ie-is+1.or.size(area8,2)/=je-js+1) & + call mpp_error(FATAL, module_name//'/get_grid_comp_area '//& + 'size of the output argument "area" is not consistent with the domain') + + ! find the nest tile + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + call read_data(gridfileobj, 'atm_mosaic', mosaic_name) + call get_grid_ntiles('atm', ntiles) + allocate(nest_tile_name(ntiles)) + num_nest_tile = 0 + do n = 1, ntiles + tilefile = read_file_name(mosaic_fileobj(1), 'gridfiles', n) + call open_grid_file(tilefileobj, grid_dir//tilefile) + if (global_att_exists(tilefileobj, "nest_grid")) then + call get_global_attribute(tilefileobj, "nest_grid", attvalue) + if(trim(attvalue) == "TRUE") then + num_nest_tile = num_nest_tile + 1 + nest_tile_name(num_nest_tile) = trim(mosaic_name)//'_tile'//char(n+ichar('0')) + else if(trim(attvalue) .NE. "FALSE") then + call mpp_error(FATAL,module_name//'/get_grid_comp_area value of global attribute nest_grid in file'//& + trim(tilefile)//' should be TRUE or FALSE') + endif + end if + call close_file(tilefileobj) + end do + area8(:,:) = 0.0_r8_kind + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + if(variable_exists(gridfileobj,xgrid_name)) then + ! get the number of the exchange-grid files + call get_variable_size(gridfileobj,xgrid_name,siz) + n_xgrid_files = siz(2) + found_xgrid_files = 0 + ! loop through all exchange grid files + do n = 1, n_xgrid_files + ! get the name of the current exchange grid file + xgrid_file = read_file_name(gridfileobj,xgrid_name,n) + call open_grid_file(xgrid_fileobj, grid_dir//xgrid_file) + ! skip the rest of the loop if the name of the current tile isn't found + ! in the file name, but check this only if there is more than 1 tile + if(n_xgrid_files>1) then + if(index(xgrid_file,trim(tile_name))==0) cycle + endif + found_xgrid_files = found_xgrid_files + 1 + !---make sure the atmosphere grid is not a nested grid + is_nest = .false. + do m = 1, num_nest_tile + if(index(xgrid_file, trim(nest_tile_name(m))) .NE. 0) then + is_nest = .true. + exit + end if + end do + if(is_nest) cycle + + ! finally read the exchange grid + nxgrid = get_mosaic_xgrid_size(xgrid_fileobj) + if(nxgrid < BUFSIZE) then + allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area(nxgrid)) + else + allocate(i1(BUFSIZE), j1(BUFSIZE), i2(BUFSIZE), j2(BUFSIZE), xgrid_area(BUFSIZE)) + endif + ibegin = 1 + do l = 1,nxgrid,BUFSIZE + bsize = min(BUFSIZE, nxgrid-l+1) + iend = ibegin + bsize - 1 + call get_mosaic_xgrid(xgrid_fileobj, i1(1:bsize), j1(1:bsize), i2(1:bsize), j2(1:bsize), & + xgrid_area(1:bsize), ibegin, iend) + ! and sum the exchange grid areas + do m = 1, bsize + i = i2(m); j = j2(m) + if (iie) cycle + if (jje) cycle + area8(i+i0,j+j0) = area8(i+i0,j+j0) + xgrid_area(m) + end do + ibegin = iend + 1 + enddo + deallocate(i1, j1, i2, j2, xgrid_area) + call close_file(xgrid_fileobj) + enddo + if (found_xgrid_files == 0) & + call mpp_error(FATAL, 'get_grid_comp_area no xgrid files were found for component '& + //trim(component)//' (mosaic name is '//trim(mosaic_name)//')') + + endif + deallocate(nest_tile_name) + end select ! version + ! convert area to m2 + area = real(area8*4.0_r8_kind*PI*RADIUS**2, FMS_MOS_KIND_) + + deallocate(area8) + +end subroutine GET_GRID_COMP_AREA_SG_ + +!> @brief return grid cell area for the specified model component and tile on an +!! unstructured domain +subroutine GET_GRID_CELL_AREA_UG_(component, tile, cellarea, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer , intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: cellarea(:) !< Cell area + type(domain2d) , intent(in) :: SG_domain !< Structured Domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured Domain + integer :: is, ie, js, je + real(kind=FMS_MOS_KIND_), allocatable :: SG_area(:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_area(is:ie, js:je)) + call get_grid_cell_area(component, tile, SG_area, SG_domain) + call mpp_pass_SG_to_UG(UG_domain, SG_area, cellarea) + deallocate(SG_area) +end subroutine GET_GRID_CELL_AREA_UG_ + +!> @brief get the area of the component per grid cell for an unstructured domain +subroutine GET_GRID_COMP_AREA_UG_(component, tile, area, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer , intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: area(:) !< Area of the component + type(domain2d) , intent(in) :: SG_domain !< Structured domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured domain + integer :: is, ie, js, je + real(kind=FMS_MOS_KIND_), allocatable :: SG_area(:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_area(is:ie, js:je)) + call get_grid_comp_area(component, tile, SG_area, SG_domain) + call mpp_pass_SG_to_UG(UG_domain, SG_area, area) + deallocate(SG_area) + +end subroutine GET_GRID_COMP_AREA_UG_ + +!> @brief returns arrays of global grid cell boundaries for given model component and +!! mosaic tile number. +subroutine GET_GRID_CELL_VERTICES_1D_(component, tile, glonb, glatb) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_),intent(inout) :: glonb(:),glatb(:) !< Grid cell vertices + + integer :: nlon, nlat + integer :: start(4), nread(4) + real(kind=FMS_MOS_KIND_), allocatable :: tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + if (size(glonb(:))/=nlon+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& + 'Size of argument "glonb" is not consistent with the grid size') + if (size(glatb(:))/=nlat+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& + 'Size of argument "glatb" is not consistent with the grid size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_vertices_1D '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) + case('OCN') + call read_data(gridfileobj, "gridlon_vert_t", glonb) + call read_data(gridfileobj, "gridlat_vert_t", glatb) + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) + case('OCN') + allocate (x_vert_t(nlon,1,2), y_vert_t(1,nlat,2) ) + start = 1; nread = 1 + nread(1) = nlon; nread(2) = 1; start(3) = 1 + call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,1), corner=start, edge_lengths=nread) + nread(1) = nlon; nread(2) = 1; start(3) = 2 + call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,2), corner=start, edge_lengths=nread) + + nread(1) = 1; nread(2) = nlat; start(3) = 1 + call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,1), corner=start, edge_lengths=nread) + nread(1) = 1; nread(2) = nlat; start(3) = 4 + call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,2), corner=start, edge_lengths=nread) + glonb(1:nlon) = x_vert_t(1:nlon,1,1) + glonb(nlon+1) = x_vert_t(nlon,1,2) + glatb(1:nlat) = y_vert_t(1,1:nlat,1) + glatb(nlat+1) = y_vert_t(1,nlat,2) + deallocate(x_vert_t, y_vert_t) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + + start = 1; nread = 1 + nread(1) = 2*nlon+1 + allocate( tmp(2*nlon+1,1) ) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + glonb(1:nlon+1) = tmp(1:2*nlon+1:2,1) + deallocate(tmp) + allocate(tmp(1,2*nlat+1)) + + start = 1; nread = 1 + nread(2) = 2*nlat+1 + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + glatb(1:nlat+1) = tmp(1,1:2*nlat+1:2) + deallocate(tmp) + call close_file(tilefileobj) + end select +end subroutine GET_GRID_CELL_VERTICES_1D_ + +!> @brief returns cell vertices for the specified model component and mosaic tile number +subroutine GET_GRID_CELL_VERTICES_2D_(component, tile, lonb, latb, domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lonb(:,:),latb(:,:) !< Cell vertices + type(domain2d), optional, intent(in) :: domain !< Domain + + ! local vars + integer :: nlon, nlat + integer :: i,j + real(kind=FMS_MOS_KIND_), allocatable :: buffer(:), tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) + integer :: is,ie,js,je ! boundaries of our domain + integer :: i0,j0 ! offsets for coordinates + integer :: isg, jsg + integer :: start(4), nread(4) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + + if (present(domain)) then + call mpp_get_compute_domain(domain,is,ie,js,je) + else + is = 1 ; ie = nlon + js = 1 ; je = nlat + !--- domain normally should be present + call mpp_error (NOTE, module_name//'/get_grid_cell_vertices '//& + 'domain is not present, global data will be read') + endif + i0 = -is+1; j0 = -js+1 + + ! verify that lonb and latb sizes are consistent with the size of domain + if (size(lonb,1)/=ie-is+2.or.size(lonb,2)/=je-js+2) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& + 'Size of argument "lonb" is not consistent with the domain size') + if (size(latb,1)/=ie-is+2.or.size(latb,2)/=je-js+2) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& + 'Size of argument "latb" is not consistent with the domain size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + !! use lonb, latb as r4 + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') + end if + select case(component) + case('ATM','LND') + allocate(buffer(max(nlon,nlat)+1)) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1)) + do j = js, je+1 + do i = is, ie+1 + lonb(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1)) + do j = js, je+1 + do i = is, ie+1 + latb(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + if (present(domain)) then + start = 1; nread = 1 + start(1) = is; start(2) = js + nread(1) = ie-is+2; nread(2) = je-js+2 + call read_data(gridfileobj, "geolon_vert_t", lonb, corner=start, edge_lengths=nread) + call read_data(gridfileobj, "geolat_vert_t", latb, corner=start, edge_lengths=nread) + else + call read_data(gridfileobj, "geolon_vert_t", lonb) + call read_data(gridfileobj, "geolat_vert_t", latb) + endif + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') + end if + select case(component) + case('ATM','LND') + allocate(buffer(max(nlon,nlat)+1)) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1)) + do j = js, je+1 + do i = is, ie+1 + lonb(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1)) + do j = js, je+1 + do i = is, ie+1 + latb(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + nlon=ie-is+1; nlat=je-js+1 + allocate (x_vert_t(nlon,nlat,4), y_vert_t(nlon,nlat,4) ) + call read_data(gridfileobj, 'x_vert_T', x_vert_t) + call read_data(gridfileobj, 'y_vert_T', y_vert_t) + lonb(1:nlon,1:nlat) = x_vert_t(1:nlon,1:nlat,1) + lonb(nlon+1,1:nlat) = x_vert_t(nlon,1:nlat,2) + lonb(1:nlon,nlat+1) = x_vert_t(1:nlon,nlat,4) + lonb(nlon+1,nlat+1) = x_vert_t(nlon,nlat,3) + latb(1:nlon,1:nlat) = y_vert_t(1:nlon,1:nlat,1) + latb(nlon+1,1:nlat) = y_vert_t(nlon,1:nlat,2) + latb(1:nlon,nlat+1) = y_vert_t(1:nlon,nlat,4) + latb(nlon+1,nlat+1) = y_vert_t(nlon,nlat,3) + deallocate(x_vert_t, y_vert_t) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + if(PRESENT(domain)) then + call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) + start = 1; nread = 1 + start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 + start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 + allocate(tmp(nread(1), nread(2)) ) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+2 + do i = 1, ie-is+2 + lonb(i,j) = tmp(2*i-1,2*j-1) + enddo + enddo + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+2 + do i = 1, ie-is+2 + latb(i,j) = tmp(2*i-1,2*j-1) + enddo + enddo + else + allocate(tmp(2*nlon+1,2*nlat+1)) + call read_data(tilefileobj, "x", tmp) + do j = js, je+1 + do i = is, ie+1 + lonb(i+i0,j+j0) = tmp(2*i-1,2*j-1) + end do + end do + call read_data(tilefileobj, "y", tmp) + do j = js, je+1 + do i = is, ie+1 + latb(i+i0,j+j0) = tmp(2*i-1,2*j-1) + end do + end do + endif + deallocate(tmp) + call close_file(tilefileobj) + end select ! end grid_version + end subroutine GET_GRID_CELL_VERTICES_2D_ + +!> @brief returns cell vertices for the specified model component and mosaic tile number for +!! an unstructured domain +subroutine GET_GRID_CELL_VERTICES_UG_(component, tile, lonb, latb, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lonb(:,:),latb(:,:) ! The second dimension is 4 + type(domain2d) , intent(in) :: SG_domain !< Structured domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured domain + integer :: is, ie, js, je, i, j + real(kind=FMS_MOS_KIND_), allocatable :: SG_lonb(:,:), SG_latb(:,:), tmp(:,:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_lonb(is:ie+1, js:je+1)) + allocate(SG_latb(is:ie+1, js:je+1)) + allocate(tmp(is:ie,js:je,4)) + call get_grid_cell_vertices(component, tile, SG_lonb, SG_latb, SG_domain) + do j = js, je + do i = is, ie + tmp(i,j,1) = SG_lonb(i,j) + tmp(i,j,2) = SG_lonb(i+1,j) + tmp(i,j,3) = SG_lonb(i+1,j+1) + tmp(i,j,4) = SG_lonb(i,j+1) + enddo + enddo + call mpp_pass_SG_to_UG(UG_domain, tmp, lonb) + do j = js, je + do i = is, ie + tmp(i,j,1) = SG_latb(i,j) + tmp(i,j,2) = SG_latb(i+1,j) + tmp(i,j,3) = SG_latb(i+1,j+1) + tmp(i,j,4) = SG_latb(i,j+1) + enddo + enddo + call mpp_pass_SG_to_UG(UG_domain, tmp, latb) + + + deallocate(SG_lonb, SG_latb, tmp) +end subroutine GET_GRID_CELL_VERTICES_UG_ + +!> @brief returns grid cell centers given model component and mosaic tile number +subroutine GET_GRID_CELL_CENTERS_1D_(component, tile, glon, glat) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: glon(:),glat(:) !< Grid cell centers + + integer :: nlon, nlat + integer :: start(4), nread(4) + real(kind=FMS_MOS_KIND_), allocatable :: tmp(:,:) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + if (size(glon(:))/=nlon) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& + 'Size of argument "glon" is not consistent with the grid size') + if (size(glat(:))/=nlat) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& + 'Size of argument "glat" is not consistent with the grid size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_centers_1D '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) + case('OCN') + call read_data(gridfileobj, "gridlon_t", glon) + call read_data(gridfileobj, "gridlat_t", glat) + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) + case('OCN') + call read_data(gridfileobj, "grid_x_T", glon) + call read_data(gridfileobj, "grid_y_T", glat) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + + start = 1; nread = 1 + nread(1) = 2*nlon+1; start(2) = 2 + allocate( tmp(2*nlon+1,1) ) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + glon(1:nlon) = tmp(2:2*nlon:2,1) + deallocate(tmp) + allocate(tmp(1, 2*nlat+1)) + + start = 1; nread = 1 + nread(2) = 2*nlat+1; start(1) = 2 + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + glat(1:nlat) = tmp(1,2:2*nlat:2) + deallocate(tmp) + call close_file(tilefileobj) + end select +end subroutine GET_GRID_CELL_CENTERS_1D_ + +!> @brief returns grid cell centers given model component and mosaic tile number +subroutine GET_GRID_CELL_CENTERS_2D_(component, tile, lon, lat, domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lon(:,:),lat(:,:) !< Grid cell centers + type(domain2d), intent(in), optional :: domain !< Domain + ! local vars + integer :: nlon, nlat + integer :: i,j + real(kind=FMS_MOS_KIND_), allocatable :: buffer(:),tmp(:,:) + integer :: is,ie,js,je ! boundaries of our domain + integer :: i0,j0 ! offsets for coordinates + integer :: isg, jsg + integer :: start(4), nread(4) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + if (present(domain)) then + call mpp_get_compute_domain(domain,is,ie,js,je) + else + is = 1 ; ie = nlon + js = 1 ; je = nlat + !--- domain normally should be present + call mpp_error (NOTE, module_name//'/get_grid_cell_centers '//& + 'domain is not present, global data will be read') + endif + i0 = -is+1; j0 = -js+1 + + ! verify that lon and lat sizes are consistent with the size of domain + if (size(lon,1)/=ie-is+1.or.size(lon,2)/=je-js+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& + 'Size of array "lon" is not consistent with the domain size') + if (size(lat,1)/=ie-is+1.or.size(lat,2)/=je-js+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& + 'Size of array "lat" is not consistent with the domain size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') + end if + select case (trim(component)) + case('ATM','LND') + allocate(buffer(max(nlon,nlat))) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) + do j = js,je + do i = is,ie + lon(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) + do j = js,je + do i = is,ie + lat(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + call read_data(gridfileobj, 'geolon_t', lon) + call read_data(gridfileobj, 'geolat_t', lat) + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + allocate(buffer(max(nlon,nlat))) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) + do j = js,je + do i = is,ie + lon(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) + do j = js,je + do i = is,ie + lat(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + call read_data(gridfileobj, 'x_T', lon) + call read_data(gridfileobj, 'y_T', lat) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic grid file + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + + if(PRESENT(domain)) then + call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) + start = 1; nread = 1 + start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 + start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 + allocate(tmp(nread(1), nread(2))) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+1 + do i = 1, ie-is+1 + lon(i,j) = tmp(2*i,2*j) + enddo + enddo + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+1 + do i = 1, ie-is+1 + lat(i,j) = tmp(2*i,2*j) + enddo + enddo + else + allocate(tmp(2*nlon+1,2*nlat+1)) + call read_data(tilefileobj, 'x', tmp) + do j = js,je + do i = is,ie + lon(i+i0,j+j0) = tmp(2*i,2*j) + end do + end do + call read_data(tilefileobj, 'y', tmp) + do j = js,je + do i = is,ie + lat(i+i0,j+j0) = tmp(2*i,2*j) + end do + end do + deallocate(tmp) + endif + call close_file(tilefileobj) + end select +end subroutine GET_GRID_CELL_CENTERS_2D_ + +!> @brief returns grid cell centers given model component and mosaic tile number +!! for unstructured domain +subroutine GET_GRID_CELL_CENTERS_UG_(component, tile, lon, lat, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lon(:),lat(:) !< Grid cell centers + type(domain2d) , intent(in) :: SG_domain !< Structured domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured domain + integer :: is, ie, js, je + real(kind=FMS_MOS_KIND_), allocatable :: SG_lon(:,:), SG_lat(:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_lon(is:ie, js:je)) + allocate(SG_lat(is:ie, js:je)) + call get_grid_cell_centers(component, tile, SG_lon, SG_lat, SG_domain) + call mpp_pass_SG_to_UG(UG_domain, SG_lon, lon) + call mpp_pass_SG_to_UG(UG_domain, SG_lat, lat) + deallocate(SG_lon, SG_lat) +end subroutine GET_GRID_CELL_CENTERS_UG_ + +!> @} +! close documentation grouping diff --git a/mosaic2/include/grid2_r4.fh b/mosaic2/include/grid2_r4.fh new file mode 100644 index 0000000000..07b069fdbb --- /dev/null +++ b/mosaic2/include/grid2_r4.fh @@ -0,0 +1,59 @@ +!*********************************************************************** +!* 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 include file for grid2_mod to generate subroutines/functions for r4_kind arguments + +!> @addtogroup grid2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r4_kind + +#undef GET_GRID_CELL_AREA_SG_ +#define GET_GRID_CELL_AREA_SG_ get_grid_cell_area_SG_r4 + +#undef GET_GRID_COMP_AREA_SG_ +#define GET_GRID_COMP_AREA_SG_ get_grid_comp_area_SG_r4 + +#undef GET_GRID_CELL_AREA_UG_ +#define GET_GRID_CELL_AREA_UG_ get_grid_cell_area_UG_r4 + +#undef GET_GRID_COMP_AREA_UG_ +#define GET_GRID_COMP_AREA_UG_ get_grid_comp_area_UG_r4 + +#undef GET_GRID_CELL_VERTICES_1D_ +#define GET_GRID_CELL_VERTICES_1D_ get_grid_cell_vertices_1D_r4 + +#undef GET_GRID_CELL_VERTICES_2D_ +#define GET_GRID_CELL_VERTICES_2D_ get_grid_cell_vertices_2D_r4 + +#undef GET_GRID_CELL_VERTICES_UG_ +#define GET_GRID_CELL_VERTICES_UG_ get_grid_cell_vertices_UG_r4 + +#undef GET_GRID_CELL_CENTERS_1D_ +#define GET_GRID_CELL_CENTERS_1D_ get_grid_cell_centers_1D_r4 + +#undef GET_GRID_CELL_CENTERS_2D_ +#define GET_GRID_CELL_CENTERS_2D_ get_grid_cell_centers_2D_r4 + +#undef GET_GRID_CELL_CENTERS_UG_ +#define GET_GRID_CELL_CENTERS_UG_ get_grid_cell_centers_UG_r4 + +#include "grid2.inc" +!> @} diff --git a/mosaic2/include/grid2_r8.fh b/mosaic2/include/grid2_r8.fh new file mode 100644 index 0000000000..c9cbf9eb23 --- /dev/null +++ b/mosaic2/include/grid2_r8.fh @@ -0,0 +1,59 @@ +!*********************************************************************** +!* 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 include file for grid2_mod to generate subroutines/functions for r8_kind arguments + +!> @addtogroup grid2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r8_kind + +#undef GET_GRID_CELL_AREA_SG_ +#define GET_GRID_CELL_AREA_SG_ get_grid_cell_area_SG_r8 + +#undef GET_GRID_CELL_AREA_UG_ +#define GET_GRID_CELL_AREA_UG_ get_grid_cell_area_UG_r8 + +#undef GET_GRID_COMP_AREA_SG_ +#define GET_GRID_COMP_AREA_SG_ get_grid_comp_area_SG_r8 + +#undef GET_GRID_COMP_AREA_UG_ +#define GET_GRID_COMP_AREA_UG_ get_grid_comp_area_UG_r8 + +#undef GET_GRID_CELL_VERTICES_1D_ +#define GET_GRID_CELL_VERTICES_1D_ get_grid_cell_vertices_1D_r8 + +#undef GET_GRID_CELL_VERTICES_2D_ +#define GET_GRID_CELL_VERTICES_2D_ get_grid_cell_vertices_2D_r8 + +#undef GET_GRID_CELL_VERTICES_UG_ +#define GET_GRID_CELL_VERTICES_UG_ get_grid_cell_vertices_UG_r8 + +#undef GET_GRID_CELL_CENTERS_1D_ +#define GET_GRID_CELL_CENTERS_1D_ get_grid_cell_centers_1D_r8 + +#undef GET_GRID_CELL_CENTERS_2D_ +#define GET_GRID_CELL_CENTERS_2D_ get_grid_cell_centers_2D_r8 + +#undef GET_GRID_CELL_CENTERS_UG_ +#define GET_GRID_CELL_CENTERS_UG_ get_grid_cell_centers_UG_r8 + +#include "grid2.inc" +!> @} diff --git a/mosaic2/include/mosaic2.inc b/mosaic2/include/mosaic2.inc new file mode 100644 index 0000000000..2da3d136db --- /dev/null +++ b/mosaic2/include/mosaic2.inc @@ -0,0 +1,167 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @file + +!> @brief Get exchange grid information from mosaic xgrid file. +!> Example usage: +!! +!! call get_mosaic_xgrid(fileobj, nxgrid, i1, j1, i2, j2, area) +!! + subroutine GET_MOSAIC_XGRID_(fileobj, i1, j1, i2, j2, area, ibegin, iend) + type(FmsNetcdfFile_t), intent(in) :: fileobj !> The file that contains exchange grid information. + integer, intent(inout) :: i1(:), j1(:), i2(:), j2(:) !> i and j indices for grids 1 and 2 + real(kind=FMS_MOS_KIND_), intent(inout) :: area(:) !> area of the exchange grid. The area is scaled to + !! represent unit earth area + integer, optional, intent(in) :: ibegin, iend + + integer :: start(4), nread(4), istart + real(kind=FMS_MOS_KIND_), dimension(2, size(i1(:))) :: tile1_cell, tile2_cell + integer :: nxgrid, n + real(kind=r8_kind) :: garea + real(kind=r8_kind) :: get_global_area + + garea = get_global_area() !< get_global_area returns a r8_kind + + ! When start and nread present, make sure nread(1) is the same as the size of the data + if(present(ibegin) .and. present(iend)) then + istart = ibegin + nxgrid = iend - ibegin + 1 + if(nxgrid .NE. size(i1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i1(:))") + if(nxgrid .NE. size(j1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j1(:))") + if(nxgrid .NE. size(i2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i2(:))") + if(nxgrid .NE. size(j2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j2(:))") + if(nxgrid .NE. size(area(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(area(:))") + else + istart = 1 + nxgrid = size(i1(:)) + endif + + start = 1; nread = 1 + start(1) = istart; nread(1) = nxgrid + + call read_data(fileobj, 'xgrid_area', area, corner=start, edge_lengths=nread) + + start = 1; nread = 1 + nread(1) = 2 + start(2) = istart; nread(2) = nxgrid + + call read_data(fileobj, 'tile1_cell', tile1_cell, corner=start, edge_lengths=nread) + call read_data(fileobj, 'tile2_cell', tile2_cell, corner=start, edge_lengths=nread) + + do n = 1, nxgrid + i1(n) = int(tile1_cell(1,n)) + j1(n) = int(tile1_cell(2,n)) + i2(n) = int(tile2_cell(1,n)) + j2(n) = int(tile2_cell(2,n)) + area(n) = real( real(area(n),r8_kind)/garea, FMS_MOS_KIND_ ) + end do + + return + + end subroutine GET_MOSAIC_XGRID_ + !############################################################################### + !> @brief Calculate grid cell area. + !> Calculate the grid cell area. The purpose of this routine is to make + !! sure the consistency between model grid area and exchange grid area. + !> @param lon geographical longitude of grid cell vertices. + !> @param lat geographical latitude of grid cell vertices. + !> @param[inout] area grid cell area. + !>
Example usage: + !! call calc_mosaic_grid_area(lon, lat, area) + subroutine CALC_MOSAIC_GRID_AREA_(lon, lat, area) + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lon + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lat + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(inout) :: area + integer :: nlon, nlat + + real(r8_kind) :: area_r8(size(area,1),size(area,2)) + + area_r8=real(area,r8_kind) + + nlon = size(area,1) + nlat = size(area,2) + ! make sure size of lon, lat and area are consitency + if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") + if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") + + ! get_grid_area only accepts double precision data + call get_grid_area( nlon, nlat, real(lon,r8_kind), real(lat,r8_kind), area_r8) + + area=real(area_r8,FMS_MOS_KIND_) + + end subroutine CALC_MOSAIC_GRID_AREA_ + !############################################################################### + !> @brief Calculate grid cell area using great cirlce algorithm + !> Calculate the grid cell area. The purpose of this routine is to make + !! sure the consistency between model grid area and exchange grid area. + !> @param lon geographical longitude of grid cell vertices. + !> @param lat geographical latitude of grid cell vertices. + !> @param[inout] area grid cell area. + !>
Example usage: + !! call calc_mosaic_grid_great_circle_area(lon, lat, area) + subroutine CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_(lon, lat, area) + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lon + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lat + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(inout) :: area + integer :: nlon, nlat + + real(r8_kind) :: area_r8(size(area,1),size(area,2)) + + nlon = size(area,1) + nlat = size(area,2) + ! make sure size of lon, lat and area are consitency + if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") + if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") + + ! get_grid_great_circle_area only accepts r8_kind arguments + call get_grid_great_circle_area( nlon, nlat, real(lon,r8_kind), real(lat,r8_kind), area_r8) + + area=real(area_r8, FMS_MOS_KIND_) + + end subroutine CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ + !##################################################################### + !> This function check if a point (lon1,lat1) is inside a polygon (lon2(:), lat2(:)) + !! lon1, lat1, lon2, lat2 are in radians. + function IS_INSIDE_POLYGON_(lon1, lat1, lon2, lat2 ) + real(kind=FMS_MOS_KIND_), intent(in) :: lon1, lat1 + real(kind=FMS_MOS_KIND_), intent(in) :: lon2(:), lat2(:) + logical :: IS_INSIDE_POLYGON_ + integer :: npts, isinside + integer :: inside_a_polygon + + npts = size(lon2(:)) + + !> inside_a_polygon function only accepts r8_kind real variables + + isinside = inside_a_polygon(real(lon1,r8_kind), real(lat1,r8_kind), npts, real(lon2,r8_kind), real(lat2,r8_kind)) + if(isinside == 1) then + IS_INSIDE_POLYGON_ = .TRUE. + else + IS_INSIDE_POLYGON_ = .FALSE. + endif + + return + + end function IS_INSIDE_POLYGON_ +!> @} diff --git a/mosaic2/include/mosaic2_r4.fh b/mosaic2/include/mosaic2_r4.fh new file mode 100644 index 0000000000..fa663bec41 --- /dev/null +++ b/mosaic2/include/mosaic2_r4.fh @@ -0,0 +1,41 @@ +!*********************************************************************** +!* 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 include file for mosaic22_mod to generate subroutines/functions for r4_kind arguments + +!> @addtogroup mosaic2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r4_kind + +#undef GET_MOSAIC_XGRID_ +#define GET_MOSAIC_XGRID_ get_mosaic_xgrid_r4 + +#undef CALC_MOSAIC_GRID_AREA_ +#define CALC_MOSAIC_GRID_AREA_ calc_mosaic_grid_area_r4 + +#undef CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ +#define CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ calc_mosaic_grid_great_circle_area_r4 + +#undef IS_INSIDE_POLYGON_ +#define IS_INSIDE_POLYGON_ is_inside_polygon_r4 + +#include "mosaic2.inc" +!> @} diff --git a/mosaic2/include/mosaic2_r8.fh b/mosaic2/include/mosaic2_r8.fh new file mode 100644 index 0000000000..fa410a245a --- /dev/null +++ b/mosaic2/include/mosaic2_r8.fh @@ -0,0 +1,41 @@ +!*********************************************************************** +!* 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 include file for mosaic2_mod to generate subroutines/functions for r8_kind arguments + +!> @addtogroup mosaic2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r8_kind + +#undef GET_MOSAIC_XGRID_ +#define GET_MOSAIC_XGRID_ get_mosaic_xgrid_r8 + +#undef CALC_MOSAIC_GRID_AREA_ +#define CALC_MOSAIC_GRID_AREA_ calc_mosaic_grid_area_r8 + +#undef CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ +#define CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ calc_mosaic_grid_great_circle_area_r8 + +#undef IS_INSIDE_POLYGON_ +#define IS_INSIDE_POLYGON_ is_inside_polygon_r8 + +#include "mosaic2.inc" +!> @} diff --git a/mosaic2/mosaic2.F90 b/mosaic2/mosaic2.F90 index 9cb4584178..0cb68f60ec 100644 --- a/mosaic2/mosaic2.F90 +++ b/mosaic2/mosaic2.F90 @@ -38,7 +38,7 @@ module mosaic2_mod use constants_mod, only : PI, RADIUS use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, get_dimension_size use fms2_io_mod, only : read_data, variable_exists -use platform_mod +use platform_mod, only : r4_kind, r8_kind implicit none private @@ -66,6 +66,28 @@ module mosaic2_mod public :: calc_mosaic_grid_great_circle_area public :: is_inside_polygon + +interface get_mosaic_xgrid + module procedure get_mosaic_xgrid_r4 + module procedure get_mosaic_xgrid_r8 +end interface get_mosaic_xgrid + +interface calc_mosaic_grid_area + module procedure calc_mosaic_grid_area_r4 + module procedure calc_mosaic_grid_area_r8 +end interface calc_mosaic_grid_area + +interface calc_mosaic_grid_great_circle_area + module procedure calc_mosaic_grid_great_circle_area_r4 + module procedure calc_mosaic_grid_great_circle_area_r8 +end interface calc_mosaic_grid_great_circle_area + +interface is_inside_polygon + module procedure is_inside_polygon_r4 + module procedure is_inside_polygon_r8 +end interface is_inside_polygon + + logical :: module_is_initialized = .true. ! Include variable "version" to be written to log file. #include @@ -103,83 +125,6 @@ function get_mosaic_xgrid_size(fileobj) return end function get_mosaic_xgrid_size -!####################################################################### -!> @brief Get exchange grid information from mosaic xgrid file. -!> Example usage: -!! -!! call get_mosaic_xgrid(fileobj, nxgrid, i1, j1, i2, j2, area) -!! - subroutine get_mosaic_xgrid(fileobj, i1, j1, i2, j2, area, ibegin, iend) - type(FmsNetcdfFile_t), intent(in) :: fileobj !> The file that contains exchange grid information. - integer, intent(inout) :: i1(:), j1(:), i2(:), j2(:) !> i and j indices for grids 1 and 2 - class(*), intent(inout) :: area(:) !> area of the exchange grid. The area is scaled to - !! represent unit earth area - integer, optional, intent(in) :: ibegin, iend - - integer :: start(4), nread(4), istart - real, dimension(2, size(i1(:))) :: tile1_cell, tile2_cell - integer :: nxgrid, n - real :: garea - real :: get_global_area - - garea = get_global_area() - - ! When start and nread present, make sure nread(1) is the same as the size of the data - if(present(ibegin) .and. present(iend)) then - istart = ibegin - nxgrid = iend - ibegin + 1 - if(nxgrid .NE. size(i1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i1(:))") - if(nxgrid .NE. size(j1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j1(:))") - if(nxgrid .NE. size(i2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i2(:))") - if(nxgrid .NE. size(j2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j2(:))") - if(nxgrid .NE. size(area(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(area(:))") - else - istart = 1 - nxgrid = size(i1(:)) - endif - - start = 1; nread = 1 - start(1) = istart; nread(1) = nxgrid - - select type(area) - type is (real(r4_kind)) - call read_data(fileobj, 'xgrid_area', area, corner=start, edge_lengths=nread) - type is (real(r8_kind)) - call read_data(fileobj, 'xgrid_area', area, corner=start, edge_lengths=nread) - class default - call mpp_error(FATAL,"get_mosaic_xgrid: invalid data type for area, must be real(r4_kind) or real(r8_kind)") - end select - - start = 1; nread = 1 - nread(1) = 2 - start(2) = istart; nread(2) = nxgrid - - select type(area) - type is (real(r4_kind)) - call read_data(fileobj, 'tile1_cell', tile1_cell, corner=start, edge_lengths=nread) - call read_data(fileobj, 'tile2_cell', tile2_cell, corner=start, edge_lengths=nread) - type is (real(r8_kind)) - call read_data(fileobj, 'tile1_cell', tile1_cell, corner=start, edge_lengths=nread) - call read_data(fileobj, 'tile2_cell', tile2_cell, corner=start, edge_lengths=nread) - end select - - do n = 1, nxgrid - i1(n) = int(tile1_cell(1,n)) - j1(n) = int(tile1_cell(2,n)) - i2(n) = int(tile2_cell(1,n)) - j2(n) = int(tile2_cell(2,n)) - select type(area) - type is (real(r4_kind)) - area(n) = real(area(n)/garea, r4_kind) - type is (real(r8_kind)) - area(n) = real(area(n)/garea, r8_kind) - end select - end do - - return - - end subroutine get_mosaic_xgrid - !############################################################################### !> Get number of tiles in the mosaic_file. !> @param fileobj mosaic file object @@ -430,172 +375,50 @@ function transfer_to_model_index(istart, iend, refine_ratio) return end function transfer_to_model_index - - !############################################################################### - !> @brief Calculate grid cell area. - !> Calculate the grid cell area. The purpose of this routine is to make - !! sure the consistency between model grid area and exchange grid area. - !> @param lon geographical longitude of grid cell vertices. - !> @param lat geographical latitude of grid cell vertices. - !> @param[inout] area grid cell area. - !>
Example usage: - !! call calc_mosaic_grid_area(lon, lat, area) - subroutine calc_mosaic_grid_area(lon, lat, area) - class(*), dimension(:,:), intent(in) :: lon - class(*), dimension(:,:), intent(in) :: lat - class(*), dimension(:,:), intent(inout) :: area - integer :: nlon, nlat - logical :: valid_types = .false. - - nlon = size(area,1) - nlat = size(area,2) - ! make sure size of lon, lat and area are consitency - if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") - if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") - select type (lon) - type is (real(r4_kind)) - select type (lat) - type is (real(r4_kind)) - select type(area) - type is (real(r4_kind)) - call get_grid_area( nlon, nlat, real(lon, r8_kind), real(lat, r8_kind), real(area, r8_kind)) - valid_types = .true. - end select - end select - type is (real(r8_kind)) - select type (lat) - type is (real(r8_kind)) - select type(area) - type is (real(r8_kind)) - call get_grid_area( nlon, nlat, lon, lat, area) - valid_types = .true. - end select - end select - end select - - if(.not. valid_types) call mpp_error(FATAL, "calc_mosaic_grid_area: invalid types given." & - //" Arguments must be all r4_kind or r8_kind") - - end subroutine calc_mosaic_grid_area - - !############################################################################### - !> @brief Calculate grid cell area using great cirlce algorithm - !> Calculate the grid cell area. The purpose of this routine is to make - !! sure the consistency between model grid area and exchange grid area. - !> @param lon geographical longitude of grid cell vertices. - !> @param lat geographical latitude of grid cell vertices. - !> @param[inout] area grid cell area. - !>
Example usage: - !! call calc_mosaic_grid_great_circle_area(lon, lat, area) - subroutine calc_mosaic_grid_great_circle_area(lon, lat, area) - class(*), dimension(:,:), intent(in) :: lon - class(*), dimension(:,:), intent(in) :: lat - class(*), dimension(:,:), intent(inout) :: area - integer :: nlon, nlat - logical :: valid_types = .false. - - nlon = size(area,1) - nlat = size(area,2) - ! make sure size of lon, lat and area are consitency - if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") - if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") - - select type (lon) - type is (real(r4_kind)) - select type (lat) - type is (real(r4_kind)) - select type(area) - type is (real(r4_kind)) - call get_grid_great_circle_area( nlon, nlat, real(lon, r8_kind), real(lat, r8_kind), real(area, r8_kind)) - valid_types = .true. - end select - end select - type is (real(r8_kind)) - select type (lat) - type is (real(r8_kind)) - select type(area) - type is (real(r8_kind)) - call get_grid_great_circle_area( nlon, nlat, lon, lat, area) - valid_types = .true. - end select - end select - end select - - if(.not. valid_types) call mpp_error(FATAL, "calc_mosaic_grid_area: invalid types given." & - //" Arguments must be all r4_kind or r8_kind") - - end subroutine calc_mosaic_grid_great_circle_area - - !##################################################################### - !> This function check if a point (lon1,lat1) is inside a polygon (lon2(:), lat2(:)) - !! lon1, lat1, lon2, lat2 are in radians. - function is_inside_polygon(lon1, lat1, lon2, lat2 ) - real, intent(in) :: lon1, lat1 - real, intent(in) :: lon2(:), lat2(:) - logical :: is_inside_polygon - integer :: npts, isinside - integer :: inside_a_polygon - - npts = size(lon2(:)) - - isinside = inside_a_polygon(lon1, lat1, npts, lon2, lat2) - if(isinside == 1) then - is_inside_polygon = .TRUE. - else - is_inside_polygon = .FALSE. - endif - - return - - end function is_inside_polygon - - function parse_string(string, set, value) - character(len=*), intent(in) :: string - character(len=*), intent(in) :: set - character(len=*), intent(out) :: value(:) - integer :: parse_string - integer :: nelem, length, first, last - - nelem = size(value(:)) - length = len_trim(string) - - first = 1; last = 0 - parse_string = 0 - - do while(first .LE. length) - parse_string = parse_string + 1 - if(parse_string>nelem) then +!##################################################################### +function parse_string(string, set, value) + character(len=*), intent(in) :: string + character(len=*), intent(in) :: set + character(len=*), intent(out) :: value(:) + integer :: parse_string + integer :: nelem, length, first, last + + nelem = size(value(:)) + length = len_trim(string) + + first = 1; last = 0 + parse_string = 0 + + do while(first .LE. length) + parse_string = parse_string + 1 + if(parse_string>nelem) then call mpp_error(FATAL, "mosaic_mod(parse_string) : number of element is greater than size(value(:))") - endif - last = first - 1 + scan(string(first:length), set) - if(last == first-1 ) then ! not found, end of string + endif + last = first - 1 + scan(string(first:length), set) + if(last == first-1 ) then ! not found, end of string value(parse_string) = string(first:length) exit - else + else if(last <= first) then - call mpp_error(FATAL, "mosaic_mod(parse_string) : last <= first") + call mpp_error(FATAL, "mosaic_mod(parse_string) : last <= first") endif value(parse_string) = string(first:(last-1)) first = last + 1 ! scan to make sure the next is not the character in the set do while (first == last+1) - last = first - 1 + scan(string(first:length), set) - if(last == first) then - first = first+1 - else - exit - endif + last = first - 1 + scan(string(first:length), set) + if(last == first) then + first = first+1 + else + exit + endif end do - endif - enddo + endif + enddo - return + return - end function parse_string +end function parse_string !############################################################################# !> Gets the name of a mosaic tile grid file @@ -603,29 +426,31 @@ end function parse_string !> @param fileobj mosaic file object !> @param domain current domain !> @param tile_count optional count of tiles - subroutine get_mosaic_tile_grid(grid_file, fileobj, domain, tile_count) - character(len=*), intent(out) :: grid_file - type(FmsNetcdfFile_t), intent(in) :: fileobj - type(domain2D), intent(in) :: domain - integer, intent(in), optional :: tile_count - integer :: tile, ntileMe - integer, dimension(:), allocatable :: tile_id - character(len=256), allocatable :: filelist(:) - integer :: ntiles - - ntiles = get_mosaic_ntiles(fileobj) - allocate(filelist(ntiles)) - tile = 1 - if(present(tile_count)) tile = tile_count - ntileMe = mpp_get_current_ntile(domain) - allocate(tile_id(ntileMe)) - tile_id = mpp_get_tile_id(domain) - call read_data(fileobj, "gridfiles", filelist) - grid_file = 'INPUT/'//trim(filelist(tile_id(tile))) - deallocate(tile_id, filelist) - - end subroutine get_mosaic_tile_grid - +subroutine get_mosaic_tile_grid(grid_file, fileobj, domain, tile_count) + character(len=*), intent(out) :: grid_file + type(FmsNetcdfFile_t), intent(in) :: fileobj + type(domain2D), intent(in) :: domain + integer, intent(in), optional :: tile_count + integer :: tile, ntileMe + integer, dimension(:), allocatable :: tile_id + character(len=256), allocatable :: filelist(:) + integer :: ntiles + + ntiles = get_mosaic_ntiles(fileobj) + allocate(filelist(ntiles)) + tile = 1 + if(present(tile_count)) tile = tile_count + ntileMe = mpp_get_current_ntile(domain) + allocate(tile_id(ntileMe)) + tile_id = mpp_get_tile_id(domain) + call read_data(fileobj, "gridfiles", filelist) + grid_file = 'INPUT/'//trim(filelist(tile_id(tile))) + deallocate(tile_id, filelist) + +end subroutine get_mosaic_tile_grid + +#include "mosaic2_r4.fh" +#include "mosaic2_r8.fh" end module mosaic2_mod !> @} diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 742d76b7a2..230ad1b164 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -25,9 +25,9 @@ ACLOCAL_AMFLAGS = -I m4 # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = astronomy coupler diag_manager data_override exchange monin_obukhov drifters \ -mosaic interpolator fms mpp mpp_io time_interp time_manager horiz_interp \ +mosaic2 interpolator fms mpp mpp_io time_interp time_manager horiz_interp topography \ field_manager axis_utils affinity fms2_io parser string_utils sat_vapor_pres tracer_manager \ -random_numbers diag_integral +random_numbers diag_integral column_diagnostics tridiagonal # testing utility scripts to distribute EXTRA_DIST = test-lib.sh.in intel_coverage.sh.in tap-driver.sh diff --git a/test_fms/column_diagnostics/Makefile.am b/test_fms/column_diagnostics/Makefile.am new file mode 100644 index 0000000000..8c9f9b6d5a --- /dev/null +++ b/test_fms/column_diagnostics/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_column_diagnostics_r4 test_column_diagnostics_r8 + +# This is the source code for the test. +test_column_diagnostics_r4_SOURCES = test_column_diagnostics.F90 +test_column_diagnostics_r8_SOURCES = test_column_diagnostics.F90 + +test_column_diagnostics_r4_CPPFLAGS=-DTEST_CD_KIND_=4 -I$(AM_CPPFLAGS) +test_column_diagnostics_r8_CPPFLAGS=-DTEST_CD_KIND_=8 -I$(AM_CPPFLAGS) + +TEST_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_column_diagnostics.sh + +# These files will be included in the distribution. +EXTRA_DIST = test_column_diagnostics.sh + +# Clean up +CLEANFILES = *.nml *.out* *.dpi *.spi *.dyn *.spl fort.* diff --git a/test_fms/column_diagnostics/test_column_diagnostics.F90 b/test_fms/column_diagnostics/test_column_diagnostics.F90 new file mode 100644 index 0000000000..cde97faa6f --- /dev/null +++ b/test_fms/column_diagnostics/test_column_diagnostics.F90 @@ -0,0 +1,191 @@ +!*********************************************************************** +!* 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 column_diagnostics_mod +!! @author MiKyung Lee +!! @email gfdl.climate.model.info@noaa.gov +!! @description This program mainly tests initialize_diagnostics_columns. +!! TODO: The current test only tests with 1 processor. A test that uses +!! domain decomposition is needed. +program test_column_diagnostics + + use column_diagnostics_mod + use fms_mod, only: fms_init + use mpp_mod, only: FATAL, mpp_error + use time_manager_mod, only: time_manager_init, time_type, set_time, set_calendar_type + use constants_mod, only : PI, DEG_TO_RAD + use platform_mod, only: r4_kind, r8_kind + + implicit none + + character(13), parameter :: mod_name='pemberley_mod' !< made up module name; Mr. Darcy's estate + integer, parameter :: num_diag_pts_latlon=2 !< number of diagnostics column described in terms of latlon coordinates + integer, parameter :: num_diag_pts_ij=2 !< number of diagnostics column describes in terms of i/j indices + integer :: global_i(num_diag_pts_ij) ! global i coordinates of the diagnostic column + integer :: global_j(num_diag_pts_ij) ! global j coordinates of the diagnostic column + real(TEST_CD_KIND_) :: global_lat_latlon(num_diag_pts_latlon)!< latitude value for the diagnostic column + real(TEST_CD_KIND_) :: global_lon_latlon(num_diag_pts_latlon)!< longitude value for the diagnostic columns + + integer, parameter :: nlatlon=6 !< number of latlon grid points + real(TEST_CD_KIND_) :: lonb_in(nlatlon,nlatlon) !< model longitude grid point + real(TEST_CD_KIND_) :: latb_in(nlatlon,nlatlon) !< model latitude point + logical :: do_column_diagnostics(nlatlon,nlatlon) !< out + + integer, parameter :: num_diag_pts=num_diag_pts_latlon + num_diag_pts_ij !< total number of diagnostics column + integer :: diag_i(num_diag_pts) !< out + integer :: diag_j(num_diag_pts) !< out + real(TEST_CD_KIND_) :: diag_lat(num_diag_pts) !< out + real(TEST_CD_KIND_) :: diag_lon(num_diag_pts) !< out + integer :: diag_units(num_diag_pts) + + integer, parameter :: lkind=TEST_CD_KIND_ !< local kind; either r4_kind or r8_kind + + call fms_init() + call time_manager_init() + call initialize_variables(0.0_lkind) !< set up input arrays + call column_diagnostics_init() !< initialize diagnostics column + call initialize_variables(0.01_lkind) !< set up input arrays; + call test_initialize_diagnostic_columns !< initialize diagnostics column + call test_column_diagnostics_header + +contains + !------------------------------------------! + subroutine initialize_variables(dlatlon) + + !> This subroutine initializes all the input arrays for intialize_diagnostic_columns + + implicit none + + real(lkind), intent(in) :: dlatlon !< in degrees; displace lat/lon grid by dlatlon + real(lkind) :: dlat, dlon + integer :: i + + !> lat lon coordinates in degrees; made up to match the diagnostic column coordinates +/- dlatlon + !! see initialize_diagnostic_columns. A-Grid coordinates + dlat=15.0_lkind !< randomly chosen value + dlon=15.0_lkind !< randomly chosen value + do i=1, nlatlon + lonb_in(i,:)=real(i,lkind)*dlat - 0.5_lkind*dlat + latb_in(:,i)=-90._lkind + real(i,lkind)*dlon -0.5_lkind*dlat + end do + + !> initialize_diagnostic_columns coordinates expects these values to be in degrees + global_lon_latlon(1)=lonb_in(2,1) + global_lon_latlon(2)=lonb_in(3,1) + global_lat_latlon(1)=latb_in(1,2) + global_lat_latlon(2)=latb_in(1,3) + global_i(1)=4 ; global_i(2)=5 + global_j(1)=4 ; global_j(2)=5 + + !> intialize_diagnostic_columns expects these values to be in radians + lonb_in=(lonb_in+dlatlon)*DEG_TO_RAD + latb_in=(latb_in+dlatlon)*DEG_TO_RAD + + + end subroutine initialize_variables + !------------------------------------------! + subroutine test_initialize_diagnostic_columns + + !> this subroutine tests intialize_diagnostics_columns + + implicit none + integer :: i + + integer :: i_answers(num_diag_pts), j_answers(num_diag_pts) + real(TEST_CD_KIND_) :: lon_answers(num_diag_pts), lat_answers(num_diag_pts) + + call initialize_diagnostic_columns(mod_name, num_diag_pts_latlon, num_diag_pts_ij, & + global_i, global_j, global_lat_latlon, global_lon_latlon, & + lonb_in, latb_in, do_column_diagnostics, & + diag_lon, diag_lat, diag_i, diag_j, diag_units) + + !> the edge points do not count + i_answers=(/2,3,4,5/) + j_answers=(/2,3,4,5/) + lon_answers=lonb_in(2:5,1)/DEG_TO_RAD + lat_answers=latb_in(1,2:5)/DEG_TO_RAD + + do i=1, num_diag_pts + call check_answers(i_answers(i), diag_i(i), 'test_initialize_diagnostics_column diag_i') + call check_answers(j_answers(i), diag_j(i), 'test_initialize_diagnostics_column diag_j') + call check_answers(lon_answers(i), diag_lon(i), 'test_initialize_diagnostics_column diag_lon') + call check_answers(lat_answers(i), diag_lat(i), 'test_initialize_diagnostics_column diag_lon') + end do + + end subroutine test_initialize_diagnostic_columns + !------------------------------------------! + subroutine test_column_diagnostics_header + + !> This subroutine only tests that column_diagnostics_header works + + implicit none + integer :: nn, diag_unit + type(time_type) :: Time + + diag_unit=45 !< will produce fort.45 file + call set_calendar_type(2) + Time=set_time(12,14,1) + do nn=1, num_diag_pts + call column_diagnostics_header(mod_name, diag_unit, Time, nn, diag_lon, diag_lat, diag_i, diag_j) + end do + + end subroutine test_column_diagnostics_header + !------------------------------------------! + subroutine check_answers(answer, myvalue, whoami) + + implicit none + class(*) :: answer + class(*) :: myvalue + character(*) :: whoami + + select type(answer) + type is ( integer ) + select type(myvalue) + type is( integer ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r4_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r8_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + end select + + end subroutine check_answers + !------------------------------------------! +end program test_column_diagnostics diff --git a/test_fms/column_diagnostics/test_column_diagnostics.sh b/test_fms/column_diagnostics/test_column_diagnostics.sh new file mode 100755 index 0000000000..909a539bfb --- /dev/null +++ b/test_fms/column_diagnostics/test_column_diagnostics.sh @@ -0,0 +1,29 @@ +#* 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 +EOF + + +##### +test_expect_success "test_column_diagnostics r4" 'mpirun -n 1 ./test_column_diagnostics_r4' +test_expect_success "test_column_diagnostics r8" 'mpirun -n 1 ./test_column_diagnostics_r8' +test_done diff --git a/test_fms/coupler/Makefile.am b/test_fms/coupler/Makefile.am index 9fba580190..cf6be6a00b 100644 --- a/test_fms/coupler/Makefile.am +++ b/test_fms/coupler/Makefile.am @@ -31,6 +31,7 @@ LDADD = ${top_builddir}/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_coupler_2d_r4 test_coupler_2d_r8 \ test_coupler_3d_r4 test_coupler_3d_r8 \ + test_coupler_types_r4 test_coupler_types_r8 \ test_atmos_ocean_fluxes_r4 test_atmos_ocean_fluxes_r8 # This is the source code for the test. @@ -38,6 +39,8 @@ test_coupler_2d_r4_SOURCES = test_coupler_2d.F90 test_coupler_utils.inc test_coupler_2d_r8_SOURCES = test_coupler_2d.F90 test_coupler_utils.inc test_coupler_3d_r4_SOURCES = test_coupler_3d.F90 test_coupler_utils.inc test_coupler_3d_r8_SOURCES = test_coupler_3d.F90 test_coupler_utils.inc +test_coupler_types_r4_SOURCES = test_coupler_types.F90 test_coupler_utils.inc +test_coupler_types_r8_SOURCES = test_coupler_types.F90 test_coupler_utils.inc test_atmos_ocean_fluxes_r4_SOURCES = test_atmos_ocean_fluxes.F90 test_atmos_ocean_fluxes_r8_SOURCES = test_atmos_ocean_fluxes.F90 @@ -46,6 +49,8 @@ test_coupler_2d_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r test_coupler_2d_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) test_coupler_3d_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r4 -I$(MODDIR) test_coupler_3d_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) +test_coupler_types_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r4 -I$(MODDIR) +test_coupler_types_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) test_atmos_ocean_fluxes_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r4 -I$(MODDIR) test_atmos_ocean_fluxes_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) @@ -60,4 +65,4 @@ TESTS = test_coupler.sh EXTRA_DIST = test_coupler.sh # Clean up -CLEANFILES = input.nml *.nc* *.out *.dpi *.spi *.dyn *.spl diag_table* +CLEANFILES = input.nml *.nc* *.out *.dpi *.spi *.dyn *.spl *_table* INPUT/*.nc diff --git a/test_fms/coupler/test_coupler.sh b/test_fms/coupler/test_coupler.sh index ece1faffc5..030a33269a 100755 --- a/test_fms/coupler/test_coupler.sh +++ b/test_fms/coupler/test_coupler.sh @@ -1,5 +1,4 @@ #!/bin/sh - #*********************************************************************** #* GNU Lesser General Public License #* @@ -18,9 +17,8 @@ #* 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/data_override directory. +# execute tests in the test_fms/coupler directory. # Ed Hartnett 11/26/19 # Uriel Ramirez 07/22/20 @@ -28,21 +26,92 @@ # Set common test settings. . ../test-lib.sh -# Run the ongrid test case with 2 halos in x and y touch input.nml +# diag_table for test cat <<_EOF > diag_table test_coupler 1 1 1 0 0 0 - #output files - "coupler_types_test", 1, "days", 1, "days", "time" - + "coupler_types_bc2", 1, "days", 1, "days", "time" + "coupler_types_bc1", 1, "days", 1, "days", "time" #output variables - "test_coupler", "dat1", "dat1", "coupler_types_test", "all", .false., "none", 2 - "test_coupler", "dat2", "dat2", "coupler_types_test", "all", .false., "none", 2 + "test_coupler_types", "bc1_var2d_1", "bc1_variable_2d_1_min", "coupler_types_bc1", "all", "min", "none", 2 + "test_coupler_types", "bc1_var2d_2", "bc1_variable_2d_2_max", "coupler_types_bc1", "all", "max", "none", 2 + "test_coupler_types", "bc1_var3d_1", "bc1_variable_3d_1", "coupler_types_bc1", "all", "rms", "none", 2 + "test_coupler_types", "bc1_var3d_2", "bc1_variable_3d_2", "coupler_types_bc1", "all", "avg", "none", 2 + "test_coupler_types", "bc2_var2d_1", "bc2_variable_2d_1_min", "coupler_types_bc2", "all", "min", "none", 2 + "test_coupler_types", "bc2_var2d_2", "bc2_variable_2d_2_max", "coupler_types_bc2", "all", "max", "none", 2 + "test_coupler_types", "bc2_var3d_1", "bc2_variable_3d_1", "coupler_types_bc2", "all", "rms", "none", 2 + "test_coupler_types", "bc2_var3d_2", "bc2_variable_3d_2", "coupler_types_bc2", "all", "avg", "none", 2 +_EOF +# we'll just make both in case compiled with yaml support +cat <<_EOF > diag_table.yaml +title: test_coupler +base_date: 1 1 1 0 0 0 +diag_files: +- file_name: coupler_types_bc2 + filename_time: end + freq: 1 days + time_units: days + unlimdim: time + varlist: + - module: test_coupler_types + var_name: bc1_var2d_1 + output_name: bc1_variable_2d_1_min + reduction: min + - module: test_coupler_types + var_name: bc1_var2d_2 + output_name: bc1_variable_2d_2_max + reduction: max + - module: test_coupler_types + var_name: bc1_var3d_1 + output_name: bc1_variable_3d_1 + reduction: rms + - module: test_coupler_types + var_name: bc1_var3d_2 + output_name: bc1_variable_3d_2 + reduction: avg +- file_name: coupler_types_bc1 + filename_time: end + freq: 1 days + time_units: days + unlimdim: time + varlist: + - module: test_coupler_types + var_name: bc2_var2d_1 + output_name: bc2_variable_2d_1_min + reduction: min + - module: test_coupler_types + var_name: bc2_var2d_2 + output_name: bc2_variable_2d_2_max + reduction: max + - module: test_coupler_types + var_name: bc2_var3d_1 + output_name: bc2_variable_3d_1 + reduction: rms + - module: test_coupler_types + var_name: bc2_var3d_2 + output_name: bc2_variable_3d_2 + reduction: avg +_EOF + +cat <<_EOF > data_table +"ATM", "bc1_var2d_1", "bc1_variable_2d_1_min", "coupler_types_bc1.nc", .false., 300.0 _EOF +rm -rf INPUT +mkdir INPUT + + +test_expect_success "coupler types interfaces (r4_kind)" ' + mpirun -n 4 ./test_coupler_types_r4 +' + +test_expect_success "coupler types interfaces (r8_kind)" ' + mpirun -n 4 ./test_coupler_types_r8 +' + mkdir RESTART test_expect_success "coupler register restart 2D(r4_kind)" ' @@ -69,5 +138,4 @@ test_expect_success "test atmos_ocean_fluxes (r8_kind)" ' ' rm -rf RESTART - test_done diff --git a/test_fms/coupler/test_coupler_types.F90 b/test_fms/coupler/test_coupler_types.F90 new file mode 100644 index 0000000000..8beb9f4695 --- /dev/null +++ b/test_fms/coupler/test_coupler_types.F90 @@ -0,0 +1,317 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +! Ryan Mulhall 8/23 + +!! defaults to ensure compilation +#ifndef FMS_CP_TEST_KIND_ +#define FMS_CP_TEST_KIND_ r8_kind +#endif + +#ifndef FMS_TEST_BC_TYPE_ +#define FMS_TEST_BC_TYPE_ bc +#endif + +!> Tests for the coupler types interfaces not tested in test_coupler_2d/3d +program test_coupler_types + +use fms_mod, only: fms_init, fms_end, stdout, string +use mpp_mod, only: mpp_error, mpp_pe, mpp_root_pe, FATAL, mpp_sync, mpp_init +use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_data_domain, domain1D +use mpp_domains_mod, only: mpp_domains_set_stack_size +use coupler_types_mod, only: coupler_3d_bc_type, coupler_2d_bc_type, coupler_1d_bc_type +use coupler_types_mod, only: coupler_type_copy, coupler_type_spawn, coupler_type_copy_data +use coupler_types_mod, only: coupler_type_redistribute_data, coupler_type_set_data, coupler_type_data_override +use coupler_types_mod, only: coupler_type_rescale_data, coupler_type_increment_data, coupler_type_extract_data +use coupler_types_mod, only: coupler_type_set_diags, coupler_type_write_chksums, coupler_type_send_data +use coupler_types_mod, only: coupler_type_destructor, coupler_type_initialized +use diag_manager_mod, only: diag_axis_init, diag_manager_end, diag_manager_init, NULL_AXIS_ID +use time_manager_mod, only: time_type, set_date, time_manager_init, set_calendar_type, JULIAN +use data_override_mod, only: data_override_init +use constants_mod, only: pi +use platform_mod, only: r8_kind, r4_kind +use fms2_io_mod, only: fms2_io_init +use netcdf, only: nf90_close, nf90_put_var, nf90_enddef, nf90_create, nf90_def_dim, nf90_clobber, & + nf90_64bit_offset, nf90_char, nf90_def_var, nf90_float +implicit none + +type(coupler_1d_bc_type) :: bc_1d_new +type(coupler_2d_bc_type) :: bc_2d_new, bc_2d_cp +type(coupler_3d_bc_type) :: bc_3d_new, bc_3d_cp +type(coupler_2d_bc_type) :: bc_2d_ref !< just used to check answers +type(coupler_3d_bc_type) :: bc_3d_ref !< just used to check answers +type(domain2D) :: Domain, Domain_out +integer :: layout(2) +integer :: nlat, nlon, nz, i, j +integer :: data_grid(5) !< i/j starting and ending indices for data domain +character(len=3) :: appendix !< appoendix added to filename +type(time_type) :: time_t +integer, parameter :: lkind = FMS_CP_TEST_KIND_ +real(FMS_CP_TEST_KIND_), allocatable :: array_2d(:,:), array_3d(:,:,:) +integer, parameter :: num_bc = 2, num_fields = 2 !< these are set in set_up_coupler_type routines +real(FMS_CP_TEST_KIND_), allocatable :: lats(:), lons(:), nzs(:) !< arrays of coordinate values for diag_axis + !! initalization +integer :: id_x, id_y, id_z, chksum_unit +character(len=128) :: chksum_2d, chksum_3d +real(FMS_CP_TEST_KIND_), allocatable :: expected_2d(:,:), expected_3d(:,:,:) +integer :: err, ncid, dim1D, varid, day + +call fms_init +call time_manager_init +call fms2_io_init +call mpp_init +call set_calendar_type(JULIAN) + +! basic domain set up +nlat=60; nlon=60; nz=12 +layout = (/2, 2/) +call mpp_domains_set_stack_size(86400) +call mpp_define_domains( (/1,nlon,1,nlat/), layout, Domain, name='test_coupler') +call mpp_define_io_domain(Domain, (/1,1/)) +call mpp_get_data_domain(Domain, data_grid(1), data_grid(2), data_grid(3), data_grid(4)) + +! create/allocate new types with routines in utils file +call set_up_1d_coupler_type(bc_1d_new, data_grid) +call set_up_2d_coupler_type(bc_2d_new, data_grid, appendix="new", to_read=.false.) +data_grid(5) = nz +call set_up_3d_coupler_type(bc_3d_new, data_grid, appendix="new", to_read=.false.) + +! coupler_type_set_data +allocate(array_2d(data_grid(1):data_grid(2), data_grid(3):data_grid(4))) +allocate(array_3d(data_grid(1):data_grid(2), data_grid(3):data_grid(4), data_grid(5))) +array_2d = 1.0_lkind +array_3d = 1.0_lkind +do i=1, num_bc + do j=1, num_fields + call coupler_type_set_data(array_2d, i, j, bc_2d_new) + call coupler_type_set_data(array_2d, i, j, data_grid(5), bc_3d_new) + call coupler_type_set_data(array_3d, i, j, bc_3d_new) + enddo +enddo +call check_field_data_2d(bc_2d_new, array_2d) +call check_field_data_3d(bc_3d_new, array_3d) + +! coupler_type_write_chksum +! needs to write to a unit num +call coupler_type_write_chksums(bc_2d_new, stdout()) +call coupler_type_write_chksums(bc_3d_new, stdout()) + +! coupler_type_increment_data +! creates copies to increment into original +call coupler_type_copy(bc_2d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ 0 /), time_t ) +call coupler_type_copy_data(bc_2d_new, bc_2d_cp) +call coupler_type_copy(bc_3d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ", & + (/ 0 /), time_t ) +call coupler_type_copy_data(bc_3d_new, bc_3d_cp) +call coupler_type_increment_data(bc_2d_new, bc_2d_cp) +call coupler_type_increment_data(bc_3d_new, bc_3d_cp) +! copy of itself incremented should just be 2.0 +array_2d = 2.0_lkind; array_3d = 2.0_lkind +call check_field_data_2d(bc_2d_cp, array_2d) +call check_field_data_3d(bc_3d_cp, array_3d) + +! coupler_type_rescale_data +call coupler_type_rescale_data(bc_2d_cp, 2.0_lkind) +call coupler_type_rescale_data(bc_3d_cp, 2.0_lkind) +array_2d = 4.0_lkind; array_3d = 4.0_lkind ! data was 2, rescaled by factor of 2 +call check_field_data_2d(bc_2d_cp, array_2d) +call check_field_data_3d(bc_3d_cp, array_3d) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) + +! coupler_type_extract_data +do i=1, num_bc + do j=1, num_fields + call coupler_type_extract_data(bc_2d_new, i, j, array_2d) + call coupler_type_extract_data(bc_3d_new, i, j, array_3d) + enddo +enddo +call check_field_data_2d(bc_2d_new, array_2d) +call check_field_data_3d(bc_3d_new, array_3d) + +! test coupler_type_copy, coupler_type_copy_data and coupler_type_destructor +time_t = set_date(1, 1, 1) +! 1d -> 2d, 3d +call coupler_type_copy(bc_1d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy(bc_1d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5)," ",& + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) +! 2d -> 2d, 3d +call coupler_type_copy(bc_2d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy(bc_2d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy_data(bc_2d_new, bc_2d_cp) +call coupler_type_copy_data(bc_2d_new, bc_3d_cp) +array_2d = 1.0; array_3d = 1.0 +call check_field_data_2d(bc_2d_cp, array_2d) +call check_field_data_3d(bc_3d_cp, array_3d) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) +! 3d -> 2d, 3d +call coupler_type_copy(bc_3d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy(bc_3d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy_data(bc_3d_new, bc_3d_cp) +call check_field_data_3d(bc_3d_cp, array_3d) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) + +! coupler_type_set_diags and coupler_type_send_data +! set up for diag manager +call diag_manager_init +allocate(lats(1:nlat), lons(1:nlon), nzs(1:nz)) +do i=1, nlat + lats(i) = i +enddo +do i=1, nlon + lons(i) = i +enddo +do i=1, nz + nzs(i) = i +enddo +id_x = diag_axis_init('x', lats, 'point_E', 'x', long_name='point_E', Domain2=Domain) +id_y = diag_axis_init('y', lons, 'point_N', 'y', long_name='point_N', Domain2=Domain) +id_z = diag_axis_init('z', nzs, 'point_Z', 'z', long_name='point_Z') +! registers field with data in type +! reset the time and assign names to each field +time_t = set_date(1, 1, 1) +do i=1, num_bc + do j=1, num_fields + bc_2d_new%FMS_TEST_BC_TYPE_(i)%field(j)%name = "bc"//string(i)//"_var2d_"//string(j) + bc_3d_new%FMS_TEST_BC_TYPE_(i)%field(j)%name = "bc"//string(i)//"_var3d_"//string(j) + bc_2d_new%FMS_TEST_BC_TYPE_(i)%field(j)%long_name = "bc"//string(i)//"_variable_2d_"//string(j)//"_min" + bc_3d_new%FMS_TEST_BC_TYPE_(i)%field(j)%long_name = "bc"//string(i)//"_variable_3d_"//string(j)//"_min" + enddo +enddo +call coupler_type_set_diags(bc_2d_new, "test_coupler_types", (/id_x, id_y/), time_t) +call coupler_type_set_diags(bc_3d_new, "test_coupler_types", (/id_x, id_y, id_z/), time_t) +call coupler_type_copy(bc_2d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/null_axis_id/), time_t) +call coupler_type_copy_data(bc_2d_new, bc_2d_cp) +call coupler_type_copy(bc_3d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ",& + (/null_axis_id/), time_t) +call coupler_type_copy_data(bc_3d_new, bc_3d_cp) + +do day=1,31 + time_t = set_date(1, 1, day) + call coupler_type_increment_data(bc_2d_cp, bc_2d_new) ! increment _new with cp + call coupler_type_increment_data(bc_3d_cp, bc_3d_new) + call coupler_type_send_data(bc_2d_new, time_t) + call coupler_type_send_data(bc_3d_new, time_t) +enddo +time_t = set_date(1, 2, 1) +call diag_manager_end(time_t) + +! coupler_type_data_override +! basic grid spec points to outputted .nc's +if( mpp_pe() .eq. mpp_root_pe()) then + err = nf90_create('INPUT/grid_spec.nc', ior(nf90_clobber, nf90_64bit_offset), ncid) + err = nf90_def_dim(ncid, 'str', 60, dim1d) + err = nf90_def_var(ncid, 'x_T', nf90_char, (/dim1d/), varid) + err = nf90_put_var(ncid, varid, "coupler_types_bc1.nc") + err = nf90_def_var(ncid, 'xta', nf90_float, (/dim1d/), varid) + err = nf90_def_var(ncid, 'yta', nf90_float, (/dim1d/), varid) + err = nf90_enddef(ncid) + err = nf90_close(ncid) +endif +call mpp_sync() +call data_override_init(Atm_domain_in=Domain, mode=FMS_CP_TEST_KIND_) + +time_t = set_date(1, 1, 15) +call coupler_type_data_override("ATM", bc_2d_new, time_t) +call coupler_type_data_override("ATM", bc_3d_new, time_t) +call coupler_type_data_override("OCN", bc_2d_new, time_t) +call coupler_type_data_override("OCN", bc_3d_new, time_t) +call coupler_type_data_override("ICE", bc_2d_new, time_t) +call coupler_type_data_override("ICE", bc_3d_new, time_t) +call coupler_type_data_override("LND", bc_2d_new, time_t) +call coupler_type_data_override("LND", bc_3d_new, time_t) + +! coupler_type_redistribute_data +! just using the same domain +call mpp_define_domains((/1, nlon, 1, nlat/), layout, Domain_out, name="test_coupler_redistributed_2x2") +call set_up_2d_coupler_type(bc_2d_cp, data_grid, appendix="new", to_read=.false.) +call set_up_3d_coupler_type(bc_3d_cp, data_grid, appendix="new", to_read=.false.) +call coupler_type_redistribute_data(bc_2d_new, Domain, bc_2d_cp, domain_out, complete=.true.) +call coupler_type_redistribute_data(bc_3d_new, Domain, bc_3d_cp, domain_out, complete=.true.) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) +! using a different layout +call mpp_define_domains((/1, nlon, 1, nlat/), (/1, 4/), Domain_out, name="test_coupler_redistributed_1x4") +call mpp_get_data_domain(Domain_out, data_grid(1), data_grid(2), data_grid(3), data_grid(4)) +call set_up_2d_coupler_type(bc_2d_cp, data_grid, appendix="new", to_read=.false.) +call set_up_3d_coupler_type(bc_3d_cp, data_grid, appendix="new", to_read=.false.) +call coupler_type_redistribute_data(bc_2d_new, Domain, bc_2d_cp, domain_out, complete=.true.) +call coupler_type_redistribute_data(bc_3d_new, Domain, bc_3d_cp, domain_out, complete=.true.) +! clean up +call coupler_type_destructor(bc_1d_new) +call coupler_type_destructor(bc_2d_new) +call coupler_type_destructor(bc_3d_new) +! check deallocation +! both should be deallocated regardless of kind +if( associated(bc_1d_new%bc) .or. associated(bc_2d_new%bc) .or. associated(bc_3d_new%bc)) & + call mpp_error(FATAL, "test_coupler_types: bc type still associated after destructor called") +if( associated(bc_1d_new%bc_r4) .or. associated(bc_2d_new%bc_r4) .or. associated(bc_3d_new%bc_r4)) & + call mpp_error(FATAL, "test_coupler_types: bc_r4 type still associated after destructor called") + +call fms_end + +contains + +#include "test_coupler_utils.inc" + +subroutine check_field_data_2d(bc_2d, expected) + type(coupler_2d_bc_type) :: bc_2d + real(FMS_CP_TEST_KIND_), intent(in) :: expected(:,:) + real(FMS_CP_TEST_KIND_), pointer :: values_ptr(:,:) + + do i=1, bc_2d%num_bcs + do j=1, bc_2d%FMS_TEST_BC_TYPE_(i)%num_fields + values_ptr => bc_2d%FMS_TEST_BC_TYPE_(i)%field(j)%values + ! checks each index + if(SUM(values_ptr) .ne. SUM(expected)) then + print *, "SUMS", SUM(values_ptr), SUM(expected), SHAPE(values_ptr), SHAPE(expected) + call mpp_error(FATAL, "test_coupler_types: incorrect 2d values against expected result") + endif + enddo + enddo +end subroutine + +subroutine check_field_data_3d(bc_3d, expected) + type(coupler_3d_bc_type) :: bc_3d + real(FMS_CP_TEST_KIND_), intent(in) :: expected(:,:,:) + real(FMS_CP_TEST_KIND_), pointer :: values_ptr(:,:,:) + integer :: x, y, z, vals_start(3) !< need start point for indices, passed in will always be 1-n + + do i=1, bc_3d%num_bcs + do j=1, bc_3d%FMS_TEST_BC_TYPE_(i)%num_fields + values_ptr => bc_3d%FMS_TEST_BC_TYPE_(i)%field(j)%values + if(SUM(values_ptr) .ne. SUM(expected)) then + print *, "SUMS", SUM(values_ptr), SUM(expected), SHAPE(values_ptr), SHAPE(expected) + call mpp_error(FATAL, "test_coupler_types: incorrect 3d values against expected result") + endif + enddo + enddo +end subroutine check_field_data_3d + +end program \ No newline at end of file diff --git a/test_fms/coupler/test_coupler_utils.inc b/test_fms/coupler/test_coupler_utils.inc index 0f6698c423..6c2ee91d77 100644 --- a/test_fms/coupler/test_coupler_utils.inc +++ b/test_fms/coupler/test_coupler_utils.inc @@ -19,16 +19,20 @@ !> Include file to hold common routines for the coupler tests !! Uses the FMS_TEST_BC_TYPE_ macro to test both r4/r8 +!! constants used for test +#define BCNUM_ 2 +#define FLDNUM_ 2 + subroutine set_up_1d_coupler_type(bc_type, data_grid) type(coupler_1d_bc_type), intent(inout) :: bc_type !< Coupler 2d restart types - integer, dimension(4), intent(in) :: data_grid !< Starting and ending indexes of data_domain + integer, dimension(2), intent(in) :: data_grid !< Starting and ending indexes of data_domain integer :: nfiles, nfields, i, j character(len=1) :: field_num, file_num !bc_type%isc = data_grid(1); bc_type%iec = data_grid(2) !bc_type%isd = data_grid(1); bc_type%ied = data_grid(2) bc_type%set = .true. - bc_type%num_bcs = 2 + bc_type%num_bcs = BCNUM_ nfiles = bc_type%num_bcs allocate(bc_type%FMS_TEST_BC_TYPE_(nfiles)) @@ -36,7 +40,7 @@ subroutine set_up_1d_coupler_type(bc_type, data_grid) write(file_num,'(i1)') i bc_type%FMS_TEST_BC_TYPE_(i)%ice_restart_file="default_"//file_num//"_ice_restart_2d.nc" - bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=2 + bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=FLDNUM_ nfields = bc_type%FMS_TEST_BC_TYPE_(i)%num_fields allocate(bc_type%FMS_TEST_BC_TYPE_(i)%field(nfields)) @@ -67,9 +71,9 @@ subroutine set_up_2d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%set = .true. if (to_read) then - bc_type%num_bcs = 3 + bc_type%num_bcs = BCNUM_ + 1 else - bc_type%num_bcs = 2 + bc_type%num_bcs = BCNUM_ endif bc_type%isc = data_grid(1); bc_type%iec = data_grid(2) @@ -88,7 +92,7 @@ subroutine set_up_2d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%FMS_TEST_BC_TYPE_(i)%ice_restart_file=appendix//"_"//file_num//"_ice_restart_2d.nc" endif - bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=2 + bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=FLDNUM_ nfields = bc_type%FMS_TEST_BC_TYPE_(i)%num_fields allocate(bc_type%FMS_TEST_BC_TYPE_(i)%field(nfields)) @@ -181,9 +185,9 @@ subroutine set_up_3d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%set = .true. if (to_read) then - bc_type%num_bcs = 3 + bc_type%num_bcs = BCNUM_ + 1 else - bc_type%num_bcs = 2 + bc_type%num_bcs = BCNUM_ endif nfiles = bc_type%num_bcs @@ -199,7 +203,7 @@ subroutine set_up_3d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%FMS_TEST_BC_TYPE_(i)%ice_restart_file=appendix//"_"//file_num//"_ice_restart_3d.nc" endif - bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=2 + bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=FLDNUM_ nfields = bc_type%FMS_TEST_BC_TYPE_(i)%num_fields allocate(bc_type%FMS_TEST_BC_TYPE_(i)%field(nfields)) diff --git a/test_fms/mosaic/test_mosaic.F90 b/test_fms/mosaic/test_mosaic.F90 deleted file mode 100644 index 6c436d27f2..0000000000 --- a/test_fms/mosaic/test_mosaic.F90 +++ /dev/null @@ -1,145 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** - -!> @brief This programs tests calls to get_mosaic_ntiles, get_mosaic_ncontacts, -!! get_mosaic_grid_sizes, get_mosaic_contact -program test_mosaic - -use mosaic2_mod, only : get_mosaic_ntiles, get_mosaic_ncontacts -use mosaic2_mod, only : get_mosaic_grid_sizes, get_mosaic_contact -use mpp_mod, only : mpp_init, mpp_error, FATAL, mpp_sync, mpp_npes, mpp_get_current_pelist -use fms2_io_mod, only : open_file, close_file, FmsNetcdfFile_t -use fms2_io_mod, only : register_axis, register_field, write_data -use fms_mod, only : fms_init, fms_end - -implicit none - -integer :: ntiles !< Number of tiles -integer :: ncontacts !< Number of contacts -integer :: n !< For do loops -integer, allocatable :: tile1(:) !< tile number for first contact -integer, allocatable :: tile2(:) !< tile number of the second contact -integer, allocatable :: nx(:), ny(:) !< Number of x/y points for each tile -integer, allocatable :: istart1(:), iend1(:), jstart1(:), jend1(:) !< Indexes of first contact point -integer, allocatable :: istart2(:), iend2(:), jstart2(:), jend2(:) !< Indexes of second contact point -character(len=128) :: mosaic_file !< Mosaic filename -type(FmsNetcdfFile_t):: mosaic_fileobj !< Fileobj for the file read by the test -integer :: answers(2, 8) !< Expected results -integer, allocatable :: pes(:) !< List of pes in the current pelist - -call mpp_init() -call fms_init() - -mosaic_file = "INPUT/ocean_mosaic.nc" -answers(1,:) = (/1440, 1440, 1, 1080, 1, 1, 1, 1080 /) -answers(2,:) = (/1, 720, 1080, 1080, 1440, 721, 1080, 1080 /) - -allocate(pes(mpp_npes())) -call mpp_get_current_pelist(pes) - -call create_files(pes) - -!< Open the mosaic file -if(.not. open_file(mosaic_fileobj, mosaic_file, 'read', pelist=pes)) then - call mpp_error(FATAL, 'test_mosaic: error in opening file '//trim(mosaic_file)) -endif - -ntiles = get_mosaic_ntiles(mosaic_fileobj) -ncontacts = get_mosaic_ncontacts(mosaic_fileobj) -allocate(nx(ntiles), ny(ntiles)) -allocate(tile1(ncontacts), tile2(ncontacts) ) -allocate(istart1(ncontacts), iend1(ncontacts), jstart1(ncontacts), jend1(ncontacts) ) -allocate(istart2(ncontacts), iend2(ncontacts), jstart2(ncontacts), jend2(ncontacts) ) - -call get_mosaic_grid_sizes(mosaic_fileobj, nx, ny ) -call get_mosaic_contact(mosaic_fileobj, tile1, tile2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2) - -!< Compare with expected results: -if (ntiles .ne. 1) call mpp_error(FATAL, "ntiles is not equal to 1") - -do n = 1, ntiles - if (nx(n) .ne. 2880/2) call mpp_error(FATAL, "nx is not the expected result") - if (ny(n) .ne. 2160/2) call mpp_error(FATAL, "ny is not the expected result") -end do - -if (ncontacts .ne. 2) call mpp_error(FATAL, "ncontacts is not the expected result") -do n = 1, ncontacts - if (istart1(n) .ne. answers(n,1)) call mpp_error(FATAL, "istart1 is not the expected result") - if (iend1(n) .ne. answers(n,2)) call mpp_error(FATAL, "iend1 is not the expected result") - - if (jstart1(n) .ne. answers(n,3)) call mpp_error(FATAL, "jstart1 is not the expected result") - if (jend1(n) .ne. answers(n,4)) call mpp_error(FATAL, "jend1 is not the expected result") - - if (istart2(n) .ne. answers(n,5)) call mpp_error(FATAL, "istart2 is not the expected result") - if (iend2(n) .ne. answers(n,6)) call mpp_error(FATAL, "iend2 is not the expected result") - - if (jstart2(n) .ne. answers(n,7)) call mpp_error(FATAL, "jstart2 is not the expected result") - if (jend2(n) .ne. answers(n,8)) call mpp_error(FATAL, "jend2 is not the expected result") -end do - -deallocate(tile1, tile2, nx, ny) -deallocate(istart1, iend1, jstart1, jend1) -deallocate(istart2, iend2, jstart2, jend2) - -call close_file(mosaic_fileobj) -call fms_end() - -contains - -subroutine create_files(pes) - integer, intent(in) :: pes(:) !< List of pes - - type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test - character(len=255) :: str_array(2) !< Array of strings because GNU - - if( open_file(fileobj, mosaic_file, 'overwrite', pelist=pes)) then - call register_axis(fileobj, "ntiles", 1) - call register_axis(fileobj, "ncontact", 2) - call register_axis(fileobj, "string", 255) - - str_array(1) = "string" - str_array(2) = "ncontact" - call register_field(fileobj, "contacts", "char", dimensions=str_array) - call register_field(fileobj, "contact_index", "char", dimensions=str_array) - call register_field(fileobj, "gridfiles", "char", dimensions=(/"string", "ntiles"/)) - call register_field(fileobj, "gridtiles", "char", dimensions=(/"string", "ntiles"/)) - - call write_data(fileobj, "gridfiles", (/"ocean_hgrid.nc"/)) - call write_data(fileobj, "gridtiles", (/"tile1"/)) - - str_array(1) = "2880:2880,1:2160::1:1,1:2160" - str_array(2) = "1:1440,2160:2160::2880:1441,2160:2160" - call write_data(fileobj, "contact_index", str_array) - call write_data(fileobj, "contacts", & - & (/"ocean_mosaic:tile1::ocean_mosaic:tile1", "ocean_mosaic:tile1::ocean_mosaic:tile1" /)) - - call close_file(fileobj) - endif - call mpp_sync() - - if( open_file(fileobj, "INPUT/ocean_hgrid.nc", "overwrite", pelist=pes)) then - call register_axis(fileobj, "nx", 2880) - call register_axis(fileobj, "ny", 2160) - - call close_file(fileobj) - endif - call mpp_sync() -end subroutine create_files - -end program test_mosaic diff --git a/test_fms/mosaic2/Makefile.am b/test_fms/mosaic2/Makefile.am new file mode 100644 index 0000000000..ca0b4804d4 --- /dev/null +++ b/test_fms/mosaic2/Makefile.am @@ -0,0 +1,61 @@ +#*********************************************************************** +#* 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/mosaic directory of the +# FMS package. + +# uramirez, Ed Hartnett + +# Find the needed mod and include files. +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) -I./INPUT -I$(top_srcdir)/mosaic -I./ + +# Link to the FMS library. +LDADD = $(top_builddir)/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_mosaic2_r4 test_mosaic2_r8 test_grid2_r4 test_grid2_r8 + +# This is the source code for the test +test_mosaic2_r4_SOURCES = test_mosaic2.F90 write_files.inc +test_grid2_r4_SOURCES = test_grid2.F90 write_files.inc + +test_mosaic2_r8_SOURCES = test_mosaic2.F90 write_files.inc +test_grid2_r8_SOURCES = test_grid2.F90 write_files.inc + +test_mosaic2_r4_CPPFLAGS=-DTEST_MOS_KIND_=4 $(AM_CPPFLAGS) +test_grid2_r4_CPPFLAGS =-DTEST_MOS_KIND_=4 $(AM_CPPFLAGS) + +test_mosaic2_r8_CPPFLAGS=-DTEST_MOS_KIND_=8 $(AM_CPPFLAGS) +test_grid2_r8_CPPFLAGS =-DTEST_MOS_KIND_=8 $(AM_CPPFLAGS) + +# These files are also included in the distribution. +EXTRA_DIST = test_mosaic2.sh + +if SKIP_MOSAIC_TESTS +TESTS_ENVIRONMENT = SKIP_TESTS="test_mosaic2.1 test_mosaic2.2 test_mosaic2.3 test_mosaic2.4" +endif + +# Run the test program. +TESTS = test_mosaic2.sh + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ + $(abs_top_srcdir)/test_fms/tap-driver.sh +# Clean up +CLEANFILES = input.nml *.nc *.out *.dpi *.spi *.dyn *.spl *.mod diff --git a/test_fms/mosaic2/test_grid2.F90 b/test_fms/mosaic2/test_grid2.F90 new file mode 100644 index 0000000000..3f008badb2 --- /dev/null +++ b/test_fms/mosaic2/test_grid2.F90 @@ -0,0 +1,258 @@ +!*********************************************************************** +!* 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 calls to get_mosaic_ntiles, get_mosaic_ncontacts, +!! get_mosaic_grid_sizes, get_mosaic_contact. All subroutines here are tested +!! with C1 tiles where tiles 1-6 are identical. The tile points are made up with +!! values that result in simple answers. See write_files module for grid details. + +#include "write_files.inc" !> including write_files.mod because I don't know how to compile when write_files.mod is + !! in a separate file. +program test_mosaic + +use mpp_mod, only : mpp_init, mpp_error, FATAL, mpp_npes, mpp_pe, mpp_root_pe +use mpp_domains_mod, only: domain2D, domainUG, mpp_define_domains, mpp_get_compute_domain, mpp_define_unstruct_domain +use fms2_io_mod, only : open_file, close_file, FmsNetcdfFile_t, fms2_io_init +use fms2_io_mod, only : register_axis, register_field, write_data, read_data +use fms_mod, only : fms_init, fms_end +use platform_mod, only : r4_kind, r8_kind +use grid2_mod +use write_files + +implicit none + +!> write out netcdf files +!! write_all sets up the grids +call fms2_io_init() +call write_all() +call fms_init() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_CELL_VERTICIES' +call test_get_cell_vertices + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_CELL_CENTERS' +call test_get_cell_centers + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_CELL_AREA_SG' +call test_get_grid_cell_area_sg + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST_GET_GRID_CELL_AREA_UG' +call test_get_grid_cell_area_ug + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_COMP_AREA_SG' +call test_get_grid_comp_area_sg + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_COMP_AREA_UG' +call test_get_grid_comp_area_ug + +contains + !------------------------------------------! + subroutine test_get_cell_vertices + + !> This subroutine tests get_cell_verticees. This + !! subroutine only tests for vertices in tile 1. + + implicit none + + real(TEST_MOS_KIND_) :: lonb_2d(c1_nx,c1_ny) !< returned values for lon 2d + real(TEST_MOS_KIND_) :: latb_2d(c1_nx,c1_ny) !< returned values for lat 2d + real(TEST_MOS_KIND_) :: answer_lon_2d(c1_nx,c1_ny) !< answers for lon 2d + real(TEST_MOS_KIND_) :: answer_lat_2d(c1_nx,c1_ny) !< answers for lat 2d + + integer :: i,j + + !> answers + answer_lon_2d=x(1:c1_nxp:2, 1:c1_nxp:2) + answer_lat_2d=y(1:c1_nxp:2, 1:c1_nxp:2) + + call get_grid_cell_vertices('ATM',1,lonb_2d,latb_2d) + !> check + do j=1, c1_ny + do i=1, c1_nx + call check_answer(answer_lon_2d(i,j), lonb_2d(i,j), 'TEST_GET_CELL_VERTICIES_2D lon') + call check_answer(answer_lat_2d(i,j), latb_2d(i,j), 'TEST_GET_CELL_VERTICIES_2D lat') + end do + end do + + end subroutine test_get_cell_vertices + !------------------------------------------! + subroutine test_get_cell_centers + + !> This subroutine tests get_cell_centers. + !! There is only one cell center point in a C1 tile. + + implicit none + + integer, parameter :: nx = c1_nx/2 !< number of center points + integer, parameter :: ny = c1_ny/2 !< number of center points + + real(TEST_MOS_KIND_) :: glon_2d(nx,ny) !< results from grid_cell_centers + real(TEST_MOS_KIND_) :: glat_2d(nx,ny) !< results from grid_cell_centers + real(TEST_MOS_KIND_) :: answer_glon_2d(nx,ny) !< answers for glon + real(TEST_MOS_KIND_) :: answer_glat_2d(nx,ny) !< answers for glat + + integer :: i, j + + !--- 2d ---! + answer_glon_2d=x(2:c1_nx:2, 2:c1_nx:2) + answer_glat_2d=y(2:c1_nx:2, 2:c1_nx:2) + + call get_grid_cell_centers('ATM', 1, glon_2d, glat_2d) + do i=1, nx + do j=1, ny + call check_answer(answer_glon_2d(j,i), glon_2d(j,i), 'TEST_GET_CELL_CENTERS_2D lon') + call check_answer(answer_glat_2d(j,i), glat_2d(j,i), 'TEST_GET_CELL_CENTERS_2D lat') + end do + end do + + end subroutine test_get_cell_centers + !------------------------------------------! + subroutine test_get_grid_cell_area_sg + + !> This subroutine tests get_grid_cell_area_SG + !! first without the domain input argument and second + !! with the domain input argument + + implicit none + + type(domain2D) :: SG_domain + real(TEST_MOS_KIND_) :: area_out2(1,1) + real(TEST_MOS_KIND_) :: answer + + answer = real(2.0_r8_kind*PI*RADIUS*RADIUS,lkind) + + !> total of 1 domain with 1 (center) point in the domain + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + + !> Test withtout SG_domain + call get_grid_cell_area('ATM',2, area_out2) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_CELL_AREA_SG') + + !> Test with SG_domain + call get_grid_cell_area('ATM',2, area_out2, SG_domain) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_CELL_AREA_SG with SG_domain') + + end subroutine test_get_grid_cell_area_sg + !------------------------------------------! + subroutine test_get_grid_cell_area_ug + + !> This subroutine tests get_grid_cell_area_ug + + implicit none + type(domain2D) :: SG_domain + type(domainUG) :: UG_domain !< UG_domain is the same as SG_domain + real(TEST_MOS_KIND_) :: area_out1(1) + real(TEST_MOS_KIND_) :: answer + integer :: i + integer :: npts_tile(1),grid_nlevel(1), ndivs, grid_index(1) + + npts_tile=1 + grid_nlevel=1 + ndivs=1 + grid_index=1 + + answer = real( 4.0_r8_kind * area(1,1), TEST_MOS_KIND_) + + !> The unstructured grid is the same as the structured grid; there's only one center point in the tile. + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + call mpp_define_unstruct_domain(UG_domain, SG_domain,npts_tile,grid_nlevel,& + mpp_npes(),ndivs,grid_index,name='immadeup') + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + call get_grid_cell_area('ATM',1, area_out1, SG_domain, UG_domain) + call check_answer(answer, area_out1(1), 'TEST_GRID_CELL_AREA_UG') + + end subroutine test_get_grid_cell_area_ug + !------------------------------------------! + subroutine test_get_grid_comp_area_sg + + !> This subroutine tests get_grid_comp_area_sg + !! first without the domain input argument and second + !! with the domain input argument + + implicit none + type(domain2D) :: SG_domain + real(TEST_MOS_KIND_) :: area_out2(1,1) + real(TEST_MOS_KIND_) :: answer + + answer = real( 4.0_r8_kind * area(1,1), TEST_MOS_KIND_) + + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + !! Test without SG_domain + call get_grid_comp_area('ATM', 1, area_out2) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_COMP_AREA_SG') + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + !! Test with SG_domain + call get_grid_comp_area('ATM', 1, area_out2, SG_domain) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_COMP_AREA_SG with SG_domain') + + end subroutine test_get_grid_comp_area_sg + !------------------------------------------! + subroutine test_get_grid_comp_area_ug + + !> This subroutine tests get_grid_comp_area_ug + + implicit none + type(domain2D) :: SG_domain + type(domainUG) :: UG_domain !< UG_domain is the same as SG_domain + integer :: npts_tile(1), ntiles_grid(1), grid_index(1) + real(TEST_MOS_KIND_) :: answer + real(TEST_MOS_KIND_) :: area_out1(1) + + npts_tile=1 + ntiles_grid=1 + grid_index(1)=1 + answer = real( 4.0_r8_kind * area(1,1), TEST_MOS_KIND_) + + !> the unstructured grid is the same as the structured grid + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + call mpp_define_unstruct_domain(UG_domain, SG_domain, npts_tile, ntiles_grid,mpp_npes(),1,grid_index) + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + call get_grid_comp_area('ATM',3,area_out1,SG_domain, UG_domain) + call check_answer(answer, area_out1(1), 'TEST_GRID_CELL_AREA_UG') + + end subroutine test_get_grid_comp_area_ug + !------------------------------------------! + subroutine check_answer(answer, myvalue, whoami) + + implicit none + real(TEST_MOS_KIND_) :: answer + real(TEST_MOS_KIND_) :: myvalue + character(*) :: whoami + + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + + end subroutine check_answer +!------------------------------------------------------! +end program test_mosaic diff --git a/test_fms/mosaic2/test_mosaic2.F90 b/test_fms/mosaic2/test_mosaic2.F90 new file mode 100644 index 0000000000..10da8a2820 --- /dev/null +++ b/test_fms/mosaic2/test_mosaic2.F90 @@ -0,0 +1,328 @@ +!*********************************************************************** +!* 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 calls to get_mosaic_ntiles, get_mosaic_ncontacts, +!! get_mosaic_grid_sizes, get_mosaic_contact. The subroutines are tested with +!! made up C1 grids and exchange grids. See write_files mod for grid details. + +#include "write_files.inc" !> including write_files.mod because I don't know how to compile when write_files.mod is + !! in a separate file. +program test_mosaic + +use mosaic2_mod +use grid2_mod +use write_files +use mpp_mod, only : mpp_init, mpp_error, FATAL, mpp_pe, mpp_root_pe +use fms2_io_mod, only : open_file, close_file, FmsNetcdfFile_t, fms2_io_init, read_data +use fms_mod, only : fms_init, fms_end +use constants_mod, only : DEG_TO_RAD +use platform_mod, only : r4_kind, r8_kind + +implicit none + +!> create mosaic and grid files +!! In orderr to create the mosaic and grid files, fms2_io needs to be initialized first +call fms2_io_init() +call write_all() +!< fms_init calls grid_init which reads in the grid_spec file +!! In this case, the grid_version is VERSION_OCN_MOSAIC_FILE. +call fms_init() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_MOSAIC_GRID_SIZES' +call test_get_mosaic_grid_sizes() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_MOSAIC_CONTACT' +call test_get_mosaic_contact() + +!> does not work, results in negative areas for r4_kind. Figure out why later +!if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_GREAT_CIRCLE_AREA' +!call test_get_grid_great_circle_area() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST CALC_MOSAIC_GRID_AREA' +call test_calc_mosaic_grid_area() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_MOSAIC_XGRID' +call test_get_mosaic_xgrid() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST IS_INSIDE_POLYGON' +call test_is_inside_polygon() + +call fms_end() + +contains +!------------------------------------------------------! +subroutine test_get_mosaic_grid_sizes + + !> test get_mosaic_grid_sizes + + integer :: ntiles !< number of tiles + integer :: n !< counter + integer, allocatable :: nx_out(:), ny_out(:) !< number of grid points for each tile + type(FmsNetcdfFile_t):: fileobj + + !-- ocean --! + if( .not. open_file(fileobj, 'INPUT/'//trim(ocn_mosaic_file), 'read') ) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(ocn_mosaic_file)) + + allocate( nx_out(ocn_ntiles), ny_out(ocn_ntiles) ) + !> get_mosaic_grid_sizes reads in the grid file + call get_mosaic_grid_sizes(fileobj, nx_out, ny_out ) + do n=1, ocn_ntiles + call check_answer(ocn_nx/2, nx_out(n), 'ocn TEST_GET_MOSAIC_GRID_SIZES') + call check_answer(ocn_nY/2, ny_out(n), 'ocn TEST_GET_MOSAIC_GRID_SIZES') + end do + deallocate(nx_out, ny_out) + call close_file(fileobj) + + !-- atm --! + if( .not. open_file(fileobj, 'INPUT/'//trim(c1_mosaic_file), 'read') ) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(c1_mosaic_file)) + + allocate( nx_out(c1_ntiles), ny_out(c1_ntiles) ) + call get_mosaic_grid_sizes(fileobj, nx_out, ny_out) + do n=1, ntiles + call check_answer(c1_nx/2, nx_out(n), 'atm TEST_GET_MOSAIC_GRID_SIZES') + call check_answer(c1_nx/2, ny_out(n), 'atm TEST_GET_MOSAIC_GRID_SIZES') + end do + deallocate(nx_out, ny_out) + call close_file(fileobj) + +end subroutine test_get_mosaic_grid_sizes +!------------------------------------------------------! +subroutine test_get_mosaic_contact + + !< @uriel.ramirez + + integer :: ntiles !< Number of tiles + integer :: ncontacts !< Number of contacts + integer :: n !< For do loops + integer, allocatable :: tile1(:) !< tile number for first contact + integer, allocatable :: tile2(:) !< tile number of the second contact + integer, allocatable :: nx(:), ny(:) !< Number of x/y points for each tile + integer, allocatable :: istart1(:), iend1(:), jstart1(:), jend1(:) !< Indexes of first contact point + integer, allocatable :: istart2(:), iend2(:), jstart2(:), jend2(:) !< Indexes of second contact point + + integer :: answers(2, 8) !< Expected results + + type(FmsNetcdfFile_t):: ocn_fileobj + + if( .not. open_file(ocn_fileobj, 'INPUT/'//trim(ocn_mosaic_file), 'read') ) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(ocn_mosaic_file)) + + answers(1,:) = (/1440, 1440, 1, 1080, 1, 1, 1, 1080 /) + answers(2,:) = (/1, 720, 1080, 1080, 1440, 721, 1080, 1080 /) + + ntiles = get_mosaic_ntiles(ocn_fileobj) + ncontacts = get_mosaic_ncontacts(ocn_fileobj) + + allocate(nx(ntiles), ny(ntiles)) + allocate(tile1(ncontacts), tile2(ncontacts) ) + allocate(istart1(ncontacts), iend1(ncontacts), jstart1(ncontacts), jend1(ncontacts) ) + allocate(istart2(ncontacts), iend2(ncontacts), jstart2(ncontacts), jend2(ncontacts) ) + + call get_mosaic_contact(ocn_fileobj, tile1, tile2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2) + + !< Compare with expected results: + if (ntiles .ne. 1) call mpp_error(FATAL, "ntiles is not equal to 1") + if (ncontacts .ne. 2) call mpp_error(FATAL, "ncontacts is not the expected result") + do n = 1, ncontacts + if (istart1(n) .ne. answers(n,1)) call mpp_error(FATAL, "istart1 is not the expected result") + if (iend1(n) .ne. answers(n,2)) call mpp_error(FATAL, "iend1 is not the expected result") + + if (jstart1(n) .ne. answers(n,3)) call mpp_error(FATAL, "jstart1 is not the expected result") + if (jend1(n) .ne. answers(n,4)) call mpp_error(FATAL, "jend1 is not the expected result") + + if (istart2(n) .ne. answers(n,5)) call mpp_error(FATAL, "istart2 is not the expected result") + if (iend2(n) .ne. answers(n,6)) call mpp_error(FATAL, "iend2 is not the expected result") + + if (jstart2(n) .ne. answers(n,7)) call mpp_error(FATAL, "jstart2 is not the expected result") + if (jend2(n) .ne. answers(n,8)) call mpp_error(FATAL, "jend2 is not the expected result") + end do + + deallocate(tile1, tile2, nx, ny) + deallocate(istart1, iend1, jstart1, jend1) + deallocate(istart2, iend2, jstart2, jend2) + +end subroutine test_get_mosaic_contact +!------------------------------------------------------! +subroutine test_calc_mosaic_grid_area + + !> This subroutine tests get_grid_area + + implicit none + + real(TEST_MOS_KIND_) :: x_rad(c1_nx, c1_ny), y_rad(c1_nx, c1_ny) !< x and y in radians + real(TEST_MOS_KIND_) :: area_out(1,1) !< area to be computed + + !> x_rad and y_rad can be set to be be the entire cell + !! x_rad = x(1:3:2, 1:3:2) and y_rad = y(1:3:2, 1:3:2) + !! The answer will then be 4.0*area(1,1) + x_rad = real( real(x(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + y_rad = real( real(y(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + + call calc_mosaic_grid_area(x_rad, y_rad, area_out) + call check_answer(area(1,1), area_out(1,1), 'TEST_CALC_MOSAIC_GRID_AREA') + +end subroutine test_calc_mosaic_grid_area +!------------------------------------------------------! +subroutine test_get_grid_great_circle_area + + !> This subroutine tests calc_mosaic_grid_great_circle_area + + implicit none + + real(TEST_MOS_KIND_) :: x_rad(c1_nx, c1_ny), y_rad(c1_nx, c1_ny) !< x and y in radians + real(TEST_MOS_KIND_) :: area_out(1,1) !< area to be computed + + !> x_rad and y_rad can be set to be be the entire cell + !! x_rad = x(1:3:2, 1:3:2) and y_rad = y(1:3:2, 1:3:2) + !! The answer will then be 4.0*area(1,1) + x_rad = real( real(x(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + y_rad = real( real(y(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + call calc_mosaic_grid_great_circle_area(x_rad, y_rad, area_out) + call check_answer(area(1,1), area_out(1,1), 'TEST_GET_GRID_GREAT_CIRCLE_AREA') + +end subroutine test_get_grid_great_circle_area +!------------------------------------------------------! +subroutine test_get_mosaic_xgrid + + !> Test get_mosaic_xgrid + + implicit none + + integer, dimension(ncells) :: i1, j1, i2, j2 !< indices of parent cells + real(TEST_MOS_KIND_), dimension(ncells) :: area !< area to be returned + real(r8_kind) :: garea, get_global_area !< global area + integer :: i !< counter + + type(FmsNetcdfFile_t) x_fileobj + + garea = get_global_area() + + if( .not. open_file(x_fileobj, 'INPUT/'//trim(exchange_file), 'read')) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(exchange_file)) + + call get_mosaic_xgrid(x_fileobj, i1, j1, i2, j2, area) + + !> check answers + do i=1, ncells + call check_answer( real(real(xgrid_area(i),r8_kind)/garea,lkind), area(i),"TEST_GET_MOSAIC_XGRID area") + call check_answer(tile1_cell(1,i), i1(i), "TEST_GET_MOSAIC_XGRID i1") + call check_answer(tile2_cell(1,i), i2(i), "TEST_GET_MOSAIC_XGRID i2") + call check_answer(tile1_cell(1,i), j1(i), "TEST_GET_MOSAIC_XGRID j1") + call check_answer(tile2_cell(1,i), j2(i), "TEST_GET_MOSAIC_XGRID j2") + end do + + call close_file(x_fileobj) + + +end subroutine test_get_mosaic_xgrid +!------------------------------------------------------! +subroutine test_is_inside_polygon + + !> cheating a little. starting with xyz coordinates (cause easier to understand) + + implicit none + + integer, parameter :: n=5 + integer :: i + real(TEST_MOS_KIND_) :: lat1, lon1, x1, y1, z1, r + real(TEST_MOS_KIND_), dimension(n) :: lon2, lat2, x2, y2, z2 + logical :: answer, is_inside + + integer, parameter :: lkind=TEST_MOS_KIND_ !< local kind + + !> polygon + x2=0.0_lkind + y2(1)=1.0_lkind ; y2(2)=1.0_lkind ; y2(3)=4.0_lkind ; y2(4)=4.0_lkind ; y2(5)=1.0_lkind + z2(1)=2.0_lkind ; z2(2)=4.0_lkind ; z2(3)=4.0_lkind ; z2(4)=2.0_lkind ; z2(5)=2.0_lkind + do i=1, n + r = sqrt( x2(i)**2 + y2(i)**2 + z2(i)**2 ) + lon2(i)=atan(y2(i)/x2(i)) + lat2(i)=asin(z2(i)/r) + end do + + !> point outside of the polygon + x1=2.0_lkind + y1=5.0_lkind + z1=4.2_lkind + r = sqrt(x1**2+y1**2+z1**2) + lon1=atan(y1/x1) + lat1=asin(z1/r) + + answer=.false. + is_inside=is_inside_polygon(lon1, lat1, lon2, lat2) + call check_answer(answer,is_inside,' TEST_IS_INSIDE_POLYGON') + + !> point inside the polygon + x1=0.0_lkind + y1=3.0_lkind + z1=2.5_lkind + r = sqrt(x1**2+y1**2+z1**2) + lon1=atan(y1/x1) + lat1=asin(z1/r) + + answer=.true. + is_inside=is_inside_polygon(lon1, lat1, lon2, lat2) + call check_answer(answer,is_inside,'TEST_IS_INSIDE_POLYGON') + +end subroutine test_is_inside_polygon +!------------------------------------------------------! +subroutine check_answer(answer, myvalue, whoami) + + implicit none + class(*) :: answer + class(*) :: myvalue + character(*) :: whoami + + select type(answer) + type is ( logical ) + select type(myvalue) + type is( logical ) + if( answer .neqv. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r4_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r8_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + end select + +end subroutine check_answer +!------------------------------------------------------! +end program test_mosaic diff --git a/test_fms/mosaic/test_mosaic2.sh b/test_fms/mosaic2/test_mosaic2.sh similarity index 71% rename from test_fms/mosaic/test_mosaic2.sh rename to test_fms/mosaic2/test_mosaic2.sh index f67991a9a3..93d0b357c7 100755 --- a/test_fms/mosaic/test_mosaic2.sh +++ b/test_fms/mosaic2/test_mosaic2.sh @@ -20,7 +20,7 @@ #*********************************************************************** # This is part of the GFDL FMS package. This is a shell script to -# execute tests in the test_fms/field_manager directory. +# execute tests in the test_fms/mosaic directory. # Ed Hartnett 11/29/19 @@ -31,8 +31,13 @@ touch input.nml rm -rf INPUT mkdir INPUT -test_expect_success "test mosaic" ' - mpirun -n 2 ./test_mosaic -' + +# The tests are skipped if FMS is compiled in r4 via ./configure --enable-mixedmode +# because answers differ when FMS is compiled in r4. +test_expect_success "test mosaic2 r4" 'mpirun -n 1 ./test_mosaic2_r4' +test_expect_success "test grid2 r4" 'mpirun -n 1 ./test_grid2_r4' +test_expect_success "test mosaic2 r8" 'mpirun -n 1 ./test_mosaic2_r8' +test_expect_success "test grid2 r8" 'mpirun -n 1 ./test_grid2_r8' + rm -rf INPUT test_done diff --git a/test_fms/mosaic2/write_files.inc b/test_fms/mosaic2/write_files.inc new file mode 100644 index 0000000000..4bb247eb31 --- /dev/null +++ b/test_fms/mosaic2/write_files.inc @@ -0,0 +1,351 @@ +module write_files + + use fms2_io_mod, only: fms2_io_init, open_file, close_file, FmsNetcdfFile_t + use fms2_io_mod, only: register_axis, register_field, write_data + use mpp_mod, only: mpp_init, mpp_sync, mpp_npes, mpp_get_current_pelist + use fms_mod, only: fms_init + use constants_mod, only: PI, RADIUS + use platform_mod, only :r4_kind, r8_kind + + implicit none + + character(23), parameter :: grid_spec_file="grid_spec.nc" + character(23), parameter :: c1_mosaic_file="C1_mosaic.nc" + character(30), parameter :: ocn_mosaic_file="ocean_mosaic.nc" + character(50), parameter :: exchange_file="C96_mosaic_tile1Xocean_mosaic_tile1.nc" + character(30), parameter :: ocn_tile_file="ocean_hgrid.nc" + character(23), parameter :: tile1_file="C1_grid.tile1.nc" + character(23), parameter :: tile2_file="C1_grid.tile2.nc" + character(23), parameter :: tile3_file="C1_grid.tile3.nc" + character(23), parameter :: tile4_file="C1_grid.tile4.nc" + character(23), parameter :: tile5_file="C1_grid.tile5.nc" + character(23), parameter :: tile6_file="C1_grid.tile6.nc" + + ! atm and land + integer, parameter :: c1_nx=2 !x---x----x + integer, parameter :: c1_ny=2 !| | + integer, parameter :: c1_nxp=3 !x x x + integer, parameter :: c1_nyp=3 !| | + integer, parameter :: c1_ntiles=6 !x---x----x + integer, parameter :: c1_ncontacts=12 + + !ocn + integer, parameter :: ocn_nx=2880 + integer, parameter :: ocn_ny=2160 + integer, parameter :: ocn_ntiles=1 + integer, parameter :: ocn_ncontacts=2 + + !exchange + integer, parameter :: ncells=2 + + ! variables for tile1 + character(5) :: tile + real(TEST_MOS_KIND_), dimension(c1_nxp,c1_nyp) :: x + real(TEST_MOS_KIND_), dimension(c1_nxp,c1_nyp) :: y + real(TEST_MOS_KIND_), dimension(c1_nx,c1_ny) :: area + + !variables for exchange grid cells + real(TEST_MOS_KIND_), dimension(2,ncells) :: tile1_cell, tile2_cell + real(TEST_MOS_KIND_), dimension(ncells) :: xgrid_area + + integer, parameter :: lkind=TEST_MOS_KIND_ !< local kind parameter + +contains + !---------------------------------! + subroutine write_grid_spec + + implicit none + type(FmsNetcdfFile_t) :: fileobj + integer, allocatable :: pes(:) + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//grid_spec_file, 'overwrite', pelist=pes) ) then + call register_axis(fileobj, "string", 128) + + call register_field(fileobj, "atm_mosaic_file", "char", dimensions=(/"string"/)) + call register_field(fileobj, "lnd_mosaic_file", "char", dimensions=(/"string"/)) + call register_field(fileobj, "ocn_mosaic_file", "char", dimensions=(/"string"/)) + + call write_data(fileobj, "atm_mosaic_file", "C1_mosaic.nc") + call write_data(fileobj, "lnd_mosaic_file", "C1_mosaic.nc") + call write_data(fileobj, "ocn_mosaic_file", "ocean_mosaic.nc") + + call close_file(fileobj) + end if + + end subroutine write_grid_spec + !---------------------------------! + subroutine write_c1_mosaic + + implicit none + + type(FmsNetcdfFile_t) :: fileobj + integer, allocatable :: pes(:) + + character(50), dimension(c1_ntiles) :: strings6 + character(50), dimension(c1_ncontacts) :: strings12 + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + + if( open_file(fileobj, 'INPUT/'//trim(c1_mosaic_file), 'overwrite', pelist=pes) ) then + + call register_axis(fileobj, 'ntiles', c1_ntiles) + call register_axis(fileobj, 'ncontact', c1_ncontacts) + call register_axis(fileobj, 'string', 55) + + call register_field(fileobj, 'mosaic', 'char', dimensions=(/'string'/)) + call register_field(fileobj, 'gridfiles', 'char', dimensions=(/'string','ntiles'/)) + call register_field(fileobj, "gridtiles", "char", dimensions=(/"string","ntiles"/)) + call register_field(fileobj, "contacts", "char", dimensions=(/"string ","ncontact"/)) + call register_field(fileobj, "contact_index", "char", dimensions=(/"string ","ncontact"/)) + + call write_data(fileobj, "mosaic", "C1_mosaic") + + strings6(1)=tile1_file + strings6(2)=tile2_file + strings6(3)=tile3_file + strings6(4)=tile4_file + strings6(5)=tile5_file + strings6(6)=tile6_file + call write_data(fileobj, "gridfiles", strings6) + + strings6(1)='tile1' + strings6(2)='tile2' + strings6(3)='tile3' + strings6(4)='tile4' + strings6(5)='tile5' + strings6(6)='tile6' + call write_data(fileobj, "gridtiles", strings6) + + strings12(1) ="C1_mosaic:tile1::C1_mosaic:tile2" + strings12(2) ="C1_mosaic:tile1::C1_mosaic:tile3" + strings12(3) ="C1_mosaic:tile1::C1_mosaic:tile5" + strings12(4) ="C1_mosaic:tile1::C1_mosaic:tile6" + strings12(5) ="C1_mosaic:tile2::C1_mosaic:tile3" + strings12(6) ="C1_mosaic:tile2::C1_mosaic:tile4" + strings12(7) ="C1_mosaic:tile2::C1_mosaic:tile6" + strings12(8) ="C1_mosaic:tile3::C1_mosaic:tile4" + strings12(9) ="C1_mosaic:tile3::C1_mosaic:tile5" + strings12(10)="C1_mosaic:tile4::C1_mosaic:tile5" + strings12(11)="C1_mosaic:tile4::C1_mosaic:tile6" + strings12(12)="C1_mosaic:tile5::C1_mosaic:tile6" + call write_data(fileobj, "contacts", strings12) + + strings12(1) ="2:2,1:2::1:1,1:2" + strings12(2) ="1:2,2:2::1:1,2:1" + strings12(3) ="1:1,1:2::2:1,2:2" + strings12(4) ="1:2,1:1::1:2,2:2" + strings12(5) ="1:2,2:2::1:2,1:1" + strings12(6) ="2:2,1:2::2:1,1:1" + strings12(7) ="1:2,1:1::2:2,2:1" + strings12(8) ="2:2,1:2::1:1,1:2" + strings12(9) ="1:2,2:2::1:1,2:1" + strings12(10)="1:2,2:2::1:2,1:1" + strings12(11)="2:2,1:2::2:1,1:1" + strings12(12)="2:2,1:2::1:1,1:2" + call write_data(fileobj, "contact_index", strings12) + + call close_file(fileobj) + + end if + + end subroutine write_c1_mosaic + !---------------------------------! + subroutine write_c1_tiles + + !> These are made up numbers, numbers chosen + !! for computational convenience + + implicit none + + character(5) :: tile + real(TEST_MOS_KIND_), parameter :: area_value = real(PI*RADIUS*RADIUS/2.0_r8_kind, TEST_MOS_KIND_) + real(r8_kind) :: xtmp(c1_nxp, c1_nyp), ytmp(c1_nxp, c1_nyp) + + xtmp(1,1)=0.0_r8_kind ; xtmp(2,1)=90.0_r8_kind ; xtmp(3,1)=180.0_r8_kind + xtmp(1,2)=0.0_r8_kind ; xtmp(2,2)=90.0_r8_kind ; xtmp(3,2)=180.0_r8_kind + xtmp(1,3)=0.0_r8_kind ; xtmp(2,3)=90.0_r8_kind ; xtmp(3,3)=180.0_r8_kind + + x = real(xtmp,lkind) + + ytmp(1,1)=-90.0_r8_kind ; ytmp(2,1)=-90.0_r8_kind ; ytmp(3,1)=-90.0_r8_kind + ytmp(1,2)= 0.0_r8_kind ; ytmp(2,2)= 0.0_r8_kind ; ytmp(3,2)= 0.0_r8_kind + ytmp(1,3)= 90.0_r8_kind ; ytmp(2,3)= 90.0_r8_kind ; ytmp(3,3)= 90.0_r8_kind + + y = real(ytmp,lkind) + + area(1,1)=area_value ; area(2,1)=area_value + area(1,2)=area_value ; area(2,2)=area_value + + tile='tile1' ; call call_fms2_io(tile1_file, tile, x, y, area) + tile='tile2' ; call call_fms2_io(tile2_file, tile, x, y, area) + tile='tile3' ; call call_fms2_io(tile3_file, tile, x, y, area) + tile='tile4' ; call call_fms2_io(tile4_file, tile, x, y, area) + tile='tile5' ; call call_fms2_io(tile5_file, tile, x, y, area) + tile='tile6' ; call call_fms2_io(tile6_file, tile, x, y, area) + + end subroutine write_c1_tiles + !-----------------------------------! + subroutine call_fms2_io(filename, tile, x_in, y_in, area_in) + + implicit none + + character(*) :: filename + character(*) :: tile + real(TEST_MOS_KIND_), dimension(c1_nxp,c1_nyp), intent(in) :: x_in, y_in + real(TEST_MOS_KIND_), dimension(c1_nx,c1_ny), intent(in) :: area_in + + type(FmsNetcdfFile_t) :: fileobj + integer, allocatable :: pes(:) + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//trim(filename), 'overwrite', pelist=pes) ) then + + call register_axis(fileobj, "nx", c1_nx) + call register_axis(fileobj, "ny", c1_ny) + call register_axis(fileobj, 'nxp', c1_nxp) + call register_axis(fileobj, 'nyp', c1_nyp) + call register_axis(fileobj, "string", 5) + + call register_field(fileobj, 'tile', 'char', dimensions=(/'string'/)) + call register_field(fileobj, 'x', 'double', dimensions=(/'nxp', 'nyp'/)) + call register_field(fileobj, 'y', 'double', dimensions=(/'nxp', 'nyp'/)) + call register_field(fileobj, 'area', 'double', dimensions=(/'nx','ny'/)) + + call write_data(fileobj, 'tile', trim(tile)) + call write_data(fileobj, 'x', x_in) + call write_data(fileobj, 'y', y_in) + call write_data(fileobj, 'area', area_in) + + call close_file(fileobj) + + end if + + end subroutine call_fms2_io + !---------------------------------! + subroutine write_ocean_mosaic() + + !> from @uriel.ramirez + + implicit none + + type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test + integer, allocatable :: pes(:) + + character(38), dimension(ocn_ntiles) :: strings1 + character(38), dimension(ocn_ncontacts) :: strings2 + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//ocn_mosaic_file, 'overwrite', pelist=pes)) then + call register_axis(fileobj, "ntiles", ocn_ntiles) + call register_axis(fileobj, "ncontact", ocn_ncontacts) + call register_axis(fileobj, "string", 50) + + call register_field(fileobj, "contacts", "char", dimensions=(/"string ","ncontact"/)) + call register_field(fileobj, "contact_index", "char", dimensions=(/"string ","ncontact"/)) + call register_field(fileobj, "gridfiles", "char", dimensions=(/"string", "ntiles"/)) + call register_field(fileobj, "gridtiles", "char", dimensions=(/"string", "ntiles"/)) + + strings1(1)=ocn_tile_file + call write_data(fileobj, "gridfiles",strings1) + + strings1(1)='tile1' + call write_data(fileobj, "gridtiles",strings1) + + strings2(1)="2880:2880,1:2160::1:1,1:2160" + strings2(2)="1:1440,2160:2160::2880:1441,2160:2160" + call write_data(fileobj, "contact_index", strings2) + + strings2(1)="ocean_mosaic:tile1::ocean_mosaic:tile1" + strings2(2)="ocean_mosaic:tile1::ocean_mosaic:tile1" + call write_data(fileobj, "contacts", strings2) + + call close_file(fileobj) + endif + + end subroutine write_ocean_mosaic + !---------------------------------- + subroutine write_exchange + + implicit none + + type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test + integer, allocatable :: pes(:) + integer :: i, j, k + real(r8_kind) :: get_global_area !< get_global_area returns a double + + !> These are made up numbers, numbers chosen + !! for computational convenience + + do i=1,ncells + tile1_cell(1,i) = i + tile1_cell(2,i) = i + tile2_cell(1,i) = i + tile2_cell(2,i) = i + end do + + do i=1, ncells + xgrid_area(i) = real(get_global_area(), TEST_MOS_KIND_) + end do + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + if( open_file(fileobj, 'INPUT/'//trim(exchange_file), "overwrite", pelist=pes)) then + call register_axis(fileobj, "ncells", ncells) + call register_axis(fileobj, "two", 2) + + call register_field(fileobj, "tile1_cell", "double", dimensions=(/"two ", "ncells"/)) + call register_field(fileobj, "tile2_cell", "double", dimensions=(/"two ", "ncells"/)) + call register_field(fileobj, "xgrid_area", "double", dimensions=(/"ncells"/)) + + call write_data(fileobj, "tile1_cell", tile1_cell) + call write_data(fileobj, "tile2_cell", tile2_cell) + call write_data(fileobj, "xgrid_area", xgrid_area) + + call close_file(fileobj) + end if + + end subroutine write_exchange + !---------------------------------- + subroutine write_hgrid + + !> from @uriel.ramirez + + implicit none + + type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test + integer, allocatable :: pes(:) + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//ocn_tile_file, "overwrite", pelist=pes)) then + call register_axis(fileobj, "nx", ocn_nx) + call register_axis(fileobj, "ny", ocn_ny) + + call close_file(fileobj) + endif + + end subroutine write_hgrid + !---------------------------------! + subroutine write_all + + implicit none + call write_grid_spec() + call write_c1_mosaic() + call write_ocean_mosaic() + call write_c1_tiles() + call write_hgrid() + call write_exchange() + + end subroutine write_all + !---------------------------------! +end module write_files diff --git a/test_fms/mosaic/Makefile.am b/test_fms/topography/Makefile.am similarity index 67% rename from test_fms/mosaic/Makefile.am rename to test_fms/topography/Makefile.am index ff36605e0a..8f873da1a9 100644 --- a/test_fms/mosaic/Makefile.am +++ b/test_fms/topography/Makefile.am @@ -17,32 +17,39 @@ #* License along with FMS. If not, see . #*********************************************************************** -# This is an automake file for the test_fms/mosaic directory of the +# This is an automake file for the test_fms/topography directory of the # FMS package. -# uramirez, Ed Hartnett +# Caitlyn McAllister -# Find the needed mod and include files. +# Find the fms and mpp mod files. AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_mosaic +check_PROGRAMS = \ + test_topography_r4 \ + test_topography_r8 # This is the source code for the test. -test_mosaic_SOURCES = test_mosaic.F90 +test_topography_r4_SOURCES = test_topography.F90 +test_topography_r8_SOURCES = test_topography.F90 + +# Set r4_kind and r8_kind +test_topography_r4_CPPFLAGS = $(AM_CPPFLAGS) -DTEST_TOP_KIND_=r4_kind +test_topography_r8_CPPFLAGS = $(AM_CPPFLAGS) -DTEST_TOP_KIND_=r8_kind # Run the test program. -TESTS = test_mosaic2.sh +TESTS = test_topography.sh + +# Copy over other needed files to the srcdir +EXTRA_DIST = test_topography.sh TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ $(abs_top_srcdir)/test_fms/tap-driver.sh -# These files are also included in the distribution. -EXTRA_DIST = test_mosaic2.sh - # Clean up -CLEANFILES = input.nml *.nc *.out *.dpi *.spi *.dyn *.spl +CLEANFILES = input.nml *.out* *.dpi *.spi *.dyn *.spl *.nc diff --git a/test_fms/topography/test_topography.F90 b/test_fms/topography/test_topography.F90 new file mode 100644 index 0000000000..0ccbebd63e --- /dev/null +++ b/test_fms/topography/test_topography.F90 @@ -0,0 +1,355 @@ +!*********************************************************************** +!* 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 +!> @author Caitlyn McAllister +!> @brief Unit tests for topography_mod +!> @email gfdl.climate.model.info@noaa.gov +!> @description This suit includes testing for all public functions available +!! in the topography module +!! TODO: More intricate data with larger arrays for lat, lon, and 'zdat' should +!! be added and included +!! TODO: More tests to check a wider range of indices for zmean2d/1d, stdev2d/1d, ocean_mask2d/1d, +!! ocean_frac2d/1d, ocean_mask2d/1d, water_frac2d/1d, and water_mask2d/1d + +program test_top + + 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 fms_mod, only: fms_init, fms_end + use fms2_io_mod, only: fms2_io_init, FmsNetcdfFile_t, open_file, close_file, register_axis, register_field, & + register_variable_attribute, write_data, read_data, unlimited + use mpp_mod, only: mpp_error, FATAL, stdout, mpp_init, mpp_exit + use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_sync, input_nml_file + use horiz_interp_mod, only: horiz_interp_type, horiz_interp_new, & + horiz_interp, horiz_interp_del + use constants_mod, only: pi + use platform_mod, only: r4_kind, r8_kind + + implicit none + + type(FmsNetcdfFile_t) :: top_fileobj ! fileobj for fms2_io + character(len=128) :: topog_file, water_file ! filenames needed for topography_mod + real(kind=TEST_TOP_KIND_) :: xdat(3), ydat(3), zdat(2,2) ! specifc data topog_mod looks for + integer :: ipts, jpts ! axis for files + integer :: iptsp1, jptsp1 ! serves as a counter for data + integer :: ipts_r, jpts_r ! sub axis + integer, parameter :: lkind = TEST_TOP_KIND_ ! kind parameter for mixed precision + + real(kind=TEST_TOP_KIND_), parameter :: deg2rad = real(pi, TEST_TOP_KIND_)/180.0_lkind + real(kind=TEST_TOP_KIND_), dimension(2,2) :: lon2d, lat2d ! in radians + real(kind=TEST_TOP_KIND_), dimension(2) :: lon1d, lat1d ! in radians + + call fms_init + call topography_init + + !-------------------------------------------------------------------------------------------------------------! + + ! define blat and blon, in this test they'll be referred to as lat2d/lon2d, lat1d/lon1d + ! these ordered pair for lon and lat create a perfect square for calculation purposes + lon2d(1,1) = 1.5_lkind*deg2rad ; lat2d(1,1) = 1.5_lkind*deg2rad + lon2d(2,1) = 2.5_lkind*deg2rad ; lat2d(2,1) = 1.5_lkind*deg2rad + lon2d(1,2) = 1.5_lkind*deg2rad ; lat2d(1,2) = 2.5_lkind*deg2rad + lon2d(2,2) = 2.5_lkind*deg2rad ; lat2d(2,2) = 2.5_lkind*deg2rad + + lon1d(1) = 1.5_lkind*deg2rad ; lat1d(1) = 1.5_lkind*deg2rad + lon1d(2) = 2.5_lkind*deg2rad ; lat1d(2) = 1.5_lkind*deg2rad + + ! name files + topog_file = "topography.data.nc" + water_file = "water.data.nc" + + ! create data for both topog and water files + ipts_r = 1 ; ipts = 2 ; iptsp1 = 3 ! axes an sub-axes sizes + jpts_r = 1 ; jpts = 2 ; jptsp1 = 3 + + + xdat = (/1.0_lkind*deg2rad, 2.0_lkind*deg2rad, 3.0_lkind*deg2rad/) !size of iptsp1, in radians + ydat = (/1.0_lkind*deg2rad, 2.0_lkind*deg2rad, 3.0_lkind*deg2rad/) !size of jptsp1, in radians + + zdat(1,1) = 0.0_lkind ; zdat(1,2) = 1.0_lkind + zdat(2,1) = 1.0_lkind ; zdat(2,2) = 0.0_lkind !size of (ipts, jpts) + !-------------------------------------------------------------------------------------------------------------! + + ! write topog file + if (open_file(top_fileobj, topog_file, "overwrite")) then + call register_axis(top_fileobj, "i_zdat", ipts) !first index dimension in zdat + call register_axis(top_fileobj, "j_zdat", jpts) !second index dimension in zdat + call register_axis(top_fileobj, "ipts_r", ipts_r) + call register_axis(top_fileobj, "jpts_r", jpts_r) + call register_axis(top_fileobj, "i_xdat", iptsp1) !# of points in xdat variable + call register_axis(top_fileobj, "j_ydat", jptsp1) !# of point in ydat variable + + call register_field(top_fileobj, "ipts", "double", dimensions=(/"ipts_r"/)) + call register_field(top_fileobj, "jpts", "double", dimensions=(/"jpts_r"/)) + call register_field(top_fileobj, "xdat", "double", dimensions=(/"i_xdat"/)) + call register_field(top_fileobj, "ydat", "double", dimensions=(/"j_ydat"/)) + call register_field(top_fileobj, "zdat", "double", dimensions=(/"i_zdat", "j_zdat"/)) + + call write_data(top_fileobj, "ipts", real(ipts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "jpts", real(jpts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "xdat", xdat) + call write_data(top_fileobj, "ydat", ydat) + call write_data(top_fileobj, "zdat", zdat) + + call close_file(top_fileobj) + + else + call mpp_error(FATAL, "test_topography: error opening topog_file") + end if + !-------------------------------------------------------------------------------------------------------------! + + ! write water file + if (open_file(top_fileobj, water_file, "overwrite")) then + call register_axis(top_fileobj, "i_zdat", ipts) !first index dimension in zdat + call register_axis(top_fileobj, "j_zdat", jpts) !second index dimension in zdat + call register_axis(top_fileobj, "ipts_r", ipts_r) + call register_axis(top_fileobj, "jpts_r", jpts_r) + call register_axis(top_fileobj, "i_xdat", iptsp1) !# of points in xdat variable + call register_axis(top_fileobj, "j_ydat", jptsp1) !# of point in ydat variable + + call register_field(top_fileobj, "ipts", "double", dimensions=(/"ipts_r"/)) + call register_field(top_fileobj, "jpts", "double", dimensions=(/"jpts_r"/)) + call register_field(top_fileobj, "xdat", "double", dimensions=(/"i_xdat"/)) + call register_field(top_fileobj, "ydat", "double", dimensions=(/"j_ydat"/)) + call register_field(top_fileobj, "zdat", "double", dimensions=(/"i_zdat", "j_zdat"/)) + + call write_data(top_fileobj, "ipts", real(ipts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "jpts", real(jpts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "xdat", xdat) + call write_data(top_fileobj, "ydat", ydat) + call write_data(top_fileobj, "zdat", zdat) + + call close_file(top_fileobj) + + else + call mpp_error(FATAL, "test_topography: error opening water_file") + end if + !-------------------------------------------------------------------------------------------------------------! + + call test_topog_mean ; call test_topog_stdev + call test_get_ocean_frac ; call test_get_ocean_mask + call test_get_water_frac ; call test_get_water_mask + + call fms_end + + contains + + subroutine test_topog_mean() + !! The naming convention of zmean2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both zmean2d and zmean1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: zmean2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: zmean1d + logical :: get_mean_answer + + !---------------------------------------- test topog mean 2d ---------------------------------------------! + + get_mean_answer = get_topog_mean(lon2d, lat2d, zmean2d) + + if (get_mean_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(zmean2d(1,1), 0.5_lkind, "Error in test_topog_mean 2d") + ! in the case of this simplistic test, size(zmean2d) = 1, more tests should be created + ! with a larger zmean2d array size + + !---------------------------------------- test topog mean 1d ---------------------------------------------! + + get_mean_answer = get_topog_mean(lon1d, lat1d, zmean1d) + + if (get_mean_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(zmean1d(1,1), 0.5_lkind, "Error in test_topog_mean 1d") + ! in the case of this simplistic test, size(zmean1d) = 1, more tests should be created + ! with a larger zmean1d array size + + end subroutine test_topog_mean + + subroutine test_topog_stdev + + !! The naming convention of stdev2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both stdev2d and stdev1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: stdev2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: stdev1d + logical :: get_stdev_answer + + !---------------------------------------- test topog stdev 2d ---------------------------------------------! + + get_stdev_answer = get_topog_stdev(lon2d, lat2d, stdev2d) + + if (get_stdev_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(stdev2d(1,1), 0.5_lkind, "Error in test_topog_stdev 2d") + ! in the case of this simplistic test, size(stdev2d) = 1, more tests should be created + ! with a larger stdev2d array size + + !---------------------------------------- test topog stdev 2d ---------------------------------------------! + + get_stdev_answer = get_topog_stdev(lon1d, lat1d, stdev1d) + + if (get_stdev_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(stdev1d(1,1), 0.5_lkind, "Error in test_topog_stdev 1d") + ! in the case of this simplistic test, size(stdev1d) = 1, more tests should be created + ! with a larger stdev1d array size + + end subroutine test_topog_stdev + + subroutine test_get_ocean_frac + + !! The naming convention of ocean_frac2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both ocean_frac2d and ocean_frac1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: ocean_frac2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: ocean_frac1d + logical :: get_ocean_frac_answer + + !---------------------------------------- test get_ocean_frac 2d ---------------------------------------------! + + get_ocean_frac_answer = get_ocean_frac(lon2d, lat2d, ocean_frac2d) + + if (get_ocean_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(ocean_frac2d(1,1), 0.5_lkind, "Error in test_get_ocean_frac 2d") + ! in the case of this simplistic test, size(ocean_frac2d) = 1, more tests should be created + ! with a larger ocean_frac2d array size + + !---------------------------------------- test get_ocean_frac 1d ---------------------------------------------! + + get_ocean_frac_answer = get_ocean_frac(lon1d, lat1d, ocean_frac1d) + + if (get_ocean_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(ocean_frac1d(1,1), 0.5_lkind, "Error in test_get_ocean_frac 1d") + ! in the case of this simplistic test, size(ocean_frac1d) = 1, more tests should be created + ! with a larger ocean_frac1d array size + end subroutine test_get_ocean_frac + + subroutine test_get_ocean_mask + + !! The naming convention of ocean_mask2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both ocean_mask2d and ocean_mask1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: ocean_mask2d + logical, dimension(size(lon1d)-1,size(lat1d)-1) :: ocean_mask1d + logical :: get_ocean_mask_answer + + !---------------------------------------- test get_ocean_mask 2d ---------------------------------------------! + + get_ocean_mask_answer = get_ocean_mask(lon2d, lat2d, ocean_mask2d) + + + if (get_ocean_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (ocean_mask2d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_ocean_mask 2d: ocean mask should be false") + ! in the case of this simplistic test, size(ocean_mask2d) = 1, more tests should be created + ! with a larger ocean_mask2d array size + + !---------------------------------------- test get_ocean_mask 1d ---------------------------------------------! + + get_ocean_mask_answer = get_ocean_mask(lon1d, lat1d, ocean_mask1d) + + if (get_ocean_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (ocean_mask1d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_ocean_mask 1d: ocean mask should be false") + ! ! in the case of this simplistic test, size(ocean_mask1d) = 1, more tests should be created + ! with a larger ocean_mask1d array size + + end subroutine test_get_ocean_mask + + subroutine test_get_water_frac + !! The naming convention of water_frac2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both water_frac2d and water_frac1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: water_frac2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: water_frac1d + logical :: get_water_frac_answer + + !---------------------------------------- test get_water_frac 2d ---------------------------------------------! + + get_water_frac_answer = get_water_frac(lon2d, lat2d, water_frac2d) + + if (get_water_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(water_frac2d(1,1), 0.5_lkind, "Error in test_get_water_frac 2d") + ! in the case of this simplistic test, size(water_frac2d) = 1, more tests should be created + ! with a larger water_frac2d array size + + !---------------------------------------- test get_water_frac 1d ---------------------------------------------! + + get_water_frac_answer = get_water_frac(lon1d, lat1d, water_frac1d) + + if (get_water_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(water_frac1d(1,1), 0.5_lkind, "Error in test_get_ocean_frac 1d") + ! in the case of this simplistic test, size(water_frac1d) = 1, more tests should be created + ! with a larger water_frac1d array size + + end subroutine test_get_water_frac + + subroutine test_get_water_mask + + !! The naming convention of water_mask2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both water_mask2d and water_mask1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: water_mask2d + logical, dimension(size(lon1d)-1,size(lat1d)-1) :: water_mask1d + logical :: get_water_mask_answer + + !---------------------------------------- test get_water_mask 2d ---------------------------------------------! + + get_water_mask_answer = get_water_mask(lon2d, lat2d, water_mask2d) + + if (get_water_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (water_mask2d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_water_mask 2d: ocean mask should be false") + ! in the case of this simplistic test, size(water_mask2d) = 1, more tests should be created + ! with a larger water_mask2d array size + + !---------------------------------------- test get_water_mask 1d ---------------------------------------------! + + get_water_mask_answer = get_ocean_mask(lon1d, lat1d, water_mask1d) + + if (get_water_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (water_mask1d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_ocean_mask 1d: ocean mask should be false") + ! in the case of this simplistic test, size(water_mask1d) = 1, more tests should be created + ! with a larger water_mask1d array size + + end subroutine test_get_water_mask + + subroutine check_answers(calculated_answer, expected_answer, what_error) + + implicit none + real(kind=TEST_TOP_KIND_) :: calculated_answer ! value calculated from script + real(kind=TEST_TOP_KIND_) :: expected_answer ! expected answer + character(*) :: what_error ! error message to print + + if (calculated_answer.ne. expected_answer) then + write(*,*) 'Expected ', expected_answer, ' but computed ', calculated_answer + call mpp_error(FATAL, trim(what_error)) + end if + + end subroutine check_answers + + + +end program test_top \ No newline at end of file diff --git a/test_fms/topography/test_topography.sh b/test_fms/topography/test_topography.sh new file mode 100755 index 0000000000..f9c55afda5 --- /dev/null +++ b/test_fms/topography/test_topography.sh @@ -0,0 +1,53 @@ +#!/bin/sh + +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/astronomy directory. + +# Caitlyn McAllister + +# Set common test settings. +. ../test-lib.sh + +# Prepare the directory to run the tests. +cat < input.nml +&topography_nml + topog_file = "topography.data.nc", + water_file = "water.data.nc" +/ + +EOF + +# Run the test. + +test_expect_success "Test topography: r4_kind" ' + mpirun -n 1 ./test_topography_r4 +' + +sync; rm -f *.nc + +test_expect_success "Test topography: r8_kind" ' + mpirun -n 1 ./test_topography_r8 +' + +rm -f *.nc + +test_done diff --git a/test_fms/tridiagonal/Makefile.am b/test_fms/tridiagonal/Makefile.am new file mode 100644 index 0000000000..211869202b --- /dev/null +++ b/test_fms/tridiagonal/Makefile.am @@ -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 . +#*********************************************************************** + +# This is an automake file for the test_fms/tridiagonal directory of the FMS +# package. + +# Ryan Mulhall + +# Find the .mod directory +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_tridiagonal_r4 test_tridiagonal_r8 + +# compiles test file with both kind sizes via macro +test_tridiagonal_r4_SOURCES=test_tridiagonal.F90 +test_tridiagonal_r8_SOURCES=test_tridiagonal.F90 + +test_tridiagonal_r4_CPPFLAGS=-DTRID_REAL_TYPE=tridiag_r4 -DTEST_TRIDIAG_REAL=r4_kind -I$(MODDIR) +test_tridiagonal_r8_CPPFLAGS=-DTRID_REAL_TYPE=tridiag_r8 -DTEST_TRIDIAG_REAL=r8_kind -I$(MODDIR) + +# Run the test program. +TESTS = test_tridiagonal.sh + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ + $(abs_top_srcdir)/test_fms/tap-driver.sh + +# These files will be included in the distribution. +EXTRA_DIST = test_tridiagonal.sh + +# Clean up +CLEANFILES = *.nml *.out* *.dpi *.spi *.dyn *.spl *.o test_tridiagonal4 test_tridiagonal8 test_tridiagonal diff --git a/test_fms/tridiagonal/test_tridiagonal.F90 b/test_fms/tridiagonal/test_tridiagonal.F90 new file mode 100644 index 0000000000..18200a8c77 --- /dev/null +++ b/test_fms/tridiagonal/test_tridiagonal.F90 @@ -0,0 +1,173 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +#ifndef TEST_TRIDIAG_KIND +#define TEST_TRIDIAG_KIND 8 +#endif + +!> Tests the tridiagonal module routines (tri_invert and close_tridiagonal) +!! Tests reals with the kind value set above, +program test_tridiagonal + + use tridiagonal_mod + use platform_mod + use mpp_mod + use fms_mod + + implicit none + + integer, parameter :: IN_LEN = 8 !< length of input arrays + integer, parameter :: kindl = TEST_TRIDIAG_KIND !< kind value for all reals in this test + !! set by TEST_TRIDIAG_KIND cpp macro + real(TEST_TRIDIAG_KIND), allocatable :: d(:,:,:), x(:,:,:), ref_array(:,:,:) + real(TEST_TRIDIAG_KIND), allocatable :: a(:,:,:), b(:,:,:), c(:,:,:) + real(r4_kind), allocatable :: d_r4(:,:,:), x_r4(:,:,:) + real(r4_kind), allocatable :: a_r4(:,:,:), b_r4(:,:,:), c_r4(:,:,:) + real(r8_kind), allocatable :: d_r8(:,:,:), x_r8(:,:,:) + real(r8_kind), allocatable :: a_r8(:,:,:), b_r8(:,:,:), c_r8(:,:,:) + integer :: i, end, ierr, io + real(TEST_TRIDIAG_KIND) :: k + ! nml + logical :: do_error_check = .false. + namelist / test_tridiagonal_nml/ do_error_check + + call mpp_init + + read (input_nml_file, test_tridiagonal_nml, iostat=io) + ierr = check_nml_error (io, 'test_tridiagonal_nml') + + ! allocate input and output arrays + allocate(d(1,1,IN_LEN)) + allocate(a(1,1,IN_LEN)) + allocate(b(1,1,IN_LEN)) + allocate(c(1,1,IN_LEN)) + allocate(x(1,1,IN_LEN)) + + !! simple test with only 1 coeff + a = 0.0_kindl + b = 1.0_kindl + c = 0.0_kindl + d = 5.0_kindl + call tri_invert(x, d, a, b, c) + if(any(x .ne. 5.0_kindl)) call mpp_error(FATAL, "test_tridiagonal: invalid results for 1 coefficient check") + !! check with stored data arrays + d = -5.0_kindl + call tri_invert(x, d) + if(any(x .ne. -5.0_kindl)) call mpp_error(FATAL, "test_tridiagonal: invalid results for 1 coefficient check") + + ! test with a,b,c + ! 0.5x(n-2) + x(n-1) + 0.5x(n) = 1 + ! + ! x(n) = k * [4, 1, 3, 2, 2, 3, 1, 4] + ! k * [8 , 1, 7, 2, 6, .. ] = k *(-n/2 + ((n%2)*arr_length/2)) + a = 0.5_kindl + b = 1.0_kindl + c = 0.5_kindl + d = 1.0_kindl + call tri_invert(x, d, a, b, c) + ! set up reference answers + k = 1.0_kindl/(IN_LEN+1.0_kindl) * 2.0_kindl + allocate(ref_array(1,1,IN_LEN)) + do i=1, IN_LEN/2 + end=IN_LEN-i+1 + if(mod(i, 2) .eq. 1) then + ref_array(1,1,i) = real(-(i/2) + (mod(i,2)* IN_LEN/2), kindl) + ref_array(1,1,end) = real(-(i/2) + (mod(i,2)* IN_LEN/2), kindl) + else + ref_array(1,1,i) = real(i/2, kindl) + ref_array(1,1,end) = real(i/2, kindl) + endif + enddo + ref_array = ref_array * k + ! check + do i=1, IN_LEN + if(ABS(x(1,1,i) - ref_array(1,1,i)) .gt. 0.1e-12_kindl) then + print *, i, x(1,1,i), ref_array(1,1,i) + call mpp_error(FATAL, "test_tridiagonal: failed reference check for tri_invert") + endif + enddo + !! check with stored data arrays + d = -1.0_kindl + ref_array = ref_array * -1.0_kindl + call tri_invert(x, d) + do i=1, IN_LEN + if(ABS(x(1,1,i) - ref_array(1,1,i)) .gt. 0.1e-12_kindl) then + print *, i, x(1,1,i), ref_array(1,1,i) + call mpp_error(FATAL, "test_tridiagonal: failed reference check for tri_invert with saved values") + endif + enddo + call close_tridiagonal() + + !! tests for module state across kinds + !! default keeps stored values separate depending on kind + !! store_both_kinds argument can be specified to store both r4 and r8 kinds + if(kindl .eq. r8_kind) then + allocate(a_r4(1,1,IN_LEN), b_r4(1,1,IN_LEN), c_r4(1,1,IN_LEN)) + allocate(d_r4(1,1,IN_LEN), x_r4(1,1,IN_LEN)) + a_r4 = 0.0_r4_kind; b_r4 = 1.0_r4_kind; c_r4 = 0.0_r4_kind + d_r4 = 5.0_r4_kind; x_r4 = 0.0_r4_kind + a = 0.0_kindl; b = 2.0_kindl; c = 0.0_kindl + d = 5.0_kindl + ! default, module variables distinct per kind + call tri_invert(x_r4, d_r4, a_r4, b_r4, c_r4) + ! conditionally errors here for calling with unallocated a/b/c for kind + if( do_error_check ) call tri_invert(x, d) + call tri_invert(x, d, a, b, c) + ! check both values are correct from prior state + call tri_invert(x_r4, d_r4) + call tri_invert(x, d) + if(any(x_r4 .ne. 5.0_r4_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r4 kind result") + if(any(x .ne. 2.5_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + call close_tridiagonal() + ! run with storing for both kinds + call tri_invert(x_r4, d_r4, a_r4, b_r4, c_r4, store_both_kinds=.true.) + call tri_invert(x_r4, d_r4) + call tri_invert(x, d) + if(any(x_r4 .ne. 5.0_r4_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r4 kind result") + if(any(x .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + else + allocate(a_r8(1,1,IN_LEN), b_r8(1,1,IN_LEN), c_r8(1,1,IN_LEN)) + allocate(d_r8(1,1,IN_LEN), x_r8(1,1,IN_LEN)) + a_r8 = 0.0_r8_kind; b_r8 = 1.0_r8_kind; c_r8 = 0.0_r8_kind + d_r8 = 5.0_r8_kind; x_r8 = 0.0_r8_kind + a = 0.0_kindl; b = 2.0_kindl; c = 0.0_kindl + d = 5.0_kindl + ! default, module variables distinct per kind + call tri_invert(x_r8, d_r8, a_r8, b_r8, c_r8) + ! conditionally errors here for calling with unallocated a/b/c for kind + if( do_error_check ) call tri_invert(x, d) + call tri_invert(x, d, a, b, c) + ! check both values are correct from prior state + call tri_invert(x_r8, d_r8) + call tri_invert(x, d) + if(any(x_r8 .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + if(any(x .ne. 2.5_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + call close_tridiagonal() + ! run with storing for both kinds + call tri_invert(x_r8, d_r8, a_r8, b_r8, c_r8, store_both_kinds=.true.) + call tri_invert(x_r8, d_r8) + call tri_invert(x, d) + if(any(x_r8 .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + if(any(x .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + endif + + call close_tridiagonal() + + call mpp_exit + +end program \ No newline at end of file diff --git a/test_fms/tridiagonal/test_tridiagonal.sh b/test_fms/tridiagonal/test_tridiagonal.sh new file mode 100755 index 0000000000..4be1fa80b1 --- /dev/null +++ b/test_fms/tridiagonal/test_tridiagonal.sh @@ -0,0 +1,51 @@ +#!/bin/sh + +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/time_manager directory. + +# Ryan Mulhall 9/2023 + +# Set common test settings. +. ../test-lib.sh + +rm -f input.nml && touch input.nml + +test_expect_success "test tridiagonal functionality 32 bit reals" ' + mpirun -n 1 ./test_tridiagonal_r4 +' +test_expect_success "test tridiagonal functionality 64 bit reals" ' + mpirun -n 1 ./test_tridiagonal_r8 +' +# tries to call without a,b,c args provided or previously set +cat <<_EOF > input.nml +&test_tridiagonal_nml +do_error_check = .true. +/ +_EOF +test_expect_failure "error out if passed in incorrect real size (r4_kind)" ' + mpirun -n 1 ./test_tridiagonal_r4 +' +test_expect_failure "error out if passed in incorrect real size (r8_kind)" ' + mpirun -n 1 ./test_tridiagonal_r8 +' + +test_done diff --git a/tridiagonal/Makefile.am b/tridiagonal/Makefile.am index 177ca904a5..d8b90c409b 100644 --- a/tridiagonal/Makefile.am +++ b/tridiagonal/Makefile.am @@ -23,14 +23,17 @@ # 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)/tridiagonal/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. noinst_LTLIBRARIES = libtridiagonal.la # The convenience library depends on its source. -libtridiagonal_la_SOURCES = tridiagonal.F90 +libtridiagonal_la_SOURCES = tridiagonal.F90 \ + include/tridiagonal.inc \ + include/tridiagonal_r4.fh \ + include/tridiagonal_r8.fh # Mod file depends on its o file, is built and then installed. tridiagonal.lo: tridiagonal_mod.$(FC_MODEXT) diff --git a/tridiagonal/include/tridiagonal.inc b/tridiagonal/include/tridiagonal.inc new file mode 100644 index 0000000000..95788eb795 --- /dev/null +++ b/tridiagonal/include/tridiagonal.inc @@ -0,0 +1,106 @@ +!*********************************************************************** +!* 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 tridiagonal_mod +!> @{ + +!> @brief Sets up and solves the tridiagonal system of equations +!! +!> For simplicity, A and C are assumed to be dimensioned the same size +!! as B, D, and X, although any input values for A(N) and C(1) are ignored. +!! There are no checks to make sure the sizes agree. +!! +!! The value of A(N) is modified on output, and B and C are unchanged. +!! +!! For mixed precision, this routine uses the kind size macro(FMS_TRID_KIND_) to determine +!! which module variables are used/stored. This means a,b, and c values will only be stored for calls +!! of the same real kind value unless store_both_kinds is present and .true.. +subroutine TRI_INVERT_(x,d,a,b,c, store_both_kinds) + + real(FMS_TRID_KIND_), intent(out), dimension(:,:,:) :: x !< Solution to the tridiagonal system of equations + real(FMS_TRID_KIND_), intent(in), dimension(:,:,:) :: d !< The right-hand side term, see the schematic above. + real(FMS_TRID_KIND_), optional, dimension(:,:,:) :: a,b,c !< Left hand side terms(see schematic on module page). + !! If not provided, values from last call are used + logical, optional :: store_both_kinds !< Will save module state + !! variables for both kind types in order to be used in + !! subsequent calls with either kind. + + real(FMS_TRID_KIND_), dimension(size(x,1),size(x,2),size(x,3)) :: f + integer, parameter :: kindl = FMS_TRID_KIND_ + + integer :: k + + if(present(a)) then + !$OMP SINGLE + INIT_VAR = .true. + if(allocated(TRID_REAL_TYPE%e)) deallocate(TRID_REAL_TYPE%e) + if(allocated(TRID_REAL_TYPE%g)) deallocate(TRID_REAL_TYPE%g) + if(allocated(TRID_REAL_TYPE%bb)) deallocate(TRID_REAL_TYPE%bb) + if(allocated(TRID_REAL_TYPE%cc)) deallocate(TRID_REAL_TYPE%cc) + allocate(TRID_REAL_TYPE%e (size(x,1),size(x,2),size(x,3))) + allocate(TRID_REAL_TYPE%g (size(x,1),size(x,2),size(x,3))) + allocate(TRID_REAL_TYPE%bb(size(x,1),size(x,2))) + allocate(TRID_REAL_TYPE%cc(size(x,1),size(x,2),size(x,3))) + !$OMP END SINGLE + + TRID_REAL_TYPE%e(:,:,1) = - a(:,:,1) / b(:,:,1) + a(:,:,size(x,3)) = 0.0_kindl + + do k= 2,size(x,3) + TRID_REAL_TYPE%g(:,:,k) = 1.0_kindl/(b(:,:,k)+c(:,:,k)*TRID_REAL_TYPE%e(:,:,k-1)) + TRID_REAL_TYPE%e(:,:,k) = - a(:,:,k)* TRID_REAL_TYPE%g(:,:,k) + end do + TRID_REAL_TYPE%cc = c + TRID_REAL_TYPE%bb = 1.0_kindl/b(:,:,1) + + end if + + if(.not.INIT_VAR) call mpp_error(FATAL, 'tri_invert: a,b,and c args not provided or previously calculated.') + + f(:,:,1) = d(:,:,1)*TRID_REAL_TYPE%bb + do k= 2, size(x,3) + f(:,:,k) = (d(:,:,k) - TRID_REAL_TYPE%cc(:,:,k)*f(:,:,k-1))*TRID_REAL_TYPE%g(:,:,k) + end do + + x(:,:,size(x,3)) = f(:,:,size(x,3)) + do k = size(x,3)-1,1,-1 + x(:,:,k) = TRID_REAL_TYPE%e(:,:,k)*x(:,:,k+1)+f(:,:,k) + end do + + ! stores both kind values for subsequent calculations if running with option + if( present(store_both_kinds)) then + if( store_both_kinds ) then + if( FMS_TRID_KIND_ .eq. r8_kind) then + tridiag_r4%e = real(TRID_REAL_TYPE%e, r4_kind) + tridiag_r4%g = real(TRID_REAL_TYPE%g, r4_kind) + tridiag_r4%cc = real(TRID_REAL_TYPE%cc, r4_kind) + tridiag_r4%bb = real(TRID_REAL_TYPE%bb, r4_kind) + init_tridiagonal_r4 = .true. + else + tridiag_r8%e = real(TRID_REAL_TYPE%e, r8_kind) + tridiag_r8%g = real(TRID_REAL_TYPE%g, r8_kind) + tridiag_r8%cc = real(TRID_REAL_TYPE%cc, r8_kind) + tridiag_r8%bb = real(TRID_REAL_TYPE%bb, r8_kind) + init_tridiagonal_r8 = .true. + endif + endif + endif + + return +end subroutine TRI_INVERT_ \ No newline at end of file diff --git a/tridiagonal/include/tridiagonal_r4.fh b/tridiagonal/include/tridiagonal_r4.fh new file mode 100644 index 0000000000..09e0ad57ac --- /dev/null +++ b/tridiagonal/include/tridiagonal_r4.fh @@ -0,0 +1,32 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +#undef FMS_TRID_KIND_ +#define FMS_TRID_KIND_ r4_kind + +#undef TRID_REAL_TYPE +#define TRID_REAL_TYPE tridiag_r4 + +#undef TRI_INVERT_ +#define TRI_INVERT_ tri_invert_r4 + +#undef INIT_VAR +#define INIT_VAR init_tridiagonal_r4 + +#include "tridiagonal.inc" \ No newline at end of file diff --git a/tridiagonal/include/tridiagonal_r8.fh b/tridiagonal/include/tridiagonal_r8.fh new file mode 100644 index 0000000000..b007941723 --- /dev/null +++ b/tridiagonal/include/tridiagonal_r8.fh @@ -0,0 +1,32 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +#undef FMS_TRID_KIND_ +#define FMS_TRID_KIND_ r8_kind + +#undef TRID_REAL_TYPE +#define TRID_REAL_TYPE tridiag_r8 + +#undef TRI_INVERT_ +#define TRI_INVERT_ tri_invert_r8 + +#undef INIT_VAR +#define INIT_VAR init_tridiagonal_r8 + +#include "tridiagonal.inc" \ No newline at end of file diff --git a/tridiagonal/tridiagonal.F90 b/tridiagonal/tridiagonal.F90 index c22f99c4ee..e34feb4d92 100644 --- a/tridiagonal/tridiagonal.F90 +++ b/tridiagonal/tridiagonal.F90 @@ -52,128 +52,85 @@ !! 
 !!    call close_tridiagonal
 !!
+!! +!! !! Arguments A, B, and C are optional, and are saved as module variables !! if one recalls tri_invert without changing (A,B,C) +!! +!! @note +!! Optional arguments A,B,C have no intent declaration, +!! so the default intent is inout. The value of A(N) is modified +!! on output, and B and C are unchanged. +!! +!! The following private allocatable arrays save the relevant information +!! if one recalls tri_invert without changing (A,B,C): +!! 
+!!        allocate ( e  (size(x,1), size(x,2), size(x,3)) )
+!!        allocate ( g  (size(x,1), size(x,2), size(x,3)) )
+!!        allocate ( cc (size(x,1), size(x,2), size(x,3)) )
+!!        allocate ( bb (size(x,1), size(x,2)) )
+!!
+!! This storage is deallocated when close_tridiagonal is called. !> @addtogroup tridiagonal_mod !> @{ module tridiagonal_mod -!-------------------------------------------------------------------------- -real, private, allocatable, dimension(:,:,:) :: e,g,cc -real, private, allocatable, dimension(:,:) :: bb -logical, private :: init_tridiagonal = .false. -!-------------------------------------------------------------------------- - -contains - -!-------------------------------------------------------------------------- - -!> @brief Sets up and solves the tridiagonal system of equations -!! -!> For simplicity, A and C are assumed to be dimensioned the same size -!! as B, D, and X, although any input values for A(N) and C(1) are ignored. -!! There are no checks to make sure the sizes agree. -!! -!! The value of A(N) is modified on output, and B and C are unchanged. -subroutine tri_invert(x,d,a,b,c) - -implicit none - -real, intent(out), dimension(:,:,:) :: x !< Solution to the tridiagonal system of equations -real, intent(in), dimension(:,:,:) :: d !< The right-hand side term, see the schematic above. -real, optional, dimension(:,:,:) :: a,b,c !< Left hand side terms(see schematic above). - !! If not provided, values from last call are used - -real, dimension(size(x,1),size(x,2),size(x,3)) :: f -integer :: k - -if(present(a)) then - - !< Check if module variables are allocated - !$OMP SINGLE - init_tridiagonal = .true. - if(allocated(e)) deallocate(e) - if(allocated(g)) deallocate(g) - if(allocated(bb)) deallocate(bb) - if(allocated(cc)) deallocate(cc) - allocate(e (size(x,1),size(x,2),size(x,3))) - allocate(g (size(x,1),size(x,2),size(x,3))) - allocate(bb(size(x,1),size(x,2))) - allocate(cc(size(x,1),size(x,2),size(x,3))) - !$OMP END SINGLE !< There is an implicit barrier. - - e(:,:,1) = - a(:,:,1)/b(:,:,1) - a(:,:,size(x,3)) = 0.0 - - do k= 2,size(x,3) - g(:,:,k) = 1.0/(b(:,:,k)+c(:,:,k)*e(:,:,k-1)) - e(:,:,k) = - a(:,:,k)*g(:,:,k) - end do - cc = c - bb = 1.0/b(:,:,1) - -end if - -! if(.not.init_tridiagonal) error - -f(:,:,1) = d(:,:,1)*bb -do k= 2, size(x,3) - f(:,:,k) = (d(:,:,k) - cc(:,:,k)*f(:,:,k-1))*g(:,:,k) -end do - -x(:,:,size(x,3)) = f(:,:,size(x,3)) -do k = size(x,3)-1,1,-1 - x(:,:,k) = e(:,:,k)*x(:,:,k+1)+f(:,:,k) -end do - -return -end subroutine tri_invert - -!----------------------------------------------------------------- - -!> @brief Releases memory used by the solver -subroutine close_tridiagonal - - implicit none - - !< Check if module variables are allocated - !$OMP SINGLE - if(allocated(e)) deallocate(e) - if(allocated(g)) deallocate(g) - if(allocated(bb)) deallocate(bb) - if(allocated(cc)) deallocate(cc) - !$OMP END SINGLE !< There is an implicit barrier. - -return -end subroutine close_tridiagonal - -!---------------------------------------------------------------- + use platform_mod, only: r4_kind, r8_kind + use mpp_mod, only: mpp_error, FATAL + implicit none + + type :: tridiag_reals_r4 + real(r4_kind), private, allocatable, dimension(:,:,:) :: e, g, cc + real(r4_kind), private, allocatable, dimension(:,:) :: bb + end type + + type :: tridiag_reals_r8 + real(r8_kind), private, allocatable, dimension(:,:,:) :: e, g, cc + real(r8_kind), private, allocatable, dimension(:,:) :: bb + end type + + type(tridiag_reals_r4) :: tridiag_r4 !< holds reals stored from r4_kind calls to tri_invert + type(tridiag_reals_r8) :: tridiag_r8 !< holds reals stored from r8_kind calls to tri_invert + + logical, private :: init_tridiagonal_r4 = .false. !< true when fields in tridiag_r4 are allocated + logical, private :: init_tridiagonal_r8 = .false. !< true when fields in tridiag_r8 are allocated + + !> Interface to solve tridiagonal systems of equations for either kind value. + !! Module level variables will be deallocated and allocated for every + !! Since this relies on the state of module variables (unless A,B,C are specified) + !! the values stored are distinct for each kind call unless the added optional argument store_both_kinds + !! is true. + interface tri_invert + module procedure tri_invert_r4 + module procedure tri_invert_r8 + end interface + + public :: tri_invert + + contains + + !> @brief Releases memory used by the solver + subroutine close_tridiagonal + if(.not. init_tridiagonal_r4 .and. .not. init_tridiagonal_r8) return + !$OMP SINGLE + if(allocated(tridiag_r4%e)) deallocate(tridiag_r4%e) + if(allocated(tridiag_r4%g)) deallocate(tridiag_r4%g) + if(allocated(tridiag_r4%cc)) deallocate(tridiag_r4%cc) + if(allocated(tridiag_r4%bb)) deallocate(tridiag_r4%bb) + if(allocated(tridiag_r8%e)) deallocate(tridiag_r8%e) + if(allocated(tridiag_r8%g)) deallocate(tridiag_r8%g) + if(allocated(tridiag_r8%cc)) deallocate(tridiag_r8%cc) + if(allocated(tridiag_r8%bb)) deallocate(tridiag_r8%bb) + init_tridiagonal_r4 = .false.; init_tridiagonal_r8 = .false. + !$OMP END SINGLE + return + end subroutine close_tridiagonal + +#include "tridiagonal_r4.fh" +#include "tridiagonal_r8.fh" end module tridiagonal_mod -! - -! -! Optional arguments A,B,C have no intent declaration, -! so the default intent is inout. The value of A(N) is modified -! on output, and B and C are unchanged. -! -! -! The following private allocatable arrays save the relevant information -! if one recalls tri_invert without changing (A,B,C): -! 
-!        allocate ( e  (size(x,1), size(x,2), size(x,3)) )
-!        allocate ( g  (size(x,1), size(x,2), size(x,3)) )
-!        allocate ( cc (size(x,1), size(x,2), size(x,3)) )
-!        allocate ( bb (size(x,1), size(x,2)) )
-!
-! This storage is deallocated when close_tridiagonal is called. -! -! -! Maybe a cleaner version? -! - -! !> @} -! close documentation grouping +! close documentation grouping \ No newline at end of file