"Fossies" - the Fresh Open Source Software Archive

Member "netcdf-fortran-4.4.5/nf_test/ftst_vars4.F" (31 Jan 2019, 4036 Bytes) of package /linux/misc/netcdf-fortran-4.4.5.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Fortran 77 source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 C     This is part of the netCDF package.
    2 C     Copyright 2008 University Corporation for Atmospheric Research/Unidata.
    3 C     See COPYRIGHT file for conditions of use.
    4 
    5 C     This program tests netCDF-4 variable functions from fortran, even
    6 C     more, even more.
    7 
    8 C     $Id: ftst_vars4.F,v 1.11 2009/10/24 10:03:39 ed Exp $
    9 
   10       program ftst_vars4
   11       implicit none
   12       include 'netcdf.inc'
   13 
   14 C     This is the name of the data file we will create.
   15       character*(*) FILE_NAME
   16       parameter (FILE_NAME='ftst_vars4.nc')
   17 
   18 C     NetCDF IDs.
   19       integer ncid, vlen_typeid
   20 
   21       integer max_types
   22       parameter (max_types = 1)
   23 
   24 C     Need these to read type information.
   25       integer num_types, typeids(max_types)
   26       integer base_type, base_size, num_members, member_value
   27       character*80 type_name, member_name
   28       integer type_size, nfields, class
   29 
   30 C     Information for the vlen type we will define.
   31       character*(*) vlen_type_name
   32       parameter (vlen_type_name = 'vlen_type')
   33 
   34 C     Some data about and for the vlen.
   35       integer vlen_len, vlen_len_in
   36       parameter (vlen_len = 5)
   37       integer data1(vlen_len), data1_in(vlen_len)
   38 
   39 C     These must be big enough to hold the struct nc_vlen in netcdf.h.
   40       integer*8 vlen(10), vlen_in(10)
   41 
   42 C     Loop indexes, and error handling.
   43       integer x, retval, index(1)
   44 
   45       print *, ''
   46       print *,'*** Testing VLEN types.'
   47 
   48       do x = 1, vlen_len
   49          data1(x) = x
   50       end do
   51 
   52 C     Create the netCDF file.
   53       retval = nf_create(FILE_NAME, NF_NETCDF4, ncid)
   54       if (retval .ne. nf_noerr) call handle_err(retval)
   55 
   56 C     Create the vlen type.
   57       retval = nf_def_vlen(ncid, vlen_type_name, nf_int, vlen_typeid)
   58       if (retval .ne. nf_noerr) call handle_err(retval)
   59 
   60 C     Set up the vlen with this helper function, since F77 can't deal
   61 C     with pointers.
   62       retval = nf_put_vlen_element(ncid, vlen_typeid, vlen, 
   63      &     vlen_len, data1)
   64       if (retval .ne. nf_noerr) call handle_err(retval)
   65 
   66 C     Write the vlen attribute.
   67       retval = nf_put_att(ncid, NF_GLOBAL, 'att1', vlen_typeid, 1, vlen)
   68       if (retval .ne. nf_noerr) call handle_err(retval)
   69 
   70 C     Close the file. 
   71       retval = nf_close(ncid)
   72       if (retval .ne. nf_noerr) call handle_err(retval)
   73 
   74 C     Reopen the file.
   75       retval = nf_open(FILE_NAME, NF_NOWRITE, ncid)
   76       if (retval .ne. nf_noerr) call handle_err(retval)
   77 
   78 C     Get the typeids of all user defined types.
   79       retval = nf_inq_typeids(ncid, num_types, typeids)
   80       if (retval .ne. nf_noerr) call handle_err(retval)
   81       if (num_types .ne. max_types) stop 2
   82 
   83 C     Use nf_inq_user_type to confirm this is an vlen type, with base
   84 C     type NF_INT.
   85       retval = nf_inq_user_type(ncid, typeids(1), type_name, type_size, 
   86      &     base_type, nfields, class)
   87       if (retval .ne. nf_noerr) call handle_err(retval)
   88       if (type_name(1:len(vlen_type_name)) .ne. vlen_type_name .or.
   89      &     base_type .ne. nf_int .or.
   90      &     nfields .ne. 0 .or. class .ne. nf_vlen) stop 2
   91 
   92 C     Use nf_inq_vlen and make sure we get the same answers as we did
   93 C     with nf_inq_user_type.
   94       retval = nf_inq_vlen(ncid, typeids(1), type_name, base_size, 
   95      &     base_type)
   96       if (retval .ne. nf_noerr) call handle_err(retval)
   97       if (type_name(1:len(vlen_type_name)) .ne. vlen_type_name .or.
   98      &     base_type .ne. nf_int) stop 2
   99 
  100 C     Read the vlen attribute.
  101       retval = nf_get_att(ncid, NF_GLOBAL, 'att1', vlen_in)
  102       if (retval .ne. nf_noerr) call handle_err(retval)
  103 
  104 C     Get the data from the vlen we just read.
  105       retval = nf_get_vlen_element(ncid, vlen_typeid, vlen_in, 
  106      &     vlen_len_in, data1_in)
  107       if (retval .ne. nf_noerr) call handle_err(retval)
  108       if (vlen_len_in .ne. vlen_len) stop 2
  109 
  110 C     Check the data
  111       do x = 1, vlen_len
  112          if (data1(x) .ne. data1_in(x)) stop 2
  113       end do
  114 
  115 C     Close the file. 
  116       retval = nf_close(ncid)
  117       if (retval .ne. nf_noerr) call handle_err(retval)
  118 
  119       print *,'*** SUCCESS!'
  120       end