1! 2! Copyright (C) 2013, Northwestern University and Argonne National Laboratory 3! See COPYRIGHT notice in top-level directory. 4! 5! $Id: util.F90 2284 2015-12-30 20:27:18Z wkliao $ 6! 7 8 SUBROUTINE PRINT_NOK(NOK) 9 USE PNETCDF 10 IMPLICIT NONE 11 INTEGER NOK 12#include "tests.inc" 13 14 123 FORMAT(I4,A) 15 IF (NFAILS .GT. 0) PRINT *, ' ' 16 IF (VERBOSE) THEN 17 PRINT 123, NOK, ' good comparisons.' 18 ENDIF 19 END 20 21 22! Is value within external type range? */ 23 logical FUNCTION INRANGE(VALUE, DATATYPE) 24 USE PNETCDF 25 IMPLICIT NONE 26 DOUBLEPRECISION VALUE 27 INTEGER DATATYPE 28#include "tests.inc" 29 30 DOUBLEPRECISION MIN 31 DOUBLEPRECISION MAX 32 33 MIN = X_DOUBLE_MIN 34 MAX = X_DOUBLE_MAX 35 IF (DATATYPE .EQ. NF90_CHAR) THEN 36 MIN = X_CHAR_MIN 37 MAX = X_CHAR_MAX 38 ELSE IF (DATATYPE .EQ. NF90_BYTE) THEN 39 MIN = X_BYTE_MIN 40 MAX = X_BYTE_MAX 41 ELSE IF (DATATYPE .EQ. NF90_SHORT) THEN 42 MIN = X_SHORT_MIN 43 MAX = X_SHORT_MAX 44 ELSE IF (DATATYPE .EQ. NF90_INT) THEN 45 MIN = X_INT_MIN 46 MAX = X_INT_MAX 47 ELSE IF (DATATYPE .EQ. NF90_FLOAT) THEN 48 MIN = X_FLOAT_MIN 49 MAX = X_FLOAT_MAX 50 ELSE IF (DATATYPE .EQ. NF90_DOUBLE) THEN 51 MIN = X_DOUBLE_MIN 52 MAX = X_DOUBLE_MAX 53 ELSE IF (DATATYPE .EQ. NF90_UBYTE) THEN 54 MIN = 0 55 MAX = X_UCHAR_MAX 56 ELSE IF (DATATYPE .EQ. NF90_USHORT) THEN 57 MIN = 0 58 MAX = X_USHORT_MAX 59 ELSE IF (DATATYPE .EQ. NF90_UINT) THEN 60 MIN = 0 61 MAX = X_UINT_MAX 62 ELSE IF (DATATYPE .EQ. NF90_INT64) THEN 63 INRANGE = (VALUE .GE. X_INT8_MIN) .AND. & 64 (VALUE .LE. X_INT8_MAX) 65 return 66 ELSE IF (DATATYPE .EQ. NF90_UINT64) THEN 67 INRANGE = (VALUE .GE. 0) .AND. & 68 (VALUE .LE. X_UINT8_MAX) 69 return 70 ELSE 71 CALL UD_ABORT 72 END IF 73 74 INRANGE = (VALUE .GE. MIN) .AND. (VALUE .LE. MAX) 75 END 76 77 78 logical FUNCTION INRANGE_UCHAR(VALUE, DATATYPE) 79 USE PNETCDF 80 IMPLICIT NONE 81 DOUBLEPRECISION VALUE 82 INTEGER DATATYPE 83#include "tests.inc" 84 LOGICAL INRANGE 85 86 IF (DATATYPE .EQ. NF90_BYTE) THEN 87 INRANGE_UCHAR = (VALUE .GE. 0) .AND. (VALUE .LE. 255) 88 ELSE 89 INRANGE_UCHAR = INRANGE(VALUE, DATATYPE) 90 END IF 91 END 92 93 94 logical FUNCTION INRANGE_FLOAT(VALUE, DATATYPE) 95 USE PNETCDF 96 IMPLICIT NONE 97 DOUBLEPRECISION VALUE 98 INTEGER DATATYPE 99#include "tests.inc" 100 double precision internal_max 101 102 DOUBLEPRECISION MIN 103 DOUBLEPRECISION MAX 104 REAL FVALUE 105 106 MIN = X_DOUBLE_MIN 107 MAX = X_DOUBLE_MAX 108 109 IF (DATATYPE .EQ. NF90_CHAR) THEN 110 MIN = X_CHAR_MIN 111 MAX = X_CHAR_MAX 112 ELSE IF (DATATYPE .EQ. NF90_BYTE) THEN 113 MIN = X_BYTE_MIN 114 MAX = X_BYTE_MAX 115 ELSE IF (DATATYPE .EQ. NF90_SHORT) THEN 116 MIN = X_SHORT_MIN 117 MAX = X_SHORT_MAX 118 ELSE IF (DATATYPE .EQ. NF90_INT) THEN 119 MIN = X_INT_MIN 120 MAX = X_INT_MAX 121 ELSE IF (DATATYPE .EQ. NF90_FLOAT) THEN 122 IF (internal_max(NFT_REAL) .LT. X_FLOAT_MAX) THEN 123 MIN = -internal_max(NFT_REAL) 124 MAX = internal_max(NFT_REAL) 125 ELSE 126 MIN = X_FLOAT_MIN 127 MAX = X_FLOAT_MAX 128 END IF 129 ELSE IF (DATATYPE .EQ. NF90_DOUBLE) THEN 130 IF (internal_max(NFT_REAL) .LT. X_DOUBLE_MAX) THEN 131 MIN = -internal_max(NFT_REAL) 132 MAX = internal_max(NFT_REAL) 133 ELSE 134 MIN = X_DOUBLE_MIN 135 MAX = X_DOUBLE_MAX 136 END IF 137 ELSE IF (DATATYPE .EQ. NF90_UBYTE) THEN 138 MIN = 0 139 MAX = X_UCHAR_MAX 140 ELSE IF (DATATYPE .EQ. NF90_USHORT) THEN 141 MIN = 0 142 MAX = X_USHORT_MAX 143 ELSE IF (DATATYPE .EQ. NF90_UINT) THEN 144 MIN = 0 145 MAX = X_UINT_MAX 146 ELSE IF (DATATYPE .EQ. NF90_INT64) THEN 147 MIN = X_INT8_MIN 148 MAX = X_INT8_MAX 149 ELSE IF (DATATYPE .EQ. NF90_UINT64) THEN 150 MIN = 0 151 MAX = X_UINT8_MAX 152 ELSE 153 CALL UD_ABORT 154 END IF 155 156 IF (.NOT.((VALUE .GE. MIN) .AND. (VALUE .LE. MAX))) THEN 157 INRANGE_FLOAT = .FALSE. 158 ELSE 159 FVALUE = REAL(VALUE) 160 INRANGE_FLOAT = (FVALUE .GE. MIN) .AND. (FVALUE .LE. MAX) 161 END IF 162 END 163 164 165! wrapper for inrange to handle special NF90_BYTE/uchar adjustment */ 166 logical function inrange3(value, datatype, itype) 167 use pnetcdf 168 implicit none 169 doubleprecision value 170 integer datatype 171 integer itype 172#include "tests.inc" 173 logical inrange_float, inrange 174 175 if (itype .eq. NFT_REAL) then 176 inrange3 = inrange_float(value, datatype) 177 else 178 inrange3 = inrange(value, datatype) 179 end if 180 end 181 182 183! 184! Does x == y, where one is internal and other external (netCDF)? 185! Use tolerant comparison based on IEEE FLT_EPSILON or DBL_EPSILON. 186! 187 logical function equal(x, y, extType, itype) 188 use pnetcdf 189 implicit none 190 doubleprecision x 191 doubleprecision y 192 integer extType !!/* external data type */ 193 integer itype 194#include "tests.inc" 195 196 doubleprecision epsilon 197 198 if ((extType .eq. NF90_REAL) .or. (itype .eq. NFT_REAL)) then 199 epsilon = 1.19209290E-07 200 else 201 epsilon = 2.2204460492503131E-16 202 end if 203 equal = abs(x-y) .le. epsilon * max( abs(x), abs(y)) 204 end 205 206 207! Test whether two int vectors are equal. If so return 1, else 0 */ 208 logical function int_vec_eq(v1, v2, n) 209 use pnetcdf 210 implicit none 211 integer n 212 integer v1(n) 213 integer v2(n) 214#include "tests.inc" 215 216 integer i 217 218 int_vec_eq = .true. 219 220 if (n .le. 0) & 221 return 222 223 do 1, i=1, n 224 if (v1(i) .ne. v2(i)) then 225 int_vec_eq = .false. 226 return 227 end if 2281 continue 229 end 230 231 232! 233! Generate random integer from 0 through n-1 234! Like throwing an n-sided dice marked 0, 1, 2, ..., n-1 235! 236 integer function roll(n) 237 use pnetcdf 238 implicit none 239#include "tests.inc" 240 integer(kind=MPI_OFFSET_KIND) n 241 242 doubleprecision ud_rand 243 external ud_rand 244 2451 roll = INT((ud_rand(0) * (n-1)) + 0.5) 246 if (roll .ge. n) goto 1 247 end 248 249 250! 251! Convert an origin-1 cumulative index to a netCDF index vector. 252! Grosset dimension first; finest dimension last. 253! 254! Authors: Harvey Davies, Unidata/UCAR, Boulder, Colorado 255! Steve Emmerson, (same place) 256! 257 integer function index2ncindexes(index, rank, base, indexes) 258 use pnetcdf 259 implicit none 260 integer index !!/* index to be converted */ 261 integer rank !/* number of dimensions */ 262#include "tests.inc" 263 integer(kind=MPI_OFFSET_KIND) base(rank) !/* base(rank) ignored */ 264 integer(kind=MPI_OFFSET_KIND) indexes(rank) !/* returned FORTRAN indexes */ 265 266 integer i 267 integer offset 268 integer intbase 269 270 if (rank .gt. 0) then 271 offset = index - 1 272 do 1, i = rank, 1, -1 273 if (base(i) .eq. 0) then 274 index2ncindexes = 1 275 return 276 end if 277 intbase = INT(base(i)) 278 indexes(i) = 1 + mod(offset, intbase) 279 offset = offset / INT(base(i)) 2801 continue 281 end if 282 index2ncindexes = 0 283 end 284 285 286! 287! Convert an origin-1 cumulative index to a FORTRAN index vector. 288! Finest dimension first; grossest dimension last. 289! 290! Authors: Harvey Davies, Unidata/UCAR, Boulder, Colorado 291! Steve Emmerson, (same place) 292! 293 integer function index2indexes(index, rank, base, indexes) 294 use pnetcdf 295 implicit none 296 integer index !/* index to be converted */ 297 integer rank !/* number of dimensions */ 298#include "tests.inc" 299 integer(kind=MPI_OFFSET_KIND) base(rank) !/* base(rank) ignored */ 300 integer(kind=MPI_OFFSET_KIND) indexes(rank) !/* returned FORTRAN indexes */ 301 302 integer i 303 integer offset 304 integer intbase 305 306 if (rank .gt. 0) then 307 offset = index - 1 308 do 1, i = 1, rank 309 if (base(i) .eq. 0) then 310 index2indexes = 1 311 return 312 end if 313 intbase = INT(base(i)) 314 indexes(i) = 1 + mod(offset, intbase) 315 offset = offset / INT(base(i)) 3161 continue 317 end if 318 index2indexes = 0 319 end 320 321 322! 323! Convert a FORTRAN index vector to an origin-1 cumulative index. 324! Finest dimension first; grossest dimension last. 325! 326! Authors: Harvey Davies, Unidata/UCAR, Boulder, Colorado 327! Steve Emmerson, (same place) 328! 329 integer function indexes2index(rank, indexes, base) 330 use pnetcdf 331 implicit none 332 integer rank !/* number of dimensions */ 333 integer indexes(rank) !/* FORTRAN indexes */ 334 integer base(rank) !/* base(rank) ignored */ 335#include "tests.inc" 336 337 integer i 338 339 indexes2index = 0 340 if (rank .gt. 0) then 341 do 1, i = rank, 1, -1 342 indexes2index = (indexes2index-1) * base(i) + indexes(i) 3431 continue 344 end if 345 end 346 347 348! Generate data values as function of type, rank (-1 for attribute), index */ 349 double precision function hash(type, rank, index) 350 use pnetcdf 351 implicit none 352 integer type 353 integer rank 354#include "tests.inc" 355 integer(kind=MPI_OFFSET_KIND) index(*) 356 357 doubleprecision base 358 doubleprecision result 359 integer d !/* index of dimension */ 360 361 !/* If vector then elements 1 & 2 are min & max. Elements 3 & 4 are */ 362 !/* just < min & > max (except for NF90_CHAR & NF90_DOUBLE) */ 363 hash = 0 364 if (abs(rank) .eq. 1 .and. index(1) .le. 4) then 365 if (index(1) .eq. 1) then 366 if (type .eq. NF90_CHAR) then 367 hash = X_CHAR_MIN 368 else if (type .eq. NF90_BYTE) then 369 hash = X_BYTE_MIN 370 else if (type .eq. NF90_SHORT) then 371 hash = X_SHORT_MIN 372 else if (type .eq. NF90_INT) then 373 hash = X_INT_MIN 374 else if (type .eq. NF90_FLOAT) then 375 hash = X_FLOAT_MIN 376 else if (type .eq. NF90_DOUBLE) then 377 hash = X_DOUBLE_MIN 378 else if (type .eq. NF90_UBYTE) then 379 hash = 0 380 else if (type .eq. NF90_USHORT) then 381 hash = 0 382 else if (type .eq. NF90_UINT) then 383 hash = 0 384 else if (type .eq. NF90_INT64) then 385 hash = X_INT_MIN - 128.0 386 else if (type .eq. NF90_UINT64) then 387 hash = 0 388 else 389 call ud_abort 390 end if 391 else if (index(1) .eq. 2) then 392 if (type .eq. NF90_CHAR) then 393 hash = X_CHAR_MAX 394 else if (type .eq. NF90_BYTE) then 395 hash = X_BYTE_MAX 396 else if (type .eq. NF90_SHORT) then 397 hash = X_SHORT_MAX 398 else if (type .eq. NF90_INT) then 399 hash = X_INT_MAX 400 else if (type .eq. NF90_FLOAT) then 401 hash = X_FLOAT_MAX 402 else if (type .eq. NF90_DOUBLE) then 403 hash = X_DOUBLE_MAX 404 else if (type .eq. NF90_UBYTE) then 405 hash = X_UCHAR_MAX 406 else if (type .eq. NF90_USHORT) then 407 hash = X_USHORT_MAX 408 else if (type .eq. NF90_UINT) then 409 hash = X_UINT_MAX 410 else if (type .eq. NF90_INT64) then 411 hash = X_INT_MAX + 128.0 412 else if (type .eq. NF90_UINT64) then 413 hash = X_UINT_MAX + 128.0 414 else 415 call ud_abort 416 end if 417 else if (index(1) .eq. 3) then 418 if (type .eq. NF90_CHAR) then 419 hash = ichar('A') 420 else if (type .eq. NF90_BYTE) then 421 hash = X_BYTE_MIN-1.0 422 else if (type .eq. NF90_SHORT) then 423 hash = X_SHORT_MIN-1.0 424 else if (type .eq. NF90_INT) then 425 hash = X_INT_MIN 426 else if (type .eq. NF90_FLOAT) then 427 hash = X_FLOAT_MIN 428 else if (type .eq. NF90_DOUBLE) then 429 hash = -1.0 430 else if (type .eq. NF90_UBYTE) then 431 hash = -1.0 432 else if (type .eq. NF90_USHORT) then 433 hash = -1.0 434 else if (type .eq. NF90_UINT) then 435 hash = -1.0 436 else if (type .eq. NF90_INT64) then 437 hash = -1.0 438 else if (type .eq. NF90_UINT64) then 439 hash = -1.0 440 else 441 call ud_abort 442 end if 443 else if (index(1) .eq. 4) then 444 if (type .eq. NF90_CHAR) then 445 hash = ichar('Z') 446 else if (type .eq. NF90_BYTE) then 447 hash = X_BYTE_MAX+1.0 448 else if (type .eq. NF90_SHORT) then 449 hash = X_SHORT_MAX+1.0 450 else if (type .eq. NF90_INT) then 451 hash = X_INT_MAX+1.0 452 else if (type .eq. NF90_FLOAT) then 453 hash = X_FLOAT_MAX 454 else if (type .eq. NF90_DOUBLE) then 455 hash = 1.0 456 else if (type .eq. NF90_UBYTE) then 457 hash = X_UCHAR_MAX + 1.0 458 else if (type .eq. NF90_USHORT) then 459 hash = X_USHORT_MAX + 1.0 460 else if (type .eq. NF90_UINT) then 461 hash = X_UINT_MAX + 1.0 462 else if (type .eq. NF90_INT64) then 463 hash = 1.0 464 else if (type .eq. NF90_UINT64) then 465 hash = 1.0 466 else 467 call ud_abort 468 end if 469 end if 470 else 471 if (type .eq. NF90_CHAR) then 472 base = 2 473 else if (type .eq. NF90_BYTE) then 474 base = -2 475 else if (type .eq. NF90_SHORT) then 476 base = -5 477 else if (type .eq. NF90_INT) then 478 base = -20 479 else if (type .eq. NF90_FLOAT) then 480 base = -9 481 else if (type .eq. NF90_DOUBLE) then 482 base = -10 483 else if (type .eq. NF90_UBYTE) then 484 base = 2 485 else if (type .eq. NF90_USHORT) then 486 base = 5 487 else if (type .eq. NF90_UINT) then 488 base = 20 489 else if (type .eq. NF90_INT64) then 490 base = -20 491 else if (type .eq. NF90_UINT64) then 492 base = 20 493 else 494 print*, 'Error: no such nc_type ',type 495 stop 'in hash()' 496 end if 497 498 if (rank .lt. 0) then 499 result = base * 7 500 else 501 result = base * (rank + 1) 502 end if 503 504! /* 505! * NB: Finest netCDF dimension assumed first. 506! */ 507 do 1, d = abs(rank), 1, -1 508 result = base * (result + index(d) - 1) 5091 continue 510 hash = result 511 end if 512 end 513 514 515! wrapper for hash to handle special NC_BYTE/uchar adjustment */ 516 double precision function hash4(type, rank, index, itype) 517 use pnetcdf 518 implicit none 519 integer type 520 integer rank 521#include "tests.inc" 522 double precision hash 523 524 integer(kind=MPI_OFFSET_KIND) index(*) 525 integer itype 526 527 hash4 = hash( type, rank, index ) 528 if ((itype .eq. NFT_CHAR) .and. (type .eq. NF90_BYTE) .and. & 529 (hash4 .ge. -128) .and. (hash4 .lt. 0)) hash4 = hash4 + 256 530 end 531 532 533 integer function char2type(letter) 534 use pnetcdf 535 implicit none 536 character*1 letter 537#include "tests.inc" 538 539 if (letter .eq. 'c') then 540 char2type = NF90_CHAR 541 else if (letter .eq. 'b') then 542 char2type = NF90_BYTE 543 else if (letter .eq. 's') then 544 char2type = NF90_SHORT 545 else if (letter .eq. 'i') then 546 char2type = NF90_INT 547 else if (letter .eq. 'f') then 548 char2type = NF90_FLOAT 549 else if (letter .eq. 'd') then 550 char2type = NF90_DOUBLE 551 else if (letter .eq. 'y') then 552 char2type = NF90_UBYTE 553 else if (letter .eq. 't') then 554 char2type = NF90_USHORT 555 else if (letter .eq. 'u') then 556 char2type = NF90_UINT 557 else if (letter .eq. 'x') then 558 char2type = NF90_INT64 559 else if (letter .eq. 'z') then 560 char2type = NF90_UINT64 561 else 562 stop 'char2type(): invalid type-letter' 563 end if 564 end 565 566 567 subroutine init_dims(digit) 568 use pnetcdf 569 implicit none 570 character*1 digit(NDIMS) 571#include "tests.inc" 572 573 integer dimid !/* index of dimension */ 574 do 1, dimid = 1, NDIMS 575 if (dimid .eq. RECDIM) then 576 dim_len(dimid) = NRECS 577 else 578 dim_len(dimid) = dimid - 1 579 endif 580 dim_name(dimid) = 'D' // digit(dimid) 5811 continue 582 end 583 584 585 subroutine init_gatts(type_letter) 586 use pnetcdf 587 implicit none 588 character*1 type_letter(NTYPES) 589#include "tests.inc" 590 591 integer attid 592 integer char2type 593 594 do 1, attid = 1, numTypes 595 gatt_name(attid) = 'G' // type_letter(attid) 596 gatt_len(attid) = attid 597 gatt_type(attid) = char2type(type_letter(attid)) 5981 continue 599 end 600 601 602 integer function prod(nn, sp) 603 use pnetcdf 604 implicit none 605 integer nn 606#include "tests.inc" 607 integer(kind=MPI_OFFSET_KIND) sp(MAX_RANK) 608 609 integer i 610 611 prod = 1 612 do 1, i = 1, nn 613 prod = prod * INT(sp(i)) 6141 continue 615 end 616 617 618! 619! define global variables: 620! dim_name, dim_len, 621! var_name, var_type, var_rank, var_shape, var_natts, var_dimid, var_nels 622! att_name, gatt_name, att_type, gatt_type, att_len, gatt_len 623! 624 625 subroutine init_gvars 626 use pnetcdf 627 implicit none 628#include "tests.inc" 629 integer index2ncindexes 630 631 integer(kind=MPI_OFFSET_KIND) max_dim_len(MAX_RANK) 632 character*1 type_letter(NTYPES) 633 character*1 digit(10) 634 635 integer rank 636 integer vn !/* var number */ 637 integer xtype !/* index of type */ 638 integer an !/* origin-0 cumulative attribute index */ 639 integer nvars 640 integer jj 641 integer n_types 642 integer tc 643 integer(kind=MPI_OFFSET_KIND) tmp(MAX_RANK) 644 integer ac !/* attribute index */ 645 integer dn !/* dimension number */ 646 integer prod !/* function */ 647 integer char2type !/* function */ 648 integer err 649 650 data max_dim_len /0, MAX_DIM_LEN, MAX_DIM_LEN/ 651 data type_letter /'c', 'b', 's', 'i', 'f', 'd', 'y', & 652 't', 'u', 'x', 'z'/ 653 data digit /'r', '1', '2', '3', '4', '5', & 654 '6', '7', '8', '9'/ 655 656 max_dim_len(1) = MAX_DIM_LEN + 1 657 658 call init_dims(digit) 659 660 vn = 1 661 xtype = 1 662 an = 0 663 664! /* Loop over variable ranks */ 665 do 1, rank = 0, MAX_RANK 666 nvars = prod(rank, max_dim_len) 667 668 !/* Loop over variable shape vectors */ 669 do 2, jj = 1, nvars !/* 1, 5, 20, 80 */ 670 !/* number types of this shape */ 671 if (rank .lt. 2) then 672 n_types = numTypes !/* 6 */ 673 else 674 n_types = 1 675 end if 676 677 !/* Loop over external data types */ 678 do 3, tc = 1, n_types !/* 6, 1 */ 679 var_name(vn) = type_letter(xtype) 680 var_type(vn) = char2type(type_letter(xtype)) 681 var_rank(vn) = rank 682 if (rank .eq. 0) then 683 var_natts(vn) = mod(vn - 1, MAX_NATTS + 1) 684 else 685 var_natts(vn) = 0 686 end if 687 688 do 4, ac = 1, var_natts(vn) 689 attname(ac,vn) = & 690 type_letter(1+mod(an, numTypes)) 691 attlen(ac,vn) = an 692 atttype(ac,vn) = & 693 char2type(type_letter(1+mod(an, numTypes))) 694 an = an + 1 6954 continue 696 697 !/* Construct initial shape vector */ 698 err = index2ncindexes(jj, rank, max_dim_len, tmp) 699 do 5, dn = 1, rank 700 var_dimid(dn,vn) = INT(tmp(1+rank-dn)) 7015 continue 702 703 var_nels(vn) = 1 704 do 6, dn = 1, rank 705 if (dn .lt. rank) then 706 var_dimid(dn,vn) = var_dimid(dn,vn) + 1 707 end if 708 if (var_dimid(dn,vn) .gt. 9) then 709 stop 'Invalid var_dimid vector' 710 end if 711 var_name(vn)(rank+2-dn:rank+2-dn) = & 712 digit(var_dimid(dn,vn)) 713 if (var_dimid(dn,vn) .ne. RECDIM) then 714 var_shape(dn,vn) = var_dimid(dn,vn) - 1 715 else 716 var_shape(dn,vn) = NRECS 717 end if 718 var_nels(vn) = var_nels(vn) * INT(var_shape(dn,vn)) 7196 continue 720 721 vn = vn + 1 722 xtype = 1 + mod(xtype, numTypes) 7233 continue 7242 continue 7251 continue 726 727 call init_gatts(type_letter) 728 end 729 730 731! define dims defined by global variables */ 732 subroutine def_dims(ncid) 733 use pnetcdf 734 implicit none 735 integer ncid 736#include "tests.inc" 737 738 integer err !/* status */ 739 integer i 740 integer dimid !/* dimension id */ 741 742 do 1, i = 1, NDIMS 743 if (i .eq. RECDIM) then 744 err = nf90mpi_def_dim(ncid, dim_name(i), & 745 NF90MPI_UNLIMITED, dimid) 746 else 747 err = nf90mpi_def_dim(ncid, dim_name(i), dim_len(i), & 748 dimid) 749 end if 750 if (err .ne. NF90_NOERR) then 751 call errore('nf90mpi_def_dim: ', err) 752 end if 7531 continue 754 end 755 756 757! define vars defined by global variables */ 758 subroutine def_vars(ncid) 759 use pnetcdf 760 implicit none 761 integer ncid 762#include "tests.inc" 763 764 integer err !/* status */ 765 integer i 766 integer var_id 767 768 do 1, i = 1, numVars 769 err = nf90mpi_def_var(ncid, var_name(i), var_type(i), & 770 var_dimid(1:var_rank(i),i), var_id) 771 if (err .ne. NF90_NOERR) then 772 call errore('nf90mpi_def_var: ', err) 773 end if 7741 continue 775 end 776 777 778! put attributes defined by global variables */ 779 subroutine put_atts(ncid) 780 use pnetcdf 781 implicit none 782 integer ncid 783#include "tests.inc" 784 integer(kind=MPI_OFFSET_KIND) ATT_LEN_LL 785 integer VARID, NATTS, ATT_TYPE, ATT_LEN 786 CHARACTER*2 ATT_NAME 787 double precision hash 788 logical inrange 789 790 integer err !/* netCDF status */ 791 integer i !/* variable index (0 => global 792 ! * attribute */ 793 integer k !/* attribute index */ 794 integer j !/* index of attribute */ 795 integer(kind=MPI_OFFSET_KIND) ndx(1) 796 logical allInRange 797 double precision att(MAX_NELS) 798 character*(MAX_NELS+2) catt 799 800 do 1, i = 0, numVars !/* var 0 => NF90_GLOBAL attributes */ 801 do 2, j = 1, NATTS(i) 802 if (NF90_CHAR .eq. ATT_TYPE(j,i)) then 803 catt = ' ' 804 do 3, k = 1, ATT_LEN(j,i) 805 ndx(1) = k 806 catt(k:k) = char(int(hash(ATT_TYPE(j,i), -1, & 807 ndx))) 8083 continue 809! /* 810! * The following ensures that the text buffer doesn't 811! * start with 4 zeros (which is a CFORTRAN NULL pointer 812! * indicator) yet contains a zero (which causes the 813! * CFORTRAN interface to pass the address of the 814! * actual text buffer). 815! */ 816 catt(ATT_LEN(j,i)+1:ATT_LEN(j,i)+1) = char(1) 817 catt(ATT_LEN(j,i)+2:ATT_LEN(j,i)+2) = char(0) 818 819 err = nf90mpi_put_att(ncid, varid(i), ATT_NAME(j,i), & 820 catt(1:ATT_LEN(j,i))) 821 if (err .ne. NF90_NOERR) then 822 call errore('nf90mpi_put_att: ', err) 823 end if 824 else 825 allInRange = .true. 826 do 4, k = 1, ATT_LEN(j,i) 827 ndx(1) = k 828 att(k) = hash(ATT_TYPE(j,i), -1, ndx) 829 allInRange = allInRange .and. & 830 inRange(att(k), ATT_TYPE(j,i)) 8314 continue 832 ! cannot use nf90mpi_put_att, as it checks data types 833 ATT_LEN_LL = ATT_LEN(j,i) 834 err = nfmpi_put_att_double(ncid, varid(i), ATT_NAME(j,i), & 835 ATT_TYPE(j,i), ATT_LEN_LL, att) 836 if (allInRange) then 837 if (err .ne. NF90_NOERR) then 838 call errore('nf90mpi_put_att: ', err) 839 end if 840 ! F90 skips this error check 841 ! else 842 ! if (err .ne. NF90_ERANGE) then 843 ! call errore( & 844 ! 'type-conversion range error: status = ', & 845 ! err) 846 ! end if 847 end if 848 end if 8492 continue 8501 continue 851 end 852 853 854! put variables defined by global variables */ 855 subroutine put_vars(ncid) 856 use pnetcdf 857 implicit none 858 integer ncid 859#include "tests.inc" 860 integer index2indexes 861 double precision hash 862 logical inrange 863 864 integer(kind=MPI_OFFSET_KIND) start(MAX_RANK) 865 integer(kind=MPI_OFFSET_KIND) index(MAX_RANK) 866 integer err !/* netCDF status */ 867 integer i 868 integer j 869 doubleprecision value(MAX_NELS) 870 character*(MAX_NELS+2) text 871 logical allInRange 872 873 do 1, j = 1, MAX_RANK 874 start(j) = 1 8751 continue 876 877 err = nf90mpi_begin_indep_data(ncid) 878 do 2, i = 1, numVars 879 allInRange = .true. 880 do 3, j = 1, var_nels(i) 881 err = index2indexes(j, var_rank(i), var_shape(1,i), & 882 index) 883 if (err .ne. NF90_NOERR) then 884 call errori( & 885 'Error calling index2indexes() for var ', j) 886 end if 887 if (var_name(i)(1:1) .eq. 'c') then 888 text(j:j) = & 889 char(int(hash(var_type(i), var_rank(i), index))) 890 else 891 value(j) = hash(var_type(i), var_rank(i), index) 892 allInRange = allInRange .and. & 893 inRange(value(j), var_type(i)) 894 end if 8953 continue 896 if (var_name(i)(1:1) .eq. 'c') then 897! /* 898! * The following statement ensures that the first 4 899! * characters in 'text' are not all zeros (which is 900! * a cfortran.h NULL indicator) and that the string 901! * contains a zero (which will cause the address of the 902! * actual string buffer to be passed). 903! */ 904 text(var_nels(i)+1:var_nels(i)+1) = char(1) 905 text(var_nels(i)+2:var_nels(i)+2) = char(0) 906 err = nf90mpi_put_var(ncid, i, text, start, & 907 var_shape(:,i)) 908 if (err .ne. NF90_NOERR) then 909 call errore('nf90mpi_put_var: ', err) 910 end if 911 else 912 err = nf90mpi_put_var(ncid, i, value, start, & 913 var_shape(:,i)) 914 if (allInRange) then 915 if (err .ne. NF90_NOERR) then 916 call errore('nf90mpi_put_var: ', err) 917 end if 918 else 919 if (err .ne. NF90_ERANGE) then 920 call errore( & 921 'type-conversion range error: status = ', & 922 err) 923 end if 924 end if 925 end if 9262 continue 927 err = nf90mpi_end_indep_data(ncid) 928 end 929 930 931! Create & write all of specified file using global variables */ 932 subroutine write_file(filename) 933 use pnetcdf 934 implicit none 935 character*(*) filename 936#include "tests.inc" 937 938 integer ncid !/* netCDF id */ 939 integer err !/* netCDF status */ 940 integer flags 941 942 flags = IOR(NF90_CLOBBER, extra_flags) 943 err = nf90mpi_create(comm, filename, flags, info, & 944 ncid) 945 if (err .ne. NF90_NOERR) then 946 call errore('nf90mpi_create: ', err) 947 end if 948 949 call def_dims(ncid) 950 call def_vars(ncid) 951 call put_atts(ncid) 952 err = nf90mpi_enddef(ncid) 953 if (err .ne. NF90_NOERR) then 954 call errore('nf90mpi_enddef: ', err) 955 end if 956 call put_vars(ncid) 957 958 err = nf90mpi_close(ncid) 959 if (err .ne. NF90_NOERR) then 960 call errore('nf90mpi_close: ', err) 961 end if 962 end 963 964 965! 966! check dimensions of specified file have expected name & length 967! 968 subroutine check_dims(ncid) 969 use pnetcdf 970 implicit none 971 integer ncid 972#include "tests.inc" 973 974 character*(NF90_MAX_NAME) name 975 integer(kind=MPI_OFFSET_KIND) length 976 integer i 977 integer err !/* netCDF status */ 978 979 do 1, i = 1, NDIMS 980 err = nf90mpi_inquire_dimension(ncid, i, name, length) 981 if (err .ne. NF90_NOERR) then 982 call errore('nf90mpi_inquire_dimension: ', err) 983 end if 984 if (name .ne. dim_name(i)) then 985 call errori('Unexpected name of dimension ', i) 986 end if 987 if (length .ne. dim_len(i)) then 988 call errori('Unexpected length of dimension ', i) 989 end if 9901 continue 991 end 992 993 994! 995! check variables of specified file have expected name, type, shape & values 996! 997 subroutine check_vars(ncid) 998 use pnetcdf 999 implicit none 1000 integer ncid 1001#include "tests.inc" 1002 integer index2indexes 1003 double precision hash 1004 logical inrange, equal 1005 1006 integer(kind=MPI_OFFSET_KIND) index(MAX_RANK) 1007 integer err !/* netCDF status */ 1008 integer i 1009 integer j 1010 character*1 text 1011 doubleprecision value 1012 integer datatype 1013 integer ndims 1014 integer natt 1015 integer dimids(MAX_RANK) 1016 logical isChar 1017 doubleprecision expect 1018 character*(NF90_MAX_NAME) name 1019 integer(kind=MPI_OFFSET_KIND) length 1020 integer nok !/* count of valid comparisons */ 1021 1022 nok = 0 1023 err = nf90mpi_begin_indep_data(ncid) 1024 1025 do 1, i = 1, numVars 1026 isChar = var_type(i) .eq. NF90_CHAR 1027 err = nf90mpi_inquire_variable(ncid, i, name, datatype, ndims, dimids, & 1028 natt) 1029 if (err .ne. NF90_NOERR) then 1030 call errore('nf90mpi_inquire_variable: ', err) 1031 end if 1032 if (name .ne. var_name(i)) then 1033 call errori('Unexpected var_name for variable ', i) 1034 end if 1035 if (datatype .ne. var_type(i)) then 1036 call errori('Unexpected type for variable ', i) 1037 end if 1038 if (ndims .ne. var_rank(i)) then 1039 call errori('Unexpected rank for variable ', i) 1040 end if 1041 do 2, j = 1, ndims 1042 err = nf90mpi_inquire_dimension(ncid, dimids(j), name, length) 1043 if (err .ne. NF90_NOERR) then 1044 call errore('nf90mpi_inquire_dimension: ', err) 1045 end if 1046 if (length .ne. var_shape(j,i)) then 1047 call errori('Unexpected shape for variable ', i) 1048 end if 10492 continue 1050 do 3, j = 1, var_nels(i) 1051 err = index2indexes(j, var_rank(i), var_shape(1,i), & 1052 index) 1053 if (err .ne. NF90_NOERR) then 1054 call errori('error in index2indexes() 2, variable ', & 1055 i) 1056 end if 1057 expect = hash(var_type(i), var_rank(i), index ) 1058 if (isChar) then 1059 err = nf90mpi_get_var(ncid, i, text, index) 1060 if (err .ne. NF90_NOERR) then 1061 call errore('nf90mpi_get_var: ', err) 1062 end if 1063 if (ichar(text) .ne. expect) then 1064 call errori( & 1065 'Var value read not that expected for variable ', i) 1066 else 1067 nok = nok + 1 1068 end if 1069 else 1070 err = nf90mpi_get_var(ncid, i, value, index) 1071 if (inRange(expect,var_type(i))) then 1072 if (err .ne. NF90_NOERR) then 1073 call errore('nf90mpi_get_var: ', err) 1074 else 1075 if (.not. equal(value,expect,var_type(i), & 1076 NFT_DOUBLE)) then 1077 call errori( & 1078 'Var value read not that expected for variable ', i) 1079 else 1080 nok = nok + 1 1081 end if 1082 end if 1083 end if 1084 end if 10853 continue 10861 continue 1087 err = nf90mpi_end_indep_data(ncid) 1088 ! call print_nok(nok) 1089 end 1090 1091 1092! 1093! check attributes of specified file have expected name, type, length & values 1094! 1095 subroutine check_atts(ncid) 1096 use pnetcdf 1097 implicit none 1098 integer ncid 1099#include "tests.inc" 1100 integer VARID, NATTS, ATT_TYPE, ATT_LEN 1101 CHARACTER*2 ATT_NAME 1102 double precision hash 1103 logical inrange, equal 1104 1105 integer err !/* netCDF status */ 1106 integer i 1107 integer j 1108 integer k 1109 integer vid !/* "variable" ID */ 1110 integer datatype 1111 integer(kind=MPI_OFFSET_KIND) ndx(1) 1112 character*(NF90_MAX_NAME) name 1113 integer(kind=MPI_OFFSET_KIND) length 1114 character*(MAX_NELS) text 1115 doubleprecision value(MAX_NELS) 1116 doubleprecision expect 1117 integer nok !/* count of valid comparisons */ 1118 1119 nok = 0 1120 1121 do 1, vid = 0, numVars 1122 i = varid(vid) 1123 1124 do 2, j = 1, NATTS(i) 1125 err = nf90mpi_inq_attname(ncid, i, j, name) 1126 if (err .ne. NF90_NOERR) then 1127 call errore('nf90mpi_inq_attname: ', err) 1128 end if 1129 if (name .ne. ATT_NAME(j,i)) then 1130 call errori( & 1131 'nf90mpi_inq_attname: unexpected name for var ', i) 1132 end if 1133 err = nf90mpi_inquire_attribute(ncid, i, name, datatype, length) 1134 if (err .ne. NF90_NOERR) then 1135 call errore('nf90mpi_inquire_attribute: ', err) 1136 end if 1137 if (datatype .ne. ATT_TYPE(j,i)) then 1138 call errori( & 1139 'nf90mpi_inquire_attribute: unexpected type for var ', i) 1140 end if 1141 if (length .ne. ATT_LEN(j,i)) then 1142 call errori( & 1143 'nf90mpi_inquire_attribute: unexpected length for var ', i) 1144 end if 1145 if (datatype .eq. NF90_CHAR) then 1146 err = nf90mpi_get_att(ncid, i, name, text) 1147 if (err .ne. NF90_NOERR) then 1148 call errore('nf90mpi_get_att: ', err) 1149 end if 1150 do 3, k = 1, ATT_LEN(j,i) 1151 ndx(1) = k 1152 if (ichar(text(k:k)) .ne. hash(datatype, -1, & 1153 ndx)) & 1154 then 1155 call errori( & 1156 'nf90mpi_get_att: unexpected value for var ', i) 1157 else 1158 nok = nok + 1 1159 end if 11603 continue 1161 else 1162 err = nf90mpi_get_att(ncid, i, name, value) 1163 do 4, k = 1, ATT_LEN(j,i) 1164 ndx(1) = k 1165 expect = hash(datatype, -1, ndx) 1166 if (inRange(expect,ATT_TYPE(j,i))) then 1167 if (err .ne. NF90_NOERR) then 1168 call errore( & 1169 'nf90mpi_get_att: ', err) 1170 end if 1171 if (.not. equal(value(k), expect, & 1172 ATT_TYPE(j,i), NFT_DOUBLE)) then 1173 call errori( & 1174 'Att value read not that expected for var ', i) 1175 else 1176 nok = nok + 1 1177 end if 1178 end if 11794 continue 1180 end if 11812 continue 11821 continue 1183 ! call print_nok(nok) 1184 end 1185 1186 1187! Check file (dims, vars, atts) corresponds to global variables */ 1188 subroutine check_file(filename) 1189 use pnetcdf 1190 implicit none 1191 character*(*) filename 1192#include "tests.inc" 1193 1194 integer ncid !/* netCDF id */ 1195 integer err !/* netCDF status */ 1196 1197 err = nf90mpi_open(comm, filename, NF90_NOWRITE, info, & 1198 ncid) 1199 if (err .ne. NF90_NOERR) then 1200 call errore('nf90mpi_open: ', err) 1201 else 1202 call check_dims(ncid) 1203 call check_vars(ncid) 1204 call check_atts(ncid) 1205 err = nf90mpi_close (ncid) 1206 if (err .ne. NF90_NOERR) then 1207 call errore('nf90mpi_close: ', err) 1208 end if 1209 end if 1210 end 1211 1212 1213! 1214! Functions for accessing attribute test data. 1215! 1216! NB: 'varid' is 0 for global attributes; thus, global attributes can 1217! be handled in the same loop as variable attributes. 1218! 1219 1220 integer FUNCTION VARID(VID) 1221 USE PNETCDF 1222 IMPLICIT NONE 1223 INTEGER VID 1224#include "tests.inc" 1225 IF (VID .LT. 1) THEN 1226 VARID = NF90_GLOBAL 1227 ELSE 1228 VARID = VID 1229 ENDIF 1230 end 1231 1232 1233 integer FUNCTION NATTS(VID) 1234 USE PNETCDF 1235 IMPLICIT NONE 1236 INTEGER VID 1237#include "tests.inc" 1238 IF (VID .LT. 1) THEN 1239 NATTS = numGatts 1240 ELSE 1241 NATTS = VAR_NATTS(VID) 1242 ENDIF 1243 END 1244 1245 1246 character*2 FUNCTION ATT_NAME(J,VID) 1247 USE PNETCDF 1248 IMPLICIT NONE 1249 INTEGER J 1250 INTEGER VID 1251#include "tests.inc" 1252 IF (VID .LT. 1) THEN 1253 ATT_NAME = GATT_NAME(J) 1254 ELSE 1255 ATT_NAME = ATTNAME(J,VID) 1256 ENDIF 1257 END 1258 1259 1260 integer FUNCTION ATT_TYPE(J,VID) 1261 USE PNETCDF 1262 IMPLICIT NONE 1263 INTEGER J 1264 INTEGER VID 1265#include "tests.inc" 1266 IF (VID .LT. 1) THEN 1267 ATT_TYPE = GATT_TYPE(J) 1268 ELSE 1269 ATT_TYPE = ATTTYPE(J,VID) 1270 ENDIF 1271 END 1272 1273 1274 integer FUNCTION ATT_LEN(J,VID) 1275 USE PNETCDF 1276 IMPLICIT NONE 1277 INTEGER J 1278 INTEGER VID 1279#include "tests.inc" 1280 IF (VID .LT. 1) THEN 1281 ATT_LEN = INT(GATT_LEN(J)) 1282 ELSE 1283 ATT_LEN = ATTLEN(J,VID) 1284 ENDIF 1285 END 1286 1287 1288! 1289! Return the minimum value of an internal type. 1290! 1291 DOUBLE PRECISION function internal_min(type) 1292 use pnetcdf 1293 implicit none 1294 integer type 1295 doubleprecision min_schar 1296 doubleprecision min_short 1297 doubleprecision min_int 1298 ! doubleprecision min_long 1299 doubleprecision max_float 1300 doubleprecision max_double 1301 doubleprecision min_int64 1302#include "tests.inc" 1303 1304 if (type .eq. NFT_CHAR) then 1305 internal_min = 0 1306 else if (type .eq. NFT_INT1) then 1307#if defined NF90_INT1_IS_C_SIGNED_CHAR 1308 internal_min = min_schar() 1309#elif defined NF90_INT1_IS_C_SHORT 1310 internal_min = min_short() 1311#elif defined NF90_INT1_IS_C_INT 1312 internal_min = min_int() 1313#elif defined NF90_INT1_IS_C_LONG 1314 internal_min = min_long() 1315#else 1316 internal_min = min_schar() 1317! #include "No C equivalent to Fortran INTEGER*1" 1318#endif 1319 else if (type .eq. NFT_INT2) then 1320#if defined NF90_INT2_IS_C_SHORT 1321 internal_min = min_short() 1322#elif defined NF90_INT2_IS_C_INT 1323 internal_min = min_int() 1324#elif defined NF90_INT2_IS_C_LONG 1325 internal_min = min_long() 1326#else 1327 internal_min = min_short() 1328! #include "No C equivalent to Fortran INTEGER*2" 1329#endif 1330 else if (type .eq. NFT_INT) then 1331#if defined NF90_INT_IS_C_INT 1332 internal_min = min_int() 1333#elif defined NF90_INT_IS_C_LONG 1334 internal_min = min_long() 1335#else 1336 internal_min = min_int() 1337! #include "No C equivalent to Fortran INTEGER" 1338#endif 1339 else if (type .eq. NFT_REAL) then 1340#if defined NF90_REAL_IS_C_FLOAT 1341 internal_min = -max_float() 1342#elif defined NF90_REAL_IS_C_DOUBLE 1343 internal_min = -max_double() 1344#else 1345 internal_min = -max_float() 1346! #include "No C equivalent to Fortran REAL" 1347#endif 1348 else if (type .eq. NFT_DOUBLE) then 1349#if defined NF90_DOUBLEPRECISION_IS_C_DOUBLE 1350 internal_min = -max_double() 1351#elif defined NF90_DOUBLEPRECISION_IS_C_FLOAT 1352 internal_min = -max_float() 1353#else 1354 internal_min = -max_double() 1355! #include "No C equivalent to Fortran DOUBLE" 1356#endif 1357 else if (type .eq. NFT_INT8) then 1358 internal_min = min_int64() 1359 else 1360 stop 'internal_min(): invalid type' 1361 end if 1362 end 1363 1364 1365! 1366! Return the maximum value of an internal type. 1367! 1368 DOUBLE PRECISION function internal_max(type) 1369 use pnetcdf 1370 implicit none 1371 integer type 1372 doubleprecision max_schar 1373 doubleprecision max_short 1374 doubleprecision max_int 1375 ! doubleprecision max_long 1376 doubleprecision max_float 1377 doubleprecision max_double 1378 doubleprecision max_int64 1379#include "tests.inc" 1380 1381 if (type .eq. NFT_CHAR) then 1382 internal_max = 255 1383 else if (type .eq. NFT_INT1) then 1384#if defined NF90_INT1_IS_C_SIGNED_CHAR 1385 internal_max = max_schar() 1386#elif defined NF90_INT1_IS_C_SHORT 1387 internal_max = max_short() 1388#elif defined NF90_INT1_IS_C_INT 1389 internal_max = max_int() 1390#elif defined NF90_INT1_IS_C_LONG 1391 internal_max = max_long() 1392#else 1393 internal_max = max_schar() 1394! #include "No C equivalent to Fortran INTEGER*1" 1395#endif 1396 else if (type .eq. NFT_INT2) then 1397#if defined NF90_INT2_IS_C_SHORT 1398 internal_max = max_short() 1399#elif defined NF90_INT2_IS_C_INT 1400 internal_max = max_int() 1401#elif defined NF90_INT2_IS_C_LONG 1402 internal_max = max_long() 1403#else 1404 internal_max = max_short() 1405! #include "No C equivalent to Fortran INTEGER*2" 1406#endif 1407 else if (type .eq. NFT_INT) then 1408#if defined NF90_INT_IS_C_INT 1409 internal_max = max_int() 1410#elif defined NF90_INT_IS_C_LONG 1411 internal_max = max_long() 1412#else 1413 internal_max = max_int() 1414! #include "No C equivalent to Fortran INTEGER" 1415#endif 1416 else if (type .eq. NFT_REAL) then 1417#if defined NF90_REAL_IS_C_FLOAT 1418 internal_max = max_float() 1419#elif defined NF90_REAL_IS_C_DOUBLE 1420 internal_max = max_double() 1421#else 1422 internal_max = max_float() 1423! #include "No C equivalent to Fortran REAL" 1424#endif 1425 else if (type .eq. NFT_DOUBLE) then 1426#if defined NF90_DOUBLEPRECISION_IS_C_DOUBLE 1427 internal_max = max_double() 1428#elif defined NF90_DOUBLEPRECISION_IS_C_FLOAT 1429 internal_max = max_float() 1430#else 1431 internal_max = max_double() 1432! #include "No C equivalent to Fortran DOUBLE" 1433#endif 1434 else if (type .eq. NFT_INT8) then 1435 internal_max = max_int64() 1436 else 1437 stop 'internal_max(): invalid type' 1438 end if 1439 end 1440 1441 1442! 1443! Return the minimum value of an external type. 1444! 1445 DOUBLE PRECISION function external_min(type) 1446 use pnetcdf 1447 implicit none 1448 integer type 1449#include "tests.inc" 1450 1451 if (type .eq. NF90_BYTE) then 1452 external_min = X_BYTE_MIN 1453 else if (type .eq. NF90_CHAR) then 1454 external_min = X_CHAR_MIN 1455 else if (type .eq. NF90_SHORT) then 1456 external_min = X_SHORT_MIN 1457 else if (type .eq. NF90_INT) then 1458 external_min = X_INT_MIN 1459 else if (type .eq. NF90_FLOAT) then 1460 external_min = X_FLOAT_MIN 1461 else if (type .eq. NF90_DOUBLE) then 1462 external_min = X_DOUBLE_MIN 1463 else if (type .eq. NF90_INT64) then 1464 external_min = X_INT8_MIN 1465 else 1466 stop 'external_min(): invalid type' 1467 end if 1468 end 1469 1470 1471! 1472! Return the maximum value of an internal type. 1473! 1474 DOUBLE PRECISION function external_max(type) 1475 use pnetcdf 1476 implicit none 1477 integer type 1478#include "tests.inc" 1479 1480 if (type .eq. NF90_BYTE) then 1481 external_max = X_BYTE_MAX 1482 else if (type .eq. NF90_CHAR) then 1483 external_max = X_CHAR_MAX 1484 else if (type .eq. NF90_SHORT) then 1485 external_max = X_SHORT_MAX 1486 else if (type .eq. NF90_INT) then 1487 external_max = X_INT_MAX 1488 else if (type .eq. NF90_FLOAT) then 1489 external_max = X_FLOAT_MAX 1490 else if (type .eq. NF90_DOUBLE) then 1491 external_max = X_DOUBLE_MAX 1492 else if (type .eq. NF90_INT64) then 1493 external_max = X_INT8_MAX 1494 else 1495 stop 'external_max(): invalid type' 1496 end if 1497 end 1498 1499 1500! 1501! Indicate whether or not a value lies in the range of an internal type. 1502! 1503 logical function in_internal_range(itype, value) 1504 use pnetcdf 1505 implicit none 1506 integer itype 1507 doubleprecision value 1508#include "tests.inc" 1509 double precision internal_min, internal_max 1510 1511 in_internal_range = value .ge. internal_min(itype) .and. & 1512 value .le. internal_max(itype) 1513 end 1514 1515