fms/fms_io_unstructured_setup_one_field.inc

   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 !ug support
  21 !> @addtogroup fms_io_mod
  22 !> @{
  23
  24 !>Add a field to a restart object (restart_file_type).  Return the index of the
  25 !!inputted field in the fileObj%var array.
  26 subroutine fms_io_unstructured_setup_one_field(fileObj, &
  27                                                filename, &
  28                                                fieldname, &
  29                                                field_dimension_order, &
  30                                                field_dimension_sizes, &
  31                                                index_field, &
  32                                                domain, &
  33                                                mandatory, &
  34                                                data_default, &
  35                                                longname, &
  36                                                units, &
  37                                                read_only, &
  38                                                owns_data)
  39
  40    !Inputs/Outputs
  41     type(restart_file_type),intent(inout)        :: fileObj               !<A restart object.
  42     character(len=*),intent(in)                  :: filename              !<The name of the restart file.
  43     character(len=*),intent(in)                  :: fieldname             !<The name of a field.
  44     integer(INT_KIND),dimension(:),intent(in)    :: field_dimension_order !<Array telling the ordering
  45                                                                           !! of the dimensions for the field.
  46     integer(INT_KIND),dimension(NIDX),intent(in) :: field_dimension_sizes !<Array of sizes of the dimensions
  47                                                                           !! of the inputted field.
  48     integer(INT_KIND),intent(out)                :: index_field           !<Index of the inputted field
  49                                                                           !! in the fileObj%var array.
  50     type(domainUG),intent(in),target             :: domain                !<An unstructured mpp domain.
  51     logical(INT_KIND),intent(in),optional        :: mandatory             !<Flag telling if the field
  52                                                                           !! is mandatory for the restart.
  53     real,intent(in),optional                     :: data_default          !<A default value for the data.
  54     character(len=*),intent(in),optional         :: longname              !<A more descriptive name of the field.
  55     character(len=*),intent(in),optional         :: units                 !<Units for the field.
  56     logical(INT_KIND),intent(in),optional        :: read_only             !<Tells whether or not the
  57                                                                        !! variable will be written to the restart file.
  58     logical(INT_KIND),intent(in),optional        :: owns_data             !<Tells if the data will be
  59                                                                  !! deallocated when the restart object is deallocated.
  60
  61    !Local variables
  62     real(DOUBLE_KIND)      :: default_data    !<The "default" data value.  This defaults to MPP_FILL_DOUBLE.
  63                                               !! Shouldn't this be a real(DOUBLE_KIND)?
  64     character(len=256)     :: filename2       !<A string used to manipulate the inputted filename.
  65     integer(INT_KIND)      :: length          !<the length of the (trimmed) inputted file name.
  66     character(len=256)     :: append_string   !<A string used to append the filename_appendix module
  67                                               !! variable string to the inputted filename.
  68     character(len=256)     :: fname           !<A string to hold a file name.
  69     type(var_type),pointer :: cur_var         !<A convenience pointer.
  70     integer(INT_KIND)      :: i               !<Loop variable.
  71     character(len=256)     :: error_msg       !<An error message string.
  72
  73    !Make sure that the field does not have more than five dimensions.
  74     if (size(field_dimension_order) .gt. 5) then
  75         call mpp_error(FATAL, &
  76                        "fms_io_unstructured_setup_one_field:" &
  77                        //" the inputted field cannot contain more than" &
  78                        //" five dimensions.")
  79     endif
  80
  81    !Make sure that each dimension size is greater than zero.
  82     if (any(field_dimension_sizes .lt. 0)) then
  83         call mpp_error(FATAL, &
  84                        "fms_io_unstructured_setup_one_field:" &
  85                        //" all dimensions must have a size that is a non-" &
  86                        //" negative integer.")
  87     endif
  88
  89    !Set the "default" data value for the field.
  90     if (present(data_default)) then
  91         default_data = data_default
  92     else
  93         default_data = MPP_FILL_DOUBLE
  94     endif
  95
  96    !Remove the ".nc" from file name.
  97     length = len_trim(filename)
  98     if (filename(length-2:length) .eq. ".nc") then
  99         filename2 = filename(1:length-3)
 100     else
 101         filename2 = filename(1:length)
 102     endif
 103
 104    !Append the filename_appendix string to the file name.
 105    !filename_appendix is a module variable.
 106     append_string = ""
 107     if (len_trim(filename_appendix) .gt. 0) then
 108         append_string = filename_appendix
 109     endif
 110     if (len_trim(append_string) .gt. 0) then
 111         filename2 = trim(filename2)//'.'//trim(append_string)
 112     endif
 113
 114    !If necessary, add the correct domain ".tilexxxx" string to the inputted
 115    !file name.  For a file named foo.nc, this would become foo.tilexxxx.nc.
 116     call get_mosaic_tile_file_ug(filename2, &
 117                                  fname, &
 118                                  domain)
 119
 120     if (associated(fileObj%var)) then
 121
 122        !Make sure that the filename stored in fileObj matches the filename
 123        !returned from get_mosaic_tile_file_ug.
 124         if (trim(fileObj%name) .ne. trim(fname)) then
 125             call mpp_error(FATAL, &
 126                            "fms_io_unstructured_setup_one_field:" &
 127                            //" filename = "//trim(fname)//" is not" &
 128                            //" consistent with the filename of the" &
 129                            //" restart object = "//trim(fileObj%name))
 130         endif
 131     else
 132
 133        !If any axis has already been registered, then make sure that the
 134        !filename returned from get_mosaic_tile_file_ug matches the filename
 135        !stored in the fileObj restart object.  If this is the first axis/
 136        !field registered to the restart object, then store the filename
 137        !returned from get_mosaic_tile_file_ug in the restart object.
 138         if (allocated(fileObj%axes)) then
 139             if (trim(fileObj%name) .ne. trim(fname)) then
 140                 call mpp_error(FATAL, &
 141                                "fms_io_unstructured_setup_one_field:" &
 142                                //" filename = "//trim(fname)//" is not" &
 143                                //" consistent with the filename of the" &
 144                                //" restart object = "//trim(fileObj%name))
 145             endif
 146         else
 147             fileObj%name = trim(fname)
 148         endif
 149
 150        !Allocate necessary space in hte restart object.
 151         allocate(fileObj%var(max_fields))
 152         allocate(fileObj%p0dr(MAX_TIME_LEVEL_REGISTER,max_fields))
 153         allocate(fileObj%p1dr(MAX_TIME_LEVEL_REGISTER,max_fields))
 154         allocate(fileObj%p2dr(MAX_TIME_LEVEL_REGISTER,max_fields))
 155         allocate(fileObj%p3dr(MAX_TIME_LEVEL_REGISTER,max_fields))
 156         allocate(fileObj%p4dr(MAX_TIME_LEVEL_REGISTER,max_fields))
 157         allocate(fileObj%p2dr8(MAX_TIME_LEVEL_REGISTER,max_fields))
 158         allocate(fileObj%p3dr8(MAX_TIME_LEVEL_REGISTER,max_fields))
 159         allocate(fileObj%p0di(MAX_TIME_LEVEL_REGISTER,max_fields))
 160         allocate(fileObj%p1di(MAX_TIME_LEVEL_REGISTER,max_fields))
 161         allocate(fileObj%p2di(MAX_TIME_LEVEL_REGISTER,max_fields))
 162         allocate(fileObj%p3di(MAX_TIME_LEVEL_REGISTER,max_fields))
 163
 164        !Make sure that the restart file name is not currently being used by
 165        !an other restart objects.  Shouldn't this be fatal?
 166        !num_registered files is a module variable.
 167         do i = 1,num_registered_files
 168             if (trim(fname) .eq. trim(registered_file(i))) then
 169                 call mpp_error(FATAL, &
 170                                "fms_io_unstructured_setup_one_field: " &
 171                                //trim(fname)//" is already registered with" &
 172                                //" another restart_file_type data.")
 173                 exit
 174             endif
 175         enddo
 176
 177        !Iterate the number of registered restart files, and add the inputted
 178        !file to the array.  Should this be fatal?
 179        !max_files_w is a module variable.
 180         num_registered_files = num_registered_files + 1
 181         if (num_registered_files .gt. max_files_w) then
 182             call mpp_error(FATAL, &
 183                            "fms_io_unstructured_setup_one_field:" &
 184                            //" the number of registered files is greater" &
 185                            //" than max_files_w.  Please increase" &
 186                            //" max_files_w in the fms_io_nml namelist.")
 187         endif
 188         registered_file(num_registered_files) = trim(fname)
 189
 190        !Set values for the restart object.
 191        !max_fields is a module variable.
 192         fileObj%register_id = num_registered_files
 193         fileObj%max_ntime = field_dimension_sizes(TIDX)
 194         fileObj%is_root_pe = mpp_domain_UG_is_tile_root_pe(domain)
 195         fileObj%nvar = 0
 196         do i = 1,max_fields
 197             fileObj%var(i)%name = "none"
 198             fileObj%var(i)%longname = "";
 199             fileObj%var(i)%units = "none";
 200             fileObj%var(i)%domain_present = .false.
 201             fileObj%var(i)%domain_idx = -1
 202             fileObj%var(i)%is_dimvar = .false.
 203             fileObj%var(i)%read_only = .false.
 204             fileObj%var(i)%owns_data = .false.
 205             fileObj%var(i)%position = CENTER
 206             fileObj%var(i)%ndim = -1
 207             fileObj%var(i)%siz(:) = -1
 208             fileObj%var(i)%gsiz(:) = -1
 209             fileObj%var(i)%id_axes(:) = -1
 210             fileObj%var(i)%initialized = .false.
 211             fileObj%var(i)%mandatory = .true.
 212             fileObj%var(i)%is = -1
 213             fileObj%var(i)%ie = -1
 214             fileObj%var(i)%js = -1
 215             fileObj%var(i)%je = -1
 216             fileObj%var(i)%default_data = -1
 217             fileObj%var(i)%compressed_axis = ""
 218             fileObj%var(i)%ishift = -1
 219             fileObj%var(i)%jshift = -1
 220             fileObj%var(i)%x_halo = -1
 221             fileObj%var(i)%y_halo = -1
 222             fileObj%var(i)%field_dimension_order(:) = -1
 223             fileObj%var(i)%field_dimension_sizes(:) = -1
 224         enddo
 225     endif
 226
 227    !Get the index of the field in the fileObj%var array, if it exists.  If
 228    !it doesn't exist, set the index to be -1.
 229     index_field = -1
 230     do i = 1,fileObj%nvar
 231         if (trim(fileObj%var(i)%name) .eq. trim(fieldname)) then
 232             index_field = i
 233             exit
 234         endif
 235     enddo
 236
 237     if (index_field > 0) then
 238
 239        !If the field already exists in the fileObj%var array, then update its
 240        !time level.
 241         cur_var => null()
 242         cur_var => fileObj%var(index_field)
 243
 244        !Make sure tha the inputted array describing the ordering of the
 245        !dimensions for the field matches the dimension ordering for the
 246        !found field.
 247         do i = 1,size(field_dimension_order)
 248             if (field_dimension_order(i) .ne. cur_var%field_dimension_order(i)) then
 249                 call mpp_error(FATAL, &
 250                                "fms_io_unstructured_setup_one_field:" &
 251                                //" field dimension ordering mismatch for " &
 252                                //trim(fieldname)//" of file "//trim(filename))
 253             endif
 254         enddo
 255
 256        !Make sure that the array of field dimension sizes matches the
 257        !dimension sizes of the found field for all dimensions except the
 258        !time level.
 259         if (cur_var%field_dimension_sizes(XIDX) .ne. field_dimension_sizes(XIDX) .or. &
 260             cur_var%field_dimension_sizes(YIDX) .ne. field_dimension_sizes(YIDX) .or. &
 261             cur_var%field_dimension_sizes(CIDX) .ne. field_dimension_sizes(CIDX) .or. &
 262             cur_var%field_dimension_sizes(ZIDX) .ne. field_dimension_sizes(ZIDX) .or. &
 263             cur_var%field_dimension_sizes(HIDX) .ne. field_dimension_sizes(HIDX) .or. &
 264             cur_var%field_dimension_sizes(UIDX) .ne. field_dimension_sizes(UIDX) .or. &
 265             cur_var%field_dimension_sizes(CCIDX) .ne. field_dimension_sizes(CCIDX)) then
 266             call mpp_error(FATAL, &
 267                            "fms_io_unstructured_setup_one_field:" &
 268                            //" field dimension size mismatch for field " &
 269                            //trim(fieldname)//" of file "//trim(filename))
 270         endif
 271
 272        !Update the time level.
 273         cur_var%siz(4) = cur_var%siz(4) + field_dimension_sizes(TIDX)
 274         if (fileObj%max_ntime .lt. cur_var%siz(4)) then
 275             fileObj%max_ntime = cur_var%siz(4)
 276         endif
 277         if (cur_var%siz(4) .gt. MAX_TIME_LEVEL_REGISTER) then
 278             call mpp_error(FATAL, &
 279                            "fms_io_unstructured_setup_one_field:" &
 280                            //" the time level of field "//trim(cur_var%name) &
 281                            //" in file "//trim(fileObj%name)//" is greater" &
 282                            //" than MAX_TIME_LEVEL_REGISTER(=2), increase" &
 283                            //" MAX_TIME_LEVEL_REGISTER or check your code.")
 284         endif
 285     else
 286
 287        !If this is a new field, then add it the restart object.
 288         fileObj%nvar = fileObj%nvar + 1
 289         if (fileObj%nvar .gt. max_fields) then
 290             write(error_msg,'(I3,"/",I3)') fileObj%nvar,max_fields
 291             call mpp_error(FATAL, &
 292                            "fms_io_unstructured_setup_one_field:" &
 293                            //" max_fields exceeded, needs increasing," &
 294                            //" nvar/max_fields = "//trim(error_msg))
 295         endif
 296         index_field = fileObj%nvar
 297         cur_var => null()
 298         cur_var => fileObj%var(index_field)
 299
 300        !Point to the inputted unstructured domain.
 301         cur_var%domain_ug => domain
 302
 303        !Copy in the dimension sizes of the data domain (siz, used for
 304        !writes), and of the global domain (gsiz, used for reads).
 305         cur_var%field_dimension_sizes = field_dimension_sizes
 306         do i = 1,size(field_dimension_order)
 307             cur_var%field_dimension_order(i) = field_dimension_order(i)
 308         enddo
 309         cur_var%siz(4) = field_dimension_sizes(TIDX)
 310
 311        !Copy in the rest of the data.
 312         cur_var%name = fieldname
 313         cur_var%default_data = real(default_data)
 314         if (present(mandatory)) then
 315             cur_var%mandatory = mandatory
 316         endif
 317         if (present(read_only)) then
 318             cur_var%read_only = read_only
 319         endif
 320         if (present(owns_data)) then
 321             cur_var%owns_data = owns_data
 322         endif
 323         if (present(longname)) then
 324             cur_var%longname = longname
 325         else
 326             cur_var%longname = fieldname
 327         endif
 328         if (present(units)) then
 329             cur_var%units = units
 330         endif
 331     endif
 332
 333    !Nullify local pointer.
 334     cur_var => null()
 335
 336     return
 337 end subroutine fms_io_unstructured_setup_one_field
 338 !> @}