/other/netcdf_write_matrix/src/nf_test/test_put.F
FORTRAN Legacy | 6641 lines | 5687 code | 340 blank | 614 comment | 987 complexity | 2de8200fc76adb62ac8910218694729c MD5 | raw file
Possible License(s): AGPL-1.0
- C Do not edit this file. It is produced from the corresponding .m4 source */
- C********************************************************************
- C Copyright 1996, UCAR/Unidata
- C See netcdf/COPYRIGHT file for copying and redistribution conditions.
- C $Id: test_put.m4,v 1.15 2005/01/12 19:52:13 ed Exp $
- C********************************************************************
- C
- C ensure hash value within range for internal TYPE
- C
- function hash_text(type, rank, index, itype)
- implicit none
- #include "tests.inc"
- integer type
- integer rank
- integer index(1)
- integer itype
- doubleprecision minimum
- doubleprecision maximum
- minimum = internal_min(itype)
- maximum = internal_max(itype)
- hash_text = max(minimum, min(maximum, hash4( type, rank,
- + index, itype)))
- end
- #ifdef NF_INT1_T
- C
- C ensure hash value within range for internal TYPE
- C
- function hash_int1(type, rank, index, itype)
- implicit none
- #include "tests.inc"
- integer type
- integer rank
- integer index(1)
- integer itype
- doubleprecision minimum
- doubleprecision maximum
- minimum = internal_min(itype)
- maximum = internal_max(itype)
- hash_int1 = max(minimum, min(maximum, hash4( type, rank,
- + index, itype)))
- end
- #endif
- #ifdef NF_INT2_T
- C
- C ensure hash value within range for internal TYPE
- C
- function hash_int2(type, rank, index, itype)
- implicit none
- #include "tests.inc"
- integer type
- integer rank
- integer index(1)
- integer itype
- doubleprecision minimum
- doubleprecision maximum
- minimum = internal_min(itype)
- maximum = internal_max(itype)
- hash_int2 = max(minimum, min(maximum, hash4( type, rank,
- + index, itype)))
- end
- #endif
- C
- C ensure hash value within range for internal TYPE
- C
- function hash_int(type, rank, index, itype)
- implicit none
- #include "tests.inc"
- integer type
- integer rank
- integer index(1)
- integer itype
- doubleprecision minimum
- doubleprecision maximum
- minimum = internal_min(itype)
- maximum = internal_max(itype)
- hash_int = max(minimum, min(maximum, hash4( type, rank,
- + index, itype)))
- end
- C
- C ensure hash value within range for internal TYPE
- C
- function hash_real(type, rank, index, itype)
- implicit none
- #include "tests.inc"
- integer type
- integer rank
- integer index(1)
- integer itype
- doubleprecision minimum
- doubleprecision maximum
- minimum = internal_min(itype)
- maximum = internal_max(itype)
- hash_real = max(minimum, min(maximum, hash4( type, rank,
- + index, itype)))
- end
- C
- C ensure hash value within range for internal TYPE
- C
- function hash_double(type, rank, index, itype)
- implicit none
- #include "tests.inc"
- integer type
- integer rank
- integer index(1)
- integer itype
- doubleprecision minimum
- doubleprecision maximum
- minimum = internal_min(itype)
- maximum = internal_max(itype)
- hash_double = max(minimum, min(maximum, hash4( type, rank,
- + index, itype)))
- end
- C
- C check all vars in file which are (text/numeric) compatible with TYPE
- C
- subroutine check_vars_text(filename)
- implicit none
- #include "tests.inc"
- character*(*) filename
- integer ncid !/* netCDF id */
- integer index(MAX_RANK)
- integer err !/* status */
- integer d
- integer i
- integer j
- character value
- integer datatype
- integer ndims
- integer dimids(MAX_RANK)
- integer ngatts
- doubleprecision expect
- character*(NF_MAX_NAME) name
- integer length
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- err = nf_open(filename, NF_NOWRITE, ncid)
- if (err .ne. 0)
- + call errore('nf_open: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
- + ngatts)
- if (err .ne. 0)
- + call errore('nf_inq_var: ', err)
- if (name .ne. var_name(i))
- + call error('Unexpected var_name')
- if (datatype .ne. var_type(i))
- + call error('Unexpected type')
- if (ndims .ne. var_rank(i))
- + call error('Unexpected rank')
- do 2, j = 1, ndims
- err = nf_inq_dim(ncid, dimids(j), name, length)
- if (err .ne. 0)
- + call errore('nf_inq_dim: ', err)
- if (length .ne. var_shape(j,i))
- + call error('Unexpected shape')
- 2 continue
- do 3, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- expect = hash4( var_type(i), var_rank(i), index,
- + NFT_TEXT)
- err = nf_get_var1_text(ncid, i, index, value)
- if (inRange3(expect,datatype,NFT_TEXT)) then
- if (in_internal_range(NFT_TEXT,
- + expect)) then
- if (err .ne. 0) then
- call errore('nf_get_var1_text: ', err)
- else
- val = ichar(value)
- if (.not.equal(
- + val,
- + expect,var_type(i),
- + NFT_TEXT)) then
- call error(
- + 'Var value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: %d', i)
- call errorc('var_name: ',
- + var_name(i))
- call error('index:')
- do 4, d = 1, var_rank(i)
- call errori(' ', index(d))
- 4 continue
- call errord('expect: ', expect)
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- end if
- end if
- 3 continue
- end if
- 1 continue
- err = nf_close (ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call print_nok(nok)
- end
- #ifdef NF_INT1_T
- C
- C check all vars in file which are (text/numeric) compatible with TYPE
- C
- subroutine check_vars_int1(filename)
- implicit none
- #include "tests.inc"
- character*(*) filename
- integer ncid !/* netCDF id */
- integer index(MAX_RANK)
- integer err !/* status */
- integer d
- integer i
- integer j
- NF_INT1_T value
- integer datatype
- integer ndims
- integer dimids(MAX_RANK)
- integer ngatts
- doubleprecision expect
- character*(NF_MAX_NAME) name
- integer length
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- err = nf_open(filename, NF_NOWRITE, ncid)
- if (err .ne. 0)
- + call errore('nf_open: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
- + ngatts)
- if (err .ne. 0)
- + call errore('nf_inq_var: ', err)
- if (name .ne. var_name(i))
- + call error('Unexpected var_name')
- if (datatype .ne. var_type(i))
- + call error('Unexpected type')
- if (ndims .ne. var_rank(i))
- + call error('Unexpected rank')
- do 2, j = 1, ndims
- err = nf_inq_dim(ncid, dimids(j), name, length)
- if (err .ne. 0)
- + call errore('nf_inq_dim: ', err)
- if (length .ne. var_shape(j,i))
- + call error('Unexpected shape')
- 2 continue
- do 3, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- expect = hash4( var_type(i), var_rank(i), index,
- + NFT_INT1)
- err = nf_get_var1_int1(ncid, i, index, value)
- if (inRange3(expect,datatype,NFT_INT1)) then
- if (in_internal_range(NFT_INT1,
- + expect)) then
- if (err .ne. 0) then
- call errore('nf_get_var1_int1: ', err)
- else
- val = value
- if (.not.equal(
- + val,
- + expect,var_type(i),
- + NFT_INT1)) then
- call error(
- + 'Var value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: %d', i)
- call errorc('var_name: ',
- + var_name(i))
- call error('index:')
- do 4, d = 1, var_rank(i)
- call errori(' ', index(d))
- 4 continue
- call errord('expect: ', expect)
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- end if
- end if
- 3 continue
- end if
- 1 continue
- err = nf_close (ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call print_nok(nok)
- end
- #endif
- #ifdef NF_INT2_T
- C
- C check all vars in file which are (text/numeric) compatible with TYPE
- C
- subroutine check_vars_int2(filename)
- implicit none
- #include "tests.inc"
- character*(*) filename
- integer ncid !/* netCDF id */
- integer index(MAX_RANK)
- integer err !/* status */
- integer d
- integer i
- integer j
- NF_INT2_T value
- integer datatype
- integer ndims
- integer dimids(MAX_RANK)
- integer ngatts
- doubleprecision expect
- character*(NF_MAX_NAME) name
- integer length
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- err = nf_open(filename, NF_NOWRITE, ncid)
- if (err .ne. 0)
- + call errore('nf_open: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
- + ngatts)
- if (err .ne. 0)
- + call errore('nf_inq_var: ', err)
- if (name .ne. var_name(i))
- + call error('Unexpected var_name')
- if (datatype .ne. var_type(i))
- + call error('Unexpected type')
- if (ndims .ne. var_rank(i))
- + call error('Unexpected rank')
- do 2, j = 1, ndims
- err = nf_inq_dim(ncid, dimids(j), name, length)
- if (err .ne. 0)
- + call errore('nf_inq_dim: ', err)
- if (length .ne. var_shape(j,i))
- + call error('Unexpected shape')
- 2 continue
- do 3, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- expect = hash4( var_type(i), var_rank(i), index,
- + NFT_INT2)
- err = nf_get_var1_int2(ncid, i, index, value)
- if (inRange3(expect,datatype,NFT_INT2)) then
- if (in_internal_range(NFT_INT2,
- + expect)) then
- if (err .ne. 0) then
- call errore('nf_get_var1_int2: ', err)
- else
- val = value
- if (.not.equal(
- + val,
- + expect,var_type(i),
- + NFT_INT2)) then
- call error(
- + 'Var value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: %d', i)
- call errorc('var_name: ',
- + var_name(i))
- call error('index:')
- do 4, d = 1, var_rank(i)
- call errori(' ', index(d))
- 4 continue
- call errord('expect: ', expect)
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- end if
- end if
- 3 continue
- end if
- 1 continue
- err = nf_close (ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call print_nok(nok)
- end
- #endif
- C
- C check all vars in file which are (text/numeric) compatible with TYPE
- C
- subroutine check_vars_int(filename)
- implicit none
- #include "tests.inc"
- character*(*) filename
- integer ncid !/* netCDF id */
- integer index(MAX_RANK)
- integer err !/* status */
- integer d
- integer i
- integer j
- integer value
- integer datatype
- integer ndims
- integer dimids(MAX_RANK)
- integer ngatts
- doubleprecision expect
- character*(NF_MAX_NAME) name
- integer length
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- err = nf_open(filename, NF_NOWRITE, ncid)
- if (err .ne. 0)
- + call errore('nf_open: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
- + ngatts)
- if (err .ne. 0)
- + call errore('nf_inq_var: ', err)
- if (name .ne. var_name(i))
- + call error('Unexpected var_name')
- if (datatype .ne. var_type(i))
- + call error('Unexpected type')
- if (ndims .ne. var_rank(i))
- + call error('Unexpected rank')
- do 2, j = 1, ndims
- err = nf_inq_dim(ncid, dimids(j), name, length)
- if (err .ne. 0)
- + call errore('nf_inq_dim: ', err)
- if (length .ne. var_shape(j,i))
- + call error('Unexpected shape')
- 2 continue
- do 3, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- expect = hash4( var_type(i), var_rank(i), index,
- + NFT_INT)
- err = nf_get_var1_int(ncid, i, index, value)
- if (inRange3(expect,datatype,NFT_INT)) then
- if (in_internal_range(NFT_INT,
- + expect)) then
- if (err .ne. 0) then
- call errore('nf_get_var1_int: ', err)
- else
- val = value
- if (.not.equal(
- + val,
- + expect,var_type(i),
- + NFT_INT)) then
- call error(
- + 'Var value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: %d', i)
- call errorc('var_name: ',
- + var_name(i))
- call error('index:')
- do 4, d = 1, var_rank(i)
- call errori(' ', index(d))
- 4 continue
- call errord('expect: ', expect)
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- end if
- end if
- 3 continue
- end if
- 1 continue
- err = nf_close (ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call print_nok(nok)
- end
- C
- C check all vars in file which are (text/numeric) compatible with TYPE
- C
- subroutine check_vars_real(filename)
- implicit none
- #include "tests.inc"
- character*(*) filename
- integer ncid !/* netCDF id */
- integer index(MAX_RANK)
- integer err !/* status */
- integer d
- integer i
- integer j
- real value
- integer datatype
- integer ndims
- integer dimids(MAX_RANK)
- integer ngatts
- doubleprecision expect
- character*(NF_MAX_NAME) name
- integer length
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- err = nf_open(filename, NF_NOWRITE, ncid)
- if (err .ne. 0)
- + call errore('nf_open: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
- + ngatts)
- if (err .ne. 0)
- + call errore('nf_inq_var: ', err)
- if (name .ne. var_name(i))
- + call error('Unexpected var_name')
- if (datatype .ne. var_type(i))
- + call error('Unexpected type')
- if (ndims .ne. var_rank(i))
- + call error('Unexpected rank')
- do 2, j = 1, ndims
- err = nf_inq_dim(ncid, dimids(j), name, length)
- if (err .ne. 0)
- + call errore('nf_inq_dim: ', err)
- if (length .ne. var_shape(j,i))
- + call error('Unexpected shape')
- 2 continue
- do 3, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- expect = hash4( var_type(i), var_rank(i), index,
- + NFT_REAL)
- err = nf_get_var1_real(ncid, i, index, value)
- if (inRange3(expect,datatype,NFT_REAL)) then
- if (in_internal_range(NFT_REAL,
- + expect)) then
- if (err .ne. 0) then
- call errore('nf_get_var1_real: ', err)
- else
- val = value
- if (.not.equal(
- + val,
- + expect,var_type(i),
- + NFT_REAL)) then
- call error(
- + 'Var value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: %d', i)
- call errorc('var_name: ',
- + var_name(i))
- call error('index:')
- do 4, d = 1, var_rank(i)
- call errori(' ', index(d))
- 4 continue
- call errord('expect: ', expect)
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- end if
- end if
- 3 continue
- end if
- 1 continue
- err = nf_close (ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call print_nok(nok)
- end
- C
- C check all vars in file which are (text/numeric) compatible with TYPE
- C
- subroutine check_vars_double(filename)
- implicit none
- #include "tests.inc"
- character*(*) filename
- integer ncid !/* netCDF id */
- integer index(MAX_RANK)
- integer err !/* status */
- integer d
- integer i
- integer j
- doubleprecision value
- integer datatype
- integer ndims
- integer dimids(MAX_RANK)
- integer ngatts
- doubleprecision expect
- character*(NF_MAX_NAME) name
- integer length
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- err = nf_open(filename, NF_NOWRITE, ncid)
- if (err .ne. 0)
- + call errore('nf_open: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
- + ngatts)
- if (err .ne. 0)
- + call errore('nf_inq_var: ', err)
- if (name .ne. var_name(i))
- + call error('Unexpected var_name')
- if (datatype .ne. var_type(i))
- + call error('Unexpected type')
- if (ndims .ne. var_rank(i))
- + call error('Unexpected rank')
- do 2, j = 1, ndims
- err = nf_inq_dim(ncid, dimids(j), name, length)
- if (err .ne. 0)
- + call errore('nf_inq_dim: ', err)
- if (length .ne. var_shape(j,i))
- + call error('Unexpected shape')
- 2 continue
- do 3, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- expect = hash4( var_type(i), var_rank(i), index,
- + NFT_DOUBLE)
- err = nf_get_var1_double(ncid, i, index, value)
- if (inRange3(expect,datatype,NFT_DOUBLE)) then
- if (in_internal_range(NFT_DOUBLE,
- + expect)) then
- if (err .ne. 0) then
- call errore('nf_get_var1_double: ', err)
- else
- val = value
- if (.not.equal(
- + val,
- + expect,var_type(i),
- + NFT_DOUBLE)) then
- call error(
- + 'Var value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: %d', i)
- call errorc('var_name: ',
- + var_name(i))
- call error('index:')
- do 4, d = 1, var_rank(i)
- call errori(' ', index(d))
- 4 continue
- call errord('expect: ', expect)
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- end if
- end if
- 3 continue
- end if
- 1 continue
- err = nf_close (ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call print_nok(nok)
- end
- C/*
- C * check all attributes in file which are (text/numeric) compatible with TYPE
- C * ignore any attributes containing values outside range of TYPE
- C */
- subroutine check_atts_text(ncid)
- implicit none
- #include "tests.inc"
- integer ncid
- integer err !/* status */
- integer i
- integer j
- integer k
- integer ndx(1)
- character value(MAX_NELS)
- integer datatype
- doubleprecision expect(MAX_NELS)
- integer length
- integer nInExtRange !/* number values within external range */
- integer nInIntRange !/* number values within internal range */
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
- + length)
- if (err .ne. 0)
- + call errore('nf_inq_att: ', err)
- if (datatype .ne. ATT_TYPE(j,i))
- + call error('nf_inq_att: unexpected type')
- if (length .ne. ATT_LEN(j,i))
- + call error('nf_inq_att: unexpected length')
- if (.not.(length .le. MAX_NELS))
- + stop 'assert(length .le. MAX_NELS)'
- nInIntRange = 0
- nInExtRange = 0
- do 4, k = 1, length
- ndx(1) = k
- expect(k) = hash4( datatype, -1, ndx,
- + NFT_TEXT)
- if (inRange3(expect(k), datatype,
- + NFT_TEXT)) then
- nInExtRange = nInExtRange + 1
- if (in_internal_range(NFT_TEXT,
- + expect(k)))
- + nInIntRange = nInIntRange + 1
- end if
- 4 continue
- err = nf_get_att_text(ncid, i,
- + ATT_NAME(j,i), value)
- if (nInExtRange .eq. length .and.
- + nInIntRange .eq. length) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. 0 .and. err .ne. NF_ERANGE)
- + call errore('OK or Range error: ', err)
- end if
- do 3, k = 1, length
- if (inRange3(expect(k),datatype,NFT_TEXT)
- + .and.
- + in_internal_range(NFT_TEXT,
- + expect(k))) then
- val = ichar(value(k))
- if (.not.equal(
- + val,
- + expect(k),datatype,
- + NFT_TEXT)) then
- call error(
- + 'att. value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: ', i)
- call errorc('att_name: ',
- + ATT_NAME(j,i))
- call errori('element number: ', k)
- call errord('expect: ', expect(k))
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- 3 continue
- end if
- 2 continue
- 1 continue
- call print_nok(nok)
- end
- #ifdef NF_INT1_T
- C/*
- C * check all attributes in file which are (text/numeric) compatible with TYPE
- C * ignore any attributes containing values outside range of TYPE
- C */
- subroutine check_atts_int1(ncid)
- implicit none
- #include "tests.inc"
- integer ncid
- integer err !/* status */
- integer i
- integer j
- integer k
- integer ndx(1)
- NF_INT1_T value(MAX_NELS)
- integer datatype
- doubleprecision expect(MAX_NELS)
- integer length
- integer nInExtRange !/* number values within external range */
- integer nInIntRange !/* number values within internal range */
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
- + length)
- if (err .ne. 0)
- + call errore('nf_inq_att: ', err)
- if (datatype .ne. ATT_TYPE(j,i))
- + call error('nf_inq_att: unexpected type')
- if (length .ne. ATT_LEN(j,i))
- + call error('nf_inq_att: unexpected length')
- if (.not.(length .le. MAX_NELS))
- + stop 'assert(length .le. MAX_NELS)'
- nInIntRange = 0
- nInExtRange = 0
- do 4, k = 1, length
- ndx(1) = k
- expect(k) = hash4( datatype, -1, ndx,
- + NFT_INT1)
- if (inRange3(expect(k), datatype,
- + NFT_INT1)) then
- nInExtRange = nInExtRange + 1
- if (in_internal_range(NFT_INT1,
- + expect(k)))
- + nInIntRange = nInIntRange + 1
- end if
- 4 continue
- err = nf_get_att_int1(ncid, i,
- + ATT_NAME(j,i), value)
- if (nInExtRange .eq. length .and.
- + nInIntRange .eq. length) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. 0 .and. err .ne. NF_ERANGE)
- + call errore('OK or Range error: ', err)
- end if
- do 3, k = 1, length
- if (inRange3(expect(k),datatype,NFT_INT1)
- + .and.
- + in_internal_range(NFT_INT1,
- + expect(k))) then
- val = value(k)
- if (.not.equal(
- + val,
- + expect(k),datatype,
- + NFT_INT1)) then
- call error(
- + 'att. value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: ', i)
- call errorc('att_name: ',
- + ATT_NAME(j,i))
- call errori('element number: ', k)
- call errord('expect: ', expect(k))
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- 3 continue
- end if
- 2 continue
- 1 continue
- call print_nok(nok)
- end
- #endif
- #ifdef NF_INT2_T
- C/*
- C * check all attributes in file which are (text/numeric) compatible with TYPE
- C * ignore any attributes containing values outside range of TYPE
- C */
- subroutine check_atts_int2(ncid)
- implicit none
- #include "tests.inc"
- integer ncid
- integer err !/* status */
- integer i
- integer j
- integer k
- integer ndx(1)
- NF_INT2_T value(MAX_NELS)
- integer datatype
- doubleprecision expect(MAX_NELS)
- integer length
- integer nInExtRange !/* number values within external range */
- integer nInIntRange !/* number values within internal range */
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
- + length)
- if (err .ne. 0)
- + call errore('nf_inq_att: ', err)
- if (datatype .ne. ATT_TYPE(j,i))
- + call error('nf_inq_att: unexpected type')
- if (length .ne. ATT_LEN(j,i))
- + call error('nf_inq_att: unexpected length')
- if (.not.(length .le. MAX_NELS))
- + stop 'assert(length .le. MAX_NELS)'
- nInIntRange = 0
- nInExtRange = 0
- do 4, k = 1, length
- ndx(1) = k
- expect(k) = hash4( datatype, -1, ndx,
- + NFT_INT2)
- if (inRange3(expect(k), datatype,
- + NFT_INT2)) then
- nInExtRange = nInExtRange + 1
- if (in_internal_range(NFT_INT2,
- + expect(k)))
- + nInIntRange = nInIntRange + 1
- end if
- 4 continue
- err = nf_get_att_int2(ncid, i,
- + ATT_NAME(j,i), value)
- if (nInExtRange .eq. length .and.
- + nInIntRange .eq. length) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. 0 .and. err .ne. NF_ERANGE)
- + call errore('OK or Range error: ', err)
- end if
- do 3, k = 1, length
- if (inRange3(expect(k),datatype,NFT_INT2)
- + .and.
- + in_internal_range(NFT_INT2,
- + expect(k))) then
- val = value(k)
- if (.not.equal(
- + val,
- + expect(k),datatype,
- + NFT_INT2)) then
- call error(
- + 'att. value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: ', i)
- call errorc('att_name: ',
- + ATT_NAME(j,i))
- call errori('element number: ', k)
- call errord('expect: ', expect(k))
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- 3 continue
- end if
- 2 continue
- 1 continue
- call print_nok(nok)
- end
- #endif
- C/*
- C * check all attributes in file which are (text/numeric) compatible with TYPE
- C * ignore any attributes containing values outside range of TYPE
- C */
- subroutine check_atts_int(ncid)
- implicit none
- #include "tests.inc"
- integer ncid
- integer err !/* status */
- integer i
- integer j
- integer k
- integer ndx(1)
- integer value(MAX_NELS)
- integer datatype
- doubleprecision expect(MAX_NELS)
- integer length
- integer nInExtRange !/* number values within external range */
- integer nInIntRange !/* number values within internal range */
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
- + length)
- if (err .ne. 0)
- + call errore('nf_inq_att: ', err)
- if (datatype .ne. ATT_TYPE(j,i))
- + call error('nf_inq_att: unexpected type')
- if (length .ne. ATT_LEN(j,i))
- + call error('nf_inq_att: unexpected length')
- if (.not.(length .le. MAX_NELS))
- + stop 'assert(length .le. MAX_NELS)'
- nInIntRange = 0
- nInExtRange = 0
- do 4, k = 1, length
- ndx(1) = k
- expect(k) = hash4( datatype, -1, ndx,
- + NFT_INT)
- if (inRange3(expect(k), datatype,
- + NFT_INT)) then
- nInExtRange = nInExtRange + 1
- if (in_internal_range(NFT_INT,
- + expect(k)))
- + nInIntRange = nInIntRange + 1
- end if
- 4 continue
- err = nf_get_att_int(ncid, i,
- + ATT_NAME(j,i), value)
- if (nInExtRange .eq. length .and.
- + nInIntRange .eq. length) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. 0 .and. err .ne. NF_ERANGE)
- + call errore('OK or Range error: ', err)
- end if
- do 3, k = 1, length
- if (inRange3(expect(k),datatype,NFT_INT)
- + .and.
- + in_internal_range(NFT_INT,
- + expect(k))) then
- val = value(k)
- if (.not.equal(
- + val,
- + expect(k),datatype,
- + NFT_INT)) then
- call error(
- + 'att. value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: ', i)
- call errorc('att_name: ',
- + ATT_NAME(j,i))
- call errori('element number: ', k)
- call errord('expect: ', expect(k))
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- 3 continue
- end if
- 2 continue
- 1 continue
- call print_nok(nok)
- end
- C/*
- C * check all attributes in file which are (text/numeric) compatible with TYPE
- C * ignore any attributes containing values outside range of TYPE
- C */
- subroutine check_atts_real(ncid)
- implicit none
- #include "tests.inc"
- integer ncid
- integer err !/* status */
- integer i
- integer j
- integer k
- integer ndx(1)
- real value(MAX_NELS)
- integer datatype
- doubleprecision expect(MAX_NELS)
- integer length
- integer nInExtRange !/* number values within external range */
- integer nInIntRange !/* number values within internal range */
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
- + length)
- if (err .ne. 0)
- + call errore('nf_inq_att: ', err)
- if (datatype .ne. ATT_TYPE(j,i))
- + call error('nf_inq_att: unexpected type')
- if (length .ne. ATT_LEN(j,i))
- + call error('nf_inq_att: unexpected length')
- if (.not.(length .le. MAX_NELS))
- + stop 'assert(length .le. MAX_NELS)'
- nInIntRange = 0
- nInExtRange = 0
- do 4, k = 1, length
- ndx(1) = k
- expect(k) = hash4( datatype, -1, ndx,
- + NFT_REAL)
- if (inRange3(expect(k), datatype,
- + NFT_REAL)) then
- nInExtRange = nInExtRange + 1
- if (in_internal_range(NFT_REAL,
- + expect(k)))
- + nInIntRange = nInIntRange + 1
- end if
- 4 continue
- err = nf_get_att_real(ncid, i,
- + ATT_NAME(j,i), value)
- if (nInExtRange .eq. length .and.
- + nInIntRange .eq. length) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. 0 .and. err .ne. NF_ERANGE)
- + call errore('OK or Range error: ', err)
- end if
- do 3, k = 1, length
- if (inRange3(expect(k),datatype,NFT_REAL)
- + .and.
- + in_internal_range(NFT_REAL,
- + expect(k))) then
- val = value(k)
- if (.not.equal(
- + val,
- + expect(k),datatype,
- + NFT_REAL)) then
- call error(
- + 'att. value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: ', i)
- call errorc('att_name: ',
- + ATT_NAME(j,i))
- call errori('element number: ', k)
- call errord('expect: ', expect(k))
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- 3 continue
- end if
- 2 continue
- 1 continue
- call print_nok(nok)
- end
- C/*
- C * check all attributes in file which are (text/numeric) compatible with TYPE
- C * ignore any attributes containing values outside range of TYPE
- C */
- subroutine check_atts_double(ncid)
- implicit none
- #include "tests.inc"
- integer ncid
- integer err !/* status */
- integer i
- integer j
- integer k
- integer ndx(1)
- doubleprecision value(MAX_NELS)
- integer datatype
- doubleprecision expect(MAX_NELS)
- integer length
- integer nInExtRange !/* number values within external range */
- integer nInIntRange !/* number values within internal range */
- logical canConvert !/* Both text or both numeric */
- integer nok !/* count of valid comparisons */
- doubleprecision val
- nok = 0
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- if (canConvert) then
- err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
- + length)
- if (err .ne. 0)
- + call errore('nf_inq_att: ', err)
- if (datatype .ne. ATT_TYPE(j,i))
- + call error('nf_inq_att: unexpected type')
- if (length .ne. ATT_LEN(j,i))
- + call error('nf_inq_att: unexpected length')
- if (.not.(length .le. MAX_NELS))
- + stop 'assert(length .le. MAX_NELS)'
- nInIntRange = 0
- nInExtRange = 0
- do 4, k = 1, length
- ndx(1) = k
- expect(k) = hash4( datatype, -1, ndx,
- + NFT_DOUBLE)
- if (inRange3(expect(k), datatype,
- + NFT_DOUBLE)) then
- nInExtRange = nInExtRange + 1
- if (in_internal_range(NFT_DOUBLE,
- + expect(k)))
- + nInIntRange = nInIntRange + 1
- end if
- 4 continue
- err = nf_get_att_double(ncid, i,
- + ATT_NAME(j,i), value)
- if (nInExtRange .eq. length .and.
- + nInIntRange .eq. length) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. 0 .and. err .ne. NF_ERANGE)
- + call errore('OK or Range error: ', err)
- end if
- do 3, k = 1, length
- if (inRange3(expect(k),datatype,NFT_DOUBLE)
- + .and.
- + in_internal_range(NFT_DOUBLE,
- + expect(k))) then
- val = value(k)
- if (.not.equal(
- + val,
- + expect(k),datatype,
- + NFT_DOUBLE)) then
- call error(
- + 'att. value read not that expected')
- if (verbose) then
- call error(' ')
- call errori('varid: ', i)
- call errorc('att_name: ',
- + ATT_NAME(j,i))
- call errori('element number: ', k)
- call errord('expect: ', expect(k))
- call errord('got: ', val)
- end if
- else
- nok = nok + 1
- end if
- end if
- 3 continue
- end if
- 2 continue
- 1 continue
- call print_nok(nok)
- end
- subroutine test_nf_put_var1_text()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer err
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- character value
- doubleprecision val
- value = char(int(5))!/* any value would do - only for error cases */
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- do 2, j = 1, var_rank(i)
- index(j) = 1
- 2 continue
- err = nf_put_var1_text(BAD_ID, i, index, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var1_text(ncid, BAD_VARID,
- + index, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
- index(j) = var_shape(j,i) + 1
- err = nf_put_var1_text(ncid, i,
- + index, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad index: ', err)
- endif
- index(j) = 0
- end if
- 3 continue
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value = char(int(hash_text(var_type(i),var_rank(i),
- + index, NFT_TEXT)))
- err = nf_put_var1_text(ncid, i, index, value)
- if (canConvert) then
- val = ichar(value)
- if (inRange3(val, var_type(i), NFT_TEXT)) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('Range error: ', err)
- end if
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 4 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_text(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #ifdef NF_INT1_T
- subroutine test_nf_put_var1_int1()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer err
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- NF_INT1_T value
- doubleprecision val
- value = 5!/* any value would do - only for error cases */
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- do 2, j = 1, var_rank(i)
- index(j) = 1
- 2 continue
- err = nf_put_var1_int1(BAD_ID, i, index, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var1_int1(ncid, BAD_VARID,
- + index, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
- index(j) = var_shape(j,i) + 1
- err = nf_put_var1_int1(ncid, i,
- + index, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad index: ', err)
- endif
- index(j) = 0
- end if
- 3 continue
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value = hash_int1(var_type(i),var_rank(i),
- + index, NFT_INT1)
- err = nf_put_var1_int1(ncid, i, index, value)
- if (canConvert) then
- val = value
- if (inRange3(val, var_type(i), NFT_INT1)) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('Range error: ', err)
- end if
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 4 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int1(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #endif
- #ifdef NF_INT2_T
- subroutine test_nf_put_var1_int2()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer err
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- NF_INT2_T value
- doubleprecision val
- value = 5!/* any value would do - only for error cases */
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- do 2, j = 1, var_rank(i)
- index(j) = 1
- 2 continue
- err = nf_put_var1_int2(BAD_ID, i, index, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var1_int2(ncid, BAD_VARID,
- + index, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
- index(j) = var_shape(j,i) + 1
- err = nf_put_var1_int2(ncid, i,
- + index, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad index: ', err)
- endif
- index(j) = 0
- end if
- 3 continue
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value = hash_int2(var_type(i),var_rank(i),
- + index, NFT_INT2)
- err = nf_put_var1_int2(ncid, i, index, value)
- if (canConvert) then
- val = value
- if (inRange3(val, var_type(i), NFT_INT2)) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('Range error: ', err)
- end if
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 4 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int2(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #endif
- subroutine test_nf_put_var1_int()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer err
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- integer value
- doubleprecision val
- value = 5!/* any value would do - only for error cases */
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- do 2, j = 1, var_rank(i)
- index(j) = 1
- 2 continue
- err = nf_put_var1_int(BAD_ID, i, index, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var1_int(ncid, BAD_VARID,
- + index, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
- index(j) = var_shape(j,i) + 1
- err = nf_put_var1_int(ncid, i,
- + index, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad index: ', err)
- endif
- index(j) = 0
- end if
- 3 continue
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value = hash_int(var_type(i),var_rank(i),
- + index, NFT_INT)
- err = nf_put_var1_int(ncid, i, index, value)
- if (canConvert) then
- val = value
- if (inRange3(val, var_type(i), NFT_INT)) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('Range error: ', err)
- end if
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 4 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_var1_real()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer err
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- real value
- doubleprecision val
- value = 5!/* any value would do - only for error cases */
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- do 2, j = 1, var_rank(i)
- index(j) = 1
- 2 continue
- err = nf_put_var1_real(BAD_ID, i, index, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var1_real(ncid, BAD_VARID,
- + index, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
- index(j) = var_shape(j,i) + 1
- err = nf_put_var1_real(ncid, i,
- + index, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad index: ', err)
- endif
- index(j) = 0
- end if
- 3 continue
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value = hash_real(var_type(i),var_rank(i),
- + index, NFT_REAL)
- err = nf_put_var1_real(ncid, i, index, value)
- if (canConvert) then
- val = value
- if (inRange3(val, var_type(i), NFT_REAL)) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('Range error: ', err)
- end if
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 4 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_real(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_var1_double()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer err
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- doubleprecision value
- doubleprecision val
- value = 5!/* any value would do - only for error cases */
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- do 2, j = 1, var_rank(i)
- index(j) = 1
- 2 continue
- err = nf_put_var1_double(BAD_ID, i, index, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var1_double(ncid, BAD_VARID,
- + index, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
- index(j) = var_shape(j,i) + 1
- err = nf_put_var1_double(ncid, i,
- + index, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad index: ', err)
- endif
- index(j) = 0
- end if
- 3 continue
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value = hash_double(var_type(i),var_rank(i),
- + index, NFT_DOUBLE)
- err = nf_put_var1_double(ncid, i, index, value)
- if (canConvert) then
- val = value
- if (inRange3(val, var_type(i), NFT_DOUBLE)) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('Range error: ', err)
- end if
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 4 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_double(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_var_text()
- implicit none
- #include "tests.inc"
- integer ncid
- integer vid
- integer i
- integer j
- integer err
- integer nels
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* All values within external range?*/
- character value(MAX_NELS)
- doubleprecision val
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- err = nf_put_var_text(BAD_ID, i, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var_text(ncid, BAD_VARID, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- nels = 1
- do 3, j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 3 continue
- allInExtRange = .true.
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value(j) = char(int(hash_text(var_type(i),
- + var_rank(i),
- + index, NFT_TEXT)))
- val = ichar(value(j))
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_TEXT)
- 4 continue
- err = nf_put_var_text(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE .and.
- + var_dimid(var_rank(i),i) .ne. RECDIM)
- + call errore('Range error: ', err)
- endif
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- 1 continue
- C The preceeding has written nothing for record variables, now try
- C again with more than 0 records.
- C Write record number NRECS to force writing of preceding records.
- C Assumes variable cr is char vector with UNLIMITED dimension.
- err = nf_inq_varid(ncid, "cr", vid)
- if (err .ne. 0)
- + call errore('nf_inq_varid: ', err)
- index(1) = NRECS
- err = nf_put_var1_text(ncid, vid, index, 'x')
- if (err .ne. 0)
- + call errore('nf_put_var1_text: ', err)
- do 5 i = 1, NVARS
- C Only test record variables here
- if (var_rank(i) .ge. 1 .and.
- + var_dimid(var_rank(i),i) .eq. RECDIM) then
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- if (var_rank(i) .gt. MAX_RANK)
- + stop 'var_rank(i) .gt. MAX_RANK'
- if (var_nels(i) .gt. MAX_NELS)
- + stop 'var_nels(i) .gt. MAX_NELS'
- err = nf_put_var_text(BAD_ID, i, value)
- nels = 1
- do 6 j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- value(j) = char(int(hash_text(var_type(i),
- + var_rank(i),
- + index, NFT_TEXT)))
- val = ichar(value(j))
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_TEXT)
- 7 continue
- err = nf_put_var_text(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- endif
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- endif
- 5 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_text(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #ifdef NF_INT1_T
- subroutine test_nf_put_var_int1()
- implicit none
- #include "tests.inc"
- integer ncid
- integer vid
- integer i
- integer j
- integer err
- integer nels
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* All values within external range?*/
- NF_INT1_T value(MAX_NELS)
- doubleprecision val
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- err = nf_put_var_int1(BAD_ID, i, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var_int1(ncid, BAD_VARID, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- nels = 1
- do 3, j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 3 continue
- allInExtRange = .true.
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value(j) = hash_int1(var_type(i),
- + var_rank(i),
- + index, NFT_INT1)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT1)
- 4 continue
- err = nf_put_var_int1(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE .and.
- + var_dimid(var_rank(i),i) .ne. RECDIM)
- + call errore('Range error: ', err)
- endif
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- 1 continue
- C The preceeding has written nothing for record variables, now try
- C again with more than 0 records.
- C Write record number NRECS to force writing of preceding records.
- C Assumes variable cr is char vector with UNLIMITED dimension.
- err = nf_inq_varid(ncid, "cr", vid)
- if (err .ne. 0)
- + call errore('nf_inq_varid: ', err)
- index(1) = NRECS
- err = nf_put_var1_text(ncid, vid, index, 'x')
- if (err .ne. 0)
- + call errore('nf_put_var1_text: ', err)
- do 5 i = 1, NVARS
- C Only test record variables here
- if (var_rank(i) .ge. 1 .and.
- + var_dimid(var_rank(i),i) .eq. RECDIM) then
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- if (var_rank(i) .gt. MAX_RANK)
- + stop 'var_rank(i) .gt. MAX_RANK'
- if (var_nels(i) .gt. MAX_NELS)
- + stop 'var_nels(i) .gt. MAX_NELS'
- err = nf_put_var_int1(BAD_ID, i, value)
- nels = 1
- do 6 j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- value(j) = hash_int1(var_type(i),
- + var_rank(i),
- + index, NFT_INT1)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT1)
- 7 continue
- err = nf_put_var_int1(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- endif
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- endif
- 5 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int1(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #endif
- #ifdef NF_INT2_T
- subroutine test_nf_put_var_int2()
- implicit none
- #include "tests.inc"
- integer ncid
- integer vid
- integer i
- integer j
- integer err
- integer nels
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* All values within external range?*/
- NF_INT2_T value(MAX_NELS)
- doubleprecision val
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- err = nf_put_var_int2(BAD_ID, i, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var_int2(ncid, BAD_VARID, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- nels = 1
- do 3, j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 3 continue
- allInExtRange = .true.
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value(j) = hash_int2(var_type(i),
- + var_rank(i),
- + index, NFT_INT2)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT2)
- 4 continue
- err = nf_put_var_int2(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE .and.
- + var_dimid(var_rank(i),i) .ne. RECDIM)
- + call errore('Range error: ', err)
- endif
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- 1 continue
- C The preceeding has written nothing for record variables, now try
- C again with more than 0 records.
- C Write record number NRECS to force writing of preceding records.
- C Assumes variable cr is char vector with UNLIMITED dimension.
- err = nf_inq_varid(ncid, "cr", vid)
- if (err .ne. 0)
- + call errore('nf_inq_varid: ', err)
- index(1) = NRECS
- err = nf_put_var1_text(ncid, vid, index, 'x')
- if (err .ne. 0)
- + call errore('nf_put_var1_text: ', err)
- do 5 i = 1, NVARS
- C Only test record variables here
- if (var_rank(i) .ge. 1 .and.
- + var_dimid(var_rank(i),i) .eq. RECDIM) then
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- if (var_rank(i) .gt. MAX_RANK)
- + stop 'var_rank(i) .gt. MAX_RANK'
- if (var_nels(i) .gt. MAX_NELS)
- + stop 'var_nels(i) .gt. MAX_NELS'
- err = nf_put_var_int2(BAD_ID, i, value)
- nels = 1
- do 6 j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- value(j) = hash_int2(var_type(i),
- + var_rank(i),
- + index, NFT_INT2)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT2)
- 7 continue
- err = nf_put_var_int2(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- endif
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- endif
- 5 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int2(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #endif
- subroutine test_nf_put_var_int()
- implicit none
- #include "tests.inc"
- integer ncid
- integer vid
- integer i
- integer j
- integer err
- integer nels
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* All values within external range?*/
- integer value(MAX_NELS)
- doubleprecision val
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- err = nf_put_var_int(BAD_ID, i, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var_int(ncid, BAD_VARID, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- nels = 1
- do 3, j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 3 continue
- allInExtRange = .true.
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value(j) = hash_int(var_type(i),
- + var_rank(i),
- + index, NFT_INT)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT)
- 4 continue
- err = nf_put_var_int(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE .and.
- + var_dimid(var_rank(i),i) .ne. RECDIM)
- + call errore('Range error: ', err)
- endif
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- 1 continue
- C The preceeding has written nothing for record variables, now try
- C again with more than 0 records.
- C Write record number NRECS to force writing of preceding records.
- C Assumes variable cr is char vector with UNLIMITED dimension.
- err = nf_inq_varid(ncid, "cr", vid)
- if (err .ne. 0)
- + call errore('nf_inq_varid: ', err)
- index(1) = NRECS
- err = nf_put_var1_text(ncid, vid, index, 'x')
- if (err .ne. 0)
- + call errore('nf_put_var1_text: ', err)
- do 5 i = 1, NVARS
- C Only test record variables here
- if (var_rank(i) .ge. 1 .and.
- + var_dimid(var_rank(i),i) .eq. RECDIM) then
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- if (var_rank(i) .gt. MAX_RANK)
- + stop 'var_rank(i) .gt. MAX_RANK'
- if (var_nels(i) .gt. MAX_NELS)
- + stop 'var_nels(i) .gt. MAX_NELS'
- err = nf_put_var_int(BAD_ID, i, value)
- nels = 1
- do 6 j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- value(j) = hash_int(var_type(i),
- + var_rank(i),
- + index, NFT_INT)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT)
- 7 continue
- err = nf_put_var_int(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- endif
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- endif
- 5 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_var_real()
- implicit none
- #include "tests.inc"
- integer ncid
- integer vid
- integer i
- integer j
- integer err
- integer nels
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* All values within external range?*/
- real value(MAX_NELS)
- doubleprecision val
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- err = nf_put_var_real(BAD_ID, i, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var_real(ncid, BAD_VARID, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- nels = 1
- do 3, j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 3 continue
- allInExtRange = .true.
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value(j) = hash_real(var_type(i),
- + var_rank(i),
- + index, NFT_REAL)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_REAL)
- 4 continue
- err = nf_put_var_real(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE .and.
- + var_dimid(var_rank(i),i) .ne. RECDIM)
- + call errore('Range error: ', err)
- endif
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- 1 continue
- C The preceeding has written nothing for record variables, now try
- C again with more than 0 records.
- C Write record number NRECS to force writing of preceding records.
- C Assumes variable cr is char vector with UNLIMITED dimension.
- err = nf_inq_varid(ncid, "cr", vid)
- if (err .ne. 0)
- + call errore('nf_inq_varid: ', err)
- index(1) = NRECS
- err = nf_put_var1_text(ncid, vid, index, 'x')
- if (err .ne. 0)
- + call errore('nf_put_var1_text: ', err)
- do 5 i = 1, NVARS
- C Only test record variables here
- if (var_rank(i) .ge. 1 .and.
- + var_dimid(var_rank(i),i) .eq. RECDIM) then
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- if (var_rank(i) .gt. MAX_RANK)
- + stop 'var_rank(i) .gt. MAX_RANK'
- if (var_nels(i) .gt. MAX_NELS)
- + stop 'var_nels(i) .gt. MAX_NELS'
- err = nf_put_var_real(BAD_ID, i, value)
- nels = 1
- do 6 j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- value(j) = hash_real(var_type(i),
- + var_rank(i),
- + index, NFT_REAL)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_REAL)
- 7 continue
- err = nf_put_var_real(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- endif
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- endif
- 5 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_real(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_var_double()
- implicit none
- #include "tests.inc"
- integer ncid
- integer vid
- integer i
- integer j
- integer err
- integer nels
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* All values within external range?*/
- doubleprecision value(MAX_NELS)
- doubleprecision val
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- err = nf_put_var_double(BAD_ID, i, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_var_double(ncid, BAD_VARID, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- nels = 1
- do 3, j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 3 continue
- allInExtRange = .true.
- do 4, j = 1, var_nels(i)
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- value(j) = hash_double(var_type(i),
- + var_rank(i),
- + index, NFT_DOUBLE)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_DOUBLE)
- 4 continue
- err = nf_put_var_double(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE .and.
- + var_dimid(var_rank(i),i) .ne. RECDIM)
- + call errore('Range error: ', err)
- endif
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- 1 continue
- C The preceeding has written nothing for record variables, now try
- C again with more than 0 records.
- C Write record number NRECS to force writing of preceding records.
- C Assumes variable cr is char vector with UNLIMITED dimension.
- err = nf_inq_varid(ncid, "cr", vid)
- if (err .ne. 0)
- + call errore('nf_inq_varid: ', err)
- index(1) = NRECS
- err = nf_put_var1_text(ncid, vid, index, 'x')
- if (err .ne. 0)
- + call errore('nf_put_var1_text: ', err)
- do 5 i = 1, NVARS
- C Only test record variables here
- if (var_rank(i) .ge. 1 .and.
- + var_dimid(var_rank(i),i) .eq. RECDIM) then
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- if (var_rank(i) .gt. MAX_RANK)
- + stop 'var_rank(i) .gt. MAX_RANK'
- if (var_nels(i) .gt. MAX_NELS)
- + stop 'var_nels(i) .gt. MAX_NELS'
- err = nf_put_var_double(BAD_ID, i, value)
- nels = 1
- do 6 j = 1, var_rank(i)
- nels = nels * var_shape(j,i)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), var_shape(1,i),
- + index)
- if (err .ne. 0)
- + call error('error in index2indexes()')
- value(j) = hash_double(var_type(i),
- + var_rank(i),
- + index, NFT_DOUBLE)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_DOUBLE)
- 7 continue
- err = nf_put_var_double(ncid, i, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- endif
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- endif
- 5 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_double(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_vara_text()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer d
- integer err
- integer nslabs
- integer nels
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer mid(MAX_RANK)
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- character value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- 2 continue
- err = nf_put_vara_text(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_text(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 1
- err = nf_put_vara_text(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vara_text(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- end if
- 3 continue
- C /* Check correct error returned even when nothing to put */
- do 20, j = 1, var_rank(i)
- edge(j) = 0
- 20 continue
- err = nf_put_vara_text(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_text(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 21, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vara_text(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- endif
- 21 continue
- err = nf_put_vara_text(ncid, i, start, edge, value)
- if (canConvert) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- do 22, j = 1, var_rank(i)
- edge(j) = 1
- 22 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- do 5, k = 1, nslabs
- nels = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- nels = nels * edge(j)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), edge, index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- do 8, d = 1, var_rank(i)
- index(d) = index(d) + start(d) - 1
- 8 continue
- value(j)= char(int(hash_text(var_type(i),
- + var_rank(i), index,
- + NFT_TEXT)))
- val = ichar(value(j))
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_TEXT)
- 7 continue
- err = nf_put_vara_text(ncid, i, start,
- + edge, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_text(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #ifdef NF_INT1_T
- subroutine test_nf_put_vara_int1()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer d
- integer err
- integer nslabs
- integer nels
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer mid(MAX_RANK)
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- NF_INT1_T value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- 2 continue
- err = nf_put_vara_int1(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_int1(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 1
- err = nf_put_vara_int1(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vara_int1(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- end if
- 3 continue
- C /* Check correct error returned even when nothing to put */
- do 20, j = 1, var_rank(i)
- edge(j) = 0
- 20 continue
- err = nf_put_vara_int1(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_int1(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 21, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vara_int1(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- endif
- 21 continue
- err = nf_put_vara_int1(ncid, i, start, edge, value)
- if (canConvert) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- do 22, j = 1, var_rank(i)
- edge(j) = 1
- 22 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- do 5, k = 1, nslabs
- nels = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- nels = nels * edge(j)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), edge, index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- do 8, d = 1, var_rank(i)
- index(d) = index(d) + start(d) - 1
- 8 continue
- value(j)= hash_int1(var_type(i),
- + var_rank(i), index,
- + NFT_INT1)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT1)
- 7 continue
- err = nf_put_vara_int1(ncid, i, start,
- + edge, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int1(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #endif
- #ifdef NF_INT2_T
- subroutine test_nf_put_vara_int2()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer d
- integer err
- integer nslabs
- integer nels
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer mid(MAX_RANK)
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- NF_INT2_T value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- 2 continue
- err = nf_put_vara_int2(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_int2(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 1
- err = nf_put_vara_int2(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vara_int2(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- end if
- 3 continue
- C /* Check correct error returned even when nothing to put */
- do 20, j = 1, var_rank(i)
- edge(j) = 0
- 20 continue
- err = nf_put_vara_int2(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_int2(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 21, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vara_int2(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- endif
- 21 continue
- err = nf_put_vara_int2(ncid, i, start, edge, value)
- if (canConvert) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- do 22, j = 1, var_rank(i)
- edge(j) = 1
- 22 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- do 5, k = 1, nslabs
- nels = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- nels = nels * edge(j)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), edge, index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- do 8, d = 1, var_rank(i)
- index(d) = index(d) + start(d) - 1
- 8 continue
- value(j)= hash_int2(var_type(i),
- + var_rank(i), index,
- + NFT_INT2)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT2)
- 7 continue
- err = nf_put_vara_int2(ncid, i, start,
- + edge, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int2(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- #endif
- subroutine test_nf_put_vara_int()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer d
- integer err
- integer nslabs
- integer nels
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer mid(MAX_RANK)
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- integer value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- 2 continue
- err = nf_put_vara_int(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_int(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 1
- err = nf_put_vara_int(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vara_int(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- end if
- 3 continue
- C /* Check correct error returned even when nothing to put */
- do 20, j = 1, var_rank(i)
- edge(j) = 0
- 20 continue
- err = nf_put_vara_int(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_int(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 21, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vara_int(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- endif
- 21 continue
- err = nf_put_vara_int(ncid, i, start, edge, value)
- if (canConvert) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- do 22, j = 1, var_rank(i)
- edge(j) = 1
- 22 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- do 5, k = 1, nslabs
- nels = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- nels = nels * edge(j)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), edge, index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- do 8, d = 1, var_rank(i)
- index(d) = index(d) + start(d) - 1
- 8 continue
- value(j)= hash_int(var_type(i),
- + var_rank(i), index,
- + NFT_INT)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_INT)
- 7 continue
- err = nf_put_vara_int(ncid, i, start,
- + edge, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_vara_real()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer d
- integer err
- integer nslabs
- integer nels
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer mid(MAX_RANK)
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- real value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- 2 continue
- err = nf_put_vara_real(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_real(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 1
- err = nf_put_vara_real(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vara_real(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- end if
- 3 continue
- C /* Check correct error returned even when nothing to put */
- do 20, j = 1, var_rank(i)
- edge(j) = 0
- 20 continue
- err = nf_put_vara_real(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_real(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 21, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vara_real(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- endif
- 21 continue
- err = nf_put_vara_real(ncid, i, start, edge, value)
- if (canConvert) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- do 22, j = 1, var_rank(i)
- edge(j) = 1
- 22 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- do 5, k = 1, nslabs
- nels = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- nels = nels * edge(j)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), edge, index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- do 8, d = 1, var_rank(i)
- index(d) = index(d) + start(d) - 1
- 8 continue
- value(j)= hash_real(var_type(i),
- + var_rank(i), index,
- + NFT_REAL)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_REAL)
- 7 continue
- err = nf_put_vara_real(ncid, i, start,
- + edge, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_real(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_vara_double()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer d
- integer err
- integer nslabs
- integer nels
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer mid(MAX_RANK)
- integer index(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- doubleprecision value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- 2 continue
- err = nf_put_vara_double(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_double(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 1
- err = nf_put_vara_double(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vara_double(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- end if
- 3 continue
- C /* Check correct error returned even when nothing to put */
- do 20, j = 1, var_rank(i)
- edge(j) = 0
- 20 continue
- err = nf_put_vara_double(BAD_ID, i, start,
- + edge, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vara_double(ncid, BAD_VARID,
- + start, edge, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 21, j = 1, var_rank(i)
- if (var_dimid(j,i) .gt. 1) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vara_double(ncid, i, start,
- + edge, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- endif
- 21 continue
- err = nf_put_vara_double(ncid, i, start, edge, value)
- if (canConvert) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- endif
- do 22, j = 1, var_rank(i)
- edge(j) = 1
- 22 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- do 5, k = 1, nslabs
- nels = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- nels = nels * edge(j)
- 6 continue
- allInExtRange = .true.
- do 7, j = 1, nels
- err = index2indexes(j, var_rank(i), edge, index)
- if (err .ne. 0)
- + call error('error in index2indexes 1')
- do 8, d = 1, var_rank(i)
- index(d) = index(d) + start(d) - 1
- 8 continue
- value(j)= hash_double(var_type(i),
- + var_rank(i), index,
- + NFT_DOUBLE)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i), NFT_DOUBLE)
- 7 continue
- err = nf_put_vara_double(ncid, i, start,
- + edge, value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_double(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed: ',
- + scratch)
- end
- subroutine test_nf_put_vars_text()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- character value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- 2 continue
- err = nf_put_vars_text(BAD_ID, i, start,
- + edge, stride, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vars_text(ncid, BAD_VARID, start,
- + edge, stride,
- + value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vars_text(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vars_text(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_vars_text(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) {
- C for (j = 1 j .lt. var_rank(i) j++) {
- C index(j) += (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C }
- C }
- C*/
- allInExtRange = .true.
- do 9, j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 10, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 10 continue
- value(j) = char(int(hash_text(var_type(i),
- + var_rank(i),
- + index2, NFT_TEXT)))
- val = ichar(value(j))
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_TEXT)
- 9 continue
- err = nf_put_vars_text(ncid, i, index,
- + count, stride,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_text(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #ifdef NF_INT1_T
- subroutine test_nf_put_vars_int1()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- NF_INT1_T value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- 2 continue
- err = nf_put_vars_int1(BAD_ID, i, start,
- + edge, stride, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vars_int1(ncid, BAD_VARID, start,
- + edge, stride,
- + value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vars_int1(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vars_int1(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_vars_int1(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) {
- C for (j = 1 j .lt. var_rank(i) j++) {
- C index(j) += (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C }
- C }
- C*/
- allInExtRange = .true.
- do 9, j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 10, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 10 continue
- value(j) = hash_int1(var_type(i),
- + var_rank(i),
- + index2, NFT_INT1)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_INT1)
- 9 continue
- err = nf_put_vars_int1(ncid, i, index,
- + count, stride,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int1(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #endif
- #ifdef NF_INT2_T
- subroutine test_nf_put_vars_int2()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- NF_INT2_T value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- 2 continue
- err = nf_put_vars_int2(BAD_ID, i, start,
- + edge, stride, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vars_int2(ncid, BAD_VARID, start,
- + edge, stride,
- + value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vars_int2(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vars_int2(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_vars_int2(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) {
- C for (j = 1 j .lt. var_rank(i) j++) {
- C index(j) += (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C }
- C }
- C*/
- allInExtRange = .true.
- do 9, j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 10, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 10 continue
- value(j) = hash_int2(var_type(i),
- + var_rank(i),
- + index2, NFT_INT2)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_INT2)
- 9 continue
- err = nf_put_vars_int2(ncid, i, index,
- + count, stride,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int2(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #endif
- subroutine test_nf_put_vars_int()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- integer value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- 2 continue
- err = nf_put_vars_int(BAD_ID, i, start,
- + edge, stride, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vars_int(ncid, BAD_VARID, start,
- + edge, stride,
- + value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vars_int(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vars_int(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_vars_int(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) {
- C for (j = 1 j .lt. var_rank(i) j++) {
- C index(j) += (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C }
- C }
- C*/
- allInExtRange = .true.
- do 9, j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 10, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 10 continue
- value(j) = hash_int(var_type(i),
- + var_rank(i),
- + index2, NFT_INT)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_INT)
- 9 continue
- err = nf_put_vars_int(ncid, i, index,
- + count, stride,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_vars_real()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- real value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- 2 continue
- err = nf_put_vars_real(BAD_ID, i, start,
- + edge, stride, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vars_real(ncid, BAD_VARID, start,
- + edge, stride,
- + value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vars_real(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vars_real(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_vars_real(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) {
- C for (j = 1 j .lt. var_rank(i) j++) {
- C index(j) += (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C }
- C }
- C*/
- allInExtRange = .true.
- do 9, j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 10, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 10 continue
- value(j) = hash_real(var_type(i),
- + var_rank(i),
- + index2, NFT_REAL)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_REAL)
- 9 continue
- err = nf_put_vars_real(ncid, i, index,
- + count, stride,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_real(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_vars_double()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- doubleprecision value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- 2 continue
- err = nf_put_vars_double(BAD_ID, i, start,
- + edge, stride, value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_vars_double(ncid, BAD_VARID, start,
- + edge, stride,
- + value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
- start(j) = var_shape(j,i) + 2
- err = nf_put_vars_double(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_vars_double(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_vars_double(ncid, i, start,
- + edge, stride,
- + value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) {
- C for (j = 1 j .lt. var_rank(i) j++) {
- C index(j) += (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C }
- C }
- C*/
- allInExtRange = .true.
- do 9, j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 10, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 10 continue
- value(j) = hash_double(var_type(i),
- + var_rank(i),
- + index2, NFT_DOUBLE)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_DOUBLE)
- 9 continue
- err = nf_put_vars_double(ncid, i, index,
- + count, stride,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_double(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_varm_text()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- integer imap(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- character value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_TEXT .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- imap(j) = 1
- 2 continue
- err = nf_put_varm_text(BAD_ID, i, start,
- + edge, stride, imap,
- + value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_varm_text(ncid, BAD_VARID, start,
- + edge, stride,
- + imap, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 2
- err = nf_put_varm_text(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_varm_text(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_varm_text(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) then
- C do 9, j = 1, var_rank(i)
- C index(j) = index(j) +
- C + (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C9 continue
- C end if
- C*/
- if (var_rank(i) .gt. 0) then
- imap(1) = 1
- do 10, j = 2, var_rank(i)
- imap(j) = imap(j-1) * count(j-1)
- 10 continue
- end if
- allInExtRange = .true.
- do 11 j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 12, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 12 continue
- value(j) = char(int(hash_text(var_type(i),
- + var_rank(i),
- + index2, NFT_TEXT)))
- val = ichar(value(j))
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_TEXT)
- 11 continue
- err = nf_put_varm_text(ncid,i,index,count,
- + stride,imap,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_text(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #ifdef NF_INT1_T
- subroutine test_nf_put_varm_int1()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- integer imap(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- NF_INT1_T value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT1 .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- imap(j) = 1
- 2 continue
- err = nf_put_varm_int1(BAD_ID, i, start,
- + edge, stride, imap,
- + value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_varm_int1(ncid, BAD_VARID, start,
- + edge, stride,
- + imap, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 2
- err = nf_put_varm_int1(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_varm_int1(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_varm_int1(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) then
- C do 9, j = 1, var_rank(i)
- C index(j) = index(j) +
- C + (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C9 continue
- C end if
- C*/
- if (var_rank(i) .gt. 0) then
- imap(1) = 1
- do 10, j = 2, var_rank(i)
- imap(j) = imap(j-1) * count(j-1)
- 10 continue
- end if
- allInExtRange = .true.
- do 11 j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 12, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 12 continue
- value(j) = hash_int1(var_type(i),
- + var_rank(i),
- + index2, NFT_INT1)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_INT1)
- 11 continue
- err = nf_put_varm_int1(ncid,i,index,count,
- + stride,imap,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int1(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #endif
- #ifdef NF_INT2_T
- subroutine test_nf_put_varm_int2()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- integer imap(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- NF_INT2_T value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT2 .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- imap(j) = 1
- 2 continue
- err = nf_put_varm_int2(BAD_ID, i, start,
- + edge, stride, imap,
- + value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_varm_int2(ncid, BAD_VARID, start,
- + edge, stride,
- + imap, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 2
- err = nf_put_varm_int2(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_varm_int2(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_varm_int2(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) then
- C do 9, j = 1, var_rank(i)
- C index(j) = index(j) +
- C + (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C9 continue
- C end if
- C*/
- if (var_rank(i) .gt. 0) then
- imap(1) = 1
- do 10, j = 2, var_rank(i)
- imap(j) = imap(j-1) * count(j-1)
- 10 continue
- end if
- allInExtRange = .true.
- do 11 j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 12, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 12 continue
- value(j) = hash_int2(var_type(i),
- + var_rank(i),
- + index2, NFT_INT2)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_INT2)
- 11 continue
- err = nf_put_varm_int2(ncid,i,index,count,
- + stride,imap,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int2(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #endif
- subroutine test_nf_put_varm_int()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- integer imap(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- integer value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_INT .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- imap(j) = 1
- 2 continue
- err = nf_put_varm_int(BAD_ID, i, start,
- + edge, stride, imap,
- + value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_varm_int(ncid, BAD_VARID, start,
- + edge, stride,
- + imap, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 2
- err = nf_put_varm_int(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_varm_int(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_varm_int(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) then
- C do 9, j = 1, var_rank(i)
- C index(j) = index(j) +
- C + (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C9 continue
- C end if
- C*/
- if (var_rank(i) .gt. 0) then
- imap(1) = 1
- do 10, j = 2, var_rank(i)
- imap(j) = imap(j-1) * count(j-1)
- 10 continue
- end if
- allInExtRange = .true.
- do 11 j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 12, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 12 continue
- value(j) = hash_int(var_type(i),
- + var_rank(i),
- + index2, NFT_INT)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_INT)
- 11 continue
- err = nf_put_varm_int(ncid,i,index,count,
- + stride,imap,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_int(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_varm_real()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- integer imap(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- real value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_REAL .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- imap(j) = 1
- 2 continue
- err = nf_put_varm_real(BAD_ID, i, start,
- + edge, stride, imap,
- + value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_varm_real(ncid, BAD_VARID, start,
- + edge, stride,
- + imap, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 2
- err = nf_put_varm_real(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_varm_real(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_varm_real(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) then
- C do 9, j = 1, var_rank(i)
- C index(j) = index(j) +
- C + (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C9 continue
- C end if
- C*/
- if (var_rank(i) .gt. 0) then
- imap(1) = 1
- do 10, j = 2, var_rank(i)
- imap(j) = imap(j-1) * count(j-1)
- 10 continue
- end if
- allInExtRange = .true.
- do 11 j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 12, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 12 continue
- value(j) = hash_real(var_type(i),
- + var_rank(i),
- + index2, NFT_REAL)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_REAL)
- 11 continue
- err = nf_put_varm_real(ncid,i,index,count,
- + stride,imap,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_real(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_varm_double()
- implicit none
- #include "tests.inc"
- integer ncid
- integer d
- integer i
- integer j
- integer k
- integer m
- integer err
- integer nels
- integer nslabs
- integer nstarts !/* number of different starts */
- integer start(MAX_RANK)
- integer edge(MAX_RANK)
- integer index(MAX_RANK)
- integer index2(MAX_RANK)
- integer mid(MAX_RANK)
- integer count(MAX_RANK)
- integer sstride(MAX_RANK)
- integer stride(MAX_RANK)
- integer imap(MAX_RANK)
- logical canConvert !/* Both text or both numeric */
- logical allInExtRange !/* all values within external range? */
- doubleprecision value(MAX_NELS)
- doubleprecision val
- integer udshift
- err = nf_create(scratch, NF_CLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- err = nf_enddef(ncid)
- if (err .ne. 0)
- + call errore('nf_enddef: ', err)
- do 1, i = 1, NVARS
- canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
- + (NFT_DOUBLE .eq. NFT_TEXT)
- if (.not.(var_rank(i) .le. MAX_RANK))
- + stop 'assert(var_rank(i) .le. MAX_RANK)'
- if (.not.(var_nels(i) .le. MAX_NELS))
- + stop 'assert(var_nels(i) .le. MAX_NELS)'
- do 2, j = 1, var_rank(i)
- start(j) = 1
- edge(j) = 1
- stride(j) = 1
- imap(j) = 1
- 2 continue
- err = nf_put_varm_double(BAD_ID, i, start,
- + edge, stride, imap,
- + value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_varm_double(ncid, BAD_VARID, start,
- + edge, stride,
- + imap, value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, j = 1, var_rank(i)
- if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
- start(j) = var_shape(j,i) + 2
- err = nf_put_varm_double(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EINVALCOORDS)
- + call errore('bad start: ', err)
- endif
- start(j) = 1
- edge(j) = var_shape(j,i) + 1
- err = nf_put_varm_double(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_EEDGE)
- + call errore('bad edge: ', err)
- endif
- edge(j) = 1
- stride(j) = 0
- err = nf_put_varm_double(ncid, i, start,
- + edge, stride,
- + imap, value)
- if (.not. canConvert) then
- if (err .ne. NF_ECHAR)
- + call errore('conversion: ', err)
- else
- if (err .ne. NF_ESTRIDE)
- + call errore('bad stride: ', err)
- endif
- stride(j) = 1
- end if
- 3 continue
- !/* Choose a random point dividing each dim into 2 parts */
- !/* Put 2^rank (nslabs) slabs so defined */
- nslabs = 1
- do 4, j = 1, var_rank(i)
- mid(j) = roll( var_shape(j,i) )
- nslabs = nslabs * 2
- 4 continue
- !/* bits of k determine whether to put lower or upper part of dim */
- !/* choose random stride from 1 to edge */
- do 5, k = 1, nslabs
- nstarts = 1
- do 6, j = 1, var_rank(i)
- if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
- start(j) = 1
- edge(j) = mid(j)
- else
- start(j) = 1 + mid(j)
- edge(j) = var_shape(j,i) - mid(j)
- end if
- if (edge(j) .gt. 0) then
- stride(j) = 1+roll(edge(j))
- else
- stride(j) = 1
- end if
- sstride(j) = stride(j)
- nstarts = nstarts * stride(j)
- 6 continue
- do 7, m = 1, nstarts
- err = index2indexes(m, var_rank(i), sstride, index)
- if (err .ne. 0)
- + call error('error in index2indexes')
- nels = 1
- do 8, j = 1, var_rank(i)
- count(j) = 1 + (edge(j) - index(j)) / stride(j)
- nels = nels * count(j)
- index(j) = index(j) + start(j) - 1
- 8 continue
- !/* Random choice of forward or backward */
- C/* TODO
- C if ( roll(2) ) then
- C do 9, j = 1, var_rank(i)
- C index(j) = index(j) +
- C + (count(j) - 1) * stride(j)
- C stride(j) = -stride(j)
- C9 continue
- C end if
- C*/
- if (var_rank(i) .gt. 0) then
- imap(1) = 1
- do 10, j = 2, var_rank(i)
- imap(j) = imap(j-1) * count(j-1)
- 10 continue
- end if
- allInExtRange = .true.
- do 11 j = 1, nels
- err = index2indexes(j, var_rank(i), count,
- + index2)
- if (err .ne. 0)
- + call error('error in index2indexes')
- do 12, d = 1, var_rank(i)
- index2(d) = index(d) +
- + (index2(d)-1) * stride(d)
- 12 continue
- value(j) = hash_double(var_type(i),
- + var_rank(i),
- + index2, NFT_DOUBLE)
- val = value(j)
- allInExtRange = allInExtRange .and.
- + inRange3(val, var_type(i),
- + NFT_DOUBLE)
- 11 continue
- err = nf_put_varm_double(ncid,i,index,count,
- + stride,imap,
- + value)
- if (canConvert) then
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- else
- if (nels .gt. 0 .and. err .ne. NF_ECHAR)
- + call errore('wrong type: ', err)
- end if
- 7 continue
- 5 continue
- 1 continue
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- call check_vars_double(scratch)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_att_text()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer err
- character value(MAX_NELS)
- err = nf_create(scratch, NF_NOCLOBBER, ncid)
- if (err .ne. 0) then
- call errore('NF_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- if (ATT_TYPE(j,i) .eq. NF_CHAR) then
- if (.not.(ATT_LEN(j,i) .le. MAX_NELS))
- + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
- err = nf_put_att_text(BAD_ID, i,
- + ATT_NAME(j,i), ATT_LEN(j,i), value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_att_text(ncid, BAD_VARID,
- + ATT_NAME(j,i),
- + ATT_LEN(j,i), value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- do 3, k = 1, ATT_LEN(j,i)
- value(k) = char(int(hash(ATT_TYPE(j,i), -1, k)))
- 3 continue
- err = nf_put_att_text(ncid, i, ATT_NAME(j,i),
- + ATT_LEN(j,i), value)
- if (err .ne. 0)
- + call error(NF_strerror(err))
- end if
- 2 continue
- 1 continue
- call check_atts_text(ncid)
- err = NF_close(ncid)
- if (err .ne. 0)
- + call errore('NF_close: ', err)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #ifdef NF_INT1_T
- subroutine test_nf_put_att_int1()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer ndx(1)
- integer err
- NF_INT1_T value(MAX_NELS)
- logical allInExtRange !/* all values within external range? */
- doubleprecision val
- err = nf_create(scratch, NF_NOCLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
- if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
- + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
- err = nf_put_att_int1(BAD_ID, i,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i),
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_att_int1(ncid, BAD_VARID,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i), value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- err = nf_put_att_int1(ncid, i,
- + ATT_NAME(j,i), BAD_TYPE,
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADTYPE)
- + call errore('bad type: ', err)
- allInExtRange = .true.
- do 3, k = 1, ATT_LEN(j,i)
- ndx(1) = k
- value(k) = hash_int1(ATT_TYPE(j,i), -1, ndx,
- + NFT_INT1)
- val = value(k)
- allInExtRange = allInExtRange .and.
- + inRange3(val, ATT_TYPE(j,i),
- + NFT_INT1)
- 3 continue
- err = nf_put_att_int1(ncid, i, ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i),
- + value)
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- end if
- 2 continue
- 1 continue
- call check_atts_int1(ncid)
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #endif
- #ifdef NF_INT2_T
- subroutine test_nf_put_att_int2()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer ndx(1)
- integer err
- NF_INT2_T value(MAX_NELS)
- logical allInExtRange !/* all values within external range? */
- doubleprecision val
- err = nf_create(scratch, NF_NOCLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
- if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
- + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
- err = nf_put_att_int2(BAD_ID, i,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i),
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_att_int2(ncid, BAD_VARID,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i), value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- err = nf_put_att_int2(ncid, i,
- + ATT_NAME(j,i), BAD_TYPE,
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADTYPE)
- + call errore('bad type: ', err)
- allInExtRange = .true.
- do 3, k = 1, ATT_LEN(j,i)
- ndx(1) = k
- value(k) = hash_int2(ATT_TYPE(j,i), -1, ndx,
- + NFT_INT2)
- val = value(k)
- allInExtRange = allInExtRange .and.
- + inRange3(val, ATT_TYPE(j,i),
- + NFT_INT2)
- 3 continue
- err = nf_put_att_int2(ncid, i, ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i),
- + value)
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- end if
- 2 continue
- 1 continue
- call check_atts_int2(ncid)
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- #endif
- subroutine test_nf_put_att_int()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer ndx(1)
- integer err
- integer value(MAX_NELS)
- logical allInExtRange !/* all values within external range? */
- doubleprecision val
- err = nf_create(scratch, NF_NOCLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
- if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
- + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
- err = nf_put_att_int(BAD_ID, i,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i),
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_att_int(ncid, BAD_VARID,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i), value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- err = nf_put_att_int(ncid, i,
- + ATT_NAME(j,i), BAD_TYPE,
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADTYPE)
- + call errore('bad type: ', err)
- allInExtRange = .true.
- do 3, k = 1, ATT_LEN(j,i)
- ndx(1) = k
- value(k) = hash_int(ATT_TYPE(j,i), -1, ndx,
- + NFT_INT)
- val = value(k)
- allInExtRange = allInExtRange .and.
- + inRange3(val, ATT_TYPE(j,i),
- + NFT_INT)
- 3 continue
- err = nf_put_att_int(ncid, i, ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i),
- + value)
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- end if
- 2 continue
- 1 continue
- call check_atts_int(ncid)
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_att_real()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer ndx(1)
- integer err
- real value(MAX_NELS)
- logical allInExtRange !/* all values within external range? */
- doubleprecision val
- err = nf_create(scratch, NF_NOCLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
- if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
- + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
- err = nf_put_att_real(BAD_ID, i,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i),
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_att_real(ncid, BAD_VARID,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i), value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- err = nf_put_att_real(ncid, i,
- + ATT_NAME(j,i), BAD_TYPE,
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADTYPE)
- + call errore('bad type: ', err)
- allInExtRange = .true.
- do 3, k = 1, ATT_LEN(j,i)
- ndx(1) = k
- value(k) = hash_real(ATT_TYPE(j,i), -1, ndx,
- + NFT_REAL)
- val = value(k)
- allInExtRange = allInExtRange .and.
- + inRange3(val, ATT_TYPE(j,i),
- + NFT_REAL)
- 3 continue
- err = nf_put_att_real(ncid, i, ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i),
- + value)
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- end if
- 2 continue
- 1 continue
- call check_atts_real(ncid)
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end
- subroutine test_nf_put_att_double()
- implicit none
- #include "tests.inc"
- integer ncid
- integer i
- integer j
- integer k
- integer ndx(1)
- integer err
- doubleprecision value(MAX_NELS)
- logical allInExtRange !/* all values within external range? */
- doubleprecision val
- err = nf_create(scratch, NF_NOCLOBBER, ncid)
- if (err .ne. 0) then
- call errore('nf_create: ', err)
- return
- end if
- call def_dims(ncid)
- call def_vars(ncid)
- do 1, i = 0, NVARS
- do 2, j = 1, NATTS(i)
- if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
- if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
- + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
- err = nf_put_att_double(BAD_ID, i,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i),
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADID)
- + call errore('bad ncid: ', err)
- err = nf_put_att_double(ncid, BAD_VARID,
- + ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i), value)
- if (err .ne. NF_ENOTVAR)
- + call errore('bad var id: ', err)
- err = nf_put_att_double(ncid, i,
- + ATT_NAME(j,i), BAD_TYPE,
- + ATT_LEN(j,i), value)
- if (err .ne. NF_EBADTYPE)
- + call errore('bad type: ', err)
- allInExtRange = .true.
- do 3, k = 1, ATT_LEN(j,i)
- ndx(1) = k
- value(k) = hash_double(ATT_TYPE(j,i), -1, ndx,
- + NFT_DOUBLE)
- val = value(k)
- allInExtRange = allInExtRange .and.
- + inRange3(val, ATT_TYPE(j,i),
- + NFT_DOUBLE)
- 3 continue
- err = nf_put_att_double(ncid, i, ATT_NAME(j,i),
- + ATT_TYPE(j,i), ATT_LEN(j,i),
- + value)
- if (allInExtRange) then
- if (err .ne. 0)
- + call error(nf_strerror(err))
- else
- if (err .ne. NF_ERANGE)
- + call errore('range error: ', err)
- end if
- end if
- 2 continue
- 1 continue
- call check_atts_double(ncid)
- err = nf_close(ncid)
- if (err .ne. 0)
- + call errore('nf_close: ', err)
- err = nf_delete(scratch)
- if (err .ne. 0)
- + call errorc('delete of scratch file failed:',
- + scratch)
- end