FMS  2024.03
Flexible Modeling System
mpp_io_write.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 
22 !> @file
23 !> @brief This series of routines is used to describe the contents of the file
24 !! being written on <unit>.
25 
26 !> @addtogroup mpp_io_mod
27 !> @{
28 
29 !> Writes a global metadata attribute to unit <unit>
30 !! attribute <name> can be an real, integer or character
31 !! one and only one of rval, ival, and cval should be present
32 !! the first found will be used
33 !! for a non-netCDF file, it is encoded into a string "GLOBAL <name> <val>"
34  subroutine mpp_write_meta_global( unit, name, rval, ival, cval, pack)
35  integer, intent(in) :: unit
36  character(len=*), intent(in) :: name
37  real, intent(in), optional :: rval(:)
38  integer, intent(in), optional :: ival(:)
39  character(len=*), intent(in), optional :: cval
40  integer, intent(in), optional :: pack
41 
42 ! call mpp_clock_begin(mpp_write_clock)
43  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META: must first call mpp_io_init.' )
44  if( .NOT. mpp_file(unit)%write_on_this_pe) then
45 ! call mpp_clock_end(mpp_write_clock)
46  return
47  endif
48  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
49  if( mpp_file(unit)%initialized ) &
50  call mpp_error( fatal, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
51 
52  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
53 #ifdef use_netCDF
54  call write_attribute_netcdf( unit, nf_global, name, rval, ival, cval, pack )
55 #endif
56  else
57  call write_attribute( unit, 'GLOBAL '//trim(name), rval, ival, cval, pack )
58  end if
59 ! call mpp_clock_end(mpp_write_clock)
60 
61  return
62  end subroutine mpp_write_meta_global
63 
64 !versions of above to support <rval> and <ival> as scalars (because of f90 strict rank matching)
65  subroutine mpp_write_meta_global_scalar_r( unit, name, rval, pack )
66  integer, intent(in) :: unit
67  character(len=*), intent(in) :: name
68  real, intent(in) :: rval
69  integer, intent(in), optional :: pack
70 
71  call mpp_write_meta_global( unit, name, rval=(/rval/), pack=pack )
72  return
73  end subroutine mpp_write_meta_global_scalar_r
74 
75  subroutine mpp_write_meta_global_scalar_i( unit, name, ival, pack )
76  integer, intent(in) :: unit
77  character(len=*), intent(in) :: name
78  integer, intent(in) :: ival
79  integer, intent(in), optional :: pack
80 
81  call mpp_write_meta_global( unit, name, ival=(/ival/), pack=pack )
82  return
83  end subroutine mpp_write_meta_global_scalar_i
84 
85  subroutine mpp_write_meta_var( unit, id, name, rval, ival, cval, pack)
86 !writes a metadata attribute for variable <id> to unit <unit>
87 !attribute <name> can be an real, integer or character
88 !one and only one of rval, ival, and cval should be present
89 !the first found will be used
90 !for a non-netCDF file, it is encoded into a string "<id> <name> <val>"
91  integer, intent(in) :: unit, id
92  character(len=*), intent(in) :: name
93  real, intent(in), optional :: rval(:)
94  integer, intent(in), optional :: ival(:)
95  character(len=*), intent(in), optional :: cval
96  integer, intent(in), optional :: pack
97 
98  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META: must first call mpp_io_init.' )
99  if( .NOT. mpp_file(unit)%write_on_this_pe) then
100  return
101  endif
102  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
103  if( mpp_file(unit)%initialized ) &
104  call mpp_error( fatal, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
105 
106  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
107  call write_attribute_netcdf( unit, id, name, rval, ival, cval, pack )
108  else
109  write( text, '(a,i4,a)' )'VARIABLE ', id, ' '//name
110  call write_attribute( unit, trim(text), rval, ival, cval, pack )
111  end if
112 
113  return
114  end subroutine mpp_write_meta_var
115 
116 !versions of above to support <rval> and <ival> as scalar (because of f90 strict rank matching)
117  subroutine mpp_write_meta_scalar_r( unit, id, name, rval, pack )
118  integer, intent(in) :: unit, id
119  character(len=*), intent(in) :: name
120  real, intent(in) :: rval
121  integer, intent(in), optional :: pack
122 
123  call mpp_write_meta( unit, id, name, rval=(/rval/), pack=pack )
124  return
125  end subroutine mpp_write_meta_scalar_r
126 
127  subroutine mpp_write_meta_scalar_i( unit, id, name, ival,pack )
128  integer, intent(in) :: unit, id
129  character(len=*), intent(in) :: name
130  integer, intent(in) :: ival
131  integer, intent(in), optional :: pack
132 
133  call mpp_write_meta( unit, id, name, ival=(/ival/),pack=pack )
134  return
135  end subroutine mpp_write_meta_scalar_i
136 
137 
138  subroutine mpp_write_axis_data (unit, axes )
139  integer, intent(in) :: unit
140  type(axistype), dimension(:), intent(in) :: axes
141 
142  integer :: naxis
143 
144  naxis = size (axes)
145  allocate (mpp_file(unit)%axis(naxis))
146  mpp_file(unit)%axis(1:naxis) = axes(1:naxis)
147 #ifdef use_netCDF
148  if( mpp_file(unit)%action.EQ.mpp_wronly )then
149  if(header_buffer_val>0) then
150  error = nf__enddef(mpp_file(unit)%ncid,header_buffer_val,4,0,4)
151  else
152  error = nf_enddef(mpp_file(unit)%ncid)
153  endif
154  endif
155 #endif
156  end subroutine mpp_write_axis_data
157 
158  subroutine mpp_def_dim_nodata(unit,name,size)
159  integer, intent(in) :: unit
160  character(len=*), intent(in) :: name
161  integer, intent(in) :: size
162  integer :: error,did
163 
164  ! This routine assumes the file is in define mode
165  if(.NOT. mpp_file(unit)%write_on_this_pe) return
166 #ifdef use_netCDF
167  error = nf_def_dim(mpp_file(unit)%ncid,name,size,did)
168  call netcdf_err(error, mpp_file(unit),string='Axis='//trim(name))
169 #endif
170  end subroutine mpp_def_dim_nodata
171 
172  subroutine mpp_def_dim_int(unit,name,dsize,longname,data)
173  integer, intent(in) :: unit
174  character(len=*), intent(in) :: name
175  integer, intent(in) :: dsize
176  character(len=*), intent(in) :: longname
177  integer, intent(in) :: data(:)
178  integer :: error,did,id
179 
180  ! This routine assumes the file is in define mode
181 #ifdef use_netCDF
182  if(.NOT. mpp_file(unit)%write_on_this_pe) return
183  error = nf_def_dim(mpp_file(unit)%ncid,name,dsize,did)
184  call netcdf_err(error, mpp_file(unit),string='Axis='//trim(name))
185 
186  ! Write dimension data.
187  error = nf_def_var( mpp_file(unit)%ncid, name, nf_int, 1, (/did/), id )
188  call netcdf_err( error, mpp_file(unit), string=' axis varable '//trim(name))
189 
190  error = nf_put_att_text( mpp_file(unit)%ncid, id, 'long_name', len_trim(longname), longname )
191  call netcdf_err( error, mpp_file(unit), string=' Attribute=long_name' )
192 
193  if( mpp_file(unit)%action.EQ.mpp_wronly )then
194  if(header_buffer_val>0) then
195  error = nf__enddef(mpp_file(unit)%ncid,header_buffer_val,4,0,4)
196  else
197  error = nf_enddef(mpp_file(unit)%ncid)
198  endif
199  endif
200  call netcdf_err( error, mpp_file(unit), string=' subroutine mpp_def_dim')
201  error = nf_put_vara_int( mpp_file(unit)%ncid, id, (/1/), (/size(data)/), data )
202  call netcdf_err( error, mpp_file(unit), string=' axis varable '//trim(name))
203  error = nf_redef(mpp_file(unit)%ncid)
204  call netcdf_err( error, mpp_file(unit), string=' subroutine mpp_def_dim')
205 #endif
206  return
207  end subroutine mpp_def_dim_int
208 
209  subroutine mpp_def_dim_real(unit,name,dsize,longname,data)
210  integer, intent(in) :: unit
211  character(len=*), intent(in) :: name
212  integer, intent(in) :: dsize
213  character(len=*), intent(in) :: longname
214  real, intent(in) :: data(:)
215  integer :: error,did,id
216 
217  ! This routine assumes the file is in define mode
218 #ifdef use_netCDF
219  if(.NOT. mpp_file(unit)%write_on_this_pe) return
220  error = nf_def_dim(mpp_file(unit)%ncid,name,dsize,did)
221  call netcdf_err(error, mpp_file(unit),string='Axis='//trim(name))
222 
223  ! Write dimension data.
224  error = nf_def_var( mpp_file(unit)%ncid, name, nf_int, 1, (/did/), id )
225  call netcdf_err( error, mpp_file(unit), string=' axis varable '//trim(name))
226 
227  error = nf_put_att_text( mpp_file(unit)%ncid, id, 'long_name', len_trim(longname), longname )
228  call netcdf_err( error, mpp_file(unit), string=' Attribute=long_name' )
229 
230  if( mpp_file(unit)%action.EQ.mpp_wronly )then
231  if(header_buffer_val>0) then
232  error = nf__enddef(mpp_file(unit)%ncid,header_buffer_val,4,0,4)
233  else
234  error = nf_enddef(mpp_file(unit)%ncid)
235  endif
236  endif
237  call netcdf_err( error, mpp_file(unit), string=' subroutine mpp_def_dim')
238  error = nf90_put_var( mpp_file(unit)%ncid, id, data, start=(/1/), count=(/size(data)/) )
239  call netcdf_err( error, mpp_file(unit), string=' axis varable '//trim(name))
240  error = nf_redef(mpp_file(unit)%ncid)
241  call netcdf_err( error, mpp_file(unit), string=' subroutine mpp_def_dim')
242 #endif
243  return
244  end subroutine mpp_def_dim_real
245 
246 
247 
248  subroutine mpp_write_meta_axis_r1d( unit, axis, name, units, longname, cartesian, sense, domain, data, min, &
249  & calendar)
250 !load the values in an axistype (still need to call mpp_write)
251 !write metadata attributes for axis
252 !it is declared intent(inout) so you can nullify pointers in the incoming object if needed
253 !the f90 standard doesn't guarantee that intent(out) on a type guarantees that its pointer
254 !components will be unassociated
255  integer, intent(in) :: unit
256  type(axistype), intent(inout) :: axis
257  character(len=*), intent(in) :: name, units, longname
258  character(len=*), intent(in), optional :: cartesian
259  integer, intent(in), optional :: sense
260  type(domain1d), intent(in), optional :: domain
261  real, intent(in), optional :: data(:)
262  real, intent(in), optional :: min
263  character(len=*), intent(in), optional :: calendar
264 
265  integer :: is, ie, isg, ieg
266  integer :: istat
267  logical :: domain_exist
268  type(domain2d), pointer :: io_domain => null()
269 
270 ! call mpp_clock_begin(mpp_write_clock)
271  !--- the shift and cartesian information is needed in mpp_write_meta_field from all the pe.
272  !--- we may revise this in the future.
273  axis%cartesian = 'N'
274  if( PRESENT(cartesian) )axis%cartesian = cartesian
275 
276  domain_exist = .false.
277 
278  if( PRESENT(domain) ) then
279  domain_exist = .true.
280  call mpp_get_global_domain( domain, isg, ieg )
281  if(mpp_file(unit)%io_domain_exist) then
282  io_domain => mpp_get_io_domain(mpp_file(unit)%domain)
283  if(axis%cartesian=='X') then
284  call mpp_get_global_domain( io_domain, xbegin=is, xend=ie)
285  else if(axis%cartesian=='Y') then
286  call mpp_get_global_domain( io_domain, ybegin=is, yend=ie)
287  endif
288  else
289  call mpp_get_compute_domain( domain, is, ie )
290  endif
291  else if( PRESENT(data) )then
292  isg=1; ieg=size(data(:)); is=isg; ie=ieg
293  endif
294 
295  axis%shift = 0
296  if( PRESENT(data) .AND. domain_exist ) then
297  if( size(data(:)) == ieg-isg+2 ) then
298  axis%shift = 1
299  ie = ie + 1
300  ieg = ieg + 1
301  endif
302  endif
303 
304  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META: must first call mpp_io_init.' )
305  if( .NOT. mpp_file(unit)%write_on_this_pe) then
306 ! call mpp_clock_end(mpp_write_clock)
307  return
308  endif
309  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
310  if( mpp_file(unit)%initialized ) &
311  call mpp_error( fatal, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
312 
313 !pre-existing pointers need to be nullified
314  if( ASSOCIATED(axis%data) ) then
315  DEALLOCATE(axis%data, stat=istat)
316  endif
317 !load axistype
318  axis%name = name
319  axis%units = units
320  axis%longname = longname
321  if( PRESENT(calendar) ) axis%calendar = calendar
322  if( PRESENT(sense) ) axis%sense = sense
323  if( PRESENT(data) )then
324  if( mpp_file(unit)%fileset.EQ.mpp_multi .AND. domain_exist ) then
325  axis%len = ie - is + 1
326  allocate(axis%data(axis%len))
327  axis%data = data(is-isg+1:ie-isg+1)
328  else
329  axis%len = size(data(:))
330  allocate(axis%data(axis%len))
331  axis%data = data
332  endif
333  endif
334 !write metadata
335  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
336 #ifdef use_netCDF
337 !write axis def
338 !space axes are always floats, time axis is always double
339  if( ASSOCIATED(axis%data) )then !space axis
340  error = nf_def_dim( mpp_file(unit)%ncid, axis%name, axis%len, axis%did )
341  call netcdf_err( error, mpp_file(unit), axis )
342  if(pack_size == 1) then
343  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_double, 1, (/axis%did/), axis%id )
344  else ! pack_size == 2
345  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_float, 1, (/axis%did/), axis%id )
346  endif
347  call netcdf_err( error, mpp_file(unit), axis )
348  else !time axis
349  if( mpp_file(unit)%id.NE.-1 ) &
350  call mpp_error( fatal, 'MPP_WRITE_META_AXIS: There is already a time axis for this file.' )
351  error = nf_def_dim( mpp_file(unit)%ncid, axis%name, nf_unlimited, axis%did )
352  call netcdf_err( error, mpp_file(unit), axis )
353  if(pack_size == 1) then
354  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_double, 1, (/axis%did/), axis%id )
355  else ! pack_size == 2
356  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_float, 1, (/axis%did/), axis%id )
357  endif
358  call netcdf_err( error, mpp_file(unit), axis )
359  mpp_file(unit)%id = axis%id !file ID is the same as time axis varID
360  end if
361 #endif
362  else
363  varnum = varnum + 1
364  axis%id = varnum
365  axis%did = varnum
366 !write axis def
367  write( text, '(a,i4,a)' )'AXIS ', axis%id, ' name'
368  call write_attribute( unit, trim(text), cval=axis%name )
369  write( text, '(a,i4,a)' )'AXIS ', axis%id, ' size'
370  if( ASSOCIATED(axis%data) )then !space axis
371 ! if( mpp_file(unit)%fileset.EQ.MPP_MULTI .AND. axis%domain.NE.NULL_DOMAIN1D )then
372 ! call write_attribute( unit, trim(text), ival=(/ie-is+1/) )
373 ! else
374  call write_attribute( unit, trim(text), ival=(/size(axis%data(:))/) )
375 ! end if
376  else !time axis
377  if( mpp_file(unit)%id.NE.-1 ) &
378  call mpp_error( fatal, 'MPP_WRITE_META_AXIS: There is already a time axis for this file.' )
379  call write_attribute( unit, trim(text), ival=(/0/) ) !a size of 0 indicates time axis
380  mpp_file(unit)%id = axis%id
381  end if
382  end if
383 !write axis attributes
384  call mpp_write_meta( unit, axis%id, 'long_name', cval=axis%longname) ; axis%natt = axis%natt + 1
385  if (lowercase(trim(axis%units)).ne.'none' .OR. .NOT.cf_compliance) then
386  call mpp_write_meta( unit, axis%id, 'units', cval=axis%units) ; axis%natt = axis%natt + 1
387  endif
388  if( PRESENT(calendar) ) then
389  if (.NOT.cf_compliance) then
390  call mpp_write_meta( unit, axis%id, 'calendar', cval=axis%calendar)
391  else
392  call mpp_write_meta( unit, axis%id, 'calendar', cval=lowercase(axis%calendar))
393  endif
394  axis%natt = axis%natt + 1
395  endif
396  if( PRESENT(cartesian) ) then
397  if (.NOT.cf_compliance) then
398  call mpp_write_meta( unit, axis%id, 'cartesian_axis', cval=axis%cartesian)
399  axis%natt = axis%natt + 1
400  else
401  if (trim(axis%cartesian).ne.'N') then
402  call mpp_write_meta( unit, axis%id, 'axis', cval=axis%cartesian)
403  axis%natt = axis%natt + 1
404  endif
405  endif
406  endif
407  if( PRESENT(sense) )then
408  if( sense.EQ.-1 )then
409  call mpp_write_meta( unit, axis%id, 'positive', cval='down')
410  axis%natt = axis%natt + 1
411  else if( sense.EQ.1 )then
412  call mpp_write_meta( unit, axis%id, 'positive', cval='up')
413  axis%natt = axis%natt + 1
414  else
415  ! silently ignore values of sense other than +/-1.
416  end if
417  end if
418  if( PRESENT(min) ) then
419  call mpp_write_meta( unit, axis%id, 'valid_min', rval=min)
420  axis%natt = axis%natt + 1
421  endif
422  if( mpp_file(unit)%threading.EQ.mpp_multi .AND. mpp_file(unit)%fileset.EQ.mpp_multi .AND. domain_exist )then
423  call mpp_write_meta( unit, axis%id, 'domain_decomposition', ival=(/isg,ieg,is,ie/))
424  axis%natt = axis%natt + 1
425  end if
426  if( verbose )print '(a,2i6,x,a,2i3)', &
427  'MPP_WRITE_META: Wrote axis metadata, pe, unit, axis%name, axis%id, axis%did=', &
428  pe, unit, trim(axis%name), axis%id, axis%did
429 
430  mpp_file(unit)%ndim = max(1,mpp_file(unit)%ndim + 1)
431 
432 ! call mpp_clock_end(mpp_write_clock)
433  return
434  end subroutine mpp_write_meta_axis_r1d
435 
436  subroutine mpp_write_meta_axis_i1d(unit, axis, name, units, longname, data, min, compressed)
437 !load the values in an axistype (still need to call mpp_write)
438 !write metadata attributes for axis
439 !it is declared intent(inout) so you can nullify pointers in the incoming object if needed
440 !the f90 standard doesn't guarantee that intent(out) on a type guarantees that its pointer
441 !components will be unassociated
442  integer, intent(in) :: unit
443  type(axistype), intent(inout) :: axis
444  character(len=*), intent(in) :: name, units, longname
445  integer, intent(in) :: data(:)
446  integer, intent(in), optional :: min
447  character(len=*), intent(in), optional :: compressed
448 
449  integer :: istat
450  logical :: domain_exist
451  type(domain2d), pointer :: io_domain => null()
452 
453 ! call mpp_clock_begin(mpp_write_clock)
454  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META_I1D: must first call mpp_io_init.' )
455  if( .NOT. mpp_file(unit)%write_on_this_pe) then
456 ! call mpp_clock_end(mpp_write_clock)
457  return
458  endif
459  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
460  if( mpp_file(unit)%initialized ) &
461  call mpp_error( fatal, 'MPP_WRITE_META_I1D: cannot write metadata to file after an mpp_write.' )
462 
463 !pre-existing pointers need to be nullified
464  if( ASSOCIATED(axis%idata) ) then
465  DEALLOCATE(axis%idata, stat=istat)
466  endif
467 !load axistype
468  axis%name = name
469  axis%units = units
470  axis%longname = longname
471  if( PRESENT(compressed)) axis%compressed = trim(compressed)
472  axis%len = size(data(:))
473  allocate(axis%idata(axis%len))
474  axis%idata = data
475 !write metadata
476 #ifdef use_netCDF
477  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
478  error = nf_def_dim( mpp_file(unit)%ncid, axis%name, axis%len, axis%did )
479  call netcdf_err( error, mpp_file(unit), axis )
480  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_int, 1, (/axis%did/), axis%id )
481  call netcdf_err( error, mpp_file(unit), axis )
482  else
483  call mpp_error( fatal, 'MPP_WRITE_META_AXIS_I1D: Only netCDF format is currently supported.' )
484  end if
485 #endif
486 !write axis attributes
487  call mpp_write_meta( unit, axis%id, 'long_name', cval=axis%longname) ; axis%natt = axis%natt + 1
488  if (lowercase(trim(axis%units)).ne.'none' .OR. .NOT.cf_compliance) then
489  call mpp_write_meta( unit, axis%id, 'units', cval=axis%units) ; axis%natt = axis%natt + 1
490  endif
491  if( PRESENT(compressed) ) then
492  call mpp_write_meta( unit, axis%id, 'compress', cval=axis%compressed)
493  axis%natt = axis%natt + 1
494  endif
495  if( PRESENT(min) ) then
496  call mpp_write_meta( unit, axis%id, 'valid_min', ival=min)
497  axis%natt = axis%natt + 1
498  endif
499  if( verbose )print '(a,2i6,x,a,2i3)', &
500  'MPP_WRITE_META: Wrote axis metadata, pe, unit, axis%name, axis%id, axis%did=', &
501  pe, unit, trim(axis%name), axis%id, axis%did
502 
503  mpp_file(unit)%ndim = max(1,mpp_file(unit)%ndim + 1)
504 
505 ! call mpp_clock_end(mpp_write_clock)
506  return
507  end subroutine mpp_write_meta_axis_i1d
508 
509 
510  subroutine mpp_write_meta_axis_unlimited(unit, axis, name, data, unlimited, units, longname)
511 !load the values in an axistype (still need to call mpp_write)
512 !write metadata attributes for axis
513 !it is declared intent(inout) so you can nullify pointers in the incoming object if needed
514 !the f90 standard doesn't guarantee that intent(out) on a type guarantees that its pointer
515 !components will be unassociated
516  integer, intent(in) :: unit
517  type(axistype), intent(inout) :: axis
518  character(len=*), intent(in) :: name
519  integer, intent(in) :: data ! Number of elements to be written
520  logical, intent(in) :: unlimited ! Provides unique arg signature
521  character(len=*), intent(in), optional :: units, longname
522 
523  integer :: istat
524  logical :: domain_exist
525  type(domain2d), pointer :: io_domain => null()
526 
527 ! call mpp_clock_begin(mpp_write_clock)
528  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META_I1D: must first call mpp_io_init.' )
529  if( .NOT. mpp_file(unit)%write_on_this_pe) then
530 ! call mpp_clock_end(mpp_write_clock)
531  return
532  endif
533  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
534  if( mpp_file(unit)%initialized ) &
535  call mpp_error( fatal, 'MPP_WRITE_META_I1D: cannot write metadata to file after an mpp_write.' )
536 
537 !load axistype
538  axis%name = name
539  if(present(units)) axis%units = units
540  if(present(longname)) axis%longname = longname
541  axis%len = 1
542  allocate(axis%idata(1))
543  axis%idata = data
544 !write metadata
545 #ifdef use_netCDF
546  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
547  error = nf_def_dim( mpp_file(unit)%ncid, axis%name, nf_unlimited, axis%did )
548  call netcdf_err( error, mpp_file(unit), axis )
549  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_int, 0, (/axis%did/), axis%id )
550  call netcdf_err( error, mpp_file(unit), axis )
551  else
552  call mpp_error( fatal, 'MPP_WRITE_META_AXIS_UNLIMITED: Only netCDF format is currently supported.' )
553  end if
554 #endif
555 !write axis attributes
556  if(present(longname)) then
557  call mpp_write_meta(unit,axis%id,'long_name',cval=axis%longname); axis%natt=axis%natt+1
558  endif
559  if(present(units)) then
560  if (lowercase(trim(axis%units)).ne.'none' .OR. .NOT.cf_compliance) then
561  call mpp_write_meta(unit,axis%id,'units', cval=axis%units); axis%natt=axis%natt+1
562  endif
563  endif
564  if( verbose )print '(a,2i6,x,a,2i3)', &
565  'MPP_WRITE_META_UNLIMITED: Wrote axis metadata, pe, unit, axis%name, axis%id, axis%did=', &
566  pe, unit, trim(axis%name), axis%id, axis%did
567 
568  mpp_file(unit)%ndim = max(1,mpp_file(unit)%ndim + 1)
569 
570 ! call mpp_clock_end(mpp_write_clock)
571  return
572  end subroutine mpp_write_meta_axis_unlimited
573 
574 
575  subroutine mpp_write_meta_field( unit, field, axes, name, units, longname,&
576  min, max, missing, fill, scale, add, pack, time_method, standard_name, checksum)
577 !define field: must have already called mpp_write_meta(axis) for each axis
578  integer, intent(in) :: unit
579  type(fieldtype), intent(inout) :: field
580  type(axistype), intent(in) :: axes(:)
581  character(len=*), intent(in) :: name, units, longname
582  real, intent(in), optional :: min, max, missing, fill, scale, add
583  integer, intent(in), optional :: pack
584  character(len=*), intent(in), optional :: time_method
585  character(len=*), intent(in), optional :: standard_name
586  integer(i8_kind), dimension(:), intent(in), optional :: checksum
587 !this array is required because of f77 binding on netCDF interface
588  integer, allocatable :: axis_id(:)
589  real :: a, b
590  integer :: i, istat, ishift, jshift
591  character(len=64) :: checksum_char
592 
593 ! call mpp_clock_begin(mpp_write_clock)
594 
595  !--- figure out the location of data, this is needed in mpp_write.
596  !--- for NON-symmetry domain, the position is not an issue.
597  !--- we may need to rethink how to address the symmetric issue.
598  ishift = 0; jshift = 0
599  do i = 1, size(axes(:))
600  select case ( lowercase( axes(i)%cartesian ) )
601  case ( 'x' )
602  ishift = axes(i)%shift
603  case ( 'y' )
604  jshift = axes(i)%shift
605  end select
606  end do
607 
608  field%position = center
609  if(ishift == 1 .AND. jshift == 1) then
610  field%position = corner
611  else if(ishift == 1) then
612  field%position = east
613  else if(jshift == 1) then
614  field%position = north
615  endif
616 
617  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META: must first call mpp_io_init.' )
618 
619  if( .NOT.mpp_file(unit)%write_on_this_pe) then
620  if( .NOT. ASSOCIATED(field%axes) )allocate(field%axes(1)) !temporary fix
621 ! call mpp_clock_end(mpp_write_clock)
622  return
623  endif
624  if( .NOT.mpp_file(unit)%opened ) call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
625  if( mpp_file(unit)%initialized ) then
626 ! File has already been written to and needs to be returned to define mode.
627 #ifdef use_netCDF
628  error = nf_redef(mpp_file(unit)%ncid)
629 #endif
630  mpp_file(unit)%initialized = .false.
631  endif
632 ! call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
633 
634 !pre-existing pointers need to be nullified
635  if( ASSOCIATED(field%axes) ) DEALLOCATE(field%axes, stat=istat)
636  if( ASSOCIATED(field%size) ) DEALLOCATE(field%size, stat=istat)
637 !fill in field metadata
638  field%name = name
639  field%units = units
640  field%longname = longname
641  allocate( field%axes(size(axes(:))) )
642  field%axes = axes
643  field%ndim = size(axes(:))
644  field%time_axis_index = -1 !this value will never match any axis index
645 !size is buffer area for the corresponding axis info: it is required to buffer this info in the fieldtype
646 !because axis might be reused in different files
647  allocate( field%size(size(axes(:))) )
648  do i = 1,size(axes(:))
649  if( ASSOCIATED(axes(i)%data) )then !space axis
650  field%size(i) = size(axes(i)%data(:))
651  else !time
652  field%size(i) = 1
653  field%time_axis_index = i
654  end if
655  end do
656 !attributes
657  if( PRESENT(min) ) field%min = min
658  if( PRESENT(max) ) field%max = max
659  if( PRESENT(scale) ) field%scale = scale
660  if( PRESENT(add) ) field%add = add
661  if( PRESENT(standard_name)) field%standard_name = standard_name
662  if( PRESENT(missing) ) field%missing = missing
663  if( PRESENT(fill) ) field%fill = fill
664  field%checksum = 0
665  if( PRESENT(checksum) ) field%checksum(1:size(checksum)) = checksum(:)
666 
667  ! Issue warning if fill and missing are different
668  if (present(fill).and.present(missing)) then
669  if (field%missing .ne. field%fill) then
670  call mpp_error(warning, 'MPP_WRITE_META: NetCDF attributes &
671  &_FillValue and missing_value should be equal.')
672  end if
673  end if
674 !pack is currently used only for netCDF
675  field%pack = 2 !default write 32-bit floats
676  if( PRESENT(pack) )field%pack = pack
677  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
678 #ifdef use_netCDF
679  allocate( axis_id(size(field%axes(:))) )
680  do i = 1,size(field%axes(:))
681  axis_id(i) = field%axes(i)%did
682  end do
683 !write field def
684  select case (field%pack)
685  case(0)
686  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_int, size(field%axes(:)), axis_id, field%id )
687  case(1)
688  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_double, size(field%axes(:)),axis_id,field%id)
689  case(2)
690  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_float, size(field%axes(:)),axis_id,field%id)
691  case(4)
692  if( .NOT.PRESENT(scale) .OR. .NOT.PRESENT(add) ) &
693  call mpp_error( fatal, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=4.' )
694  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_short, size(field%axes(:)),axis_id,field%id)
695  case(8)
696  if( .NOT.PRESENT(scale) .OR. .NOT.PRESENT(add) ) &
697  call mpp_error( fatal, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=8.' )
698  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_byte, size(field%axes(:)),axis_id,field%id)
699  case default
700  call mpp_error( fatal, 'MPP_WRITE_META_FIELD: only legal packing values are 1,2,4,8.' )
701  end select
702  call netcdf_err( error, mpp_file(unit), field=field )
703  deallocate(axis_id)
704 #ifndef use_netCDF3
705  if(shuffle .NE. 0 .OR. deflate .NE. 0) then
706  error = nf_def_var_deflate(mpp_file(unit)%ncid, field%id, shuffle, deflate, deflate_level)
707  call netcdf_err( error, mpp_file(unit), field=field )
708  endif
709 #endif
710 #endif
711  else
712  varnum = varnum + 1
713  field%id = varnum
714  if( PRESENT(pack) )call mpp_error( warning, &
715  & 'MPP_WRITE_META: Packing is currently available only on netCDF files.' )
716 !write field def
717  write( text, '(a,i4,a)' )'FIELD ', field%id, ' name'
718  call write_attribute( unit, trim(text), cval=field%name )
719  write( text, '(a,i4,a)' )'FIELD ', field%id, ' axes'
720  call write_attribute( unit, trim(text), ival=field%axes(:)%did )
721  end if
722 !write field attributes: these names follow netCDF conventions
723  call mpp_write_meta( unit, field%id, 'long_name', cval=field%longname)
724  if (lowercase(trim(field%units)).ne.'none' .OR. .NOT.cf_compliance) then
725  call mpp_write_meta( unit, field%id, 'units', cval=field%units)
726  endif
727 !all real attributes must be written as packed
728  if( PRESENT(min) .AND. PRESENT(max) )then
729  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
730  call mpp_write_meta( unit, field%id, 'valid_range', rval=(/min,max/), pack=pack )
731  else
732  a = nint((min-add)/scale)
733  b = nint((max-add)/scale)
734  call mpp_write_meta( unit, field%id, 'valid_range', rval=(/a, b /), pack=pack )
735  end if
736  else if( PRESENT(min) )then
737  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
738  call mpp_write_meta( unit, field%id, 'valid_min', rval=field%min, pack=pack )
739  else
740  a = nint((min-add)/scale)
741  call mpp_write_meta( unit, field%id, 'valid_min', rval=a, pack=pack )
742  end if
743  else if( PRESENT(max) )then
744  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
745  call mpp_write_meta( unit, field%id, 'valid_max', rval=field%max, pack=pack )
746  else
747  a = nint((max-add)/scale)
748  call mpp_write_meta( unit, field%id, 'valid_max', rval=a, pack=pack )
749  end if
750  end if
751 ! write missing_value
752  if ( present(missing) ) then
753  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
754  call mpp_write_meta( unit, field%id, 'missing_value', rval=field%missing, pack=pack )
755  else
756  a = nint((missing-add)/scale)
757  call mpp_write_meta( unit, field%id, 'missing_value', rval=a, pack=pack )
758  end if
759  end if
760 ! write _FillValue
761  if ( present(fill) ) then
762  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
763  call mpp_write_meta( unit, field%id, '_FillValue', rval=field%fill, pack=pack )
764  else if (field%pack==0) then ! some safety checks for integer fills
765  if ( present(scale).OR.present(add) ) then
766  call mpp_error(fatal,"add,scale not currently implimented for pack=0 int handling, try reals instead.")
767  else
768  ! Trust No One
769  call mpp_write_meta( unit, field%id, '_FillValue', ival=mpp_fill_int, pack=pack )
770  end if
771  else
772  a = nint((fill-add)/scale)
773  call mpp_write_meta( unit, field%id, '_FillValue', rval=a, pack=pack )
774  end if
775  end if
776 
777  if( field%pack.NE.1 .AND. field%pack.NE.2 )then
778  call mpp_write_meta( unit, field%id, 'packing', ival=field%pack )
779  if( PRESENT(scale) )call mpp_write_meta( unit, field%id, 'scale_factor', rval=field%scale )
780  if( PRESENT(add) )call mpp_write_meta( unit, field%id, 'add_offset', rval=field%add )
781  end if
782 
783  if( present(checksum) )then
784  write (checksum_char,'(Z16)') field%checksum(1)
785  do i = 2,size(checksum)
786  write (checksum_char,'(a,Z16)') trim(checksum_char)//",",checksum(i)
787  enddo
788  call mpp_write_meta( unit, field%id, 'checksum', cval=checksum_char )
789  end if
790 
791  if ( PRESENT(time_method) ) then
792  call mpp_write_meta(unit,field%id, 'cell_methods',cval='time: '//trim(time_method))
793  endif
794  if ( PRESENT(standard_name)) &
795  call mpp_write_meta(unit,field%id,'standard_name ', cval=field%standard_name)
796 
797  if( verbose )print '(a,2i6,x,a,i3)', 'MPP_WRITE_META: Wrote field metadata: pe, unit, field%name, field%id=', &
798  pe, unit, trim(field%name), field%id
799 
800 ! call mpp_clock_end(mpp_write_clock)
801  return
802  end subroutine mpp_write_meta_field
803 
804  subroutine write_attribute( unit, name, rval, ival, cval, pack )
805 !called to write metadata for non-netCDF I/O
806  integer, intent(in) :: unit
807  character(len=*), intent(in) :: name
808  real, intent(in), optional :: rval(:)
809  integer, intent(in), optional :: ival(:)
810  character(len=*), intent(in), optional :: cval
811 !pack is currently ignored in this routine: only used by netCDF I/O
812  integer, intent(in), optional :: pack
813 
814  if( mpp_file(unit)%nohdrs )return
815 !encode text string
816  if( PRESENT(rval) )then
817  write( text,* )trim(name)//'=', rval
818  else if( PRESENT(ival) )then
819  write( text,* )trim(name)//'=', ival
820  else if( PRESENT(cval) )then
821  text = ' '//trim(name)//'='//trim(cval)
822  else
823  call mpp_error( fatal, 'WRITE_ATTRIBUTE: one of rval, ival, cval must be present.' )
824  end if
825  if( mpp_file(unit)%format.EQ.mpp_ascii )then
826 !implies sequential access
827  write( unit,fmt='(a)' )trim(text)//char(10)
828  else !MPP_IEEE32 or MPP_NATIVE
829  if( mpp_file(unit)%access.EQ.mpp_sequential )then
830  write(unit)trim(text)//char(10)
831  else !MPP_DIRECT
832  write( unit,rec=mpp_file(unit)%record )trim(text)//char(10)
833  if( verbose )print '(a,i6,a,i3)', 'WRITE_ATTRIBUTE: PE=', pe, ' wrote record ', mpp_file(unit)%record
834  mpp_file(unit)%record = mpp_file(unit)%record + 1
835  end if
836  end if
837  return
838  end subroutine write_attribute
839 
840  subroutine write_attribute_netcdf( unit, id, name, rval, ival, cval, pack )
841 !called to write metadata for netCDF I/O
842  integer, intent(in) :: unit
843  integer, intent(in) :: id
844  character(len=*), intent(in) :: name
845  real, intent(in), optional :: rval(:)
846  integer, intent(in), optional :: ival(:)
847  character(len=*), intent(in), optional :: cval
848  integer, intent(in), optional :: pack
849  integer, allocatable :: rval_i(:)
850 #ifdef use_netCDF
851  if( PRESENT(rval) )then
852 !pack was only meaningful for FP numbers, but is now extended by the ival branch of this routine
853  if( PRESENT(pack) )then
854  if( pack== 0 ) then !! here be dragons, use ival branch!...
855  if( kind(rval).EQ.r8_kind )then
856  call mpp_error( fatal, &
857  'WRITE_ATTRIBUTE_NETCDF: attempting to write internal NF_INT, currently int32, as double.' )
858  else if( kind(rval).EQ.r4_kind )then
859  call mpp_error( fatal, &
860  'WRITE_ATTRIBUTE_NETCDF: attempting to write internal NF_INT, currently int32, as float.' )
861  end if
862  else if( pack.EQ.1 )then
863  if( kind(rval).EQ.r8_kind )then
864  error = nf_put_att_double( mpp_file(unit)%ncid, id, name, nf_double, &
865  size(rval(:)), real(rval, kind=r8_kind))
866  else if( kind(rval).EQ.r4_kind )then
867  call mpp_error( warning, &
868  'WRITE_ATTRIBUTE_NETCDF: attempting to write internal 32-bit real as external 64-bit.' )
869  error = nf_put_att_real( mpp_file(unit)%ncid, id, name, nf_double, &
870  size(rval(:)), real(rval, kind=r4_kind))
871  end if
872  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
873  else if( pack.EQ.2 )then
874  if( kind(rval).EQ.r8_kind )then
875  error = nf_put_att_double( mpp_file(unit)%ncid, id, name, nf_float, &
876  size(rval(:)), real(rval, kind=r8_kind))
877  else if( kind(rval).EQ.r4_kind )then
878  error = nf_put_att_real( mpp_file(unit)%ncid, id, name, nf_float, &
879  size(rval(:)), real(rval, kind=r4_kind))
880  end if
881  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
882  else if( pack.EQ.4 )then
883  allocate( rval_i(size(rval(:))) )
884  rval_i = rval
885  if( kind(rval).EQ.r8_kind )then
886  error = nf_put_att_double( mpp_file(unit)%ncid, id, name, nf_short, &
887  size(rval_i(:)), real(rval, kind=r8_kind))
888  else if( kind(rval).EQ.r4_kind )then
889  error = nf_put_att_real( mpp_file(unit)%ncid, id, name, nf_short, &
890  size(rval_i(:)), real(rval, kind=r4_kind))
891  end if
892  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
893  deallocate(rval_i)
894  else if( pack.EQ.8 )then
895  allocate( rval_i(size(rval(:))) )
896  rval_i = rval
897  if( kind(rval).EQ.r8_kind )then
898  error = nf_put_att_double( mpp_file(unit)%ncid, id, name, nf_byte, &
899  size(rval_i(:)), real(rval, kind=r8_kind))
900  else if( kind(rval).EQ.r4_kind )then
901  error = nf_put_att_real( mpp_file(unit)%ncid, id, name, nf_byte, &
902  size(rval_i(:)), real(rval, kind=r4_kind))
903  end if
904  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
905  deallocate(rval_i)
906  else
907  call mpp_error( fatal, 'WRITE_ATTRIBUTE_NETCDF: only legal packing values are 1,2,4,8.' )
908  end if
909  else
910 !default is to write FLOATs (32-bit)
911  if( kind(rval).EQ.r8_kind )then
912  error = nf_put_att_double( mpp_file(unit)%ncid, id, name, nf_float, &
913  size(rval(:)), real(rval, kind=r8_kind))
914  else if( kind(rval).EQ.r4_kind )then
915  error = nf_put_att_real( mpp_file(unit)%ncid, id, name, nf_float, &
916  size(rval(:)), real(rval, kind=r4_kind))
917  end if
918  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
919  end if
920  else if( PRESENT(ival) )then
921  if( PRESENT(pack) ) then
922  if (pack ==0) then
923  if (kind(ival).EQ.i8_kind) then
924  call mpp_error(fatal,'only use NF_INTs with pack=0 for now')
925  end if
926  error = nf_put_att_int( mpp_file(unit)%ncid, id, name, &
927  nf_int, size(ival(:)), ival ) !!XXX int32_t
928  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
929  else
930  call mpp_error( fatal, 'WRITE_ATTRIBUTE_NETCDF: only implimented ints when pack=0, else use reals.' )
931  endif
932  else
933  error = nf_put_att_int( mpp_file(unit)%ncid, id, name, nf_int, size(ival(:)), ival )
934  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
935  end if
936  else if( present(cval) )then
937  if (.NOT.cf_compliance .or. trim(name).NE.'calendar') then
938  error = nf_put_att_text( mpp_file(unit)%ncid, id, name, len_trim(cval), cval )
939  else
940  error = nf_put_att_text( mpp_file(unit)%ncid, id, name, len_trim(cval), lowercase(cval) )
941  endif
942  call netcdf_err( error, mpp_file(unit), string=' Attribute='//name )
943  else
944  call mpp_error( fatal, 'WRITE_ATTRIBUTE_NETCDF: one of rval, ival, cval must be present.' )
945  end if
946 #endif /* use_netCDF */
947  return
948  end subroutine write_attribute_netcdf
949 
950 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
951 ! !
952 ! MPP_WRITE !
953 ! !
954 ! mpp_write is used to write data to the file on <unit> using the !
955 ! file parameters supplied by mpp_open(). Axis and field definitions !
956 ! must have previously been written to the file using mpp_write_meta. !
957 ! !
958 ! mpp_write can take 2 forms, one for distributed data and one for !
959 ! non-distributed data. Distributed data refer to arrays whose two !
960 ! fastest-varying indices are domain-decomposed. Distributed data !
961 ! must be 2D or 3D (in space). Non-distributed data can be 0-3D. !
962 ! !
963 ! In all calls to mpp_write, tstamp is an optional argument. It is to !
964 ! be omitted if the field was defined not to be a function of time. !
965 ! Results are unpredictable if the argument is supplied for a time- !
966 ! independent field, or omitted for a time-dependent field. Repeated !
967 ! writes of a time-independent field are also not recommended. One !
968 ! time level of one field is written per call. !
969 ! !
970 ! !
971 ! For non-distributed data, use !
972 ! !
973 ! mpp_write( unit, field, data, tstamp ) !
974 ! integer, intent(in) :: unit !
975 ! type(fieldtype), intent(in) :: field !
976 ! real(r8_kind), optional :: tstamp !
977 ! data is real and can be scalar or of rank 1-3. !
978 ! !
979 ! For distributed data, use !
980 ! !
981 ! mpp_write( unit, field, domain, data, tstamp ) !
982 ! integer, intent(in) :: unit !
983 ! type(fieldtype), intent(in) :: field !
984 ! type(domain2D), intent(in) :: domain !
985 ! real(r8_kind), optional :: tstamp !
986 ! data is real and can be of rank 2 or 3. !
987 ! !
988 ! mpp_write( unit, axis ) !
989 ! integer, intent(in) :: unit !
990 ! type(axistype), intent(in) :: axis !
991 ! !
992 ! This call writes the actual co-ordinate values along each space !
993 ! axis. It must be called once for each space axis after all other !
994 ! metadata has been written. !
995 ! !
996 ! The mpp_write package also includes the routine write_record which !
997 ! performs the actual write. This routine is private to this module. !
998 ! !
999 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1000 #undef WRITE_RECORD_
1001 #define WRITE_RECORD_ write_record_r8
1002 #undef MPP_WRITE_2DDECOMP_2D_
1003 #define MPP_WRITE_2DDECOMP_2D_ mpp_write_2ddecomp_r2d_r8
1004 #undef MPP_WRITE_2DDECOMP_3D_
1005 #define MPP_WRITE_2DDECOMP_3D_ mpp_write_2ddecomp_r3d_r8
1006 #undef MPP_WRITE_2DDECOMP_4D_
1007 #define MPP_WRITE_2DDECOMP_4D_ mpp_write_2ddecomp_r4d_r8
1008 #undef MPP_TYPE_
1009 #define MPP_TYPE_ real(KIND=r8_kind)
1010 #include <mpp_write_2Ddecomp.fh>
1011 
1012 #undef WRITE_RECORD_
1013 #define WRITE_RECORD_ write_record_r4
1014 #undef MPP_WRITE_2DDECOMP_2D_
1015 #define MPP_WRITE_2DDECOMP_2D_ mpp_write_2ddecomp_r2d_r4
1016 #undef MPP_WRITE_2DDECOMP_3D_
1017 #define MPP_WRITE_2DDECOMP_3D_ mpp_write_2ddecomp_r3d_r4
1018 #undef MPP_WRITE_2DDECOMP_4D_
1019 #define MPP_WRITE_2DDECOMP_4D_ mpp_write_2ddecomp_r4d_r4
1020 #undef MPP_TYPE_
1021 #define MPP_TYPE_ real(KIND=r4_kind)
1022 #include <mpp_write_2Ddecomp.fh>
1023 
1024 #undef MPP_WRITE_COMPRESSED_1D_
1025 #define MPP_WRITE_COMPRESSED_1D_ mpp_write_compressed_r1d_r8
1026 #undef MPP_WRITE_COMPRESSED_2D_
1027 #define MPP_WRITE_COMPRESSED_2D_ mpp_write_compressed_r2d_r8
1028 #undef MPP_WRITE_COMPRESSED_3D_
1029 #define MPP_WRITE_COMPRESSED_3D_ mpp_write_compressed_r3d_r8
1030 #undef WRITE_RECORD_
1031 #define WRITE_RECORD_ write_record_r8
1032 #undef MPP_TYPE_
1033 #define MPP_TYPE_ real(KIND=r8_kind)
1034 #include <mpp_write_compressed.fh>
1035 
1036 #undef MPP_WRITE_COMPRESSED_1D_
1037 #define MPP_WRITE_COMPRESSED_1D_ mpp_write_compressed_r1d_r4
1038 #undef MPP_WRITE_COMPRESSED_2D_
1039 #define MPP_WRITE_COMPRESSED_2D_ mpp_write_compressed_r2d_r4
1040 #undef MPP_WRITE_COMPRESSED_3D_
1041 #define MPP_WRITE_COMPRESSED_3D_ mpp_write_compressed_r3d_r4
1042 #undef WRITE_RECORD_
1043 #define WRITE_RECORD_ write_record_r4
1044 #undef MPP_TYPE_
1045 #define MPP_TYPE_ real(KIND=r4_kind)
1046 #include <mpp_write_compressed.fh>
1047 
1048 #undef MPP_WRITE_UNLIMITED_AXIS_1D_
1049 #define MPP_WRITE_UNLIMITED_AXIS_1D_ mpp_write_unlimited_axis_r1d
1050 #undef MPP_TYPE_
1051 #define MPP_TYPE_ real
1052 #include <mpp_write_unlimited_axis.fh>
1053 
1054 #undef MPP_WRITE_
1055 #define MPP_WRITE_ mpp_write_r0D_r8
1056 #undef MPP_TYPE_
1057 #define MPP_TYPE_ real(KIND=r8_kind)
1058 #undef MPP_RANK_
1059 #define MPP_RANK_ !
1060 #undef MPP_WRITE_RECORD_
1061 #define MPP_WRITE_RECORD_ write_record_r8( unit, field, 1, (/data/), tstamp)
1062 #include <mpp_write.fh>
1063 
1064 #undef MPP_WRITE_
1065 #define MPP_WRITE_ mpp_write_r1D_r8
1066 #undef MPP_TYPE_
1067 #define MPP_TYPE_ real(KIND=r8_kind)
1068 #undef MPP_WRITE_RECORD_
1069 #define MPP_WRITE_RECORD_ write_record_r8( unit, field, size(data(:)), data, tstamp)
1070 #undef MPP_RANK_
1071 #define MPP_RANK_ (:)
1072 #include <mpp_write.fh>
1073 
1074 #undef MPP_WRITE_
1075 #define MPP_WRITE_ mpp_write_r2D_r8
1076 #undef MPP_TYPE_
1077 #define MPP_TYPE_ real(KIND=r8_kind)
1078 #undef MPP_WRITE_RECORD_
1079 #define MPP_WRITE_RECORD_ write_record_r8( unit, field, size(data(:,:)), data, tstamp )
1080 #undef MPP_RANK_
1081 #define MPP_RANK_ (:,:)
1082 #include <mpp_write.fh>
1083 
1084 #undef MPP_WRITE_
1085 #define MPP_WRITE_ mpp_write_r3D_r8
1086 #undef MPP_TYPE_
1087 #define MPP_TYPE_ real(KIND=r8_kind)
1088 #undef MPP_WRITE_RECORD_
1089 #define MPP_WRITE_RECORD_ write_record_r8( unit, field, size(data(:,:,:)), data, tstamp)
1090 #undef MPP_RANK_
1091 #define MPP_RANK_ (:,:,:)
1092 #include <mpp_write.fh>
1093 
1094 #undef MPP_WRITE_
1095 #define MPP_WRITE_ mpp_write_r4D_r8
1096 #undef MPP_TYPE_
1097 #define MPP_TYPE_ real(KIND=r8_kind)
1098 #undef MPP_WRITE_RECORD_
1099 #define MPP_WRITE_RECORD_ write_record_r8( unit, field, size(data(:,:,:,:)), data, tstamp)
1100 #undef MPP_RANK_
1101 #define MPP_RANK_ (:,:,:,:)
1102 #include <mpp_write.fh>
1103 
1104 #undef MPP_WRITE_
1105 #define MPP_WRITE_ mpp_write_r0D_r4
1106 #undef MPP_TYPE_
1107 #define MPP_TYPE_ real(KIND=r4_kind)
1108 #undef MPP_RANK_
1109 #define MPP_RANK_ !
1110 #undef MPP_WRITE_RECORD_
1111 #define MPP_WRITE_RECORD_ write_record_r4( unit, field, 1, (/data/), tstamp)
1112 #include <mpp_write.fh>
1113 
1114 #undef MPP_WRITE_
1115 #define MPP_WRITE_ mpp_write_r1D_r4
1116 #undef MPP_TYPE_
1117 #define MPP_TYPE_ real(KIND=r4_kind)
1118 #undef MPP_WRITE_RECORD_
1119 #define MPP_WRITE_RECORD_ write_record_r4( unit, field, size(data(:)), data, tstamp)
1120 #undef MPP_RANK_
1121 #define MPP_RANK_ (:)
1122 #include <mpp_write.fh>
1123 
1124 #undef MPP_WRITE_
1125 #define MPP_WRITE_ mpp_write_r2D_r4
1126 #undef MPP_TYPE_
1127 #define MPP_TYPE_ real(KIND=r4_kind)
1128 #undef MPP_WRITE_RECORD_
1129 #define MPP_WRITE_RECORD_ write_record_r4( unit, field, size(data(:,:)), data, tstamp )
1130 #undef MPP_RANK_
1131 #define MPP_RANK_ (:,:)
1132 #include <mpp_write.fh>
1133 
1134 #undef MPP_WRITE_
1135 #define MPP_WRITE_ mpp_write_r3D_r4
1136 #undef MPP_TYPE_
1137 #define MPP_TYPE_ real(KIND=r4_kind)
1138 #undef MPP_WRITE_RECORD_
1139 #define MPP_WRITE_RECORD_ write_record_r4( unit, field, size(data(:,:,:)), data, tstamp)
1140 #undef MPP_RANK_
1141 #define MPP_RANK_ (:,:,:)
1142 #include <mpp_write.fh>
1143 
1144 #undef MPP_WRITE_
1145 #define MPP_WRITE_ mpp_write_r4D_r4
1146 #undef MPP_TYPE_
1147 #define MPP_TYPE_ real(KIND=r4_kind)
1148 #undef MPP_WRITE_RECORD_
1149 #define MPP_WRITE_RECORD_ write_record_r4( unit, field, size(data(:,:,:,:)), data, tstamp)
1150 #undef MPP_RANK_
1151 #define MPP_RANK_ (:,:,:,:)
1152 #include <mpp_write.fh>
1153 
1154  subroutine mpp_write_axis( unit, axis )
1155  integer, intent(in) :: unit
1156  type(axistype), intent(in) :: axis
1157  type(fieldtype) :: field
1158 
1159  call mpp_clock_begin(mpp_write_clock)
1160  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE: must first call mpp_io_init.' )
1161  if( .NOT. mpp_file(unit)%write_on_this_pe ) then
1162  call mpp_clock_end(mpp_write_clock)
1163  return
1164  endif
1165  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE: invalid unit number.' )
1166 !we convert axis to type(fieldtype) in order to call write_record
1167  field = default_field
1168  allocate( field%axes(1) )
1169  field%axes(1) = axis
1170  allocate( field%size(1) )
1171  field%size(1) = axis%len
1172  field%id = axis%id
1173 
1174  field%name = axis%name
1175  field%longname = axis%longname
1176  field%units = axis%units
1177 
1178  if(ASSOCIATED(axis%data))then
1179  allocate( field%axes(1)%data(size(axis%data) ))
1180  field%axes(1)%data = axis%data
1181  call write_record( unit, field, axis%len, axis%data )
1182  elseif(ASSOCIATED(axis%idata))then
1183  allocate( field%axes(1)%data(size(axis%idata) ))
1184  field%axes(1)%data = real(axis%idata)
1185  field%pack=4
1186  call write_record( unit, field, axis%len, real(axis%idata) )
1187  else
1188  call mpp_error( fatal, 'MPP_WRITE_AXIS: No data associated with axis.' )
1189  endif
1190 
1191  deallocate(field%axes(1)%data)
1192  deallocate(field%axes,field%size)
1193 
1194  call mpp_clock_end(mpp_write_clock)
1195  return
1196  end subroutine mpp_write_axis
1197 
1198 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1199 ! !
1200 ! MPP_COPY_META !
1201 ! !
1202 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1203  subroutine mpp_copy_meta_global( unit, gatt )
1204 !writes a global metadata attribute to unit <unit>
1205 !attribute <name> can be an real, integer or character
1206 !one and only one of rval, ival, and cval should be present
1207 !the first found will be used
1208 !for a non-netCDF file, it is encoded into a string "GLOBAL <name> <val>"
1209  integer, intent(in) :: unit
1210  type(atttype), intent(in) :: gatt
1211  integer :: len, error
1212 
1213  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META: must first call mpp_io_init.' )
1214  if( .NOT. mpp_file(unit)%write_on_this_pe )return
1215  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
1216  if( mpp_file(unit)%initialized ) then
1217 ! File has already been written to and needs to be returned to define mode.
1218 #ifdef use_netCDF
1219  error = nf_redef(mpp_file(unit)%ncid)
1220 #endif
1221  mpp_file(unit)%initialized = .false.
1222  endif
1223 ! call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
1224 #ifdef use_netCDF
1225  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
1226  if( gatt%type.EQ.nf_char )then
1227  len = gatt%len
1228  call write_attribute_netcdf( unit, nf_global, gatt%name, cval=gatt%catt(1:len) )
1229  else
1230  call write_attribute_netcdf( unit, nf_global, gatt%name, rval=gatt%fatt )
1231  endif
1232  else
1233  if( gatt%type.EQ.nf_char )then
1234  len=gatt%len
1235  call write_attribute( unit, 'GLOBAL '//trim(gatt%name), cval=gatt%catt(1:len) )
1236  else
1237  call write_attribute( unit, 'GLOBAL '//trim(gatt%name), rval=gatt%fatt )
1238  endif
1239  end if
1240 #else
1241  call mpp_error( fatal, 'MPP_READ currently requires use_netCDF option' )
1242 #endif
1243  return
1244  end subroutine mpp_copy_meta_global
1245 
1246  subroutine mpp_copy_meta_axis( unit, axis, domain )
1247 !load the values in an axistype (still need to call mpp_write)
1248 !write metadata attributes for axis. axis is declared inout
1249 !because the variable and dimension ids are altered
1250 
1251  integer, intent(in) :: unit
1252  type(axistype), intent(inout) :: axis
1253  type(domain1d), intent(in), optional :: domain
1254  character(len=512) :: text
1255  integer :: i, len, is, ie, isg, ieg, error
1256 
1257 ! call mpp_clock_begin(mpp_write_clock)
1258  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META: must first call mpp_io_init.' )
1259  if( .NOT. mpp_file(unit)%write_on_this_pe ) then
1260 ! call mpp_clock_end(mpp_write_clock)
1261  return
1262  endif
1263  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
1264  if( mpp_file(unit)%initialized ) then
1265 ! File has already been written to and needs to be returned to define mode.
1266 #ifdef use_netCDF
1267  error = nf_redef(mpp_file(unit)%ncid)
1268 #endif
1269  mpp_file(unit)%initialized = .false.
1270  endif
1271 ! call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
1272 
1273 ! redefine domain if present
1274  if( PRESENT(domain) )then
1275  axis%domain = domain
1276  else
1277  axis%domain = null_domain1d
1278  end if
1279 
1280 #ifdef use_netCDF
1281 !write metadata
1282  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
1283 
1284 !write axis def
1285  if( ASSOCIATED(axis%data) )then !space axis
1286  if( mpp_file(unit)%fileset.EQ.mpp_multi .AND. axis%domain.NE.null_domain1d )then
1287  call mpp_get_compute_domain( axis%domain, is, ie )
1288  call mpp_get_global_domain( axis%domain, isg, ieg )
1289  ie = ie + axis%shift
1290  ieg = ieg + axis%shift
1291  error = nf_def_dim( mpp_file(unit)%ncid, axis%name, ie-is+1, axis%did )
1292  else
1293  error = nf_def_dim( mpp_file(unit)%ncid, axis%name, size(axis%data(:)), axis%did )
1294  end if
1295  call netcdf_err( error, mpp_file(unit), axis )
1296  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_float, 1, (/axis%did/), axis%id )
1297  call netcdf_err( error, mpp_file(unit), axis )
1298  else !time axis
1299  error = nf_def_dim( mpp_file(unit)%ncid, axis%name, nf_unlimited, axis%did )
1300  call netcdf_err( error, mpp_file(unit), axis )
1301  error = nf_def_var( mpp_file(unit)%ncid, axis%name, nf_double, 1, (/axis%did/), axis%id )
1302  call netcdf_err( error, mpp_file(unit), axis )
1303  mpp_file(unit)%id = axis%id !file ID is the same as time axis varID
1304  mpp_file(unit)%recdimid = axis%did ! record dimension id
1305  end if
1306  else
1307  varnum = varnum + 1
1308  axis%id = varnum
1309  axis%did = varnum
1310 !write axis def
1311  write( text, '(a,i4,a)' )'AXIS ', axis%id, ' name'
1312  call write_attribute( unit, trim(text), cval=axis%name )
1313  write( text, '(a,i4,a)' )'AXIS ', axis%id, ' size'
1314  if( ASSOCIATED(axis%data) )then !space axis
1315  if( mpp_file(unit)%fileset.EQ.mpp_multi .AND. axis%domain.NE.null_domain1d )then
1316  call mpp_get_compute_domain(axis%domain, is, ie)
1317  call write_attribute( unit, trim(text), ival=(/ie-is+1/) ) ! ??? is, ie is not initialized
1318  else
1319  call write_attribute( unit, trim(text), ival=(/size(axis%data(:))/) )
1320  end if
1321  else !time axis
1322  if( mpp_file(unit)%id.NE.-1 ) &
1323  call mpp_error( fatal, 'MPP_WRITE_META_AXIS: There is already a time axis for this file.' )
1324  call write_attribute( unit, trim(text), ival=(/0/) ) !a size of 0 indicates time axis
1325  mpp_file(unit)%id = axis%id
1326  end if
1327  end if
1328 !write axis attributes
1329 
1330  do i=1,axis%natt
1331  if( axis%Att(i)%name.NE.default_att%name )then
1332  if( axis%Att(i)%type.EQ.nf_char )then
1333  len = axis%Att(i)%len
1334  call mpp_write_meta( unit, axis%id, axis%Att(i)%name, cval=axis%Att(i)%catt(1:len) )
1335  else
1336  call mpp_write_meta( unit, axis%id, axis%Att(i)%name, rval=axis%Att(i)%fatt)
1337  endif
1338  endif
1339  enddo
1340 
1341  if( mpp_file(unit)%threading.EQ.mpp_multi .AND. mpp_file(unit)%fileset.EQ.mpp_multi &
1342  .AND. axis%domain.NE.null_domain1d )then
1343  call mpp_write_meta( unit, axis%id, 'domain_decomposition', ival=(/isg,ieg,is,ie/) )
1344  end if
1345  if( verbose )print '(a,2i6,x,a,2i3)', &
1346  'MPP_WRITE_META: Wrote axis metadata, pe, unit, axis%name, axis%id, axis%did=', &
1347  pe, unit, trim(axis%name), axis%id, axis%did
1348 #else
1349  call mpp_error( fatal, 'MPP_READ currently requires use_netCDF option' )
1350 #endif
1351 ! call mpp_clock_end(mpp_write_clock)
1352  return
1353  end subroutine mpp_copy_meta_axis
1354 
1355  subroutine mpp_copy_meta_field( unit, field, axes )
1356 !useful for copying field metadata from a previous call to mpp_read_meta
1357 !define field: must have already called mpp_write_meta(axis) for each axis
1358  integer, intent(in) :: unit
1359  type(fieldtype), intent(inout) :: field
1360  type(axistype), intent(in), optional :: axes(:)
1361 !this array is required because of f77 binding on netCDF interface
1362  integer, allocatable :: axis_id(:)
1363  real :: a, b
1364  integer :: i, error
1365 
1366 ! call mpp_clock_begin(mpp_write_clock)
1367  if( .NOT.module_is_initialized )call mpp_error( fatal, 'MPP_WRITE_META: must first call mpp_io_init.' )
1368  if( .NOT. mpp_file(unit)%write_on_this_pe ) then
1369 ! call mpp_clock_end(mpp_write_clock)
1370  return
1371  endif
1372  if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'MPP_WRITE_META: invalid unit number.' )
1373  if( mpp_file(unit)%initialized ) then
1374 ! File has already been written to and needs to be returned to define mode.
1375 #ifdef use_netCDF
1376  error = nf_redef(mpp_file(unit)%ncid)
1377 #endif
1378  mpp_file(unit)%initialized = .false.
1379  endif
1380 ! call mpp_error( FATAL, 'MPP_WRITE_META: cannot write metadata to file after an mpp_write.' )
1381 
1382  if( field%pack.NE.1 .AND. field%pack.NE.2 )then
1383  if( field%pack.NE.4 .AND. field%pack.NE.8 ) &
1384  call mpp_error( fatal, 'MPP_WRITE_META_FIELD: only legal packing values are 1,2,4,8.' )
1385  end if
1386 
1387  if (PRESENT(axes)) then
1388  deallocate(field%axes)
1389  deallocate(field%size)
1390  allocate(field%axes(size(axes(:))))
1391  allocate(field%size(size(axes(:))))
1392  field%axes = axes
1393  do i=1,size(axes(:))
1394  if (ASSOCIATED(axes(i)%data)) then
1395  field%size(i) = size(axes(i)%data(:))
1396  else
1397  field%size(i) = 1
1398  field%time_axis_index = i
1399  endif
1400  enddo
1401  endif
1402 
1403  if( mpp_file(unit)%format.EQ.mpp_netcdf )then
1404 #ifdef use_netCDF
1405  allocate( axis_id(size(field%axes(:))) )
1406  do i = 1,size(field%axes(:))
1407  axis_id(i) = field%axes(i)%did
1408  end do
1409 !write field def
1410  select case (field%pack)
1411  case(1)
1412  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_double, &
1413  size(field%axes(:)), axis_id, field%id )
1414  case(2)
1415  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_float, &
1416  size(field%axes(:)), axis_id, field%id )
1417  case(4)
1418 ! if( field%scale.EQ.default_field%scale .OR. field%add.EQ.default_field%add ) &
1419 ! call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=4.' )
1420  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_short, &
1421  size(field%axes(:)), axis_id, field%id )
1422  case(8)
1423 ! if( field%scale.EQ.default_field%scale .OR. field%add.EQ.default_field%add ) &
1424 ! call mpp_error( FATAL, 'MPP_WRITE_META_FIELD: scale and add must be supplied when pack=8.' )
1425  error = nf_def_var( mpp_file(unit)%ncid, field%name, nf_byte, &
1426  size(field%axes(:)), axis_id, field%id )
1427  case default
1428  call mpp_error( fatal, 'MPP_WRITE_META_FIELD: only legal packing values are 1,2,4,8.' )
1429  end select
1430  deallocate( axis_id )
1431 #endif
1432  else
1433  varnum = varnum + 1
1434  field%id = varnum
1435  if( field%pack.NE.default_field%pack ) &
1436  call mpp_error( warning, 'MPP_WRITE_META: Packing is currently available only on netCDF files.' )
1437 !write field def
1438  write( text, '(a,i4,a)' )'FIELD ', field%id, ' name'
1439  call write_attribute( unit, trim(text), cval=field%name )
1440  write( text, '(a,i4,a)' )'FIELD ', field%id, ' axes'
1441  call write_attribute( unit, trim(text), ival=field%axes(:)%did )
1442  end if
1443 !write field attributes: these names follow netCDF conventions
1444  call mpp_write_meta( unit, field%id, 'long_name', cval=field%longname )
1445  if (lowercase(trim(field%units)).ne.'none' .OR. .NOT.cf_compliance) then
1446  call mpp_write_meta( unit, field%id, 'units', cval=field%units )
1447  endif
1448 !all real attributes must be written as packed
1449  if( (field%min.NE.default_field%min) .AND. (field%max.NE.default_field%max) )then
1450  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
1451  call mpp_write_meta( unit, field%id, 'valid_range', rval=(/field%min,field%max/), pack=field%pack )
1452  else
1453  a = nint((field%min-field%add)/field%scale)
1454  b = nint((field%max-field%add)/field%scale)
1455  call mpp_write_meta( unit, field%id, 'valid_range', rval=(/a, b /), pack=field%pack )
1456  end if
1457  else if( field%min.NE.default_field%min )then
1458  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
1459  call mpp_write_meta( unit, field%id, 'valid_min', rval=field%min, pack=field%pack )
1460  else
1461  a = nint((field%min-field%add)/field%scale)
1462  call mpp_write_meta( unit, field%id, 'valid_min', rval=a, pack=field%pack )
1463  end if
1464  else if( field%max.NE.default_field%max )then
1465  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
1466  call mpp_write_meta( unit, field%id, 'valid_max', rval=field%max, pack=field%pack )
1467  else
1468  a = nint((field%max-field%add)/field%scale)
1469  call mpp_write_meta( unit, field%id, 'valid_max', rval=a, pack=field%pack )
1470  end if
1471  end if
1472  if( field%missing.NE.default_field%missing )then
1473  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
1474  call mpp_write_meta( unit, field%id, 'missing_value', rval=field%missing, pack=field%pack )
1475  else
1476  a = nint((field%missing-field%add)/field%scale)
1477  call mpp_write_meta( unit, field%id, 'missing_value', rval=a, pack=field%pack )
1478  end if
1479  end if
1480  if( field%fill.NE.default_field%fill )then
1481  if( field%pack.EQ.1 .OR. field%pack.EQ.2 )then
1482  call mpp_write_meta( unit, field%id, '_FillValue', rval=field%missing, pack=field%pack )
1483  else
1484  a = nint((field%fill-field%add)/field%scale)
1485  call mpp_write_meta( unit, field%id, '_FillValue', rval=a, pack=field%pack )
1486  end if
1487  end if
1488  if( field%pack.NE.1 .AND. field%pack.NE.2 )then
1489  call mpp_write_meta( unit, field%id, 'packing', ival=field%pack )
1490  if( field%scale.NE.default_field%scale ) &
1491  call mpp_write_meta( unit, field%id, 'scale_factor', rval=field%scale )
1492  if( field%add.NE.default_field%add ) &
1493  call mpp_write_meta( unit, field%id, 'add_offset', rval=field%add )
1494  end if
1495  if( verbose )print '(a,2i6,x,a,i3)', 'MPP_WRITE_META: Wrote field metadata: pe, unit, field%name, field%id=', &
1496  pe, unit, trim(field%name), field%id
1497 
1498 ! call mpp_clock_end(mpp_write_clock)
1499  return
1500  end subroutine mpp_copy_meta_field
1501 
1502  subroutine mpp_modify_axis_meta( axis, name, units, longname, cartesian, data )
1503 
1504  type(axistype), intent(inout) :: axis
1505  character(len=*), intent(in), optional :: name, units, longname, cartesian
1506  real, dimension(:), intent(in), optional :: data
1507 
1508  if (PRESENT(name)) axis%name = trim(name)
1509  if (PRESENT(units)) axis%units = trim(units)
1510  if (PRESENT(longname)) axis%longname = trim(longname)
1511  if (PRESENT(cartesian)) axis%cartesian = trim(cartesian)
1512  if (PRESENT(data)) then
1513  axis%len = size(data(:))
1514  if (ASSOCIATED(axis%data)) deallocate(axis%data)
1515  allocate(axis%data(axis%len))
1516  axis%data = data
1517  endif
1518 
1519  return
1520  end subroutine mpp_modify_axis_meta
1521 
1522  subroutine mpp_modify_field_meta( field, name, units, longname, min, max, missing, axes )
1523 
1524  type(fieldtype), intent(inout) :: field
1525  character(len=*), intent(in), optional :: name, units, longname
1526  real, intent(in), optional :: min, max, missing
1527  type(axistype), dimension(:), intent(inout), optional :: axes
1528 
1529  if (PRESENT(name)) field%name = trim(name)
1530  if (PRESENT(units)) field%units = trim(units)
1531  if (PRESENT(longname)) field%longname = trim(longname)
1532  if (PRESENT(min)) field%min = min
1533  if (PRESENT(max)) field%max = max
1534  if (PRESENT(missing)) field%missing = missing
1535 ! if (PRESENT(axes)) then
1536 ! axis%len = size(data(:))
1537 ! deallocate(axis%data)
1538 ! allocate(axis%data(axis%len))
1539 ! axis%data = data
1540 ! endif
1541 
1542  return
1543  end subroutine mpp_modify_field_meta
1544 
1545 
1546 !> \brief Fills in a fieldtype variable, and is used with the diag_manager when using
1547 !! fms2_io
1548  subroutine fillin_fieldtype(field, axes, name, units, longname,&
1549  min, max, missing, fill, scale, add, pack, time_method, standard_name, checksum)
1550 !define field: must have already called mpp_write_meta(axis) for each axis
1551  type(fieldtype), intent(inout) :: field
1552  type(axistype), intent(in) :: axes(:)
1553  character(len=*), intent(in) :: name, units, longname
1554  real, intent(in), optional :: min, max, missing, fill, scale, add
1555  integer, intent(in), optional :: pack
1556  character(len=*), intent(in), optional :: time_method
1557  character(len=*), intent(in), optional :: standard_name
1558  integer(i8_kind), dimension(:), intent(in), optional :: checksum
1559 !this array is required because of f77 binding on netCDF interface
1560  integer, allocatable :: axis_id(:)
1561  real :: a, b
1562  integer :: i, istat, ishift, jshift
1563  character(len=64) :: checksum_char
1564 
1565 ! call mpp_clock_begin(mpp_write_clock)
1566 
1567  !--- figure out the location of data, this is needed in mpp_write.
1568  !--- for NON-symmetry domain, the position is not an issue.
1569  !--- we may need to rethink how to address the symmetric issue.
1570  ishift = 0; jshift = 0
1571  do i = 1, size(axes(:))
1572  select case ( lowercase( axes(i)%cartesian ) )
1573  case ( 'x' )
1574  ishift = axes(i)%shift
1575  case ( 'y' )
1576  jshift = axes(i)%shift
1577  end select
1578  end do
1579 
1580  field%position = center
1581  if(ishift == 1 .AND. jshift == 1) then
1582  field%position = corner
1583  else if(ishift == 1) then
1584  field%position = east
1585  else if(jshift == 1) then
1586  field%position = north
1587  endif
1588 
1589 !pre-existing pointers need to be nullified
1590  if( ASSOCIATED(field%axes) ) DEALLOCATE(field%axes, stat=istat)
1591  if( ASSOCIATED(field%size) ) DEALLOCATE(field%size, stat=istat)
1592 !fill in field metadata
1593  field%name = name
1594  field%units = units
1595  field%longname = longname
1596  allocate( field%axes(size(axes(:))) )
1597  field%axes = axes
1598  field%ndim = size(axes(:))
1599  field%time_axis_index = -1 !this value will never match any axis index
1600 !size is buffer area for the corresponding axis info: it is required to buffer this info in the fieldtype
1601 !because axis might be reused in different files
1602  allocate( field%size(size(axes(:))) )
1603  do i = 1,size(axes(:))
1604  if( ASSOCIATED(axes(i)%data) )then !space axis
1605  field%size(i) = size(axes(i)%data(:))
1606  else !time
1607  field%size(i) = 1
1608  field%time_axis_index = i
1609  end if
1610  end do
1611 !attributes
1612  if( PRESENT(min) ) field%min = min
1613  if( PRESENT(max) ) field%max = max
1614  if( PRESENT(scale) ) field%scale = scale
1615  if( PRESENT(add) ) field%add = add
1616  if( PRESENT(standard_name)) field%standard_name = standard_name
1617  if( PRESENT(missing) ) field%missing = missing
1618  if( PRESENT(fill) ) field%fill = fill
1619  field%checksum = 0
1620  if( PRESENT(checksum) ) field%checksum(1:size(checksum)) = checksum(:)
1621 
1622  ! Issue warning if fill and missing are different
1623  if ( (present(fill).and.present(missing)) .and. (field%missing .ne. field%fill) ) then
1624  call mpp_error(warning, 'MPP_WRITE_META: NetCDF attributes _FillValue and missing_value should be equal.')
1625  end if
1626 !pack is currently used only for netCDF
1627  field%pack = 2 !default write 32-bit floats
1628  if( PRESENT(pack) )field%pack = pack
1629 
1630  return
1631  end subroutine fillin_fieldtype
1632 !> @}
mpp_get_io_domain
type(domain2d) function, pointer mpp_get_io_domain(domain)
Set user stack size.
Definition: mpp_domains_util.inc:712
fillin_fieldtype
subroutine fillin_fieldtype(field, axes, name, units, longname, min, max, missing, fill, scale, add, pack, time_method, standard_name, checksum)
Fills in a fieldtype variable, and is used with the diag_manager when using fms2_io.
Definition: mpp_io_write.inc:1550
mpp_write_meta_global
subroutine mpp_write_meta_global(unit, name, rval, ival, cval, pack)
Writes a global metadata attribute to unit <unit> attribute <name> can be an real,...
Definition: mpp_io_write.inc:35