"Fossies" - the Fresh Open Source Software Archive

Member "netcdf-fortran-4.4.5/nf_test/ftst_types3.F" (31 Jan 2019, 4421 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 2007 University Corporation for Atmospheric Research/Unidata.
    3 C     See COPYRIGHT file for conditions of use.
    4 
    5 C     This program tests netCDF-4 user defined types from fortran.
    6 
    7 C     $Id: ftst_types3.F,v 1.2 2009/09/25 19:23:37 ed Exp $
    8 
    9       program ftst_types3
   10       implicit none
   11       include 'netcdf.inc'
   12 
   13 C     This is the name of the data file we will create.
   14       character*(*) FILE_NAME
   15       parameter (FILE_NAME='ftst_types3.nc')
   16 
   17 C     We are writing 2D data, a 3 x 2 grid. 
   18       integer NDIMS
   19       parameter (NDIMS = 2)
   20       integer dim_sizes(NDIMS)
   21       integer NX, NY
   22       parameter (NX = 3, NY = 2)
   23 
   24 C     NetCDF IDs.
   25       integer ncid, varid, dimids(NDIMS)
   26       integer cmp_typeid, typeid_in
   27       integer x_dimid, y_dimid
   28       integer typeids(1)
   29       integer grpid, sub_grpid
   30 
   31 C     Info about the groups we'll create.
   32       character*(*) group_name, sub_group_name
   33       parameter (group_name = 'you_drive_me_crazy')
   34       parameter (sub_group_name = 'baby_Im_so_into_you')
   35 
   36 C     Info about the type we'll create.
   37       integer size_in, base_type_in, nfields_in, class_in
   38       character*80 name_in
   39       character*(*) type_name, field_name
   40       parameter (type_name = 'I_just_want_to_have_some_fun')
   41       parameter (field_name = 'Ill_tell_it_to_the_world')
   42       integer ntypes
   43       integer cmp_size
   44       parameter (cmp_size = 4)
   45       integer offset_in, field_typeid_in, ndims_in, dim_sizes_in(NDIMS)
   46 
   47 C     Loop indexes, and error handling.
   48       integer x, y, retval
   49 
   50       print *, ''
   51       print *,'*** Testing netCDF-4 user-defined types and groups.'
   52 
   53 C     Create the netCDF file.
   54       retval = nf_create(FILE_NAME, NF_NETCDF4, ncid)
   55       if (retval .ne. nf_noerr) call handle_err(retval)
   56 
   57 C     Create a group and a subgroup.
   58       retval = nf_def_grp(ncid, group_name, grpid)
   59       if (retval .ne. nf_noerr) call handle_err(retval)
   60       retval = nf_def_grp(grpid, sub_group_name, sub_grpid)
   61       if (retval .ne. nf_noerr) call handle_err(retval)
   62 
   63 C     Define a compound type in the root group.
   64       retval = nf_def_compound(ncid, cmp_size, type_name, 
   65      &     cmp_typeid)
   66       if (retval .ne. nf_noerr) call handle_err(retval)
   67 
   68 C     Include a float.
   69       retval = nf_insert_compound(ncid, cmp_typeid, field_name, 0, 
   70      &     NF_FLOAT)
   71       if (retval .ne. nf_noerr) call handle_err(retval)
   72 
   73 C     Close the file. 
   74       retval = nf_close(ncid)
   75       if (retval .ne. nf_noerr) call handle_err(retval)
   76 
   77 C     Reopen the file and check again.
   78       retval = nf_open(FILE_NAME, NF_NOWRITE, ncid)
   79       if (retval .ne. nf_noerr) call handle_err(retval)
   80 
   81 C     Find the type.
   82       retval = nf_inq_typeids(ncid, ntypes, typeids)
   83       if (retval .ne. nf_noerr) call handle_err(retval)
   84       if (ntypes .ne. 1 .or. typeids(1) .ne. cmp_typeid) stop 2
   85       
   86 C     Check the type.
   87       retval = nf_inq_user_type(ncid, typeids(1), name_in, size_in, 
   88      &     base_type_in, nfields_in, class_in)
   89       if (retval .ne. nf_noerr) call handle_err(retval)
   90       if (name_in(1:len(type_name)) .ne. type_name .or. 
   91      &     size_in .ne. cmp_size .or. nfields_in .ne. 1 .or. 
   92      &     class_in .ne. NF_COMPOUND) stop 31
   93 
   94 C     Check the first field of the compound type.
   95       retval = nf_inq_compound_field(ncid, typeids(1), 1, name_in, 
   96      &     offset_in, field_typeid_in, ndims_in, dim_sizes_in)
   97       if (retval .ne. nf_noerr) call handle_err(retval)
   98       if (name_in(1:len(field_name)) .ne. field_name .or. 
   99      &     offset_in .ne. 0 .or. field_typeid_in .ne. NF_FLOAT .or. 
  100      &     ndims_in .ne. 0) stop 19
  101 
  102 C     Go to a child group and find the id of our type.
  103       retval = nf_inq_grp_ncid(ncid, group_name, sub_grpid)
  104       if (retval .ne. nf_noerr) call handle_err(retval)
  105       retval = nf_inq_typeid(sub_grpid, type_name, typeid_in)
  106       if (retval .ne. nf_noerr) call handle_err(retval)
  107       retval = nf_inq_user_type(sub_grpid, typeid_in, name_in, size_in, 
  108      &     base_type_in, nfields_in, class_in)
  109       if (retval .ne. nf_noerr) call handle_err(retval)
  110       if (name_in(1:len(type_name)) .ne. type_name .or. 
  111      &     size_in .ne. cmp_size .or. nfields_in .ne. 1 .or. 
  112      &     class_in .ne. NF_COMPOUND) stop 22
  113       
  114 
  115 
  116 C     Close the file. 
  117       retval = nf_close(ncid)
  118       if (retval .ne. nf_noerr) call handle_err(retval)
  119 
  120       print *,'*** SUCCESS!'
  121       end