FMS 2025.01-dev
Flexible Modeling System
Loading...
Searching...
No Matches
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
997return
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