test_fms/diag_manager/test_diag_attribute_add.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 program test_diag_attribute_add
  21   use platform_mod, only: r4_kind, r8_kind
  22   use mpp_mod, only: FATAL, mpp_error
  23   use fms_mod, only: fms_init, fms_end
  24   use diag_manager_mod, only: diag_axis_init, register_static_field, diag_send_complete, send_data
  25   use diag_manager_mod, only: register_diag_field, diag_field_add_attribute
  26   use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_manager_set_time_end
  27   use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+)
  28   use fms2_io_mod
  29
  30   implicit none
  31
  32   integer :: id_potatoes
  33   integer :: i
  34   type(time_type) :: Time
  35   type(time_type) :: Time_step
  36   logical :: used
  37   real(kind=r4_kind) :: fbuffer(2) = (/ 13., 14./)
  38   real(kind=r8_kind) :: dbuffer(2) = (/ 23., 24./)
  39   integer :: ibuffer(2) = (/ 551, 552/)
  40   character(len=20) :: cbuffer = "Hello World"
  41
  42   call fms_init()
  43   call set_calendar_type(JULIAN)
  44   call diag_manager_init()
  45
  46   Time = set_date(2,1,1,0,0,0)
  47   Time_step = set_time (3600*4,0)
  48   call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
  49
  50   id_potatoes = register_diag_field ('food_mod', 'potatoes', init_time=Time)
  51   call diag_field_add_attribute(id_potatoes, "real_32", fbuffer(1))
  52   call diag_field_add_attribute(id_potatoes, "real_32_1d", fbuffer)
  53   call diag_field_add_attribute(id_potatoes, "real_64", dbuffer(1))
  54   call diag_field_add_attribute(id_potatoes, "real_64_1d", dbuffer )
  55   call diag_field_add_attribute(id_potatoes, "integer", ibuffer(1))
  56   call diag_field_add_attribute(id_potatoes, "integer_1d", ibuffer)
  57   call diag_field_add_attribute(id_potatoes, "some_string", cbuffer)
  58
  59   do i = 1, 6
  60     Time = Time + Time_step
  61     used = send_data(id_potatoes, real(103.201), Time)
  62     call diag_send_complete(Time_step)
  63   enddo
  64
  65   call diag_manager_end(Time)
  66
  67   call check_output()
  68   call fms_end()
  69
  70   contains
  71
  72   subroutine check_output()
  73     type(FmsNetcdfFile_t) :: fileobj !< FMS2io fileobj
  74     character(len=256) :: cbuffer_out !< Buffer to read stuff into
  75     integer :: ibuffer_out(2)
  76     real(kind=r4_kind) :: fbuffer_out(2)
  77     real(kind=r8_kind) :: dbuffer_out(2)
  78
  79     if (.not. open_file(fileobj, "food_file.nc", "read")) &
  80       call mpp_error(FATAL, "food_file.nc was not created by the diag manager!")
  81     if (.not. variable_exists(fileobj, "potatoes")) &
  82       call mpp_error(FATAL, "potatoes is not in food_file.nc")
  83
  84     !! Checking the string attributes
  85     call get_variable_attribute(fileobj, "potatoes", "some_string", cbuffer_out)
  86     if (trim(cbuffer_out) .ne. trim(cbuffer)) call mpp_error(FATAL, "some_string is not the expected attribute")
  87
  88     !! Checking the integer attributes
  89     ibuffer_out = -999
  90     call get_variable_attribute(fileobj, "potatoes", "integer", ibuffer_out(1))
  91     if (ibuffer(1) .ne. ibuffer_out(1)) call mpp_error(FATAL, "integer is not the expected attribute")
  92
  93     ibuffer_out = -999
  94     call get_variable_attribute(fileobj, "potatoes", "integer_1d", ibuffer_out)
  95     if (ibuffer(1) .ne. ibuffer_out(1)) call mpp_error(FATAL, "integer_1d is not the expected attribute")
  96     if (ibuffer(2) .ne. ibuffer_out(2)) call mpp_error(FATAL, "integer_1d is not the expected attribute")
  97
  98     !! Checking the double attributes
  99     dbuffer_out = -999
 100     call get_variable_attribute(fileobj, "potatoes", "real_64", dbuffer_out(1))
 101     if (dbuffer(1) .ne. dbuffer_out(1)) call mpp_error(FATAL, "real_64 is not the expected attribute")
 102
 103     dbuffer_out = -999
 104     call get_variable_attribute(fileobj, "potatoes", "real_64_1d", dbuffer_out)
 105     if (dbuffer(1) .ne. dbuffer_out(1)) call mpp_error(FATAL, "real_64_1d is not the expected attribute")
 106     if (dbuffer(2) .ne. dbuffer_out(2)) call mpp_error(FATAL, "real_64_1d is not the expected attribute")
 107
 108     !! Checking the float attributes
 109     fbuffer_out = -999
 110     call get_variable_attribute(fileobj, "potatoes", "real_32", fbuffer_out(1))
 111     if (fbuffer(1) .ne. fbuffer_out(1)) call mpp_error(FATAL, "real_32 is not the expected attribute")
 112
 113     fbuffer_out = -999
 114     call get_variable_attribute(fileobj, "potatoes", "real_32_1d", fbuffer_out)
 115     if (fbuffer(1) .ne. fbuffer_out(1)) call mpp_error(FATAL, "real_32_1d is not the expected attribute")
 116     if (fbuffer(2) .ne. fbuffer_out(2)) call mpp_error(FATAL, "real_32_1d is not the expected attribute")
 117
 118     call close_file(fileobj)
 119   end subroutine check_output
 120 end program test_diag_attribute_add