"Fossies" - the Fresh Open Source Software Archive

Member "netcdf-fortran-4.4.5/nf_test/util.F" (31 Jan 2019, 45089 Bytes) of package /linux/misc/netcdf-fortran-4.4.5.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Fortran 77 source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "util.F": 4.4.4_vs_4.4.5.

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