source: LMDZ6/branches/cirrus/libf/phylmd/ecrad/utilities/easy_netcdf.F90 @ 5434

Last change on this file since 5434 was 4773, checked in by idelkadi, 12 months ago
  • Update of Ecrad in LMDZ The same organization of the Ecrad offline version is retained in order to facilitate the updating of Ecrad in LMDZ and the comparison between online and offline results. version 1.6.1 of Ecrad (https://github.com/lguez/ecrad.git)
  • Implementation of the double call of Ecrad in LMDZ


File size: 104.4 KB
Line 
1! easy_netcdf.F90 - Module providing convenient NetCDF read/write capability
2!
3! (C) Copyright 2014- ECMWF.
4!
5! This software is licensed under the terms of the Apache Licence Version 2.0
6! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
7!
8! In applying this licence, ECMWF does not waive the privileges and immunities
9! granted to it by virtue of its status as an intergovernmental organisation
10! nor does it submit to any jurisdiction.
11!
12! Author:  Robin Hogan
13! Email:   r.j.hogan@ecmwf.int
14!
15! Modifications
16!   2017-04-28  R. Hogan  Fix "reshape" when writing 3D array
17!   2017-10-23  A. Bozzo  Reading 4-D array
18!   2018-03-14  R. Hogan  Fix "reshape" properly this time
19!   2019-01-04  R. Hogan  Allow reading and writing a slice of a larger array
20!   2019-01-07  R. Hogan  HDF5 writing support, allowing larger files, provided NC_NETCDF4 defined
21!   2019-01-16  R. Hogan  Revised interpretation of "iverbose"
22!   2019-06-17  R. Hogan  Pass through deflate_level and shuffle to variable definition
23
24module easy_netcdf
25
26  use netcdf
27  use parkind1,      only : jprb, jpib, jprm, jprd
28  use radiation_io,  only : nulout, nulerr, my_abort => radiation_abort
29
30  implicit none
31  public
32
33  !---------------------------------------------------------------------
34  ! An object of this type provides convenient read or write access to
35  ! a NetCDF file
36  type netcdf_file
37    integer :: ncid = -1! NetCDF file ID
38    integer :: iverbose ! Verbosity: 0 = report only fatal errors,
39                        !            1 = ...and warnings,
40                        !            2 = ...and when opening files,
41                        !            3 = ...and when reading/writing variables,
42                        !            4 = ...and variable attributes and when writing dimensions,
43                        !            5 = ...and debugging information
44    logical :: do_transpose_2d = .false.   ! Transpose 2D arrays on read/write?
45    logical :: is_write_mode   = .false.   ! .false. for read, .true. for write
46    logical :: is_define_mode  = .true.    ! .true. if in NetCDF define mode
47    logical :: is_double_precision = .false. ! Write reals in double precision?
48    logical :: do_permute_3d   = .false.   ! Permute 3D arrays on write?
49    logical :: do_permute_4d   = .false.   ! Permute 3D arrays on write?
50    integer :: i_permute_3d(3) = (/1,2,3/) ! New order of dimensions
51    integer :: i_permute_4d(4) = (/1,2,3,4/) ! New order of dimensions
52    character(len=511) :: file_name
53  contains
54    procedure :: open => open_netcdf_file
55    procedure :: create => create_netcdf_file
56    procedure :: close => close_netcdf_file
57    procedure :: is_open
58    procedure :: get_real_scalar
59    procedure :: get_int_scalar
60    procedure :: get_real_vector
61    procedure :: get_int_vector
62    procedure :: get_real_matrix
63    procedure :: get_real_array3
64    procedure :: get_real_scalar_indexed
65    procedure :: get_real_vector_indexed
66    procedure :: get_real_matrix_indexed
67    procedure :: get_real_array3_indexed
68    procedure :: get_real_array4
69    procedure :: get_char_vector
70    procedure :: get_char_matrix
71    generic   :: get => get_real_scalar, get_int_scalar, &
72         &              get_real_vector, get_int_vector, &
73         &              get_real_matrix, get_real_array3, &
74         &              get_real_array4, &
75         &              get_real_scalar_indexed, get_real_vector_indexed, &
76         &              get_real_matrix_indexed, get_real_array3_indexed, &
77         &              get_char_vector, get_char_matrix
78    procedure :: get_real_scalar_attribute
79    procedure :: get_string_attribute
80    generic   :: get_attribute => get_real_scalar_attribute, &
81         &                        get_string_attribute
82    procedure :: get_global_attribute
83
84    procedure :: define_dimension
85    procedure :: define_variable
86    procedure :: put_attribute
87    procedure :: put_global_attributes
88    procedure :: put_global_attribute
89    procedure :: put_real_scalar
90    procedure :: put_real_vector
91    procedure :: put_int_vector
92    procedure :: put_real_matrix
93    procedure :: put_real_array3
94    procedure :: put_real_scalar_indexed
95    procedure :: put_real_vector_indexed
96    procedure :: put_real_matrix_indexed
97    generic   :: put => put_real_scalar, put_real_vector, &
98         &              put_real_matrix, put_real_array3, &
99         &              put_real_scalar_indexed, put_real_vector_indexed, &
100         &              put_real_matrix_indexed, put_int_vector
101    procedure :: set_verbose
102    procedure :: transpose_matrices
103    procedure :: double_precision
104    procedure :: permute_3d_arrays
105    procedure :: get_rank
106    procedure :: exists
107    procedure :: get_outer_dimension
108    procedure :: attribute_exists
109    procedure :: global_attribute_exists
110#ifdef NC_NETCDF4
111    procedure :: copy_dimensions
112#endif
113    procedure :: copy_variable_definition
114    procedure :: copy_variable
115    procedure, private :: get_array_dimensions
116    procedure, private :: get_variable_id
117    procedure, private :: end_define_mode
118    procedure, private :: print_variable_attributes
119  end type netcdf_file
120
121contains
122
123  ! --- GENERIC SUBROUTINES ---
124
125  !---------------------------------------------------------------------
126  ! Open a NetCDF file with name "file_name", optionally specifying the
127  ! verbosity level (0-5) and if the file is for writing (the default
128  ! is read-only)
129  subroutine open_netcdf_file(this, file_name, iverbose, is_write_mode, is_hdf5_file)
130    class(netcdf_file)            :: this
131    character(len=*), intent(in)  :: file_name
132    integer, intent(in), optional :: iverbose
133    logical, intent(in), optional :: is_write_mode
134    logical, intent(in), optional :: is_hdf5_file ! Only for write mode
135
136    integer                       :: istatus
137    integer                       :: i_write_mode
138
139
140    ! Store verbosity level in object
141    if (present(iverbose)) then
142      this%iverbose = iverbose
143    else
144      ! By default announce files being opened and closed, but not
145      ! variables read/written
146      this%iverbose = 2
147    end if
148
149    ! Store read/write mode in object
150    if (present(is_write_mode)) then
151      this%is_write_mode = is_write_mode
152    else
153      this%is_write_mode = .false.
154    end if
155
156    ! By default we don't transpose 2D arrays on read/write
157    this%do_transpose_2d = .false.
158
159    ! Store filename
160    this%file_name = file_name
161
162    ! Open file according to write mode
163    if (.not. this%is_write_mode) then
164      istatus = nf90_open(file_name, NF90_NOWRITE, this%ncid)
165      if (this%iverbose >= 2) then
166        write(nulout,'(a,a)') 'Reading NetCDF file ', file_name
167        !write(nulout,'(a,a,a,i0,a)') 'Reading NetCDF file ', file_name, ' (ID=', this%ncid, ')'
168      end if
169      this%is_define_mode = .false.
170    else
171      i_write_mode = NF90_CLOBBER
172      ! Check if HDF5 file is to be written (which can be larger)
173      if (present(is_hdf5_file)) then
174        if (is_hdf5_file) then
175#ifdef NC_NETCDF4
176          i_write_mode = ior(i_write_mode, NF90_HDF5)
177#else
178          if (this%iverbose >= 1) then
179            write(nulout,'(a,a)') 'Warning: cannot use HDF5 format for writing ', file_name, &
180                 &                ' unless compiled with NC_NETCDF4 defined'
181          end if
182#endif
183        end if
184      end if
185
186      istatus = nf90_create(file_name, i_write_mode, this%ncid)
187      if (this%iverbose >= 2) then
188        write(nulout,'(a,a)') 'Writing NetCDF file ', file_name
189      end if
190      this%is_define_mode = .true.
191    end if
192
193    ! Check the file opened correctly
194    if (istatus /= NF90_NOERR) then
195      write(nulerr,'(a,a,a,a)') '*** Error opening NetCDF file ', &
196           &       file_name, ': ', trim(nf90_strerror(istatus))
197      call my_abort('Error opening NetCDF file')
198    end if
199
200  end subroutine open_netcdf_file
201
202
203  !---------------------------------------------------------------------
204  ! Open a NetCDF file for writing
205  subroutine create_netcdf_file(this, file_name, iverbose, is_hdf5_file)
206    class(netcdf_file)            :: this
207    character(len=*), intent(in)  :: file_name
208    integer, intent(in), optional :: iverbose
209    logical, intent(in), optional :: is_hdf5_file
210
211    integer                       :: istatus
212    integer                       :: i_write_mode
213
214    if (present(iverbose)) then
215      this%iverbose = iverbose
216    else
217      this%iverbose = 2
218    end if
219
220    this%do_transpose_2d = .false.
221
222    i_write_mode = NF90_CLOBBER
223    ! Check if HDF5 file is to be written (which can be large)
224    if (present(is_hdf5_file)) then
225      if (is_hdf5_file) then
226#ifdef NC_NETCDF4
227        i_write_mode = ior(i_write_mode, NF90_HDF5)
228#else
229        if (this%iverbose >= 1) then
230          write(nulout,'(a,a)') 'Warning: cannot use HDF5 format for writing ', file_name, &
231               &                ' unless compiled with NC_NETCDF4 defined'
232        end if
233#endif
234      end if
235    end if
236
237    istatus = nf90_create(file_name, i_write_mode, this%ncid)
238    if (this%iverbose >= 2) then
239      write(nulout,'(a,a)') 'Writing NetCDF file ', file_name
240      !write(nulout,'(a,a,a,i0,a)') 'Writing NetCDF file ', file_name, ' (ID=', this%ncid, ')'
241    end if
242    this%is_define_mode = .true.
243
244    if (istatus /= NF90_NOERR) then
245      write(nulerr,'(a,a,a)') '*** Error opening NetCDF file ', file_name, &
246           &                  ': ', trim(nf90_strerror(istatus))
247      stop
248    end if
249    this%file_name = file_name
250
251  end subroutine create_netcdf_file
252
253
254  !---------------------------------------------------------------------
255  ! Close the NetCDF file
256  subroutine close_netcdf_file(this)
257    class(netcdf_file) :: this
258    integer            :: istatus
259
260    if (this%iverbose >= 3) then
261      write(nulout,'(a,a)') 'Closing NetCDF file ', trim(this%file_name)
262    end if
263
264    istatus = nf90_close(this%ncid)
265    if (istatus /= NF90_NOERR) then
266      write(nulerr,'(a,a,a,a)') '*** Error closing NetCDF file ', &
267           & trim(this%file_name), ': ', trim(nf90_strerror(istatus))
268      stop
269    end if
270
271    this%ncid = -1
272
273  end subroutine close_netcdf_file
274
275
276  !---------------------------------------------------------------------
277  ! Set the verbosity level from 0 to 5, where the codes have the
278  ! following meaning: 0=errors only, 1=warning, 2=info, 3=progress,
279  ! 4=detailed, 5=debug
280  subroutine set_verbose(this, ival)
281    class(netcdf_file) :: this
282    integer, optional  :: ival
283
284    if (present(ival)) then
285      this%iverbose = ival
286    else
287      this%iverbose = 2
288    end if
289
290  end subroutine set_verbose
291
292
293  !---------------------------------------------------------------------
294  ! Specify whether floating-point arrays should be written in double precision
295  subroutine double_precision(this, is_double)
296    class(netcdf_file) :: this
297    logical, optional  :: is_double
298
299    if (present(is_double)) then
300      this%is_double_precision = is_double
301    else
302      this%is_double_precision = .true.
303    end if
304
305  end subroutine double_precision
306
307
308  !---------------------------------------------------------------------
309  ! Specify whether 2D arrays should be transposed on read/write
310  subroutine transpose_matrices(this, do_transpose)
311    class(netcdf_file) :: this
312    logical, optional  :: do_transpose
313
314    if (present(do_transpose)) then
315      this%do_transpose_2d = do_transpose
316    else
317      this%do_transpose_2d = .true.
318    end if
319
320  end subroutine transpose_matrices
321
322
323  !---------------------------------------------------------------------
324  ! Specify that 3D arrays should be permuted on write, with the new
325  ! dimension order in the input argument "ipermute" (e.g. 3,2,1)
326  subroutine permute_3d_arrays(this, ipermute)
327    class(netcdf_file)  :: this
328    integer, intent(in) :: ipermute(3)
329
330    this%do_permute_3d = .true.
331    this%i_permute_3d  = ipermute
332
333  end subroutine permute_3d_arrays
334
335
336  !---------------------------------------------------------------------
337  ! Specify that 4D arrays should be permuted on write, with the new
338  ! dimension order in the input argument "ipermute" (e.g. 4,3,2,1)
339  subroutine permute_4d_arrays(this, ipermute)
340    class(netcdf_file)  :: this
341    integer, intent(in) :: ipermute(4)
342
343    this%do_permute_4d = .true.
344    this%i_permute_4d  = ipermute
345
346  end subroutine permute_4d_arrays
347
348
349  ! --- PRIVATE SUBROUTINES ---
350
351  !---------------------------------------------------------------------
352  ! Return the NetCDF variable ID for variable "var_name", or abort if
353  ! not present
354  subroutine get_variable_id(this, var_name, ivarid)
355    class(netcdf_file)           :: this
356    character(len=*), intent(in) :: var_name
357    integer, intent(out)         :: ivarid
358
359    integer                      :: istatus
360
361    istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
362    if (istatus /= NF90_NOERR) then
363      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
364           & var_name, ': ', trim(nf90_strerror(istatus))
365      call my_abort('Error reading NetCDF file')
366    end if
367
368  end subroutine get_variable_id
369
370
371  !---------------------------------------------------------------------
372  ! Return the array dimensions of variable with specified ID, along
373  ! with the number of dimensions and optionally the total number of
374  ! elements, or abort if variable not present
375  subroutine get_array_dimensions(this, ivarid, ndims, ndimlens, ntotal)
376    class(netcdf_file)             :: this
377    integer, intent(in)            :: ivarid
378    integer, intent(out)           :: ndims
379    integer, intent(out)           :: ndimlens(NF90_MAX_VAR_DIMS)
380    integer(kind=jpib), intent(out), optional :: ntotal
381
382    integer                        :: j, istatus
383    integer                        :: idimids(NF90_MAX_VAR_DIMS)
384
385    istatus = nf90_inquire_variable(this%ncid, ivarid, &
386         &                          ndims=ndims, dimids=idimids)
387    if (istatus /= NF90_NOERR) then
388      write(nulerr,'(a,i0,a,a)') '*** Error inquiring about NetCDF variable with id ', &
389           & ivarid, ': ', trim(nf90_strerror(istatus))
390      call my_abort('Error reading NetCDF file')
391    end if
392
393    ndimlens(:) = 0
394    do j = 1,ndims
395      istatus = nf90_inquire_dimension(this%ncid, idimids(j), len=ndimlens(j))
396      if (istatus /= NF90_NOERR) then
397        write(nulerr,'(a,i0,a,i0,a,a)') '*** Error reading length of dimension ', &
398             & j, ' of NetCDF variable with id ', ivarid, ': ', &
399             & trim(nf90_strerror(istatus))
400        call my_abort('Error reading NetCDF file')
401      end if
402    end do
403
404    if (present(ntotal)) then
405      ntotal = 1
406      do j = 1, ndims
407        ntotal = ntotal * ndimlens(j)
408      end do
409    end if
410
411  end subroutine get_array_dimensions
412
413
414  !---------------------------------------------------------------------
415  ! End define mode, if in define mode, and check the error code
416  ! (errors are possible if variables are too large for the format,
417  ! for example)
418  subroutine end_define_mode(this)
419    class(netcdf_file)             :: this
420    integer                        :: istatus
421    if (this%is_define_mode) then
422      istatus = nf90_enddef(this%ncid)
423      if (istatus /= NF90_NOERR) then
424        write(nulerr,'(a,a,a,a)') '*** Error ending define mode when writing ', &
425             &    trim(this%file_name), ': ', trim(nf90_strerror(istatus))
426        call my_abort('Error writing NetCDF file')
427      end if
428      this%is_define_mode = .false.
429    end if
430  end subroutine end_define_mode
431
432
433  ! --- READING SUBROUTINES ---
434
435  !---------------------------------------------------------------------
436  ! Return true if file is open, false otherwise
437  function is_open(this)
438    class(netcdf_file) :: this
439    logical            :: is_open
440    is_open = (this%ncid >= 0)
441  end function is_open
442
443  !---------------------------------------------------------------------
444  ! Return the number of dimensions of variable with name var_name, or
445  ! -1 if the variable is not found
446  function get_rank(this, var_name) result(ndims)
447    class(netcdf_file)           :: this
448    character(len=*), intent(in) :: var_name
449
450    integer :: ndims
451    integer :: ivarid
452    integer :: ndimlens(NF90_MAX_VAR_DIMS)
453    integer :: istatus
454
455    istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
456    if (istatus /= NF90_NOERR) then
457      if (istatus == NF90_ENOTVAR) then
458        if (this%iverbose >= 1) then
459          write(nulout,'(a,a,a)') '  Warning: variable ', var_name, ' not found'
460        end if
461      else
462        write(nulerr,'(a,a,a)') '*** Error inquiring about variable ', &
463             &                  var_name, ': ', trim(nf90_strerror(istatus))
464        call my_abort('Error reading NetCDF file')
465      end if
466      ndims = -1
467    else
468      call this%get_array_dimensions(ivarid, ndims, ndimlens)
469    end if
470
471  end function get_rank
472
473
474  !---------------------------------------------------------------------
475  ! Return the length of the slowest-varying dimension of variable
476  ! with name var_name, or -1 if the variable is not found
477  function get_outer_dimension(this, var_name) result(n)
478    class(netcdf_file)           :: this
479    character(len=*), intent(in) :: var_name
480
481    integer :: n
482    integer :: ndims
483    integer :: ivarid
484    integer :: ndimlens(NF90_MAX_VAR_DIMS)
485    integer :: istatus
486
487    istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
488    if (istatus /= NF90_NOERR) then
489      if (istatus == NF90_ENOTVAR) then
490        if (this%iverbose >= 1) then
491          write(nulout,'(a,a,a)') '  Warning: variable ', var_name, ' not found'
492        end if
493      else
494        write(nulerr,'(a,a,a)') '*** Error inquiring about variable ', &
495             &                  var_name, ': ', trim(nf90_strerror(istatus))
496        call my_abort('Error reading NetCDF file')
497      end if
498      n = -1
499    else
500      call this%get_array_dimensions(ivarid, ndims, ndimlens)
501      n = ndimlens(ndims)
502    end if
503
504  end function get_outer_dimension
505
506
507  !---------------------------------------------------------------------
508  ! Return true if the variable is present, false otherwise
509  function exists(this, var_name) result(is_present)
510    class(netcdf_file)           :: this
511    character(len=*), intent(in) :: var_name
512
513    logical :: is_present
514
515    integer :: ivarid
516    integer :: istatus
517
518    istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
519    if (istatus /= NF90_NOERR) then
520      is_present = .false.
521    else
522      is_present = .true.
523    end if
524
525  end function exists
526
527
528  !---------------------------------------------------------------------
529  ! Return true if the attribute is present, false otherwise.  If
530  ! argument "len" is provided then return false if len is smaller
531  ! than the length of the attribute.  This is useful if you have a
532  ! fixed array size and want to check whether the attribute will fit
533  ! into it.
534  function attribute_exists(this, var_name, attr_name, len) result(is_present)
535    class(netcdf_file)            :: this
536    character(len=*), intent(in)  :: var_name, attr_name
537    integer, optional, intent(in) :: len
538
539    logical :: is_present
540    integer :: i_attr_len, ivarid
541    integer :: istatus
542
543    istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
544    if (istatus /= NF90_NOERR) then
545      is_present = .false.
546    else
547      istatus = nf90_inquire_attribute(this%ncid, ivarid, attr_name, &
548           &                           len=i_attr_len)
549      if (istatus /= NF90_NOERR) then
550        is_present = .false.
551      else
552        is_present = .true.
553        if (present(len)) then
554          if (i_attr_len > len) then
555            is_present = .false.
556          end if
557        end if
558      end if
559    end if
560
561  end function attribute_exists
562
563
564  !---------------------------------------------------------------------
565  ! Return true if the global attribute is present, false otherwise.
566  ! If argument "len" is provided then return false if len is smaller
567  ! than the length of the attribute.  This is useful if you have a
568  ! fixed array size and want to check whether the attribute will fit
569  ! into it.
570  function global_attribute_exists(this, attr_name, len) result(is_present)
571    class(netcdf_file)            :: this
572    character(len=*), intent(in)  :: attr_name
573    integer, optional, intent(in) :: len
574
575    logical :: is_present
576    integer :: i_attr_len
577    integer :: istatus
578
579    istatus = nf90_inquire_attribute(this%ncid, NF90_GLOBAL, attr_name, &
580         &                           len=i_attr_len)
581    if (istatus /= NF90_NOERR) then
582      is_present = .false.
583    else
584      is_present = .true.
585      if (present(len)) then
586        if (i_attr_len > len) then
587          is_present = .false.
588        end if
589      end if
590    end if
591
592  end function global_attribute_exists
593
594
595  !---------------------------------------------------------------------
596  ! The method "get" will read either a scalar, vector or matrix
597  ! depending on the rank of the output argument. This version reads a
598  ! scalar.
599  subroutine get_real_scalar(this, var_name, scalar)
600    class(netcdf_file)           :: this
601    character(len=*), intent(in) :: var_name
602    real(jprb), intent(out)      :: scalar
603
604    integer                      :: istatus
605    integer                      :: ivarid, ndims
606    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
607    integer                      :: j, ntotal
608
609    ! Inquire the ID, shape & size of the variable
610    call this%get_variable_id(var_name, ivarid)
611    call this%get_array_dimensions(ivarid, ndims, ndimlens)
612
613    ! Compute number of elements of the variable in the file
614    ntotal = 1
615    do j = 1, ndims
616      ntotal = ntotal * ndimlens(j)
617    end do
618
619    if (this%iverbose >= 3) then
620      write(nulout,'(a,a)',advance='no') '  Reading ', var_name
621      call this%print_variable_attributes(ivarid,nulout)
622    end if
623
624    ! Abort if the number of elements is anything other than 1
625    if (ntotal /= 1) then
626      write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', &
627           &    var_name, ' with total length ', ntotal, ' as a scalar'
628      call my_abort('Error reading NetCDF file')
629    end if
630
631    ! Read variable
632    istatus = nf90_get_var(this%ncid, ivarid, scalar)
633    if (istatus /= NF90_NOERR) then
634      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
635           &  var_name, ' as a scalar: ', trim(nf90_strerror(istatus))
636      call my_abort('Error reading NetCDF file')
637    end if
638
639  end subroutine get_real_scalar
640
641
642  !---------------------------------------------------------------------
643  ! Read an integer scalar
644  subroutine get_int_scalar(this, var_name, scalar)
645    class(netcdf_file)           :: this
646    character(len=*), intent(in) :: var_name
647    integer,          intent(out):: scalar
648
649    integer                      :: istatus
650    integer                      :: ivarid, ndims
651    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
652    integer                      :: j, ntotal
653
654    ! Inquire the ID, shape & size of the variable
655    call this%get_variable_id(var_name, ivarid)
656    call this%get_array_dimensions(ivarid, ndims, ndimlens)
657
658    ! Compute number of elements of the variable in the file
659    ntotal = 1
660    do j = 1, ndims
661      ntotal = ntotal * ndimlens(j)
662    end do
663
664    if (this%iverbose >= 3) then
665      write(nulout,'(a,a)',advance='no') '  Reading ', var_name
666      call this%print_variable_attributes(ivarid,nulout)
667    end if
668
669    ! Abort if the number of elements is anything other than 1
670    if (ntotal /= 1) then
671      write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', &
672           &    var_name, ' with total length ', ntotal, ' as a scalar'
673      call my_abort('Error reading NetCDF file')
674    end if
675
676    ! Read variable
677    istatus = nf90_get_var(this%ncid, ivarid, scalar)
678    if (istatus /= NF90_NOERR) then
679      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
680           &  var_name, ' as a scalar: ', trim(nf90_strerror(istatus))
681      call my_abort('Error reading NetCDF file')
682    end if
683
684  end subroutine get_int_scalar
685
686
687  !---------------------------------------------------------------------
688  ! Read a scalar from a larger array, where "index" indexes the most
689  ! slowly varying dimension
690  subroutine get_real_scalar_indexed(this, var_name, scalar, index)
691    class(netcdf_file)           :: this
692    character(len=*), intent(in) :: var_name
693    integer, intent(in)          :: index
694    real(jprb), intent(out)      :: scalar
695
696    integer                      :: istatus
697    integer                      :: ivarid, ndims
698    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
699    integer                      :: vstart(NF90_MAX_VAR_DIMS)
700    integer                      :: j, ntotal
701
702    ! Inquire the ID, shape & size of the variable
703    call this%get_variable_id(var_name, ivarid)
704    call this%get_array_dimensions(ivarid, ndims, ndimlens)
705
706    ! Compute number of elements of the slice in the file,
707    ! i.e. excluding the slowest varying dimension, indexed by "index"
708    ntotal = 1
709    do j = 1, ndims-1
710      ntotal = ntotal * ndimlens(j)
711    end do
712
713    if (this%iverbose >= 3) then
714      write(nulout,'(a,a,i0,a,a)') '  Reading element ', index, ' of ', var_name
715    end if
716
717    ! Abort if the number of elements is anything other than 1
718    if (ntotal /= 1) then
719      write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', &
720           &    var_name, ' with slice length ', ntotal, ' as a scalar'
721      call my_abort('Error reading NetCDF file')
722    end if
723
724    if (index < 1 .or. index > ndimlens(ndims)) then
725      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, &
726           &  ' of NetCDF variable ', &
727           &    var_name, ' with outer dimension ', ndimlens(ndims)
728      call my_abort('Error reading NetCDF file')
729    end if
730
731    ! Read variable
732    vstart(1:ndims-1) = 1
733    vstart(ndims)     = index
734    istatus = nf90_get_var(this%ncid, ivarid, scalar, start=vstart)
735    if (istatus /= NF90_NOERR) then
736      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
737           &  var_name, ' as a scalar: ', trim(nf90_strerror(istatus))
738      call my_abort('Error reading NetCDF file')
739    end if
740
741  end subroutine get_real_scalar_indexed
742
743
744  !---------------------------------------------------------------------
745  ! Read a 1D real array into "vector", which must be allocatable and
746  ! will be reallocated if necessary
747  subroutine get_real_vector(this, var_name, vector)
748    class(netcdf_file)           :: this
749    character(len=*), intent(in) :: var_name
750    real(jprb), allocatable, intent(out) :: vector(:)
751
752    integer                      :: n  ! Length of vector
753    integer                      :: istatus
754    integer                      :: ivarid, ndims
755    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
756    integer                      :: j
757
758    call this%get_variable_id(var_name, ivarid)
759    call this%get_array_dimensions(ivarid, ndims, ndimlens)
760
761    ! Ensure variable has only one dimension in the file
762    n = 1
763    do j = 1, ndims
764      n = n * ndimlens(j)
765      if (j > 1 .and. ndimlens(j) > 1) then
766        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
767             & var_name, &
768             & ' as a vector: all dimensions above the first must be singletons'
769        call my_abort('Error reading NetCDF file')
770      end if
771    end do
772
773    ! Reallocate if necessary
774    if (allocated(vector)) then
775      if (size(vector) /= n) then
776        if (this%iverbose >= 1) then
777          write(nulout,'(a,a)') '  Warning: resizing vector to read ', var_name
778        end if
779        deallocate(vector)
780        allocate(vector(n))
781      end if
782    else
783      allocate(vector(n))
784    end if
785
786    if (this%iverbose >= 3) then
787      write(nulout,'(a,a,a,i0,a)',advance='no') '  Reading ', var_name, '(', n, ')'
788      call this%print_variable_attributes(ivarid,nulout)
789    end if
790
791    ! Read variable
792    istatus = nf90_get_var(this%ncid, ivarid, vector)
793    if (istatus /= NF90_NOERR) then
794      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
795           &  var_name, ' as a vector: ', trim(nf90_strerror(istatus))
796      call my_abort('Error reading NetCDF file')
797    end if
798
799  end subroutine get_real_vector
800
801
802  !---------------------------------------------------------------------
803  ! Read a 1D character array into "vector", which must be allocatable
804  ! and will be reallocated if necessary
805  subroutine get_char_vector(this, var_name, vector)
806    class(netcdf_file)           :: this
807    character(len=*), intent(in) :: var_name
808    character(len=1), allocatable, intent(out) :: vector(:)
809
810    integer                      :: n  ! Length of vector
811    integer                      :: istatus
812    integer                      :: ivarid, ndims
813    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
814    integer                      :: j
815
816    call this%get_variable_id(var_name, ivarid)
817    call this%get_array_dimensions(ivarid, ndims, ndimlens)
818
819    ! Ensure variable has only one dimension in the file
820    n = 1
821    do j = 1, ndims
822      n = n * ndimlens(j)
823      if (j > 1 .and. ndimlens(j) > 1) then
824        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
825             & var_name, &
826             & ' as a vector: all dimensions above the first must be singletons'
827        call my_abort('Error reading NetCDF file')
828      end if
829    end do
830
831    ! Reallocate if necessary
832    if (allocated(vector)) then
833      if (size(vector) /= n) then
834        if (this%iverbose >= 1) then
835          write(nulout,'(a,a)') '  Warning: resizing vector to read ', var_name
836        end if
837        deallocate(vector)
838        allocate(vector(n))
839      end if
840    else
841      allocate(vector(n))
842    end if
843
844    if (this%iverbose >= 3) then
845      write(nulout,'(a,a,a,i0,a)',advance='no') '  Reading ', var_name, '(', n, ')'
846      call this%print_variable_attributes(ivarid,nulout)
847    end if
848
849    ! Read variable
850    istatus = nf90_get_var(this%ncid, ivarid, vector)
851    if (istatus /= NF90_NOERR) then
852      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
853           &  var_name, ' as a vector of chars: ', trim(nf90_strerror(istatus))
854      call my_abort('Error reading NetCDF file')
855    end if
856
857  end subroutine get_char_vector
858
859
860  !---------------------------------------------------------------------
861  ! Read a 1D integer array into "vector", which must be allocatable
862  ! and will be reallocated if necessary
863  subroutine get_int_vector(this, var_name, vector)
864
865    class(netcdf_file)           :: this
866    character(len=*), intent(in) :: var_name
867    integer, allocatable, intent(out) :: vector(:)
868
869    integer                      :: n  ! Length of vector
870    integer                      :: istatus
871    integer                      :: ivarid, ndims
872    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
873    integer                      :: j
874
875    call this%get_variable_id(var_name, ivarid)
876    call this%get_array_dimensions(ivarid, ndims, ndimlens)
877
878    ! Ensure variable has only one dimension in the file
879    n = 1
880    do j = 1, ndims
881      n = n * ndimlens(j)
882      if (j > 1 .and. ndimlens(j) > 1) then
883        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
884             & var_name, &
885             & ' as a vector: all dimensions above the first must be singletons'
886        call my_abort('Error reading NetCDF file')
887      end if
888    end do
889
890    ! Reallocate if necessary
891    if (allocated(vector)) then
892      if (size(vector) /= n) then
893        if (this%iverbose >= 1) then
894          write(nulout,'(a,a)') '  Warning: resizing vector to read ', var_name
895        end if
896        deallocate(vector)
897        allocate(vector(n))
898      end if
899    else
900      allocate(vector(n))
901    end if
902
903    if (this%iverbose >= 3) then
904      write(nulout,'(a,a,a,i0,a)',advance='no') '  Reading ', var_name, '(', n, ')'
905      call this%print_variable_attributes(ivarid,nulout)
906    end if
907
908    ! Read variable
909    istatus = nf90_get_var(this%ncid, ivarid, vector)
910    if (istatus /= NF90_NOERR) then
911      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
912           &  var_name, ' as an integer vector: ', trim(nf90_strerror(istatus))
913      call my_abort('Error reading NetCDF file')
914    end if
915
916  end subroutine get_int_vector
917
918  !---------------------------------------------------------------------
919  ! Read a vector of data from a larger array; the vector must be
920  ! allocatable and will be reallocated if necessary
921  subroutine get_real_vector_indexed(this, var_name, vector, index)
922    class(netcdf_file)           :: this
923    character(len=*), intent(in) :: var_name
924    integer, intent(in)          :: index
925    real(jprb), allocatable, intent(out) :: vector(:)
926
927    integer                      :: n  ! Length of vector
928    integer                      :: istatus
929    integer                      :: ivarid, ndims
930    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
931    integer                      :: vstart(NF90_MAX_VAR_DIMS)
932    integer                      :: vcount(NF90_MAX_VAR_DIMS)
933    integer                      :: j
934
935    call this%get_variable_id(var_name, ivarid)
936    call this%get_array_dimensions(ivarid, ndims, ndimlens)
937
938    ! Ensure variable has only one dimension aside from the last one
939    n = 1
940    do j = 1, ndims-1
941      n = n * ndimlens(j)
942      if (j > 1 .and. ndimlens(j) > 1) then
943        write(nulerr,'(a,a,a)') '*** Error reading 1D slice from NetCDF variable ', &
944             & var_name, &
945             & ': all dimensions except the first and last must be singletons'
946        call my_abort('Error reading NetCDF file')
947      end if
948    end do
949
950    ! Reallocate if necessary
951    if (allocated(vector)) then
952      if (size(vector) /= n) then
953        if (this%iverbose >= 1) then
954          write(nulout,'(a,i0,a,a)') '  Warning: resizing vector to length ', n, &
955               &                ' to read slice of ', var_name
956        end if
957        deallocate(vector)
958        allocate(vector(n))
959      end if
960    else
961      allocate(vector(n))
962    end if
963
964    if (this%iverbose >= 3) then
965      write(nulout,'(a,i0,a,a)') '  Reading column ', index, ' of ', var_name
966    end if
967
968    if (index < 1 .or. index > ndimlens(ndims)) then
969      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, &
970           &  ' of NetCDF variable ', &
971           &    var_name, ' with outer dimension ', ndimlens(ndims)
972      call my_abort('Error reading NetCDF file')
973    end if
974
975    ! Read variable
976    vstart(1:ndims-1) = 1
977    vstart(ndims)     = index
978    vcount(1:ndims-1) = ndimlens(1:ndims-1)
979    vcount(ndims)     = 1
980    istatus = nf90_get_var(this%ncid, ivarid, vector, &
981         &                 start=vstart, count=vcount)
982    if (istatus /= NF90_NOERR) then
983      write(nulerr,'(a,a,a,a)') '*** Error reading 1D slice of NetCDF variable ', &
984           &  var_name, ': ', trim(nf90_strerror(istatus))
985      call my_abort('Error reading NetCDF file')
986    end if
987
988  end subroutine get_real_vector_indexed
989
990
991  !---------------------------------------------------------------------
992  ! Read 2D array into "matrix", which must be allocatable and will be
993  ! reallocated if necessary.  Whether to transpose is specifed by the
994  ! final optional argument, but can also be specified by the
995  ! do_transpose_2d class data member.
996  subroutine get_real_matrix(this, var_name, matrix, do_transp)
997    class(netcdf_file)           :: this
998    character(len=*), intent(in) :: var_name
999    real(jprb), allocatable, intent(out) :: matrix(:,:)
1000    logical, optional, intent(in):: do_transp ! Transpose data?
1001
1002    real(jprb), allocatable      :: tmp_matrix(:,:)
1003    integer                      :: ndimlen1, ndimlen2
1004    integer                      :: istatus
1005    integer                      :: ivarid, ndims
1006    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
1007    integer                      :: j, ntotal
1008    logical                      :: do_transpose
1009
1010    ! Decide whether to transpose the array
1011    if (present(do_transp)) then
1012      do_transpose = do_transp
1013    else
1014      do_transpose = this%do_transpose_2d
1015    end if
1016
1017    call this%get_variable_id(var_name, ivarid)
1018    call this%get_array_dimensions(ivarid, ndims, ndimlens)
1019
1020    ! Ensure the variable has no more than two non-singleton
1021    ! dimensions
1022    ntotal = 1
1023    do j = 1, ndims
1024      ntotal = ntotal * ndimlens(j)
1025      if (j > 2 .and. ndimlens(j) > 1) then
1026        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
1027           & var_name, &
1028           & ' as a matrix: all dimensions above the second must be singletons'
1029        call my_abort('Error reading NetCDF file')
1030      end if
1031    end do
1032
1033    ! Work out dimension lengths
1034    if (ndims >= 2) then
1035      ndimlen1 = ndimlens(1)
1036      ndimlen2 = ntotal/ndimlen1
1037    else
1038      ndimlen1 = ntotal
1039      ndimlen2 = 1
1040    end if
1041
1042    if (do_transpose) then
1043      ! Read and transpose
1044      allocate(tmp_matrix(ndimlen1, ndimlen2))
1045
1046      ! Reallocate if necessary
1047      if (allocated(matrix)) then
1048        if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then
1049          if (this%iverbose >= 1) then
1050            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
1051          end if
1052          deallocate(matrix)
1053          allocate(matrix(ndimlen2, ndimlen1))
1054        end if
1055      else
1056        allocate(matrix(ndimlen2, ndimlen1))
1057      end if
1058
1059      if (this%iverbose >= 3) then
1060        write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, '(', &
1061             &                            ndimlen2, ',', ndimlen1, ')'
1062        call this%print_variable_attributes(ivarid,nulout)
1063      end if
1064
1065      istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix)
1066      matrix = transpose(tmp_matrix)
1067      deallocate(tmp_matrix)
1068    else
1069      ! Read data without transposition
1070
1071      ! Reallocate if necessary
1072      if (allocated(matrix)) then
1073        if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then
1074          if (this%iverbose >= 1) then
1075            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
1076          end if
1077          allocate(matrix(ndimlen1, ndimlen2))
1078        end if
1079      else
1080        allocate(matrix(ndimlen1, ndimlen2))
1081      end if
1082
1083      if (this%iverbose >= 3) then
1084        write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, '(', &
1085             &                            ndimlen1, ',', ndimlen2, ')'
1086        call this%print_variable_attributes(ivarid,nulout)
1087      end if
1088
1089      istatus = nf90_get_var(this%ncid, ivarid, matrix)
1090    end if
1091
1092    if (istatus /= NF90_NOERR) then
1093      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
1094           &    var_name, ' as a matrix: ', trim(nf90_strerror(istatus))
1095      call my_abort('Error reading NetCDF file')
1096    end if
1097
1098  end subroutine get_real_matrix
1099
1100
1101  !---------------------------------------------------------------------
1102  ! Read 2D array of characters into "matrix", which must be
1103  ! allocatable and will be reallocated if necessary.  Whether to
1104  ! transpose is specifed by the final optional argument, but can also
1105  ! be specified by the do_transpose_2d class data member.
1106  subroutine get_char_matrix(this, var_name, matrix, do_transp)
1107    class(netcdf_file)           :: this
1108    character(len=*), intent(in) :: var_name
1109    character(len=1), allocatable, intent(inout) :: matrix(:,:)
1110    logical, optional, intent(in):: do_transp ! Transpose data?
1111
1112    character(len=1), allocatable:: tmp_matrix(:,:)
1113    integer                      :: ndimlen1, ndimlen2
1114    integer                      :: istatus
1115    integer                      :: ivarid, ndims
1116    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
1117    integer                      :: vstart(NF90_MAX_VAR_DIMS)
1118    integer                      :: vcount(NF90_MAX_VAR_DIMS)
1119    integer                      :: j, ntotal
1120    logical                      :: do_transpose
1121
1122    ! Decide whether to transpose the array
1123    if (present(do_transp)) then
1124      do_transpose = do_transp
1125    else
1126      do_transpose = this%do_transpose_2d
1127    end if
1128
1129    call this%get_variable_id(var_name, ivarid)
1130    call this%get_array_dimensions(ivarid, ndims, ndimlens)
1131
1132    ! Ensure the variable has no more than two non-singleton
1133    ! dimensions
1134    ntotal = 1
1135    do j = 1, ndims
1136      ntotal = ntotal * ndimlens(j)
1137      if (j > 2 .and. ndimlens(j) > 1) then
1138        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
1139           & var_name, &
1140           & ' as a matrix: all dimensions above the second must be singletons'
1141        call my_abort('Error reading NetCDF file')
1142      end if
1143    end do
1144
1145    ! Work out dimension lengths
1146    if (ndims >= 2) then
1147      ndimlen1 = ndimlens(1)
1148      ndimlen2 = ntotal/ndimlen1
1149    else
1150      ndimlen1 = ntotal
1151      ndimlen2 = 1
1152    end if
1153
1154    if (do_transpose) then
1155      ! Read and transpose
1156      allocate(tmp_matrix(ndimlen1, ndimlen2))
1157
1158      ! Reallocate if necessary
1159      if (allocated(matrix)) then
1160        if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then
1161          if (this%iverbose >= 1) then
1162            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
1163          end if
1164          deallocate(matrix)
1165          allocate(matrix(ndimlen2, ndimlen1))
1166        end if
1167      else
1168        allocate(matrix(ndimlen2, ndimlen1))
1169      end if
1170
1171      if (this%iverbose >= 3) then
1172        write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, '(', &
1173             &                            ndimlen2, ',', ndimlen1, ')'
1174        call this%print_variable_attributes(ivarid,nulout)
1175      end if
1176
1177      istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix)
1178      matrix = transpose(tmp_matrix)
1179      deallocate(tmp_matrix)
1180    else
1181      ! Read data without transposition
1182
1183      ! Reallocate if necessary
1184      if (allocated(matrix)) then
1185        if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then
1186          if (this%iverbose >= 1) then
1187            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
1188          end if
1189          allocate(matrix(ndimlen1, ndimlen2))
1190        end if
1191      else
1192        allocate(matrix(ndimlen1, ndimlen2))
1193      end if
1194
1195      if (this%iverbose >= 3) then
1196        write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, '(', &
1197             &                            ndimlen1, ',', ndimlen2, ')'
1198        call this%print_variable_attributes(ivarid,nulout)
1199      end if
1200
1201      vstart = 1
1202      vcount(1:2) = [ndimlen1,1]
1203     
1204      do j = 1,ndimlen2
1205        vstart(2) = j
1206        istatus = nf90_get_var(this%ncid, ivarid, matrix(:,j), start=vstart, count=vcount)
1207      end do
1208    end if
1209
1210    if (istatus /= NF90_NOERR) then
1211      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
1212           &    var_name, ' as a matrix of characters: ', trim(nf90_strerror(istatus))
1213      call my_abort('Error reading NetCDF file')
1214    end if
1215
1216  end subroutine get_char_matrix
1217
1218
1219  !---------------------------------------------------------------------
1220  ! Read matrix of data from a larger array, which must be allocatable
1221  ! and will be reallocated if necessary.  Whether to transpose is
1222  ! specifed by the final optional argument, but can also be specified
1223  ! by the do_transpose_2d class data member.
1224  subroutine get_real_matrix_indexed(this, var_name, matrix, index, do_transp)
1225    class(netcdf_file)           :: this
1226    character(len=*), intent(in) :: var_name
1227    integer, intent(in)          :: index
1228    real(jprb), allocatable, intent(out) :: matrix(:,:)
1229    logical, optional, intent(in):: do_transp ! Transpose data?
1230
1231    real(jprb), allocatable      :: tmp_matrix(:,:)
1232    integer                      :: ndimlen1, ndimlen2
1233    integer                      :: istatus
1234    integer                      :: ivarid, ndims
1235    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
1236    integer                      :: vstart(NF90_MAX_VAR_DIMS)
1237    integer                      :: vcount(NF90_MAX_VAR_DIMS)
1238    integer                      :: j, ntotal
1239    logical                      :: do_transpose
1240
1241    ! Decide whether to transpose the array
1242    if (present(do_transp)) then
1243      do_transpose = do_transp
1244    else
1245      do_transpose = this%do_transpose_2d
1246    end if
1247
1248    call this%get_variable_id(var_name, ivarid)
1249    call this%get_array_dimensions(ivarid, ndims, ndimlens)
1250
1251    ! Ensure the variable has no more than two non-singleton
1252    ! dimensions aside from the last one
1253    ntotal = 1
1254    do j = 1, ndims-1
1255      ntotal = ntotal * ndimlens(j)
1256      if (j > 2 .and. ndimlens(j) > 1) then
1257        write(nulerr,'(a,a,a)') '*** Error reading 2D slice from NetCDF variable ', &
1258           & var_name, &
1259           & ': all dimensions except the first, second and last must be singletons'
1260        call my_abort('Error reading NetCDF file')
1261      end if
1262    end do
1263
1264    if (index < 1 .or. index > ndimlens(ndims)) then
1265      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, &
1266           &  ' of NetCDF variable ', &
1267           &    var_name, ' with outer dimension ', ndimlens(ndims)
1268      call my_abort('Error reading NetCDF file')
1269    end if
1270
1271    ! Work out dimension lengths
1272    if (ndims >= 2) then
1273      ndimlen1 = ndimlens(1)
1274      ndimlen2 = ntotal/ndimlen1
1275    else
1276      ndimlen1 = ntotal
1277      ndimlen2 = 1
1278    end if
1279
1280    vstart(1:ndims-1) = 1
1281    vstart(ndims)     = index
1282    vcount(1:ndims-1) = ndimlens(1:ndims-1)
1283    vcount(ndims)     = 1
1284
1285    if (do_transpose) then
1286      ! Read and transpose
1287      allocate(tmp_matrix(ndimlen1, ndimlen2))
1288
1289      ! Reallocate if necessary
1290      if (allocated(matrix)) then
1291        if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then
1292          if (this%iverbose >= 1) then
1293            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
1294          end if
1295          allocate(matrix(ndimlen2, ndimlen1))
1296        end if
1297      else
1298        allocate(matrix(ndimlen2, ndimlen1))
1299      end if
1300
1301      if (this%iverbose >= 3) then
1302        write(nulout,'(a,i0,a,a,a,i0,a,i0,a)') '  Reading slice ', index, &
1303             &  ' of ', var_name, ' as ', ndimlen2, 'x', ndimlen1, ' array'
1304      end if
1305
1306      istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix, &
1307           &                 start=vstart, count=vcount)
1308      matrix = transpose(tmp_matrix)
1309      deallocate(tmp_matrix)
1310    else
1311      ! Read data without transposition
1312
1313      ! Reallocate if necessary
1314      if (allocated(matrix)) then
1315        if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then
1316          if (this%iverbose >= 1) then
1317            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
1318          end if
1319          allocate(matrix(ndimlen1, ndimlen2))
1320        end if
1321      else
1322        allocate(matrix(ndimlen1, ndimlen2))
1323      end if
1324
1325      if (this%iverbose >= 3) then
1326        write(nulout,'(a,i0,a,a,a,i0,a,i0,a)') '  Reading slice ', index, &
1327             &  ' of ', var_name, ' as ', ndimlen1, 'x', ndimlen2, ' array'
1328      end if
1329
1330      istatus = nf90_get_var(this%ncid, ivarid, matrix, &
1331           &                 start=vstart, count=vcount)
1332    end if
1333
1334    if (istatus /= NF90_NOERR) then
1335      write(nulerr,'(a,a,a,a)') '*** Error reading 2D slice of NetCDF variable ', &
1336           &    var_name, ': ', trim(nf90_strerror(istatus))
1337      call my_abort('Error reading NetCDF file')
1338    end if
1339
1340  end subroutine get_real_matrix_indexed
1341
1342
1343  !---------------------------------------------------------------------
1344  ! Read 3D array into "var", which must be allocatable and will be
1345  ! reallocated if necessary.  Whether to pemute is specifed by the
1346  ! final optional argument
1347  subroutine get_real_array3(this, var_name, var, ipermute)
1348    class(netcdf_file)                   :: this
1349    character(len=*), intent(in)         :: var_name
1350    real(jprb), allocatable, intent(out) :: var(:,:,:)
1351    integer, optional, intent(in)        :: ipermute(3)
1352
1353    real(jprb), allocatable   :: var_permute(:,:,:)
1354    integer                   :: ndimlen1, ndimlen2, ndimlen3
1355    integer                   :: istatus
1356    integer                   :: ivarid, ndims
1357    integer                   :: ndimlens(NF90_MAX_VAR_DIMS)
1358    integer                   :: j, ntotal
1359    integer                   :: n_dimlens_permuted(3)
1360    integer                   :: i_permute_3d(3)
1361    logical                   :: do_permute
1362
1363    ! Decide whether to permute
1364    if (present(ipermute)) then
1365      do_permute = .true.
1366      i_permute_3d = ipermute
1367    else
1368      do_permute = this%do_permute_3d
1369      i_permute_3d = this%i_permute_3d
1370    end if
1371
1372    call this%get_variable_id(var_name, ivarid)
1373    call this%get_array_dimensions(ivarid, ndims, ndimlens)
1374
1375    ! Ensure the variable has no more than three non-singleton
1376    ! dimensions
1377    ntotal = 1
1378    do j = 1, ndims
1379      ntotal = ntotal * ndimlens(j)
1380      if (j > 3 .and. ndimlens(j) > 1) then
1381        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
1382           & var_name, &
1383           & ' as a 3D array: all dimensions above the third must be singletons'
1384        call my_abort('Error reading NetCDF file')
1385      end if
1386    end do
1387
1388    ! Work out dimension lengths
1389    if (ndims >= 3) then
1390      ndimlen1 = ndimlens(1)
1391      ndimlen2 = ndimlens(2)
1392      ndimlen3 = ntotal/(ndimlen1*ndimlen2)
1393    else if (ndims >= 2) then
1394      ndimlen1 = ndimlens(1)
1395      ndimlen2 = ntotal/ndimlen1
1396      ndimlen3 = 1
1397    else
1398      ndimlen1 = ntotal
1399      ndimlen2 = 1
1400      ndimlen3 = 1
1401    end if
1402
1403    ! Deallocate if necessary
1404    if (allocated(var)) then
1405      deallocate(var)
1406    end if
1407
1408    if (do_permute) then
1409      ! Read and permute
1410      allocate(var_permute(ndimlen1, ndimlen2, ndimlen3))
1411      n_dimlens_permuted(i_permute_3d) = ndimlens(1:3)
1412
1413      ! Reallocate if necessary
1414      if (allocated(var)) then
1415        if (size(var,1) /= n_dimlens_permuted(1) &
1416             &  .or. size(var,2) /= n_dimlens_permuted(2) &
1417             &  .or. size(var,3) /= n_dimlens_permuted(3)) then
1418          if (this%iverbose >= 1) then
1419            write(nulout,'(a,a)') '  Warning: resizing array to read ', var_name
1420          end if
1421          deallocate(var)
1422          allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), &
1423               &       n_dimlens_permuted(3)))
1424        end if
1425      else
1426        allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), &
1427             &       n_dimlens_permuted(3)))
1428      end if
1429
1430      if (this%iverbose >= 3) then
1431        write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') '  Reading ', var_name, &
1432             & ' (permuting dimensions ', i_permute_3d, ')'
1433        call this%print_variable_attributes(ivarid,nulout)
1434      end if
1435
1436      istatus = nf90_get_var(this%ncid, ivarid, var_permute)
1437      var = reshape(var_permute, n_dimlens_permuted, order=i_permute_3d)
1438      deallocate(var_permute)
1439
1440    else
1441      ! Read data without permutation
1442
1443      ! Reallocate if necessary
1444      if (allocated(var)) then
1445        if (size(var,1) /= ndimlen1 &
1446             &  .or. size(var,2) /= ndimlen2 &
1447             &  .or. size(var,3) /= ndimlen3) then
1448          if (this%iverbose >= 1) then
1449            write(nulout,'(a,a)') '  Warning: resizing array to read ', var_name
1450          end if
1451          deallocate(var)
1452          allocate(var(ndimlen1, ndimlen2, ndimlen3))
1453        end if
1454      else
1455        allocate(var(ndimlen1, ndimlen2, ndimlen3))
1456      end if
1457
1458      if (this%iverbose >= 3) then
1459        write(nulout,'(a,a,a,i0,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, &
1460             &            '(', ndimlen1, ',', ndimlen2, ',', ndimlen3, ')'
1461        call this%print_variable_attributes(ivarid,nulout)
1462      end if
1463
1464      istatus = nf90_get_var(this%ncid, ivarid, var)
1465    end if
1466
1467    if (istatus /= NF90_NOERR) then
1468      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
1469           &  var_name, ' as a 3D array: ', trim(nf90_strerror(istatus))
1470      call my_abort('Error reading NetCDF file')
1471    end if
1472
1473  end subroutine get_real_array3
1474
1475
1476  !---------------------------------------------------------------------
1477  ! Read 3D array of data from a larger-dimensional array, which must
1478  ! be allocatable and will be reallocated if necessary.  Whether to
1479  ! pemute is specifed by the final optional argument
1480  subroutine get_real_array3_indexed(this, var_name, var, index, ipermute)
1481    class(netcdf_file)                   :: this
1482    character(len=*), intent(in)         :: var_name
1483    integer, intent(in)                  :: index
1484    real(jprb), allocatable, intent(out) :: var(:,:,:)
1485    integer, optional, intent(in)        :: ipermute(3)
1486
1487    real(jprb), allocatable   :: var_permute(:,:,:)
1488    integer                   :: ndimlen1, ndimlen2, ndimlen3
1489    integer                   :: istatus
1490    integer                   :: ivarid, ndims
1491    integer                   :: ndimlens(NF90_MAX_VAR_DIMS)
1492    integer                   :: vstart(NF90_MAX_VAR_DIMS)
1493    integer                   :: vcount(NF90_MAX_VAR_DIMS)
1494    integer                   :: j, ntotal
1495    integer                   :: n_dimlens_permuted(3)
1496    integer                   :: i_permute_3d(3)
1497    logical                   :: do_permute
1498
1499    ! Decide whether to permute
1500    if (present(ipermute)) then
1501      do_permute = .true.
1502      i_permute_3d = ipermute
1503    else
1504      do_permute = this%do_permute_3d
1505      i_permute_3d = this%i_permute_3d
1506    end if
1507
1508    call this%get_variable_id(var_name, ivarid)
1509    call this%get_array_dimensions(ivarid, ndims, ndimlens)
1510
1511    ! Ensure the variable has no more than three non-singleton
1512    ! dimensions aside from the last one
1513    ntotal = 1
1514    do j = 1, ndims-1
1515      ntotal = ntotal * ndimlens(j)
1516      if (j > 3 .and. ndimlens(j) > 1) then
1517        write(nulerr,'(a,a,a)') '*** Error reading 3D slice from NetCDF variable ', &
1518           & var_name, &
1519           & ': all dimensions above the third must be singletons'
1520        call my_abort('Error reading NetCDF file')
1521      end if
1522    end do
1523
1524    if (index < 1 .or. index > ndimlens(ndims)) then
1525      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error reading element ', index, &
1526           &  ' of NetCDF variable ', &
1527           &    var_name, ' with outer dimension ', ndimlens(ndims)
1528      call my_abort('Error reading NetCDF file')
1529    end if
1530
1531    ! Work out dimension lengths
1532    if (ndims >= 3) then
1533      ndimlen1 = ndimlens(1)
1534      ndimlen2 = ndimlens(2)
1535      ndimlen3 = ntotal/(ndimlen1*ndimlen2)
1536    else if (ndims >= 2) then
1537      ndimlen1 = ndimlens(1)
1538      ndimlen2 = ntotal/ndimlen1
1539      ndimlen3 = 1
1540    else
1541      ndimlen1 = ntotal
1542      ndimlen2 = 1
1543      ndimlen3 = 1
1544    end if
1545
1546    vstart(1:ndims-1) = 1
1547    vstart(ndims)     = index
1548    vcount(1:ndims-1) = ndimlens(1:ndims-1)
1549    vcount(ndims)     = 1
1550
1551    if (do_permute) then
1552      ! Read and permute
1553      allocate(var_permute(ndimlen1, ndimlen2, ndimlen3))
1554      n_dimlens_permuted(i_permute_3d) = ndimlens(1:3)
1555
1556      ! Reallocate if necessary
1557      if (allocated(var)) then
1558        if (size(var,1) /= n_dimlens_permuted(1) &
1559             &  .or. size(var,2) /= n_dimlens_permuted(2) &
1560             &  .or. size(var,3) /= n_dimlens_permuted(3)) then
1561          if (this%iverbose >= 1) then
1562            write(nulout,'(a,a)') '  Warning: resizing array to read ', var_name
1563          end if
1564          deallocate(var)
1565          allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), &
1566               &       n_dimlens_permuted(3)))
1567        end if
1568      else
1569        allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), &
1570             &       n_dimlens_permuted(3)))
1571      end if
1572
1573      if (this%iverbose >= 3) then
1574        write(nulout,'(a,i0,a,a,a,i0,i0,i0,a)') '  Reading slice ', index, &
1575             &  ' of ', var_name, &
1576             & ' (permuting dimensions ', i_permute_3d, ')'
1577      end if
1578
1579      istatus = nf90_get_var(this%ncid, ivarid, var_permute, &
1580           &                 start=vstart, count=vcount)
1581      var = reshape(var_permute, n_dimlens_permuted, order=i_permute_3d)
1582      deallocate(var_permute)
1583
1584    else
1585      ! Read data without permutation
1586
1587      ! Reallocate if necessary
1588      if (allocated(var)) then
1589        if (size(var,1) /= ndimlen1 &
1590             &  .or. size(var,2) /= ndimlen2 &
1591             &  .or. size(var,3) /= ndimlen3) then
1592          if (this%iverbose >= 1) then
1593            write(nulout,'(a,a)') '  Warning: resizing array to read ', var_name
1594          end if
1595          deallocate(var)
1596          allocate(var(ndimlen1, ndimlen2, ndimlen3))
1597        end if
1598      else
1599        allocate(var(ndimlen1, ndimlen2, ndimlen3))
1600      end if
1601
1602      if (this%iverbose >= 3) then
1603        write(nulout,'(a,i0,a,a,a,i0,a,i0,a,i0,a)') '  Reading slice ', index, &
1604             &  ' of ', var_name, ' as ', ndimlen1, 'x', ndimlen2, 'x', &
1605             &  ndimlen3, 'array'
1606      end if
1607
1608      istatus = nf90_get_var(this%ncid, ivarid, var, &
1609           &                 start=vstart, count=vcount)
1610    end if
1611
1612    if (istatus /= NF90_NOERR) then
1613      write(nulerr,'(a,a,a,a)') '*** Error reading 3D slice of NetCDF variable ', &
1614           &  var_name, ': ', trim(nf90_strerror(istatus))
1615      call my_abort('Error reading NetCDF file')
1616    end if
1617
1618  end subroutine get_real_array3_indexed
1619
1620
1621  !---------------------------------------------------------------------
1622  ! Read 4D array into "var", which must be allocatable and will be
1623  ! reallocated if necessary.  Whether to pemute is specifed by the
1624  ! final optional argument
1625  subroutine get_real_array4(this, var_name, var, ipermute)
1626    class(netcdf_file)                   :: this
1627    character(len=*), intent(in)         :: var_name
1628    real(jprb), allocatable, intent(out) :: var(:,:,:,:)
1629    integer, optional, intent(in)        :: ipermute(4)
1630
1631    real(jprb), allocatable   :: var_permute(:,:,:,:)
1632    integer                   :: ndimlen1, ndimlen2, ndimlen3, ndimlen4
1633    integer                   :: istatus
1634    integer                   :: ivarid, ndims
1635    integer                   :: ndimlens(NF90_MAX_VAR_DIMS)
1636    integer                   :: j, ntotal
1637    integer                   :: n_dimlens_permuted(4)
1638    integer                   :: i_permute_4d(4)
1639    logical                   :: do_permute
1640
1641    ! Decide whether to permute
1642    if (present(ipermute)) then
1643      do_permute = .true.
1644      i_permute_4d = ipermute
1645    else
1646      do_permute = this%do_permute_4d
1647      i_permute_4d = this%i_permute_4d
1648    end if
1649
1650    call this%get_variable_id(var_name, ivarid)
1651    call this%get_array_dimensions(ivarid, ndims, ndimlens)
1652
1653    ! Ensure the variable has no more than three non-singleton
1654    ! dimensions
1655    ntotal = 1
1656    do j = 1, ndims
1657      ntotal = ntotal * ndimlens(j)
1658      if (j > 4 .and. ndimlens(j) > 1) then
1659        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
1660           & var_name, &
1661           & ' as a 4D array: all dimensions above the third must be singletons'
1662        call my_abort('Error reading NetCDF file')
1663      end if
1664    end do
1665
1666    ! Work out dimension lengths
1667    if (ndims >= 4) then
1668      ndimlen1 = ndimlens(1)
1669      ndimlen2 = ndimlens(2)
1670      ndimlen3 = ndimlens(3)
1671      ndimlen4 = ntotal/(ndimlen1*ndimlen2*ndimlen3)
1672    else if (ndims >= 3) then
1673      ndimlen1 = ndimlens(1)
1674      ndimlen2 = ndimlens(2)
1675      ndimlen3 = ntotal/(ndimlen1*ndimlen2)
1676    else if (ndims >= 2) then
1677      ndimlen1 = ndimlens(1)
1678      ndimlen2 = ntotal/ndimlen1
1679      ndimlen3 = 1
1680    else
1681      ndimlen1 = ntotal
1682      ndimlen2 = 1
1683      ndimlen3 = 1
1684    end if
1685
1686    ! Deallocate if necessary
1687    if (allocated(var)) then
1688      deallocate(var)
1689    end if
1690
1691    if (do_permute) then
1692      ! Read and permute - not tested
1693      allocate(var_permute(ndimlen1, ndimlen2, ndimlen3, ndimlen4))
1694      n_dimlens_permuted(i_permute_4d) = ndimlens(1:4)
1695
1696      ! Reallocate if necessary
1697      if (allocated(var)) then
1698        if (size(var,1) /= n_dimlens_permuted(1) &
1699             &  .or. size(var,2) /= n_dimlens_permuted(2) &
1700             &  .or. size(var,3) /= n_dimlens_permuted(3) &
1701             &  .or. size(var,4) /= n_dimlens_permuted(4)) then
1702          if (this%iverbose >= 1) then
1703            write(nulout,'(a,a)') '  Warning: resizing array to read ', var_name
1704          end if
1705          deallocate(var)
1706          allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), &
1707               &       n_dimlens_permuted(3), n_dimlens_permuted(4)))
1708        end if
1709      else
1710        allocate(var(n_dimlens_permuted(1), n_dimlens_permuted(2), &
1711             &       n_dimlens_permuted(3), n_dimlens_permuted(4)))
1712      end if
1713
1714      if (this%iverbose >= 3) then
1715        write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') '  Reading ', var_name, &
1716             & ' (permuting dimensions ', i_permute_4d, ')'
1717        call this%print_variable_attributes(ivarid,nulout)
1718      end if
1719
1720      istatus = nf90_get_var(this%ncid, ivarid, var_permute)
1721      var = reshape(var_permute, n_dimlens_permuted, order=i_permute_4d)
1722      deallocate(var_permute)
1723
1724    else
1725      ! Read data without permutation
1726
1727      ! Reallocate if necessary
1728      if (allocated(var)) then
1729        if (size(var,1) /= ndimlen1 &
1730             &  .or. size(var,2) /= ndimlen2 &
1731             &  .or. size(var,3) /= ndimlen3 &
1732             &  .or. size(var,4) /= ndimlen4) then
1733          if (this%iverbose >= 1) then
1734            write(nulout,'(a,a)') '  Warning: resizing array to read ', var_name
1735          end if
1736          deallocate(var)
1737          allocate(var(ndimlen1, ndimlen2, ndimlen3, ndimlen4))
1738        end if
1739      else
1740        allocate(var(ndimlen1, ndimlen2, ndimlen3, ndimlen4))
1741      end if
1742
1743      if (this%iverbose >= 3) then
1744        write(nulout,'(a,a,a,i0,a,i0,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, &
1745             &            '(', ndimlen1, ',', ndimlen2, ',', ndimlen3,',', ndimlen4, ')'
1746        call this%print_variable_attributes(ivarid,nulout)
1747      end if
1748
1749      istatus = nf90_get_var(this%ncid, ivarid, var)
1750    end if
1751
1752    if (istatus /= NF90_NOERR) then
1753      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
1754           &  var_name, ' as a 4D array: ', trim(nf90_strerror(istatus))
1755      call my_abort('Error reading NetCDF file')
1756    end if
1757
1758  end subroutine get_real_array4
1759
1760
1761  !---------------------------------------------------------------------
1762  ! Get attribute as a character string
1763  subroutine get_string_attribute(this, var_name, attr_name, attr_str)
1764    class(netcdf_file) :: this
1765
1766    character(len=*), intent(in)    :: var_name, attr_name
1767    character(len=*), intent(inout) :: attr_str
1768
1769    integer :: i_attr_len, ivarid
1770    integer :: istatus
1771    integer :: j
1772
1773    istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
1774    if (istatus /= NF90_NOERR) then
1775      write(nulerr,'(a,a,a,a)') '*** Error inquiring about variable ', var_name, &
1776           &                    ': ', trim(nf90_strerror(istatus))
1777      call my_abort('Error reading NetCDF file')
1778    end if
1779    istatus = nf90_inquire_attribute(this%ncid, ivarid, attr_name, &
1780         &                           len = i_attr_len)
1781    if (istatus /= NF90_NOERR) then
1782      write(nulerr,'(a,a,a,a)') '*** Error reading size of attribute ', attr_name, &
1783           &                    ': ', trim(nf90_strerror(istatus))
1784      call my_abort('Error reading NetCDF file')
1785    end if
1786
1787    ! Allocatable character strings not supported on enough compilers
1788    ! yet
1789    !    if (allocated(attr_str)) then
1790    !      deallocate(attr_str)
1791    !    end if
1792    !    allocate(character(len=i_attr_len) :: attr_str)
1793    if (len(attr_str) < i_attr_len) then
1794      write(nulerr,'(a,a)') '*** Not enough space to read attribute ', attr_name
1795      call my_abort('Error reading NetCDF file')
1796    end if
1797
1798    istatus = nf90_get_att(this%ncid, ivarid, attr_name, attr_str)
1799    if (istatus /= NF90_NOERR) then
1800      write(nulerr,'(a,a,a,a)') '*** Error reading attribute ', attr_name, &
1801           &                    ': ', trim(nf90_strerror(istatus))
1802      call my_abort('Error reading NetCDF file')
1803    end if
1804
1805    ! Pad with blanks since nf90_get_att does not do this
1806    do j = i_attr_len+1,len(attr_str)
1807      attr_str(j:j) = ' '
1808    end do
1809
1810  end subroutine get_string_attribute
1811
1812
1813
1814  !---------------------------------------------------------------------
1815  ! Get attribute as a real scalar
1816  subroutine get_real_scalar_attribute(this, var_name, attr_name, attr)
1817    class(netcdf_file) :: this
1818
1819    character(len=*), intent(in)  :: var_name, attr_name
1820    real(jprb),       intent(out) :: attr
1821
1822    integer :: ivarid
1823    integer :: istatus
1824
1825    istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
1826    if (istatus /= NF90_NOERR) then
1827      write(nulerr,'(a,a,a,a)') '*** Error inquiring about variable ', var_name, &
1828           &                    ': ', trim(nf90_strerror(istatus))
1829      call my_abort('Error reading NetCDF file')
1830    end if
1831    istatus = nf90_get_att(this%ncid, ivarid, attr_name, attr)
1832    if (istatus /= NF90_NOERR) then
1833      write(nulerr,'(a,a,a,a)') '*** Error reading attribute ', attr_name, &
1834           &                    ': ', trim(nf90_strerror(istatus))
1835      call my_abort('Error reading NetCDF file')
1836    end if
1837
1838  end subroutine get_real_scalar_attribute
1839
1840
1841  !---------------------------------------------------------------------
1842  ! Get a global attribute as a character string
1843  subroutine get_global_attribute(this, attr_name, attr_str)
1844    class(netcdf_file) :: this
1845
1846    character(len=*), intent(in)    :: attr_name
1847    character(len=*), intent(inout) :: attr_str
1848
1849    integer :: i_attr_len
1850    integer :: istatus
1851    integer :: j
1852
1853    istatus = nf90_inquire_attribute(this%ncid, NF90_GLOBAL, attr_name, &
1854         &                           len = i_attr_len)
1855    if (istatus /= NF90_NOERR) then
1856      write(nulerr,'(a,a,a,a)') '*** Error reading size of global attribute ', attr_name, &
1857           &                    ': ', trim(nf90_strerror(istatus))
1858      call my_abort('Error reading NetCDF file')
1859    end if
1860
1861    ! Allocatable character strings not supported one enough compilers
1862    ! yet
1863    !    if (allocated(attr_str)) then
1864    !      deallocate(attr_str)
1865    !    end if
1866    !    allocate(character(len=i_attr_len) :: attr_str)
1867    if (len(attr_str) < i_attr_len) then
1868      write(nulerr,'(a,a)') '*** Not enough space to read global attribute ', attr_name
1869      call my_abort('Error reading NetCDF file')
1870    end if
1871
1872    istatus = nf90_get_att(this%ncid, NF90_GLOBAL, attr_name, attr_str)
1873    if (istatus /= NF90_NOERR) then
1874      write(nulerr,'(a,a,a,a)') '*** Error reading global attribute ', attr_name, &
1875           &                    ': ', trim(nf90_strerror(istatus))
1876      call my_abort('Error reading NetCDF file')
1877    end if
1878
1879    ! Pad with blanks since nf90_get_att does not do this
1880    do j = i_attr_len+1,len(attr_str)
1881      attr_str(j:j) = ' '
1882    end do
1883
1884  end subroutine get_global_attribute
1885
1886
1887  !---------------------------------------------------------------------
1888  ! Print a variable's long_name, units and comment, according to
1889  ! verbosity level
1890  subroutine print_variable_attributes(this, ivarid, iunit)
1891    class(netcdf_file)  :: this
1892    integer, intent(in) :: ivarid   ! NetCDF ID of variable
1893    integer, intent(in) :: iunit    ! Unit to print information to
1894
1895    character(len=4000) :: attr_str
1896    integer :: istatus
1897
1898    if (this%iverbose >= 4) then
1899      istatus = nf90_get_att(this%ncid, ivarid, 'long_name', attr_str)
1900      if (istatus == NF90_NOERR) then
1901        write(iunit, '(a,a,a)', advance='no') ': "', trim(attr_str), '"'
1902        istatus = nf90_get_att(this%ncid, ivarid, 'units', attr_str)
1903        if (istatus == NF90_NOERR) then
1904          if (trim(attr_str) == '1') then
1905            write(iunit, '(a)') ' (dimensionless)'
1906          else
1907            write(iunit, '(a,a,a)') ' (', trim(attr_str), ')'
1908          end if
1909        else
1910          ! No units present
1911          write(iunit, '(1x)')
1912        end if
1913        if (this%iverbose >= 5) then
1914          istatus = nf90_get_att(this%ncid, ivarid, 'comment', attr_str)
1915          if (istatus == NF90_NOERR) then
1916            write(iunit, '(a,a,a)') 'comment="', trim(attr_str), '"'
1917          end if
1918        end if
1919      end if
1920    else
1921      ! No long_name present
1922      write(iunit, '(1x)')
1923    end if
1924
1925  end subroutine print_variable_attributes
1926
1927
1928  ! --- WRITING SUBROUTINES ---
1929
1930  !---------------------------------------------------------------------
1931  ! Define a dimension with name dim_name of length n (or 0 to
1932  ! indicate the unlimited dimension)
1933  subroutine define_dimension(this, dim_name, n)
1934    class(netcdf_file)           :: this
1935    character(len=*), intent(in) :: dim_name
1936    integer, intent(in)          :: n
1937    integer                      :: idimid, istatus
1938
1939    istatus = nf90_def_dim(this%ncid, dim_name, n, idimid)
1940    if (istatus /= NF90_NOERR) then
1941      write(nulerr,'(a,a,a,a)') '*** Error defining ', dim_name, &
1942           &   ' as a dimension: ', trim(nf90_strerror(istatus))
1943      call my_abort('Error writing NetCDF file')
1944    end if
1945
1946    if (this%iverbose >= 4) then
1947      write(nulout,'(a,a,a,i0)') '  Defining dimension ',trim(dim_name), &
1948           & ' of length ', n
1949    end if
1950
1951  end subroutine define_dimension
1952
1953
1954  !---------------------------------------------------------------------
1955  ! Define a variable with name var_name, and specify its shape via
1956  ! the dim1_name, dim2_name and dim3_name optional arguments, which
1957  ! are strings referring to existing dimensions. If none are
1958  ! specified, the variable will be a scalar. The optional arguments
1959  ! long_name, units and comment write string attributes with these
1960  ! names.
1961  subroutine define_variable(this, var_name, dim1_name, dim2_name, dim3_name, &
1962       &                     dim4_name, long_name, units_str, comment_str, &
1963       &                     standard_name, is_double, data_type_name, fill_value, &
1964       &                     deflate_level, shuffle, chunksizes, ndims)
1965    class(netcdf_file)                     :: this
1966    character(len=*), intent(in)           :: var_name
1967    character(len=*), intent(in), optional :: long_name, units_str, comment_str, standard_name
1968    character(len=*), intent(in), optional :: dim1_name, dim2_name, dim3_name, dim4_name
1969    logical,          intent(in), optional :: is_double
1970    character(len=*), intent(in), optional :: data_type_name
1971    real(jprb),       intent(in), optional :: fill_value
1972    integer,          intent(in), optional :: deflate_level ! Compression: 0 (none) to 9 (most)
1973    logical,          intent(in), optional :: shuffle ! Shuffle bytes before compression
1974    integer, dimension(:), intent(in), optional :: chunksizes
1975    integer,          intent(in), optional :: ndims
1976
1977    integer :: istatus, ndims_local, ndims_input, ivarid
1978    integer, dimension(NF90_MAX_VAR_DIMS) :: idimids
1979    integer :: data_type
1980
1981    ! Sometimes a program may not know at compile time the exact
1982    ! dimensions of a variable - if ndims is present then only up to
1983    ! that many dimensions will be defined
1984    ndims_input = 4
1985    if (present(ndims)) then
1986      ndims_input = ndims
1987    end if
1988
1989    if (present(dim1_name) .and. ndims_input >= 1) then
1990      ! Variable is at least one dimensional
1991      ndims_local = 1
1992      istatus = nf90_inq_dimid(this%ncid, dim1_name, idimids(1))
1993      if (istatus /= NF90_NOERR) then
1994        write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', &
1995             &             dim1_name, ': ', trim(nf90_strerror(istatus))
1996        call my_abort('Error writing NetCDF file')
1997      end if
1998      if (present(dim2_name) .and. ndims_input >= 2) then
1999        ! Variable is at least two dimensional
2000        ndims_local = 2
2001        istatus = nf90_inq_dimid(this%ncid, dim2_name, idimids(2))
2002        if (istatus /= NF90_NOERR) then
2003          write(nulerr,'(a,a,a)') '*** Error inquiring ID of dimension ', &
2004               &           dim2_name, ': ', trim(nf90_strerror(istatus))
2005          call my_abort('Error writing NetCDF file')
2006        end if
2007        if (present(dim3_name) .and. ndims_input >= 3) then
2008          ! Variable is at least three dimensional
2009          ndims_local = 3
2010          istatus = nf90_inq_dimid(this%ncid, dim3_name, idimids(3))
2011          if (istatus /= NF90_NOERR) then
2012            write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', &
2013                 &             dim3_name, ': ', trim(nf90_strerror(istatus))
2014            call my_abort('Error writing NetCDF file')
2015          end if
2016          if (present(dim4_name) .and. ndims_input >= 4) then
2017            ! Variable is at least three dimensional
2018            ndims_local = 4
2019            istatus = nf90_inq_dimid(this%ncid, dim4_name, idimids(4))
2020            if (istatus /= NF90_NOERR) then
2021              write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', &
2022                   &             dim4_name, ': ', trim(nf90_strerror(istatus))
2023              call my_abort('Error writing NetCDF file')
2024            end if
2025          end if
2026        end if
2027      end if
2028    else
2029      ! Variable is a scalar
2030      ndims_local = 0
2031    end if
2032
2033    ! Read output precision from optional argument "is_double" if
2034    ! present, otherwise from default output precision for this file
2035    if (present(data_type_name)) then
2036      if (data_type_name == 'double') then
2037        data_type = NF90_DOUBLE
2038      else if (data_type_name == 'byte') then
2039        data_type = NF90_BYTE
2040      else if (data_type_name == 'short') then
2041        data_type = NF90_SHORT
2042      else if (data_type_name == 'int') then
2043        data_type = NF90_INT
2044      else if (data_type_name == 'float') then
2045        data_type = NF90_FLOAT
2046      else
2047        write(nulerr,'(a,a,a)') '*** NetCDF data type "', data_type_name, '" not supported'
2048        call my_abort('Error writing NetCDF file')
2049      end if
2050    else if (present(is_double)) then
2051      if (is_double) then
2052        data_type = NF90_DOUBLE
2053      else
2054        data_type = NF90_FLOAT
2055      end if
2056    else if (this%is_double_precision) then
2057      data_type = NF90_DOUBLE
2058    else
2059      data_type = NF90_FLOAT
2060    end if
2061
2062    ! Define variable
2063#ifdef NC_NETCDF4
2064    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), &
2065         & ivarid, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes)
2066#else
2067    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), ivarid)
2068#endif
2069    if (istatus /= NF90_NOERR) then
2070      write(nulerr,'(a,a,a,a)') '*** Error defining variable ', var_name, &
2071           &                    ': ', trim(nf90_strerror(istatus))
2072      call my_abort('Error writing NetCDF file')
2073    end if
2074
2075    ! Add optional attributes
2076    if (present(long_name)) then
2077      istatus = nf90_put_att(this%ncid, ivarid, "long_name", long_name)
2078      if (this%iverbose >= 4) then
2079        write(nulout,'(a,a,a,a,a)', advance='no') '  Defining ',trim(var_name), &
2080             &  ': "', long_name, '"'
2081      end if
2082    else
2083      if (this%iverbose >= 4) then
2084        write(nulout,'(a,a)', advance='no') '  Defining ',trim(var_name)
2085      end if
2086    end if
2087
2088    if (present(units_str)) then
2089      istatus = nf90_put_att(this%ncid, ivarid, "units", units_str)
2090      if (this%iverbose >= 4) then
2091        if (trim(units_str) == '1') then
2092          write(nulout, '(a)') ' (dimensionless)'
2093        else
2094          write(nulout, '(a,a,a)') ' (', trim(units_str), ')'
2095        end if
2096      end if
2097    else
2098      if (this%iverbose >= 4) then
2099        write(nulout, '(1x)')
2100      end if
2101    end if
2102
2103    if (present(standard_name)) then
2104      istatus = nf90_put_att(this%ncid, ivarid, "standard_name", standard_name)
2105    end if
2106    if (present(comment_str)) then
2107      istatus = nf90_put_att(this%ncid, ivarid, "comment", comment_str)
2108    end if
2109
2110    if (present(fill_value)) then
2111#ifdef NC_NETCDF4
2112      if (data_type == NF90_DOUBLE) then
2113        istatus = nf90_def_var_fill(this%ncid, ivarid, 0, real(fill_value,jprd))
2114      else if (data_type == NF90_FLOAT) then
2115        istatus = nf90_def_var_fill(this%ncid, ivarid, 0, real(fill_value,jprm))
2116      else if (data_type == NF90_INT) then
2117        istatus = nf90_def_var_fill(this%ncid, ivarid, 0, int(fill_value,4))
2118      else if (data_type == NF90_SHORT) then
2119        istatus = nf90_def_var_fill(this%ncid, ivarid, 0, int(fill_value,2))
2120      else if (data_type == NF90_BYTE) then
2121        istatus = nf90_def_var_fill(this%ncid, ivarid, 0, int(fill_value,1))
2122      end if
2123#else
2124      if (data_type == NF90_DOUBLE) then
2125        istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", real(fill_value,jprd))
2126      else if (data_type == NF90_FLOAT) then
2127        istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", real(fill_value,jprm))
2128      else if (data_type == NF90_INT) then
2129        istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", int(fill_value,4))
2130      else if (data_type == NF90_SHORT) then
2131        istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", int(fill_value,2))
2132      else if (data_type == NF90_BYTE) then
2133        istatus = nf90_put_att(this%ncid, ivarid, "_FillValue", int(fill_value,1))
2134      end if
2135#endif
2136    end if
2137
2138  end subroutine define_variable
2139
2140
2141  !---------------------------------------------------------------------
2142  ! Put CF-compliant global attributes into the file
2143  subroutine put_global_attributes(this, title_str, inst_str, source_str, &
2144       &  comment_str, references_str, creator_name, creator_email_str, &
2145       &  contributor_name, project_str, conventions_str, prior_history_str)
2146    class(netcdf_file)                     :: this
2147
2148    character(len=*), intent(in), optional :: title_str
2149    character(len=*), intent(in), optional :: inst_str
2150    character(len=*), intent(in), optional :: source_str
2151    character(len=*), intent(in), optional :: creator_name, creator_email_str
2152    character(len=*), intent(in), optional :: contributor_name, project_str
2153    character(len=*), intent(in), optional :: comment_str, conventions_str
2154    character(len=*), intent(in), optional :: references_str, prior_history_str
2155
2156    character(len=32)   :: date_time_str
2157    character(len=4000) :: command_line_str
2158    character(len=4032) :: history_str
2159
2160    integer :: time_vals(8)
2161    integer :: i ! status
2162
2163    call date_and_time(values=time_vals)
2164    call get_command(command_line_str)
2165
2166    write(date_time_str,"(i0.4,'-',i0.2,'-',i0.2,' ',i0.2,':',i0.2,':',i0.2)") &
2167         &   time_vals(1), time_vals(2), time_vals(3), time_vals(5), time_vals(6), time_vals(7)
2168
2169    if (present(prior_history_str)) then
2170      history_str = trim(prior_history_str) // new_line('a') &
2171           &  // trim(date_time_str) // ': ' // trim(command_line_str)
2172    else
2173      history_str = trim(date_time_str) // ': ' // trim(command_line_str)
2174    end if
2175
2176    if (present(title_str))   i=nf90_put_att(this%ncid, NF90_GLOBAL, "title", title_str)
2177    if (present(inst_str))    i=nf90_put_att(this%ncid, NF90_GLOBAL, "institution", inst_str)
2178    if (present(source_str))  i=nf90_put_att(this%ncid, NF90_GLOBAL, "source", source_str)
2179    if (present(creator_name))i=nf90_put_att(this%ncid, NF90_GLOBAL, "creator_name", creator_name)
2180    if (present(creator_email_str))i=nf90_put_att(this%ncid, NF90_GLOBAL, "creator_email", creator_email_str)
2181    if (present(contributor_name))i=nf90_put_att(this%ncid, NF90_GLOBAL, "contributor_name", contributor_name)
2182
2183    i = nf90_put_att(this%ncid, NF90_GLOBAL, "history", history_str)
2184
2185    if (present(project_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "project", project_str)
2186    if (present(comment_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, "comment", comment_str)
2187    if (present(references_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, &
2188         &  "references", references_str)
2189    if (present(conventions_str)) i=nf90_put_att(this%ncid, NF90_GLOBAL, &
2190         &  "conventions", conventions_str)
2191
2192  end subroutine put_global_attributes
2193
2194
2195  !---------------------------------------------------------------------
2196  ! Put a non-standard global attribute into the file
2197  subroutine put_global_attribute(this, attr_name, attr_str)
2198    class(netcdf_file) :: this
2199
2200    character(len=*), intent(in) :: attr_name, attr_str
2201
2202    integer :: istatus
2203
2204    istatus = nf90_put_att(this%ncid, NF90_GLOBAL, trim(attr_name), trim(attr_str))
2205
2206    if (istatus /= NF90_NOERR) then
2207      write(nulerr,'(a,a,a,a)') '*** Error writing global attribute ', attr_name, &
2208           &                    ': ', trim(nf90_strerror(istatus))
2209      call my_abort('Error writing NetCDF file')
2210    end if
2211
2212  end subroutine put_global_attribute
2213
2214
2215  !---------------------------------------------------------------------
2216  ! Put a non-standard variable attribute into the file
2217  subroutine put_attribute(this, var_name, attr_name, attr_str)
2218    class(netcdf_file) :: this
2219
2220    character(len=*), intent(in) :: var_name, attr_name, attr_str
2221
2222    integer :: istatus, ivarid
2223
2224    call this%get_variable_id(var_name, ivarid)
2225
2226    istatus = nf90_put_att(this%ncid, ivarid, trim(attr_name), trim(attr_str))
2227
2228    if (istatus /= NF90_NOERR) then
2229      write(nulerr,'(a,a,a,a)') '*** Error writing attribute ', attr_name, &
2230           &                    ': ', trim(nf90_strerror(istatus))
2231      call my_abort('Error writing NetCDF file')
2232    end if
2233
2234  end subroutine put_attribute
2235
2236
2237  !---------------------------------------------------------------------
2238  ! The "put" method saves a scalar, vector or matrix into the
2239  ! variable with name var_name, according to the rank of the var
2240  ! argument. This version saves a scalar.
2241  subroutine put_real_scalar(this, var_name, var)
2242    class(netcdf_file)             :: this
2243    character(len=*), intent(in)   :: var_name
2244    real(jprb), intent(in)         :: var
2245
2246    integer :: ivarid, ndims, istatus
2247    integer(kind=jpib) :: ntotal
2248    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2249
2250    ! If we are in define mode, exit define mode
2251    call this%end_define_mode()
2252
2253    ! Check the variable is a scalar
2254    call this%get_variable_id(var_name, ivarid)
2255    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
2256    if (ntotal /= 1) then
2257      write(nulerr,'(a,a,a,i0)') '*** Error: attempt to write scalar to ', &
2258           &                 var_name, ' which has total length ', ntotal
2259      call my_abort('Error writing NetCDF file')
2260    end if
2261
2262    ! Save the scalar
2263    istatus = nf90_put_var(this%ncid, ivarid, var)
2264    if (istatus /= NF90_NOERR) then
2265      write(nulerr,'(a,a,a,a)') '*** Error writing scalar ', var_name, ': ', &
2266           &                    trim(nf90_strerror(istatus))
2267      call my_abort('Error writing NetCDF file')
2268    end if
2269
2270  end subroutine put_real_scalar
2271
2272
2273  !---------------------------------------------------------------------
2274  ! Save a scalar.
2275  subroutine put_real_scalar_indexed(this, var_name, index, var)
2276    class(netcdf_file)             :: this
2277    character(len=*), intent(in)   :: var_name
2278    real(jprb), intent(in)         :: var
2279    integer, intent(in)            :: index
2280
2281    integer :: ivarid, ndims, istatus
2282    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2283    integer :: vstart(NF90_MAX_VAR_DIMS)
2284
2285    ! If we are in define mode, exit define mode
2286    call this%end_define_mode()
2287
2288    ! Check the variable is a scalar
2289    call this%get_variable_id(var_name, ivarid)
2290    call this%get_array_dimensions(ivarid, ndims, ndimlens)
2291    if (index < 1 .or. index > ndimlens(ndims)) then
2292      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write scalar to element ', &
2293           &  index, ' of ', var_name, ' which has outer dimension  ', ndimlens(ndims)
2294      call my_abort('Error writing NetCDF file')
2295    end if
2296
2297    ! Save the scalar
2298    vstart(1:ndims-1) = 1
2299    vstart(ndims)     = index
2300    istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart)
2301    if (istatus /= NF90_NOERR) then
2302      write(nulerr,'(a,a,a,a)') '*** Error writing scalar to ', var_name, ': ', &
2303           &                    trim(nf90_strerror(istatus))
2304      call my_abort('Error writing NetCDF file')
2305    end if
2306
2307  end subroutine put_real_scalar_indexed
2308
2309
2310  !---------------------------------------------------------------------
2311  ! Save a vector with name var_name in the file
2312  subroutine put_real_vector(this, var_name, var)
2313    class(netcdf_file)             :: this
2314    character(len=*), intent(in)   :: var_name
2315    real(jprb), intent(in)         :: var(:)
2316
2317    integer :: ivarid, ndims, istatus
2318    integer(kind=jpib) :: ntotal
2319    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2320
2321    call this%end_define_mode()
2322
2323    ! Check the vector is of the right length
2324    call this%get_variable_id(var_name, ivarid)
2325    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
2326    if (ntotal /= size(var,kind=jpib)) then
2327      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', &
2328           & size(var), ' to ', var_name, ' which has total length ', ntotal
2329      call my_abort('Error writing NetCDF file')
2330    end if
2331
2332    ! Save the vector
2333    istatus = nf90_put_var(this%ncid, ivarid, var)
2334    if (istatus /= NF90_NOERR) then
2335      write(nulerr,'(a,a,a,a)') '*** Error writing vector ', var_name, ': ', &
2336           &                    trim(nf90_strerror(istatus))
2337      call my_abort('Error writing NetCDF file')
2338    end if
2339
2340  end subroutine put_real_vector
2341
2342
2343  !---------------------------------------------------------------------
2344  ! Save an integer vector with name var_name in the file
2345  subroutine put_int_vector(this, var_name, var)
2346    class(netcdf_file)             :: this
2347    character(len=*), intent(in)   :: var_name
2348    integer,          intent(in)   :: var(:)
2349
2350    integer :: ivarid, ndims, istatus
2351    integer(kind=jpib) :: ntotal
2352    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2353
2354    call this%end_define_mode()
2355
2356    ! Check the vector is of the right length
2357    call this%get_variable_id(var_name, ivarid)
2358    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
2359    if (ntotal /= size(var,kind=jpib)) then
2360      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', &
2361           & size(var), ' to ', var_name, ' which has total length ', ntotal
2362      call my_abort('Error writing NetCDF file')
2363    end if
2364
2365    ! Save the vector
2366    istatus = nf90_put_var(this%ncid, ivarid, var)
2367    if (istatus /= NF90_NOERR) then
2368      write(nulerr,'(a,a,a,a)') '*** Error writing vector ', var_name, ': ', &
2369           &                    trim(nf90_strerror(istatus))
2370      call my_abort('Error writing NetCDF file')
2371    end if
2372
2373  end subroutine put_int_vector
2374
2375
2376  !---------------------------------------------------------------------
2377  ! Save a vector slice with name var_name in the file
2378  subroutine put_real_vector_indexed(this, var_name, var, index2, index3)
2379    class(netcdf_file)             :: this
2380    character(len=*), intent(in)   :: var_name
2381    real(jprb), intent(in)         :: var(:)
2382    integer, intent(in)            :: index2
2383    integer, intent(in), optional  :: index3
2384
2385    integer :: ivarid, ndims, istatus
2386    integer(kind=jpib) :: ntotal
2387    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2388    integer :: vstart(NF90_MAX_VAR_DIMS)
2389    integer :: vcount(NF90_MAX_VAR_DIMS)
2390
2391    character(len=512) :: var_slice_name
2392    integer :: index_last
2393
2394    call this%end_define_mode()
2395
2396    ! Check the vector is of the right length
2397    call this%get_variable_id(var_name, ivarid)
2398    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
2399    ntotal = ntotal / ndimlens(ndims)
2400    if (present(index3)) then
2401      ntotal = ntotal / ndimlens(ndims-1)
2402      index_last = index3
2403      write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,', index2, ',', index3, ')'
2404    else
2405      index_last = index2
2406      write(var_slice_name,'(a,a,i0,a)') var_name, '(:,', index2, ')'
2407    end if
2408
2409    if (ntotal /= size(var,kind=jpib)) then
2410      write(nulerr,'(a,i0,a,a,i0)') '*** Error: attempt to write vector of length ', &
2411           & size(var), ' to ', trim(var_slice_name), ' which has length ', ntotal
2412      call my_abort('Error writing NetCDF file')
2413    end if
2414    if (index_last < 1 .or. index_last > ndimlens(ndims)) then
2415      write(nulerr,'(a,a,a,i0)') '*** Error: attempt to write vector to ', &
2416           &  trim(var_slice_name), ' which has outer dimension  ', ndimlens(ndims)
2417      call my_abort('Error writing NetCDF file')
2418    end if
2419
2420    ! Save the vector
2421    vstart(1:ndims-1) = 1
2422    vcount(1:ndims-1) = ndimlens(1:ndims-1)
2423    vcount(ndims)     = 1
2424    if (present(index3)) then
2425      vstart(ndims)   = index3
2426      vstart(ndims-1) = index2
2427      vcount(ndims-1) = 1
2428    else
2429      vstart(ndims)   = index2
2430    end if
2431
2432    istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount)
2433    if (istatus /= NF90_NOERR) then
2434      write(nulerr,'(a,a,a,a)') '*** Error writing vector to ', trim(var_slice_name), &
2435           &  ': ', trim(nf90_strerror(istatus))
2436      call my_abort('Error writing NetCDF file')
2437    end if
2438
2439  end subroutine put_real_vector_indexed
2440
2441
2442  !---------------------------------------------------------------------
2443  ! Save a matrix with name var_name in the file, transposing its
2444  ! dimensions if either optional argument transp is .true., or the
2445  ! transpose_matrices method has already been called.
2446  subroutine put_real_matrix(this, var_name, var, do_transp)
2447    class(netcdf_file)             :: this
2448    character(len=*), intent(in)   :: var_name
2449    real(jprb), intent(in)         :: var(:,:)
2450    real(jprb), allocatable        :: var_transpose(:,:)
2451    logical, optional, intent(in):: do_transp
2452
2453    integer :: ivarid, ndims, nvarlen, istatus
2454    integer(kind=jpib) :: ntotal
2455    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2456
2457    logical :: do_transpose
2458
2459    if (present(do_transp)) then
2460      do_transpose = do_transp
2461    else
2462      do_transpose = this%do_transpose_2d
2463    end if
2464
2465    call this%end_define_mode()
2466
2467    call this%get_variable_id(var_name, ivarid)
2468    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
2469
2470    nvarlen = size(var,1)*size(var,2)
2471
2472    ! Check the total size of the variable to be stored (but receiving
2473    ! ntotal is zero then there must be an unlimited dimension)
2474    if (ntotal /= size(var,kind=jpib) .and. ntotal /= 0) then
2475      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write matrix of total size ', &
2476           & nvarlen, ' to ', var_name, ' which has total size ', ntotal
2477      call my_abort('Error writing NetCDF file')
2478    end if
2479
2480    if (do_transpose) then
2481      ! Save the matrix with transposition
2482      if (this%iverbose >= 3) then
2483        write(nulout,'(a,a,a)') '  Writing ', var_name, &
2484             & ' (transposing dimensions)'
2485      end if
2486      allocate(var_transpose(size(var,2), size(var,1)))
2487      var_transpose = transpose(var)
2488      istatus = nf90_put_var(this%ncid, ivarid, var_transpose)
2489      deallocate(var_transpose)
2490    else
2491      ! Save the matrix without transposition
2492      if (this%iverbose >= 3) then
2493        write(nulout,'(a,a)') '  Writing ', var_name
2494      end if
2495      istatus = nf90_put_var(this%ncid, ivarid, var)
2496    end if
2497
2498    if (istatus /= NF90_NOERR) then
2499      write(nulerr,'(a,a,a,a)') '*** Error writing matrix ', var_name, &
2500           &                    ': ', trim(nf90_strerror(istatus))
2501      call my_abort('Error writing NetCDF file')
2502    end if
2503
2504  end subroutine put_real_matrix
2505
2506
2507  !---------------------------------------------------------------------
2508  ! Save a matrix slice with name var_name in the file, transposing its
2509  ! dimensions if either optional argument transp is .true., or the
2510  ! transpose_matrices method has already been called.
2511  subroutine put_real_matrix_indexed(this, var_name, var, index3, index4, do_transp)
2512    class(netcdf_file)             :: this
2513    character(len=*), intent(in)   :: var_name
2514    real(jprb), intent(in)         :: var(:,:)
2515    integer, intent(in)            :: index3
2516    integer, intent(in), optional  :: index4
2517
2518    real(jprb), allocatable        :: var_transpose(:,:)
2519    logical, optional, intent(in)  :: do_transp
2520
2521    integer :: ivarid, ndims, nvarlen, istatus
2522    integer(kind=jpib) :: ntotal
2523    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2524    integer :: vstart(NF90_MAX_VAR_DIMS)
2525    integer :: vcount(NF90_MAX_VAR_DIMS)
2526
2527    character(len=512) :: var_slice_name
2528
2529    logical :: do_transpose
2530
2531    if (present(do_transp)) then
2532      do_transpose = do_transp
2533    else
2534      do_transpose = this%do_transpose_2d
2535    end if
2536
2537    call this%end_define_mode()
2538
2539    call this%get_variable_id(var_name, ivarid)
2540    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
2541
2542    nvarlen = size(var,1)*size(var,2)
2543
2544    ! Check the total size of the variable to be stored (but receiving
2545    ! ntotal is zero then there must be an unlimited dimension)
2546    ntotal = ntotal / ndimlens(ndims)
2547    if (present(index4)) then
2548      ntotal = ntotal / ndimlens(ndims-1)
2549      write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,:,', index3, ',', index4, ')'
2550    else
2551      write(var_slice_name,'(a,a,i0,a)') var_name, '(:,:,', index3, ')'
2552    end if
2553    if (ntotal /= size(var,kind=jpib) .and. ntotal /= 0) then
2554      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write matrix of total size ', &
2555           & nvarlen, ' to ', trim(var_slice_name), ' which has total size ', ntotal
2556      call my_abort('Error writing NetCDF file')
2557    end if
2558
2559    vstart(1:ndims-1) = 1
2560    vcount(1:ndims-1) = ndimlens(1:ndims-1)
2561    vcount(ndims)     = 1
2562    if (present(index4)) then
2563      vstart(ndims)   = index4
2564      vstart(ndims-1) = index3
2565      vcount(ndims-1) = 1
2566    else
2567      vstart(ndims)   = index3
2568    end if
2569
2570    if (do_transpose) then
2571      ! Save the matrix with transposition
2572      if (this%iverbose >= 3) then
2573        write(nulout,'(a,a,a)') '  Writing ', trim(var_slice_name), &
2574             & ' (transposing dimensions)'
2575      end if
2576      allocate(var_transpose(size(var,2), size(var,1)))
2577      var_transpose = transpose(var)
2578      istatus = nf90_put_var(this%ncid, ivarid, var_transpose, start=vstart, count=vcount)
2579      deallocate(var_transpose)
2580    else
2581      ! Save the matrix without transposition
2582      if (this%iverbose >= 3) then
2583        write(nulout,'(a,a)') '  Writing ', trim(var_slice_name)
2584      end if
2585      istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount)
2586    end if
2587
2588    if (istatus /= NF90_NOERR) then
2589      write(nulerr,'(a,a,a)') '*** Error writing ', trim(var_slice_name), &
2590           &                    ': ', trim(nf90_strerror(istatus))
2591      call my_abort('Error writing NetCDF file')
2592    end if
2593
2594  end subroutine put_real_matrix_indexed
2595
2596
2597  !---------------------------------------------------------------------
2598  ! Save a 3D array with name var_name in the file.  The optional
2599  ! argument permute specifies that the dimensions should first be
2600  ! permuted according to the three integers therein (or if
2601  ! permute_3d_arrays has already been called). ipermute is
2602  ! interpretted such that if OLD and NEW are 3-element vectors
2603  ! containing the size of each dimension in memory and in the written
2604  ! file, respectively, then NEW=OLD(ipermute).
2605  subroutine put_real_array3(this, var_name, var, ipermute)
2606    class(netcdf_file)             :: this
2607    character(len=*), intent(in)   :: var_name
2608    real(jprb), intent(in)         :: var(:,:,:)
2609    real(jprb), allocatable        :: var_permute(:,:,:)
2610    integer, optional, intent(in)  :: ipermute(3)
2611
2612    integer :: ivarid, ndims, nvarlen, istatus
2613    integer(kind=jpib) :: ntotal
2614    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2615
2616    logical :: do_permute          ! Do we permute?
2617    integer :: i_permute_3d(3)
2618    integer :: n_dimlens_permuted(3)
2619    integer :: i_order(3)
2620
2621    ! Decide whether to permute
2622    if (present(ipermute)) then
2623      do_permute   = .true.
2624      i_permute_3d = ipermute
2625    else
2626      do_permute   = this%do_permute_3d
2627      i_permute_3d = this%i_permute_3d
2628    end if
2629
2630    call this%end_define_mode()
2631
2632    ! Check total size
2633    call this%get_variable_id(var_name, ivarid)
2634    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
2635    nvarlen = size(var,1)*size(var,2)*size(var,3)
2636    if (ntotal /= size(var,kind=jpib)) then
2637      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write array of total size ', &
2638           & nvarlen, ' to ', var_name, ' which has total size ', ntotal
2639      call my_abort('Error writing NetCDF file')
2640    end if
2641
2642    if (do_permute) then
2643      ! Save array after permuting dimensions
2644      if (this%iverbose >= 3) then
2645        write(nulout,'(a,a,a,i0,i0,i0,a)') '  Writing ', var_name, &
2646             & ' (permuting dimensions: ', i_permute_3d, ')'
2647      end if
2648      n_dimlens_permuted = (/ size(var,i_permute_3d(1)), &
2649           &                  size(var,i_permute_3d(2)), &
2650           &                  size(var,i_permute_3d(3))  /)
2651      !! FIX: This makes it look like the dimensions have stayed the same
2652      ! if (this%iverbose >= 4) then
2653      !   write(nulout,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)') '    (', &
2654      !        &  n_dimlens_permuted(1), ',', n_dimlens_permuted(2), &
2655      !        &  ',', n_dimlens_permuted(3), ') -> (', ndimlens(1), &
2656      !        &  ',', ndimlens(2), ',', ndimlens(3), ')'
2657      ! end if
2658      allocate(var_permute(n_dimlens_permuted(1), &
2659           &   n_dimlens_permuted(2), n_dimlens_permuted(3)))
2660      ! Due to the odd way that ORDER works in Fortran RESHAPE, we
2661      ! need to do this:
2662      i_order(i_permute_3d) = (/ 1, 2, 3 /)
2663      var_permute = reshape(var, n_dimlens_permuted, order=i_order)
2664      istatus = nf90_put_var(this%ncid, ivarid, var_permute)
2665      deallocate(var_permute)
2666    else
2667      ! Save array without permuting dimensions
2668      if (this%iverbose >= 3) then
2669        write(nulout,'(a,a)') '  Writing ', var_name
2670      end if
2671      istatus = nf90_put_var(this%ncid, ivarid, var)
2672    end if
2673
2674    if (istatus /= NF90_NOERR) then
2675      write(nulerr,'(a,a,a,a)') '*** Error writing array ', var_name, &
2676           &                    ': ', trim(nf90_strerror(istatus))
2677      call my_abort('Error writing NetCDF file')
2678    end if
2679
2680  end subroutine put_real_array3
2681
2682
2683#ifdef NC_NETCDF4
2684  !---------------------------------------------------------------------
2685  ! Copy dimensions from "infile" to "this"
2686  subroutine copy_dimensions(this, infile)
2687    class(netcdf_file)            :: this
2688    type(netcdf_file), intent(in) :: infile
2689
2690    integer :: jdim
2691    integer :: ndims
2692    integer :: idimids(1024)
2693    integer :: dimlen
2694    character(len=512) :: dimname
2695    integer :: istatus
2696    integer :: include_parents
2697   
2698    include_parents = 0
2699
2700    istatus = nf90_inq_dimids(infile%ncid, ndims, idimids, include_parents)
2701    if (istatus /= NF90_NOERR) then
2702      write(nulerr,'(a,a)') '*** Error reading dimensions of NetCDF file: ', &
2703           trim(nf90_strerror(istatus))
2704      call my_abort('Error reading NetCDF file')
2705    end if
2706
2707    do jdim = 1,ndims
2708      istatus = nf90_inquire_dimension(infile%ncid, idimids(jdim), &
2709           &  name=dimname, len=dimlen)
2710      if (istatus /= NF90_NOERR) then
2711        write(nulerr,'(a,a)') '*** Error reading NetCDF dimension properties: ', &
2712             trim(nf90_strerror(istatus))
2713        call my_abort('Error reading NetCDF file')
2714      end if
2715      call this%define_dimension(trim(dimname), dimlen)
2716    end do
2717
2718  end subroutine copy_dimensions
2719#endif
2720
2721  !---------------------------------------------------------------------
2722  ! Copy variable definition and attributes from "infile" to "this"
2723  subroutine copy_variable_definition(this, infile, var_name)
2724    class(netcdf_file)            :: this
2725    type(netcdf_file), intent(in) :: infile
2726    character(len=*),  intent(in) :: var_name
2727
2728#ifdef NC_NETCDF4
2729    integer :: deflate_level  ! Compression: 0 (none) to 9 (most)
2730    logical :: shuffle        ! Shuffle bytes before compression
2731    integer :: chunksizes(NF90_MAX_VAR_DIMS)
2732#endif
2733    integer :: data_type
2734    integer :: ndims
2735    integer :: idimids_in(NF90_MAX_VAR_DIMS)
2736    integer :: idimids_out(NF90_MAX_VAR_DIMS)
2737    integer :: nattr
2738    character(len=512) :: attr_name
2739    character(len=512) :: dim_name
2740
2741    integer :: istatus
2742    integer :: ivarid_in, ivarid_out
2743    integer :: jattr, jdim
2744
2745    if (this%iverbose >= 4) then
2746      write(nulout,'(a,a)') '  Copying definition of ', trim(var_name)
2747    end if
2748
2749    ! Get variable ID from name
2750    istatus = nf90_inq_varid(infile%ncid, trim(var_name), ivarid_in)
2751    if (istatus /= NF90_NOERR) then
2752      write(nulerr,'(a,a,a)') '*** Error inquiring about NetCDF variable "', &
2753           & trim(var_name), '": ', trim(nf90_strerror(istatus))
2754      call my_abort('Error reading NetCDF file')
2755    end if
2756
2757    ! Get variable properties
2758#ifdef NC_NETCDF4
2759    istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, &
2760         &  dimids=idimids_in, chunksizes=chunksizes, deflate_level=deflate_level, &
2761         &  shuffle=shuffle, natts=nattr)
2762#else
2763    istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, &
2764         &  dimids=idimids_in, natts=nattr)
2765#endif
2766    if (istatus /= NF90_NOERR) then
2767      write(nulerr,'(a,a)') '*** Error reading NetCDF variable properties: ', &
2768           trim(nf90_strerror(istatus))
2769      call my_abort('Error reading NetCDF file')
2770    end if
2771
2772    ! Map dimension IDs
2773    do jdim = 1,ndims
2774      istatus = nf90_inquire_dimension(infile%ncid, idimids_in(jdim), name=dim_name)
2775      if (istatus /= NF90_NOERR) then
2776        write(nulerr,'(a,a)') '*** Error reading NetCDF dimension name: ', &
2777             trim(nf90_strerror(istatus))
2778        call my_abort('Error reading NetCDF file')
2779      end if
2780
2781      istatus = nf90_inq_dimid(this%ncid, trim(dim_name), idimids_out(jdim))
2782      if (istatus /= NF90_NOERR) then
2783        write(nulerr,'(a,a)') '*** Error reading NetCDF dimension ID: ', &
2784             trim(nf90_strerror(istatus))
2785        call my_abort('Error reading NetCDF file')
2786      end if
2787    end do
2788
2789    ! Create variable
2790#ifdef NC_NETCDF4
2791    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), &
2792         & ivarid_out, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes(1:ndims))
2793#else
2794    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), ivarid_out)
2795#endif
2796    if (istatus /= NF90_NOERR) then
2797      write(nulerr,'(a,a,a,a)') '*** Error defining variable "', var_name, &
2798           &                    '": ', trim(nf90_strerror(istatus))
2799      call my_abort('Error writing NetCDF file')
2800    end if
2801
2802    ! Copy attributes
2803    do jattr = 1,nattr
2804      istatus = nf90_inq_attname(infile%ncid, ivarid_in, jattr, attr_name)
2805      if (istatus /= NF90_NOERR) then
2806        write(nulerr,'(a,a)') '*** Error reading attribute: ', &
2807             &  trim(nf90_strerror(istatus))
2808        call my_abort('Error reading NetCDF file')
2809      end if
2810      istatus = nf90_copy_att(infile%ncid, ivarid_in, trim(attr_name), &
2811           &                    this%ncid, ivarid_out)
2812
2813    end do
2814
2815  end subroutine copy_variable_definition
2816
2817
2818  !---------------------------------------------------------------------
2819  ! Copy variable from "infile" to "this"
2820  subroutine copy_variable(this, infile, var_name)
2821    class(netcdf_file)             :: this
2822    class(netcdf_file), intent(in) :: infile
2823    character(len=*),   intent(in) :: var_name
2824
2825    integer :: ivarid_in, ivarid_out
2826    integer :: ndims
2827    integer :: ndimlens(NF90_MAX_VAR_DIMS)
2828    integer(kind=jpib) :: ntotal, ntotal_out
2829    integer :: data_type
2830    integer :: istatus
2831
2832    ! We use the Fortran-77 functions because they don't check that
2833    ! the rank of the arguments is correct
2834    integer, external :: nf_get_var_double, nf_put_var_double
2835    integer, external :: nf_get_var_int, nf_put_var_int
2836
2837    real(kind=jprd), allocatable :: data_real(:)
2838    integer,         allocatable :: data_int(:)
2839
2840    ! If we are in define mode, exit define mode
2841    call this%end_define_mode()
2842
2843    if (this%iverbose >= 4) then
2844      write(nulout,'(a,a)') '  Copying ', trim(var_name)
2845    end if
2846
2847    call infile%get_variable_id(var_name, ivarid_in)
2848    call infile%get_array_dimensions(ivarid_in, ndims, ndimlens, ntotal)
2849    istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type)
2850    if (istatus /= NF90_NOERR) then
2851      write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', &
2852           &  trim(nf90_strerror(istatus))
2853      call my_abort('Error reading NetCDF file')
2854    end if
2855
2856    call this%get_variable_id(var_name, ivarid_out)
2857    call this%get_array_dimensions(ivarid_out, ndims, ndimlens, ntotal_out)
2858    if (ntotal /= ntotal_out) then
2859      write(nulerr,'(a)') '*** Error: size mismatch between input and output variables'
2860      call my_abort('Error writing NetCDF file')
2861    end if
2862   
2863    if (data_type == NF90_DOUBLE .or. data_type == NF90_FLOAT) then
2864      allocate(data_real(ntotal))
2865      !istatus = nf90_get_var(infile%ncid, ivarid_in, data_real(1))
2866      istatus = nf_get_var_double(infile%ncid, ivarid_in, data_real)
2867      if (istatus /= NF90_NOERR) then
2868        deallocate(data_real)
2869        write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', &
2870             &  trim(nf90_strerror(istatus))
2871        call my_abort('Error reading NetCDF file')
2872      end if
2873
2874      !istatus = nf90_put_var(this%ncid, ivarid_out, data_real)
2875      istatus = nf_put_var_double(this%ncid, ivarid_out, data_real)
2876      deallocate(data_real)
2877      if (istatus /= NF90_NOERR) then
2878        write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', &
2879             &  trim(nf90_strerror(istatus))
2880        call my_abort('Error writing NetCDF file')
2881      end if
2882
2883    else
2884      allocate(data_int(ntotal))
2885      !istatus = nf90_get_var(infile%ncid, ivarid_in, data_int)
2886      istatus = nf_get_var_int(infile%ncid, ivarid_in, data_int)
2887      if (istatus /= NF90_NOERR) then
2888        deallocate(data_int)
2889 
2890        write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', &
2891             &  trim(nf90_strerror(istatus))
2892        call my_abort('Error reading NetCDF file')
2893      end if
2894
2895      !istatus = nf90_put_var(this%ncid, ivarid_out, data_int)
2896      istatus = nf_put_var_int(this%ncid, ivarid_out, data_int)
2897      deallocate(data_int)
2898      if (istatus /= NF90_NOERR) then
2899        write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', &
2900             &  trim(nf90_strerror(istatus))
2901        call my_abort('Error writing NetCDF file')
2902      end if
2903    end if
2904
2905  end subroutine copy_variable
2906
2907end module easy_netcdf
Note: See TracBrowser for help on using the repository browser.