1C Copyright 1996-2019, UCAR/Unidata 2C See netcdf/COPYRIGHT file for copying and redistribution conditions. 3 4C Steve Emmerson, Ed Hartnett 5 6C Test nf_create 7C For mode in NF_NOCLOBBER, NF_CLOBBER do: 8C create netcdf file 'scratch.nc' with no data, close it 9C test that it can be opened, do nf_inq to check nvars = 0, etc. 10C Try again in NF_NOCLOBBER mode, check error return 11C On exit, delete this file 12 subroutine test_nf_create() 13 USE tests 14 implicit none 15 16 integer clobber !/* 0 for NF_NOCLOBBER, 1 for NF_CLOBBER */ 17 integer err 18 integer ncid 19 integer ndims1 !/* number of dimensions */ 20 integer nvars1 !/* number of variables */ 21 integer ngatts1 !/* number of global attributes */ 22 integer recdim1 !/* id of unlimited dimension */ 23 integer flags 24 25 flags = NF_NOCLOBBER 26 do 1, clobber = 0, 1 27 err = nf_create(scratch, flags, ncid) 28 if (err .ne. 0) then 29 call errore('nf_create: ', err) 30 end if 31 err = nf_close(ncid) 32 if (err .ne. 0) then 33 call errore('nf_close: ', err) 34 end if 35 err = nf_open(scratch, NF_NOWRITE, ncid) 36 if (err .ne. 0) then 37 call errore('nf_open: ', err) 38 end if 39 err = nf_inq(ncid, ndims1, nvars1, ngatts1, recdim1) 40 if (err .ne. 0) then 41 call errore('nf_inq: ', err) 42 else if (ndims1 .ne. 0) then 43 call errori( 44 + 'nf_inq: wrong number of dimensions returned, ', 45 + ndims1) 46 else if (nvars1 .ne. 0) then 47 call errori( 48 + 'nf_inq: wrong number of variables returned, ', 49 + nvars1) 50 else if (ngatts1 .ne. 0) then 51 call errori( 52 + 'nf_inq: wrong number of global atts returned, ', 53 + ngatts1) 54 else if (recdim1 .ge. 1) then 55 call errori( 56 + 'nf_inq: wrong record dimension ID returned, ', 57 + recdim1) 58 end if 59 err = nf_close(ncid) 60 if (err .ne. 0) then 61 call errore('nf_close: ', err) 62 end if 63 64 flags = NF_CLOBBER 65 1 continue 66 67 err = nf_create(scratch, NF_NOCLOBBER, ncid) 68 if (err .ne. NF_EEXIST) then 69 call errore('attempt to overwrite file: ', err) 70 end if 71 err = nf_delete(scratch) 72 if (err .ne. 0) then 73 call errori('delete of scratch file failed: ', err) 74 end if 75 end 76 77 78C Test nf_redef 79C (In fact also tests nf_enddef - called from test_nf_enddef) 80C BAD_ID 81C attempt redef (error) & enddef on read-only file 82C create file, define dims & vars. 83C attempt put var (error) 84C attempt redef (error) & enddef. 85C put vars 86C attempt def new dims (error) 87C redef 88C def new dims, vars. 89C put atts 90C enddef 91C put vars 92C close 93C check file: vars & atts 94 subroutine test_nf_redef() 95 USE tests 96 implicit none 97 integer title_len 98 parameter (title_len = 9) 99 100 integer ncid !/* netcdf id */ 101 integer dimid !/* dimension id */ 102 integer vid !/* variable id */ 103 integer err 104 character*(title_len) title 105 doubleprecision var 106 character*(NF_MAX_NAME) name 107 integer length 108 109 title = 'Not funny' 110 111C /* BAD_ID tests */ 112 err = nf_redef(BAD_ID) 113 if (err .ne. NF_EBADID) 114 + call errore('bad ncid: ', err) 115 err = nf_enddef(BAD_ID) 116 if (err .ne. NF_EBADID) 117 + call errore('bad ncid: ', err) 118 119C /* read-only tests */ 120 err = nf_open(testfile, NF_NOWRITE, ncid) 121 if (err .ne. 0) 122 + call errore('nf_open: ', err) 123 err = nf_redef(ncid) 124 if (err .ne. NF_EPERM) 125 + call errore('nf_redef in NF_NOWRITE mode: ', err) 126 err = nf_enddef(ncid) 127 if (err .ne. NF_ENOTINDEFINE) 128 + call errore('nf_redef in NF_NOWRITE mode: ', err) 129 err = nf_close(ncid) 130 if (err .ne. 0) 131 + call errore('nf_close: ', err) 132 133C /* tests using scratch file */ 134 err = nf_create(scratch, NF_NOCLOBBER, ncid) 135 if (err .ne. 0) then 136 call errore('nf_create: ', err) 137 return 138 end if 139 call def_dims(ncid) 140 call def_vars(ncid) 141 call put_atts(ncid) 142 err = nf_inq_varid(ncid, 'd', vid) 143 if (err .ne. 0) 144 + call errore('nf_inq_varid: ', err) 145 var = 1.0 146 err = nf_put_var1_double(ncid, vid, (/0/), var) 147 if (err .ne. NF_EINDEFINE) 148 + call errore('nf_put_var... in define mode: ', err) 149 err = nf_redef(ncid) 150 if (err .ne. NF_EINDEFINE) 151 + call errore('nf_redef in define mode: ', err) 152 err = nf_enddef(ncid) 153 if (err .ne. 0) 154 + call errore('nf_enddef: ', err) 155 call put_vars(ncid) 156 err = nf_def_dim(ncid, 'abc', 8, dimid) 157 if (err .ne. NF_ENOTINDEFINE) 158 + call errore('nf_def_dim in define mode: ', err) 159 err = nf_redef(ncid) 160 if (err .ne. 0) 161 + call errore('nf_redef: ', err) 162 err = nf_def_dim(ncid, 'abc', 8, dimid) 163 if (err .ne. 0) 164 + call errore('nf_def_dim: ', err) 165 err = nf_def_var(ncid, 'abc', NF_INT, 0, (/0/), vid) 166 if (err .ne. 0) 167 + call errore('nf_def_var: ', err) 168 err = nf_put_att_text(ncid, NF_GLOBAL, 'title', len(title), 169 + title) 170 if (err .ne .0) 171 + call errore('nf_put_att_text: ', err) 172 err = nf_enddef(ncid) 173 if (err .ne. 0) 174 + call errore('nf_enddef: ', err) 175 var = 1.0 176 err = nf_put_var1_double(ncid, vid, (/0/), var) 177 if (err .ne. 0) 178 + call errore('nf_put_var1_double: ', err) 179 err = nf_close(ncid) 180 if (err .ne. 0) 181 + call errore('nf_close: ', err) 182 183C /* check scratch file written as expected */ 184 call check_file(scratch) 185 err = nf_open(scratch, NF_NOWRITE, ncid) 186 if (err .ne. 0) 187 + call errore('nf_open: ', err) 188 err = nf_inq_dim(ncid, dimid, name, length) 189 if (err .ne. 0) 190 + call errore('nf_inq_dim: ', err) 191 if (name .ne. "abc") 192 + call errori('Unexpected dim name in netCDF ', ncid) 193 if (length .ne. 8) 194 + call errori('Unexpected dim length: ', length) 195 err = nf_get_var1_double(ncid, vid, (/0/), var) 196 if (err .ne. 0) 197 + call errore('nf_get_var1_double: ', err) 198 if (var .ne. 1.0) 199 + call errori( 200 + 'nf_get_var1_double: unexpected value in netCDF ', ncid) 201 err = nf_close(ncid) 202 if (err .ne. 0) 203 + call errore('nf_close: ', err) 204 205 err = nf_delete(scratch) 206 if (err .ne. 0) 207 + call errori('delete failed for netCDF: ', err) 208 end 209 210C Test nf_enddef 211C Simply calls test_nf_redef which tests both nf_redef & nf_enddef 212 213 subroutine test_nf_enddef() 214 USE tests 215 implicit none 216 217 call test_nf_redef 218 end 219 220 221C Test nf_sync 222C try with bad handle, check error 223C try in define mode, check error 224C try writing with one handle, reading with another on same netCDF 225 subroutine test_nf_sync() 226 USE tests 227 implicit none 228 229 integer ncidw !/* netcdf id for writing */ 230 integer ncidr !/* netcdf id for reading */ 231 integer err 232 233C /* BAD_ID test */ 234 err = nf_sync(BAD_ID) 235 if (err .ne. NF_EBADID) 236 + call errore('bad ncid: ', err) 237 238C /* create scratch file & try nf_sync in define mode */ 239 err = nf_create(scratch, NF_NOCLOBBER, ncidw) 240 if (err .ne. 0) then 241 call errore('nf_create: ', err) 242 return 243 end if 244 err = nf_sync(ncidw) 245 if (err .ne. NF_EINDEFINE) 246 + call errore('nf_sync called in define mode: ', err) 247 248C /* write using same handle */ 249 call def_dims(ncidw) 250 call def_vars(ncidw) 251 call put_atts(ncidw) 252 err = nf_enddef(ncidw) 253 if (err .ne. 0) 254 + call errore('nf_enddef: ', err) 255 call put_vars(ncidw) 256 err = nf_sync(ncidw) 257 if (err .ne. 0) 258 + call errore('nf_sync of ncidw failed: ', err) 259 260C /* open another handle, nf_sync, read (check) */ 261 err = nf_open(scratch, NF_NOWRITE, ncidr) 262 if (err .ne. 0) 263 + call errore('nf_open: ', err) 264 err = nf_sync(ncidr) 265 if (err .ne. 0) 266 + call errore('nf_sync of ncidr failed: ', err) 267 call check_dims(ncidr) 268 call check_atts(ncidr) 269 call check_vars(ncidr) 270 271C /* close both handles */ 272 err = nf_close(ncidr) 273 if (err .ne. 0) 274 + call errore('nf_close: ', err) 275 err = nf_close(ncidw) 276 if (err .ne. 0) 277 + call errore('nf_close: ', err) 278 279 err = nf_delete(scratch) 280 if (err .ne. 0) 281 + call errori('delete of scratch file failed: ', err) 282 end 283 284 285C Test nf_abort 286C try with bad handle, check error 287C try in define mode before anything written, check that file was deleted 288C try after nf_enddef, nf_redef, define new dims, vars, atts 289C try after writing variable 290 subroutine test_nf_abort() 291 USE tests 292 implicit none 293 294 integer ncid !/* netcdf id */ 295 integer err 296 integer ndims1 297 integer nvars1 298 integer ngatts1 299 integer recdim1 300 301C /* BAD_ID test */ 302 err = nf_abort(BAD_ID) 303 if (err .ne. NF_EBADID) 304 + call errore('bad ncid: status = ', err) 305 306C /* create scratch file & try nf_abort in define mode */ 307 err = nf_create(scratch, NF_NOCLOBBER, ncid) 308 if (err .ne. 0) then 309 call errore('nf_create: ', err) 310 return 311 end if 312 call def_dims(ncid) 313 call def_vars(ncid) 314 call put_atts(ncid) 315 err = nf_abort(ncid) 316 if (err .ne. 0) 317 + call errore('nf_abort of ncid failed: ', err) 318 err = nf_close(ncid) !/* should already be closed */ 319 if (err .ne. NF_EBADID) 320 + call errore('bad ncid: ', err) 321 err = nf_delete(scratch) !/* should already be deleted */ 322 if (err .eq. 0) 323 + call errori('scratch file should not exist: ', err) 324 325C create scratch file 326C do nf_enddef & nf_redef 327C define new dims, vars, atts 328C try nf_abort: should restore previous state (no dims, vars, atts) 329 err = nf_create(scratch, NF_NOCLOBBER, ncid) 330 if (err .ne. 0) then 331 call errore('nf_create: ', err) 332 return 333 end if 334 err = nf_enddef(ncid) 335 if (err .ne. 0) 336 + call errore('nf_enddef: ', err) 337 err = nf_redef(ncid) 338 if (err .ne. 0) 339 + call errore('nf_redef: ', err) 340 call def_dims(ncid) 341 call def_vars(ncid) 342 call put_atts(ncid) 343 err = nf_abort(ncid) 344 if (err .ne. 0) 345 + call errore('nf_abort of ncid failed: ', err) 346 err = nf_close(ncid) !/* should already be closed */ 347 if (err .ne. NF_EBADID) 348 + call errore('bad ncid: ', err) 349 err = nf_open(scratch, NF_NOWRITE, ncid) 350 if (err .ne. 0) 351 + call errore('nf_open: ', err) 352 err = nf_inq (ncid, ndims1, nvars1, ngatts1, recdim1) 353 if (err .ne. 0) 354 + call errore('nf_inq: ', err) 355 if (ndims1 .ne. 0) 356 + call errori('ndims1 should be ', 0) 357 if (nvars1 .ne. 0) 358 + call errori('nvars1 should be ', 0) 359 if (ngatts1 .ne. 0) 360 + call errori('ngatts1 should be ', 0) 361 err = nf_close (ncid) 362 if (err .ne. 0) 363 + call errore('nf_close: ', err) 364 365C /* try nf_abort in data mode - should just close */ 366 err = nf_create(scratch, NF_CLOBBER, ncid) 367 if (err .ne. 0) then 368 call errore('nf_create: ', err) 369 return 370 end if 371 call def_dims(ncid) 372 call def_vars(ncid) 373 call put_atts(ncid) 374 err = nf_enddef(ncid) 375 if (err .ne. 0) 376 + call errore('nf_enddef: ', err) 377 call put_vars(ncid) 378 err = nf_abort(ncid) 379 if (err .ne. 0) 380 + call errore('nf_abort of ncid failed: ', err) 381 err = nf_close(ncid) !/* should already be closed */ 382 if (err .ne. NF_EBADID) 383 + call errore('bad ncid: ', err) 384 call check_file(scratch) 385 err = nf_delete(scratch) 386 if (err .ne. 0) 387 + call errori('delete of scratch file failed: ', err) 388 end 389 390 391C Test nf_def_dim 392C try with bad netCDF handle, check error 393C try in data mode, check error 394C check that returned id is one more than previous id 395C try adding same dimension twice, check error 396C try with illegal sizes, check error 397C make sure unlimited size works, shows up in nf_inq_unlimdim 398C try to define a second unlimited dimension, check error 399 subroutine test_nf_def_dim() 400 USE tests 401 implicit none 402 403 integer ncid 404 integer err !/* status */ 405 integer i 406 integer dimid !/* dimension id */ 407 integer length 408 409C /* BAD_ID test */ 410 err = nf_def_dim(BAD_ID, 'abc', 8, dimid) 411 if (err .ne. NF_EBADID) 412 + call errore('bad ncid: ', err) 413 414C /* data mode test */ 415 err = nf_create(scratch, NF_CLOBBER, ncid) 416 if (err .ne. 0) then 417 call errore('nf_create: ', err) 418 return 419 end if 420 err = nf_enddef(ncid) 421 if (err .ne. 0) 422 + call errore('nf_enddef: ', err) 423 err = nf_def_dim(ncid, 'abc', 8, dimid) 424 if (err .ne. NF_ENOTINDEFINE) 425 + call errore('bad ncid: ', err) 426 427C /* define-mode tests: unlimited dim */ 428 err = nf_redef(ncid) 429 if (err .ne. 0) 430 + call errore('nf_redef: ', err) 431 err = nf_def_dim(ncid, dim_name(1), NF_UNLIMITED, dimid) 432 if (err .ne. 0) 433 + call errore('nf_def_dim: ', err) 434 if (dimid .ne. 1) 435 + call errori('Unexpected dimid: ', dimid) 436 err = nf_inq_unlimdim(ncid, dimid) 437 if (err .ne. 0) 438 + call errore('nf_inq_unlimdim: ', err) 439 if (dimid .ne. RECDIM) 440 + call error('Unexpected recdim1: ') 441 err = nf_inq_dimlen(ncid, dimid, length) 442 if (length .ne. 0) 443 + call errori('Unexpected length: ', 0) 444 err = nf_def_dim(ncid, 'abc', NF_UNLIMITED, dimid) 445 if (err .ne. NF_EUNLIMIT) 446 + call errore('2nd unlimited dimension: ', err) 447 448C /* define-mode tests: remaining dims */ 449 do 1, i = 2, NDIMS 450 err = nf_def_dim(ncid, dim_name(i-1), dim_len(i), 451 + dimid) 452 if (err .ne. NF_ENAMEINUSE) 453 + call errore('duplicate name: ', err) 454 err = nf_def_dim(ncid, BAD_NAME, dim_len(i), dimid) 455 if (err .ne. NF_EBADNAME) 456 + call errore('bad name: ', err) 457 err = nf_def_dim(ncid, dim_name(i), NF_UNLIMITED-1, 458 + dimid) 459 if (err .ne. NF_EDIMSIZE) 460 + call errore('bad size: ', err) 461 err = nf_def_dim(ncid, dim_name(i), dim_len(i), dimid) 462 if (err .ne. 0) 463 + call errore('nf_def_dim: ', err) 464 if (dimid .ne. i) 465 + call errori('Unexpected dimid: ', 0) 466 1 continue 467 468C /* Following just to expand unlimited dim */ 469 call def_vars(ncid) 470 err = nf_enddef(ncid) 471 if (err .ne. 0) 472 + call errore('nf_enddef: ', err) 473 call put_vars(ncid) 474 475C /* Check all dims */ 476 call check_dims(ncid) 477 478 err = nf_close(ncid) 479 if (err .ne. 0) 480 + call errore('nf_close: ', err) 481 err = nf_delete(scratch) 482 if (err .ne. 0) 483 + call errori('delete of scratch file failed: ', err) 484 end 485 486 487C Test nf_rename_dim 488C try with bad netCDF handle, check error 489C check that proper rename worked with nf_inq_dim 490C try renaming to existing dimension name, check error 491C try with bad dimension handle, check error 492 subroutine test_nf_rename_dim() 493 USE tests 494 implicit none 495 496 integer ncid 497 integer err !/* status */ 498 character*(NF_MAX_NAME) name 499 500C /* BAD_ID test */ 501 err = nf_rename_dim(BAD_ID, 1, 'abc') 502 if (err .ne. NF_EBADID) 503 + call errore('bad ncid: ', err) 504 505C /* main tests */ 506 err = nf_create(scratch, NF_NOCLOBBER, ncid) 507 if (err .ne. 0) then 508 call errore('nf_create: ', err) 509 return 510 end if 511 call def_dims(ncid) 512 err = nf_rename_dim(ncid, BAD_DIMID, 'abc') 513 if (err .ne. NF_EBADDIM) 514 + call errore('bad dimid: ', err) 515 err = nf_rename_dim(ncid, 3, 'abc') 516 if (err .ne. 0) 517 + call errore('nf_rename_dim: ', err) 518 err = nf_inq_dimname(ncid, 3, name) 519 if (name .ne. 'abc') 520 + call errorc('Unexpected name: ', name) 521 err = nf_rename_dim(ncid, 1, 'abc') 522 if (err .ne. NF_ENAMEINUSE) 523 + call errore('duplicate name: ', err) 524 525 err = nf_close(ncid) 526 if (err .ne. 0) 527 + call errore('nf_close: ', err) 528 err = nf_delete(scratch) 529 if (err .ne. 0) 530 + call errori('delete of scratch file failed: ', err) 531 end 532 533 534C Test nf_def_var 535C try with bad netCDF handle, check error 536C try with bad name, check error 537C scalar tests: 538C check that proper define worked with nf_inq_var 539C try redefining an existing variable, check error 540C try with bad datatype, check error 541C try with bad number of dimensions, check error 542C try in data mode, check error 543C check that returned id is one more than previous id 544C try with bad dimension ids, check error 545 subroutine test_nf_def_var() 546 USE tests 547 implicit none 548 549 integer ncid 550 integer vid 551 integer err !/* status */ 552 integer i 553 integer ndims1 554 integer na 555 character*(NF_MAX_NAME) name 556 integer dimids(MAX_RANK) 557 integer datatype 558 559C /* BAD_ID test */ 560 err = nf_def_var(BAD_ID, 'abc', NF_SHORT, 0, dimids, vid) 561 if (err .ne. NF_EBADID) 562 + call errore('bad ncid: status = ', err) 563 564C /* scalar tests */ 565 err = nf_create(scratch, NF_NOCLOBBER, ncid) 566 if (err .ne. 0) then 567 call errore('nf_create: ', err) 568 return 569 end if 570 err = nf_def_var(ncid, 'abc', NF_SHORT, 0, dimids, vid) 571 if (err .ne. 0) 572 + call errore('nf_def_var: ', err) 573 err = nf_inq_var(ncid, vid, name, datatype, ndims1, dimids, 574 + na) 575 if (err .ne. 0) 576 + call errore('nf_inq_var: ', err) 577 if (name .ne. 'abc') 578 + call errorc('Unexpected name: ', name) 579 if (datatype .ne. NF_SHORT) 580 + call error('Unexpected datatype') 581 if (ndims1 .ne. 0) 582 + call error('Unexpected rank') 583 err = nf_def_var(ncid, BAD_NAME, NF_SHORT, 0, dimids, vid) 584 if (err .ne. NF_EBADNAME) 585 + call errore('bad name: ', err) 586 err = nf_def_var(ncid, 'abc', NF_SHORT, 0, dimids, vid) 587 if (err .ne. NF_ENAMEINUSE) 588 + call errore('duplicate name: ', err) 589 err = nf_def_var(ncid, 'ABC', BAD_TYPE, -1, dimids, vid) 590 if (err .ne. NF_EBADTYPE) 591 + call errore('bad type: ', err) 592 err = nf_def_var(ncid, 'ABC', NF_SHORT, -1, dimids, vid) 593 if (err .ne. NF_EINVAL) 594 + call errore('bad rank: ', err) 595 err = nf_enddef(ncid) 596 if (err .ne. 0) 597 + call errore('nf_enddef: ', err) 598 err = nf_def_var(ncid, 'ABC', NF_SHORT, 0, dimids, vid) 599 if (err .ne. NF_ENOTINDEFINE) 600 + call errore('nf_def_var called in data mode: ', err) 601 err = nf_close(ncid) 602 if (err .ne. 0) 603 + call errore('nf_close: ', err) 604 err = nf_delete(scratch) 605 if (err .ne. 0) 606 + call errorc('delete of scratch file failed: ', scratch) 607 608C /* general tests using global vars */ 609 err = nf_create(scratch, NF_CLOBBER, ncid) 610 if (err .ne. 0) then 611 call errore('nf_create: ', err) 612 return 613 end if 614 call def_dims(ncid) 615 do 1, i = 1, NVARS 616 err = nf_def_var(ncid, var_name(i), var_type(i), 617 + var_rank(i), var_dimid(1,i), vid) 618 if (err .ne. 0) 619 + call errore('nf_def_var: ', err) 620 if (vid .ne. i) 621 + call error('Unexpected varid') 622 1 continue 623 624C /* try bad dim ids */ 625 dimids(1) = BAD_DIMID 626 err = nf_def_var(ncid, 'abc', NF_SHORT, 1, dimids, vid) 627 if (err .ne. NF_EBADDIM) 628 + call errore('bad dim ids: ', err) 629 err = nf_close(ncid) 630 if (err .ne. 0) 631 + call errore('nf_close: ', err) 632 633 err = nf_delete(scratch) 634 if (err .ne. 0) 635 + call errorc('delete of scratch file failed: ', scratch) 636 end 637 638 639C Test nf_rename_var 640C try with bad netCDF handle, check error 641C try with bad variable handle, check error 642C try renaming to existing variable name, check error 643C check that proper rename worked with nf_inq_varid 644C try in data mode, check error 645 subroutine test_nf_rename_var() 646 USE tests 647 implicit none 648 649 integer ncid 650 integer vid 651 integer err 652 integer i 653 character*(NF_MAX_NAME) name 654 655 err = nf_create(scratch, NF_NOCLOBBER, ncid) 656 if (err .ne. 0) then 657 call errore('nf_create: ', err) 658 return 659 end if 660 err = nf_rename_var(ncid, BAD_VARID, 'newName') 661 if (err .ne. NF_ENOTVAR) 662 + call errore('bad var id: ', err) 663 call def_dims(ncid) 664 call def_vars(ncid) 665 666C /* Prefix "new_" to each name */ 667 do 1, i = 1, NVARS 668 err = nf_rename_var(BAD_ID, i, 'newName') 669 if (err .ne. NF_EBADID) 670 + call errore('bad ncid: ', err) 671 err = nf_rename_var(ncid, i, var_name(NVARS)) 672 if (err .ne. NF_ENAMEINUSE) 673 + call errore('duplicate name: ', err) 674 name = 'new_' // var_name(i) 675 err = nf_rename_var(ncid, i, name) 676 if (err .ne. 0) 677 + call errore('nf_rename_var: ', err) 678 err = nf_inq_varid(ncid, name, vid) 679 if (err .ne. 0) 680 + call errore('nf_inq_varid: ', err) 681 if (vid .ne. i) 682 + call error('Unexpected varid') 683 1 continue 684 685C /* Change to data mode */ 686C /* Try making names even longer. Then restore original names */ 687 err = nf_enddef(ncid) 688 if (err .ne. 0) 689 + call errore('nf_enddef: ', err) 690 do 2, i = 1, NVARS 691 name = 'even_longer_' // var_name(i) 692 err = nf_rename_var(ncid, i, name) 693 if (err .ne. NF_ENOTINDEFINE) 694 + call errore('longer name in data mode: ', err) 695 err = nf_rename_var(ncid, i, var_name(i)) 696 if (err .ne. 0) 697 + call errore('nf_rename_var: ', err) 698 err = nf_inq_varid(ncid, var_name(i), vid) 699 if (err .ne. 0) 700 + call errore('nf_inq_varid: ', err) 701 if (vid .ne. i) 702 + call error('Unexpected varid') 703 2 continue 704 705 call put_vars(ncid) 706 call check_vars(ncid) 707 708 err = nf_close(ncid) 709 if (err .ne. 0) 710 + call errore('nf_close: ', err) 711 712 err = nf_delete(scratch) 713 if (err .ne. 0) 714 + call errorc('delete of scratch file failed: ', scratch) 715 end 716 717 718C Test nf_copy_att 719C try with bad source or target netCDF handles, check error 720C try with bad source or target variable handle, check error 721C try with nonexisting attribute, check error 722C check that NF_GLOBAL variable for source or target works 723C check that new attribute put works with target in define mode 724C check that old attribute put works with target in data mode 725C check that changing type and length of an attribute work OK 726C try with same ncid for source and target, different variables 727C try with same ncid for source and target, same variable 728 subroutine test_nf_copy_att() 729 USE tests 730 implicit none 731 732 integer ncid_in 733 integer ncid_out 734 integer vid 735 integer err 736 integer i 737 integer j 738 character*(NF_MAX_NAME) name !/* of att */ 739 integer datatype !/* of att */ 740 integer length !/* of att */ 741 character*1 value 742 743 err = nf_open(testfile, NF_NOWRITE, ncid_in) 744 if (err .ne. 0) 745 + call errore('nf_open: ', err) 746 err = nf_create(scratch, NF_NOCLOBBER, ncid_out) 747 if (err .ne. 0) then 748 call errore('nf_create: ', err) 749 return 750 end if 751 call def_dims(ncid_out) 752 call def_vars(ncid_out) 753 754 do 1, i = 0, NVARS 755 vid = VARID(i) 756 do 2, j = 1, NATTS(i) 757 name = ATT_NAME(j,i) 758 err = nf_copy_att(ncid_in, BAD_VARID, name, ncid_out, 759 + vid) 760 if (err .ne. NF_ENOTVAR) 761 + call errore('bad var id: ', err) 762 err = nf_copy_att(ncid_in, vid, name, ncid_out, 763 + BAD_VARID) 764 if (err .ne. NF_ENOTVAR) 765 + call errore('bad var id: ', err) 766 err = nf_copy_att(BAD_ID, vid, name, ncid_out, vid) 767 if (err .ne. NF_EBADID) 768 + call errore('bad ncid: ', err) 769 err = nf_copy_att(ncid_in, vid, name, BAD_ID, vid) 770 if (err .ne. NF_EBADID) 771 + call errore('bad ncid: ', err) 772 err = nf_copy_att(ncid_in, vid, 'noSuch', ncid_out, vid) 773 if (err .ne. NF_ENOTATT) 774 + call errore('bad attname: ', err) 775 err = nf_copy_att(ncid_in, vid, name, ncid_out, vid) 776 if (err .ne. 0) 777 + call errore('nf_copy_att: ', err) 778 err = nf_copy_att(ncid_out, vid, name, ncid_out, vid) 779 if (err .ne. 0) 780 + call errore('source = target: ', err) 781 2 continue 782 1 continue 783 784 err = nf_close(ncid_in) 785 if (err .ne. 0) 786 + call errore('nf_close: ', err) 787 788C /* Close scratch. Reopen & check attributes */ 789 err = nf_close(ncid_out) 790 if (err .ne. 0) 791 + call errore('nf_close: ', err) 792 err = nf_open(scratch, NF_WRITE, ncid_out) 793 if (err .ne. 0) 794 + call errore('nf_open: ', err) 795 call check_atts(ncid_out) 796 797C change to define mode 798C define single char. global att. ':a' with value 'A' 799C This will be used as source for following copies 800 err = nf_redef(ncid_out) 801 if (err .ne. 0) 802 + call errore('nf_redef: ', err) 803 err = nf_put_att_text(ncid_out, NF_GLOBAL, 'a', 1, 'A') 804 if (err .ne. 0) 805 + call errore('nf_put_att_text: ', err) 806 807C change to data mode 808C Use scratch as both source & dest. 809C try copy to existing att. change type & decrease length 810C rename 1st existing att of each var (if any) 'a' 811C if this att. exists them copy ':a' to it 812 err = nf_enddef(ncid_out) 813 if (err .ne. 0) 814 + call errore('nf_enddef: ', err) 815 do 3, i = 1, NVARS 816 if (NATTS(i) .gt. 0 .and. ATT_LEN(1,i) .gt. 0) then 817 err = nf_rename_att(ncid_out, i, att_name(1,i), 'a') 818 if (err .ne. 0) 819 + call errore('nf_rename_att: ', err) 820 err = nf_copy_att(ncid_out, NF_GLOBAL, 'a', ncid_out, 821 + i) 822 if (err .ne. 0) 823 + call errore('nf_copy_att: ', err) 824 end if 825 3 continue 826 err = nf_close(ncid_out) 827 if (err .ne. 0) 828 + call errore('nf_close: ', err) 829 830C /* Reopen & check */ 831 err = nf_open(scratch, NF_WRITE, ncid_out) 832 if (err .ne. 0) 833 + call errore('nf_open: ', err) 834 do 4, i = 1, NVARS 835 if (NATTS(i) .gt. 0 .and. ATT_LEN(1,i) .gt. 0) then 836 err = nf_inq_att(ncid_out, i, 'a', datatype, length) 837 if (err .ne. 0) 838 + call errore('nf_inq_att: ', err) 839 if (datatype .ne. NF_CHAR) 840 + call error('Unexpected type') 841 if (length .ne. 1) 842 + call error('Unexpected length') 843 err = nf_get_att_text(ncid_out, i, 'a', value) 844 if (err .ne. 0) 845 + call errore('nf_get_att_text: ', err) 846 if (value .ne. 'A') 847 + call error('Unexpected value') 848 end if 849 4 continue 850 851 err = nf_close(ncid_out) 852 if (err .ne. 0) 853 + call errore('nf_close: ', err) 854 err = nf_delete(scratch) 855 if (err .ne. 0) 856 + call errorc('delete of scratch file failed', scratch) 857 end 858 859 860C Test nf_rename_att 861C try with bad netCDF handle, check error 862C try with bad variable handle, check error 863C try with nonexisting att name, check error 864C try renaming to existing att name, check error 865C check that proper rename worked with nf_inq_attid 866C try in data mode, check error 867 subroutine test_nf_rename_att() 868 USE tests 869 implicit none 870 871 integer ncid 872 integer vid 873 integer err 874 integer i 875 integer j 876 integer k 877 integer attnum 878 character*(NF_MAX_NAME) atnam 879 character*(NF_MAX_NAME) name 880 character*(NF_MAX_NAME) oldname 881 character*(NF_MAX_NAME) newname 882 integer nok !/* count of valid comparisons */ 883 integer datatype 884 integer attyp 885 integer length 886 integer attlength 887 integer ndx(1) 888 character*(MAX_NELS) text 889 doubleprecision value(MAX_NELS) 890 doubleprecision expect 891 892 nok = 0 893 894 err = nf_create(scratch, NF_NOCLOBBER, ncid) 895 if (err .ne. 0) then 896 call errore('nf_create: ', err) 897 return 898 end if 899 err = nf_rename_att(ncid, BAD_VARID, 'abc', 'newName') 900 if (err .ne. NF_ENOTVAR) 901 + call errore('bad var id: ', err) 902 call def_dims(ncid) 903 call def_vars(ncid) 904 call put_atts(ncid) 905 906 do 1, i = 0, NVARS 907 vid = VARID(i) 908 do 2, j = 1, NATTS(i) 909 atnam = ATT_NAME(j,i) 910 err = nf_rename_att(BAD_ID, vid, atnam, 'newName') 911 if (err .ne. NF_EBADID) 912 + call errore('bad ncid: ', err) 913 err = nf_rename_att(ncid, vid, 'noSuch', 'newName') 914 if (err .ne. NF_ENOTATT) 915 + call errore('bad attname: ', err) 916 newname = 'new_' // atnam 917 err = nf_rename_att(ncid, vid, atnam, newname) 918 if (err .ne. 0) 919 + call errore('nf_rename_att: ', err) 920 err = nf_inq_attid(ncid, vid, newname, attnum) 921 if (err .ne. 0) 922 + call errore('nf_inq_attid: ', err) 923 if (attnum .ne. j) 924 + call error('Unexpected attnum') 925 2 continue 926 1 continue 927 928C /* Close. Reopen & check */ 929 err = nf_close(ncid) 930 if (err .ne. 0) 931 + call errore('nf_close: ', err) 932 err = nf_open(scratch, NF_WRITE, ncid) 933 if (err .ne. 0) 934 + call errore('nf_open: ', err) 935 936 do 3, i = 0, NVARS 937 vid = VARID(i) 938 do 4, j = 1, NATTS(i) 939 atnam = ATT_NAME(j,i) 940 attyp = ATT_TYPE(j,i) 941 attlength = ATT_LEN(j,i) 942 newname = 'new_' // atnam 943 err = nf_inq_attname(ncid, vid, j, name) 944 if (err .ne. 0) 945 + call errore('nf_inq_attname: ', err) 946 if (name .ne. newname) 947 + call error('nf_inq_attname: unexpected name') 948 err = nf_inq_att(ncid, vid, name, datatype, length) 949 if (err .ne. 0) 950 + call errore('nf_inq_att: ', err) 951 if (datatype .ne. attyp) 952 + call error('nf_inq_att: unexpected type') 953 if (length .ne. attlength) 954 + call error('nf_inq_att: unexpected length') 955 if (datatype .eq. NF_CHAR) then 956 err = nf_get_att_text(ncid, vid, name, text) 957 if (err .ne. 0) 958 + call errore('nf_get_att_text: ', err) 959 do 5, k = 1, attlength 960 ndx(1) = k 961 expect = hash(datatype, -1, ndx) 962 if (ichar(text(k:k)) .ne. expect) then 963 call error( 964 + 'nf_get_att_text: unexpected value') 965 else 966 nok = nok + 1 967 end if 968 5 continue 969 else 970 err = nf_get_att_double(ncid, vid, name, value) 971 if (err .ne. 0) 972 + call errore('nf_get_att_double: ', err) 973 do 6, k = 1, attlength 974 ndx(1) = k 975 expect = hash(datatype, -1, ndx) 976 if (inRange(expect, datatype)) then 977 if (.not. equal(value(k),expect,datatype, 978 + NF_DOUBLE)) then 979 call error( 980 + 'nf_get_att_double: unexpected value') 981 else 982 nok = nok + 1 983 end if 984 end if 985 6 continue 986 end if 987 4 continue 988 3 continue 989 call print_nok(nok) 990 991C /* Now in data mode */ 992C /* Try making names even longer. Then restore original names */ 993 994 do 7, i = 0, NVARS 995 vid = VARID(i) 996 do 8, j = 1, NATTS(i) 997 atnam = ATT_NAME(j,i) 998 oldname = 'new_' // atnam 999 newname = 'even_longer_' // atnam 1000 err = nf_rename_att(ncid, vid, oldname, newname) 1001 if (err .ne. NF_ENOTINDEFINE) 1002 + call errore('longer name in data mode: ', err) 1003 err = nf_rename_att(ncid, vid, oldname, atnam) 1004 if (err .ne. 0) 1005 + call errore('nf_rename_att: ', err) 1006 err = nf_inq_attid(ncid, vid, atnam, attnum) 1007 if (err .ne. 0) 1008 + call errore('nf_inq_attid: ', err) 1009 if (attnum .ne. j) 1010 + call error('Unexpected attnum') 1011 8 continue 1012 7 continue 1013 1014 err = nf_close(ncid) 1015 if (err .ne. 0) 1016 + call errore('nf_close: ', err) 1017 1018 err = nf_delete(scratch) 1019 if (err .ne. 0) 1020 + call errori('delete of scratch file failed: ', err) 1021 end 1022 1023 1024C Test nf_del_att 1025C try with bad netCDF handle, check error 1026C try with bad variable handle, check error 1027C try with nonexisting att name, check error 1028C check that proper delete worked using: 1029C nf_inq_attid, nf_inq_natts, nf_inq_varnatts 1030 subroutine test_nf_del_att() 1031 USE tests 1032 implicit none 1033 1034 integer ncid 1035 integer err 1036 integer i 1037 integer j 1038 integer attnum 1039 integer na 1040 integer numatts 1041 integer vid 1042 character*(NF_MAX_NAME) name !/* of att */ 1043 1044 err = nf_create(scratch, NF_NOCLOBBER, ncid) 1045 if (err .ne. 0) then 1046 call errore('nf_create: ', err) 1047 return 1048 end if 1049 err = nf_del_att(ncid, BAD_VARID, 'abc') 1050 if (err .ne. NF_ENOTVAR) 1051 + call errore('bad var id: ', err) 1052 call def_dims(ncid) 1053 call def_vars(ncid) 1054 call put_atts(ncid) 1055 1056 do 1, i = 0, NVARS 1057 vid = VARID(i) 1058 numatts = NATTS(i) 1059 do 2, j = 1, numatts 1060 name = ATT_NAME(j,i) 1061 err = nf_del_att(BAD_ID, vid, name) 1062 if (err .ne. NF_EBADID) 1063 + call errore('bad ncid: ', err) 1064 err = nf_del_att(ncid, vid, 'noSuch') 1065 if (err .ne. NF_ENOTATT) 1066 + call errore('bad attname: ', err) 1067 err = nf_del_att(ncid, vid, name) 1068 if (err .ne. 0) 1069 + call errore('nf_del_att: ', err) 1070 err = nf_inq_attid(ncid, vid, name, attnum) 1071 if (err .ne. NF_ENOTATT) 1072 + call errore('bad attname: ', err) 1073 if (i .lt. 1) then 1074 err = nf_inq_natts(ncid, na) 1075 if (err .ne. 0) 1076 + call errore('nf_inq_natts: ', err) 1077 if (na .ne. numatts-j) then 1078 call errori('natts: expected: ', numatts-j) 1079 call errori('natts: got: ', na) 1080 end if 1081 end if 1082 err = nf_inq_varnatts(ncid, vid, na) 1083 if (err .ne. 0) 1084 + call errore('nf_inq_natts: ', err) 1085 if (na .ne. numatts-j) then 1086 call errori('natts: expected: ', numatts-j) 1087 call errori('natts: got: ', na) 1088 end if 1089 2 continue 1090 1 continue 1091 1092C /* Close. Reopen & check no attributes left */ 1093 err = nf_close(ncid) 1094 if (err .ne. 0) 1095 + call errore('nf_close: ', err) 1096 err = nf_open(scratch, NF_WRITE, ncid) 1097 if (err .ne. 0) 1098 + call errore('nf_open: ', err) 1099 err = nf_inq_natts(ncid, na) 1100 if (err .ne. 0) 1101 + call errore('nf_inq_natts: ', err) 1102 if (na .ne. 0) 1103 + call errori('natts: expected 0, got ', na) 1104 do 3, i = 0, NVARS 1105 vid = VARID(i) 1106 err = nf_inq_varnatts(ncid, vid, na) 1107 if (err .ne. 0) 1108 + call errore('nf_inq_natts: ', err) 1109 if (na .ne. 0) 1110 + call errori('natts: expected 0, got ', na) 1111 3 continue 1112 1113C /* restore attributes. change to data mode. try to delete */ 1114 err = nf_redef(ncid) 1115 if (err .ne. 0) 1116 + call errore('nf_redef: ', err) 1117 call put_atts(ncid) 1118 err = nf_enddef(ncid) 1119 if (err .ne. 0) 1120 + call errore('nf_enddef: ', err) 1121 1122 do 4, i = 0, NVARS 1123 vid = VARID(i) 1124 numatts = NATTS(i) 1125 do 5, j = 1, numatts 1126 name = ATT_NAME(j,i) 1127 err = nf_del_att(ncid, vid, name) 1128 if (err .ne. NF_ENOTINDEFINE) 1129 + call errore('in data mode: ', err) 1130 5 continue 1131 4 continue 1132 1133 err = nf_close(ncid) 1134 if (err .ne. 0) 1135 + call errore('nf_close: ', err) 1136 err = nf_delete(scratch) 1137 if (err .ne. 0) 1138 + call errori('delete of scratch file failed: ', err) 1139 end 1140 1141 1142C Test nf_set_fill 1143C try with bad netCDF handle, check error 1144C try in read-only mode, check error 1145C try with bad new_fillmode, check error 1146C try in data mode, check error 1147C check that proper set to NF_FILL works for record & non-record variables 1148C (note that it is not possible to test NF_NOFILL mode!) 1149C close file & create again for test using attribute _FillValue 1150 subroutine test_nf_set_fill() 1151 USE tests 1152 implicit none 1153 1154 integer ncid 1155 integer vid 1156 integer err 1157 integer i 1158 integer j 1159 integer old_fillmode 1160 integer nok !/* count of valid comparisons */ 1161 character*1 text 1162 doubleprecision value 1163 doubleprecision fill 1164 doubleprecision fill_array(1) 1165 integer index(MAX_RANK) 1166 1167 nok = 0 1168 value = 0 1169 1170C /* bad ncid */ 1171 err = nf_set_fill(BAD_ID, NF_NOFILL, old_fillmode) 1172 if (err .ne. NF_EBADID) 1173 + call errore('bad ncid: ', err) 1174 1175C /* try in read-only mode */ 1176 err = nf_open(testfile, NF_NOWRITE, ncid) 1177 if (err .ne. 0) 1178 + call errore('nf_open: ', err) 1179 err = nf_set_fill(ncid, NF_NOFILL, old_fillmode) 1180 if (err .ne. NF_EPERM) 1181 + call errore('read-only: ', err) 1182 err = nf_close(ncid) 1183 if (err .ne. 0) 1184 + call errore('nf_close: ', err) 1185 1186C /* create scratch */ 1187 err = nf_create(scratch, NF_NOCLOBBER, ncid) 1188 if (err .ne. 0) then 1189 call errore('nf_create: ', err) 1190 return 1191 end if 1192 1193C /* BAD_FILLMODE */ 1194 err = nf_set_fill(ncid, BAD_FILLMODE, old_fillmode) 1195 if (err .ne. NF_EINVAL) 1196 + call errore('bad fillmode: ', err) 1197 1198C /* proper calls */ 1199 err = nf_set_fill(ncid, NF_NOFILL, old_fillmode) 1200 if (err .ne. 0) 1201 + call errore('nf_set_fill: ', err) 1202 if (old_fillmode .ne. NF_FILL) 1203 + call errori('Unexpected old fill mode: ', old_fillmode) 1204 err = nf_set_fill(ncid, NF_FILL, old_fillmode) 1205 if (err .ne. 0) 1206 + call errore('nf_set_fill: ', err) 1207 if (old_fillmode .ne. NF_NOFILL) 1208 + call errori('Unexpected old fill mode: ', old_fillmode) 1209 1210C /* define dims & vars */ 1211 call def_dims(ncid) 1212 call def_vars(ncid) 1213 1214C /* Change to data mode. Set fillmode again */ 1215 err = nf_enddef(ncid) 1216 if (err .ne. 0) 1217 + call errore('nf_enddef: ', err) 1218 err = nf_set_fill(ncid, NF_FILL, old_fillmode) 1219 if (err .ne. 0) 1220 + call errore('nf_set_fill: ', err) 1221 if (old_fillmode .ne. NF_FILL) 1222 + call errori('Unexpected old fill mode: ', old_fillmode) 1223 1224C /* Write record number NRECS to force writing of preceding records */ 1225C /* Assumes variable cr is char vector with UNLIMITED dimension */ 1226 err = nf_inq_varid(ncid, 'cr', vid) 1227 if (err .ne. 0) 1228 + call errore('nf_inq_varid: ', err) 1229 index(1) = NRECS 1230 text = char(NF_FILL_CHAR) 1231 err = nf_put_var1_text(ncid, vid, index, text) 1232 if (err .ne. 0) 1233 + call errore('nf_put_var1_text: ', err) 1234 1235C /* get all variables & check all values equal default fill */ 1236 do 1, i = 1, NVARS 1237 if (var_type(i) .eq. NF_CHAR) then 1238 fill = NF_FILL_CHAR 1239 else if (var_type(i) .eq. NF_BYTE) then 1240 fill = NF_FILL_BYTE 1241 else if (var_type(i) .eq. NF_SHORT) then 1242 fill = NF_FILL_SHORT 1243 else if (var_type(i) .eq. NF_INT) then 1244 fill = NF_FILL_INT 1245 else if (var_type(i) .eq. NF_FLOAT) then 1246 fill = NF_FILL_FLOAT 1247 else if (var_type(i) .eq. NF_DOUBLE) then 1248 fill = NF_FILL_DOUBLE 1249 else 1250 stop 2 1251 end if 1252 1253 do 2, j = 1, var_nels(i) 1254 err = index2indexes(j, var_rank(i), var_shape(1,i), 1255 + index) 1256 if (err .ne. 0) 1257 + call error('error in index2indexes()') 1258 if (var_type(i) .eq. NF_CHAR) then 1259 err = nf_get_var1_text(ncid, i, index, text) 1260 if (err .ne. 0) 1261 + call errore('nf_get_var1_text failed: ',err) 1262 value = ichar(text) 1263 else 1264 err = nf_get_var1_double(ncid, i, index, value) 1265 if (err .ne. 0) 1266 + call errore('nf_get_var1_double failed: ',err) 1267 end if 1268 if (value .ne. fill .and. 1269 + abs((fill - value)/fill) .gt. 1.0e-9) then 1270 call errord('Unexpected fill value: ', value) 1271 else 1272 nok = nok + 1 1273 end if 1274 2 continue 1275 1 continue 1276 1277C /* close scratch & create again for test using attribute _FillValue */ 1278 err = nf_close(ncid) 1279 if (err .ne. 0) 1280 + call errore('nf_close: ', err) 1281 err = nf_create(scratch, NF_CLOBBER, ncid) 1282 if (err .ne. 0) then 1283 call errore('nf_create: ', err) 1284 return 1285 end if 1286 call def_dims(ncid) 1287 call def_vars(ncid) 1288 1289C /* set _FillValue = 42 for all vars */ 1290 fill = 42 1291 fill_array(1) = fill 1292 text = char(int(fill)) 1293 do 3, i = 1, NVARS 1294 if (var_type(i) .eq. NF_CHAR) then 1295 err = nf_put_att_text(ncid, i, '_FillValue', 1, text) 1296 if (err .ne. 0) 1297 + call errore('nf_put_att_text: ', err) 1298 else 1299 err = nf_put_att_double(ncid, i, '_FillValue', 1300 + var_type(i),1,fill_array) 1301 if (err .ne. 0) 1302 + call errore('nf_put_att_double: ', err) 1303 end if 1304 3 continue 1305 1306C /* data mode. write records */ 1307 err = nf_enddef(ncid) 1308 if (err .ne. 0) 1309 + call errore('nf_enddef: ', err) 1310 index(1) = NRECS 1311 err = nf_put_var1_text(ncid, vid, index, text) 1312 if (err .ne. 0) 1313 + call errore('nf_put_var1_text: ', err) 1314 1315C /* get all variables & check all values equal 42 */ 1316 do 4, i = 1, NVARS 1317 do 5, j = 1, var_nels(i) 1318 err = index2indexes(j, var_rank(i), var_shape(1,i), 1319 + index) 1320 if (err .ne. 0) 1321 + call error('error in index2indexes') 1322 if (var_type(i) .eq. NF_CHAR) then 1323 err = nf_get_var1_text(ncid, i, index, text) 1324 if (err .ne. 0) 1325 + call errore('nf_get_var1_text failed: ',err) 1326 value = ichar(text) 1327 else 1328 err = nf_get_var1_double(ncid, i, index, value) 1329 if (err .ne. 0) 1330 + call errore('nf_get_var1_double failed: ', err) 1331 end if 1332 if (value .ne. fill) then 1333 call errord(' Value expected: ', fill) 1334 call errord(' Value read: ', value) 1335 else 1336 nok = nok + 1 1337 end if 1338 5 continue 1339 4 continue 1340 call print_nok(nok) 1341 1342 err = nf_close(ncid) 1343 if (err .ne. 0) 1344 + call errore('nf_close: ', err) 1345 err = nf_delete(scratch) 1346 if (err .ne. 0) 1347 + call errori('delete of scratch file failed: ', err) 1348 end 1349 1350C * Test nc_set_default_format 1351C * try with bad default format 1352C * try with NULL old_formatp 1353C * try in data mode, check error 1354C * check that proper set to NC_FILL works for record & non-record variables 1355C * (note that it is not possible to test NC_NOFILL mode!) 1356C * close file & create again for test using attribute _FillValue 1357 subroutine test_nf_set_default_format() 1358 USE tests 1359 implicit none 1360 1361 integer ncid 1362 integer err 1363 integer i 1364 integer version 1365 integer old_format 1366 integer nf_get_file_version 1367 1368C /* bad format */ 1369 err = nf_set_default_format(99, old_format) 1370 IF (err .ne. NF_EINVAL) 1371 + call errore("bad default format: status = %d", err) 1372 1373C /* Cycle through available formats. (actually netcdf-4 formats are 1374C ignored for the moment - ed 5/15/5) */ 1375 do 1 i=1, 2 1376 err = nf_set_default_format(i, old_format) 1377 if (err .ne. 0) 1378 + call errore("setting classic format: status = %d", err) 1379 err = nf_create(scratch, NF_CLOBBER, ncid) 1380 if (err .ne. 0) call errore("bad nf_create: status = %d", err) 1381 err = nf_put_att_text(ncid, NF_GLOBAL, "testatt", 1382 + 4, "blah") 1383 if (err .ne. 0) call errore("bad put_att: status = %d", err) 1384 err = nf_close(ncid) 1385 if (err .ne. 0) call errore("bad close: status = %d", err) 1386 err = nf_get_file_version(scratch, version) 1387 if (err .ne. 0) call errore("bad file version = %d", err) 1388 if (version .ne. i) 1389 + call errore("bad file version = %d", err) 1390 1 continue 1391 1392C /* Remove the left-over file. */ 1393C err = nf_delete(scratch) 1394 if (err .ne. 0) call errore("remove failed", err) 1395 end 1396 1397C This function looks in a file for the netCDF magic number. 1398 integer function nf_get_file_version(path, version) 1399 USE tests 1400 implicit none 1401 1402 character*(*) path 1403 integer version, iosnum 1404 character magic*4 1405 integer ver 1406 integer f 1407 parameter (f = 10) 1408 1409 open(f, file=path, status='OLD', form='UNFORMATTED', 1410 + access='DIRECT', recl=4) 1411 1412C Assume this is not a netcdf file. 1413 nf_get_file_version = NF_ENOTNC 1414 version = 0 1415 1416C Read the magic number, the first 4 bytes of the file. 1417 read(f, rec=1, err = 1) magic 1418 1419C If the first three characters are not "CDF" we're done. 1420 if (index(magic, 'CDF') .eq. 1) then 1421 ver = ichar(magic(4:4)) 1422 if (ver .eq. 1) then 1423 version = 1 1424 nf_get_file_version = NF_NOERR 1425 elseif (ver .eq. 2) then 1426 version = 2 1427 nf_get_file_version = NF_NOERR 1428 endif 1429 endif 1430 1431 1 close(f) 1432 return 1433 end 1434