fms/fms_io_unstructured_get_file_name.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 !> @file
  22 !> @ingroup fms_io_mod
  23
  24 !>For an inputted file name, check if it or any of its variants exist.
  25 !!For a file named "foo", variants checked (in order) include:
  26 !!
  27 !!    foo
  28 !!    foo.nc
  29 !!    foo.<domain_tile_id_string>.nc
  30 !!    foo.nc.<IO_domain_tile_id_string>
  31 !!    foo.<domain_tile_id_string>.nc.<IO_domain_tile_id_string>
  32 !!    foo.<ensemble_id>
  33 !!    foo.<ensemble_id>.nc
  34 !!    foo.<ensemble_id>.<domain_tile_id_string>.nc
  35 !!    foo.<ensemble_id>.nc.<IO_domain_tile_id_string>
  36 !!    foo.<ensemble_id>.<domain_tile_id_string>.nc.<IO_domain_tile_id_string>
  37 !!
  38 !!If a match is found, the value true is returned for the "does_file_exist"
  39 !!flag.  In addition, the actual file name is returned and the "read_dist"
  40 !!flag, which tells whether or not the filename contains the
  41 !!IO_domain_tile_id_string appended.
  42 !!
  43 !!Should this be a subroutine instead of a funtion for clarity since it
  44 !!returns more than one value?
  45 function fms_io_unstructured_get_file_name(orig_file, &
  46                                            actual_file, &
  47                                            read_dist, &
  48                                            domain) &
  49                                            result(does_file_exist)
  50
  51    !Inputs/Outputs
  52     character(len=*),intent(in)   :: orig_file       !<The name of file we're looking for.
  53     character(len=*),intent(out)  :: actual_file     !<Name of the file we found.
  54     logical(INT_KIND),intent(out) :: read_dist       !<Flag telling if the file is "distributed"
  55                                                      !! (has IO domain tile id appended onto the end).
  56     type(domainUG),intent(in)     :: domain          !<Unstructured mpp domain.
  57     logical(INT_KIND)             :: does_file_exist !<Flag telling if the inputted file exists or one its variants.
  58
  59    !Local variables
  60     logical(INT_KIND)      :: fexist          !<Flag that tells if a file exists.
  61     type(domainUG),pointer :: io_domain       !<Pointer to an unstructured I/O domain.
  62     integer(INT_KIND)      :: io_tile_id      !<Tile id for the I/O domain.
  63     character(len=256)     :: fname           !<A character buffer used to test different file names.
  64     character(len=512)     :: actual_file_tmp !<A character buffer used to test different file names.
  65
  66    !Set the default return values for the function.
  67     actual_file = ""
  68     does_file_exist = .false.
  69     read_dist = .false.
  70
  71    !Check if the file name does not contain ".nc".
  72     fexist = .false.
  73     if (index(orig_file,".nc",back=.true.) .eq. 0) then
  74         inquire(file=trim(orig_file),exist=fexist)
  75         if (fexist) then
  76             actual_file = orig_file
  77             does_file_exist = .true.
  78             return
  79         endif
  80     endif
  81
  82    !If necessary, add the correct domain ".tilexxxx" string to the inputted
  83    !file name.  For a file named foo.nc, this would become foo.tilexxxx.nc.
  84    !Check if the new file name exists.
  85     call get_mosaic_tile_file_ug(orig_file, &
  86                                  actual_file, &
  87                                  domain)
  88     inquire(file=trim(actual_file),exist=fexist)
  89     if (fexist) then
  90         does_file_exist = .true.
  91         return
  92     endif
  93
  94    !Point to the I/O domain for the unstructured grid.  This function call
  95    !will throw a fatal error if the I/O domain does not exist.
  96     io_domain => null()
  97     io_domain => mpp_get_UG_io_domain(domain)
  98
  99    !Get the tile id for the I/O domain.
 100     io_tile_id = mpp_get_UG_domain_tile_id(io_domain)
 101     io_domain => null()
 102
 103    !Check if the file has the I/O domain's tile id appended to the end of its
 104    !name.  For a file named foo.nc, this would become foo.nc.yyyy, where
 105    !"yyyy" would in reality be the I/O domain's tile id.  If the file exists,
 106    !then set the read_dist and does_file_exist flags to true and return.
 107     write(fname,'(a,i4.4)') trim(actual_file)//'.',io_tile_id
 108     inquire(file=trim(fname),exist=fexist)
 109     if (.not. fexist) then
 110         write(fname,'(a,i6.6)') trim(actual_file)//'.',io_tile_id
 111         inquire(file=trim(fname),exist=fexist)
 112     endif
 113     if (fexist) then
 114         read_dist = .true.
 115         does_file_exist = .true.
 116         return
 117     endif
 118
 119    !Check if the file is part of an ensemble.
 120    !filename_appendix is a module variable.
 121     if (len_trim(filename_appendix) .gt. 0) then
 122         call get_instance_filename(orig_file, &
 123                                    actual_file)
 124         if (index(orig_file,'.nc',back=.true.) .eq. 0) then
 125             inquire(file=trim(actual_file),exist=fexist)
 126             if (fexist) then
 127                 does_file_exist = .true.
 128                 return
 129             endif
 130         endif
 131
 132        !Make a local copy of "actual_file", and the use the local copy to
 133        !add the domain ".tilexxxx" string to "actual_file".
 134         actual_file_tmp = actual_file
 135         call get_mosaic_tile_file_ug(actual_file_tmp, &
 136                                      actual_file, &
 137                                      domain)
 138         inquire(file=trim(actual_file),exist=fexist)
 139         if (fexist) then
 140             does_file_exist = .true.
 141             return
 142         endif
 143
 144        !Point to the I/O domain for the unstructured grid.  This function call
 145        !will throw a fatal error if the I/O domain does not exist.
 146         io_domain => mpp_get_UG_io_domain(domain)
 147
 148        !Get the tile id for the I/O domain.
 149         io_tile_id = mpp_get_UG_domain_tile_id(io_domain)
 150         io_domain => null()
 151
 152        !Check if the file has the I/O domain's tile id appended to the end of
 153        !its name.  If it does then set the read_dist and does_file_exist flags
 154        !to true and return.
 155         write(fname,'(a,i4.4)') trim(actual_file)//'.',io_tile_id
 156         inquire(file=trim(fname),exist=fexist)
 157         if (.not. fexist) then
 158             write(fname,'(a,i6.6)') trim(actual_file)//'.',io_tile_id
 159             inquire(file=trim(fname),exist=fexist)
 160         endif
 161         if (fexist) then
 162             read_dist = .true.
 163             does_file_exist = .true.
 164             return
 165         endif
 166     endif
 167
 168     return
 169 end function fms_io_unstructured_get_file_name
 170
 171 !------------------------------------------------------------------------------