mirror/netcdf-c
2
0
Fork 0
mirror of https://github.com/Unidata/netcdf-c.git synced 2024-12-03 08:01:25 +08:00
Code Issues Packages Projects Releases Wiki Activity
132359d2cb
netcdf-c/nf_test/ftest.F
Ed Hartnett 18f4bca367 moving to trunk subdir
2010-06-03 13:24:43 +00:00

1459 lines
44 KiB
Fortran
Raw Blame History

!********************************************************************
! Copyright 1993, UCAR/Unidata
! See netcdf/COPYRIGHT file for copying and redistribution conditions.
! $Id: ftest.F,v 1.12 2009/04/02 18:29:20 dmh Exp $
!********************************************************************
#include "nfconfig.inc"
!
! program to test the netCDF-2 Fortran API
!
program ftest
#include "netcdf.inc"
! name of first test cdf
character*31 name
! name of second test cdf
character*31 name2
! Returned error code.
integer iret
! netCDF ID
integer ncid
! ID of dimension lat
integer latdim
! ID of dimension lon
integer londim
! ID of dimension level
integer leveldim
! ID of dimension time
integer timedim
! ID of dimension len
integer lendim
! Count the errors.
integer nfails
! variable used to control error-handling behavior
integer ncopts
integer dimsiz(MAXNCDIM)
! allowable roundoff
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
data name/'test.nc'/
data name2/'copy.nc'/
print *, ''
print *,'*** Testing netCDF-2 Fortran 77 API.'
100 format(' *** testing ', a, ' ...')
! set error-handling to verbose and non-fatal
ncopts = NCVERBOS
call ncpopt(ncopts)
! This will be a count of how many failures we experience.
nfails = 0
! create a netCDF named 'test.nc'
write(*,100) 'nccre'
ncid = nccre(name, NCCLOB, iret)
if (ncid .eq. -1) then nfails = nfails + 1
! test ncddef
write(*,100) 'ncddef'
call tncddef(ncid, nfails)
! test ncvdef
write(*,100) 'ncvdef'
call tncvdef(ncid, nfails)
! test ncapt
write(*, 100) 'ncapt, ncaptc'
call tncapt(ncid, nfails)
! close 'test.nc'
write(*, 100) 'ncclos'
call ncclos(ncid, iret)
if (ncid .eq. -1) then nfails = nfails + 1
! test ncvpt1
write(*, 100) 'ncvpt1'
call tncvpt1(name, nfails)
! test ncvgt1
write(*, 100) 'ncvgt1'
call tncvgt1(name, nfails)
! test ncvpt
write(*, 100) 'ncvpt'
call tncvpt(name, nfails)
! test ncinq
write(*, 100) 'ncopn, ncinq, ncdinq, ncvinq, ncanam, ncainq'
call tncinq(name, nfails)
! test ncvgt
write(*, 100) 'ncvgt, ncvgtc'
call tncvgt(name, nfails)
! test ncagt
write(*, 100) 'ncagt, ncagtc'
call tncagt(name, nfails)
! test ncredf
write(*, 100) 'ncredf, ncdren, ncvren, ncaren, ncendf'
call tncredf(name, nfails)
call tncinq(name, nfails)
! test ncacpy
write(*, 100) 'ncacpy'
call tncacpy(name, name2, nfails)
! test ncadel
write(*, 100) 'ncadel'
call tncadel(name2, nfails)
! test fill values
write(*, 100) 'fill values'
call tfills(nfails)
print *,'Total number of failures: ', nfails
if (nfails .ne. 0) stop 2
print *,'*** SUCCESS!'
end
!
! subroutine to test ncacpy
!
subroutine tncacpy(iname, oname, nfails)
character*31 iname, oname
#include "netcdf.inc"
integer ndims, nvars, natts, recdim, iret
character*31 vname, attnam
integer attype, attlen
integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
integer lenstr
! existing netCDF id
integer incdf
! netCDF id of the output netCDF file to which the attribute
! will be copied
integer outcdf
integer mattlen
parameter (mattlen = 80)
character*80 charval
doubleprecision doubval(2)
real flval(2)
integer lngval(2)
NCSHORT_T shval(2)
integer i, j, k
character*31 varnam, attname(2,7), gattnam(2)
NCBYTE_T bytval(2)
common /atts/attname, gattnam
NCSHORT_T svalidrg(2)
real rvalidrg(2)
integer lvalidrg(2)
doubleprecision dvalidrg(2)
NCBYTE_T bvalidrg(2)
character*31 gavalue(2), cavalue(2)
real epsilon
data bvalidrg/-127,127/
data svalidrg/-100,100/
data lvalidrg/0,360/
data rvalidrg/0.0, 5000.0/
data dvalidrg/0D0,500D0/
data gavalue/'NWS', '88/10/25 12:00:00'/
data cavalue/'test string', 'a'/
data lenstr/80/
data epsilon /.000001/
incdf = ncopn(iname, NCNOWRIT, iret)
if (iret .ne. 0) nfails = nfails + 1
outcdf = nccre(oname, NCCLOB, iret)
if (iret .ne. 0) nfails = nfails + 1
call tncddef(outcdf, nfails)
call tncvdef(outcdf, nfails)
call ncinq (incdf, ndims, nvars, natts, recdim, iret)
if (iret .ne. 0) nfails = nfails + 1
do 5 j = 1, natts
call ncanam (incdf, NCGLOBAL, j, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncacpy (incdf, NCGLOBAL, attnam, outcdf, NCGLOBAL, iret)
if (iret .ne. 0) nfails = nfails + 1
5 continue
do 10 i = 1, nvars
call ncvinq (incdf, i, vname, vartyp, nvdims,
+ vdims, nvatts, iret)
if (iret .ne. 0) nfails = nfails + 1
do 20 k = 1, nvatts
call ncanam (incdf, i, k, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncacpy (incdf, i, attnam, outcdf, i, iret)
if (iret .ne. 0) nfails = nfails + 1
20 continue
10 continue
!
! get global attributes first
!
do 100 i = 1, natts
call ncanam (outcdf, NCGLOBAL, i, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncainq (outcdf, NCGLOBAL, attnam, attype, attlen,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attlen .gt. mattlen) then
write (*,*) 'global attribute too big!', attlen, mattlen
stop 2
else if (attype .eq. NCBYTE) then
call ncagt (outcdf, NCBYTE, attnam, bytval, iret)
if (iret .ne. 0) nfails = nfails + 1
else if (attype .eq. NCCHAR) then
call ncagtc (outcdf, NCGLOBAL, attnam, charval,
+ lenstr, iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. gattnam(i)) write(*,*) 'error in ncagt G'
if (charval .ne. gavalue(i))
+ write(*,*) 'error in ncagt G2', lenstr, charval, gavalue(i)
charval = ' '
else if (attype .eq. NCSHORT) then
call ncagt (outcdf, NCGLOBAL, attnam, shval, iret)
if (iret .ne. 0) nfails = nfails + 1
else if (attype .eq. NCLONG) then
call ncagt (outcdf, NCGLOBAL, attnam, lngval, iret)
if (iret .ne. 0) nfails = nfails + 1
else if (attype .eq. NCFLOAT) then
call ncagt (outcdf, NCGLOBAL, attnam, flval, iret)
if (iret .ne. 0) nfails = nfails + 1
else
call ncagt (outcdf, NCGLOBAL, attnam, doubval,iret)
if (iret .ne. 0) nfails = nfails + 1
end if
100 continue
!
! get variable attributes
!
do 200 i = 1, nvars
call ncvinq (outcdf, i, varnam, vartyp, nvdims, vdims,
+ nvatts, iret)
if (iret .ne. 0) nfails = nfails + 1
do 250 j = 1, nvatts
call ncanam (outcdf, i, j, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncainq (outcdf, i, attnam, attype, attlen,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attlen .gt. mattlen) then
write (*,*) 'variable ', i, 'attribute too big !'
stop 2
else
if (attype .eq. NCBYTE) then
call ncagt (outcdf, i, attnam, bytval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt BYTE N'
if (bytval(j) .ne. bvalidrg(j)) write(*,*)
+ 'ncacpy: byte ', bytval(j), ' .ne. ', bvalidrg(j)
else if (attype .eq. NCCHAR) then
call ncagtc (outcdf, i, attnam, charval,
+ lenstr, iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt CHAR N'
if (charval .ne. cavalue(j))
+ write(*,*) 'error in ncagt'
charval = ' '
else if (attype .eq. NCSHORT) then
call ncagt (outcdf, i, attnam, shval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt SHORT N'
if (shval(j) .ne. svalidrg(j)) then
write(*,*) 'error in ncagt SHORT'
end if
else if (attype .eq. NCLONG) then
call ncagt (outcdf, i, attnam, lngval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt LONG N'
if (lngval(j) .ne. lvalidrg(j))
+ write(*,*) 'error in ncagt LONG'
else if (attype .eq. NCFLOAT) then
call ncagt (outcdf, i, attnam, flval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt FLOAT N'
if (flval(j) .ne. rvalidrg(j))
+ write(*,*) 'error in ncagt FLOAT'
else if (attype .eq. NCDOUBLE) then
call ncagt (outcdf, i, attnam, doubval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt DOUBLE N'
if ( abs(doubval(j) - dvalidrg(j)) .gt. epsilon)
+ write(*,*) 'error in ncagt DOUBLE'
end if
end if
250 continue
200 continue
call ncclos(incdf, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncclos(outcdf, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test ncadel
!
subroutine tncadel (cdfname, nfails)
character*31 cdfname
#include "netcdf.inc"
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
integer ncid, iret, i, j
integer ndims, nvars, natts, recdim
integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
character*31 varnam, attnam
ncid = ncopn(cdfname, NCWRITE, iret)
if (iret .ne. 0) nfails = nfails + 1
! put cdf in define mode
call ncredf (ncid,iret)
if (iret .ne. 0) nfails = nfails + 1
! get number of global attributes
call ncinq (ncid, ndims, nvars, natts, recdim, iret)
if (iret .ne. 0) nfails = nfails + 1
do 10 i = natts, 1, -1
! get name of global attribute
call ncanam (ncid, NCGLOBAL, i, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
! delete global attribute
call ncadel (ncid, NCGLOBAL, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
10 continue
do 100 i = 1, nvars
! get number of variable attributes
call ncvinq (ncid, i, varnam, vartyp, nvdims, vdims,
+ nvatts, iret)
if (iret .ne. 0) nfails = nfails + 1
do 200 j = nvatts, 1, -1
call ncanam (ncid, i, j, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncadel (ncid, i, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
200 continue
100 continue
call ncinq (ncid, ndims, nvars, natts, recdim, iret)
if (iret .ne. 0) nfails = nfails + 1
if (natts .ne. 0) write(*,*) 'error in ncadel'
! put netCDF into data mode
call ncendf (ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncclos (ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test ncagt and ncagtc
subroutine tncagt(cdfname, nfails)
#include "netcdf.inc"
character*31 cdfname
! maximum length of an attribute
integer mattlen
parameter (mattlen = 80)
integer ncid, ndims, nvars, natts, recdim
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
integer i, j
integer attype, attlen, lenstr, iret
character*31 attnam
character*80 charval
doubleprecision doubval(2)
real flval(2)
integer lngval(2)
NCSHORT_T shval(2)
NCBYTE_T bytval(2)
integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
character*31 varnam, attname(2,7), gattnam(2)
common /atts/attname, gattnam
NCSHORT_T svalidrg(2)
real rvalidrg(2)
integer lvalidrg(2)
doubleprecision dvalidrg(2)
NCBYTE_T bvalidrg(2)
character*31 gavalue(2), cavalue(2)
real epsilon
data bvalidrg/-127,127/
data svalidrg/-100,100/
data lvalidrg/0,360/
data rvalidrg/0.0, 5000.0/
data dvalidrg/0D0,500D0/
data gavalue/'NWS', '88/10/25 12:00:00'/
data cavalue/'test string', 'a'/
data lenstr/80/
data epsilon /.000001/
ncid = ncopn (cdfname, NCNOWRIT, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncinq (ncid, ndims, nvars, natts, recdim, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! get global attributes first
!
do 10 i = 1, natts
! get name of attribute
call ncanam (ncid, NCGLOBAL, i, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
! get attribute type and length
call ncainq (ncid, NCGLOBAL, attnam, attype, attlen,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attlen .gt. mattlen) then
write (*,*) 'global attribute too big!'
stop 2
else if (attype .eq. NCBYTE) then
call ncagt (ncid, NCBYTE, attnam, bytval, iret)
if (iret .ne. 0) nfails = nfails + 1
else if (attype .eq. NCCHAR) then
call ncagtc (ncid, NCGLOBAL, attnam, charval,
+ lenstr, iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. gattnam(i)) write(*,*) 'error in ncagt'
if (charval .ne. gavalue(i)) write(*,*) 'error in ncagt'
charval = ' '
else if (attype .eq. NCSHORT) then
call ncagt (ncid, NCGLOBAL, attnam, shval, iret)
if (iret .ne. 0) nfails = nfails + 1
else if (attype .eq. NCLONG) then
call ncagt (ncid, NCGLOBAL, attnam, lngval, iret)
if (iret .ne. 0) nfails = nfails + 1
else if (attype .eq. NCFLOAT) then
call ncagt (ncid, NCGLOBAL, attnam, flval, iret)
if (iret .ne. 0) nfails = nfails + 1
else
call ncagt (ncid, NCGLOBAL, attnam, doubval,iret)
if (iret .ne. 0) nfails = nfails + 1
end if
10 continue
!
! get variable attributes
!
do 20 i = 1, nvars
call ncvinq (ncid, i, varnam, vartyp, nvdims, vdims,
+ nvatts, iret)
if (iret .ne. 0) nfails = nfails + 1
do 25 j = 1, nvatts
call ncanam (ncid, i, j, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncainq (ncid, i, attnam, attype, attlen,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attlen .gt. mattlen) then
write (*,*) 'variable ', i, 'attribute too big !'
stop 2
else
if (attype .eq. NCBYTE) then
call ncagt (ncid, i, attnam, bytval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt BYTE name'
if (bytval(j) .ne. bvalidrg(j)) write(*,*)
+ 'ncacpy: byte ', bytval(j), ' .ne. ', bvalidrg(j)
else if (attype .eq. NCCHAR) then
call ncagtc (ncid, i, attnam, charval,
+ lenstr, iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt CHAR name'
if (charval .ne. cavalue(j))
+ write(*,*) 'error in ncagt CHAR name'
charval = ' '
else if (attype .eq. NCSHORT) then
call ncagt (ncid, i, attnam, shval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt SHORT name'
if (shval(j) .ne. svalidrg(j)) then
write(*,*) 'error in ncagt SHORT'
end if
else if (attype .eq. NCLONG) then
call ncagt (ncid, i, attnam, lngval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt LONG name'
if (lngval(j) .ne. lvalidrg(j))
+ write(*,*) 'error in ncagt LONG'
else if (attype .eq. NCFLOAT) then
call ncagt (ncid, i, attnam, flval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt FLOAT name'
if (flval(j) .ne. rvalidrg(j))
+ write(*,*) 'error in ncagt FLOAT'
else if (attype .eq. NCDOUBLE) then
call ncagt (ncid, i, attnam, doubval,
+ iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(j,i))
+ write(*,*) 'error in ncagt DOUBLE name'
if ( abs(doubval(j) - dvalidrg(j)) .gt. epsilon)
+ write(*,*) 'error in ncagt DOUBLE'
end if
end if
25 continue
20 continue
call ncclos(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test ncapt
!
subroutine tncapt (ncid, nfails)
#include "netcdf.inc"
integer ncid, iret
! attribute vectors
NCSHORT_T svalidrg(2)
real rvalidrg(2)
integer lvalidrg(2)
doubleprecision dvalidrg(2)
NCBYTE_T bvalidrg(2)
! variable ids
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
! assign attributes
!
! byte
!
bvalidrg(1) = -127
bvalidrg(2) = 127
call ncapt (ncid, bid, 'validrange', NCBYTE, 2,
+bvalidrg, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! short
!
svalidrg(1) = -100
svalidrg(2) = 100
call ncapt (ncid, sid, 'validrange', NCSHORT, 2,
+svalidrg, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! long
!
lvalidrg(1) = 0
lvalidrg(2) = 360
call ncapt (ncid, lid, 'validrange', NCLONG, 2,
+lvalidrg, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! float
!
rvalidrg(1) = 0.0
rvalidrg(2) = 5000.0
call ncapt (ncid, fid, 'validrange', NCFLOAT, 2,
+rvalidrg, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! double
!
dvalidrg(1) = 0D0
dvalidrg(2) = 500D0
call ncapt (ncid, did, 'validrange', NCDOUBLE, 2,
+dvalidrg, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! global
!
call ncaptc (ncid, NCGLOBAL, 'source', NCCHAR, 3,
+'NWS', iret)
if (iret .ne. 0) nfails = nfails + 1
call ncaptc (ncid, NCGLOBAL, 'basetime', NCCHAR, 17,
+'88/10/25 12:00:00', iret)
if (iret .ne. 0) nfails = nfails + 1
!
! char
!
call ncaptc (ncid, chid, 'longname', NCCHAR, 11,
+'test string', iret)
if (iret .ne. 0) nfails = nfails + 1
call ncaptc (ncid, chid, 'id', NCCHAR, 1,
+'a', iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! initialize variables in labelled common blocks
!
block data
common /cdims/ dimnam
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
common /varn/varnam
common /atts/attname, gattnam
integer latdim, londim, leveldim, timedim, lendim
! should include 'netcdf.inc' for MAXNCDIM, but it has EXTERNAL
! declaration, which is not permitted in a BLOCK DATA unit.
integer dimsiz(1024)
character*31 dimnam(1024)
character*31 varnam(7)
character*31 attname(2,7)
character*31 gattnam(2)
data dimnam /'time', 'lat', 'lon', 'level',
+ 'length', 1019*'0'/
data dimsiz /4, 5, 5, 4, 80, 1019*0/
data varnam/'bytev', 'shortv', 'longv', 'floatv', 'doublev',
+ 'chv', 'cv'/
data attname/'validrange', '0', 'validrange', '0', 'validrange',
+ '0', 'validrange', '0', 'validrange', '0', 'longname', 'id',
+ '0', '0'/
data gattnam/'source','basetime'/
end
!
! subroutine to test ncddef
!
subroutine tncddef(ncid, nfails)
#include "netcdf.inc"
integer ncid
! sizes of dimensions of 'test.nc' and 'copy.nc'
integer ndims
parameter(ndims=5)
! dimension ids
integer latdim, londim, leveldim, timedim, lendim
integer iret
! function to define a netCDF dimension
integer dimsiz(MAXNCDIM)
character*31 dimnam(MAXNCDIM)
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
common /cdims/ dimnam
! define dimensions
timedim = ncddef(ncid, dimnam(1), NCUNLIM, iret)
if (iret .ne. 0) nfails = nfails + 1
latdim = ncddef(ncid, dimnam(2), dimsiz(2), iret)
if (iret .ne. 0) nfails = nfails + 1
londim = ncddef(ncid, dimnam(3), dimsiz(3), iret)
if (iret .ne. 0) nfails = nfails + 1
leveldim = ncddef(ncid, dimnam(4), dimsiz(4), iret)
if (iret .ne. 0) nfails = nfails + 1
lendim = ncddef(ncid, dimnam(5), dimsiz(5), iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test ncinq, ncdinq, ncdid, ncvinq, ncanam
! and ncainq
!
subroutine tncinq(cdfname, nfails)
#include "netcdf.inc"
character*31 cdfname
! netCDF id
integer ncid
! returned number of dimensions
integer ndims
! returned number of variables
integer nvars
! returned number of global attributes
integer natts
! returned id of the unlimited dimension
integer recdim
! returned error code
integer iret
! returned name of record dimension
character*31 recnam
! returned size of record dimension
integer recsiz
! loop control variables
integer i, j, k
! returned size of dimension
integer dsize
! returned dimension ID
integer dimid
! returned dimension name
character*31 dname
! returned variable name
character*31 vname
! returned attribute name
character*31 attnam
! returned netCDF datatype of variable
integer vartyp
! returned number of variable dimensions
integer nvdims
! returned number of variable attributes
integer nvatts
! returned vector of nvdims dimension IDS corresponding to the
! variable dimensions
integer vdims(MAXNCDIM)
! returned attribute length
integer attlen
! returned attribute type
integer attype
character*31 dimnam(MAXNCDIM)
character*31 varnam(7)
character*31 attname(2,7)
character*31 gattnam(2)
integer vdlist(5,7), vtyp(7), vndims(7), vnatts(7)
integer attyp(2,7),atlen(2,7),gattyp(2),gatlen(2)
integer timedim,latdim,londim,leveldim,lendim
integer dimsiz(MAXNCDIM)
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
common /varn/varnam
common /atts/attname, gattnam
common /cdims/ dimnam
data vdlist/1,0,0,0,0,1,0,0,0,0,2,0,0,0,0,4,3,2,1,0,4,3,2,1,0,
+ 5,1,0,0,0,1,0,0,0,0/
data vtyp/NCBYTE, NCSHORT, NCLONG, NCFLOAT, NCDOUBLE, NCCHAR,
+ NCCHAR/
data vndims/1,1,1,4,4,2,1/
data vnatts/1,1,1,1,1,2,0/
data attyp/NCBYTE, 0, NCSHORT, 0, NCLONG, 0, NCFLOAT, 0,
+ NCDOUBLE, 0, NCCHAR, NCCHAR, 0, 0/
data atlen/2,0,2,0,2,0,2,0,2,0,11,1, 0, 0/
data gattyp/NCCHAR,NCCHAR/
data gatlen/3,17/
ncid = ncopn (cdfname, NCNOWRIT, iret)
call ncinq (ncid, ndims, nvars, natts, recdim, iret)
if (iret .ne. 0) nfails = nfails + 1
if (ndims .ne. 5) write(*,*) 'error in ncinq or ncddef'
if (nvars .ne. 7) write(*,*) 'error in ncinq or ncvdef'
if (natts .ne. 2) write(*,*) 'error in ncinq or ncapt'
call ncdinq (ncid, recdim, recnam, recsiz, iret)
if (iret .ne. 0) nfails = nfails + 1
if (recnam .ne. 'time') write(*,*) 'error: bad recdim from ncinq'
!
! dimensions
!
do 10 i = 1, ndims
call ncdinq (ncid, i, dname, dsize, iret)
if (iret .ne. 0) nfails = nfails + 1
if (dname .ne. dimnam(i))
+ write(*,*) 'error in ncdinq or ncddef, dname=', dname
if (dsize .ne. dimsiz(i))
+ write(*,*) 'error in ncdinq or ncddef, dsize=',dsize
dimid = ncdid (ncid, dname, iret)
if (dimid .ne. i) write(*,*)
+ 'error in ncdinq or ncddef, dimid=', dimid
10 continue
!
! variables
!
do 30 i = 1, nvars
call ncvinq (ncid, i, vname, vartyp, nvdims,
+ vdims, nvatts, iret)
if (iret .ne. 0) nfails = nfails + 1
if (vname .ne. varnam(i))
+ write(*,*) 'error: from ncvinq, wrong name returned: ',
+ vname, ' .ne. ', varnam(i)
if (vartyp .ne. vtyp(i))
+ write(*,*) 'error: from ncvinq, wrong type returned: ',
+ vartyp, ' .ne. ', vtyp(i)
if (nvdims .ne. vndims(i))
+ write(*,*) 'error: from ncvinq, wrong num dims returned: ',
+ vdims, ' .ne. ', vndims(i)
do 35 j = 1, nvdims
if (vdims(j) .ne. vdlist(j,i))
+ write(*,*) 'error: from ncvinq wrong dimids: ',
+ vdims(j), ' .ne. ', vdlist(j,i)
35 continue
if (nvatts .ne. vnatts(i))
+ write(*,*) 'error in ncvinq or ncvdef'
!
! attributes
!
do 45 k = 1, nvatts
call ncanam (ncid, i, k, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncainq (ncid, i, attnam, attype, attlen, iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. attname(k,i))
+ write(*,*) 'error in ncanam or ncapt'
if (attype .ne. attyp(k,i))
+ write(*,*) 'error in ncainq or ncapt'
if (attlen .ne. atlen(k,i))
+ write(*,*) 'error in ncainq or ncapt'
45 continue
30 continue
do 40 i = 1, natts
call ncanam (ncid, NCGLOBAL, i, attnam, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncainq (ncid, NCGLOBAL, attnam, attype, attlen, iret)
if (iret .ne. 0) nfails = nfails + 1
if (attnam .ne. gattnam(i))
+ write(*,*) 'error in ncanam or ncapt'
if (attype .ne. gattyp(i))
+ write(*,*) 'error in ncainq or ncapt'
if (attlen .ne. gatlen(i))
+ write(*,*) 'error in ncainq or ncapt'
40 continue
call ncclos(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
! subroutine to test ncredf, ncdren, ncvren, ncaren, and
! ncendf
subroutine tncredf(cdfname, nfails)
#include "netcdf.inc"
character*31 cdfname
character*31 attname(2,7)
character*31 gattnam(2)
common /atts/attname, gattnam
common /cdims/ dimnam
character*31 dimnam(MAXNCDIM)
character*31 varnam(7)
common /varn/varnam
integer ncid, iret, latid, varid
dimnam(2) = 'latitude'
varnam(4) = 'realv'
attname(1,6) = 'stringname'
gattnam(1) = 'agency'
ncid = ncopn(cdfname, NCWRITE, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncredf(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
latid = ncdid(ncid, 'lat', iret)
call ncdren(ncid, latid, 'latitude', iret)
if (iret .ne. 0) nfails = nfails + 1
varid = ncvid(ncid, 'floatv', iret)
call ncvren(ncid, varid, 'realv', iret)
if (iret .ne. 0) nfails = nfails + 1
varid = ncvid(ncid, 'chv', iret)
if (iret .ne. 0) nfails = nfails + 1
call ncaren(ncid, varid, 'longname', 'stringname', iret)
if (iret .ne. 0) nfails = nfails + 1
call ncaren(ncid, NCGLOBAL, 'source', 'agency', iret)
if (iret .ne. 0) nfails = nfails + 1
call ncendf(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncclos(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test ncvdef
!
subroutine tncvdef(ncid, nfails)
#include "netcdf.inc"
integer ncid
! function to define a netCDF variable
integer dimsiz(MAXNCDIM)
integer latdim, londim, leveldim, timedim, lendim
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
! variable ids
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
! variable shapes
integer bdims(1), fdims(4), ddims(4), ldims(1), sdims(1)
integer chdims(2), cdims(1)
integer iret
!
! define variables
!
! byte
!
bdims(1) = timedim
bid = ncvdef(ncid, 'bytev', NCBYTE, 1, bdims, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! short
!
sdims(1) = timedim
sid = ncvdef (ncid, 'shortv', NCSHORT, 1, sdims, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! long
!
ldims(1) = latdim
lid = ncvdef (ncid, 'longv', NCLONG, 1, ldims, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! float
!
fdims(4) = timedim
fdims(1) = leveldim
fdims(2) = londim
fdims(3) = latdim
fid = ncvdef (ncid, 'floatv', NCFLOAT, 4, fdims, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! double
!
ddims(4) = timedim
ddims(1) = leveldim
ddims(2) = londim
ddims(3) = latdim
did = ncvdef (ncid, 'doublev', NCDOUBLE, 4, ddims, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! char
!
chdims(2) = timedim
chdims(1) = lendim
chid = ncvdef (ncid, 'chv', NCCHAR, 2, chdims, iret)
if (iret .ne. 0) nfails = nfails + 1
cdims(1) = timedim
cid = ncvdef (ncid, 'cv', NCCHAR, 1, cdims, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test ncvgt and ncvgtc
!
subroutine tncvgt(cdfname, nfails)
#include "netcdf.inc"
character*31 cdfname
integer ndims, times, lats, lons, levels, lenstr
parameter (times=4, lats=5, lons=5, levels=4)
integer start(4), count(4)
integer ncid, iret, i, m
integer latdim, londim, leveldim, timedim, lendim
integer dimsiz(MAXNCDIM)
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
integer itime, ilev, ilat, ilon
! arrays of data values to be read
NCBYTE_T barray(times), byval(times)
NCSHORT_T sarray(times), shval(times)
integer larray(lats)
real farray(levels, lats, lons, times)
doubleprecision darray(levels, lats, lons, times)
! character array of data values to be read
character*31 string
character*31 varnam
integer nvars, natts, recdim
integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
data start/1,1,1,1/
data count/levels, lats, lons, times/
data byval /97, 98, 99, 100/
data shval /10, 11, 12, 13/
ncid = ncopn (cdfname, NCWRITE, iret)
if (iret .ne. 0) nfails = nfails + 1
! get number of variables in netCDF
call ncinq (ncid, ndims, nvars, natts, recdim, iret)
if (iret .ne. 0) nfails = nfails + 1
do 5 m = 1, nvars-1
! get variable name, datatype, number of dimensions
! vector of dimension ids, and number of variable attributes
call ncvinq (ncid, m, varnam, vartyp, nvdims, vdims,
+ nvatts, iret)
if (iret .ne. 0) nfails = nfails + 1
if (vartyp .eq. NCBYTE) then
!
! byte
!
count(1) = times
call ncvgt (ncid, m, start, count, barray, iret)
if (iret .ne. 0) nfails = nfails + 1
do 10 i = 1, times
if (barray(i) .ne. byval(i)) then
write(*,*) 'ncvgt of bytes, got ', barray(i), ' .ne. '
+ , byval(i)
end if
10 continue
else if (vartyp .eq. NCSHORT) then
!
! short
!
count(1) = times
call ncvgt (ncid, m, start, count, sarray, iret)
if (iret .ne. 0) nfails = nfails + 1
do 20 i = 1, times
if (sarray(i) .ne. shval(i)) then
write(*,*) 'ncvgt of short, got ', sarray(i), ' .ne. '
+ , shval(i)
end if
20 continue
else if (vartyp .eq. NCLONG) then
!
! long
!
count(1) = lats
call ncvgt (ncid, m, start, count, larray, iret)
if (iret .ne. 0) nfails = nfails + 1
do 30 i = 1, lats
if (larray(i) .ne. 1000) then
write(*,*) 'long error in ncvgt'
end if
30 continue
else if (vartyp .eq. NCFLOAT) then
!
! float
!
count(1) = levels
call ncvgt (ncid, m, start, count, farray, iret)
if (iret .ne. 0) nfails = nfails + 1
i = 0
do 40 itime = 1,times
do 41 ilon = 1, lons
do 42 ilat = 1, lats
do 43 ilev = 1, levels
i = i + 1
if (farray(ilev, ilat, ilon, itime) .ne.
+ real(i)) then
write (*,*) 'float error in ncvgt'
end if
43 continue
42 continue
41 continue
40 continue
else if (vartyp .eq. NCDOUBLE) then
!
! double
!
count(1) = levels
call ncvgt (ncid, m, start, count, darray, iret)
if (iret .ne. 0) nfails = nfails + 1
i = 0
do 50 itime = 1, times
do 51 ilon = 1, lons
do 52 ilat = 1, lats
do 53 ilev = 1, levels
i = i + 1
if (darray(ilev, ilat, ilon, itime) .ne.
+ real (i)) then
write(*,*) 'double error in ncvgt:', i,
+ darray(ilev, ilat, ilon, itime), '.ne.',
+ real (i)
end if
53 continue
52 continue
51 continue
50 continue
else
!
! char
!
count(1) = 3
count(2) = 4
lenstr = 31
call ncvgtc (ncid, m, start, count, string, lenstr, iret)
if (iret .ne. 0) nfails = nfails + 1
if (string .ne. 'testhikin of') then
write(*,*) 'error in ncvgt, returned string =', string
end if
end if
5 continue
call ncclos(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
subroutine tncvgt1(cdfname, nfails)
#include "netcdf.inc"
character*31 cdfname
integer ncid, iret
integer latdim, londim, leveldim, timedim, lendim
integer dimsiz(MAXNCDIM)
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
integer bindx(1), sindx(1), lindx(1), findx(4), dindx(4), cindx(1)
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
NCBYTE_T bvalue
NCSHORT_T svalue
integer lvalue
real fvalue
doubleprecision dvalue
character*1 c
real epsilon
doubleprecision onethird
data epsilon /.000001/
data lindx/1/, bindx/1/, sindx/1/, findx/1,1,1,1/
+dindx/1,1,1,1/, cindx/1/
data onethird/0.3333333333D0/
ncid = ncopn (cdfname, NCNOWRIT, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! test ncvgt1 for byte
!
call ncvgt1 (ncid, bid, bindx, bvalue, iret)
if (iret .ne. 0) nfails = nfails + 1
if (bvalue .ne. ichar('z')) write(*,*) 'error in ncvgt1 byte:',
+ bvalue, ' .ne.', ichar('z')
!
! test ncvgt1 for short
!
call ncvgt1 (ncid, sid, sindx, svalue, iret)
if (iret .ne. 0) nfails = nfails + 1
if (svalue .ne. 10) write(*,*) 'error in ncvgt1 short:',
+ svalue, ' .ne.', 10
!
! test ncvgt1 for long
!
call ncvgt1 (ncid, lid, lindx, lvalue, iret)
if (iret .ne. 0) nfails = nfails + 1
if (lvalue .ne. 1000) write(*,*) 'error in ncvgt1 long:',
+ lvalue, ' .ne.', 1000
!
! test ncvgt1 for float
!
call ncvgt1 (ncid, fid, findx, fvalue, iret)
if (iret .ne. 0) nfails = nfails + 1
if (abs(fvalue - 3.14159) .gt. epsilon)
+ write(*,*) 'error in ncvgt 1 float:', fvalue,
+ ' not close to', 3.14159
!
! test ncvgt1 for double
!
call ncvgt1 (ncid, did, dindx, dvalue, iret)
if (iret .ne. 0) nfails = nfails + 1
if (abs(dvalue - onethird) .gt. epsilon) write(*,*)
+ 'error in ncvgt1 double:', dvalue, ' not close to',
+ onethird
!
! test ncvg1c for char
!
call ncvg1c (ncid, cid, cindx, c, iret)
if (iret .ne. 0) nfails = nfails + 1
if (c .ne. 'a') write(*,*) 'error in ncvg1c'
call ncclos(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test ncvpt and ncvptc
!
subroutine tncvpt(cdfname, nfails)
#include "netcdf.inc"
character*31 cdfname
! size of dimensions
integer times, lats, lons, levels
parameter (times=4, lats=5, lons=5, levels=4)
integer ncid, iret
! loop control variables
integer itime, ilev, ilon, ilat, i
integer latdim, londim, leveldim, timedim, lendim
integer dimsiz(MAXNCDIM)
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
integer lenstr
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
! vector of integers specifying the corner of the hypercube
! where the first of the data values will be written
integer start(4)
! vector of integers specifying the edge lengths from the
! corner of the hypercube where the first of the data values
! will be written
integer count(4)
! arrays of data values to be written
NCBYTE_T barray(times)
NCSHORT_T sarray(times)
integer larray(lats)
real farray(levels, lats, lons, times)
doubleprecision darray(levels, lats, lons, times)
character*31 string
data start/1,1,1,1/
data count/levels, lats, lons, times/
data barray /97, 98, 99, 100/
data sarray /10, 11, 12, 13/
ncid = ncopn (cdfname, NCWRITE, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! byte
!
count(1) = times
call ncvpt (ncid, bid, start, count, barray, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! short
!
count(1) = times
call ncvpt (ncid, sid, start, count, sarray, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! long
!
do 30 i = 1,lats
larray(i) = 1000
30 continue
count(1) = lats
call ncvpt (ncid, lid, start, count, larray, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! float
!
i = 0
do 40 itime = 1,times
do 41 ilon = 1, lons
do 42 ilat = 1, lats
do 43 ilev = 1, levels
i = i + 1
farray(ilev, ilat, ilon, itime) = real (i)
43 continue
42 continue
41 continue
40 continue
count(1) = levels
call ncvpt (ncid, fid, start, count, farray, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! double
!
i = 0
do 50 itime = 1, times
do 51 ilon = 1, lons
do 52 ilat = 1, lats
do 53 ilev = 1, levels
i = i + 1
darray(ilev, ilat, ilon, itime) = real (i)
53 continue
52 continue
51 continue
50 continue
count(1) = levels
call ncvpt (ncid, did, start, count, darray, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! char
!
start(1) = 1
start(2) = 1
count(1) = 4
count(2) = 4
lenstr = 31
string = 'testthiskind of '
call ncvptc (ncid, chid,start, count, string, lenstr, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncclos(ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
subroutine tncvpt1(cdfname, nfails)
#include "netcdf.inc"
character*31 cdfname
integer iret, ncid
integer latdim, londim, leveldim, timedim, lendim
integer dimsiz(MAXNCDIM)
common /dims/timedim, latdim, londim, leveldim, lendim,
+ dimsiz
integer bindx(1), sindx(1), lindx(1), findx(4), dindx(4), cindx(1)
integer lvalue
NCSHORT_T svalue
NCBYTE_T bvalue
doubleprecision onethird
integer bid, sid, lid, fid, did, cid, chid
common /vars/bid, sid, lid, fid, did, cid, chid
data lindx/1/, bindx/1/, sindx/1/, findx/1,1,1,1/
+dindx/1,1,1,1/, cindx/1/
data lvalue /1000/
data svalue/10/
data onethird/0.3333333333D0/
bvalue = ichar('z')
ncid = ncopn (cdfname, NCWRITE, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! test ncvpt1 for byte
!
call ncvpt1 (ncid, bid, bindx, bvalue, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! test ncvpt1 for short
!
call ncvpt1 (ncid, sid, sindx, svalue, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! test ncvpt1 for long
!
call ncvpt1 (ncid, lid, lindx, lvalue, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! test ncvpt1 for float
!
call ncvpt1 (ncid, fid, findx, 3.14159, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! test ncvpt1 for double
!
call ncvpt1 (ncid, did, dindx, onethird, iret)
if (iret .ne. 0) nfails = nfails + 1
!
! test ncvp1c for char
!
call ncvp1c (ncid, cid, cindx, 'a', iret)
if (iret .ne. 0) nfails = nfails + 1
call ncclos (ncid, iret)
if (iret .ne. 0) nfails = nfails + 1
return
end
!
! subroutine to test default fill values
!
subroutine tfills(nfails)
#include "netcdf.inc"
integer ncid
integer bid, sid, lid, fid, did
integer ix(1)
integer l
NCSHORT_T s
doubleprecision d
real f
NCBYTE_T b
ncid = NCOPN('fills.nc', NCNOWRIT, iret)
if (iret .ne. 0) nfails = nfails + 1
bid = ncvid(ncid, 'b', iret)
if (iret .ne. 0) nfails = nfails + 1
sid = ncvid(ncid, 's', iret)
if (iret .ne. 0) nfails = nfails + 1
lid = ncvid(ncid, 'l', iret)
if (iret .ne. 0) nfails = nfails + 1
fid = ncvid(ncid, 'f', iret)
if (iret .ne. 0) nfails = nfails + 1
did = ncvid(ncid, 'd', iret)
if (iret .ne. 0) nfails = nfails + 1
ix(1) = 2
call ncvgt1(ncid, bid, ix, b, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncvgt1(ncid, sid, ix, s, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncvgt1(ncid, lid, ix, l, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncvgt1(ncid, fid, ix, f, iret)
if (iret .ne. 0) nfails = nfails + 1
call ncvgt1(ncid, did, ix, d, iret)
if (iret .ne. 0) nfails = nfails + 1
if (b .ne. FILBYTE) write(*,*) 'error in byte fill value'
if (d .ne. FILDOUB) write(*,*) 'error in double fill value'
if (f .ne. FILFLOAT) write(*,*) 'error in float fill value'
if (l .ne. FILLONG) write(*,*) 'error in long fill value'
if (s .ne. FILSHORT) write(*,*) 'error in short fill value'
return
end
Reference in New Issue View Git Blame Copy Permalink