divert(-1) dnl This is m4 source. dnl Process using m4 to produce FORTRAN language file. changequote([,]) dnl undefine([index])dnl dnl Macros dnl Upcase(str) dnl define([Upcase],[dnl translit($1, abcdefghijklmnopqrstuvwxyz, ABCDEFGHIJKLMNOPQRSTUVWXYZ)]) dnl NFT_ITYPE(type) dnl define([NFT_ITYPE], [NFT_[]Upcase($1)]) dnl ARITH(itype, value) dnl define([ARITH], [ifelse($1, text, ichar($2), $2)]) dnl DATATYPE(funf_suffix) dnl define([DATATYPE], [dnl ifelse($1, text, character, ifelse($1, int1, NF_INT1_T, ifelse($1, int2, NF_INT2_T, ifelse($1, int, integer, ifelse($1, real, real, ifelse($1, double, doubleprecision)[]dnl )[]dnl )[]dnl )[]dnl )[]dnl )[]dnl ]) dnl MAKE_ARITH(funf_suffix, var) dnl define([MAKE_ARITH], [dnl ifelse($1, text, ichar($2), $2)[]dnl ]) dnl MAKE_DOUBLE(funf_suffix, var) dnl define([MAKE_DOUBLE], [dnl ifelse($1, text, dble(ichar($2)), dble($2))[]dnl ]) dnl MAKE_TYPE(funf_suffix, var) dnl define([MAKE_TYPE], [dnl ifelse($1, text, char(int($2)), $2)[]dnl ]) dnl HASH(TYPE) dnl define([HASH], [dnl C C ensure hash value within range for internal TYPE C function hash_$1(type, rank, index, itype) implicit none #include "tests.inc" integer type integer rank integer index(1) integer itype doubleprecision minimum doubleprecision maximum minimum = internal_min(itype) maximum = internal_max(itype) hash_$1 = max(minimum, min(maximum, hash4( type, rank, + index, itype))) end ])dnl dnl CHECK_VARS(TYPE) dnl define([CHECK_VARS],dnl [dnl C C check all vars in file which are (text/numeric) compatible with TYPE C subroutine check_vars_$1(filename) implicit none #include "tests.inc" character*(*) filename integer ncid !/* netCDF id */ integer index(MAX_RANK) integer err !/* status */ integer d integer i integer j DATATYPE($1) 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_ITYPE($1) .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_ITYPE($1)) err = nf_get_var1_$1(ncid, i, index, value) if (inRange3(expect,datatype,NFT_ITYPE($1))) then if (in_internal_range(NFT_ITYPE($1), + expect)) then if (err .ne. 0) then call errore('nf_get_var1_$1: ', err) else val = MAKE_ARITH($1,value) if (.not.equal( + val, + expect,var_type(i), + NFT_ITYPE($1))) 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 ])dnl dnl CHECK_ATTS(TYPE) numeric only dnl define([CHECK_ATTS],dnl [dnl 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_$1(ncid) implicit none #include "tests.inc" integer ncid integer err !/* status */ integer i integer j integer k integer ndx(1) DATATYPE($1) 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_ITYPE($1) .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_ITYPE($1)) if (inRange3(expect(k), datatype, + NFT_ITYPE($1))) then nInExtRange = nInExtRange + 1 if (in_internal_range(NFT_ITYPE($1), + expect(k))) + nInIntRange = nInIntRange + 1 end if 4 continue err = nf_get_att_$1(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_ITYPE($1)) + .and. + in_internal_range(NFT_ITYPE($1), + expect(k))) then val = MAKE_ARITH($1,value(k)) if (.not.equal( + val, + expect(k),datatype, + NFT_ITYPE($1))) 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 ])dnl dnl TEST_NF_PUT_VAR1(TYPE) dnl define([TEST_NF_PUT_VAR1],dnl [dnl subroutine test_nf_put_var1_$1() implicit none #include "tests.inc" integer ncid integer i integer j integer err integer index(MAX_RANK) logical canConvert !/* Both text or both numeric */ DATATYPE($1) value doubleprecision val value = MAKE_TYPE($1, 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_ITYPE($1) .eq. NFT_TEXT) do 2, j = 1, var_rank(i) index(j) = 1 2 continue err = nf_put_var1_$1(BAD_ID, i, index, value) if (err .ne. NF_EBADID) + call errore('bad ncid: ', err) err = nf_put_var1_$1(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_$1(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 = MAKE_TYPE($1, hash_$1(var_type(i),var_rank(i), + index, NFT_ITYPE($1))) err = nf_put_var1_$1(ncid, i, index, value) if (canConvert) then val = ARITH($1, value) if (inRange3(val, var_type(i), NFT_ITYPE($1))) 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_$1(scratch) err = nf_delete(scratch) if (err .ne. 0) + call errorc('delete of scratch file failed: ', + scratch) end ])dnl dnl TEST_NF_PUT_VAR(TYPE) dnl define([TEST_NF_PUT_VAR],dnl [dnl subroutine test_nf_put_var_$1() implicit none #include "tests.inc" integer ncid integer vid integer i integer j integer err integer nels integer index(MAX_RANK) logical canConvert !/* Both text or both numeric */ logical allInExtRange !/* All values within external range?*/ DATATYPE($1) 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_ITYPE($1) .eq. NFT_TEXT) err = nf_put_var_$1(BAD_ID, i, value) if (err .ne. NF_EBADID) + call errore('bad ncid: ', err) err = nf_put_var_$1(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) = MAKE_TYPE($1, hash_$1(var_type(i), + var_rank(i), + index, NFT_ITYPE($1))) val = ARITH($1, value(j)) allInExtRange = allInExtRange .and. + inRange3(val, var_type(i), NFT_ITYPE($1)) 4 continue err = nf_put_var_$1(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_ITYPE($1) .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_$1(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) = MAKE_TYPE($1, hash_$1(var_type(i), + var_rank(i), + index, NFT_ITYPE($1))) val = ARITH($1, value(j)) allInExtRange = allInExtRange .and. + inRange3(val, var_type(i), NFT_ITYPE($1)) 7 continue err = nf_put_var_$1(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_$1(scratch) err = nf_delete(scratch) if (err .ne. 0) + call errorc('delete of scratch file failed: ', + scratch) end ])dnl dnl TEST_NF_PUT_VARA(TYPE) dnl define([TEST_NF_PUT_VARA],dnl [dnl subroutine test_nf_put_vara_$1() implicit none #include "tests.inc" integer ncid integer i integer j integer k integer d integer err integer nslabs integer nels integer start(MAX_RANK) integer edge(MAX_RANK) integer mid(MAX_RANK) integer index(MAX_RANK) logical canConvert !/* Both text or both numeric */ logical allInExtRange !/* all values within external range? */ DATATYPE($1) 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_ITYPE($1) .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_$1(BAD_ID, i, start, + edge, value) if (err .ne. NF_EBADID) + call errore('bad ncid: ', err) err = nf_put_vara_$1(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_$1(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_$1(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_$1(BAD_ID, i, start, + edge, value) if (err .ne. NF_EBADID) + call errore('bad ncid: ', err) err = nf_put_vara_$1(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_$1(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_$1(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)= MAKE_TYPE($1, hash_$1(var_type(i), + var_rank(i), index, + NFT_ITYPE($1))) val = ARITH($1, value(j)) allInExtRange = allInExtRange .and. + inRange3(val, var_type(i), NFT_ITYPE($1)) 7 continue err = nf_put_vara_$1(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_$1(scratch) err = nf_delete(scratch) if (err .ne. 0) + call errorc('delete of scratch file failed: ', + scratch) end ])dnl dnl TEST_NF_PUT_VARS(TYPE) dnl define([TEST_NF_PUT_VARS],dnl [dnl subroutine test_nf_put_vars_$1() implicit none #include "tests.inc" integer ncid integer d integer i integer j integer k integer m integer err integer nels integer nslabs integer nstarts !/* number of different starts */ integer start(MAX_RANK) integer edge(MAX_RANK) integer index(MAX_RANK) integer index2(MAX_RANK) integer mid(MAX_RANK) integer count(MAX_RANK) integer sstride(MAX_RANK) integer stride(MAX_RANK) logical canConvert !/* Both text or both numeric */ logical allInExtRange !/* all values within external range? */ DATATYPE($1) 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_ITYPE($1) .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_$1(BAD_ID, i, start, + edge, stride, value) if (err .ne. NF_EBADID) + call errore('bad ncid: ', err) err = nf_put_vars_$1(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_$1(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_$1(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_$1(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) = MAKE_TYPE($1, hash_$1(var_type(i), + var_rank(i), + index2, NFT_ITYPE($1))) val = ARITH($1, value(j)) allInExtRange = allInExtRange .and. + inRange3(val, var_type(i), + NFT_ITYPE($1)) 9 continue err = nf_put_vars_$1(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_$1(scratch) err = nf_delete(scratch) if (err .ne. 0) + call errorc('delete of scratch file failed:', + scratch) end ])dnl dnl TEST_NF_PUT_VARM(TYPE) dnl define([TEST_NF_PUT_VARM],dnl [dnl subroutine test_nf_put_varm_$1() implicit none #include "tests.inc" integer ncid integer d integer i integer j integer k integer m integer err integer nels integer nslabs integer nstarts !/* number of different starts */ integer start(MAX_RANK) integer edge(MAX_RANK) integer index(MAX_RANK) integer index2(MAX_RANK) integer mid(MAX_RANK) integer count(MAX_RANK) integer sstride(MAX_RANK) integer stride(MAX_RANK) integer imap(MAX_RANK) logical canConvert !/* Both text or both numeric */ logical allInExtRange !/* all values within external range? */ DATATYPE($1) 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_ITYPE($1) .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_$1(BAD_ID, i, start, + edge, stride, imap, + value) if (err .ne. NF_EBADID) + call errore('bad ncid: ', err) err = nf_put_varm_$1(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_$1(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_$1(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_$1(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) = MAKE_TYPE($1, hash_$1(var_type(i), + var_rank(i), + index2, NFT_ITYPE($1))) val = ARITH($1, value(j)) allInExtRange = allInExtRange .and. + inRange3(val, var_type(i), + NFT_ITYPE($1)) 11 continue err = nf_put_varm_$1(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_$1(scratch) err = nf_delete(scratch) if (err .ne. 0) + call errorc('delete of scratch file failed:', + scratch) end ])dnl dnl TEST_NF_PUT_ATT(TYPE) numeric only dnl define([TEST_NF_PUT_ATT],dnl [dnl subroutine test_nf_put_att_$1() implicit none #include "tests.inc" integer ncid integer i integer j integer k integer ndx(1) integer err DATATYPE($1) 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_$1(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_$1(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_$1(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_$1(ATT_TYPE(j,i), -1, ndx, + NFT_ITYPE($1)) val = ARITH($1, value(k)) allInExtRange = allInExtRange .and. + inRange3(val, ATT_TYPE(j,i), + NFT_ITYPE($1)) 3 continue err = nf_put_att_$1(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_$1(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 ])dnl divert(0)dnl dnl If you see this line, you can ignore the next one. 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******************************************************************** HASH(text) #ifdef NF_INT1_T HASH(int1) #endif #ifdef NF_INT2_T HASH(int2) #endif HASH(int) HASH(real) HASH(double) CHECK_VARS(text) #ifdef NF_INT1_T CHECK_VARS(int1) #endif #ifdef NF_INT2_T CHECK_VARS(int2) #endif CHECK_VARS(int) CHECK_VARS(real) CHECK_VARS(double) CHECK_ATTS(text) #ifdef NF_INT1_T CHECK_ATTS(int1) #endif #ifdef NF_INT2_T CHECK_ATTS(int2) #endif CHECK_ATTS(int) CHECK_ATTS(real) CHECK_ATTS(double) TEST_NF_PUT_VAR1(text) #ifdef NF_INT1_T TEST_NF_PUT_VAR1(int1) #endif #ifdef NF_INT2_T TEST_NF_PUT_VAR1(int2) #endif TEST_NF_PUT_VAR1(int) TEST_NF_PUT_VAR1(real) TEST_NF_PUT_VAR1(double) TEST_NF_PUT_VAR(text) #ifdef NF_INT1_T TEST_NF_PUT_VAR(int1) #endif #ifdef NF_INT2_T TEST_NF_PUT_VAR(int2) #endif TEST_NF_PUT_VAR(int) TEST_NF_PUT_VAR(real) TEST_NF_PUT_VAR(double) TEST_NF_PUT_VARA(text) #ifdef NF_INT1_T TEST_NF_PUT_VARA(int1) #endif #ifdef NF_INT2_T TEST_NF_PUT_VARA(int2) #endif TEST_NF_PUT_VARA(int) TEST_NF_PUT_VARA(real) TEST_NF_PUT_VARA(double) TEST_NF_PUT_VARS(text) #ifdef NF_INT1_T TEST_NF_PUT_VARS(int1) #endif #ifdef NF_INT2_T TEST_NF_PUT_VARS(int2) #endif TEST_NF_PUT_VARS(int) TEST_NF_PUT_VARS(real) TEST_NF_PUT_VARS(double) TEST_NF_PUT_VARM(text) #ifdef NF_INT1_T TEST_NF_PUT_VARM(int1) #endif #ifdef NF_INT2_T TEST_NF_PUT_VARM(int2) #endif TEST_NF_PUT_VARM(int) TEST_NF_PUT_VARM(real) TEST_NF_PUT_VARM(double) subroutine test_nf_put_att_text() implicit none #include "tests.inc" integer ncid integer i integer j integer k integer err character value(MAX_NELS) err = nf_create(scratch, NF_NOCLOBBER, ncid) if (err .ne. 0) then call errore('NF_create: ', err) return end if call def_dims(ncid) call def_vars(ncid) do 1, i = 0, NVARS do 2, j = 1, NATTS(i) if (ATT_TYPE(j,i) .eq. NF_CHAR) then if (.not.(ATT_LEN(j,i) .le. MAX_NELS)) + stop 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 TEST_NF_PUT_ATT(int1) #endif #ifdef NF_INT2_T TEST_NF_PUT_ATT(int2) #endif TEST_NF_PUT_ATT(int) TEST_NF_PUT_ATT(real) TEST_NF_PUT_ATT(double)