24 INTEGER,
PARAMETER :: DEFAULT_DEFLATE_LEVEL = 2
25 PRIVATE default_deflate_level
28 CHARACTER,
DIMENSION(*),
PARAMETER :: VALID_VARS = &
29 & (/
't',
'u',
'v',
'w',
'q', &
30 &
'T',
'U',
'V',
'W',
'Q' /)
49 DO i=1,
SIZE(valid_vars)
50 print *, valid_vars(i)
64 INTEGER,
INTENT(IN) :: num_vars
65 CHARACTER,
DIMENSION(num_vars),
INTENT(IN) :: dump_vars
67 LOGICAL :: all_good = .true.
71 IF( .NOT. any(valid_vars == dump_vars(i)) )
THEN
82 SUBROUTINE fp2nc4io_dump(nc4_filepath, num_vars, dump_vars, deflate_level)
90 CHARACTER(LEN=*),
INTENT(IN) :: nc4_filepath
91 INTEGER,
INTENT(IN) :: num_vars
92 CHARACTER,
DIMENSION(num_vars),
INTENT(IN) :: dump_vars
93 INTEGER,
OPTIONAL,
INTENT(IN) :: deflate_level
97 INTEGER :: ncfunc_retval
102 INTEGER :: x_dimid, y_dimid, z_dimid, dimids(3)
107 INTEGER :: nx_test, ny_test, nz_test
108 REAL,
ALLOCATABLE,
DIMENSION(:,:,:) :: testvar_array
109 CHARACTER(LEN=NF90_MAX_NAME) :: x_dimname, y_dimname, z_dimname
110 REAL :: orig_array_sum, test_array_sum
115 print *,
'*** Running in testing mode ***'
121 IF (present(deflate_level))
THEN
122 IF (deflate_level < 0 .OR. deflate_level > 9)
THEN
123 deflevel = default_deflate_level
125 deflevel = deflate_level
128 deflevel = default_deflate_level
131 print *,
'Using deflate level: ', deflevel
137 ncfunc_retval = nf90_create(nc4_filepath, &
138 & or(nf90_clobber, nf90_hdf5), ncid)
139 print *,
'Created file: ', trim(nc4_filepath)
143 ncfunc_retval = nf90_def_dim(ncid,
'x', nx, x_dimid)
144 ncfunc_retval = nf90_def_dim(ncid,
'y', ny, y_dimid)
145 ncfunc_retval = nf90_def_dim(ncid,
'z', nz, z_dimid)
146 dimids = (/ x_dimid, y_dimid, z_dimid /)
151 print *,
'Dumped 3d field: ', dump_vars(i)
155 ncfunc_retval = nf90_def_var(ncid,
'height', nf90_double, &
158 ncfunc_retval = nf90_def_var_deflate(ncid, varid, &
161 & deflate_level=deflevel)
163 ncfunc_retval = nf90_put_var(ncid, varid, height(1:nz))
167 ncfunc_retval = nf90_def_var(ncid,
'dx', nf90_double, varid)
168 ncfunc_retval = nf90_put_var(ncid, varid, dx)
170 ncfunc_retval = nf90_def_var(ncid,
'dy', nf90_double, varid)
171 ncfunc_retval = nf90_put_var(ncid, varid, dy)
173 ncfunc_retval = nf90_def_var(ncid,
'xlon0', nf90_double, varid)
174 ncfunc_retval = nf90_put_var(ncid, varid, xlon0)
176 ncfunc_retval = nf90_def_var(ncid,
'ylat0', nf90_double, varid)
177 ncfunc_retval = nf90_put_var(ncid, varid, ylat0)
180 ncfunc_retval = nf90_close(ncid)
184 print *,
"Opening nc file for reading"
185 ncfunc_retval = nf90_open(nc4_filepath, nf90_nowrite, ncid)
188 ncfunc_retval = nf90_inq_dimid(ncid,
'x', x_dimid)
189 ncfunc_retval = nf90_inquire_dimension(ncid, x_dimid, x_dimname, &
191 print *,
'nx_test: ', nx_test
193 ncfunc_retval = nf90_inq_dimid(ncid,
'y', y_dimid)
194 ncfunc_retval = nf90_inquire_dimension(ncid, y_dimid, y_dimname, &
196 print *,
'ny_test: ', ny_test
198 ncfunc_retval = nf90_inq_dimid(ncid,
'z', z_dimid)
199 ncfunc_retval = nf90_inquire_dimension(ncid, z_dimid, z_dimname, &
201 print *,
'nz_test: ', nz_test
203 ALLOCATE( testvar_array(0:nx_test-1, 0:ny_test-1, nz_test) )
208 & nx_test, ny_test, nz_test, &
212 IF (
to_upper(dump_vars(i)) ==
'U')
THEN
213 orig_array_sum = sum( uu(0:nx_test-1, 0:ny_test-1, &
215 ELSEIF (
to_upper(dump_vars(i)) ==
'V')
THEN
216 orig_array_sum = sum( vv(0:nx_test-1, 0:ny_test-1, &
218 ELSEIF (
to_upper(dump_vars(i)) ==
'T')
THEN
219 orig_array_sum = sum( tt(0:nx_test-1, 0:ny_test-1, &
221 ELSEIF (
to_upper(dump_vars(i)) ==
'W')
THEN
222 orig_array_sum = sum( ww(0:nx_test-1, 0:ny_test-1, &
224 ELSEIF (
to_upper(dump_vars(i)) ==
'Q')
THEN
225 orig_array_sum = sum( qv(0:nx_test-1, 0:ny_test-1, &
229 test_array_sum = sum( testvar_array(0:nx_test-1, 0:ny_test-1, &
232 print *, dump_vars(i),
': ',
'SUM of differences = ', &
233 & test_array_sum - orig_array_sum
234 IF ( abs(test_array_sum - orig_array_sum) .GT. 1.0e-3 )
THEN
236 &
'WARNING WILL ROBINSON!: Sum of differences exceeds 1.0E-3'
240 ncfunc_retval = nf90_close(ncid)
241 print *,
'Closed file: ', ncfunc_retval
257 INTEGER,
INTENT(IN) :: ncid
258 CHARACTER,
INTENT(IN) :: varname
259 INTEGER,
INTENT(IN) :: dimids(3)
260 INTEGER,
INTENT(IN) :: deflevel
263 CHARACTER :: nc_varname
264 INTEGER :: ncfunc_retval, varid
267 IF( .NOT. any(valid_vars == varname) )
THEN
269 print *,
'fp2nc4io:private_dump_3d_field() bad var: ', varname
270 print *,
' ABORTING...'
279 ncfunc_retval = nf90_def_var(ncid, nc_varname, nf90_double, &
282 ncfunc_retval = nf90_def_var_deflate(ncid, varid, &
285 & deflate_level=deflevel)
292 print *,
'Writing: ', nc_varname
293 IF (nc_varname ==
'U')
THEN
294 ncfunc_retval = nf90_put_var(ncid, varid, &
295 & uu(0:nx-1, 0:ny-1, 1:nz, 1))
296 ELSEIF (nc_varname ==
'V')
THEN
297 ncfunc_retval = nf90_put_var(ncid, varid, &
298 & vv(0:nx-1, 0:ny-1, 1:nz, 1))
299 ELSEIF (nc_varname ==
'T')
THEN
300 ncfunc_retval = nf90_put_var(ncid, varid, &
301 & tt(0:nx-1, 0:ny-1, 1:nz, 1))
302 ELSEIF (nc_varname ==
'W')
THEN
303 ncfunc_retval = nf90_put_var(ncid, varid, &
304 & ww(0:nx-1, 0:ny-1, 1:nz, 1))
305 ELSEIF (nc_varname ==
'Q')
THEN
306 ncfunc_retval = nf90_put_var(ncid, varid, &
307 & qv(0:nx-1, 0:ny-1, 1:nz, 1))
310 print *,
'fp2nc4io:private_dump_3d_field() bad var: ', nc_varname
311 print *,
' ABORTING...'
315 IF (ncfunc_retval /= 0)
THEN
317 print *,
'*** WARNING ***'
318 print *,
' fp2nc4io:private_dump_3d_field()'
319 print *,
' nf90_put_var returned error for var: ', nc_varname
336 INTEGER,
INTENT(IN) :: ncid
337 CHARACTER,
INTENT(IN) :: varname
338 INTEGER,
INTENT(IN) :: xdim, ydim, zdim
339 REAL,
DIMENSION(xdim, ydim, zdim) :: var_array
341 CHARACTER :: nc_varname
342 INTEGER :: ncfunc_retval, varid
345 IF( .NOT. any(valid_vars == varname) )
THEN
347 print *,
'fp2nc4io:private_dump_3d_field() bad var: ', varname
348 print *,
' ABORTING...'
357 ncfunc_retval = nf90_inq_varid(ncid, nc_varname, varid)
360 ncfunc_retval = nf90_get_var(ncid, varid, var_array)
371 CHARACTER,
INTENT(IN) :: c
373 INTEGER :: c_ascii_code
375 c_ascii_code = iachar(c)
376 IF (c_ascii_code >= iachar(
"a") .AND. c_ascii_code <= iachar(
"z"))
THEN
logical function fp2nc4io_vars_are_valid(num_vars, dump_vars)
subroutine fp2nc4io_print_valid_vars
subroutine, private private_dump_3dfield(ncid, varname, dimids, deflevel)
character function, private to_upper(c)
subroutine fp2nc4io_dump(nc4_filepath, num_vars, dump_vars, deflate_level)
subroutine, private private_read_3dfield(ncid, varname, xdim, ydim, zdim, var_array)