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