module scan_input use netcdf type input_handle_type integer :: ncid integer :: num_vars = 0 integer :: current_var = 0 integer, dimension(:), pointer :: varids => null() integer :: unlimited_dimid end type input_handle_type type input_field_type character (len=64) :: name logical :: isTimeDependent = .false. integer :: varid = -1 integer :: xtype = -1 integer :: ndims = -1 character (len=64), dimension(:), pointer :: dimnames integer, dimension(:), pointer :: dimlens integer, dimension(:), pointer :: dimids type (input_handle_type), pointer :: file_handle ! Members to store field data real :: array0r real, dimension(:), pointer :: array1r => null() real, dimension(:,:), pointer :: array2r => null() real, dimension(:,:,:), pointer :: array3r => null() real, dimension(:,:,:,:), pointer :: array4r => null() double precision :: array0d double precision, dimension(:), pointer :: array1d => null() double precision, dimension(:,:), pointer :: array2d => null() double precision, dimension(:,:,:), pointer :: array3d => null() double precision, dimension(:,:,:,:), pointer :: array4d => null() integer :: array0i integer, dimension(:), pointer :: array1i => null() integer, dimension(:,:), pointer :: array2i => null() integer, dimension(:,:,:), pointer :: array3i => null() end type input_field_type integer, parameter :: FIELD_TYPE_UNSUPPORTED = -1, & FIELD_TYPE_REAL = 1, & FIELD_TYPE_DOUBLE = 2, & FIELD_TYPE_INTEGER = 3, & FIELD_TYPE_CHARACTER = 4 contains integer function scan_input_open(filename, handle, nRecords) result(stat) implicit none character (len=*), intent(in) :: filename type (input_handle_type), intent(out) :: handle integer, intent(out), optional :: nRecords integer :: i stat = 0 stat = nf90_open(trim(filename), NF90_NOWRITE, handle % ncid) if (stat /= NF90_NOERR) then stat = 1 return end if stat = nf90_inquire(handle % ncid, nVariables=handle % num_vars) if (stat /= NF90_NOERR) then stat = 1 return end if allocate(handle % varids(handle % num_vars)) ! Newer versions of the netCDF4 library (perhaps newer than 4.2.0?) ! provide a function to return a list of all variable IDs in a file; if ! we are using an older version of the netCDF library, we can apparently ! assume that the variable IDs are numbered 1 through nVars. ! See http://www.unidata.ucar.edu/software/netcdf/docs/tutorial_ncids.html do i=1,handle % num_vars handle % varids(i) = i end do stat = nf90_inquire(handle % ncid, unlimitedDimId=handle % unlimited_dimid) if (stat /= NF90_NOERR) then stat = 1 return end if if (present(nRecords)) then stat = nf90_inquire_dimension(handle % ncid, handle % unlimited_dimid, len=nRecords) if (stat /= NF90_NOERR) then stat = 1 return end if ! In case we have an input file that no time-varying records but ! does have time-invariant fields, set nRecords = 1 so that we can ! at least extract these fields if ((nRecords == 0) .and. (handle % num_vars > 0)) then nRecords = 1 end if end if handle % current_var = 1 end function scan_input_open integer function scan_input_close(handle) result(stat) implicit none type (input_handle_type), intent(inout) :: handle stat = 0 stat = nf90_close(handle % ncid) if (stat /= NF90_NOERR) then stat = 1 end if if (associated(handle % varids)) then deallocate(handle % varids) end if handle % current_var = 0 end function scan_input_close integer function scan_input_rewind(handle) result(stat) implicit none type (input_handle_type), intent(inout) :: handle stat = 0 handle % current_var = 1 end function scan_input_rewind integer function scan_input_next_field(handle, field) result(stat) implicit none type (input_handle_type), intent(inout), target :: handle type (input_field_type), intent(out) :: field integer :: idim stat = 0 if (handle % current_var < 1 .or. handle % current_var > handle % num_vars) then stat = 1 return end if field % varid = handle % varids(handle % current_var) stat = nf90_inquire_variable(handle % ncid, field % varid, & name=field % name, & xtype=field % xtype, & ndims=field % ndims) if (stat /= NF90_NOERR) then stat = 1 return end if if (field % xtype == NF90_FLOAT) then field % xtype = FIELD_TYPE_REAL else if (field % xtype == NF90_DOUBLE) then field % xtype = FIELD_TYPE_DOUBLE else if (field % xtype == NF90_INT) then field % xtype = FIELD_TYPE_INTEGER else if (field % xtype == NF90_CHAR) then field % xtype = FIELD_TYPE_CHARACTER else field % xtype = FIELD_TYPE_UNSUPPORTED end if allocate(field % dimids(field % ndims)) stat = nf90_inquire_variable(handle % ncid, field % varid, & dimids=field % dimids) if (stat /= NF90_NOERR) then stat = 1 deallocate(field % dimids) return end if allocate(field % dimlens(field % ndims)) allocate(field % dimnames(field % ndims)) do idim=1,field % ndims stat = nf90_inquire_dimension(handle % ncid, field % dimids(idim), & name=field % dimnames(idim), & len=field % dimlens(idim)) if (field % dimids(idim) == handle % unlimited_dimid) then field % isTimeDependent = .true. end if end do field % file_handle => handle handle % current_var = handle % current_var + 1 end function scan_input_next_field integer function scan_input_for_field(handle, fieldname, field) result(stat) implicit none type (input_handle_type), intent(inout), target :: handle character (len=*), intent(in) :: fieldname type (input_field_type), intent(out) :: field integer :: idim stat = 0 stat = nf90_inq_varid(handle % ncid, trim(fieldname), field % varid) if (stat /= NF90_NOERR) then stat = 1 return end if stat = nf90_inquire_variable(handle % ncid, field % varid, & name=field % name, & xtype=field % xtype, & ndims=field % ndims) if (stat /= NF90_NOERR) then stat = 1 return end if if (field % xtype == NF90_FLOAT) then field % xtype = FIELD_TYPE_REAL else if (field % xtype == NF90_DOUBLE) then field % xtype = FIELD_TYPE_DOUBLE else if (field % xtype == NF90_INT) then field % xtype = FIELD_TYPE_INTEGER else if (field % xtype == NF90_CHAR) then field % xtype = FIELD_TYPE_CHARACTER else field % xtype = FIELD_TYPE_UNSUPPORTED end if allocate(field % dimids(field % ndims)) stat = nf90_inquire_variable(handle % ncid, field % varid, & dimids=field % dimids) if (stat /= NF90_NOERR) then stat = 1 deallocate(field % dimids) return end if allocate(field % dimlens(field % ndims)) allocate(field % dimnames(field % ndims)) do idim=1,field % ndims stat = nf90_inquire_dimension(handle % ncid, field % dimids(idim), & name=field % dimnames(idim), & len=field % dimlens(idim)) if (field % dimids(idim) == handle % unlimited_dimid) then field % isTimeDependent = .true. end if end do field % file_handle => handle end function scan_input_for_field integer function scan_input_read_field(field, frame) result(stat) implicit none type (input_field_type), intent(inout) :: field integer, intent(in), optional :: frame integer :: local_frame integer, dimension(5) :: start, count real, dimension(1) :: temp1r double precision, dimension(1) :: temp1d integer, dimension(1) :: temp1i stat = 0 local_frame = 1 if (present(frame)) then local_frame = frame end if if (field % xtype == FIELD_TYPE_REAL) then if (field % ndims == 0 .or. (field % ndims == 1 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = local_frame count(1) = 1 stat = nf90_get_var(field % file_handle % ncid, field % varid, temp1r, & start=start(1:1), count=count(1:1)) field % array0r = temp1r(1) else stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array0r) end if else if (field % ndims == 1 .or. (field % ndims == 2 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = local_frame count(2) = 1 allocate(field % array1r(count(1))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1r, & start=start(1:2), count=count(1:2)) else allocate(field % array1r(field%dimlens(1))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1r) end if else if (field % ndims == 2 .or. (field % ndims == 3 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = local_frame count(3) = 1 allocate(field % array2r(count(1),count(2))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2r, & start=start(1:3), count=count(1:3)) else allocate(field % array2r(field%dimlens(1),field%dimlens(2))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2r) end if else if (field % ndims == 3 .or. (field % ndims == 4 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = 1 count(3) = field % dimlens(3) start(4) = local_frame count(4) = 1 allocate(field % array3r(count(1),count(2),count(3))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3r, & start=start(1:4), count=count(1:4)) else allocate(field % array3r(field%dimlens(1),field%dimlens(2),field%dimlens(3))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3r) end if else if (field % ndims == 4 .or. (field % ndims == 5 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = 1 count(3) = field % dimlens(3) start(4) = 1 count(4) = field % dimlens(4) start(5) = local_frame count(5) = 1 allocate(field % array4r(count(1),count(2),count(3),count(4))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4r, & start=start(1:5), count=count(1:5)) else allocate(field % array4r(field%dimlens(1),field%dimlens(2),field%dimlens(3),field%dimlens(4))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4r) end if end if else if (field % xtype == FIELD_TYPE_DOUBLE) then if (field % ndims == 0 .or. (field % ndims == 1 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = local_frame count(1) = 1 stat = nf90_get_var(field % file_handle % ncid, field % varid, temp1d, & start=start(1:1), count=count(1:1)) field % array0d = temp1d(1) else stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array0d) end if else if (field % ndims == 1 .or. (field % ndims == 2 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = local_frame count(2) = 1 allocate(field % array1d(count(1))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1d, & start=start(1:2), count=count(1:2)) else allocate(field % array1d(field%dimlens(1))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1d) end if else if (field % ndims == 2 .or. (field % ndims == 3 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = local_frame count(3) = 1 allocate(field % array2d(count(1),count(2))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2d, & start=start(1:3), count=count(1:3)) else allocate(field % array2d(field%dimlens(1),field%dimlens(2))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2d) end if else if (field % ndims == 3 .or. (field % ndims == 4 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = 1 count(3) = field % dimlens(3) start(4) = local_frame count(4) = 1 allocate(field % array3d(count(1),count(2),count(3))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3d, & start=start(1:4), count=count(1:4)) else allocate(field % array3d(field%dimlens(1),field%dimlens(2),field%dimlens(3))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3d) end if else if (field % ndims == 4 .or. (field % ndims == 5 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = 1 count(3) = field % dimlens(3) start(4) = 1 count(4) = field % dimlens(4) start(5) = local_frame count(5) = 1 allocate(field % array4d(count(1),count(2),count(3),count(4))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4d, & start=start(1:5), count=count(1:5)) else allocate(field % array4d(field%dimlens(1),field%dimlens(2),field%dimlens(3),field%dimlens(4))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4d) end if end if else if (field % xtype == FIELD_TYPE_INTEGER) then if (field % ndims == 0 .or. (field % ndims == 1 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = local_frame count(1) = 1 stat = nf90_get_var(field % file_handle % ncid, field % varid, temp1i, & start=start(1:1), count=count(1:1)) field % array0i = temp1i(1) else stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array0i) end if else if (field % ndims == 1 .or. (field % ndims == 2 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = local_frame count(2) = 1 allocate(field % array1i(count(1))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1i, & start=start(1:2), count=count(1:2)) else allocate(field % array1i(field%dimlens(1))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1i) end if else if (field % ndims == 2 .or. (field % ndims == 3 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = local_frame count(3) = 1 allocate(field % array2i(count(1),count(2))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2i, & start=start(1:3), count=count(1:3)) else allocate(field % array2i(field%dimlens(1),field%dimlens(2))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2i) end if else if (field % ndims == 3 .or. (field % ndims == 4 .and. field % isTimeDependent)) then if (field % isTimeDependent) then start(1) = 1 count(1) = field % dimlens(1) start(2) = 1 count(2) = field % dimlens(2) start(3) = 1 count(3) = field % dimlens(3) start(4) = local_frame count(4) = 1 allocate(field % array3i(count(1),count(2),count(3))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3i, & start=start(1:4), count=count(1:4)) else allocate(field % array3i(field%dimlens(1),field%dimlens(2),field%dimlens(3))) stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3i) end if end if else if (field % xtype == FIELD_TYPE_CHARACTER) then write(0,*) ' ' write(0,*) 'Processing of character fields is not supported; skipping read of field '//trim(field % name) write(0,*) ' ' else write(0,*) ' ' write(0,*) 'Unsupported type; skipping read of field '//trim(field % name) write(0,*) ' ' end if if (stat /= NF90_NOERR) then write(0,*) ' ' write(0,*) 'NetCDF error: reading '//trim(field % name)//' returned ', stat write(0,*) ' ' stat = 1 else stat = 0 end if end function scan_input_read_field integer function scan_input_free_field(field) result(stat) implicit none type (input_field_type), intent(inout) :: field stat = 0 if (associated(field % dimids)) then deallocate(field % dimids) end if if (associated(field % dimlens)) then deallocate(field % dimlens) end if if (associated(field % dimnames)) then deallocate(field % dimnames) end if if (associated(field % array1r)) then deallocate(field % array1r) end if if (associated(field % array2r)) then deallocate(field % array2r) end if if (associated(field % array3r)) then deallocate(field % array3r) end if if (associated(field % array4r)) then deallocate(field % array4r) end if if (associated(field % array1d)) then deallocate(field % array1d) end if if (associated(field % array2d)) then deallocate(field % array2d) end if if (associated(field % array3d)) then deallocate(field % array3d) end if if (associated(field % array4d)) then deallocate(field % array4d) end if if (associated(field % array1i)) then deallocate(field % array1i) end if if (associated(field % array2i)) then deallocate(field % array2i) end if if (associated(field % array3i)) then deallocate(field % array3i) end if nullify(field % file_handle) end function scan_input_free_field end module scan_input