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.16 2008/04/30 16:50:45 ed Exp $ C******************************************************************** C C ensure hash value within range for internal TYPE C function hash_text(type, rank, index, itype) use tests, ONLY: internal_min, internal_max, RK8, hash4 implicit none integer type integer rank integer index(1) integer itype doubleprecision minimum doubleprecision maximum real(RK8) hash_text 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) use tests, ONLY: internal_min, internal_max, RK8, hash4 implicit none integer type integer rank integer index(1) integer itype real(RK8) hash_int1 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) use tests, ONLY: internal_min, internal_max, RK8, hash4 implicit none integer type integer rank integer index(1) integer itype doubleprecision minimum doubleprecision maximum real(RK8) hash_int2 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) use tests, ONLY: internal_min, internal_max, RK8, hash4 implicit none integer type integer rank integer index(1) integer itype real(RK8) hash_int 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) use tests, ONLY: internal_min, internal_max, RK8, hash4 implicit none integer type integer rank integer index(1) integer itype real(RK8) hash_real 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) use tests, ONLY: internal_min, internal_max, RK8, hash4 implicit none integer type integer rank integer index(1) integer itype real(RK8) hash_double 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) use tests, NDIMSG=>NDIMS, NGATTSG=>NGATTS implicit none 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) use tests, NDIMSG=>NDIMS, NGATTSG=>NGATTS implicit none 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) use tests, NDIMSG=>NDIMS, NGATTSG=>NGATTS implicit none 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) use tests, NDIMSG=>NDIMS, NGATTSG=>NGATTS implicit none 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) use tests, NDIMSG=>NDIMS, NGATTSG=>NGATTS use tests implicit none 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) use tests, NDIMSG=>NDIMS, NGATTSG=>NGATTS implicit none 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) use tests implicit none 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 2 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) use tests implicit none 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 2 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) use tests implicit none 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 2 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) use tests implicit none 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 2 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) use tests implicit none 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 2 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) use tests implicit none 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 2 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() use tests implicit none 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() use tests implicit none 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() use tests implicit none 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() use tests implicit none 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() use tests implicit none 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() use tests implicit none 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() use tests implicit none 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 2 if (var_nels(i) .gt. MAX_NELS) + stop 2 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() use tests implicit none 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 2 if (var_nels(i) .gt. MAX_NELS) + stop 2 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() use tests implicit none 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 2 if (var_nels(i) .gt. MAX_NELS) + stop 2 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() use tests implicit none 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 2 if (var_nels(i) .gt. MAX_NELS) + stop 2 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() use tests implicit none 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 2 if (var_nels(i) .gt. MAX_NELS) + stop 2 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() use tests implicit none 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 2 if (var_nels(i) .gt. MAX_NELS) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 if (.not.(var_nels(i) .le. MAX_NELS)) + stop 2 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() use tests implicit none 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 2 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() use tests implicit none 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 2 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() use tests implicit none 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 2 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() use tests implicit none 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 2 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() use tests implicit none 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 2 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() use tests implicit none 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 2 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