FMS  2024.03
Flexible Modeling System
mpp_io_connect.inc
1 ! -*-f90-*-
2 
3 !***********************************************************************
4 !* GNU Lesser General Public License
5 !*
6 !* This file is part of the GFDL Flexible Modeling System (FMS).
7 !*
8 !* FMS is free software: you can redistribute it and/or modify it under
9 !* the terms of the GNU Lesser General Public License as published by
10 !* the Free Software Foundation, either version 3 of the License, or (at
11 !* your option) any later version.
12 !*
13 !* FMS is distributed in the hope that it will be useful, but WITHOUT
14 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 !* for more details.
17 !*
18 !* You should have received a copy of the GNU Lesser General Public
19 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
20 !***********************************************************************
21 !> @file
22 !> @brief Handles opening and closing files in @ref mpp_io_mod
23 
24 !> @addtogroup mpp_io_mod
25 !> @{
26 
27 ! <SUBROUTINE NAME="mpp_open">
28 
29 ! <OVERVIEW>
30 ! Open a file for parallel I/O.
31 ! </OVERVIEW>
32 ! <DESCRIPTION>
33 ! Open a file for parallel I/O.
34 ! </DESCRIPTION>
35 ! <TEMPLATE>
36 ! call mpp_open( unit, file, action, form, access, threading, fileset,
37 ! iospec, nohdrs, recl, pelist )
38 ! </TEMPLATE>
39 
40 ! <OUT NAME="unit" TYPE="integer">
41 ! unit is intent(OUT): always _returned_by_ mpp_open().
42 ! </OUT>
43 ! <IN NAME="file" TYPE="character(len=*)">
44 ! file is the filename: REQUIRED
45 ! we append .nc to filename if it is a netCDF file
46 ! we append .<pppp> to filename if fileset is private (pppp is PE number)
47 ! </IN>
48 ! <IN NAME="action" TYPE="integer">
49 ! action is one of MPP_RDONLY, MPP_APPEND, MPP_WRONLY or MPP_OVERWR.
50 ! </IN>
51 ! <IN NAME="form" TYPE="integer">
52 ! form is one of MPP_ASCII: formatted read/write
53 ! MPP_NATIVE: unformatted read/write with no conversion
54 ! MPP_IEEE32: unformatted read/write with conversion to IEEE32
55 ! MPP_NETCDF: unformatted read/write with conversion to netCDF
56 ! </IN>
57 ! <IN NAME="access" TYPE="integer">
58 ! access is one of MPP_SEQUENTIAL or MPP_DIRECT (ignored for netCDF).
59 ! RECL argument is REQUIRED for direct access IO.
60 ! </IN>
61 ! <IN NAME="threading" TYPE="integer">
62 ! threading is one of MPP_SINGLE or MPP_MULTI
63 ! single-threaded IO in a multi-PE run is done by PE0.
64 ! </IN>
65 ! <IN NAME="fileset" TYPE="integer">
66 ! fileset is one of MPP_MULTI and MPP_SINGLE
67 ! fileset is only used for multi-threaded I/O
68 ! if all I/O PEs in <pelist> use a single fileset, they write to the same file
69 ! if all I/O PEs in <pelist> use a multi fileset, they each write an independent file
70 ! </IN>
71 ! <IN NAME="pelist" TYPE="integer">
72 ! pelist is the list of I/O PEs (currently ALL).
73 ! </IN>
74 ! <IN NAME="recl" TYPE="integer">
75 ! recl is the record length in bytes.
76 ! </IN>
77 ! <IN NAME="iospec" TYPE="character(len=*)">
78 ! iospec is deprecated, but included for interface uniformity reasons.
79 ! </IN>
80 ! <IN NAME="nohdrs" TYPE="logical">
81 ! nohdrs has no effect when action=MPP_RDONLY|MPP_APPEND or when form=MPP_NETCDF
82 ! </IN>
83 ! <NOTE>
84 ! The integer parameters to be passed as flags (<TT>MPP_RDONLY</TT>,
85 ! etc) are all made available by use association. The <TT>unit</TT>
86 ! returned by <TT>mpp_open</TT> is guaranteed unique. For non-netCDF I/O
87 ! it is a valid fortran unit number and fortran I/O can be directly called
88 ! on the file.
89 !
90 ! <TT>MPP_WRONLY</TT> will guarantee that existing files named
91 ! <TT>file</TT> will not be clobbered. <TT>MPP_OVERWR</TT>
92 ! allows overwriting of files.
93 !
94 ! Files opened read-only by many processors will give each processor
95 ! an independent pointer into the file, i.e:
96 !
97 ! <PRE>
98 ! namelist / nml / ...
99 ! ...
100 ! call mpp_open( unit, 'input.nml', action=MPP_RDONLY )
101 ! read(unit,nml)
102 ! </PRE>
103 !
104 ! will result in each PE independently reading the same namelist.
105 !
106 ! Metadata identifying the file and the version of
107 ! <TT>mpp_io_mod</TT> are written to a file that is opened
108 ! <TT>MPP_WRONLY</TT> or <TT>MPP_OVERWR</TT>. If this is a
109 ! multi-file set, and an additional global attribute
110 ! <TT>NumFilesInSet</TT> is written to be used by post-processing
111 ! software.
112 !
113 ! If <TT>nohdrs=.TRUE.</TT> all calls to write attributes will
114 ! return successfully <I>without</I> performing any writes to the
115 ! file. The default is <TT>.FALSE.</TT>.
116 !
117 ! For netCDF files, headers are always written even if
118 ! <TT>nohdrs=.TRUE.</TT>
119 ! </SUBROUTINE>
120 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
121 ! !
122 ! OPENING AND CLOSING FILES: mpp_open() and mpp_close() !
123 ! !
124 ! mpp_open( unit, file, action, form, access, threading, & !
125 ! fileset, iospec, nohdrs, recl, pelist ) !
126 ! integer, intent(out) :: unit !
127 ! character(len=*), intent(in) :: file !
128 ! integer, intent(in), optional :: action, form, access, threading, !
129 ! fileset, recl !
130 ! character(len=*), intent(in), optional :: iospec !
131 ! logical, intent(in), optional :: nohdrs !
132 ! integer, optional, intent(in) :: pelist(:) !default ALL !
133 ! !
134 ! unit is intent(OUT): always _returned_by_ mpp_open() !
135 ! file is the filename: REQUIRED !
136 ! we append .nc to filename if it is a netCDF file !
137 ! we append .<pppp> to filename if fileset is private (pppp is PE number) !
138 ! iospec is a deprecated option !
139 ! if nohdrs is .TRUE. headers are not written on non-netCDF writes. !
140 ! nohdrs has no effect when action=MPP_RDONLY|MPP_APPEND !
141 ! or when form=MPP_NETCDF !
142 ! FLAGS: !
143 ! action is one of MPP_RDONLY, MPP_APPEND or MPP_WRONLY !
144 ! form is one of MPP_ASCII: formatted read/write !
145 ! MPP_NATIVE: unformatted read/write, no conversion !
146 ! MPP_IEEE32: unformatted read/write, conversion to IEEE32 !
147 ! MPP_NETCDF: unformatted read/write, conversion to netCDF !
148 ! access is one of MPP_SEQUENTIAL or MPP_DIRECT (ignored for netCDF) !
149 ! RECL argument is REQUIRED for direct access IO !
150 ! threading is one of MPP_SINGLE or MPP_MULTI !
151 ! single-threaded IO in a multi-PE run is done by PE0 !
152 ! fileset is one of MPP_MULTI and MPP_SINGLE !
153 ! fileset is only used for multi-threaded I/O !
154 ! if all I/O PEs in <pelist> use a single fileset, !
155 ! they write to the same file !
156 ! if all I/O PEs in <pelist> use a multi fileset, !
157 ! they each write an independent file !
158 ! recl is the record length in bytes !
159 ! pelist is the list of I/O PEs (currently ALL) !
160 ! !
161 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
162  subroutine mpp_open( unit, file, action, form, access, threading, &
163  fileset, iospec, nohdrs, recl, &
164  iostat, is_root_pe, domain, &
165 !----------
166 !ug support
167  domain_ug)
168 !----------
169  integer, intent(out) :: unit
170  character(len=*), intent(in) :: file
171  integer, intent(in), optional :: action, form, access
172  integer, intent(in), optional :: threading, fileset, recl
173  character(len=*), intent(in), optional :: iospec
174  logical, intent(in), optional :: nohdrs
175  integer, intent(out), optional :: iostat
176  logical, intent(in), optional :: is_root_pe
177  type(domain2d), intent(in), optional :: domain
178 !----------
179 !ug support
180  type(domainUG),target,intent(in),optional :: domain_ug
181 !----------
182  character(len=16) :: act, acc, for, pos
183  character(len=128) :: mesg
184  character(len=256) :: text2
185  integer :: action_flag, form_flag, access_flag, threading_flag, fileset_flag, length
186  integer :: nfiles, tile_id(1), io_layout(2)
187  logical :: exists, on_root_pe, dist_file
188  logical :: write_on_this_pe, read_on_this_pe, io_domain_exist
189  integer :: ios, nc_pos !position of .nc in file name
190  type(axistype) :: unlim !used by netCDF with mpp_append
191 
192 !----------
193 !ug support
194  type(domain2d),pointer :: io_domain
195  type(domainUG),pointer :: io_domain_ug
196  integer(i4_kind) :: io_layout_ug
197  integer(i4_kind) :: tile_id_ug
198 !----------
199  integer*8 :: lenp
200  integer :: comm
201  integer :: info, ierror
202  integer,dimension(:), allocatable :: glist(:)
203  integer ::lena, lenb
204  character(len=12) ::ncblk
205  character(len=128) ::nc_name
206  integer ::f_size, f_stat
207  integer ::fsize, inital = 0
208  character(len=128) :: f_test
209 
210 !----------
211 !ug support
212  !Only allow one type of mpp domain.
213  if (present(domain) .and. present(domain_ug)) then
214  call mpp_error(fatal, &
215  "mpp_open: domain and domain_ug cannot both be" &
216  //" present in the same mpp_open call.")
217  endif
218 
219  !Null initialize the unstructured I/O domain pointer.
220  io_domain => null()
221  io_domain_ug => null()
222 !----------
223 
224  call mpp_clock_begin(mpp_open_clock)
225  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_OPEN: must first call mpp_io_init.' )
226  on_root_pe = mpp_pe() == mpp_root_pe()
227  if(present(is_root_pe)) on_root_pe = is_root_pe
228 
229  dist_file = .false.
230 !set flags
231  action_flag = mpp_wronly !default
232  if( PRESENT(action) )action_flag = action
233  form_flag = mpp_ascii
234  if( PRESENT(form) )form_flag = form
235 #ifndef use_netCDF
236  if( form_flag.EQ.mpp_netcdf ) &
237  call mpp_error( fatal, &
238  & 'MPP_OPEN: To open a file with form=MPP_NETCDF, you must compile mpp_io with -Duse_netCDF.')
239 #endif
240  access_flag = mpp_sequential
241  if( PRESENT(access) )access_flag = access
242  threading_flag = mpp_single
243  if( npes.GT.1 .AND. PRESENT(threading) )threading_flag = threading
244  fileset_flag = mpp_multi
245  if( PRESENT(fileset) )fileset_flag = fileset
246  if( threading_flag.EQ.mpp_single )fileset_flag = mpp_single
247 
248 !-- iospec presence warning
249  if( PRESENT(iospec) ) &
250  & call mpp_error( note, 'MPP_OPEN: iospec option has been deprecated and will be removed at some future date')
251 
252 
253  io_domain_exist = .false.
254  if( PRESENT(domain) ) then
255  io_domain => mpp_get_io_domain(domain)
256  if(associated(io_domain)) io_domain_exist = .true.
257 
258 !----------
259 !ug support
260  elseif (present(domain_ug)) then
261  io_domain_ug => mpp_get_ug_io_domain(domain_ug)
262  io_domain_exist = .true.
263 !----------
264 
265  endif
266 
267  write_on_this_pe = .true.
268  read_on_this_pe = .true.
269  if( threading_flag.EQ.mpp_single .AND. .NOT.on_root_pe ) then
270  write_on_this_pe = .false.
271  read_on_this_pe = .false.
272  endif
273  if(form_flag == mpp_netcdf .AND. action_flag .NE. mpp_rdonly) then
274  if(fileset_flag .EQ.mpp_single .AND. threading_flag.EQ.mpp_multi) then
275  call mpp_error(fatal, "mpp_io_connect.inc(mpp_open): multiple thread and single "// &
276  "file writing/appending is not supported for netCDF file")
277  endif
278  if( fileset_flag.EQ.mpp_single .AND. .NOT.on_root_pe ) then
279  write_on_this_pe = .false.
280  read_on_this_pe = .false.
281  endif
282  endif
283 
284  if( io_domain_exist) then
285 
286 !----------
287 !ug support
288  if (associated(io_domain)) then
289  ! in this case, only write out from the root_pe of io_domain.
290  write_on_this_pe = mpp_domain_is_tile_root_pe(io_domain)
291  elseif (associated(io_domain_ug)) then
292  write_on_this_pe = mpp_domain_ug_is_tile_root_pe(io_domain_ug)
293  endif
294 !----------
295 
296  endif
297  if( action_flag == mpp_rdonly) write_on_this_pe = .false.
298  !get a unit number
299  if( .NOT. write_on_this_pe .AND. action_flag.NE.mpp_rdonly .AND. .NOT. io_domain_exist)then
300  unit = nullunit !PEs not participating in IO from this mpp_open() will return this value for unit
301  call mpp_clock_end(mpp_open_clock)
302  return
303  end if
304  if( form_flag.EQ.mpp_netcdf )then
305  do unit = maxunits+1,2*maxunits
306  if( .NOT.mpp_file(unit)%valid )exit
307  end do
308  if( unit.GT.2*maxunits ) then
309  write(mesg,*) 'all the units between ',maxunits+1,' and ',2*maxunits,' are used'
310  call mpp_error( fatal, 'MPP_OPEN: too many open netCDF files.'//trim(mesg) )
311  endif
312  else
313  do unit = unit_begin, unit_end
314  inquire( unit,opened=mpp_file(unit)%opened )
315  if( .NOT.mpp_file(unit)%opened )exit
316  end do
317  if( unit.GT.unit_end ) then
318  write(mesg,*) 'all the units between ',unit_begin,' and ',unit_end,' are used'
319  call mpp_error( fatal, 'MPP_OPEN: no available units.'//trim(mesg) )
320  endif
321  end if
322  mpp_file(unit)%valid = .true.
323  mpp_file(unit)%write_on_this_pe = write_on_this_pe
324  mpp_file(unit)%read_on_this_pe = read_on_this_pe
325  mpp_file(unit)%io_domain_exist = io_domain_exist
326  if( PRESENT(domain) ) then
327  allocate(mpp_file(unit)%domain)
328  mpp_file(unit)%domain = domain
329 
330 !----------
331 !ug support
332  elseif (present(domain_ug)) then
333  mpp_file(unit)%domain_ug => domain_ug
334 !----------
335 
336  endif
337 
338 !get a filename
339  nc_pos = index(file,'.nc.')
340  dist_file = nc_pos>0 ! this is a distributed file ending with filename.nc.0???
341  text = file
342  length = len_trim(file)
343  if(form_flag.EQ.mpp_netcdf.AND. file(length-2:length) /= '.nc' .AND. .NOT.dist_file) &
344  text = trim(file)//'.nc'
345 
346 !----------
347 !ug support
348 !HELP: Is there any way to retrieve the I/O layout for an unstructured grid?
349 ! I could not find a way, so I added it into mpp_domains.
350  if (present(domain)) then
351  io_layout = mpp_get_io_domain_layout(domain)
352  elseif (present(domain_ug)) then
353  io_layout_ug = mpp_get_io_domain_ug_layout(domain_ug)
354  endif
355 !----------
356 
357  if( io_domain_exist) then
358 
359 !----------
360 !ug support
361  if (present(domain) .and. io_layout(1)*io_layout(2) .gt. 1) then
362  fileset_flag = mpp_multi
363  threading_flag = mpp_multi
364  tile_id = mpp_get_tile_id(io_domain)
365  text2 = trim(text)
366  if (tile_id(1) .ge. 10000) then
367  call mpp_error(fatal, &
368  "mpp_open: tile_id should be less than" &
369  //" 10000 when io_domain exist")
370  endif
371  write(text,'(a,i4.4)') trim(text)//'.',tile_id(1)
372  if (action_flag .eq. mpp_rdonly) then
373  inquire(file=trim(text),exist=exists)
374  if (.not. exists) then
375  write(text2,'(a,i6.6)') trim(text2)//'.',tile_id(1)
376  inquire(file=trim(text2),exist=exists)
377  if (.not.exists) then
378  call mpp_error(fatal, &
379  "mpp_open: neither "// &
380  trim(text)//" nor "// &
381  trim(text2)//" exist and io" &
382  //" domain exist.")
383  endif
384  text = trim(text2)
385  endif
386  endif
387  elseif (present(domain_ug) .and. io_layout_ug .gt. 1) then
388  fileset_flag = mpp_multi
389  threading_flag = mpp_multi
390  tile_id_ug = mpp_get_ug_domain_tile_id(io_domain_ug)
391  text2 = trim(text)
392  if (tile_id_ug .ge. 10000) then
393  call mpp_error(fatal, &
394  "mpp_open: tile_id should be less than" &
395  //" 10000 when io_domain exist")
396  endif
397  write(text,'(a,i4.4)') trim(text)//'.',tile_id_ug
398  if (action_flag .eq. mpp_rdonly) then
399  inquire(file=trim(text),exist=exists)
400  if (.not. exists) then
401  write(text2,'(a,i6.6)') trim(text2)//'.',tile_id_ug
402  inquire(file=trim(text2),exist=exists)
403  if (.not.exists) then
404  call mpp_error(fatal, &
405  "mpp_open: neither "// &
406  trim(text)//" nor "// &
407  trim(text2)//" exist and io" &
408  //" domain exist.")
409  endif
410  text = trim(text2)
411  endif
412  endif
413  else
414  fileset_flag = mpp_single
415  threading_flag = mpp_single
416  endif
417 !----------
418 
419  else if( fileset_flag.EQ.mpp_multi ) then
420  if(mpp_npes() > 10000) then
421  write( text,'(a,i6.6)' )trim(text)//'.', pe-mpp_root_pe()
422  else
423  write( text,'(a,i4.4)' )trim(text)//'.', pe-mpp_root_pe()
424  endif
425  endif
426  mpp_file(unit)%name = text
427  if(verbose) print '(a,2i6,x,a,5i5)','MPP_OPEN: PE, unit, filename, action, format, access, threading, fileset=',&
428  & pe, unit, trim(mpp_file(unit)%name), action_flag, form_flag, access_flag, threading_flag, fileset_flag
429 
430 !action: read, write, overwrite, append: act and pos are ignored by netCDF
431  if( action_flag.EQ.mpp_rdonly )then
432  act = 'READ'
433  pos = 'REWIND'
434  else if( action_flag.EQ.mpp_wronly .OR. action_flag.EQ.mpp_overwr )then
435  act = 'WRITE'
436  pos = 'REWIND'
437  else if( action_flag.EQ.mpp_append )then
438  act = 'WRITE'
439  pos = 'APPEND'
440  else
441  call mpp_error( fatal, 'MPP_OPEN: action must be one of MPP_WRONLY, MPP_APPEND or MPP_RDONLY.' )
442  end if
443 
444  mpp_file(unit)%threading = threading_flag
445  mpp_file(unit)%fileset = fileset_flag
446 
447  if( .NOT. write_on_this_pe .AND. action_flag.NE.mpp_rdonly ) then
448  call mpp_clock_end(mpp_open_clock)
449  return
450  endif
451 
452 !access: sequential or direct: ignored by netCDF
453  if( form_flag.NE.mpp_netcdf )then
454  if( access_flag.EQ.mpp_sequential )then
455  acc = 'SEQUENTIAL'
456  else if( access_flag.EQ.mpp_direct )then
457  acc = 'DIRECT'
458  if( form_flag.EQ.mpp_ascii )call mpp_error( fatal, &
459  & 'MPP_OPEN: formatted direct access I/O is prohibited.' )
460  if( .NOT.PRESENT(recl) ) &
461  call mpp_error( fatal, &
462  & 'MPP_OPEN: recl (record length in bytes) must be specified with access=MPP_DIRECT.')
463  mpp_file(unit)%record = 1
464  records_per_pe = 1 !each PE writes 1 record per mpp_write
465  else
466  call mpp_error( fatal, 'MPP_OPEN: access must be one of MPP_SEQUENTIAL or MPP_DIRECT.' )
467  end if
468  end if
469 
470 !threading: SINGLE or MULTI
471  if( threading_flag.EQ.mpp_multi )then
472 !fileset: MULTI or SINGLE (only for multi-threaded I/O
473  if( fileset_flag.EQ.mpp_single )then
474  if( form_flag.EQ.mpp_netcdf .AND. act.EQ.'WRITE' ) &
475  call mpp_error( fatal, &
476  & 'MPP_OPEN: netCDF currently does not support single-file multi-threaded output.' )
477 
478  else if( fileset_flag.NE.mpp_multi )then
479  call mpp_error( fatal, 'MPP_OPEN: fileset must be one of MPP_MULTI or MPP_SINGLE.' )
480  end if
481  else if( threading_flag.NE.mpp_single )then
482  call mpp_error( fatal, 'MPP_OPEN: threading must be one of MPP_SINGLE or MPP_MULTI.' )
483  end if
484 
485 !open the file as specified above for various formats
486  if( form_flag.EQ.mpp_netcdf )then
487 #ifdef PAR_ACCESS
488  !adding some items for netcdf-4.... --fmi
489  if( .NOT.PRESENT(pelist)) then
490  allocate (glist(0:npes-1))
491  call mpp_get_current_pelist(glist, name, comm)
492  end if
493 
494  !create info parts...
495  call mpi_info_create(info, ierror)
496 
497  !F2003 convention
498  !call get_enviornment_variable('NC_BLKSZ', ncblk)
499  call getenv( 'NC_BLKSZ', ncblk)
500  ncblk = trim(ncblk)
501 
502 
503  if (ncblk /= "") then
504 
505  call mpi_info_set(info, "cb_buffer_size", ncblk, ierror)
506  call mpi_info_set(info, "ind_rd_buffer_size", ncblk, ierror)
507  call mpi_info_set(info, "ind_wr_buffer_size", ncblk, ierror)
508 
509  else
510  call mpi_info_set(info, "ind_rd_buffer_size", "16777216", ierror)
511  call mpi_info_set(info, "ind_wr_buffer_size", "16777216", ierror)
512  endif
513 
514 #else
515 !added by fmi to read NC_BLKSZ and NC_BLKSZ_filename...
516 
517 
518  !get regular nc_blksz...
519  !build env var for check
520  !write (*,*) 'hello', trim(mpp_file(unit)%name)
521  nc_name = 'NC_BLKSZ_'//trim(mpp_file(unit)%name)
522  !write (*,*) 'nc_name: ', nc_name, ' bcblk: ', ncblk
523 
524 
525 
526  !make the call.....
527  !f2003 replaces GETENV with get_enviornment_variable so the guts are here if we need to switch
528  !call get_enviornment_variable(trim(nc_name),ncblk )
529  call getenv( trim(nc_name),ncblk )
530 
531  !might not be there...use the general setting
532 
533  if (ncblk .EQ. '') then
534  !call get_enviornment_variable( 'NC_BLKSZ', ncblk)
535  call getenv( 'NC_BLKSZ', ncblk)
536 
537 
538  endif
539 
540  !if no general setting then use default
541  if (ncblk .EQ. '') then
542  ncblk = '64k' !change for platform...perhaps we should set an ifdef for this....
543  endif
544 
545  !set or convert the chunksize
546 
547  call file_size(ncblk, mpp_file(unit)%name, fsize)
548  !write (*,*) 'this is fsize after: ', fsize
549 
550 
551  if(debug) write(*,*) 'Blocksize for ', trim(mpp_file(unit)%name),' is ', fsize
552  !ends addition from fmi - oct.22.2008
553 #endif
554 
555 #ifdef use_netCDF
556 #ifdef use_netCDF3
557  if( action_flag.EQ.mpp_wronly )then
558  if(debug) write(*,*) 'Blocksize for create of ', trim(mpp_file(unit)%name),' is ', fsize
559  error = nf__create( trim(mpp_file(unit)%name), nf_noclobber, inital, fsize, mpp_file(unit)%ncid )
560  call netcdf_err( error, mpp_file(unit) )
561  if( verbose )print '(a,i6,i16)', 'MPP_OPEN: new netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
562  else if( action_flag.EQ.mpp_overwr )then
563  if(debug) write(*,*) 'Blocksize for create of ', trim(mpp_file(unit)%name),' is ', fsize
564  error = nf__create( trim(mpp_file(unit)%name),nf_clobber, inital, fsize, mpp_file(unit)%ncid )
565  call netcdf_err( error, mpp_file(unit) )
566  action_flag = mpp_wronly !after setting clobber, there is no further distinction btwn MPP_WRONLY
567  !! and MPP_OVERWR
568  if( verbose )print '(a,i6,i16)', 'MPP_OPEN: overwrite netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
569  else if( action_flag.EQ.mpp_append )then
570  inquire(file=trim(mpp_file(unit)%name),exist=exists)
571  if (.NOT.exists) call mpp_error(fatal,'MPP_OPEN:'&
572  &//trim(mpp_file(unit)%name)//' does not exist.')
573  error=nf__open(trim(mpp_file(unit)%name),nf_write,fsize,mpp_file(unit)%ncid)
574  call netcdf_err(error, mpp_file(unit))
575 !get the current time level of the file: writes to this file will be at next time level
576  error = nf_inq_unlimdim( mpp_file(unit)%ncid, unlim%did )
577  if( error.EQ.nf_noerr )then
578  error = nf_inq_dim( mpp_file(unit)%ncid, unlim%did, unlim%name, mpp_file(unit)%time_level )
579  call netcdf_err( error, mpp_file(unit) )
580  error = nf_inq_varid( mpp_file(unit)%ncid, unlim%name, mpp_file(unit)%id )
581  call netcdf_err( error, mpp_file(unit), unlim )
582  end if
583  if( verbose )print '(a,i6,i16,i4)', 'MPP_OPEN: append to existing netCDF file: pe, ncid, time_axis_id=',&
584  pe, mpp_file(unit)%ncid, mpp_file(unit)%id
585  mpp_file(unit)%format=form_flag ! need this for mpp_read
586  call mpp_read_meta(unit, read_time=.false.)
587  else if( action_flag.EQ.mpp_rdonly )then
588  inquire(file=trim(mpp_file(unit)%name),exist=exists)
589  if (.NOT.exists) call mpp_error(fatal,'MPP_OPEN:'&
590  &//trim(mpp_file(unit)%name)//' does not exist.')
591  error=nf__open(trim(mpp_file(unit)%name),nf_nowrite,fsize,mpp_file(unit)%ncid)
592  call netcdf_err(error, mpp_file(unit))
593  if( verbose )print '(a,i6,i16,i4)', 'MPP_OPEN: opening existing netCDF file: pe, ncid, time_axis_id=',&
594  pe, mpp_file(unit)%ncid, mpp_file(unit)%id
595  mpp_file(unit)%format=form_flag ! need this for mpp_read
596  call mpp_read_meta(unit, read_time=.true.)
597  end if
598  mpp_file(unit)%opened = .true.
599 #elif use_LARGEFILE
600  if( action_flag.EQ.mpp_wronly )then
601  if(debug) write(*,*) 'Blocksize for create of ', trim(mpp_file(unit)%name),' is ', fsize
602  error = nf__create( trim(mpp_file(unit)%name),ior(nf_64bit_offset,nf_noclobber),inital,fsize, &
603  & mpp_file(unit)%ncid )
604  call netcdf_err( error, mpp_file(unit) )
605  if( verbose )print '(a,i6,i16)', 'MPP_OPEN: new netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
606  else if( action_flag.EQ.mpp_overwr )then
607  if(debug) write(*,*) 'Blocksize for create of ', trim(mpp_file(unit)%name),' is ', fsize
608  error = nf__create( trim(mpp_file(unit)%name),ior(nf_64bit_offset,nf_clobber), inital, fsize, &
609  & mpp_file(unit)%ncid )
610  call netcdf_err( error, mpp_file(unit) )
611  action_flag = mpp_wronly !after setting clobber, there is no further distinction btwn MPP_WRONLY
612  !! and MPP_OVERWR
613  if( verbose )print '(a,i6,i16)', 'MPP_OPEN: overwrite netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
614  else if( action_flag.EQ.mpp_append )then
615  inquire(file=trim(mpp_file(unit)%name),exist=exists)
616  if (.NOT.exists) call mpp_error(fatal,'MPP_OPEN:'&
617  &//trim(mpp_file(unit)%name)//' does not exist.')
618  error=nf__open(trim(mpp_file(unit)%name),nf_write,fsize,mpp_file(unit)%ncid)
619  call netcdf_err(error, mpp_file(unit))
620 !get the current time level of the file: writes to this file will be at next time level
621  error = nf_inq_unlimdim( mpp_file(unit)%ncid, unlim%did )
622  if( error.EQ.nf_noerr )then
623  error = nf_inq_dim( mpp_file(unit)%ncid, unlim%did, unlim%name, mpp_file(unit)%time_level )
624  call netcdf_err( error, mpp_file(unit) )
625  error = nf_inq_varid( mpp_file(unit)%ncid, unlim%name, mpp_file(unit)%id )
626  call netcdf_err( error, mpp_file(unit), unlim )
627  end if
628  if( verbose )print '(a,i6,i16,i4)', 'MPP_OPEN: append to existing netCDF file: pe, ncid, time_axis_id=',&
629  pe, mpp_file(unit)%ncid, mpp_file(unit)%id
630  mpp_file(unit)%format=form_flag ! need this for mpp_read
631  call mpp_read_meta(unit, read_time=.false.)
632  else if( action_flag.EQ.mpp_rdonly )then
633  inquire(file=trim(mpp_file(unit)%name),exist=exists)
634  if (.NOT.exists) call mpp_error(fatal,'MPP_OPEN:'&
635  &//trim(mpp_file(unit)%name)//' does not exist.')
636  error=nf__open(trim(mpp_file(unit)%name),nf_nowrite,fsize,mpp_file(unit)%ncid)
637  call netcdf_err(error, mpp_file(unit))
638  if( verbose )print '(a,i6,i16,i4)', 'MPP_OPEN: opening existing netCDF file: pe, ncid, time_axis_id=',&
639  pe, mpp_file(unit)%ncid, mpp_file(unit)%id
640  mpp_file(unit)%format=form_flag ! need this for mpp_read
641  call mpp_read_meta(unit, read_time=.true.)
642  end if
643  mpp_file(unit)%opened = .true.
644 #else
645  if( action_flag.EQ.mpp_wronly )then
646  if(debug) write(*,*) 'Blocksize for create of ', trim(mpp_file(unit)%name),' is ', fsize
647  error=nf__create( trim(mpp_file(unit)%name), ior(nf_netcdf4,nf_classic_model), inital, fsize, &
648  & mpp_file(unit)%ncid )
649  call netcdf_err( error, mpp_file(unit) )
650  if( verbose )print '(a,i6,i16)', 'MPP_OPEN: new netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
651  else if( action_flag.EQ.mpp_overwr )then
652  if(debug) write(*,*) 'Blocksize for create of ', trim(mpp_file(unit)%name),' is ', fsize
653  error=nf__create( trim(mpp_file(unit)%name), ior(nf_netcdf4,nf_classic_model), inital, fsize, &
654  & mpp_file(unit)%ncid )
655  call netcdf_err( error, mpp_file(unit) )
656  action_flag = mpp_wronly !after setting clobber, there is no further distinction btwn MPP_WRONLY
657  !! and MPP_OVERWR
658  if( verbose )print '(a,i6,i16)', 'MPP_OPEN: overwrite netCDF file: pe, ncid=', pe, mpp_file(unit)%ncid
659  else if( action_flag.EQ.mpp_append )then
660  inquire(file=trim(mpp_file(unit)%name),exist=exists)
661  if (.NOT.exists) call mpp_error(fatal,'MPP_OPEN:'&
662  &//trim(mpp_file(unit)%name)//' does not exist.')
663  error=nf__open(trim(mpp_file(unit)%name),nf_write,fsize,mpp_file(unit)%ncid)
664  call netcdf_err(error,mpp_file(unit))
665 !get the current time level of the file: writes to this file will be at next time level
666  error = nf_inq_unlimdim( mpp_file(unit)%ncid, unlim%did )
667  if( error.EQ.nf_noerr )then
668  error = nf_inq_dim( mpp_file(unit)%ncid, unlim%did, unlim%name, mpp_file(unit)%time_level )
669  call netcdf_err( error, mpp_file(unit) )
670  error = nf_inq_varid( mpp_file(unit)%ncid, unlim%name, mpp_file(unit)%id )
671  call netcdf_err( error, mpp_file(unit), unlim )
672  end if
673  if( verbose )print '(a,i6,i16,i4)', 'MPP_OPEN: append to existing netCDF file: pe, ncid, time_axis_id=',&
674  pe, mpp_file(unit)%ncid, mpp_file(unit)%id
675  mpp_file(unit)%format=form_flag ! need this for mpp_read
676  call mpp_read_meta(unit, read_time=.false.)
677  else if( action_flag.EQ.mpp_rdonly )then
678  inquire(file=trim(mpp_file(unit)%name),exist=exists)
679  if (.NOT.exists) call mpp_error(fatal,'MPP_OPEN:'&
680  &//trim(mpp_file(unit)%name)//' does not exist.')
681  error=nf__open(trim(mpp_file(unit)%name),nf_nowrite,fsize,mpp_file(unit)%ncid)
682  call netcdf_err(error,mpp_file(unit))
683  if( verbose )print '(a,i6,i16,i4)', 'MPP_OPEN: opening existing netCDF file: pe, ncid, time_axis_id=',&
684  pe, mpp_file(unit)%ncid, mpp_file(unit)%id
685  mpp_file(unit)%format=form_flag ! need this for mpp_read
686  call mpp_read_meta(unit, read_time=.true.)
687  end if
688  mpp_file(unit)%opened = .true.
689 
690 #endif
691 #endif
692  else
693 !format: ascii, native, or IEEE 32 bit
694  if( form_flag.EQ.mpp_ascii )then
695  for = 'FORMATTED'
696  else if( form_flag.EQ.mpp_ieee32 )then
697  for = 'UNFORMATTED'
698  else if( form_flag.EQ.mpp_native )then
699  for = 'UNFORMATTED'
700  else
701  call mpp_error( fatal, 'MPP_OPEN: form must be one of MPP_ASCII, MPP_NATIVE, MPP_IEEE32 or MPP_NETCDF.' )
702  end if
703  inquire( file=trim(mpp_file(unit)%name), exist=exists )
704  if( exists .AND. action_flag.EQ.mpp_wronly ) &
705  call mpp_error( warning, 'MPP_OPEN: File '//trim(mpp_file(unit)%name)//' opened WRONLY already exists!')
706  if( action_flag.EQ.mpp_overwr )action_flag = mpp_wronly
707 !perform the OPEN here
708  ios = 0
709  if( PRESENT(recl) )then
710  if( verbose )print '(2(x,a,i6),5(x,a),a,i8)', 'MPP_OPEN: PE=', pe, &
711  'unit=', unit, trim(mpp_file(unit)%name), 'attributes=', trim(acc), trim(for), trim(act), &
712  & ' RECL=', recl
713  open( unit, file=trim(mpp_file(unit)%name), access=acc, form=for, action=act, recl=recl,iostat=ios )
714  else
715  if( verbose )print '(2(x,a,i6),6(x,a))', 'MPP_OPEN: PE=', pe, &
716  'unit=', unit, trim(mpp_file(unit)%name), 'attributes=', trim(acc), trim(for), trim(pos), trim(act)
717  open( unit, file=trim(mpp_file(unit)%name), access=acc, form=for, action=act, position=pos, iostat=ios)
718  end if
719 !check if OPEN worked
720  inquire( unit,opened=mpp_file(unit)%opened )
721  if (ios/=0) then
722  if (PRESENT(iostat)) then
723  iostat=ios
724  call mpp_error( warning, 'MPP_OPEN: error in OPEN for '//trim(mpp_file(unit)%name)//'.' )
725  call mpp_clock_end(mpp_open_clock)
726  return
727  else
728  call mpp_error( fatal, 'MPP_OPEN: error in OPEN for '//trim(mpp_file(unit)%name)//'.' )
729  endif
730  endif
731  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_OPEN: error in OPEN() statement.' )
732  end if
733  mpp_file(unit)%action = action_flag
734  mpp_file(unit)%format = form_flag
735  mpp_file(unit)%access = access_flag
736  if( PRESENT(nohdrs) )mpp_file(unit)%nohdrs = nohdrs
737 
738  if( action_flag.EQ.mpp_wronly )then
739  if( form_flag.NE.mpp_netcdf .AND. access_flag.EQ.mpp_direct )call mpp_write_meta( unit, &
740  & 'record_length', ival=recl )
741 !actual file name
742  call mpp_write_meta( unit, 'filename', cval=mpp_file(unit)%name)
743 !MPP_IO package version
744 ! call mpp_write_meta( unit, 'MPP_IO_VERSION', cval=trim(version) )
745 !filecount for multifileset.
746  if( threading_flag.EQ.mpp_multi .AND. fileset_flag.EQ.mpp_multi ) then
747  if(present(domain)) then
748  nfiles = io_layout(1)*io_layout(2)
749  npes = mpp_get_domain_npes(domain)
750  if(nfiles > npes) nfiles = npes
751 
752 !----------
753 !ug support
754  elseif (present(domain_ug)) then
755  nfiles = io_layout_ug
756  npes = mpp_get_ug_domain_npes(domain_ug)
757  if (nfiles .gt. npes) then
758  nfiles = npes
759  endif
760 !----------
761 
762  else
763  nfiles = mpp_npes()
764  endif
765  call mpp_write_meta( unit, 'NumFilesInSet', ival=nfiles)
766  end if
767  end if
768 
769 !----------
770 !ug support
771  !<Nullify local pointers.
772  if (associated(io_domain)) then
773  io_domain => null()
774  endif
775  if (associated(io_domain_ug)) then
776  io_domain_ug => null()
777  endif
778 !----------
779 
780  call mpp_clock_end(mpp_open_clock)
781  return
782  end subroutine mpp_open
783 
784 
785 ! <SUBROUTINE NAME="mpp_close">
786 ! <OVERVIEW>
787 ! Close an open file.
788 ! </OVERVIEW>
789 ! <DESCRIPTION>
790 ! Closes the open file on <TT>unit</TT>. Clears the
791 ! <TT>type(filetype)</TT> object <TT>mpp_file(unit)</TT> making it
792 ! available for reuse.
793 ! </DESCRIPTION>
794 ! <TEMPLATE>
795 ! call mpp_close( unit, action )
796 ! </TEMPLATE>
797 ! <IN NAME="unit" TYPE="integer"> </IN>
798 ! <IN NAME="action" TYPE="integer"> </IN>
799 ! </SUBROUTINE>
800 
801  subroutine mpp_close( unit, action )
802  integer, intent(in) :: unit
803  integer, intent(in), optional :: action
804  character(len=8) :: status
805  logical :: collect
806  integer :: i, j
807 
808  call mpp_clock_begin(mpp_close_clock)
809  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_CLOSE: must first call mpp_io_init.' )
810  if( unit.EQ.nullunit .OR. unit .EQ. stderr() ) then
811  call mpp_clock_end(mpp_close_clock)
812  return !nothing was actually opened on this unit
813  endif
814 !action on close
815  status = 'KEEP'
816 !collect is supposed to launch the post-processing collector tool for multi-fileset
817  collect = .false.
818  if( PRESENT(action) )then
819  if( action.EQ.mpp_delete )then
820  if( pe.EQ.mpp_root_pe() .OR. mpp_file(unit)%fileset.EQ.mpp_multi )status = 'DELETE'
821  else if( action.EQ.mpp_collect )then
822  collect = .false. !should be TRUE but this is not yet ready
823  call mpp_error( warning, 'MPP_CLOSE: the COLLECT operation is not yet implemented.' )
824  else
825  call mpp_error( fatal, 'MPP_CLOSE: action must be one of MPP_DELETE or MPP_COLLECT.' )
826  end if
827  end if
828  if( mpp_file(unit)%fileset.NE.mpp_multi )collect = .false.
829  if( mpp_file(unit)%opened) then
830  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
831 #ifdef use_netCDF
832  error = nf_close(mpp_file(unit)%ncid); call netcdf_err( error, mpp_file(unit) )
833 #endif
834  else
835  close(unit,status=status)
836  end if
837  endif
838  if ( associated(mpp_file(unit)%Axis) ) then
839  do i=1, mpp_file(unit)%ndim
840  if ( associated(mpp_file(unit)%Axis(i)%data) ) then
841  deallocate(mpp_file(unit)%Axis(i)%data)
842  nullify(mpp_file(unit)%Axis(i)%data)
843  end if
844 
845  if ( associated(mpp_file(unit)%Axis(i)%Att) ) then
846  do j=1, mpp_file(unit)%Axis(i)%natt
847  if ( associated(mpp_file(unit)%Axis(i)%Att(j)%fatt) ) then
848  deallocate(mpp_file(unit)%Axis(i)%Att(j)%fatt)
849  nullify(mpp_file(unit)%Axis(i)%Att(j)%fatt)
850  end if
851  end do
852  deallocate(mpp_file(unit)%Axis(i)%Att)
853  nullify(mpp_file(unit)%Axis(i)%Att)
854  end if
855  end do
856  deallocate(mpp_file(unit)%Axis)
857  nullify(mpp_file(unit)%Axis)
858  end if
859 
860  if ( associated(mpp_file(unit)%var) ) then
861  do i=1, mpp_file(unit)%nvar
862  if ( associated(mpp_file(unit)%var(i)%Axes) ) then
863  ! Do not need to deallocate/nullify child pointers, handled above with mpp_file(unit)%Axis(:)%*
864  deallocate(mpp_file(unit)%var(i)%Axes)
865  nullify(mpp_file(unit)%var(i)%Axes)
866  end if
867  if ( associated(mpp_file(unit)%var(i)%size) ) then
868  deallocate(mpp_file(unit)%var(i)%size)
869  nullify(mpp_file(unit)%var(i)%size)
870  end if
871  if ( associated(mpp_file(unit)%var(i)%Att) ) then
872  do j=1, mpp_file(unit)%var(i)%natt
873  if ( associated(mpp_file(unit)%var(i)%Att(j)%fatt) ) then
874  deallocate(mpp_file(unit)%var(i)%Att(j)%fatt)
875  nullify(mpp_file(unit)%var(i)%Att(j)%fatt)
876  end if
877  end do
878  deallocate(mpp_file(unit)%var(i)%Att)
879  nullify(mpp_file(unit)%var(i)%Att)
880  end if
881  end do
882  deallocate(mpp_file(unit)%var)
883  nullify(mpp_file(unit)%var)
884  end if
885 
886  if ( associated(mpp_file(unit)%att) ) then
887  do i=1, mpp_file(unit)%natt
888  if ( associated(mpp_file(unit)%att(i)%fatt) ) then
889  deallocate(mpp_file(unit)%att(i)%fatt)
890  nullify(mpp_file(unit)%att(i)%fatt)
891  end if
892  end do
893  deallocate(mpp_file(unit)%att)
894  nullify(mpp_file(unit)%att)
895  end if
896 
897  if ( associated(mpp_file(unit)%time_values) ) then
898  deallocate(mpp_file(unit)%time_values)
899  nullify(mpp_file(unit)%time_values)
900  end if
901 
902  mpp_file(unit)%name = ' '
903  mpp_file(unit)%action = -1
904  mpp_file(unit)%format = -1
905  mpp_file(unit)%access = -1
906  mpp_file(unit)%threading = -1
907  mpp_file(unit)%fileset = -1
908  mpp_file(unit)%record = -1
909  mpp_file(unit)%ncid = -1
910  mpp_file(unit)%opened = .false.
911  mpp_file(unit)%initialized = .false.
912  mpp_file(unit)%id = -1
913  mpp_file(unit)%ndim = -1
914  mpp_file(unit)%nvar = -1
915  mpp_file(unit)%time_level = 0
916  mpp_file(unit)%time = nulltime
917  mpp_file(unit)%valid = .false.
918  mpp_file(unit)%io_domain_exist = .false.
919  mpp_file(unit)%write_on_this_pe = .false.
920 
921 !----------
922 !ug support
923  !<There was a memory leak here. The mpp_file(unit)%domain was set
924  !!to point to null without begin deallocated first (it is allocated
925  !!in mpp_open above).
926  if (associated(mpp_file(unit)%domain)) then
927  deallocate(mpp_file(unit)%domain)
928  mpp_file(unit)%domain => null()
929  elseif (associated(mpp_file(unit)%domain_ug)) then
930  mpp_file(unit)%domain_ug => null()
931  endif
932 !----------
933 
934  call mpp_clock_end(mpp_close_clock)
935  return
936  end subroutine mpp_close
937 
938 
939  subroutine file_size(fsize, fname, size)
940 
941  character(len=12), intent(in) ::fsize
942  character(len=128) ::filesize
943  character(len=128), intent(in),optional :: fname
944  character(len=128) :: filename
945  integer*4 :: fstat(13)
946  integer :: length
947  character(len=16) ::number
948  integer,intent(OUT) :: size
949  integer*4 ::ierr, stat
950  integer :: tend
951  logical :: there
952 
953  size = 0
954 
955  filesize = fsize
956 
957  length = len(trim(fsize))
958  tend = length - 1
959 
960 
961 
962  if (filesize .EQ. 'file') then
963  filename = trim(fname)
964  INQUIRE( file=filename, exist=there )
965  if (there) then
966  ierr = stat(filename, fstat)
967  if (ierr .EQ. 0) then
968  size = fstat(8)
969  else
970  size = 0
971  end if
972  end if
973  elseif((filesize(length:length)>='a'.AND.fsize(length:length)<='z').OR.(filesize(length:length)>='A' &
974  .AND.fsize(length:length)<='Z'))then
975  number = filesize(1:tend)
976  READ(number, fmt='(I9)') size
977  if (filesize(length:length) >= 'a' .AND. fsize(length:length) <= 'z') then
978  filesize(length:length) = achar( ichar(filesize(length:length)) - 32)
979  end if
980  if ( filesize(length:length) .EQ. 'K') then
981  size = size*1024
982  elseif ( filesize(length:length) .EQ. 'M') then
983  size = (size*1024)*1024
984  elseif ( filesize(length:length) .EQ. 'G') then
985  size = (((size*1024)*1024)*1024)
986  else
987  size = size
988  end if
989  else
990  READ(filesize, fmt='(I9)') size
991  endif
992 
993  if (size .eq. 0) then
994  size = 65536
995  endif
996 
997 return
998 
999  end subroutine file_size
1000 !> @}
mpp_get_domain_npes
integer function mpp_get_domain_npes(domain)
Set user stack size.
Definition: mpp_domains_util.inc:1459
mpp_get_tile_id
integer function, dimension(size(domain%tile_id(:))) mpp_get_tile_id(domain)
Returns the tile_id on current pe.
Definition: mpp_domains_util.inc:1131
mpp_get_io_domain_layout
integer function, dimension(2) mpp_get_io_domain_layout(domain)
Set user stack size.
Definition: mpp_domains_util.inc:1488
mpp_get_io_domain
type(domain2d) function, pointer mpp_get_io_domain(domain)
Set user stack size.
Definition: mpp_domains_util.inc:712
mpp_domain_is_tile_root_pe
logical function mpp_domain_is_tile_root_pe(domain)
Returns if current pe is the root pe of the tile, if number of tiles on current pe is greater than 1,...
Definition: mpp_domains_util.inc:1183
stderr
integer function stderr()
This function returns the current standard fortran unit numbers for error messages.
Definition: mpp_util.inc:51
mpp_npes
integer function mpp_npes()
Returns processor count for current pelist.
Definition: mpp_util.inc:421
mpp_pe
integer function mpp_pe()
Returns processor ID.
Definition: mpp_util.inc:407