test_fms/coupler/test_coupler_2d.F90

   1 !***********************************************************************
   2 !*                   GNU Lesser General Public License
   3 !*
   4 !* This file is part of the GFDL Flexible Modeling System (FMS).
   5 !*
   6 !* FMS is free software: you can redistribute it and/or modify it under
   7 !* the terms of the GNU Lesser General Public License as published by
   8 !* the Free Software Foundation, either version 3 of the License, or (at
   9 !* your option) any later version.
  10 !*
  11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
  12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 !* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 !* for more details.
  15 !*
  16 !* You should have received a copy of the GNU Lesser General Public
  17 !* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
  18 !***********************************************************************
  19
  20 !! defaults to ensure compilation
  21 #ifndef FMS_CP_TEST_KIND_
  22 #define FMS_CP_TEST_KIND_ r8_kind
  23 #endif
  24
  25 #ifndef FMS_TEST_BC_TYPE_
  26 #define FMS_TEST_BC_TYPE_ bc
  27 #endif
  28
  29 !> @brief  This programs tests the functionality in
  30 !! 1. coupler_type_register_restarts (CT_register_restarts_2d)
  31 !! 2. coupler_type_restore_state (CT_restore_state_2d)
  32 program test_coupler_2d
  33
  34 use   fms2_io_mod,        only: FmsNetcdfDomainFile_t, open_file, close_file, read_restart, write_restart
  35 use   fms2_io_mod,        only: FmsNetcdfFile_t, register_axis, register_field, write_data
  36 use   fms2_io_mod,        only: register_variable_attribute
  37 use   fms_mod,            only: fms_init, fms_end
  38 use   mpp_mod,            only: mpp_error, mpp_pe, mpp_root_pe, FATAL
  39 use   mpp_domains_mod,    only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_data_domain
  40 use   coupler_types_mod,  only: coupler_2d_bc_type, coupler_3d_bc_type, coupler_type_register_restarts, &
  41                                 coupler_type_restore_state
  42 use   coupler_types_mod,  only: coupler_1d_bc_type
  43 use   platform_mod,       only: r8_kind, r4_kind
  44
  45 implicit none
  46
  47 type(coupler_2d_bc_type)              :: bc_type          !< Coupler 2d restart types
  48 type(coupler_2d_bc_type)              :: bc_type_read     !< Coupler 2d restart types for reading
  49 type(FmsNetcdfDomainFile_t), pointer  :: bc_rest_files(:)=> null() !< Array of fms2_io fileobjs
  50 type(domain2d)                        :: Domain           !< Domain with mask table
  51 integer, dimension(2)                 :: layout = (/1,1/) !< Domain layout
  52 integer                               :: nlon             !< Number of points in x axis
  53 integer                               :: nlat             !< Number of points in y axis
  54 integer, dimension(4)                 :: data_grid        !< Starting/Ending indices in x and y
  55                                                           !! for the data_domain
  56 integer                               :: num_rest_files   !< Number of restart files
  57 integer                               :: i                !< No description
  58 type(FmsNetcdfFile_t)                 :: fileobj          !< fms2_io fileobjs
  59 real(FMS_CP_TEST_KIND_), allocatable                     :: dummy_var(:,:)   !< Dummy variable
  60
  61 call fms_init()
  62
  63 nlat=60
  64 nlon=60
  65
  66 call mpp_define_domains( (/1,nlon,1,nlat/), layout, Domain, name='test_coupler')
  67 call mpp_define_io_domain(Domain, (/1,1/))
  68 call mpp_get_data_domain(Domain, data_grid(1), data_grid(2), data_grid(3), data_grid(4))
  69
  70 !> Create a dummy general file
  71 if (mpp_pe() .eq. mpp_root_pe()) then
  72    if (open_file(fileobj, "RESTART/default_3_ice_restart_2d.res.nc", "overwrite")) then
  73        call register_axis(fileobj, "lonx", nlon)
  74        call register_axis(fileobj, "laty", nlat)
  75
  76        call register_field(fileobj, "lonx", "double", (/ "lonx" /))
  77        call register_field(fileobj, "laty", "double", (/ "laty" /))
  78
  79        call register_field(fileobj, "var_1", "double", (/ "lonx", "laty" /))
  80        call register_field(fileobj, "var_2", "double", (/ "lonx", "laty" /))
  81
  82        call register_variable_attribute(fileobj, "lonx", "axis", "x", str_len=1)
  83        call register_variable_attribute(fileobj, "laty", "axis", "y", str_len=1)
  84
  85        allocate(dummy_var(nlon, nlat))
  86        dummy_var = real(1, kind=FMS_CP_TEST_KIND_)
  87        call write_data(fileobj, "var_1", dummy_var)
  88
  89        dummy_var = real(2, kind=FMS_CP_TEST_KIND_)
  90        call write_data(fileobj, "var_2", dummy_var)
  91
  92        call close_file(fileobj)
  93
  94        deallocate(dummy_var)
  95    endif
  96
  97
  98 endif
  99
 100
 101 !> Write the file with new io
 102 call set_up_2d_coupler_type(bc_type, data_grid, appendix="new", to_read=.false.)
 103 call coupler_type_register_restarts(bc_type, bc_rest_files, num_rest_files, domain, to_read=.false., &
 104                                    & ocean_restart=.false., directory="RESTART/")
 105
 106 do i = 1, bc_type%num_bcs
 107    call write_restart(bc_rest_files(i))
 108    call close_file(bc_rest_files(i))
 109 enddo
 110
 111 !< Now read the file back!
 112 call set_up_2d_coupler_type(bc_type_read, data_grid, appendix="new", to_read=.true.)
 113 call coupler_type_register_restarts(bc_type_read, bc_rest_files, num_rest_files, domain, to_read=.true., &
 114                                   & ocean_restart=.false., directory="RESTART/")
 115
 116 do i = 1, bc_type_read%num_bcs
 117    call read_restart(bc_rest_files(i))
 118 enddo
 119
 120 call coupler_type_restore_state(bc_type_read, .true., test_by_field=.true.)
 121
 122 do i = 1, bc_type_read%num_bcs
 123    call close_file(bc_rest_files(i))
 124 enddo
 125
 126 !< Compare answers!
 127 call compare_2d_answers(bc_type_read, bc_type)
 128
 129 call destroy_2d_coupler_type(bc_type)
 130 call destroy_2d_coupler_type(bc_type_read)
 131
 132 deallocate(bc_rest_files)
 133
 134 call fms_end()
 135
 136 contains
 137
 138 ! bring over shared util routines from include file
 139 #include "test_coupler_utils.inc"
 140
 141 end program test_coupler_2d