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