home *** CD-ROM | disk | FTP | other *** search
/ Photo CD Demo 1 / Demo.bin / hdf / unix / hdf3_2r2 / test / tsdnmmsf.f < prev    next >
Encoding:
Text File  |  1992-10-29  |  11.5 KB  |  391 lines
  1. C***************************************************************************
  2. C
  3. C
  4. C                         NCSA HDF version 3.2r2
  5. C                            October 30, 1992
  6. C
  7. C NCSA HDF Version 3.2 source code and documentation are in the public
  8. C domain.  Specifically, we give to the public domain all rights for future
  9. C licensing of the source code, all resale rights, and all publishing rights.
  10. C
  11. C We ask, but do not require, that the following message be included in all
  12. C derived works:
  13. C
  14. C Portions developed at the National Center for Supercomputing Applications at
  15. C the University of Illinois at Urbana-Champaign, in collaboration with the
  16. C Information Technology Institute of Singapore.
  17. C
  18. C THE UNIVERSITY OF ILLINOIS GIVES NO WARRANTY, EXPRESSED OR IMPLIED, FOR THE
  19. C SOFTWARE AND/OR DOCUMENTATION PROVIDED, INCLUDING, WITHOUT LIMITATION,
  20. C WARRANTY OF MERCHANTABILITY AND WARRANTY OF FITNESS FOR A PARTICULAR PURPOSE
  21. C
  22. C***************************************************************************
  23.  
  24. C
  25. C $Header: /hdf/hdf/v3.2r2/test/RCS/tsdnmmsf.f,v 1.7 1992/07/08 22:05:20 sxu beta koziol $
  26. C
  27. C $Log: tsdnmmsf.f,v $
  28. c Revision 1.7  1992/07/08  22:05:20  sxu
  29. c Changed dsgmaxm() to dsgrang(), and dssmaxm() to dssrang().
  30. c
  31. c Revision 1.6  1992/07/07  21:51:03  chouck
  32. c Minor error reporting fix
  33. c
  34. c Revision 1.5  1992/07/07  20:56:29  chouck
  35. c Set things up so VMS users will use byte data types instead of characters.
  36. c
  37. c Revision 1.4  1992/06/29  15:44:30  chouck
  38. c Changed the OR() to an addition.  Removed bitwise assignment
  39. c to make VMS happy.
  40. c
  41. c Revision 1.3  1992/06/01  14:47:19  mfolk
  42. c OR function doesn't work on Convex.  Need to use JIOR instead.  So
  43. c I put in the following comment lines:
  44. c  C Some Fortrans do not have the 'OR' function.  If this
  45. c  C causes an error, try substituting 'JIOR'.
  46. c
  47. c Revision 1.2  1992/05/07  16:48:07  dilg
  48. c Put in comment explaining the choice between using "char(-128)" and
  49. c "char(0)"
  50. c
  51. c Revision 1.1  1992/04/27  17:17:46  sxu
  52. c Initial revision
  53. c
  54. c Revision 1.2  1992/03/24  20:42:04  sxu
  55. c Changed output file names
  56. c
  57. c Revision 1.1  1992/02/29  22:53:38  mfolk
  58. c Initial revision
  59. c
  60. C
  61.  
  62.       program tdfsd_nmmsF
  63. C
  64. C
  65. C  Program to test writing SDSs with different types of data and
  66. C  scales and max/min values.
  67. C
  68. C  Input file:  none
  69. C  Output files: fon.hdf
  70. C
  71. C  **** VMS users ****
  72. C
  73. C  VMS has a special way of handling the passsing of character
  74. C   strings between C and FORTRAN.  For these tests to work 
  75. C   correctly, you must change the definition of i8 and ti8
  76. C   to be 'byte' not 'character'  You will also need to remove
  77. C   a couple of calls to char().  If you search on the string 
  78. C   VMS you should be able to find all of the necessary changes.
  79. C
  80.    
  81.       integer dsgdata, dsadata, dssdims, dssrang, dsgrang, dssnt
  82.       integer dssdisc, dsgdisc
  83.  
  84.       real*8 f64(10,10), tf64(10,10)
  85.       real*8 f64scale(10), tf64scale(10)
  86.       real*8 f64max, f64min, tf64max, tf64min
  87.  
  88.       real*4 f32(10,10), tf32(10,10)
  89.       real*4 f32scale(10), tf32scale(10)
  90.       real*4 f32max, f32min, tf32max, tf32min
  91.  
  92. C  Change these to be of type 'byte' for VMS      
  93. C      byte i8(10,10), ti8(10,10)
  94. C      byte i8scale(10), ti8scale(10), i8max, i8min
  95. C      byte ti8max, ti8min
  96.       characteri8(10,10), ti8(10,10)
  97.       character i8scale(10), ti8scale(10), i8max, i8min
  98.       character ti8max, ti8min
  99.  
  100.       integer*2 i16(10,10), ti16(10,10)
  101.       integer*2 i16scale(10), ti16scale(10), i16max, i16min
  102.       integer*2 ti16max, ti16min
  103.  
  104.       integer*4 i32(10,10), ti32(10,10)
  105.       integer*4 i32scale(10), ti32scale(10), i32max, i32min
  106.       integer*4 ti32max, ti32min
  107.  
  108.       integer i, j, err, err1, err2, err3
  109.       integer rank, dims(2)
  110.       integer number_failed
  111.       integer DFNT_NFLOAT64, DFNT_NFLOAT32, DFNT_NINT8, DFNT_NINT16
  112.       integer DFNT_NINT32,  DFNT_NATIVE
  113.       integer DFNT_FLOAT64, DFNT_FLOAT32, DFNT_INT8, DFNT_INT16
  114.       integer DFNT_INT32 
  115.  
  116.       f64max = 40.0
  117.       f64min = 0.0
  118.       f32max = 40.0
  119.       f32min = 0.0
  120. C Use the following lines for VMS
  121. C      i8min = -128
  122. C      i8max = 127
  123.       i8max = char(127)
  124. C NOTE: If you get a compile error on the "char(-128)" line, substitute
  125. C       the "char(0)" line.  Its not quite as thorough a test, but...
  126. C      i8min = char(0)
  127.       i8min = char(-128)
  128.       i16max = 1200
  129.       i16min = -1200
  130.       i32max = 99999999
  131.       i32min = -999999999
  132.       
  133.       rank = 2
  134.       dims(1) = 10
  135.       dims(2) = 10
  136.       number_failed = 0
  137.       DFNT_FLOAT64 = 6
  138.       DFNT_FLOAT32 = 5
  139.       DFNT_INT8 = 20
  140.       DFNT_INT16 = 22
  141.       DFNT_INT32 = 24
  142.       DFNT_NATIVE = 4096
  143.  
  144. C These should really use a logical OR to compute these values
  145. C However, OR() is not really that portable
  146.  
  147.       DFNT_NFLOAT64 = DFNT_NATIVE + DFNT_FLOAT64
  148.       DFNT_NFLOAT32 = DFNT_NATIVE + DFNT_FLOAT32
  149.       DFNT_NINT8 =    DFNT_NATIVE + DFNT_INT8
  150.       DFNT_NINT16 =   DFNT_NATIVE + DFNT_INT16
  151.       DFNT_NINT32 =   DFNT_NATIVE + DFNT_INT32
  152.       
  153.       print *, 'Creating arrays...'
  154.       
  155.       do 110 i=1,10
  156.           do 100 j=1,10
  157.             f64(i,j) = (i * 40) + j
  158.             f32(i,j) = (i * 40) + j
  159. C  Use the following line for VMS
  160. C            i8(i,j) =  (i * 10) + j
  161.              i8(i,j) = char( (i * 10) + j )
  162.             i16(i,j) = (i * 3000) + j
  163.             i32(i,j) = (i * 20) + j
  164.   100     continue
  165.           f64scale(i) = (i * 40) + j
  166.           f32scale(i) = (i * 40) + j
  167. C  Use the following line for VMS
  168. C          i8scale(i) = (i * 10) + j
  169.           i8scale(i) = char((i * 10) + j)
  170.             i16scale(i) = (i * 3000) + j
  171.             i32scale(i) = (i * 20) + j
  172.   110 continue
  173.  
  174.       err1 = dssdims(rank, dims)
  175.       
  176. C
  177. C  Writing dimscale, max/min, and arrays to a single file 
  178. C
  179.       print *, 'Writing arrays to single file...'
  180.  
  181.       err  = dssnt(DFNT_NFLOAT64)
  182.       err1 = dssdisc(1, 10, f64scale)
  183.       err2 = dssrang(f64max, f64min)
  184.       err3 = dsadata('fon.hdf', rank, dims, f64)
  185.       call errchkio(err1, err2, err3, number_failed, 'float64 write')
  186.       
  187.       err  = dssnt(DFNT_NFLOAT32)
  188.       err1 = dssdisc(1, 10, f32scale)
  189.       err2 = dssrang(f32max, f32min)
  190.       err3 = dsadata('fon.hdf', rank, dims, f32)
  191.       call errchkio(err1, err2, err3, number_failed, 'float32 write')
  192.  
  193.       err  = dssnt(DFNT_NINT8)
  194.       err1 = dssdisc(1, 10, i8scale)
  195.       err2 = dssrang(i8max, i8min)
  196.       err3 = dsadata('fon.hdf', rank, dims, i8)
  197.       call errchkio(err1, err2, err3, number_failed, 'int8 write')
  198.       
  199.       
  200.       err  = dssnt(DFNT_NINT16)
  201.       err1 = dssdisc(1, 10, i16scale)
  202.       err2 = dssrang(i16max, i16min)
  203.       err3 = dsadata('fon.hdf', rank, dims, i16)
  204.       call errchkio(err1, err2, err3, number_failed, 'int16 write')
  205.       
  206.       err  = dssnt(DFNT_NINT32)
  207.       err1 = dssdisc(1, 10, i32scale)
  208.       err2 = dssrang(i32max, i32min)
  209.       err3 = dsadata('fon.hdf', rank, dims, i32)
  210.       call errchkio(err1, err2, err3, number_failed, 'int32 write')
  211.       
  212. C
  213. C  Reading back dimscales, max/min, and arrays from single file
  214. C
  215.       err1 = dsgdata('fon.hdf', rank, dims, tf64)
  216.       err2 = dsgdisc(1, 10, tf64scale)
  217.       err3 = dsgrang(tf64max, tf64min)
  218.       call errchkio(err1, err2, err3, number_failed, 'float64 read')
  219.      
  220.       err1 = dsgdata('fon.hdf', rank, dims, tf32) 
  221.       err2 = dsgdisc(1, 10, tf32scale)
  222.       err3 = dsgrang(tf32max, tf32min)
  223.       call errchkio(err1, err2, err3, number_failed, 'float32 read')
  224.       
  225.       err1 = dsgdata('fon.hdf', rank, dims, ti8)
  226.       err2 = dsgdisc(1, 10, ti8scale)
  227.       err3 = dsgrang(ti8max, ti8min)
  228.       call errchkio(err1, err2, err3, number_failed, 'int8 read')
  229.       
  230.       err1 = dsgdata('fon.hdf', rank, dims, ti16)
  231.       err2 = dsgdisc(1, 10, ti16scale)
  232.       err3 = dsgrang(ti16max, ti16min)
  233.       call errchkio(err1, err2, err3, number_failed, 'int16 read')
  234.       
  235.       err1 = dsgdata('fon.hdf', rank, dims, ti32)
  236.       err2 = dsgdisc(1, 10, ti32scale)
  237.       err3 = dsgrang(ti32max, ti32min)
  238.       call errchkio(err1, err2, err3, number_failed, 'int32 read')
  239.       
  240. C
  241. C  Checking dimscales, max/min and arrays from single file
  242. C
  243.       print *, 'Checking dimscales, max/min & arrays from single file'
  244.  
  245. C  float64
  246.       err1 = 0
  247.       err2 = 0
  248.       err3 = 0
  249.       do 1010 i=1,10
  250.          do 1000 j=1,10
  251.            if (f64(i,j) .ne. tf64(i,j)) err1 = 1
  252.  1000    continue
  253.         if (f64scale(i) .ne. tf64scale(i)) err2 = 1
  254.  1010 continue
  255.  
  256.       if ((f64max .ne. tf64max) .or. (f64min .ne. tf64min)) err3 = 1
  257.       call errchkarr(err1, err2, err3, number_failed, 'float64')
  258.  
  259. C  float32
  260.       err1 = 0
  261.       err2 = 0
  262.       err3 = 0
  263.       do 1030 i=1,10
  264.          do 1020 j=1,10
  265.            if (f32(i,j) .ne. tf32(i,j)) err1 = 1
  266.  1020    continue
  267.          if (f32scale(i) .ne. tf32scale(i)) err2 = 1
  268.  1030 continue
  269.  
  270.       if ((f32max .ne. tf32max) .or. (f32min .ne. tf32min)) err3 = 1
  271.       call errchkarr(err1, err2, err3, number_failed, 'float32')
  272.  
  273. C  int8
  274.       err1 = 0
  275.       err2 = 0
  276.       err3 = 0
  277.       do 1110 i=1,10
  278.          do 1100 j=1,10
  279.            if (i8(i,j) .ne. ti8(i,j)) err1 = 1
  280.  1100    continue
  281.          if (i8scale(i) .ne. ti8scale(i)) err2 = 1
  282.  1110 continue
  283.  
  284.       if ((i8max .ne. ti8max) .or. (i8min .ne. ti8min)) err3 = 1
  285.       call errchkarr(err1, err2, err3, number_failed, 'int8')
  286.  
  287. C  int16
  288.       err1 = 0
  289.       err2 = 0
  290.       err3 = 0   
  291.       do 1210 i=1,10
  292.          do 1200 j=1,10
  293.            if (i16(i,j) .ne. ti16(i,j)) err1 = 1
  294.  1200    continue
  295.          if (i16scale(i) .ne. ti16scale(i)) err2 = 1
  296.  1210 continue
  297.  
  298.       if ((i16max .ne. ti16max) .or. (i16min .ne. ti16min)) err3 = 1
  299.       call errchkarr(err1, err2, err3, number_failed, 'int16')
  300.  
  301. C  int32
  302.       err1 = 0
  303.       err2 = 0
  304.       err3 = 0   
  305.       do 1310 i=1,10
  306.          do 1300 j=1,10
  307.            if (i32(i,j) .ne. ti32(i,j)) err1 = 1
  308.  1300    continue
  309.            if (i32scale(i) .ne. ti32scale(i)) err2 = 1
  310.  1310 continue
  311.  
  312.       if ((i32max .ne. ti32max) .or. (i32min .ne. ti32min)) err3 = 1
  313.       call errchkarr(err1, err2, err3, number_failed, 'int32')
  314. C
  315. C  Sum up
  316. C
  317.       
  318.       if (number_failed .gt. 0 ) then
  319.           print *, '        >>> ', number_failed, ' TESTS FAILED <<<'
  320.       else
  321.           print *, '        >>> ALL TESTS PASSED <<<'
  322.       endif
  323.  
  324.       stop
  325.       end
  326.  
  327.  
  328. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  329. C
  330. C     SUBROUTINE errchkio
  331. C
  332. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  333.       subroutine errchkio(err1, err2, err3, num_fail, msg)
  334.       integer err1, err2, err3, num_fail
  335.       character*(*)  msg
  336.  
  337.       integer FAIL
  338.  
  339.       FAIL = -1
  340.  
  341.       if (err1.eq.FAIL .or. err2.eq.FAIL .or. err3.eq.FAIL) then
  342.           num_fail = num_fail + 1
  343.           print *
  344.           print *,'>>> Test failed for ',msg, ' <<<'
  345.           print *, '  err1=',err1, '   err2=',err2, '   err3=',err3
  346.       else
  347.           print *,'Test passed for ', msg
  348.       endif
  349.       print *
  350.  
  351.       return
  352.       end
  353.  
  354.       
  355. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  356. C
  357. C     SUBROUTINE errchkarr
  358. C
  359. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  360.       subroutine errchkarr(err1, err2, err3, num_fail, type)
  361.       integer err1, err2, err3, num_fail
  362.       character*(*)  type
  363.       
  364.       print *
  365.       if (err1 .eq. 1) then
  366.         print *, '>>> Test failed for ', type, ' array' 
  367.         num_fail = num_fail + 1
  368.       else
  369.         print *, 'Test passed for ', type, ' array'
  370.       endif
  371.  
  372.       if (err2 .eq. 1) then
  373.         print *, '>>> Test failed for ',type, ' scales.'
  374.         num_fail = num_fail + 1
  375.       else
  376.         print *, 'Test passed for ', type, ' scales.'
  377.       endif
  378.  
  379.       if (err3 .eq. 1) then
  380.         print *, '>>> Test failed for ', type, ' max/min.'
  381.         num_fail = num_fail + 1
  382.       else
  383.         print *, 'Test passed for ', type, ' max/min.'
  384.       endif
  385.  
  386.       print *
  387.  
  388.       return
  389.       end
  390.  
  391.