1!******************************************************************** 2! Copyright 1993, UCAR/Unidata 3! See netcdf/COPYRIGHT file for copying and redistribution conditions. 4! Russ Rew 1993 5!******************************************************************** 6 7! 8! program to test the netCDF-2 Fortran API 9! 10 program ftest 11 12 use netcdf_f03 13 14! name of first test cdf 15 character*31 name 16! name of second test cdf 17 character*31 name2 18 19! Returned error code. 20 integer iret 21! netCDF ID 22 integer ncid 23! ID of dimension lat 24 integer latdim 25! ID of dimension lon 26 integer londim 27! ID of dimension level 28 integer leveldim 29! ID of dimension time 30 integer timedim 31! ID of dimension len 32 integer lendim 33 34! Count the errors. 35 integer nfails 36 37! variable used to control error-handling behavior 38 integer ncopts 39 integer dimsiz(MAXNCDIM) 40! allowable roundoff 41 common /dims/timedim, latdim, londim, leveldim, lendim, 42 + dimsiz 43 data name/'f03test_test.nc'/ 44 data name2/'f03test_copy.nc'/ 45 46 print *, '' 47 print *,'*** Testing netCDF-2 Fortran 77 API.' 48 49100 format(' *** testing ', a, ' ...') 50! set error-handling to verbose and non-fatal 51 ncopts = NCVERBOS 52 call ncpopt(ncopts) 53 54! This will be a count of how many failures we experience. 55 nfails = 0 56 57! create a netCDF named 'test.nc' 58 write(*,100) 'nccre' 59 ncid = nccre(name, NCCLOB, iret) 60 if (ncid .eq. -1) then nfails = nfails + 1 61 62! test ncddef 63 write(*,100) 'ncddef' 64 call tncddef(ncid, nfails) 65 66! test ncvdef 67 write(*,100) 'ncvdef' 68 call tncvdef(ncid, nfails) 69 70! test ncapt 71 write(*, 100) 'ncapt, ncaptc' 72 call tncapt(ncid, nfails) 73 74! close 'test.nc' 75 write(*, 100) 'ncclos' 76 call ncclos(ncid, iret) 77 if (ncid .eq. -1) then nfails = nfails + 1 78 79! test ncvpt1 80 write(*, 100) 'ncvpt1' 81 call tncvpt1(name, nfails) 82 83! test ncvgt1 84 write(*, 100) 'ncvgt1' 85 call tncvgt1(name, nfails) 86 87! test ncvpt 88 write(*, 100) 'ncvpt' 89 call tncvpt(name, nfails) 90 91! test ncinq 92 write(*, 100) 'ncopn, ncinq, ncdinq, ncvinq, ncanam, ncainq' 93 call tncinq(name, nfails) 94 95! test ncvgt 96 write(*, 100) 'ncvgt, ncvgtc' 97 call tncvgt(name, nfails) 98 99! test ncagt 100 write(*, 100) 'ncagt, ncagtc' 101 call tncagt(name, nfails) 102 103! test ncredf 104 write(*, 100) 'ncredf, ncdren, ncvren, ncaren, ncendf' 105 call tncredf(name, nfails) 106 107 call tncinq(name, nfails) 108 109! test ncacpy 110 write(*, 100) 'ncacpy' 111 call tncacpy(name, name2, nfails) 112 113! test ncadel 114 write(*, 100) 'ncadel' 115 call tncadel(name2, nfails) 116 117! test fill values 118 write(*, 100) 'fill values' 119 call tfills(nfails) 120 121 print *,'Total number of failures: ', nfails 122 if (nfails .ne. 0) stop 2 123 124 print *,'*** SUCCESS!' 125 126 end 127! 128! subroutine to test ncacpy 129! 130 subroutine tncacpy(iname, oname, nfails) 131 use netcdf_f03 132 character*31 iname, oname 133 integer ndims, nvars, natts, recdim, iret 134 character*31 vname, attnam 135 integer attype, attlen 136 integer vartyp, nvdims, vdims(MAXVDIMS), nvatts 137 integer lenstr 138! existing netCDF id 139 integer incdf 140! netCDF id of the output netCDF file to which the attribute 141! will be copied 142 integer outcdf 143 144 integer mattlen 145 parameter (mattlen = 80) 146 character*80 charval 147 doubleprecision doubval(2) 148 real flval(2) 149 integer lngval(2) 150 NCSHORT_T shval(2) 151 integer i, j, k 152 character*31 varnam, attname(2,7), gattnam(2) 153 NCBYTE_T bytval(2) 154 common /atts/attname, gattnam 155 NCSHORT_T svalidrg(2) 156 real rvalidrg(2) 157 integer lvalidrg(2) 158 doubleprecision dvalidrg(2) 159 NCBYTE_T bvalidrg(2) 160 character*31 gavalue(2), cavalue(2) 161 real epsilon 162 163 data bvalidrg/-127,127/ 164 data svalidrg/-100,100/ 165 data lvalidrg/0,360/ 166 data rvalidrg/0.0, 5000.0/ 167 data dvalidrg/0D0,500D0/ 168 data gavalue/'NWS', '88/10/25 12:00:00'/ 169 data cavalue/'test string', 'a'/ 170 data lenstr/80/ 171 data epsilon /.000001/ 172 173 incdf = ncopn(iname, NCNOWRIT, iret) 174 if (iret .ne. 0) nfails = nfails + 1 175 176 outcdf = nccre(oname, NCCLOB, iret) 177 if (iret .ne. 0) nfails = nfails + 1 178 179 call tncddef(outcdf, nfails) 180 call tncvdef(outcdf, nfails) 181 call ncinq (incdf, ndims, nvars, natts, recdim, iret) 182 if (iret .ne. 0) nfails = nfails + 1 183 do 5 j = 1, natts 184 call ncanam (incdf, NCGLOBAL, j, attnam, iret) 185 if (iret .ne. 0) nfails = nfails + 1 186 call ncacpy (incdf, NCGLOBAL, attnam, outcdf, NCGLOBAL, iret) 187 if (iret .ne. 0) nfails = nfails + 1 188 5 continue 189 do 10 i = 1, nvars 190 call ncvinq (incdf, i, vname, vartyp, nvdims, 191 + vdims, nvatts, iret) 192 if (iret .ne. 0) nfails = nfails + 1 193 do 20 k = 1, nvatts 194 call ncanam (incdf, i, k, attnam, iret) 195 if (iret .ne. 0) nfails = nfails + 1 196 call ncacpy (incdf, i, attnam, outcdf, i, iret) 197 if (iret .ne. 0) nfails = nfails + 1 198 20 continue 199 10 continue 200! 201! get global attributes first 202! 203 do 100 i = 1, natts 204 call ncanam (outcdf, NCGLOBAL, i, attnam, iret) 205 if (iret .ne. 0) nfails = nfails + 1 206 call ncainq (outcdf, NCGLOBAL, attnam, attype, attlen, 207 + iret) 208 if (iret .ne. 0) nfails = nfails + 1 209 if (attlen .gt. mattlen) then 210 write (*,*) 'global attribute too big!', attlen, mattlen 211 stop 2 212 else if (attype .eq. NCBYTE) then 213 call ncagt (outcdf, NCBYTE, attnam, bytval, iret) 214 if (iret .ne. 0) nfails = nfails + 1 215 else if (attype .eq. NCCHAR) then 216 call ncagtc (outcdf, NCGLOBAL, attnam, charval, 217 + lenstr, iret) 218 if (iret .ne. 0) nfails = nfails + 1 219 if (attnam .ne. gattnam(i)) write(*,*) 'error in ncagt G' 220 if (charval .ne. gavalue(i)) 221 + write(*,*) 'error in ncagt G2', lenstr, charval, gavalue(i) 222 charval = ' ' 223 else if (attype .eq. NCSHORT) then 224 call ncagt (outcdf, NCGLOBAL, attnam, shval, iret) 225 if (iret .ne. 0) nfails = nfails + 1 226 else if (attype .eq. NCLONG) then 227 call ncagt (outcdf, NCGLOBAL, attnam, lngval, iret) 228 if (iret .ne. 0) nfails = nfails + 1 229 else if (attype .eq. NCFLOAT) then 230 call ncagt (outcdf, NCGLOBAL, attnam, flval, iret) 231 if (iret .ne. 0) nfails = nfails + 1 232 else 233 call ncagt (outcdf, NCGLOBAL, attnam, doubval,iret) 234 if (iret .ne. 0) nfails = nfails + 1 235 end if 236 100 continue 237! 238! get variable attributes 239! 240 do 200 i = 1, nvars 241 call ncvinq (outcdf, i, varnam, vartyp, nvdims, vdims, 242 + nvatts, iret) 243 if (iret .ne. 0) nfails = nfails + 1 244 do 250 j = 1, nvatts 245 call ncanam (outcdf, i, j, attnam, iret) 246 if (iret .ne. 0) nfails = nfails + 1 247 call ncainq (outcdf, i, attnam, attype, attlen, 248 + iret) 249 if (iret .ne. 0) nfails = nfails + 1 250 if (attlen .gt. mattlen) then 251 write (*,*) 'variable ', i, 'attribute too big !' 252 stop 2 253 else 254 if (attype .eq. NCBYTE) then 255 call ncagt (outcdf, i, attnam, bytval, 256 + iret) 257 if (iret .ne. 0) nfails = nfails + 1 258 if (attnam .ne. attname(j,i)) 259 + write(*,*) 'error in ncagt BYTE N' 260 if (bytval(j) .ne. bvalidrg(j)) write(*,*) 261 + 'ncacpy: byte ', bytval(j), ' .ne. ', bvalidrg(j) 262 else if (attype .eq. NCCHAR) then 263 call ncagtc (outcdf, i, attnam, charval, 264 + lenstr, iret) 265 if (iret .ne. 0) nfails = nfails + 1 266 if (attnam .ne. attname(j,i)) 267 + write(*,*) 'error in ncagt CHAR N' 268 if (charval .ne. cavalue(j)) 269 + write(*,*) 'error in ncagt' 270 charval = ' ' 271 else if (attype .eq. NCSHORT) then 272 call ncagt (outcdf, i, attnam, shval, 273 + iret) 274 if (iret .ne. 0) nfails = nfails + 1 275 if (attnam .ne. attname(j,i)) 276 + write(*,*) 'error in ncagt SHORT N' 277 if (shval(j) .ne. svalidrg(j)) then 278 write(*,*) 'error in ncagt SHORT' 279 end if 280 else if (attype .eq. NCLONG) then 281 call ncagt (outcdf, i, attnam, lngval, 282 + iret) 283 if (iret .ne. 0) nfails = nfails + 1 284 if (attnam .ne. attname(j,i)) 285 + write(*,*) 'error in ncagt LONG N' 286 if (lngval(j) .ne. lvalidrg(j)) 287 + write(*,*) 'error in ncagt LONG' 288 else if (attype .eq. NCFLOAT) then 289 call ncagt (outcdf, i, attnam, flval, 290 + iret) 291 if (iret .ne. 0) nfails = nfails + 1 292 if (attnam .ne. attname(j,i)) 293 + write(*,*) 'error in ncagt FLOAT N' 294 if (flval(j) .ne. rvalidrg(j)) 295 + write(*,*) 'error in ncagt FLOAT' 296 else if (attype .eq. NCDOUBLE) then 297 call ncagt (outcdf, i, attnam, doubval, 298 + iret) 299 if (iret .ne. 0) nfails = nfails + 1 300 if (attnam .ne. attname(j,i)) 301 + write(*,*) 'error in ncagt DOUBLE N' 302 if ( abs(doubval(j) - dvalidrg(j)) .gt. epsilon) 303 + write(*,*) 'error in ncagt DOUBLE' 304 end if 305 end if 306 250 continue 307 200 continue 308 call ncclos(incdf, iret) 309 if (iret .ne. 0) nfails = nfails + 1 310 call ncclos(outcdf, iret) 311 if (iret .ne. 0) nfails = nfails + 1 312 return 313 end 314 315 316 317! 318! subroutine to test ncadel 319! 320 subroutine tncadel (cdfname, nfails) 321 use netcdf_f03 322 character*31 cdfname 323 324 integer bid, sid, lid, fid, did, cid, chid 325 common /vars/bid, sid, lid, fid, did, cid, chid 326 integer ncid, iret, i, j 327 integer ndims, nvars, natts, recdim 328 integer vartyp, nvdims, vdims(MAXVDIMS), nvatts 329 character*31 varnam, attnam 330 331 ncid = ncopn(cdfname, NCWRITE, iret) 332 if (iret .ne. 0) nfails = nfails + 1 333! put cdf in define mode 334 call ncredf (ncid,iret) 335 if (iret .ne. 0) nfails = nfails + 1 336! get number of global attributes 337 call ncinq (ncid, ndims, nvars, natts, recdim, iret) 338 if (iret .ne. 0) nfails = nfails + 1 339 do 10 i = natts, 1, -1 340! get name of global attribute 341 call ncanam (ncid, NCGLOBAL, i, attnam, iret) 342 if (iret .ne. 0) nfails = nfails + 1 343! delete global attribute 344 call ncadel (ncid, NCGLOBAL, attnam, iret) 345 if (iret .ne. 0) nfails = nfails + 1 346 10 continue 347 348 do 100 i = 1, nvars 349! get number of variable attributes 350 call ncvinq (ncid, i, varnam, vartyp, nvdims, vdims, 351 + nvatts, iret) 352 if (iret .ne. 0) nfails = nfails + 1 353 do 200 j = nvatts, 1, -1 354 call ncanam (ncid, i, j, attnam, iret) 355 if (iret .ne. 0) nfails = nfails + 1 356 call ncadel (ncid, i, attnam, iret) 357 if (iret .ne. 0) nfails = nfails + 1 358 200 continue 359 100 continue 360 call ncinq (ncid, ndims, nvars, natts, recdim, iret) 361 if (iret .ne. 0) nfails = nfails + 1 362 if (natts .ne. 0) write(*,*) 'error in ncadel' 363! put netCDF into data mode 364 call ncendf (ncid, iret) 365 if (iret .ne. 0) nfails = nfails + 1 366 call ncclos (ncid, iret) 367 if (iret .ne. 0) nfails = nfails + 1 368 return 369 end 370 371! 372! subroutine to test ncagt and ncagtc 373 374 subroutine tncagt(cdfname, nfails) 375 use netcdf_f03 376 character*31 cdfname 377 378! maximum length of an attribute 379 integer mattlen 380 parameter (mattlen = 80) 381 integer ncid, ndims, nvars, natts, recdim 382 integer bid, sid, lid, fid, did, cid, chid 383 common /vars/bid, sid, lid, fid, did, cid, chid 384 integer i, j 385 integer attype, attlen, lenstr, iret 386 character*31 attnam 387 character*80 charval 388 doubleprecision doubval(2) 389 real flval(2) 390 integer lngval(2) 391 NCSHORT_T shval(2) 392 NCBYTE_T bytval(2) 393 integer vartyp, nvdims, vdims(MAXVDIMS), nvatts 394 395 character*31 varnam, attname(2,7), gattnam(2) 396 common /atts/attname, gattnam 397 NCSHORT_T svalidrg(2) 398 real rvalidrg(2) 399 integer lvalidrg(2) 400 doubleprecision dvalidrg(2) 401 NCBYTE_T bvalidrg(2) 402 character*31 gavalue(2), cavalue(2) 403 real epsilon 404 405 data bvalidrg/-127,127/ 406 data svalidrg/-100,100/ 407 data lvalidrg/0,360/ 408 data rvalidrg/0.0, 5000.0/ 409 data dvalidrg/0D0,500D0/ 410 data gavalue/'NWS', '88/10/25 12:00:00'/ 411 data cavalue/'test string', 'a'/ 412 data lenstr/80/ 413 data epsilon /.000001/ 414 415 ncid = ncopn (cdfname, NCNOWRIT, iret) 416 if (iret .ne. 0) nfails = nfails + 1 417 call ncinq (ncid, ndims, nvars, natts, recdim, iret) 418 if (iret .ne. 0) nfails = nfails + 1 419! 420! get global attributes first 421! 422 do 10 i = 1, natts 423! get name of attribute 424 call ncanam (ncid, NCGLOBAL, i, attnam, iret) 425 if (iret .ne. 0) nfails = nfails + 1 426! get attribute type and length 427 call ncainq (ncid, NCGLOBAL, attnam, attype, attlen, 428 + iret) 429 if (iret .ne. 0) nfails = nfails + 1 430 if (attlen .gt. mattlen) then 431 write (*,*) 'global attribute too big!' 432 stop 2 433 else if (attype .eq. NCBYTE) then 434 call ncagt (ncid, NCBYTE, attnam, bytval, iret) 435 if (iret .ne. 0) nfails = nfails + 1 436 else if (attype .eq. NCCHAR) then 437 call ncagtc (ncid, NCGLOBAL, attnam, charval, 438 + lenstr, iret) 439 if (iret .ne. 0) nfails = nfails + 1 440 if (attnam .ne. gattnam(i)) write(*,*) 'error in ncagt' 441 if (charval .ne. gavalue(i)) write(*,*) 'error in ncagt' 442 charval = ' ' 443 else if (attype .eq. NCSHORT) then 444 call ncagt (ncid, NCGLOBAL, attnam, shval, iret) 445 if (iret .ne. 0) nfails = nfails + 1 446 else if (attype .eq. NCLONG) then 447 call ncagt (ncid, NCGLOBAL, attnam, lngval, iret) 448 if (iret .ne. 0) nfails = nfails + 1 449 else if (attype .eq. NCFLOAT) then 450 call ncagt (ncid, NCGLOBAL, attnam, flval, iret) 451 if (iret .ne. 0) nfails = nfails + 1 452 else 453 call ncagt (ncid, NCGLOBAL, attnam, doubval,iret) 454 if (iret .ne. 0) nfails = nfails + 1 455 end if 456 10 continue 457 458! 459! get variable attributes 460! 461 do 20 i = 1, nvars 462 call ncvinq (ncid, i, varnam, vartyp, nvdims, vdims, 463 + nvatts, iret) 464 if (iret .ne. 0) nfails = nfails + 1 465 do 25 j = 1, nvatts 466 call ncanam (ncid, i, j, attnam, iret) 467 if (iret .ne. 0) nfails = nfails + 1 468 call ncainq (ncid, i, attnam, attype, attlen, 469 + iret) 470 if (iret .ne. 0) nfails = nfails + 1 471 if (attlen .gt. mattlen) then 472 write (*,*) 'variable ', i, 'attribute too big !' 473 stop 2 474 else 475 if (attype .eq. NCBYTE) then 476 call ncagt (ncid, i, attnam, bytval, 477 + iret) 478 if (iret .ne. 0) nfails = nfails + 1 479 if (attnam .ne. attname(j,i)) 480 + write(*,*) 'error in ncagt BYTE name' 481 if (bytval(j) .ne. bvalidrg(j)) write(*,*) 482 + 'ncacpy: byte ', bytval(j), ' .ne. ', bvalidrg(j) 483 else if (attype .eq. NCCHAR) then 484 call ncagtc (ncid, i, attnam, charval, 485 + lenstr, iret) 486 if (iret .ne. 0) nfails = nfails + 1 487 if (attnam .ne. attname(j,i)) 488 + write(*,*) 'error in ncagt CHAR name' 489 if (charval .ne. cavalue(j)) 490 + write(*,*) 'error in ncagt CHAR name' 491 charval = ' ' 492 else if (attype .eq. NCSHORT) then 493 call ncagt (ncid, i, attnam, shval, 494 + iret) 495 if (iret .ne. 0) nfails = nfails + 1 496 if (attnam .ne. attname(j,i)) 497 + write(*,*) 'error in ncagt SHORT name' 498 if (shval(j) .ne. svalidrg(j)) then 499 write(*,*) 'error in ncagt SHORT' 500 end if 501 else if (attype .eq. NCLONG) then 502 call ncagt (ncid, i, attnam, lngval, 503 + iret) 504 if (iret .ne. 0) nfails = nfails + 1 505 if (attnam .ne. attname(j,i)) 506 + write(*,*) 'error in ncagt LONG name' 507 if (lngval(j) .ne. lvalidrg(j)) 508 + write(*,*) 'error in ncagt LONG' 509 else if (attype .eq. NCFLOAT) then 510 call ncagt (ncid, i, attnam, flval, 511 + iret) 512 if (iret .ne. 0) nfails = nfails + 1 513 if (attnam .ne. attname(j,i)) 514 + write(*,*) 'error in ncagt FLOAT name' 515 if (flval(j) .ne. rvalidrg(j)) 516 + write(*,*) 'error in ncagt FLOAT' 517 else if (attype .eq. NCDOUBLE) then 518 call ncagt (ncid, i, attnam, doubval, 519 + iret) 520 if (iret .ne. 0) nfails = nfails + 1 521 if (attnam .ne. attname(j,i)) 522 + write(*,*) 'error in ncagt DOUBLE name' 523 if ( abs(doubval(j) - dvalidrg(j)) .gt. epsilon) 524 + write(*,*) 'error in ncagt DOUBLE' 525 end if 526 end if 527 25 continue 528 20 continue 529 call ncclos(ncid, iret) 530 if (iret .ne. 0) nfails = nfails + 1 531 return 532 end 533! 534! subroutine to test ncapt 535! 536 subroutine tncapt (ncid, nfails) 537 use netcdf_f03 538 integer ncid, iret 539 540! attribute vectors 541 NCSHORT_T svalidrg(2) 542 real rvalidrg(2) 543 integer lvalidrg(2) 544 doubleprecision dvalidrg(2) 545 NCBYTE_T bvalidrg(2) 546 547! variable ids 548 integer bid, sid, lid, fid, did, cid, chid 549 common /vars/bid, sid, lid, fid, did, cid, chid 550 551! assign attributes 552 553! 554! byte 555! 556 557 bvalidrg(1) = -127 558 bvalidrg(2) = 127 559 call ncapt (ncid, bid, 'validrange', NCBYTE, 2, 560 +bvalidrg, iret) 561 if (iret .ne. 0) nfails = nfails + 1 562 563! 564! short 565! 566 567 svalidrg(1) = -100 568 svalidrg(2) = 100 569 call ncapt (ncid, sid, 'validrange', NCSHORT, 2, 570 +svalidrg, iret) 571 if (iret .ne. 0) nfails = nfails + 1 572 573! 574! long 575! 576 577 lvalidrg(1) = 0 578 lvalidrg(2) = 360 579 call ncapt (ncid, lid, 'validrange', NCLONG, 2, 580 +lvalidrg, iret) 581 if (iret .ne. 0) nfails = nfails + 1 582 583! 584! float 585! 586 587 rvalidrg(1) = 0.0 588 rvalidrg(2) = 5000.0 589 call ncapt (ncid, fid, 'validrange', NCFLOAT, 2, 590 +rvalidrg, iret) 591 if (iret .ne. 0) nfails = nfails + 1 592 593! 594! double 595! 596 597 dvalidrg(1) = 0D0 598 dvalidrg(2) = 500D0 599 call ncapt (ncid, did, 'validrange', NCDOUBLE, 2, 600 +dvalidrg, iret) 601 if (iret .ne. 0) nfails = nfails + 1 602 603! 604! global 605! 606 607 call ncaptc (ncid, NCGLOBAL, 'source', NCCHAR, 3, 608 +'NWS', iret) 609 if (iret .ne. 0) nfails = nfails + 1 610 call ncaptc (ncid, NCGLOBAL, 'basetime', NCCHAR, 17, 611 +'88/10/25 12:00:00', iret) 612 if (iret .ne. 0) nfails = nfails + 1 613 614! 615! char 616! 617 618 call ncaptc (ncid, chid, 'longname', NCCHAR, 11, 619 +'test string', iret) 620 if (iret .ne. 0) nfails = nfails + 1 621 622 call ncaptc (ncid, chid, 'id', NCCHAR, 1, 623 +'a', iret) 624 if (iret .ne. 0) nfails = nfails + 1 625 626 return 627 end 628 629! 630! initialize variables in labelled common blocks 631! 632 block data 633 common /cdims/ dimnam 634 common /dims/timedim, latdim, londim, leveldim, lendim, 635 + dimsiz 636 common /varn/varnam 637 common /atts/attname, gattnam 638 integer latdim, londim, leveldim, timedim, lendim 639 640! should use netcdf_f03 for MAXNCDIM, but it has EXTERNAL 641! declaration, which is not permitted in a BLOCK DATA unit. 642 643 integer dimsiz(1024) 644 character*31 dimnam(1024) 645 character*31 varnam(7) 646 character*31 attname(2,7) 647 character*31 gattnam(2) 648 649 data dimnam /'time', 'lat', 'lon', 'level', 650 + 'length', 1019*'0'/ 651 data dimsiz /4, 5, 5, 4, 80, 1019*0/ 652 data varnam/'bytev', 'shortv', 'longv', 'floatv', 'doublev', 653 + 'chv', 'cv'/ 654 655 data attname/'validrange', '0', 'validrange', '0', 'validrange', 656 + '0', 'validrange', '0', 'validrange', '0', 'longname', 'id', 657 + '0', '0'/ 658 data gattnam/'source','basetime'/ 659 end 660 661 662! 663! subroutine to test ncddef 664! 665 666 subroutine tncddef(ncid, nfails) 667 use netcdf_f03 668 integer ncid 669 670! sizes of dimensions of 'test.nc' and 'copy.nc' 671 integer ndims 672 parameter(ndims=5) 673! dimension ids 674 integer latdim, londim, leveldim, timedim, lendim 675 integer iret 676! function to define a netCDF dimension 677 integer dimsiz(MAXNCDIM) 678 character*31 dimnam(MAXNCDIM) 679 680 common /dims/timedim, latdim, londim, leveldim, lendim, 681 + dimsiz 682 common /cdims/ dimnam 683 684! define dimensions 685 timedim = ncddef(ncid, dimnam(1), NCUNLIM, iret) 686 if (iret .ne. 0) nfails = nfails + 1 687 latdim = ncddef(ncid, dimnam(2), dimsiz(2), iret) 688 if (iret .ne. 0) nfails = nfails + 1 689 londim = ncddef(ncid, dimnam(3), dimsiz(3), iret) 690 if (iret .ne. 0) nfails = nfails + 1 691 leveldim = ncddef(ncid, dimnam(4), dimsiz(4), iret) 692 if (iret .ne. 0) nfails = nfails + 1 693 lendim = ncddef(ncid, dimnam(5), dimsiz(5), iret) 694 if (iret .ne. 0) nfails = nfails + 1 695 return 696 end 697! 698! subroutine to test ncinq, ncdinq, ncdid, ncvinq, ncanam 699! and ncainq 700! 701 subroutine tncinq(cdfname, nfails) 702 use netcdf_f03 703 character*31 cdfname 704 705! netCDF id 706 integer ncid 707! returned number of dimensions 708 integer ndims 709! returned number of variables 710 integer nvars 711! returned number of global attributes 712 integer natts 713! returned id of the unlimited dimension 714 integer recdim 715! returned error code 716 integer iret 717! returned name of record dimension 718 character*31 recnam 719! returned size of record dimension 720 integer recsiz 721! loop control variables 722 integer i, j, k 723! returned size of dimension 724 integer dsize 725! returned dimension ID 726 integer dimid 727! returned dimension name 728 character*31 dname 729! returned variable name 730 character*31 vname 731! returned attribute name 732 character*31 attnam 733! returned netCDF datatype of variable 734 integer vartyp 735! returned number of variable dimensions 736 integer nvdims 737! returned number of variable attributes 738 integer nvatts 739! returned vector of nvdims dimension IDS corresponding to the 740! variable dimensions 741 integer vdims(MAXNCDIM) 742! returned attribute length 743 integer attlen 744! returned attribute type 745 integer attype 746 character*31 dimnam(MAXNCDIM) 747 character*31 varnam(7) 748 character*31 attname(2,7) 749 character*31 gattnam(2) 750 integer vdlist(5,7), vtyp(7), vndims(7), vnatts(7) 751 integer attyp(2,7),atlen(2,7),gattyp(2),gatlen(2) 752 integer timedim,latdim,londim,leveldim,lendim 753 integer dimsiz(MAXNCDIM) 754 common /dims/timedim, latdim, londim, leveldim, lendim, 755 + dimsiz 756 common /varn/varnam 757 common /atts/attname, gattnam 758 common /cdims/ dimnam 759 760 data vdlist/1,0,0,0,0,1,0,0,0,0,2,0,0,0,0,4,3,2,1,0,4,3,2,1,0, 761 + 5,1,0,0,0,1,0,0,0,0/ 762 data vtyp/NCBYTE, NCSHORT, NCLONG, NCFLOAT, NCDOUBLE, NCCHAR, 763 + NCCHAR/ 764 data vndims/1,1,1,4,4,2,1/ 765 data vnatts/1,1,1,1,1,2,0/ 766 data attyp/NCBYTE, 0, NCSHORT, 0, NCLONG, 0, NCFLOAT, 0, 767 + NCDOUBLE, 0, NCCHAR, NCCHAR, 0, 0/ 768 data atlen/2,0,2,0,2,0,2,0,2,0,11,1, 0, 0/ 769 data gattyp/NCCHAR,NCCHAR/ 770 data gatlen/3,17/ 771 772 ncid = ncopn (cdfname, NCNOWRIT, iret) 773 call ncinq (ncid, ndims, nvars, natts, recdim, iret) 774 if (iret .ne. 0) nfails = nfails + 1 775 if (ndims .ne. 5) write(*,*) 'error in ncinq or ncddef' 776 if (nvars .ne. 7) write(*,*) 'error in ncinq or ncvdef' 777 if (natts .ne. 2) write(*,*) 'error in ncinq or ncapt' 778 call ncdinq (ncid, recdim, recnam, recsiz, iret) 779 if (iret .ne. 0) nfails = nfails + 1 780 if (recnam .ne. 'time') write(*,*) 'error: bad recdim from ncinq' 781! 782! dimensions 783! 784 do 10 i = 1, ndims 785 call ncdinq (ncid, i, dname, dsize, iret) 786 if (iret .ne. 0) nfails = nfails + 1 787 if (dname .ne. dimnam(i)) 788 + write(*,*) 'error in ncdinq or ncddef, dname=', dname 789 if (dsize .ne. dimsiz(i)) 790 + write(*,*) 'error in ncdinq or ncddef, dsize=',dsize 791 dimid = ncdid (ncid, dname, iret) 792 if (dimid .ne. i) write(*,*) 793 + 'error in ncdinq or ncddef, dimid=', dimid 794 10 continue 795! 796! variables 797! 798 do 30 i = 1, nvars 799 call ncvinq (ncid, i, vname, vartyp, nvdims, 800 + vdims, nvatts, iret) 801 if (iret .ne. 0) nfails = nfails + 1 802 if (vname .ne. varnam(i)) 803 + write(*,*) 'error: from ncvinq, wrong name returned: ', 804 + vname, ' .ne. ', varnam(i) 805 if (vartyp .ne. vtyp(i)) 806 + write(*,*) 'error: from ncvinq, wrong type returned: ', 807 + vartyp, ' .ne. ', vtyp(i) 808 if (nvdims .ne. vndims(i)) 809 + write(*,*) 'error: from ncvinq, wrong num dims returned: ', 810 + vdims, ' .ne. ', vndims(i) 811 do 35 j = 1, nvdims 812 if (vdims(j) .ne. vdlist(j,i)) 813 + write(*,*) 'error: from ncvinq wrong dimids: ', 814 + vdims(j), ' .ne. ', vdlist(j,i) 815 35 continue 816 if (nvatts .ne. vnatts(i)) 817 + write(*,*) 'error in ncvinq or ncvdef' 818! 819! attributes 820! 821 do 45 k = 1, nvatts 822 call ncanam (ncid, i, k, attnam, iret) 823 if (iret .ne. 0) nfails = nfails + 1 824 call ncainq (ncid, i, attnam, attype, attlen, iret) 825 if (iret .ne. 0) nfails = nfails + 1 826 if (attnam .ne. attname(k,i)) 827 + write(*,*) 'error in ncanam or ncapt' 828 if (attype .ne. attyp(k,i)) 829 + write(*,*) 'error in ncainq or ncapt' 830 if (attlen .ne. atlen(k,i)) 831 + write(*,*) 'error in ncainq or ncapt' 832 45 continue 833 30 continue 834 do 40 i = 1, natts 835 call ncanam (ncid, NCGLOBAL, i, attnam, iret) 836 if (iret .ne. 0) nfails = nfails + 1 837 call ncainq (ncid, NCGLOBAL, attnam, attype, attlen, iret) 838 if (iret .ne. 0) nfails = nfails + 1 839 if (attnam .ne. gattnam(i)) 840 + write(*,*) 'error in ncanam or ncapt' 841 if (attype .ne. gattyp(i)) 842 + write(*,*) 'error in ncainq or ncapt' 843 if (attlen .ne. gatlen(i)) 844 + write(*,*) 'error in ncainq or ncapt' 845 40 continue 846 call ncclos(ncid, iret) 847 if (iret .ne. 0) nfails = nfails + 1 848 return 849 end 850 851 852 853! subroutine to test ncredf, ncdren, ncvren, ncaren, and 854! ncendf 855 856 subroutine tncredf(cdfname, nfails) 857 use netcdf_f03 858 character*31 cdfname 859 character*31 attname(2,7) 860 character*31 gattnam(2) 861 common /atts/attname, gattnam 862 common /cdims/ dimnam 863 character*31 dimnam(MAXNCDIM) 864 character*31 varnam(7) 865 common /varn/varnam 866 integer ncid, iret, latid, varid 867 868 dimnam(2) = 'latitude' 869 varnam(4) = 'realv' 870 attname(1,6) = 'stringname' 871 gattnam(1) = 'agency' 872 ncid = ncopn(cdfname, NCWRITE, iret) 873 if (iret .ne. 0) nfails = nfails + 1 874 call ncredf(ncid, iret) 875 if (iret .ne. 0) nfails = nfails + 1 876 latid = ncdid(ncid, 'lat', iret) 877 call ncdren(ncid, latid, 'latitude', iret) 878 if (iret .ne. 0) nfails = nfails + 1 879 varid = ncvid(ncid, 'floatv', iret) 880 call ncvren(ncid, varid, 'realv', iret) 881 if (iret .ne. 0) nfails = nfails + 1 882 varid = ncvid(ncid, 'chv', iret) 883 if (iret .ne. 0) nfails = nfails + 1 884 call ncaren(ncid, varid, 'longname', 'stringname', iret) 885 if (iret .ne. 0) nfails = nfails + 1 886 call ncaren(ncid, NCGLOBAL, 'source', 'agency', iret) 887 if (iret .ne. 0) nfails = nfails + 1 888 call ncendf(ncid, iret) 889 if (iret .ne. 0) nfails = nfails + 1 890 call ncclos(ncid, iret) 891 if (iret .ne. 0) nfails = nfails + 1 892 return 893 end 894! 895! subroutine to test ncvdef 896! 897 898 subroutine tncvdef(ncid, nfails) 899 use netcdf_f03 900 integer ncid 901 902! function to define a netCDF variable 903 integer dimsiz(MAXNCDIM) 904 integer latdim, londim, leveldim, timedim, lendim 905 common /dims/timedim, latdim, londim, leveldim, lendim, 906 + dimsiz 907 908! variable ids 909 integer bid, sid, lid, fid, did, cid, chid 910 common /vars/bid, sid, lid, fid, did, cid, chid 911 912! variable shapes 913 integer bdims(1), fdims(4), ddims(4), ldims(1), sdims(1) 914 integer chdims(2), cdims(1) 915 916 integer iret 917! 918! define variables 919! 920! byte 921! 922 bdims(1) = timedim 923 bid = ncvdef(ncid, 'bytev', NCBYTE, 1, bdims, iret) 924 if (iret .ne. 0) nfails = nfails + 1 925! 926! short 927! 928 sdims(1) = timedim 929 sid = ncvdef (ncid, 'shortv', NCSHORT, 1, sdims, iret) 930 if (iret .ne. 0) nfails = nfails + 1 931! 932! long 933! 934 ldims(1) = latdim 935 lid = ncvdef (ncid, 'longv', NCLONG, 1, ldims, iret) 936 if (iret .ne. 0) nfails = nfails + 1 937! 938! float 939! 940 fdims(4) = timedim 941 fdims(1) = leveldim 942 fdims(2) = londim 943 fdims(3) = latdim 944 fid = ncvdef (ncid, 'floatv', NCFLOAT, 4, fdims, iret) 945 if (iret .ne. 0) nfails = nfails + 1 946! 947! double 948! 949 ddims(4) = timedim 950 ddims(1) = leveldim 951 ddims(2) = londim 952 ddims(3) = latdim 953 did = ncvdef (ncid, 'doublev', NCDOUBLE, 4, ddims, iret) 954 if (iret .ne. 0) nfails = nfails + 1 955! 956! char 957! 958 chdims(2) = timedim 959 chdims(1) = lendim 960 chid = ncvdef (ncid, 'chv', NCCHAR, 2, chdims, iret) 961 if (iret .ne. 0) nfails = nfails + 1 962 963 cdims(1) = timedim 964 cid = ncvdef (ncid, 'cv', NCCHAR, 1, cdims, iret) 965 if (iret .ne. 0) nfails = nfails + 1 966 967 968 return 969 end 970 971 972! 973! subroutine to test ncvgt and ncvgtc 974! 975 subroutine tncvgt(cdfname, nfails) 976 use netcdf_f03 977 character*31 cdfname 978 979 integer ndims, times, lats, lons, levels, lenstr 980 parameter (times=4, lats=5, lons=5, levels=4) 981 982 integer start(4), count(4) 983 integer ncid, iret, i, m 984 integer latdim, londim, leveldim, timedim, lendim 985 integer dimsiz(MAXNCDIM) 986 common /dims/timedim, latdim, londim, leveldim, lendim, 987 + dimsiz 988 989 integer bid, sid, lid, fid, did, cid, chid 990 common /vars/bid, sid, lid, fid, did, cid, chid 991 integer itime, ilev, ilat, ilon 992 993! arrays of data values to be read 994 NCBYTE_T barray(times), byval(times) 995 NCSHORT_T sarray(times), shval(times) 996 integer larray(lats) 997 real farray(levels, lats, lons, times) 998 doubleprecision darray(levels, lats, lons, times) 999! character array of data values to be read 1000 character*31 string 1001 character*31 varnam 1002 integer nvars, natts, recdim 1003 integer vartyp, nvdims, vdims(MAXVDIMS), nvatts 1004 1005 data start/1,1,1,1/ 1006 data count/levels, lats, lons, times/ 1007 data byval /97, 98, 99, 100/ 1008 data shval /10, 11, 12, 13/ 1009 1010 ncid = ncopn (cdfname, NCWRITE, iret) 1011 if (iret .ne. 0) nfails = nfails + 1 1012! get number of variables in netCDF 1013 call ncinq (ncid, ndims, nvars, natts, recdim, iret) 1014 if (iret .ne. 0) nfails = nfails + 1 1015 do 5 m = 1, nvars-1 1016! get variable name, datatype, number of dimensions 1017! vector of dimension ids, and number of variable attributes 1018 call ncvinq (ncid, m, varnam, vartyp, nvdims, vdims, 1019 + nvatts, iret) 1020 if (iret .ne. 0) nfails = nfails + 1 1021 if (vartyp .eq. NCBYTE) then 1022! 1023! byte 1024! 1025 count(1) = times 1026 call ncvgt (ncid, m, start, count, barray, iret) 1027 if (iret .ne. 0) nfails = nfails + 1 1028 do 10 i = 1, times 1029 if (barray(i) .ne. byval(i)) then 1030 write(*,*) 'ncvgt of bytes, got ', barray(i), ' .ne. ' 1031 + , byval(i) 1032 end if 1033 10 continue 1034 else if (vartyp .eq. NCSHORT) then 1035! 1036! short 1037! 1038 count(1) = times 1039 call ncvgt (ncid, m, start, count, sarray, iret) 1040 if (iret .ne. 0) nfails = nfails + 1 1041 do 20 i = 1, times 1042 if (sarray(i) .ne. shval(i)) then 1043 write(*,*) 'ncvgt of short, got ', sarray(i), ' .ne. ' 1044 + , shval(i) 1045 end if 1046 20 continue 1047 else if (vartyp .eq. NCLONG) then 1048! 1049! long 1050! 1051 count(1) = lats 1052 call ncvgt (ncid, m, start, count, larray, iret) 1053 if (iret .ne. 0) nfails = nfails + 1 1054 do 30 i = 1, lats 1055 if (larray(i) .ne. 1000) then 1056 write(*,*) 'long error in ncvgt' 1057 end if 1058 30 continue 1059 else if (vartyp .eq. NCFLOAT) then 1060! 1061! float 1062! 1063 count(1) = levels 1064 call ncvgt (ncid, m, start, count, farray, iret) 1065 if (iret .ne. 0) nfails = nfails + 1 1066 i = 0 1067 do 40 itime = 1,times 1068 do 41 ilon = 1, lons 1069 do 42 ilat = 1, lats 1070 do 43 ilev = 1, levels 1071 i = i + 1 1072 if (farray(ilev, ilat, ilon, itime) .ne. 1073 + real(i)) then 1074 write (*,*) 'float error in ncvgt' 1075 end if 1076 43 continue 1077 42 continue 1078 41 continue 1079 40 continue 1080 else if (vartyp .eq. NCDOUBLE) then 1081! 1082! double 1083! 1084 count(1) = levels 1085 call ncvgt (ncid, m, start, count, darray, iret) 1086 if (iret .ne. 0) nfails = nfails + 1 1087 i = 0 1088 do 50 itime = 1, times 1089 do 51 ilon = 1, lons 1090 do 52 ilat = 1, lats 1091 do 53 ilev = 1, levels 1092 i = i + 1 1093 if (darray(ilev, ilat, ilon, itime) .ne. 1094 + real (i)) then 1095 write(*,*) 'double error in ncvgt:', i, 1096 + darray(ilev, ilat, ilon, itime), '.ne.', 1097 + real (i) 1098 end if 1099 53 continue 1100 52 continue 1101 51 continue 1102 50 continue 1103 else 1104! 1105! char 1106! 1107 count(1) = 3 1108 count(2) = 4 1109 lenstr = 31 1110 call ncvgtc (ncid, m, start, count, string, lenstr, iret) 1111 if (iret .ne. 0) nfails = nfails + 1 1112 if (string .ne. 'testhikin of') then 1113 write(*,*) 'error in ncvgt, returned string =', string 1114 end if 1115 end if 1116 5 continue 1117 call ncclos(ncid, iret) 1118 if (iret .ne. 0) nfails = nfails + 1 1119 return 1120 end 1121 1122 1123 subroutine tncvgt1(cdfname, nfails) 1124 use netcdf_f03 1125 character*31 cdfname 1126 1127 integer ncid, iret 1128 integer latdim, londim, leveldim, timedim, lendim 1129 integer dimsiz(MAXNCDIM) 1130 common /dims/timedim, latdim, londim, leveldim, lendim, 1131 + dimsiz 1132 1133 integer bindx(1), sindx(1), lindx(1), findx(4), dindx(4), cindx(1) 1134 1135 integer bid, sid, lid, fid, did, cid, chid 1136 common /vars/bid, sid, lid, fid, did, cid, chid 1137 1138 NCBYTE_T bvalue 1139 NCSHORT_T svalue 1140 integer lvalue 1141 real fvalue 1142 doubleprecision dvalue 1143 character*1 c 1144 real epsilon 1145 doubleprecision onethird 1146 1147 data epsilon /.000001/ 1148 data lindx/1/, bindx/1/, sindx/1/, findx/1,1,1,1/ 1149 +dindx/1,1,1,1/, cindx/1/ 1150 data onethird/0.3333333333D0/ 1151 1152 ncid = ncopn (cdfname, NCNOWRIT, iret) 1153 if (iret .ne. 0) nfails = nfails + 1 1154! 1155! test ncvgt1 for byte 1156! 1157 call ncvgt1 (ncid, bid, bindx, bvalue, iret) 1158 if (iret .ne. 0) nfails = nfails + 1 1159 if (bvalue .ne. ichar('z')) write(*,*) 'error in ncvgt1 byte:', 1160 + bvalue, ' .ne.', ichar('z') 1161! 1162! test ncvgt1 for short 1163! 1164 call ncvgt1 (ncid, sid, sindx, svalue, iret) 1165 if (iret .ne. 0) nfails = nfails + 1 1166 if (svalue .ne. 10) write(*,*) 'error in ncvgt1 short:', 1167 + svalue, ' .ne.', 10 1168! 1169! test ncvgt1 for long 1170! 1171 call ncvgt1 (ncid, lid, lindx, lvalue, iret) 1172 if (iret .ne. 0) nfails = nfails + 1 1173 if (lvalue .ne. 1000) write(*,*) 'error in ncvgt1 long:', 1174 + lvalue, ' .ne.', 1000 1175! 1176! test ncvgt1 for float 1177! 1178 call ncvgt1 (ncid, fid, findx, fvalue, iret) 1179 if (iret .ne. 0) nfails = nfails + 1 1180 if (abs(fvalue - 3.14159) .gt. epsilon) 1181 + write(*,*) 'error in ncvgt 1 float:', fvalue, 1182 + ' not close to', 3.14159 1183! 1184! test ncvgt1 for double 1185! 1186 call ncvgt1 (ncid, did, dindx, dvalue, iret) 1187 if (iret .ne. 0) nfails = nfails + 1 1188 if (abs(dvalue - onethird) .gt. epsilon) write(*,*) 1189 + 'error in ncvgt1 double:', dvalue, ' not close to', 1190 + onethird 1191! 1192! test ncvg1c for char 1193! 1194 call ncvg1c (ncid, cid, cindx, c, iret) 1195 if (iret .ne. 0) nfails = nfails + 1 1196 if (c .ne. 'a') write(*,*) 'error in ncvg1c' 1197 call ncclos(ncid, iret) 1198 if (iret .ne. 0) nfails = nfails + 1 1199 return 1200 end 1201 1202 1203 1204! 1205! subroutine to test ncvpt and ncvptc 1206! 1207 subroutine tncvpt(cdfname, nfails) 1208 use netcdf_f03 1209 character*31 cdfname 1210 1211! size of dimensions 1212 integer times, lats, lons, levels 1213 parameter (times=4, lats=5, lons=5, levels=4) 1214 1215 integer ncid, iret 1216! loop control variables 1217 integer itime, ilev, ilon, ilat, i 1218 integer latdim, londim, leveldim, timedim, lendim 1219 integer dimsiz(MAXNCDIM) 1220 common /dims/timedim, latdim, londim, leveldim, lendim, 1221 + dimsiz 1222 integer lenstr 1223 integer bid, sid, lid, fid, did, cid, chid 1224 common /vars/bid, sid, lid, fid, did, cid, chid 1225 1226! vector of integers specifying the corner of the hypercube 1227! where the first of the data values will be written 1228 integer start(4) 1229! vector of integers specifying the edge lengths from the 1230! corner of the hypercube where the first of the data values 1231! will be written 1232 integer count(4) 1233 1234! arrays of data values to be written 1235 NCBYTE_T barray(times) 1236 NCSHORT_T sarray(times) 1237 integer larray(lats) 1238 real farray(levels, lats, lons, times) 1239 doubleprecision darray(levels, lats, lons, times) 1240 character*31 string 1241 1242 data start/1,1,1,1/ 1243 data count/levels, lats, lons, times/ 1244 data barray /97, 98, 99, 100/ 1245 data sarray /10, 11, 12, 13/ 1246 1247 ncid = ncopn (cdfname, NCWRITE, iret) 1248 if (iret .ne. 0) nfails = nfails + 1 1249 1250! 1251! byte 1252! 1253 count(1) = times 1254 call ncvpt (ncid, bid, start, count, barray, iret) 1255 if (iret .ne. 0) nfails = nfails + 1 1256! 1257! short 1258! 1259 count(1) = times 1260 call ncvpt (ncid, sid, start, count, sarray, iret) 1261 if (iret .ne. 0) nfails = nfails + 1 1262! 1263! long 1264! 1265 do 30 i = 1,lats 1266 larray(i) = 1000 1267 30 continue 1268 count(1) = lats 1269 call ncvpt (ncid, lid, start, count, larray, iret) 1270 if (iret .ne. 0) nfails = nfails + 1 1271 1272! 1273! float 1274! 1275 i = 0 1276 do 40 itime = 1,times 1277 do 41 ilon = 1, lons 1278 do 42 ilat = 1, lats 1279 do 43 ilev = 1, levels 1280 i = i + 1 1281 farray(ilev, ilat, ilon, itime) = real (i) 1282 43 continue 1283 42 continue 1284 41 continue 1285 40 continue 1286 count(1) = levels 1287 call ncvpt (ncid, fid, start, count, farray, iret) 1288 if (iret .ne. 0) nfails = nfails + 1 1289 1290! 1291! double 1292! 1293 i = 0 1294 do 50 itime = 1, times 1295 do 51 ilon = 1, lons 1296 do 52 ilat = 1, lats 1297 do 53 ilev = 1, levels 1298 i = i + 1 1299 darray(ilev, ilat, ilon, itime) = real (i) 1300 53 continue 1301 52 continue 1302 51 continue 1303 50 continue 1304 count(1) = levels 1305 call ncvpt (ncid, did, start, count, darray, iret) 1306 if (iret .ne. 0) nfails = nfails + 1 1307 1308! 1309! char 1310! 1311 start(1) = 1 1312 start(2) = 1 1313 count(1) = 4 1314 count(2) = 4 1315 lenstr = 31 1316 string = 'testthiskind of ' 1317 call ncvptc (ncid, chid,start, count, string, lenstr, iret) 1318 if (iret .ne. 0) nfails = nfails + 1 1319 1320 call ncclos(ncid, iret) 1321 if (iret .ne. 0) nfails = nfails + 1 1322 1323 return 1324 end 1325 1326 1327 subroutine tncvpt1(cdfname, nfails) 1328 use netcdf_f03 1329 character*31 cdfname 1330 1331 1332 integer iret, ncid 1333 integer latdim, londim, leveldim, timedim, lendim 1334 integer dimsiz(MAXNCDIM) 1335 common /dims/timedim, latdim, londim, leveldim, lendim, 1336 + dimsiz 1337 1338 integer bindx(1), sindx(1), lindx(1), findx(4), dindx(4), cindx(1) 1339 1340 integer lvalue 1341 NCSHORT_T svalue 1342 NCBYTE_T bvalue 1343 doubleprecision onethird 1344 integer bid, sid, lid, fid, did, cid, chid 1345 common /vars/bid, sid, lid, fid, did, cid, chid 1346 data lindx/1/, bindx/1/, sindx/1/, findx/1,1,1,1/ 1347 +dindx/1,1,1,1/, cindx/1/ 1348 data lvalue /1000/ 1349 data svalue/10/ 1350 data onethird/0.3333333333D0/ 1351 1352 bvalue = ichar('z') 1353 1354 ncid = ncopn (cdfname, NCWRITE, iret) 1355 if (iret .ne. 0) nfails = nfails + 1 1356 1357! 1358! test ncvpt1 for byte 1359! 1360 call ncvpt1 (ncid, bid, bindx, bvalue, iret) 1361 if (iret .ne. 0) nfails = nfails + 1 1362 1363! 1364! test ncvpt1 for short 1365! 1366 call ncvpt1 (ncid, sid, sindx, svalue, iret) 1367 if (iret .ne. 0) nfails = nfails + 1 1368 1369! 1370! test ncvpt1 for long 1371! 1372 call ncvpt1 (ncid, lid, lindx, lvalue, iret) 1373 if (iret .ne. 0) nfails = nfails + 1 1374 1375! 1376! test ncvpt1 for float 1377! 1378 call ncvpt1 (ncid, fid, findx, 3.14159, iret) 1379 if (iret .ne. 0) nfails = nfails + 1 1380 1381! 1382! test ncvpt1 for double 1383! 1384 call ncvpt1 (ncid, did, dindx, onethird, iret) 1385 if (iret .ne. 0) nfails = nfails + 1 1386 1387! 1388! test ncvp1c for char 1389! 1390 call ncvp1c (ncid, cid, cindx, 'a', iret) 1391 if (iret .ne. 0) nfails = nfails + 1 1392 1393 call ncclos (ncid, iret) 1394 if (iret .ne. 0) nfails = nfails + 1 1395 1396 return 1397 end 1398 1399! 1400! subroutine to test default fill values 1401! 1402 subroutine tfills(nfails) 1403 use netcdf_f03 1404 integer ncid 1405 integer bid, sid, lid, fid, did 1406 integer ix(1) 1407 integer l 1408 NCSHORT_T s 1409 doubleprecision d 1410 real f 1411 NCBYTE_T b 1412 1413 ncid = NCOPN('fills.nc', NCNOWRIT, iret) 1414 if (iret .ne. 0) nfails = nfails + 1 1415 1416 bid = ncvid(ncid, 'b', iret) 1417 if (iret .ne. 0) nfails = nfails + 1 1418 1419 sid = ncvid(ncid, 's', iret) 1420 if (iret .ne. 0) nfails = nfails + 1 1421 1422 lid = ncvid(ncid, 'l', iret) 1423 if (iret .ne. 0) nfails = nfails + 1 1424 1425 fid = ncvid(ncid, 'f', iret) 1426 if (iret .ne. 0) nfails = nfails + 1 1427 1428 did = ncvid(ncid, 'd', iret) 1429 if (iret .ne. 0) nfails = nfails + 1 1430 1431 1432 ix(1) = 2 1433 call ncvgt1(ncid, bid, ix, b, iret) 1434 if (iret .ne. 0) nfails = nfails + 1 1435 1436 call ncvgt1(ncid, sid, ix, s, iret) 1437 if (iret .ne. 0) nfails = nfails + 1 1438 1439 call ncvgt1(ncid, lid, ix, l, iret) 1440 if (iret .ne. 0) nfails = nfails + 1 1441 1442 call ncvgt1(ncid, fid, ix, f, iret) 1443 if (iret .ne. 0) nfails = nfails + 1 1444 1445 call ncvgt1(ncid, did, ix, d, iret) 1446 if (iret .ne. 0) nfails = nfails + 1 1447 1448 1449 if (b .ne. FILBYTE) write(*,*) 'error in byte fill value' 1450 if (d .ne. FILDOUB) write(*,*) 'error in double fill value' 1451 if (f .ne. FILFLOAT) write(*,*) 'error in float fill value' 1452 if (l .ne. FILLONG) write(*,*) 'error in long fill value' 1453 if (s .ne. FILSHORT) write(*,*) 'error in short fill value' 1454 1455 return 1456 end 1457