1divert(-1) 2 3dnl This is m4 source. 4dnl Process using m4 to produce FORTRAN language file. 5 6changequote([,]) dnl 7 8undefine([index])dnl 9 10dnl Macros 11 12dnl Upcase(str) 13dnl 14define([Upcase],[dnl 15translit($1, abcdefghijklmnopqrstuvwxyz, ABCDEFGHIJKLMNOPQRSTUVWXYZ)]) 16 17dnl NFT_ITYPE(type) 18dnl 19define([NFT_ITYPE], [NFT_[]Upcase($1)]) 20 21dnl ARITH(itype, value) 22dnl 23define([ARITH], [ifelse($1, text, ichar($2), $2)]) 24 25dnl DATATYPE(funf_suffix) 26dnl 27define([DATATYPE], [dnl 28ifelse($1, text, character, 29ifelse($1, int1, NF_INT1_T, 30ifelse($1, int2, NF_INT2_T, 31ifelse($1, int, integer, 32ifelse($1, real, real, 33ifelse($1, double, doubleprecision)[]dnl 34)[]dnl 35)[]dnl 36)[]dnl 37)[]dnl 38)[]dnl 39]) 40 41dnl MAKE_ARITH(funf_suffix, var) 42dnl 43define([MAKE_ARITH], [dnl 44ifelse($1, text, ichar($2), $2)[]dnl 45]) 46 47dnl MAKE_DOUBLE(funf_suffix, var) 48dnl 49define([MAKE_DOUBLE], [dnl 50ifelse($1, text, dble(ichar($2)), dble($2))[]dnl 51]) 52 53dnl MAKE_TYPE(funf_suffix, var) 54dnl 55define([MAKE_TYPE], [dnl 56ifelse($1, text, char(int($2)), $2)[]dnl 57]) 58 59dnl HASH(TYPE) 60dnl 61define([HASH], 62[dnl 63C 64C ensure hash value within range for internal TYPE 65C 66 function hash_$1(type, rank, index, itype) 67 implicit none 68#include "tests.inc" 69 integer type 70 integer rank 71 integer index(1) 72 integer itype 73 doubleprecision minimum 74 doubleprecision maximum 75 76 minimum = internal_min(itype) 77 maximum = internal_max(itype) 78 79 hash_$1 = max(minimum, min(maximum, hash4( type, rank, 80 + index, itype))) 81 end 82])dnl 83 84 85dnl CHECK_VARS(TYPE) 86dnl 87define([CHECK_VARS],dnl 88[dnl 89C 90C check all vars in file which are (text/numeric) compatible with TYPE 91C 92 subroutine check_vars_$1(filename) 93 implicit none 94#include "tests.inc" 95 character*(*) filename 96 integer ncid !/* netCDF id */ 97 integer index(MAX_RANK) 98 integer err !/* status */ 99 integer d 100 integer i 101 integer j 102 DATATYPE($1) value 103 integer datatype 104 integer ndims 105 integer dimids(MAX_RANK) 106 integer ngatts 107 doubleprecision expect 108 character*(NF_MAX_NAME) name 109 integer length 110 logical canConvert !/* Both text or both numeric */ 111 integer nok !/* count of valid comparisons */ 112 doubleprecision val 113 114 nok = 0 115 116 err = nf_open(filename, NF_NOWRITE, ncid) 117 if (err .ne. 0) 118 + call errore('nf_open: ', err) 119 120 do 1, i = 1, NVARS 121 canConvert = (var_type(i) .eq. NF_CHAR) .eqv. 122 + (NFT_ITYPE($1) .eq. NFT_TEXT) 123 if (canConvert) then 124 err = nf_inq_var(ncid, i, name, datatype, ndims, dimids, 125 + ngatts) 126 if (err .ne. 0) 127 + call errore('nf_inq_var: ', err) 128 if (name .ne. var_name(i)) 129 + call error('Unexpected var_name') 130 if (datatype .ne. var_type(i)) 131 + call error('Unexpected type') 132 if (ndims .ne. var_rank(i)) 133 + call error('Unexpected rank') 134 do 2, j = 1, ndims 135 err = nf_inq_dim(ncid, dimids(j), name, length) 136 if (err .ne. 0) 137 + call errore('nf_inq_dim: ', err) 138 if (length .ne. var_shape(j,i)) 139 + call error('Unexpected shape') 1402 continue 141 do 3, j = 1, var_nels(i) 142 err = index2indexes(j, var_rank(i), var_shape(1,i), 143 + index) 144 if (err .ne. 0) 145 + call error('error in index2indexes()') 146 expect = hash4( var_type(i), var_rank(i), index, 147 + NFT_ITYPE($1)) 148 err = nf_get_var1_$1(ncid, i, index, value) 149 if (inRange3(expect,datatype,NFT_ITYPE($1))) then 150 if (in_internal_range(NFT_ITYPE($1), 151 + expect)) then 152 if (err .ne. 0) then 153 call errore('nf_get_var1_$1: ', err) 154 else 155 val = MAKE_ARITH($1,value) 156 if (.not.equal( 157 + val, 158 + expect,var_type(i), 159 + NFT_ITYPE($1))) then 160 call error( 161 + 'Var value read not that expected') 162 if (verbose) then 163 call error(' ') 164 call errori('varid: %d', i) 165 call errorc('var_name: ', 166 + var_name(i)) 167 call error('index:') 168 do 4, d = 1, var_rank(i) 169 call errori(' ', index(d)) 1704 continue 171 call errord('expect: ', expect) 172 call errord('got: ', val) 173 end if 174 else 175 nok = nok + 1 176 end if 177 end if 178 end if 179 end if 1803 continue 181 end if 1821 continue 183 err = nf_close (ncid) 184 if (err .ne. 0) 185 + call errore('nf_close: ', err) 186 call print_nok(nok) 187 end 188])dnl 189 190 191dnl CHECK_ATTS(TYPE) numeric only 192dnl 193define([CHECK_ATTS],dnl 194[dnl 195C/* 196C * check all attributes in file which are (text/numeric) compatible with TYPE 197C * ignore any attributes containing values outside range of TYPE 198C */ 199 subroutine check_atts_$1(ncid) 200 implicit none 201#include "tests.inc" 202 integer ncid 203 integer err !/* status */ 204 integer i 205 integer j 206 integer k 207 integer ndx(1) 208 DATATYPE($1) value(MAX_NELS) 209 integer datatype 210 doubleprecision expect(MAX_NELS) 211 integer length 212 integer nInExtRange !/* number values within external range */ 213 integer nInIntRange !/* number values within internal range */ 214 logical canConvert !/* Both text or both numeric */ 215 integer nok !/* count of valid comparisons */ 216 doubleprecision val 217 218 nok = 0 219 220 do 1, i = 0, NVARS 221 do 2, j = 1, NATTS(i) 222 canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv. 223 + (NFT_ITYPE($1) .eq. NFT_TEXT) 224 if (canConvert) then 225 err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype, 226 + length) 227 if (err .ne. 0) 228 + call errore('nf_inq_att: ', err) 229 if (datatype .ne. ATT_TYPE(j,i)) 230 + call error('nf_inq_att: unexpected type') 231 if (length .ne. ATT_LEN(j,i)) 232 + call error('nf_inq_att: unexpected length') 233 if (.not.(length .le. MAX_NELS)) 234 + stop 2 235 nInIntRange = 0 236 nInExtRange = 0 237 do 4, k = 1, length 238 ndx(1) = k 239 expect(k) = hash4( datatype, -1, ndx, 240 + NFT_ITYPE($1)) 241 if (inRange3(expect(k), datatype, 242 + NFT_ITYPE($1))) then 243 nInExtRange = nInExtRange + 1 244 if (in_internal_range(NFT_ITYPE($1), 245 + expect(k))) 246 + nInIntRange = nInIntRange + 1 247 end if 2484 continue 249 err = nf_get_att_$1(ncid, i, 250 + ATT_NAME(j,i), value) 251 if (nInExtRange .eq. length .and. 252 + nInIntRange .eq. length) then 253 if (err .ne. 0) 254 + call error(nf_strerror(err)) 255 else 256 if (err .ne. 0 .and. err .ne. NF_ERANGE) 257 + call errore('OK or Range error: ', err) 258 end if 259 do 3, k = 1, length 260 if (inRange3(expect(k),datatype,NFT_ITYPE($1)) 261 + .and. 262 + in_internal_range(NFT_ITYPE($1), 263 + expect(k))) then 264 val = MAKE_ARITH($1,value(k)) 265 if (.not.equal( 266 + val, 267 + expect(k),datatype, 268 + NFT_ITYPE($1))) then 269 call error( 270 + 'att. value read not that expected') 271 if (verbose) then 272 call error(' ') 273 call errori('varid: ', i) 274 call errorc('att_name: ', 275 + ATT_NAME(j,i)) 276 call errori('element number: ', k) 277 call errord('expect: ', expect(k)) 278 call errord('got: ', val) 279 end if 280 else 281 nok = nok + 1 282 end if 283 end if 2843 continue 285 end if 2862 continue 2871 continue 288 289 call print_nok(nok) 290 end 291])dnl 292 293 294dnl TEST_NF_PUT_VAR1(TYPE) 295dnl 296define([TEST_NF_PUT_VAR1],dnl 297[dnl 298 subroutine test_nf_put_var1_$1() 299 implicit none 300#include "tests.inc" 301 integer ncid 302 integer i 303 integer j 304 integer err 305 integer index(MAX_RANK) 306 logical canConvert !/* Both text or both numeric */ 307 DATATYPE($1) value 308 doubleprecision val 309 310 value = MAKE_TYPE($1, 5)!/* any value would do - only for error cases */ 311 312 err = nf_create(scratch, NF_CLOBBER, ncid) 313 if (err .ne. 0) then 314 call errore('nf_create: ', err) 315 return 316 end if 317 call def_dims(ncid) 318 call def_vars(ncid) 319 err = nf_enddef(ncid) 320 if (err .ne. 0) 321 + call errore('nf_enddef: ', err) 322 323 do 1, i = 1, NVARS 324 canConvert = (var_type(i) .eq. NF_CHAR) .eqv. 325 + (NFT_ITYPE($1) .eq. NFT_TEXT) 326 do 2, j = 1, var_rank(i) 327 index(j) = 1 3282 continue 329 err = nf_put_var1_$1(BAD_ID, i, index, value) 330 if (err .ne. NF_EBADID) 331 + call errore('bad ncid: ', err) 332 err = nf_put_var1_$1(ncid, BAD_VARID, 333 + index, value) 334 if (err .ne. NF_ENOTVAR) 335 + call errore('bad var id: ', err) 336 do 3, j = 1, var_rank(i) 337 if (var_dimid(j,i) .gt. 1) then !/* skip record dim */ 338 index(j) = var_shape(j,i) + 1 339 err = nf_put_var1_$1(ncid, i, 340 + index, value) 341 if (.not. canConvert) then 342 if (err .ne. NF_ECHAR) 343 + call errore('conversion: ', err) 344 else 345 if (err .ne. NF_EINVALCOORDS) 346 + call errore('bad index: ', err) 347 endif 348 index(j) = 0 349 end if 3503 continue 351 do 4, j = 1, var_nels(i) 352 err = index2indexes(j, var_rank(i), var_shape(1,i), 353 + index) 354 if (err .ne. 0) 355 + call error('error in index2indexes 1') 356 value = MAKE_TYPE($1, hash_$1(var_type(i),var_rank(i), 357 + index, NFT_ITYPE($1))) 358 err = nf_put_var1_$1(ncid, i, index, value) 359 if (canConvert) then 360 val = ARITH($1, value) 361 if (inRange3(val, var_type(i), NFT_ITYPE($1))) then 362 if (err .ne. 0) 363 + call error(nf_strerror(err)) 364 else 365 if (err .ne. NF_ERANGE) 366 + call errore('Range error: ', err) 367 end if 368 else 369 if (err .ne. NF_ECHAR) 370 + call errore('wrong type: ', err) 371 end if 3724 continue 3731 continue 374 375 err = nf_close(ncid) 376 if (err .ne. 0) 377 + call errore('nf_close: ', err) 378 379 call check_vars_$1(scratch) 380 381 err = nf_delete(scratch) 382 if (err .ne. 0) 383 + call errorc('delete of scratch file failed: ', 384 + scratch) 385 end 386])dnl 387 388 389dnl TEST_NF_PUT_VAR(TYPE) 390dnl 391define([TEST_NF_PUT_VAR],dnl 392[dnl 393 subroutine test_nf_put_var_$1() 394 implicit none 395#include "tests.inc" 396 integer ncid 397 integer vid 398 integer i 399 integer j 400 integer err 401 integer nels 402 integer index(MAX_RANK) 403 logical canConvert !/* Both text or both numeric */ 404 logical allInExtRange !/* All values within external range?*/ 405 DATATYPE($1) value(MAX_NELS) 406 doubleprecision val 407 408 err = nf_create(scratch, NF_CLOBBER, ncid) 409 if (err .ne. 0) then 410 call errore('nf_create: ', err) 411 return 412 end if 413 call def_dims(ncid) 414 call def_vars(ncid) 415 err = nf_enddef(ncid) 416 if (err .ne. 0) 417 + call errore('nf_enddef: ', err) 418 419 do 1, i = 1, NVARS 420 canConvert = (var_type(i) .eq. NF_CHAR) .eqv. 421 + (NFT_ITYPE($1) .eq. NFT_TEXT) 422 err = nf_put_var_$1(BAD_ID, i, value) 423 if (err .ne. NF_EBADID) 424 + call errore('bad ncid: ', err) 425 err = nf_put_var_$1(ncid, BAD_VARID, value) 426 if (err .ne. NF_ENOTVAR) 427 + call errore('bad var id: ', err) 428 nels = 1 429 do 3, j = 1, var_rank(i) 430 nels = nels * var_shape(j,i) 4313 continue 432 allInExtRange = .true. 433 do 4, j = 1, var_nels(i) 434 err = index2indexes(j, var_rank(i), var_shape(1,i), 435 + index) 436 if (err .ne. 0) 437 + call error('error in index2indexes 1') 438 value(j) = MAKE_TYPE($1, hash_$1(var_type(i), 439 + var_rank(i), 440 + index, NFT_ITYPE($1))) 441 val = ARITH($1, value(j)) 442 allInExtRange = allInExtRange .and. 443 + inRange3(val, var_type(i), NFT_ITYPE($1)) 4444 continue 445 err = nf_put_var_$1(ncid, i, value) 446 if (canConvert) then 447 if (allInExtRange) then 448 if (err .ne. 0) 449 + call error(nf_strerror(err)) 450 else 451 if (err .ne. NF_ERANGE .and. 452 + var_dimid(var_rank(i),i) .ne. RECDIM) 453 + call errore('Range error: ', err) 454 endif 455 else 456 if (err .ne. NF_ECHAR) 457 + call errore('wrong type: ', err) 458 endif 4591 continue 460 461C The preceeding has written nothing for record variables, now try 462C again with more than 0 records. 463 464C Write record number NRECS to force writing of preceding records. 465C Assumes variable cr is char vector with UNLIMITED dimension. 466 467 err = nf_inq_varid(ncid, "cr", vid) 468 if (err .ne. 0) 469 + call errore('nf_inq_varid: ', err) 470 index(1) = NRECS 471 err = nf_put_var1_text(ncid, vid, index, 'x') 472 if (err .ne. 0) 473 + call errore('nf_put_var1_text: ', err) 474 475 do 5 i = 1, NVARS 476C Only test record variables here 477 if (var_rank(i) .ge. 1 .and. 478 + var_dimid(var_rank(i),i) .eq. RECDIM) then 479 canConvert = (var_type(i) .eq. NF_CHAR) .eqv. 480 + (NFT_ITYPE($1) .eq. NFT_TEXT) 481 if (var_rank(i) .gt. MAX_RANK) 482 + stop 2 483 if (var_nels(i) .gt. MAX_NELS) 484 + stop 2 485 err = nf_put_var_$1(BAD_ID, i, value) 486 487 nels = 1 488 do 6 j = 1, var_rank(i) 489 nels = nels * var_shape(j,i) 4906 continue 491 allInExtRange = .true. 492 do 7, j = 1, nels 493 err = index2indexes(j, var_rank(i), var_shape(1,i), 494 + index) 495 if (err .ne. 0) 496 + call error('error in index2indexes()') 497 value(j) = MAKE_TYPE($1, hash_$1(var_type(i), 498 + var_rank(i), 499 + index, NFT_ITYPE($1))) 500 val = ARITH($1, value(j)) 501 allInExtRange = allInExtRange .and. 502 + inRange3(val, var_type(i), NFT_ITYPE($1)) 5037 continue 504 err = nf_put_var_$1(ncid, i, value) 505 if (canConvert) then 506 if (allInExtRange) then 507 if (err .ne. 0) 508 + call error(nf_strerror(err)) 509 else 510 if (err .ne. NF_ERANGE) 511 + call errore('range error: ', err) 512 endif 513 else 514 if (nels .gt. 0 .and. err .ne. NF_ECHAR) 515 + call errore('wrong type: ', err) 516 endif 517 endif 5185 continue 519 520 err = nf_close(ncid) 521 if (err .ne. 0) 522 + call errore('nf_close: ', err) 523 524 call check_vars_$1(scratch) 525 526 err = nf_delete(scratch) 527 if (err .ne. 0) 528 + call errorc('delete of scratch file failed: ', 529 + scratch) 530 end 531])dnl 532 533 534dnl TEST_NF_PUT_VARA(TYPE) 535dnl 536define([TEST_NF_PUT_VARA],dnl 537[dnl 538 subroutine test_nf_put_vara_$1() 539 implicit none 540#include "tests.inc" 541 integer ncid 542 integer i 543 integer j 544 integer k 545 integer d 546 integer err 547 integer nslabs 548 integer nels 549 integer start(MAX_RANK) 550 integer edge(MAX_RANK) 551 integer mid(MAX_RANK) 552 integer index(MAX_RANK) 553 logical canConvert !/* Both text or both numeric */ 554 logical allInExtRange !/* all values within external range? */ 555 DATATYPE($1) value(MAX_NELS) 556 doubleprecision val 557 integer udshift 558 559 err = nf_create(scratch, NF_CLOBBER, ncid) 560 if (err .ne. 0) then 561 call errore('nf_create: ', err) 562 return 563 end if 564 call def_dims(ncid) 565 call def_vars(ncid) 566 err = nf_enddef(ncid) 567 if (err .ne. 0) 568 + call errore('nf_enddef: ', err) 569 570 do 1, i = 1, NVARS 571 canConvert = (var_type(i) .eq. NF_CHAR) .eqv. 572 + (NFT_ITYPE($1) .eq. NFT_TEXT) 573 if (.not.(var_rank(i) .le. MAX_RANK)) 574 + stop 2 575 if (.not.(var_nels(i) .le. MAX_NELS)) 576 + stop 2 577 do 2, j = 1, var_rank(i) 578 start(j) = 1 579 edge(j) = 1 5802 continue 581 err = nf_put_vara_$1(BAD_ID, i, start, 582 + edge, value) 583 if (err .ne. NF_EBADID) 584 + call errore('bad ncid: ', err) 585 err = nf_put_vara_$1(ncid, BAD_VARID, 586 + start, edge, value) 587 if (err .ne. NF_ENOTVAR) 588 + call errore('bad var id: ', err) 589 do 3, j = 1, var_rank(i) 590 if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */ 591 start(j) = var_shape(j,i) + 1 592 err = nf_put_vara_$1(ncid, i, start, 593 + edge, value) 594 if (.not. canConvert) then 595 if (err .ne. NF_ECHAR) 596 + call errore('conversion: ', err) 597 else 598 if (err .ne. NF_EINVALCOORDS) 599 + call errore('bad start: ', err) 600 endif 601 start(j) = 1 602 edge(j) = var_shape(j,i) + 1 603 err = nf_put_vara_$1(ncid, i, start, 604 + edge, value) 605 if (.not. canConvert) then 606 if (err .ne. NF_ECHAR) 607 + call errore('conversion: ', err) 608 else 609 if (err .ne. NF_EEDGE) 610 + call errore('bad edge: ', err) 611 endif 612 edge(j) = 1 613 end if 6143 continue 615 616C /* Check correct error returned even when nothing to put */ 617 do 20, j = 1, var_rank(i) 618 edge(j) = 0 61920 continue 620 err = nf_put_vara_$1(BAD_ID, i, start, 621 + edge, value) 622 if (err .ne. NF_EBADID) 623 + call errore('bad ncid: ', err) 624 err = nf_put_vara_$1(ncid, BAD_VARID, 625 + start, edge, value) 626 if (err .ne. NF_ENOTVAR) 627 + call errore('bad var id: ', err) 628 do 21, j = 1, var_rank(i) 629 if (var_dimid(j,i) .gt. 1) then ! skip record dim 630 start(j) = var_shape(j,i) + 2 631 err = nf_put_vara_$1(ncid, i, start, 632 + edge, value) 633 if (.not. canConvert) then 634 if (err .ne. NF_ECHAR) 635 + call errore('conversion: ', err) 636 else 637 if (err .ne. NF_EINVALCOORDS) 638 + call errore('bad start: ', err) 639 endif 640 start(j) = 1 641 endif 64221 continue 643 err = nf_put_vara_$1(ncid, i, start, edge, value) 644 if (canConvert) then 645 if (err .ne. 0) 646 + call error(nf_strerror(err)) 647 else 648 if (err .ne. NF_ECHAR) 649 + call errore('wrong type: ', err) 650 endif 651 do 22, j = 1, var_rank(i) 652 edge(j) = 1 65322 continue 654 655 656 !/* Choose a random point dividing each dim into 2 parts */ 657 !/* Put 2^rank (nslabs) slabs so defined */ 658 nslabs = 1 659 do 4, j = 1, var_rank(i) 660 mid(j) = roll( var_shape(j,i) ) 661 nslabs = nslabs * 2 6624 continue 663 !/* bits of k determine whether to put lower or upper part of dim */ 664 do 5, k = 1, nslabs 665 nels = 1 666 do 6, j = 1, var_rank(i) 667 if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then 668 start(j) = 1 669 edge(j) = mid(j) 670 else 671 start(j) = 1 + mid(j) 672 edge(j) = var_shape(j,i) - mid(j) 673 end if 674 nels = nels * edge(j) 6756 continue 676 allInExtRange = .true. 677 do 7, j = 1, nels 678 err = index2indexes(j, var_rank(i), edge, index) 679 if (err .ne. 0) 680 + call error('error in index2indexes 1') 681 do 8, d = 1, var_rank(i) 682 index(d) = index(d) + start(d) - 1 6838 continue 684 value(j)= MAKE_TYPE($1, hash_$1(var_type(i), 685 + var_rank(i), index, 686 + NFT_ITYPE($1))) 687 val = ARITH($1, value(j)) 688 allInExtRange = allInExtRange .and. 689 + inRange3(val, var_type(i), NFT_ITYPE($1)) 6907 continue 691 err = nf_put_vara_$1(ncid, i, start, 692 + edge, value) 693 if (canConvert) then 694 if (allInExtRange) then 695 if (err .ne. 0) 696 + call error(nf_strerror(err)) 697 else 698 if (err .ne. NF_ERANGE) 699 + call errore('range error: ', err) 700 end if 701 else 702 if (nels .gt. 0 .and. err .ne. NF_ECHAR) 703 + call errore('wrong type: ', err) 704 end if 7055 continue 7061 continue 707 708 err = nf_close(ncid) 709 if (err .ne. 0) 710 + call errore('nf_close: ', err) 711 712 call check_vars_$1(scratch) 713 714 err = nf_delete(scratch) 715 if (err .ne. 0) 716 + call errorc('delete of scratch file failed: ', 717 + scratch) 718 end 719])dnl 720 721 722dnl TEST_NF_PUT_VARS(TYPE) 723dnl 724define([TEST_NF_PUT_VARS],dnl 725[dnl 726 subroutine test_nf_put_vars_$1() 727 implicit none 728#include "tests.inc" 729 integer ncid 730 integer d 731 integer i 732 integer j 733 integer k 734 integer m 735 integer err 736 integer nels 737 integer nslabs 738 integer nstarts !/* number of different starts */ 739 integer start(MAX_RANK) 740 integer edge(MAX_RANK) 741 integer index(MAX_RANK) 742 integer index2(MAX_RANK) 743 integer mid(MAX_RANK) 744 integer count(MAX_RANK) 745 integer sstride(MAX_RANK) 746 integer stride(MAX_RANK) 747 logical canConvert !/* Both text or both numeric */ 748 logical allInExtRange !/* all values within external range? */ 749 DATATYPE($1) value(MAX_NELS) 750 doubleprecision val 751 integer udshift 752 753 err = nf_create(scratch, NF_CLOBBER, ncid) 754 if (err .ne. 0) then 755 call errore('nf_create: ', err) 756 return 757 end if 758 call def_dims(ncid) 759 call def_vars(ncid) 760 err = nf_enddef(ncid) 761 if (err .ne. 0) 762 + call errore('nf_enddef: ', err) 763 764 do 1, i = 1, NVARS 765 canConvert = (var_type(i) .eq. NF_CHAR) .eqv. 766 + (NFT_ITYPE($1) .eq. NFT_TEXT) 767 if (.not.(var_rank(i) .le. MAX_RANK)) 768 + stop 2 769 if (.not.(var_nels(i) .le. MAX_NELS)) 770 + stop 2 771 do 2, j = 1, var_rank(i) 772 start(j) = 1 773 edge(j) = 1 774 stride(j) = 1 7752 continue 776 err = nf_put_vars_$1(BAD_ID, i, start, 777 + edge, stride, value) 778 if (err .ne. NF_EBADID) 779 + call errore('bad ncid: ', err) 780 err = nf_put_vars_$1(ncid, BAD_VARID, start, 781 + edge, stride, 782 + value) 783 if (err .ne. NF_ENOTVAR) 784 + call errore('bad var id: ', err) 785 do 3, j = 1, var_rank(i) 786 if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim 787 start(j) = var_shape(j,i) + 2 788 err = nf_put_vars_$1(ncid, i, start, 789 + edge, stride, 790 + value) 791 if (.not. canConvert) then 792 if (err .ne. NF_ECHAR) 793 + call errore('conversion: ', err) 794 else 795 if (err .ne. NF_EINVALCOORDS) 796 + call errore('bad start: ', err) 797 endif 798 start(j) = 1 799 edge(j) = var_shape(j,i) + 1 800 err = nf_put_vars_$1(ncid, i, start, 801 + edge, stride, 802 + value) 803 if (.not. canConvert) then 804 if (err .ne. NF_ECHAR) 805 + call errore('conversion: ', err) 806 else 807 if (err .ne. NF_EEDGE) 808 + call errore('bad edge: ', err) 809 endif 810 edge(j) = 1 811 stride(j) = 0 812 err = nf_put_vars_$1(ncid, i, start, 813 + edge, stride, 814 + value) 815 if (.not. canConvert) then 816 if (err .ne. NF_ECHAR) 817 + call errore('conversion: ', err) 818 else 819 if (err .ne. NF_ESTRIDE) 820 + call errore('bad stride: ', err) 821 endif 822 stride(j) = 1 823 end if 8243 continue 825 !/* Choose a random point dividing each dim into 2 parts */ 826 !/* Put 2^rank (nslabs) slabs so defined */ 827 nslabs = 1 828 do 4, j = 1, var_rank(i) 829 mid(j) = roll( var_shape(j,i) ) 830 nslabs = nslabs * 2 8314 continue 832 !/* bits of k determine whether to put lower or upper part of dim */ 833 !/* choose random stride from 1 to edge */ 834 do 5, k = 1, nslabs 835 nstarts = 1 836 do 6, j = 1, var_rank(i) 837 if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then 838 start(j) = 1 839 edge(j) = mid(j) 840 else 841 start(j) = 1 + mid(j) 842 edge(j) = var_shape(j,i) - mid(j) 843 end if 844 if (edge(j) .gt. 0) then 845 stride(j) = 1+roll(edge(j)) 846 else 847 stride(j) = 1 848 end if 849 sstride(j) = stride(j) 850 nstarts = nstarts * stride(j) 8516 continue 852 do 7, m = 1, nstarts 853 err = index2indexes(m, var_rank(i), sstride, index) 854 if (err .ne. 0) 855 + call error('error in index2indexes') 856 nels = 1 857 do 8, j = 1, var_rank(i) 858 count(j) = 1 + (edge(j) - index(j)) / stride(j) 859 nels = nels * count(j) 860 index(j) = index(j) + start(j) - 1 8618 continue 862 !/* Random choice of forward or backward */ 863C/* TODO 864C if ( roll(2) ) { 865C for (j = 1 j .lt. var_rank(i) j++) { 866C index(j) += (count(j) - 1) * stride(j) 867C stride(j) = -stride(j) 868C } 869C } 870C*/ 871 allInExtRange = .true. 872 do 9, j = 1, nels 873 err = index2indexes(j, var_rank(i), count, 874 + index2) 875 if (err .ne. 0) 876 + call error('error in index2indexes') 877 do 10, d = 1, var_rank(i) 878 index2(d) = index(d) + 879 + (index2(d)-1) * stride(d) 88010 continue 881 value(j) = MAKE_TYPE($1, hash_$1(var_type(i), 882 + var_rank(i), 883 + index2, NFT_ITYPE($1))) 884 val = ARITH($1, value(j)) 885 allInExtRange = allInExtRange .and. 886 + inRange3(val, var_type(i), 887 + NFT_ITYPE($1)) 8889 continue 889 err = nf_put_vars_$1(ncid, i, index, 890 + count, stride, 891 + value) 892 if (canConvert) then 893 if (allInExtRange) then 894 if (err .ne. 0) 895 + call error(nf_strerror(err)) 896 else 897 if (err .ne. NF_ERANGE) 898 + call errore('range error: ', err) 899 end if 900 else 901 if (nels .gt. 0 .and. err .ne. NF_ECHAR) 902 + call errore('wrong type: ', err) 903 end if 9047 continue 9055 continue 9061 continue 907 908 err = nf_close(ncid) 909 if (err .ne. 0) 910 + call errore('nf_close: ', err) 911 912 call check_vars_$1(scratch) 913 914 err = nf_delete(scratch) 915 if (err .ne. 0) 916 + call errorc('delete of scratch file failed:', 917 + scratch) 918 end 919])dnl 920 921 922dnl TEST_NF_PUT_VARM(TYPE) 923dnl 924define([TEST_NF_PUT_VARM],dnl 925[dnl 926 subroutine test_nf_put_varm_$1() 927 implicit none 928#include "tests.inc" 929 integer ncid 930 integer d 931 integer i 932 integer j 933 integer k 934 integer m 935 integer err 936 integer nels 937 integer nslabs 938 integer nstarts !/* number of different starts */ 939 integer start(MAX_RANK) 940 integer edge(MAX_RANK) 941 integer index(MAX_RANK) 942 integer index2(MAX_RANK) 943 integer mid(MAX_RANK) 944 integer count(MAX_RANK) 945 integer sstride(MAX_RANK) 946 integer stride(MAX_RANK) 947 integer imap(MAX_RANK) 948 logical canConvert !/* Both text or both numeric */ 949 logical allInExtRange !/* all values within external range? */ 950 DATATYPE($1) value(MAX_NELS) 951 doubleprecision val 952 integer udshift 953 954 err = nf_create(scratch, NF_CLOBBER, ncid) 955 if (err .ne. 0) then 956 call errore('nf_create: ', err) 957 return 958 end if 959 call def_dims(ncid) 960 call def_vars(ncid) 961 err = nf_enddef(ncid) 962 if (err .ne. 0) 963 + call errore('nf_enddef: ', err) 964 965 do 1, i = 1, NVARS 966 canConvert = (var_type(i) .eq. NF_CHAR) .eqv. 967 + (NFT_ITYPE($1) .eq. NFT_TEXT) 968 if (.not.(var_rank(i) .le. MAX_RANK)) 969 + stop 2 970 if (.not.(var_nels(i) .le. MAX_NELS)) 971 + stop 2 972 do 2, j = 1, var_rank(i) 973 start(j) = 1 974 edge(j) = 1 975 stride(j) = 1 976 imap(j) = 1 9772 continue 978 err = nf_put_varm_$1(BAD_ID, i, start, 979 + edge, stride, imap, 980 + value) 981 if (err .ne. NF_EBADID) 982 + call errore('bad ncid: ', err) 983 err = nf_put_varm_$1(ncid, BAD_VARID, start, 984 + edge, stride, 985 + imap, value) 986 if (err .ne. NF_ENOTVAR) 987 + call errore('bad var id: ', err) 988 do 3, j = 1, var_rank(i) 989 if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */ 990 start(j) = var_shape(j,i) + 2 991 err = nf_put_varm_$1(ncid, i, start, 992 + edge, stride, 993 + imap, value) 994 if (.not. canConvert) then 995 if (err .ne. NF_ECHAR) 996 + call errore('conversion: ', err) 997 else 998 if (err .ne. NF_EINVALCOORDS) 999 + call errore('bad start: ', err) 1000 endif 1001 start(j) = 1 1002 edge(j) = var_shape(j,i) + 1 1003 err = nf_put_varm_$1(ncid, i, start, 1004 + edge, stride, 1005 + imap, value) 1006 if (.not. canConvert) then 1007 if (err .ne. NF_ECHAR) 1008 + call errore('conversion: ', err) 1009 else 1010 if (err .ne. NF_EEDGE) 1011 + call errore('bad edge: ', err) 1012 endif 1013 edge(j) = 1 1014 stride(j) = 0 1015 err = nf_put_varm_$1(ncid, i, start, 1016 + edge, stride, 1017 + imap, value) 1018 if (.not. canConvert) then 1019 if (err .ne. NF_ECHAR) 1020 + call errore('conversion: ', err) 1021 else 1022 if (err .ne. NF_ESTRIDE) 1023 + call errore('bad stride: ', err) 1024 endif 1025 stride(j) = 1 1026 end if 10273 continue 1028 !/* Choose a random point dividing each dim into 2 parts */ 1029 !/* Put 2^rank (nslabs) slabs so defined */ 1030 nslabs = 1 1031 do 4, j = 1, var_rank(i) 1032 mid(j) = roll( var_shape(j,i) ) 1033 nslabs = nslabs * 2 10344 continue 1035 !/* bits of k determine whether to put lower or upper part of dim */ 1036 !/* choose random stride from 1 to edge */ 1037 do 5, k = 1, nslabs 1038 nstarts = 1 1039 do 6, j = 1, var_rank(i) 1040 if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then 1041 start(j) = 1 1042 edge(j) = mid(j) 1043 else 1044 start(j) = 1 + mid(j) 1045 edge(j) = var_shape(j,i) - mid(j) 1046 end if 1047 if (edge(j) .gt. 0) then 1048 stride(j) = 1+roll(edge(j)) 1049 else 1050 stride(j) = 1 1051 end if 1052 sstride(j) = stride(j) 1053 nstarts = nstarts * stride(j) 10546 continue 1055 do 7, m = 1, nstarts 1056 err = index2indexes(m, var_rank(i), sstride, index) 1057 if (err .ne. 0) 1058 + call error('error in index2indexes') 1059 nels = 1 1060 do 8, j = 1, var_rank(i) 1061 count(j) = 1 + (edge(j) - index(j)) / stride(j) 1062 nels = nels * count(j) 1063 index(j) = index(j) + start(j) - 1 10648 continue 1065 !/* Random choice of forward or backward */ 1066C/* TODO 1067C if ( roll(2) ) then 1068C do 9, j = 1, var_rank(i) 1069C index(j) = index(j) + 1070C + (count(j) - 1) * stride(j) 1071C stride(j) = -stride(j) 1072C9 continue 1073C end if 1074C*/ 1075 if (var_rank(i) .gt. 0) then 1076 imap(1) = 1 1077 do 10, j = 2, var_rank(i) 1078 imap(j) = imap(j-1) * count(j-1) 107910 continue 1080 end if 1081 allInExtRange = .true. 1082 do 11 j = 1, nels 1083 err = index2indexes(j, var_rank(i), count, 1084 + index2) 1085 if (err .ne. 0) 1086 + call error('error in index2indexes') 1087 do 12, d = 1, var_rank(i) 1088 index2(d) = index(d) + 1089 + (index2(d)-1) * stride(d) 109012 continue 1091 value(j) = MAKE_TYPE($1, hash_$1(var_type(i), 1092 + var_rank(i), 1093 + index2, NFT_ITYPE($1))) 1094 val = ARITH($1, value(j)) 1095 allInExtRange = allInExtRange .and. 1096 + inRange3(val, var_type(i), 1097 + NFT_ITYPE($1)) 109811 continue 1099 err = nf_put_varm_$1(ncid,i,index,count, 1100 + stride,imap, 1101 + value) 1102 if (canConvert) then 1103 if (allInExtRange) then 1104 if (err .ne. 0) 1105 + call error(nf_strerror(err)) 1106 else 1107 if (err .ne. NF_ERANGE) 1108 + call errore('range error: ', err) 1109 end if 1110 else 1111 if (nels .gt. 0 .and. err .ne. NF_ECHAR) 1112 + call errore('wrong type: ', err) 1113 end if 11147 continue 11155 continue 11161 continue 1117 1118 err = nf_close(ncid) 1119 if (err .ne. 0) 1120 + call errore('nf_close: ', err) 1121 1122 call check_vars_$1(scratch) 1123 1124 err = nf_delete(scratch) 1125 if (err .ne. 0) 1126 + call errorc('delete of scratch file failed:', 1127 + scratch) 1128 end 1129])dnl 1130 1131 1132dnl TEST_NF_PUT_ATT(TYPE) numeric only 1133dnl 1134define([TEST_NF_PUT_ATT],dnl 1135[dnl 1136 subroutine test_nf_put_att_$1() 1137 implicit none 1138#include "tests.inc" 1139 integer ncid 1140 integer i 1141 integer j 1142 integer k 1143 integer ndx(1) 1144 integer err 1145 DATATYPE($1) value(MAX_NELS) 1146 logical allInExtRange !/* all values within external range? */ 1147 doubleprecision val 1148 1149 err = nf_create(scratch, NF_NOCLOBBER, ncid) 1150 if (err .ne. 0) then 1151 call errore('nf_create: ', err) 1152 return 1153 end if 1154 call def_dims(ncid) 1155 call def_vars(ncid) 1156 1157 do 1, i = 0, NVARS 1158 do 2, j = 1, NATTS(i) 1159 if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then 1160 if (.not.((ATT_LEN(j,i) .le. MAX_NELS))) 1161 + stop 2 1162 err = nf_put_att_$1(BAD_ID, i, 1163 + ATT_NAME(j,i), 1164 + ATT_TYPE(j,i), 1165 + ATT_LEN(j,i), value) 1166 if (err .ne. NF_EBADID) 1167 + call errore('bad ncid: ', err) 1168 err = nf_put_att_$1(ncid, BAD_VARID, 1169 + ATT_NAME(j,i), 1170 + ATT_TYPE(j,i), ATT_LEN(j,i), value) 1171 if (err .ne. NF_ENOTVAR) 1172 + call errore('bad var id: ', err) 1173 err = nf_put_att_$1(ncid, i, 1174 + ATT_NAME(j,i), BAD_TYPE, 1175 + ATT_LEN(j,i), value) 1176 if (err .ne. NF_EBADTYPE) 1177 + call errore('bad type: ', err) 1178 allInExtRange = .true. 1179 do 3, k = 1, ATT_LEN(j,i) 1180 ndx(1) = k 1181 value(k) = hash_$1(ATT_TYPE(j,i), -1, ndx, 1182 + NFT_ITYPE($1)) 1183 val = ARITH($1, value(k)) 1184 allInExtRange = allInExtRange .and. 1185 + inRange3(val, ATT_TYPE(j,i), 1186 + NFT_ITYPE($1)) 11873 continue 1188 err = nf_put_att_$1(ncid, i, ATT_NAME(j,i), 1189 + ATT_TYPE(j,i), ATT_LEN(j,i), 1190 + value) 1191 if (allInExtRange) then 1192 if (err .ne. 0) 1193 + call error(nf_strerror(err)) 1194 else 1195 if (err .ne. NF_ERANGE) 1196 + call errore('range error: ', err) 1197 end if 1198 end if 11992 continue 12001 continue 1201 1202 call check_atts_$1(ncid) 1203 err = nf_close(ncid) 1204 if (err .ne. 0) 1205 + call errore('nf_close: ', err) 1206 1207 err = nf_delete(scratch) 1208 if (err .ne. 0) 1209 + call errorc('delete of scratch file failed:', 1210 + scratch) 1211 end 1212])dnl 1213 1214divert(0)dnl 1215dnl If you see this line, you can ignore the next one. 1216C Do not edit this file. It is produced from the corresponding .m4 source */ 1217 1218C******************************************************************** 1219C Copyright 1996, UCAR/Unidata 1220C See netcdf/COPYRIGHT file for copying and redistribution conditions. 1221C $Id: test_put.m4,v 1.16 2008/04/30 16:50:45 ed Exp $ 1222C******************************************************************** 1223 1224HASH(text) 1225#ifdef NF_INT1_T 1226HASH(int1) 1227#endif 1228#ifdef NF_INT2_T 1229HASH(int2) 1230#endif 1231HASH(int) 1232HASH(real) 1233HASH(double) 1234 1235CHECK_VARS(text) 1236#ifdef NF_INT1_T 1237CHECK_VARS(int1) 1238#endif 1239#ifdef NF_INT2_T 1240CHECK_VARS(int2) 1241#endif 1242CHECK_VARS(int) 1243CHECK_VARS(real) 1244CHECK_VARS(double) 1245 1246CHECK_ATTS(text) 1247#ifdef NF_INT1_T 1248CHECK_ATTS(int1) 1249#endif 1250#ifdef NF_INT2_T 1251CHECK_ATTS(int2) 1252#endif 1253CHECK_ATTS(int) 1254CHECK_ATTS(real) 1255CHECK_ATTS(double) 1256 1257TEST_NF_PUT_VAR1(text) 1258#ifdef NF_INT1_T 1259TEST_NF_PUT_VAR1(int1) 1260#endif 1261#ifdef NF_INT2_T 1262TEST_NF_PUT_VAR1(int2) 1263#endif 1264TEST_NF_PUT_VAR1(int) 1265TEST_NF_PUT_VAR1(real) 1266TEST_NF_PUT_VAR1(double) 1267 1268TEST_NF_PUT_VAR(text) 1269#ifdef NF_INT1_T 1270TEST_NF_PUT_VAR(int1) 1271#endif 1272#ifdef NF_INT2_T 1273TEST_NF_PUT_VAR(int2) 1274#endif 1275TEST_NF_PUT_VAR(int) 1276TEST_NF_PUT_VAR(real) 1277TEST_NF_PUT_VAR(double) 1278 1279TEST_NF_PUT_VARA(text) 1280#ifdef NF_INT1_T 1281TEST_NF_PUT_VARA(int1) 1282#endif 1283#ifdef NF_INT2_T 1284TEST_NF_PUT_VARA(int2) 1285#endif 1286TEST_NF_PUT_VARA(int) 1287TEST_NF_PUT_VARA(real) 1288TEST_NF_PUT_VARA(double) 1289 1290TEST_NF_PUT_VARS(text) 1291#ifdef NF_INT1_T 1292TEST_NF_PUT_VARS(int1) 1293#endif 1294#ifdef NF_INT2_T 1295TEST_NF_PUT_VARS(int2) 1296#endif 1297TEST_NF_PUT_VARS(int) 1298TEST_NF_PUT_VARS(real) 1299TEST_NF_PUT_VARS(double) 1300 1301TEST_NF_PUT_VARM(text) 1302#ifdef NF_INT1_T 1303TEST_NF_PUT_VARM(int1) 1304#endif 1305#ifdef NF_INT2_T 1306TEST_NF_PUT_VARM(int2) 1307#endif 1308TEST_NF_PUT_VARM(int) 1309TEST_NF_PUT_VARM(real) 1310TEST_NF_PUT_VARM(double) 1311 1312 subroutine test_nf_put_att_text() 1313 implicit none 1314#include "tests.inc" 1315 integer ncid 1316 integer i 1317 integer j 1318 integer k 1319 integer err 1320 character value(MAX_NELS) 1321 1322 err = nf_create(scratch, NF_NOCLOBBER, ncid) 1323 if (err .ne. 0) then 1324 call errore('NF_create: ', err) 1325 return 1326 end if 1327 call def_dims(ncid) 1328 call def_vars(ncid) 1329 1330 do 1, i = 0, NVARS 1331 do 2, j = 1, NATTS(i) 1332 if (ATT_TYPE(j,i) .eq. NF_CHAR) then 1333 if (.not.(ATT_LEN(j,i) .le. MAX_NELS)) 1334 + stop 2 1335 err = nf_put_att_text(BAD_ID, i, 1336 + ATT_NAME(j,i), ATT_LEN(j,i), value) 1337 if (err .ne. NF_EBADID) 1338 + call errore('bad ncid: ', err) 1339 err = nf_put_att_text(ncid, BAD_VARID, 1340 + ATT_NAME(j,i), 1341 + ATT_LEN(j,i), value) 1342 if (err .ne. NF_ENOTVAR) 1343 + call errore('bad var id: ', err) 1344 do 3, k = 1, ATT_LEN(j,i) 1345 value(k) = char(int(hash(ATT_TYPE(j,i), -1, k))) 13463 continue 1347 err = nf_put_att_text(ncid, i, ATT_NAME(j,i), 1348 + ATT_LEN(j,i), value) 1349 if (err .ne. 0) 1350 + call error(NF_strerror(err)) 1351 end if 13522 continue 13531 continue 1354 1355 call check_atts_text(ncid) 1356 err = NF_close(ncid) 1357 if (err .ne. 0) 1358 + call errore('NF_close: ', err) 1359 1360 err = nf_delete(scratch) 1361 if (err .ne. 0) 1362 + call errorc('delete of scratch file failed:', 1363 + scratch) 1364 end 1365 1366#ifdef NF_INT1_T 1367TEST_NF_PUT_ATT(int1) 1368#endif 1369#ifdef NF_INT2_T 1370TEST_NF_PUT_ATT(int2) 1371#endif 1372TEST_NF_PUT_ATT(int) 1373TEST_NF_PUT_ATT(real) 1374TEST_NF_PUT_ATT(double) 1375