FMS 2025.01-dev
Flexible Modeling System
Loading...
Searching...
No Matches
mpp_io_read.inc
1! -*-f90-*-
2
3!***********************************************************************
4!* GNU Lesser General Public License
5!*
6!* This file is part of the GFDL Flexible Modeling System (FMS).
7!*
8!* FMS is free software: you can redistribute it and/or modify it under
9!* the terms of the GNU Lesser General Public License as published by
10!* the Free Software Foundation, either version 3 of the License, or (at
11!* your option) any later version.
12!*
13!* FMS is distributed in the hope that it will be useful, but WITHOUT
14!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16!* for more details.
17!*
18!* You should have received a copy of the GNU Lesser General Public
19!* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
20!***********************************************************************
21!> @file
22!> @brief Parallel file read routines for structured grids for use in @ref mpp_io_mod
23
24!> @addtogroup mpp_io_mod
25!> @{
26
27!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28! !
29! MPP_READ !
30! !
31!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
32
33#undef MPP_READ_2DDECOMP_2D_
34#undef READ_RECORD_CORE_
35#define READ_RECORD_CORE_ read_record_core_r8
36#undef READ_RECORD_
37#define READ_RECORD_ read_record_r8
38#define MPP_READ_2DDECOMP_2D_ mpp_read_2ddecomp_r2d_r8
39#undef MPP_READ_2DDECOMP_3D_
40#define MPP_READ_2DDECOMP_3D_ mpp_read_2ddecomp_r3d_r8
41#undef MPP_READ_2DDECOMP_4D_
42#define MPP_READ_2DDECOMP_4D_ mpp_read_2ddecomp_r4d_r8
43#undef MPP_TYPE_
44#define MPP_TYPE_ real(KIND=r8_kind)
45#include <mpp_read_2Ddecomp.fh>
46
47#undef READ_RECORD_CORE_
48#define READ_RECORD_CORE_ read_record_core_r4
49#undef READ_RECORD_
50#define READ_RECORD_ read_record_r4
51#undef MPP_READ_2DDECOMP_2D_
52#define MPP_READ_2DDECOMP_2D_ mpp_read_2ddecomp_r2d_r4
53#undef MPP_READ_2DDECOMP_3D_
54#define MPP_READ_2DDECOMP_3D_ mpp_read_2ddecomp_r3d_r4
55#undef MPP_READ_2DDECOMP_4D_
56#define MPP_READ_2DDECOMP_4D_ mpp_read_2ddecomp_r4d_r4
57#undef MPP_TYPE_
58#define MPP_TYPE_ real(KIND=r4_kind)
59#include <mpp_read_2Ddecomp.fh>
60
61#undef READ_RECORD_
62#define READ_RECORD_ read_record_r8
63#undef MPP_READ_COMPRESSED_1D_
64#define MPP_READ_COMPRESSED_1D_ mpp_read_compressed_r1d_r8
65#undef MPP_READ_COMPRESSED_2D_
66#define MPP_READ_COMPRESSED_2D_ mpp_read_compressed_r2d_r8
67#undef MPP_READ_COMPRESSED_3D_
68#define MPP_READ_COMPRESSED_3D_ mpp_read_compressed_r3d_r8
69#undef MPP_TYPE_
70#define MPP_TYPE_ real(KIND=r8_kind)
71#include <mpp_read_compressed.fh>
72
73#undef READ_RECORD_
74#define READ_RECORD_ read_record_r4
75#undef MPP_READ_COMPRESSED_1D_
76#define MPP_READ_COMPRESSED_1D_ mpp_read_compressed_r1d_r4
77#undef MPP_READ_COMPRESSED_2D_
78#define MPP_READ_COMPRESSED_2D_ mpp_read_compressed_r2d_r4
79#undef MPP_READ_COMPRESSED_3D_
80#define MPP_READ_COMPRESSED_3D_ mpp_read_compressed_r3d_r4
81#undef MPP_TYPE_
82#define MPP_TYPE_ real(KIND=r4_kind)
83#include <mpp_read_compressed.fh>
84
85#include <mpp_read_distributed_ascii.inc>
86
87! <SUBROUTINE NAME="mpp_read_r4D_r8" INTERFACE="mpp_read">
88! <IN NAME="unit" TYPE="integer"></IN>
89! <IN NAME="field" TYPE="type(fieldtype)"></IN>
90! <INOUT NAME="data" TYPE="real(KIND=r8_kind)" DIM="(:,:,:,:)"></INOUT>
91! <IN NAME="tindex" TYPE="integer"></IN>
92! </SUBROUTINE>
93 subroutine mpp_read_r4d_r8( unit, field, data, tindex)
94 integer, intent(in) :: unit
95 type(fieldtype), intent(in) :: field
96 real(KIND=r8_kind), intent(inout) :: data(:,:,:,:)
97 integer, intent(in), optional :: tindex
98
99 call read_record_r8( unit, field, size(data(:,:,:,:)), data, tindex )
100 end subroutine mpp_read_r4d_r8
101
102
103! <SUBROUTINE NAME="mpp_read_r3D_r8" INTERFACE="mpp_read">
104! <IN NAME="unit" TYPE="integer"></IN>
105! <IN NAME="field" TYPE="type(fieldtype)"></IN>
106! <INOUT NAME="data" TYPE="real(KIND=r8_kind)" DIM="(:,:,:)"></INOUT>
107! <IN NAME="tindex" TYPE="integer"></IN>
108! </SUBROUTINE>
109 subroutine mpp_read_r3d_r8( unit, field, data, tindex)
110 integer, intent(in) :: unit
111 type(fieldtype), intent(in) :: field
112 real(KIND=r8_kind), intent(inout) :: data(:,:,:)
113 integer, intent(in), optional :: tindex
114
115 call read_record_r8( unit, field, size(data(:,:,:)), data, tindex )
116 end subroutine mpp_read_r3d_r8
117
118! <SUBROUTINE NAME="mpp_read_r2D_r8" INTERFACE="mpp_read">
119! <IN NAME="unit" TYPE="integer"></IN>
120! <IN NAME="field" TYPE="type(fieldtype)"></IN>
121! <INOUT NAME="data" TYPE="real(KIND=r8_kind)" DIM="(:,:,:)"></INOUT>
122! <IN NAME="tindex" TYPE="integer"></IN>
123! </SUBROUTINE>
124 subroutine mpp_read_r2d_r8( unit, field, data, tindex )
125 integer, intent(in) :: unit
126 type(fieldtype), intent(in) :: field
127 real(KIND=r8_kind), intent(inout) :: data(:,:)
128 integer, intent(in), optional :: tindex
129
130 call read_record_r8( unit, field, size(data(:,:)), data, tindex )
131 end subroutine mpp_read_r2d_r8
132
133! <SUBROUTINE NAME="mpp_read_r1D_r8" INTERFACE="mpp_read">
134! <IN NAME="unit" TYPE="integer"></IN>
135! <IN NAME="field" TYPE="type(fieldtype)"></IN>
136! <INOUT NAME="data" TYPE="real(KIND=r8_kind)" DIM="(:,:,:)"></INOUT>
137! <IN NAME="tindex" TYPE="integer"></IN>
138! </SUBROUTINE>
139 subroutine mpp_read_r1d_r8( unit, field, data, tindex )
140 integer, intent(in) :: unit
141 type(fieldtype), intent(in) :: field
142 real(KIND=r8_kind), intent(inout) :: data(:)
143 integer, intent(in), optional :: tindex
144
145 call read_record_r8( unit, field, size(data(:)), data, tindex )
146 end subroutine mpp_read_r1d_r8
147
148! <SUBROUTINE NAME="mpp_read_r0D_r8" INTERFACE="mpp_read">
149! <IN NAME="unit" TYPE="integer"></IN>
150! <IN NAME="field" TYPE="type(fieldtype)"></IN>
151! <INOUT NAME="data" TYPE="real(KIND=r8_kind)" DIM="(:,:,:)"></INOUT>
152! <IN NAME="tindex" TYPE="integer"></IN>
153! </SUBROUTINE>
154 subroutine mpp_read_r0d_r8( unit, field, data, tindex )
155 integer, intent(in) :: unit
156 type(fieldtype), intent(in) :: field
157 real(KIND=r8_kind), intent(inout) :: data
158 integer, intent(in), optional :: tindex
159 real(KIND=r8_kind), dimension(1) :: data_tmp
160
161 data_tmp(1)=data
162 call read_record_r8( unit, field, 1, data_tmp, tindex )
163 data=data_tmp(1)
164 end subroutine mpp_read_r0d_r8
165
166! <SUBROUTINE NAME="mpp_read_r4D_r4" INTERFACE="mpp_read">
167! <IN NAME="unit" TYPE="integer"></IN>
168! <IN NAME="field" TYPE="type(fieldtype)"></IN>
169! <INOUT NAME="data" TYPE="real(KIND=r8_kind)" DIM="(:,:,:,:)"></INOUT>
170! <IN NAME="tindex" TYPE="integer"></IN>
171! </SUBROUTINEr4
172 subroutine mpp_read_r4d_r4( unit, field, data, tindex)
173 integer, intent(in) :: unit
174 type(fieldtype), intent(in) :: field
175 real(KIND=r4_kind), intent(inout) :: data(:,:,:,:)
176 integer, intent(in), optional :: tindex
177
178 call read_record_r4( unit, field, size(data(:,:,:,:)), data, tindex )
179 end subroutine mpp_read_r4d_r4
180
181
182! <SUBROUTINE NAME="mpp_read_r3D_r4" INTERFACE="mpp_read">
183! <IN NAME="unit" TYPE="integer"></IN>
184! <IN NAME="field" TYPE="type(fieldtype)"></IN>
185! <INOUT NAME="data" TYPE="real(KIND=r4_kind)" DIM="(:,:,:)"></INOUT>
186! <IN NAME="tindex" TYPE="integer"></IN>
187! </SUBROUTINE>
188 subroutine mpp_read_r3d_r4( unit, field, data, tindex)
189 integer, intent(in) :: unit
190 type(fieldtype), intent(in) :: field
191 real(KIND=r4_kind), intent(inout) :: data(:,:,:)
192 integer, intent(in), optional :: tindex
193
194 call read_record_r4( unit, field, size(data(:,:,:)), data, tindex )
195 end subroutine mpp_read_r3d_r4
196
197! <SUBROUTINE NAME="mpp_read_r2D_r4" INTERFACE="mpp_read">
198! <IN NAME="unit" TYPE="integer"></IN>
199! <IN NAME="field" TYPE="type(fieldtype)"></IN>
200! <INOUT NAME="data" TYPE="real(KIND=r4_kind)" DIM="(:,:,:)"></INOUT>
201! <IN NAME="tindex" TYPE="integer"></IN>
202! </SUBROUTINE>
203 subroutine mpp_read_r2d_r4( unit, field, data, tindex )
204 integer, intent(in) :: unit
205 type(fieldtype), intent(in) :: field
206 real(KIND=r4_kind), intent(inout) :: data(:,:)
207 integer, intent(in), optional :: tindex
208
209 call read_record_r4( unit, field, size(data(:,:)), data, tindex )
210 end subroutine mpp_read_r2d_r4
211
212! <SUBROUTINE NAME="mpp_read_r1D_r4" INTERFACE="mpp_read">
213! <IN NAME="unit" TYPE="integer"></IN>
214! <IN NAME="field" TYPE="type(fieldtype)"></IN>
215! <INOUT NAME="data" TYPE="real(KIND=r4_kind)" DIM="(:,:,:)"></INOUT>
216! <IN NAME="tindex" TYPE="integer"></IN>
217! </SUBROUTINE>
218 subroutine mpp_read_r1d_r4( unit, field, data, tindex )
219 integer, intent(in) :: unit
220 type(fieldtype), intent(in) :: field
221 real(KIND=r4_kind), intent(inout) :: data(:)
222 integer, intent(in), optional :: tindex
223
224 call read_record_r4( unit, field, size(data(:)), data, tindex )
225 end subroutine mpp_read_r1d_r4
226
227! <SUBROUTINE NAME="mpp_read_r0D_r4" INTERFACE="mpp_read">
228! <IN NAME="unit" TYPE="integer"></IN>
229! <IN NAME="field" TYPE="type(fieldtype)"></IN>
230! <INOUT NAME="data" TYPE="real(KIND=r4_kind)" DIM="(:,:,:)"></INOUT>
231! <IN NAME="tindex" TYPE="integer"></IN>
232! </SUBROUTINE>
233 subroutine mpp_read_r0d_r4( unit, field, data, tindex )
234 integer, intent(in) :: unit
235 type(fieldtype), intent(in) :: field
236 real(KIND=r4_kind), intent(inout) :: data
237 integer, intent(in), optional :: tindex
238 real(KIND=r4_kind), dimension(1) :: data_tmp
239
240 data_tmp(1)=data
241 call read_record_r4( unit, field, 1, data_tmp, tindex )
242 data=data_tmp(1)
243 end subroutine mpp_read_r0d_r4
244
245 subroutine mpp_read_region_r2d_r4(unit, field, data, start, nread)
246 integer, intent(in) :: unit
247 type(fieldtype), intent(in) :: field
248 real(KIND=r4_kind), intent(inout) :: data(:,:)
249 integer, intent(in) :: start(:), nread(:)
250
251 if(size(start(:)) .NE. 4 .OR. size(nread(:)) .NE. 4) call mpp_error(fatal, &
252 "mpp_io_read.inc(mpp_read_region_r2D_r4): size of start and nread must be 4")
253
254 if(size(data,1) .NE. nread(1) .OR. size(data,2) .NE. nread(2)) then
255 call mpp_error( fatal, 'mpp_io_read.inc(mpp_read_region_r2D_r4): size mismatch between data and nread')
256 endif
257 if(nread(3) .NE. 1 .OR. nread(4) .NE. 1) call mpp_error(fatal, &
258 "mpp_io_read.inc(mpp_read_region_r2D_r4): nread(3) and nread(4) must be 1")
259 call read_record_core_r4(unit, field, nread(1)*nread(2), data, start, nread)
260
261 return
262
263
264 end subroutine mpp_read_region_r2d_r4
265
266 subroutine mpp_read_region_r3d_r4(unit, field, data, start, nread)
267 integer, intent(in) :: unit
268 type(fieldtype), intent(in) :: field
269 real(KIND=r4_kind), intent(inout) :: data(:,:,:)
270 integer, intent(in) :: start(:), nread(:)
271
272 if(size(start(:)) .NE. 4 .OR. size(nread(:)) .NE. 4) call mpp_error(fatal, &
273 "mpp_io_read.inc(mpp_read_region_r3D_r4): size of start and nread must be 4")
274
275 if(size(data,1) .NE. nread(1) .OR. size(data,2) .NE. nread(2) .OR. size(data,3) .NE. nread(3) ) then
276 call mpp_error( fatal, 'mpp_io_read.inc(mpp_read_region_r3D_r4): size mismatch between data and nread')
277 endif
278 if(nread(4) .NE. 1) call mpp_error(fatal, &
279 "mpp_io_read.inc(mpp_read_region_r3D_r4): nread(4) must be 1")
280 call read_record_core_r4(unit, field, nread(1)*nread(2)*nread(3), data, start, nread)
281
282 return
283 end subroutine mpp_read_region_r3d_r4
284
285 subroutine mpp_read_region_r2d_r8(unit, field, data, start, nread)
286 integer, intent(in) :: unit
287 type(fieldtype), intent(in) :: field
288 real(kind=r8_kind), intent(inout) :: data(:,:)
289 integer, intent(in) :: start(:), nread(:)
290
291 if(size(start(:)) .NE. 4 .OR. size(nread(:)) .NE. 4) call mpp_error(fatal, &
292 "mpp_io_read.inc(mpp_read_region_r2D_r8): size of start and nread must be 4")
293
294 if(size(data,1).NE.nread(1) .OR. size(data,2).NE.nread(2)) then
295 call mpp_error( fatal, 'mpp_io_read.inc(mpp_read_region_r2D_r8): size mismatch between data and nread')
296 endif
297 if(nread(3) .NE. 1 .OR. nread(4) .NE. 1) call mpp_error(fatal, &
298 "mpp_io_read.inc(mpp_read_region_r2D_r8): nread(3) and nread(4) must be 1")
299 call read_record_core_r8(unit, field, nread(1)*nread(2), data, start, nread)
300
301 return
302 end subroutine mpp_read_region_r2d_r8
303
304 subroutine mpp_read_region_r3d_r8(unit, field, data, start, nread)
305 integer, intent(in) :: unit
306 type(fieldtype), intent(in) :: field
307 real(kind=r8_kind), intent(inout) :: data(:,:,:)
308 integer, intent(in) :: start(:), nread(:)
309
310 if(size(start(:)) .NE. 4 .OR. size(nread(:)) .NE. 4) call mpp_error(fatal, &
311 "mpp_io_read.inc(mpp_read_region_r3D_r8): size of start and nread must be 4")
312
313 if(size(data,1).NE.nread(1) .OR. size(data,2).NE.nread(2) .OR. size(data,3).NE.nread(3) ) then
314 call mpp_error( fatal, 'mpp_io_read.inc(mpp_read_region_r3D_r8): size mismatch between data and nread')
315 endif
316 if(nread(4) .NE. 1) call mpp_error(fatal, &
317 "mpp_io_read.inc(mpp_read_region_r3D_r8): nread(4) must be 1")
318 call read_record_core_r8(unit, field, nread(1)*nread(2)*nread(3), data, start, nread)
319
320 return
321 end subroutine mpp_read_region_r3d_r8
322
323
324 !--- Assume the text field is at most two-dimensional
325 !--- the level is always for the first dimension
326 subroutine mpp_read_text( unit, field, data, level )
327 integer, intent(in) :: unit
328 type(fieldtype), intent(in) :: field
329 character(len=*), intent(inout) :: data
330 integer, intent(in), optional :: level
331 integer :: lev, n
332 character(len=256) :: error_msg
333 integer, dimension(size(field%axes(:))) :: start, axsiz
334 character(len=len(data)) :: text
335
336#ifdef use_netCDF
337 if( .NOT.module_is_initialized )call mpp_error( fatal, 'READ_RECORD: must first call mpp_io_init.' )
338 if( .NOT.mpp_file(unit)%opened )call mpp_error( fatal, 'READ_RECORD: invalid unit number.' )
339 if( mpp_file(unit)%threading.EQ.mpp_single .AND. pe.NE.mpp_root_pe() )return
340
341 if( .NOT.mpp_file(unit)%initialized ) call mpp_error( fatal, 'MPP_READ: must first call mpp_read_meta.' )
342 lev = 1
343 if(present(level)) lev = level
344
345 if( verbose )print '(a,2i6,2i5)', 'MPP_READ: PE, unit, %id, level =', pe, unit, mpp_file(unit)%id, lev
346
347 if( mpp_file(unit)%format.EQ.mpp_netcdf )then
348 start = 1
349 axsiz(:) = field%size(:)
350 if(len(data) < field%size(1) ) call mpp_error(fatal, &
351 'mpp_io(mpp_read_text): the first dimension size is greater than data length')
352 select case( field%ndim)
353 case(1)
354 if(lev .NE. 1) call mpp_error(fatal,'mpp_io(mpp_read_text): level should be 1 when ndim is 1')
355 case(2)
356 if(lev<1 .OR. lev > field%size(2)) then
357 write(error_msg,'(I5,"/",I5)') lev, field%size(2)
358 call mpp_error(fatal,'mpp_io(mpp_read_text): level out of range, level/max_level='//trim(error_msg))
359 end if
360 start(2) = lev
361 axsiz(2) = 1
362 case default
363 call mpp_error( fatal, 'MPP_READ: ndim of text field should be at most 2')
364 end select
365
366 if( verbose )print '(a,2i6,i6,12i4)', 'mpp_read_text: PE, unit, num_words, start, axsiz=', &
367 & pe, unit, len(data), start, axsiz
368
369 select case (field%type)
370 case(nf_char)
371 if(field%ndim==1) then
372 error = nf_get_var_text(mpp_file(unit)%ncid, field%id, text)
373 else
374 error = nf_get_vara_text(mpp_file(unit)%ncid, field%id, start, axsiz, text)
375 end if
376 call netcdf_err( error, mpp_file(unit), field=field )
377 do n = 1, len_trim(text)
378 if(text(n:n) == char(0) ) exit
379 end do
380 n = n-1
381 data = text(1:n)
382 case default
383 call mpp_error( fatal, 'mpp_read_text: the field type should be NF_CHAR' )
384 end select
385 else !non-netCDF
386 call mpp_error( fatal, 'Currently dont support non-NetCDF mpp read' )
387
388 end if
389#else
390 call mpp_error( fatal, 'mpp_read_text currently requires use_netCDF option' )
391#endif
392 return
393 end subroutine mpp_read_text
394
395! <SUBROUTINE NAME="mpp_read_meta">
396
397! <OVERVIEW>
398! Read metadata.
399! </OVERVIEW>
400! <DESCRIPTION>
401! This routine is used to read the <LINK SRC="#metadata">metadata</LINK>
402! describing the contents of a file. Each file can contain any number of
403! fields, which are functions of 0-3 space axes and 0-1 time axes. (Only
404! one time axis can be defined per file). The basic metadata defined <LINK
405! SRC="#metadata">above</LINK> for <TT>axistype</TT> and
406! <TT>fieldtype</TT> are stored in <TT>mpp_io_mod</TT> and
407! can be accessed outside of <TT>mpp_io_mod</TT> using calls to
408! <TT>mpp_get_info</TT>, <TT>mpp_get_atts</TT>,
409! <TT>mpp_get_vars</TT> and
410! <TT>mpp_get_times</TT>.
411! </DESCRIPTION>
412! <TEMPLATE>
413! call mpp_read_meta(unit)
414! </TEMPLATE>
415! <IN NAME="unit" TYPE="integer"> </IN>
416! <NOTE>
417! <TT>mpp_read_meta</TT> must be called prior to <TT>mpp_read</TT>.
418! </NOTE>
419! </SUBROUTINE>
420 subroutine mpp_read_meta(unit, read_time)
421!
422! read file attributes including dimension and variable attributes
423! and store in filetype structure. All of the file information
424! with the exception of the (variable) data is stored. Attributes
425! are supplied to the user by get_info,get_atts,get_axes and get_fields
426!
427! every PE is eligible to call mpp_read_meta
428!
429 integer, intent(in) :: unit
430 logical, intent(in), optional :: read_time ! read_time is set to false when file action is appending or writing.
431 ! This is temporary fix for MOM6 reopen_file issue.
432 integer :: ncid,ndim,nvar_total,natt,recdim,nv,nvar,len
433 integer :: error, i, j, istat, check_exist
434 integer :: type, nvdims, nvatts, dimid
435 integer, allocatable, dimension(:) :: dimids
436 character(len=128) :: name, attname, unlimname, attval, bounds_name
437 logical :: isdim, found_bounds, get_time_info
438 integer(i8_kind) :: checksumf
439 character(len=64) :: checksum_char
440 integer :: num_checksumf, last, is, k
441
442 integer(i2_kind), allocatable :: i2vals(:)
443 integer(i4_kind), allocatable :: ivals(:)
444 real(KIND=r4_kind), allocatable :: rvals(:)
445 real(KIND=r8_kind), allocatable :: r8vals(:)
446
447 get_time_info = .true.
448 if(present(read_time)) get_time_info = read_time
449
450#ifdef use_netCDF
451
452 if( mpp_file(unit)%format.EQ.mpp_netcdf )then
453 ncid = mpp_file(unit)%ncid
454 error = nf_inq(ncid,ndim, nvar_total,&
455 natt, recdim);call netcdf_err( error, mpp_file(unit) )
456
457
458 mpp_file(unit)%ndim = ndim
459 mpp_file(unit)%natt = natt
460 mpp_file(unit)%recdimid = recdim
461!
462! if no recdim exists, recdimid = -1
463! variable id of unlimdim and length
464!
465 if( recdim.NE.-1 )then
466 error = nf_inq_dim( ncid, recdim, unlimname, mpp_file(unit)%time_level )
467 call netcdf_err( error, mpp_file(unit) )
468 error = nf_inq_varid( ncid, unlimname, mpp_file(unit)%id )
469 call netcdf_err( error, mpp_file(unit), string='Field='//unlimname )
470 else
471 mpp_file(unit)%time_level = -1 ! set to zero so mpp_get_info returns ntime=0 if no time axis present
472 endif
473
474 allocate(mpp_file(unit)%Att(natt))
475 allocate(dimids(ndim))
476 allocate(mpp_file(unit)%Axis(ndim))
477
478!
479! initialize fieldtype and axis type
480!
481
482
483 do i=1,ndim
484 mpp_file(unit)%Axis(i) = default_axis
485 enddo
486
487 do i=1,natt
488 mpp_file(unit)%Att(i) = default_att
489 enddo
490
491!
492! assign global attributes
493!
494 do i=1,natt
495 error=nf_inq_attname(ncid,nf_global,i,name)
496 call netcdf_err( error, mpp_file(unit), string=' Global attribute error.' )
497 error=nf_inq_att(ncid,nf_global,trim(name),type,len);call netcdf_err( error, mpp_file(unit), &
498 string=' Attribute='//name )
499 mpp_file(unit)%Att(i)%name = name
500 mpp_file(unit)%Att(i)%len = len
501 mpp_file(unit)%Att(i)%type = type
502!
503! allocate space for att data and assign
504!
505 select case (type)
506 case (nf_char)
507 if (len.gt.max_att_length) then
508 call mpp_error(note,'GLOBAL ATT too long - not reading this metadata')
509 len=7
510 mpp_file(unit)%Att(i)%len=len
511 mpp_file(unit)%Att(i)%catt = 'unknown'
512 else
513 error=nf_get_att_text(ncid,nf_global,name,mpp_file(unit)%Att(i)%catt)
514 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%att(i) )
515 if (verbose.and.pe == 0) print *, 'GLOBAL ATT ',trim(name),' ',mpp_file(unit)%Att(i)%catt(1:len)
516 endif
517!
518! store integers in float arrays
519!
520 case (nf_short)
521 allocate(mpp_file(unit)%Att(i)%fatt(len), stat=istat)
522 if ( istat .ne. 0 ) then
523 write(text,'(A)') istat
524 call mpp_error(fatal, &
525 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Att%fatt, NF_SHORT case. "//&
526 & "STAT = "//trim(text))
527 end if
528 allocate(i2vals(len), stat=istat)
529 if ( istat .ne. 0 ) then
530 write(text,'(A)') istat
531 call mpp_error(fatal, &
532 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array i2vals. STAT = "&
533 & //trim(text))
534 end if
535 error=nf_get_att_int2(ncid,nf_global,name,i2vals)
536 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%att(i) )
537 if( verbose .and. pe == 0 )print *, 'GLOBAL ATT ',trim(name),' ',i2vals(1:len)
538 mpp_file(unit)%Att(i)%fatt(1:len)=i2vals(1:len)
539 deallocate(i2vals)
540 case (nf_int)
541 allocate(mpp_file(unit)%Att(i)%fatt(len), stat=istat)
542 if ( istat .ne. 0 ) then
543 write(text,'(A)') istat
544 call mpp_error(fatal, &
545 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Att%fatt, NF_INT case. "//&
546 & "STAT = "//trim(text))
547 end if
548 allocate(ivals(len), stat=istat)
549 if ( istat .ne. 0 ) then
550 write(text,'(A)') istat
551 call mpp_error(fatal, &
552 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array ivals. STAT = "&
553 & //trim(text))
554 end if
555 error=nf_get_att_int(ncid,nf_global,name,ivals)
556 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%att(i) )
557 if( verbose .and. pe == 0 )print *, 'GLOBAL ATT ',trim(name),' ',ivals(1:len)
558 mpp_file(unit)%Att(i)%fatt(1:len)=ivals(1:len)
559 if(lowercase(trim(name)) == 'time_axis' .and. ivals(1)==0) &
560 mpp_file(unit)%time_level = -1 ! This file is an unlimited axis restart
561 deallocate(ivals)
562 case (nf_float)
563 allocate(mpp_file(unit)%Att(i)%fatt(len), stat=istat)
564 if ( istat .ne. 0 ) then
565 write(text,'(A)') istat
566 call mpp_error(fatal, &
567 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Att%fatt, NF_FLOAT case. "//&
568 & "STAT = "//trim(text))
569 end if
570 allocate(rvals(len), stat=istat)
571 if ( istat .ne. 0 ) then
572 write(text,'(A)') istat
573 call mpp_error(fatal, &
574 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array rvals. STAT = "&
575 & //trim(text))
576 end if
577 error=nf_get_att_real(ncid,nf_global,name,rvals)
578 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%att(i) )
579 mpp_file(unit)%Att(i)%fatt(1:len)=rvals(1:len)
580 if( verbose .and. pe == 0)print *, 'GLOBAL ATT ',trim(name),' ',mpp_file(unit)%Att(i)%fatt(1:len)
581 deallocate(rvals)
582 case (nf_double)
583 allocate(mpp_file(unit)%Att(i)%fatt(len), stat=istat)
584 if ( istat .ne. 0 ) then
585 write(text,'(A)') istat
586 call mpp_error(fatal, &
587 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Att%fatt, NF_DOUBLE case. "//&
588 & "STAT = "//trim(text))
589 end if
590 allocate(r8vals(len), stat=istat)
591 if ( istat .ne. 0 ) then
592 write(text,'(A)') istat
593 call mpp_error(fatal, &
594 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array r8vals. STAT = "&
595 & //trim(text))
596 end if
597 error=nf_get_att_double(ncid,nf_global,name,r8vals)
598 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%att(i) )
599 mpp_file(unit)%Att(i)%fatt(1:len)=r8vals(1:len)
600 if( verbose .and. pe == 0)print *, 'GLOBAL ATT ',trim(name),' ',mpp_file(unit)%Att(i)%fatt(1:len)
601 deallocate(r8vals)
602 end select
603
604 enddo
605!
606! assign dimension name and length
607!
608 do i=1,ndim
609 error = nf_inq_dim(ncid,i,name,len);call netcdf_err( error, mpp_file(unit) )
610 mpp_file(unit)%Axis(i)%name = name
611 mpp_file(unit)%Axis(i)%len = len
612 enddo
613
614 nvar=0
615 do i=1, nvar_total
616 error=nf_inq_var(ncid,i,name,type,nvdims,dimids,nvatts);call netcdf_err( error, mpp_file(unit) )
617 isdim=.false.
618 do j=1,ndim
619 if( trim(lowercase(name)).EQ.trim(lowercase(mpp_file(unit)%Axis(j)%name)) )isdim=.true.
620 enddo
621 if (.not.isdim) nvar=nvar+1
622 enddo
623 mpp_file(unit)%nvar = nvar
624 allocate(mpp_file(unit)%Var(nvar))
625
626 do i=1,nvar
627 mpp_file(unit)%Var(i) = default_field
628 enddo
629
630!
631! assign dimension info
632!
633 do i=1, nvar_total
634 error=nf_inq_var(ncid,i,name,type,nvdims,dimids,nvatts);call netcdf_err( error, mpp_file(unit) )
635 isdim=.false.
636 do j=1,ndim
637 if( trim(lowercase(name)).EQ.trim(lowercase(mpp_file(unit)%Axis(j)%name)) )isdim=.true.
638 enddo
639
640 if( isdim )then
641 error=nf_inq_dimid(ncid,name,dimid);call netcdf_err( error, mpp_file(unit), string=' Axis='//name )
642 mpp_file(unit)%Axis(dimid)%type = type
643 mpp_file(unit)%Axis(dimid)%did = dimid
644 mpp_file(unit)%Axis(dimid)%id = i
645 mpp_file(unit)%Axis(dimid)%natt = nvatts
646 ! get axis values
647 if( i.NE.mpp_file(unit)%id )then ! non-record dims
648 select case (type)
649 case (nf_int)
650 len=mpp_file(unit)%Axis(dimid)%len
651 allocate(mpp_file(unit)%Axis(dimid)%data(len), stat=istat)
652 if ( istat .ne. 0 ) then
653 write(text,'(A)') istat
654 call mpp_error(fatal, &
655 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Axis%data, NF_INT case. "//&
656 & "STAT = "//trim(text))
657 end if
658 allocate(ivals(len), stat=istat)
659 if ( istat .ne. 0 ) then
660 write(text,'(A)') istat
661 call mpp_error(fatal, &
662 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array ivals. STAT = "&
663 & //trim(text))
664 end if
665 error = nf_get_var_int(ncid,i,ivals)
666 call netcdf_err( error, mpp_file(unit), mpp_file(unit)%Axis(dimid) )
667 mpp_file(unit)%Axis(dimid)%data(1:len)=ivals(1:len)
668 deallocate(ivals)
669 case (nf_float)
670 len=mpp_file(unit)%Axis(dimid)%len
671 allocate(mpp_file(unit)%Axis(dimid)%data(len), stat=istat)
672 if ( istat .ne. 0 ) then
673 write(text,'(A)') istat
674 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Axis%data, "//&
675 & "NF_FLOAT case. STAT = "//trim(text))
676 end if
677 allocate(rvals(len), stat=istat)
678 if ( istat .ne. 0 ) then
679 write(text,'(A)') istat
680 call mpp_error(fatal, &
681 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array rvals. STAT = "&
682 & //trim(text))
683 end if
684 error = nf_get_var_real(ncid,i,rvals)
685 call netcdf_err( error, mpp_file(unit), mpp_file(unit)%Axis(dimid) )
686 mpp_file(unit)%Axis(dimid)%data(1:len)=rvals(1:len)
687 deallocate(rvals)
688 case (nf_double)
689 len=mpp_file(unit)%Axis(dimid)%len
690 allocate(mpp_file(unit)%Axis(dimid)%data(len), stat=istat)
691 if ( istat .ne. 0 ) then
692 write(text,'(A)') istat
693 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Axis%data, "//&
694 & "NF_DOUBLE case. STAT = "//trim(text))
695 end if
696 allocate(r8vals(len), stat=istat)
697 if ( istat .ne. 0 ) then
698 write(text,'(A)') istat
699 call mpp_error(fatal, &
700 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array r8vals. STAT = "&
701 & //trim(text))
702 end if
703 error = nf_get_var_double(ncid,i,r8vals)
704 call netcdf_err( error, mpp_file(unit), mpp_file(unit)%Axis(dimid) )
705 mpp_file(unit)%Axis(dimid)%data(1:len) = r8vals(1:len)
706 deallocate(r8vals)
707 case default
708 call mpp_error( fatal, 'Invalid data type for dimension' )
709 end select
710 else if(get_time_info) then
711 len = mpp_file(unit)%time_level
712 if( len > 0 ) then
713 allocate(mpp_file(unit)%time_values(len), stat=istat)
714 if ( istat .ne. 0 ) then
715 write(text,'(A)') istat
716 call mpp_error(fatal, &
717 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%time_valuse. STAT = "&
718 & //trim(text))
719 end if
720 select case (type)
721 case (nf_float)
722 allocate(rvals(len), stat=istat)
723 if ( istat .ne. 0 ) then
724 write(text,'(A)') istat
725 call mpp_error(fatal, &
726 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array rvals. STAT = "&
727 & //trim(text))
728 end if
729 !z1l read from root pe and broadcast to other processor.
730 !In the future we will modify the code if there is performance issue for very high MPI ranks.
731 if(mpp_pe()==mpp_root_pe()) then
732 error = nf_get_var_real(ncid,i,rvals)
733 call netcdf_err( error, mpp_file(unit), mpp_file(unit)%Axis(dimid) )
734 endif
735 call mpp_broadcast(rvals, len, mpp_root_pe())
736 mpp_file(unit)%time_values(1:len) = rvals(1:len)
737 deallocate(rvals)
738 case (nf_double)
739 allocate(r8vals(len), stat=istat)
740 if ( istat .ne. 0 ) then
741 write(text,'(A)') istat
742 call mpp_error(fatal, &
743 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array r8vals. STAT = "&
744 & //trim(text))
745 end if
746 !z1l read from root pe and broadcast to other processor.
747 !In the future we will modify the code if there is performance issue for very high MPI ranks.
748 if(mpp_pe()==mpp_root_pe()) then
749 error = nf_get_var_double(ncid,i,r8vals)
750 call netcdf_err( error, mpp_file(unit), mpp_file(unit)%Axis(dimid) )
751 endif
752 call mpp_broadcast(r8vals, len, mpp_root_pe())
753 mpp_file(unit)%time_values(1:len) = r8vals(1:len)
754 deallocate(r8vals)
755 case default
756 call mpp_error( fatal, 'Invalid data type for dimension' )
757 end select
758 endif
759 endif
760 ! assign dimension atts
761 if( nvatts.GT.0 )allocate(mpp_file(unit)%Axis(dimid)%Att(nvatts))
762
763 do j=1,nvatts
764 mpp_file(unit)%Axis(dimid)%Att(j) = default_att
765 enddo
766
767 do j=1,nvatts
768 error=nf_inq_attname(ncid,i,j,attname);call netcdf_err( error, mpp_file(unit) )
769 error=nf_inq_att(ncid,i,trim(attname),type,len)
770 call netcdf_err( error, mpp_file(unit), string=' Attribute='//attname )
771
772 mpp_file(unit)%Axis(dimid)%Att(j)%name = trim(attname)
773 mpp_file(unit)%Axis(dimid)%Att(j)%type = type
774 mpp_file(unit)%Axis(dimid)%Att(j)%len = len
775
776 select case (type)
777 case (nf_char)
778 if (len.gt.max_att_length) call mpp_error(fatal,'DIM ATT too long')
779 error=nf_get_att_text(ncid,i,trim(attname),mpp_file(unit)%Axis(dimid)%Att(j)%catt);
780 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%Axis(dimid)%att(j) )
781 if( verbose .and. pe == 0 ) then
782 print *, 'AXIS ',trim(mpp_file(unit)%Axis(dimid)%name),' ATT ',trim(attname)
783 print *, mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
784 endif
785 ! store integers in float arrays
786 ! assume dimension data not packed
787 case (nf_short)
788 allocate(mpp_file(unit)%Axis(dimid)%Att(j)%fatt(len), stat=istat)
789 if ( istat .ne. 0 ) then
790 write(text,'(A)') istat
791 call mpp_error(fatal, &
792 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Axis%Att%fatt, "//&
793 & "NF_SHORT CASE. STAT = "//trim(text))
794 end if
795 allocate(i2vals(len), stat=istat)
796 if ( istat .ne. 0 ) then
797 write(text,'(A)') istat
798 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
799 "Unable to allocate temporary array i2vals. STAT = "//trim(text))
800 end if
801 error=nf_get_att_int2(ncid,i,trim(attname),i2vals);
802 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%Axis(dimid)%att(j) )
803 mpp_file(unit)%Axis(dimid)%Att(j)%fatt(1:len)=i2vals(1:len)
804 if( verbose .and. pe == 0 ) &
805 print *, 'AXIS ',trim(mpp_file(unit)%Axis(dimid)%name),' ATT ',&
806 & trim(attname),' ',mpp_file(unit)%Axis(dimid)%Att(j)%fatt
807 deallocate(i2vals)
808 case (nf_int)
809 allocate(mpp_file(unit)%Axis(dimid)%Att(j)%fatt(len), stat=istat)
810 if ( istat .ne. 0 ) then
811 write(text,'(A)') istat
812 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta):"// &
813 " Unable to allocate mpp_file%Axis%Att%fatt, "// &
814 "NF_INT CASE. STAT = "//trim(text))
815 end if
816 allocate(ivals(len), stat=istat)
817 if ( istat .ne. 0 ) then
818 write(text,'(A)') istat
819 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
820 "Unable to allocate temporary array ivals. STAT = "//trim(text))
821 end if
822 error=nf_get_att_int(ncid,i,trim(attname),ivals);
823 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%Axis(dimid)%att(j) )
824 mpp_file(unit)%Axis(dimid)%Att(j)%fatt(1:len)=ivals(1:len)
825 if( verbose .and. pe == 0 ) &
826 print *, 'AXIS ',trim(mpp_file(unit)%Axis(dimid)%name),' ATT ',trim(attname), ' ',&
827 & mpp_file(unit)%Axis(dimid)%Att(j)%fatt
828 deallocate(ivals)
829 case (nf_float)
830 allocate(mpp_file(unit)%Axis(dimid)%Att(j)%fatt(len), stat=istat)
831 if ( istat .ne. 0 ) then
832 write(text,'(A)') istat
833 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
834 "Unable to allocate mpp_file%Axis%Att%fatt, "// &
835 & "NF_FLOAT CASE. STAT = "//trim(text))
836 end if
837 allocate(rvals(len), stat=istat)
838 if ( istat .ne. 0 ) then
839 write(text,'(A)') istat
840 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
841 "Unable to allocate temporary array rvals. STAT = "&
842 & //trim(text))
843 end if
844 error=nf_get_att_real(ncid,i,trim(attname),rvals);
845 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%Axis(dimid)%att(j) )
846 mpp_file(unit)%Axis(dimid)%Att(j)%fatt(1:len)=rvals(1:len)
847 if( verbose .and. pe == 0 ) &
848 print *, 'AXIS ',trim(mpp_file(unit)%Axis(dimid)%name),' ATT ',trim(attname),' ', &
849 & mpp_file(unit)%Axis(dimid)%Att(j)%fatt
850 deallocate(rvals)
851 case (nf_double)
852 allocate(mpp_file(unit)%Axis(dimid)%Att(j)%fatt(len), stat=istat)
853 if ( istat .ne. 0 ) then
854 write(text,'(A)') istat
855 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
856 "Unable to allocate mpp_file%Axis%Att%fatt, "//&
857 & "NF_DOUBLE CASE. STAT = "//trim(text))
858 end if
859 allocate(r8vals(len), stat=istat)
860 if ( istat .ne. 0 ) then
861 write(text,'(A)') istat
862 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "//&
863 "Unable to allocate temporary array r8vals. STAT = "&
864 & //trim(text))
865 end if
866 error=nf_get_att_double(ncid,i,trim(attname),r8vals);
867 call netcdf_err( error, mpp_file(unit), attr=mpp_file(unit)%Axis(dimid)%att(j) )
868 mpp_file(unit)%Axis(dimid)%Att(j)%fatt(1:len)=r8vals(1:len)
869 if( verbose .and. pe == 0 ) &
870 print *, 'AXIS ',trim(mpp_file(unit)%Axis(dimid)%name),' ATT ',trim(attname),' ',&
871 & mpp_file(unit)%Axis(dimid)%Att(j)%fatt
872 deallocate(r8vals)
873 case default
874 call mpp_error( fatal, 'Invalid data type for dimension at' )
875 end select
876 ! assign pre-defined axis attributes
877 select case(trim(attname))
878 case('long_name')
879 mpp_file(unit)%Axis(dimid)%longname=mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
880 case('units')
881 mpp_file(unit)%Axis(dimid)%units=mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
882 case('cartesian_axis')
883 mpp_file(unit)%Axis(dimid)%cartesian=mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
884 case('calendar')
885 mpp_file(unit)%Axis(dimid)%calendar=mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
886 mpp_file(unit)%Axis(dimid)%calendar = lowercase(cut0(mpp_file(unit)%Axis(dimid)%calendar))
887 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == 'none') &
888 mpp_file(unit)%Axis(dimid)%calendar = 'no_calendar'
889 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == 'no_leap') &
890 mpp_file(unit)%Axis(dimid)%calendar = 'noleap'
891 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == '365_days') &
892 mpp_file(unit)%Axis(dimid)%calendar = '365_day'
893 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == '360_days') &
894 mpp_file(unit)%Axis(dimid)%calendar = '360_day'
895 case('calendar_type')
896 mpp_file(unit)%Axis(dimid)%calendar=mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
897 mpp_file(unit)%Axis(dimid)%calendar = lowercase(cut0(mpp_file(unit)%Axis(dimid)%calendar))
898 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == 'none') &
899 mpp_file(unit)%Axis(dimid)%calendar = 'no_calendar'
900 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == 'no_leap') &
901 mpp_file(unit)%Axis(dimid)%calendar = 'noleap'
902 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == '365_days') &
903 mpp_file(unit)%Axis(dimid)%calendar = '365_day'
904 if (trim(mpp_file(unit)%Axis(dimid)%calendar) == '360_days') &
905 mpp_file(unit)%Axis(dimid)%calendar = '360_day'
906 case('compress')
907 mpp_file(unit)%Axis(dimid)%compressed=mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
908 case('positive')
909 attval = mpp_file(unit)%Axis(dimid)%Att(j)%catt(1:len)
910 if( attval.eq.'down' )then
911 mpp_file(unit)%Axis(dimid)%sense=-1
912 else if( attval.eq.'up' )then
913 mpp_file(unit)%Axis(dimid)%sense=1
914 endif
915 end select
916
917 enddo
918 endif
919 enddo
920
921 ! assign axis bounds
922 do j = 1, mpp_file(unit)%ndim
923 if(.not. associated(mpp_file(unit)%Axis(j)%data)) cycle
924 len = size(mpp_file(unit)%Axis(j)%data(:))
925 allocate(mpp_file(unit)%Axis(j)%data_bounds(len+1))
926 mpp_file(unit)%Axis(j)%name_bounds = 'none'
927 bounds_name = 'none'
928 found_bounds = .false.
929 do i = 1, mpp_file(unit)%Axis(j)%natt
930 if(trim(mpp_file(unit)%Axis(j)%Att(i)%name) == 'bounds' .OR. &
931 trim(mpp_file(unit)%Axis(j)%Att(i)%name) == 'edges' ) then
932 bounds_name = mpp_file(unit)%Axis(j)%Att(i)%catt
933 found_bounds = .true.
934 exit
935 endif
936 enddo
937 !-- loop through all the fields to locate bounds_name
938 if( found_bounds ) then
939 found_bounds = .false.
940 do i = 1, mpp_file(unit)%ndim
941 if(.not. associated(mpp_file(unit)%Axis(i)%data)) cycle
942 if(trim(mpp_file(unit)%Axis(i)%name) == trim(bounds_name)) then
943 found_bounds = .true.
944 if(size(mpp_file(unit)%Axis(i)%data(:)) .NE. len+1) &
945 call mpp_error(fatal, "mpp_read_meta: improperly size bounds for field "// &
946 trim(bounds_name)//" in file "// trim(mpp_file(unit)%name) )
947 mpp_file(unit)%Axis(j)%data_bounds(:) = mpp_file(unit)%Axis(i)%data(:)
948 exit
949 endif
950 enddo
951 if( .not. found_bounds ) then
952 do i=1, nvar_total
953 error=nf_inq_var(ncid,i,name,type,nvdims,dimids,nvatts);call netcdf_err( error, mpp_file(unit) )
954 if(trim(name) == trim(bounds_name)) then
955 found_bounds = .true.
956 if(nvdims .NE. 2) &
957 call mpp_error(fatal, "mpp_read_meta: field "//trim(bounds_name)//" in file "//&
958 trim(mpp_file(unit)%name)//" must be 2-D field")
959 if(mpp_file(unit)%Axis(dimids(1))%len .NE. 2) &
960 call mpp_error(fatal, "mpp_read_meta: first dimension size of field "// &
961 trim(mpp_file(unit)%Var(i)%name)//" from file "//trim(mpp_file(unit)%name)// &
962 " must be 2")
963 if(mpp_file(unit)%Axis(dimids(2))%len .NE. len) &
964 call mpp_error(fatal, "mpp_read_meta: second dimension size of field "// &
965 trim(mpp_file(unit)%Var(i)%name)//" from file "//trim(mpp_file(unit)%name)// &
966 " is not correct")
967 select case (type)
968 case (nf_int)
969 allocate(ivals(2*len), stat=istat)
970 if ( istat .ne. 0 ) then
971 write(text,'(A)') istat
972 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): Unable to allocate array ivals."//&
973 " STAT = "//trim(text))
974 end if
975 error = nf_get_var_int(ncid,i,ivals)
976 call netcdf_err( error, mpp_file(unit), string=" Field="//trim(bounds_name) )
977 mpp_file(unit)%Axis(j)%data_bounds(1:len) =ivals(1:(2*len-1):2)
978 mpp_file(unit)%Axis(j)%data_bounds(len+1) = ivals(2*len)
979 deallocate(ivals)
980 case (nf_float)
981 allocate(rvals(2*len), stat=istat)
982 if ( istat .ne. 0 ) then
983 write(text,'(A)') istat
984 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): Unable to allocate array rvals. "// &
985 " STAT = "//trim(text))
986 end if
987 error = nf_get_var_real(ncid,i,rvals)
988 call netcdf_err( error, mpp_file(unit), string=" Field="//trim(bounds_name) )
989 mpp_file(unit)%Axis(j)%data_bounds(1:len) =rvals(1:(2*len-1):2)
990 mpp_file(unit)%Axis(j)%data_bounds(len+1) = rvals(2*len)
991 deallocate(rvals)
992 case (nf_double)
993 allocate(r8vals(2*len), stat=istat)
994 if ( istat .ne. 0 ) then
995 write(text,'(A)') istat
996 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): Unable to allocate array r8vals. "//&
997 " STAT = "//trim(text))
998 end if
999 error = nf_get_var_double(ncid,i,r8vals)
1000 call netcdf_err( error, mpp_file(unit), string=" Field="//trim(bounds_name) )
1001 mpp_file(unit)%Axis(j)%data_bounds(1:len) =r8vals(1:(2*len-1):2)
1002 mpp_file(unit)%Axis(j)%data_bounds(len+1) = r8vals(2*len)
1003 deallocate(r8vals)
1004 case default
1005 call mpp_error( fatal, 'mpp_io_mod(mpp_read_meta): Invalid data type for dimension' )
1006 end select
1007 exit
1008 endif
1009 enddo
1010 endif
1011 endif
1012 if (found_bounds) then
1013 mpp_file(unit)%Axis(j)%name_bounds = trim(bounds_name)
1014 else
1015 deallocate(mpp_file(unit)%Axis(j)%data_bounds)
1016 mpp_file(unit)%Axis(j)%data_bounds =>null()
1017 endif
1018 enddo
1019
1020! assign variable info
1021 nv = 0
1022 do i=1, nvar_total
1023 error=nf_inq_var(ncid,i,name,type,nvdims,dimids,nvatts);call netcdf_err( error, mpp_file(unit) )
1024!
1025! is this a dimension variable?
1026!
1027 isdim=.false.
1028 do j=1,ndim
1029 if( trim(lowercase(name)).EQ.trim(lowercase(mpp_file(unit)%Axis(j)%name)) )isdim=.true.
1030 enddo
1031
1032 if( .not.isdim )then
1033! for non-dimension variables
1034 nv=nv+1
1035 if( nv.GT.mpp_file(unit)%nvar )call mpp_error(fatal,'variable index exceeds number of defined variables')
1036 mpp_file(unit)%Var(nv)%type = type
1037 mpp_file(unit)%Var(nv)%id = i
1038 mpp_file(unit)%Var(nv)%name = name
1039 mpp_file(unit)%Var(nv)%natt = nvatts
1040! determine packing attribute based on NetCDF variable type
1041 select case (type)
1042 case(nf_short)
1043 mpp_file(unit)%Var(nv)%pack = 4
1044 case(nf_float)
1045 mpp_file(unit)%Var(nv)%pack = 2
1046 case(nf_double)
1047 mpp_file(unit)%Var(nv)%pack = 1
1048 case (nf_int)
1049 mpp_file(unit)%Var(nv)%pack = 2
1050 case (nf_char)
1051 mpp_file(unit)%Var(nv)%pack = 1
1052 case default
1053 call mpp_error( fatal, 'Invalid variable type in NetCDF file' )
1054 end select
1055! assign dimension ids
1056 mpp_file(unit)%Var(nv)%ndim = nvdims
1057 allocate(mpp_file(unit)%Var(nv)%axes(nvdims))
1058 do j=1,nvdims
1059 mpp_file(unit)%Var(nv)%axes(j) = mpp_file(unit)%Axis(dimids(j))
1060 enddo
1061 allocate(mpp_file(unit)%Var(nv)%size(nvdims))
1062
1063 do j=1,nvdims
1064 if(dimids(j).eq.mpp_file(unit)%recdimid .and. mpp_file(unit)%time_level/=-1)then
1065 mpp_file(unit)%Var(nv)%time_axis_index = j !dimids(j). z1l: Should be j.
1066 !This will cause problem when
1067 !appending to existed file.
1068 mpp_file(unit)%Var(nv)%size(j)=1 ! dimid length set to 1 here for consistency w/ mpp_write
1069 else
1070 mpp_file(unit)%Var(nv)%size(j)=mpp_file(unit)%Axis(dimids(j))%len
1071 endif
1072 enddo
1073! assign variable atts
1074 if( nvatts.GT.0 )allocate(mpp_file(unit)%Var(nv)%Att(nvatts))
1075
1076 do j=1,nvatts
1077 mpp_file(unit)%Var(nv)%Att(j) = default_att
1078 enddo
1079
1080 do j=1,nvatts
1081 error=nf_inq_attname(ncid,i,j,attname)
1082 call netcdf_err( error, mpp_file(unit), field=mpp_file(unit)%Var(nv) )
1083 error=nf_inq_att(ncid,i,attname,type,len)
1084 call netcdf_err( error, mpp_file(unit),field= mpp_file(unit)%Var(nv), string=' Attribute='//attname )
1085 mpp_file(unit)%Var(nv)%Att(j)%name = trim(attname)
1086 mpp_file(unit)%Var(nv)%Att(j)%type = type
1087 mpp_file(unit)%Var(nv)%Att(j)%len = len
1088
1089 select case (type)
1090 case (nf_char)
1091 if (len.gt.512) call mpp_error(fatal,'VAR ATT too long')
1092 error=nf_get_att_text(ncid,i,trim(attname),mpp_file(unit)%Var(nv)%Att(j)%catt(1:len))
1093 call netcdf_err( error, mpp_file(unit), field=mpp_file(unit)%var(nv), &
1094 & attr=mpp_file(unit)%var(nv)%att(j) )
1095 if (verbose .and. pe == 0 )&
1096 print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%catt(1:len)
1097! store integers as float internally
1098 case (nf_short)
1099 allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len), stat=istat)
1100 if ( istat .ne. 0 ) then
1101 write(text,'(A)') istat
1102 call mpp_error(fatal, &
1103 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Var%Att%fatt, "//&
1104 & "NF_SHORT CASE. STAT = "//trim(text))
1105 end if
1106 allocate(i2vals(len), stat=istat)
1107 if ( istat .ne. 0 ) then
1108 write(text,'(A)') istat
1109 call mpp_error(fatal, &
1110 & "mpp_io_mod(mpp_read_meta): Unable to allocate temporary array i2vals. STAT = "&
1111 & //trim(text))
1112 end if
1113 error=nf_get_att_int2(ncid,i,trim(attname),i2vals)
1114 call netcdf_err( error, mpp_file(unit), field=mpp_file(unit)%var(nv), &
1115 & attr=mpp_file(unit)%var(nv)%att(j) )
1116 mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)= i2vals(1:len)
1117 if( verbose .and. pe == 0 )&
1118 print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
1119 deallocate(i2vals)
1120 case (nf_int)
1121 allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len), stat=istat)
1122 if ( istat .ne. 0 ) then
1123 write(text,'(A)') istat
1124 call mpp_error(fatal, &
1125 & "mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Var%Att%fatt, "//&
1126 & "NF_INT CASE. STAT = "//trim(text))
1127 end if
1128 allocate(ivals(len), stat=istat)
1129 if ( istat .ne. 0 ) then
1130 write(text,'(A)') istat
1131 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
1132 "Unable to allocate temporary array ivals. STAT = "&
1133 & //trim(text))
1134 end if
1135 error=nf_get_att_int(ncid,i,trim(attname),ivals)
1136 call netcdf_err( error, mpp_file(unit), field=mpp_file(unit)%var(nv), &
1137 attr=mpp_file(unit)%var(nv)%att(j) )
1138 mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)=ivals(1:len)
1139 if( verbose .and. pe == 0 )&
1140 print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
1141 deallocate(ivals)
1142 case (nf_float)
1143 allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len), stat=istat)
1144 if ( istat .ne. 0 ) then
1145 write(text,'(A)') istat
1146 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
1147 "Unable to allocate mpp_file%Var%Att%fatt, "//&
1148 & "NF_FLOAT CASE. STAT = "//trim(text))
1149 end if
1150 allocate(rvals(len), stat=istat)
1151 if ( istat .ne. 0 ) then
1152 write(text,'(A)') istat
1153 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
1154 "Unable to allocate temporary array rvals. STAT = "&
1155 & //trim(text))
1156 end if
1157 error=nf_get_att_real(ncid,i,trim(attname),rvals)
1158 call netcdf_err( error, mpp_file(unit), field=mpp_file(unit)%var(nv), &
1159 attr=mpp_file(unit)%var(nv)%att(j) )
1160 mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)=rvals(1:len)
1161 if( verbose .and. pe == 0 )&
1162 print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
1163 deallocate(rvals)
1164 case (nf_double)
1165 allocate(mpp_file(unit)%Var(nv)%Att(j)%fatt(len), stat=istat)
1166 if ( istat .ne. 0 ) then
1167 write(text,'(A)') istat
1168 call mpp_error(fatal,"mpp_io_mod(mpp_read_meta): Unable to allocate mpp_file%Var%Att%fatt, "//&
1169 & "NF_DOUBLE CASE. STAT = "//trim(text))
1170 end if
1171 allocate(r8vals(len), stat=istat)
1172 if ( istat .ne. 0 ) then
1173 write(text,'(A)') istat
1174 call mpp_error(fatal, "mpp_io_mod(mpp_read_meta): "// &
1175 "Unable to allocate temporary array r8vals. STAT = "&
1176 & //trim(text))
1177 end if
1178 error=nf_get_att_double(ncid,i,trim(attname),r8vals)
1179 call netcdf_err( error, mpp_file(unit), field=mpp_file(unit)%var(nv), &
1180 attr=mpp_file(unit)%var(nv)%att(j) )
1181 mpp_file(unit)%Var(nv)%Att(j)%fatt(1:len)=r8vals(1:len)
1182 if( verbose .and. pe == 0 ) &
1183 print *, 'Var ',nv,' ATT ',trim(attname),' ',mpp_file(unit)%Var(nv)%Att(j)%fatt
1184 deallocate(r8vals)
1185 case default
1186 call mpp_error( fatal, 'Invalid data type for variable att' )
1187 end select
1188! assign pre-defined field attributes
1189 select case (trim(attname))
1190 case ('long_name')
1191 mpp_file(unit)%Var(nv)%longname=mpp_file(unit)%Var(nv)%Att(j)%catt(1:len)
1192 case('units')
1193 mpp_file(unit)%Var(nv)%units=mpp_file(unit)%Var(nv)%Att(j)%catt(1:len)
1194 case('scale_factor')
1195 mpp_file(unit)%Var(nv)%scale=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
1196 case('missing')
1197 mpp_file(unit)%Var(nv)%missing=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
1198 case('missing_value')
1199 mpp_file(unit)%Var(nv)%missing=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
1200 case('_FillValue')
1201 mpp_file(unit)%Var(nv)%fill=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
1202 case('add_offset')
1203 mpp_file(unit)%Var(nv)%add=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
1204 case('packing')
1205 mpp_file(unit)%Var(nv)%pack=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
1206 case('valid_range')
1207 mpp_file(unit)%Var(nv)%min=mpp_file(unit)%Var(nv)%Att(j)%fatt(1)
1208 mpp_file(unit)%Var(nv)%max=mpp_file(unit)%Var(nv)%Att(j)%fatt(2)
1209 case('checksum')
1210 checksum_char = mpp_file(unit)%Var(nv)%Att(j)%catt
1211! Scan checksum attribute for , delimiter. If found implies multiple time levels.
1212 checksumf = 0
1213 num_checksumf = 1
1214
1215 last = len_trim(checksum_char)
1216 is = index(trim(checksum_char),",") ! A value of 0 implies only 1 checksum value
1217 do while ((is > 0) .and. (is < (last-15)))
1218 is = is + scan(checksum_char(is:last), "," ) ! move starting pointer after ","
1219 num_checksumf = num_checksumf + 1
1220 enddo
1221 is =1
1222 do k = 1, num_checksumf
1223 read (checksum_char(is:is+15),'(Z16)') checksumf
1224 mpp_file(unit)%Var(nv)%checksum(k) = checksumf
1225 is = is + 17 ! Move index past the ,
1226 enddo
1227 end select
1228 enddo
1229 endif
1230 enddo ! end variable loop
1231 else
1232 call mpp_error( fatal, 'MPP READ CURRENTLY DOES NOT SUPPORT NON-NETCDF' )
1233 endif
1234
1235 mpp_file(unit)%initialized = .true.
1236#else
1237 call mpp_error( fatal, 'MPP_READ currently requires use_netCDF option' )
1238#endif
1239 return
1240 end subroutine mpp_read_meta
1241
1242
1243 function cut0(string)
1244 character(len=256) :: cut0
1245 character(len=*), intent(in) :: string
1246 integer :: i
1247
1248 cut0 = string
1249 i = index(string,achar(0))
1250 if(i > 0) cut0(i:i) = ' '
1251
1252 return
1253 end function cut0
1254
1255
1256 subroutine mpp_get_tavg_info(unit, field, fields, tstamp, tstart, tend, tavg)
1257 implicit none
1258 integer, intent(in) :: unit
1259 type(fieldtype), intent(in) :: field
1260 type(fieldtype), intent(in), dimension(:) :: fields
1261 real, intent(inout), dimension(:) :: tstamp, tstart, tend, tavg
1262!balaji: added because mpp_read can only read default reals
1263! when running with -r4 this will read a default real and then cast double
1264 real :: t_default_real
1265
1266
1267 integer :: n, m
1268 logical :: tavg_info_exists
1269
1270 tavg = -1.0
1271
1272
1273 if (size(tstamp,1) /= size(tstart,1)) call mpp_error(fatal,&
1274 'size mismatch in mpp_get_tavg_info')
1275
1276 if ((size(tstart,1) /= size(tend,1)) .OR. (size(tstart,1) /= size(tavg,1))) then
1277 call mpp_error(fatal,'size mismatch in mpp_get_tavg_info')
1278 endif
1279
1280 tstart = tstamp
1281 tend = tstamp
1282
1283 tavg_info_exists = .false.
1284
1285#ifdef use_netCDF
1286 do n= 1, field%natt
1287 if (field%Att(n)%type .EQ. nf_char) then
1288 if (field%Att(n)%name(1:13) == 'time_avg_info') then
1289 tavg_info_exists = .true.
1290 exit
1291 endif
1292 endif
1293 enddo
1294#endif
1295 if (tavg_info_exists) then
1296 do n = 1, size(fields(:))
1297 if (trim(fields(n)%name) == 'average_T1') then
1298 do m = 1, size(tstart(:))
1299 call mpp_read(unit, fields(n),t_default_real, m)
1300 tstart(m) = t_default_real
1301 enddo
1302 endif
1303 if (trim(fields(n)%name) == 'average_T2') then
1304 do m = 1, size(tend(:))
1305 call mpp_read(unit, fields(n),t_default_real, m)
1306 tend(m) = t_default_real
1307 enddo
1308 endif
1309 if (trim(fields(n)%name) == 'average_DT') then
1310 do m = 1, size(tavg(:))
1311 call mpp_read(unit, fields(n),t_default_real, m)
1312 tavg(m) = t_default_real
1313 enddo
1314 endif
1315 enddo
1316
1317 end if
1318 return
1319 end subroutine mpp_get_tavg_info
1320!> @}