home *** CD-ROM | disk | FTP | other *** search
/ Photo CD Demo 1 / Demo.bin / hdf / unix / hdf3_2r2 / test / tanfilef.f < prev    next >
Encoding:
Text File  |  1992-10-29  |  7.0 KB  |  248 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/tanfilef.f,v 1.4 1992/06/29 20:34:06 chouck beta koziol $
  26. C
  27. C $Log: tanfilef.f,v $
  28. c Revision 1.4  1992/06/29  20:34:06  chouck
  29. c Cast strings to smaller values for comparisions.  The last
  30. c byte of annotations and labels returned is NULL so the
  31. c string comparisions get confused
  32. c
  33. c Revision 1.3  1992/05/06  23:03:22  sxu
  34. c changed hiopen to hopen and hiclose to hclose
  35. c hopen returns fid (not ret)
  36. c
  37. c Revision 1.2  1992/04/27  20:49:14  koziol
  38. c Changed hopen and hclose calls to hiopen and hiclose stub routine calls
  39. c
  40. c Revision 1.1  1992/04/27  17:07:49  sxu
  41. c Initial revision
  42. c
  43. C
  44.       program tdfanfileF
  45. C
  46. C
  47. C  Test program: 
  48. C                Writes file labels and descriptions in a file.
  49. C                Reads the  labels and descriptions from the file
  50. C
  51. C  Input file:  none
  52. C  Output files: tdfanflF.hdf
  53. C
  54. C  Possible bug:  When reading in a label, we have to give it a 
  55. C                 length that is one greater than MAXLEN_LAB. This
  56. C                 may be due to a bug in dfan.c in DFANIgetann().
  57. C
  58.  
  59.       integer daafid, daafds,dagfidl,dagfid
  60.       integer dagfdsl, dagfds, hopen, hclose
  61.       integer ret, number_failed
  62.       integer ISFIRST, NOFIRST, MAXLEN_LAB, MAXLEN_DESC
  63.       integer fid, DFACC_CREATE, DFACC_READ
  64.  
  65.       character*35 lab1, lab2
  66.       character*35 templab
  67.       character*100 desc1, desc2, tempstr
  68.       character*64 TESTFILE
  69.       character*1 CR
  70.       character*1 NULL
  71.  
  72.       ISFIRST = 1
  73.       NOFIRST = 0
  74.       number_failed = 0
  75.       TESTFILE = 'tdfanflF.hdf'
  76.       CR = char(10)
  77.       MAXLEN_LAB = 35
  78.       MAXLEN_DESC = 100
  79.       DFACC_CREATE = 4
  80.       DFACC_READ = 1
  81.       NULL = char(0)
  82.  
  83.       lab1 = 'File label #1: aaa'
  84.       lab2 = 'File label #2: bbbbbb'
  85.       desc1 = 'File descr #1: This is a test file annotation'
  86.       desc2 = 'File descr #2: One more test ...'
  87.  
  88.       print *, '****** Write file labels *******'
  89.       fid = hopen(TESTFILE, DFACC_CREATE, 0)
  90.       call RESULT(fid, 'hopen')
  91.       ret = daafid(fid, lab1)
  92.       call RESULT(ret, 'daafid')
  93.  
  94.       ret = daafid(fid, lab2)
  95.       call RESULT(ret, 'daafid')
  96.  
  97.       print *, '****** Write file descriptions *******'
  98.       ret = daafds(fid, desc1, len(desc1))
  99.       call RESULT(ret, 'daafds')
  100.  
  101.       ret = daafds(fid, desc2, len(desc2))
  102.       call RESULT(ret, 'daafds')
  103.  
  104.       ret = hclose(fid)
  105.       call RESULT(ret, 'hclose')
  106.  
  107.       print *, '****** Read length of the first file label ****'
  108.       fid = hopen(TESTFILE, DFACC_READ, 0)
  109.       call RESULT(fid, 'hopen-read')
  110.       ret = dagfidl(fid, ISFIRST)
  111.       call RESULT(ret, 'dagfidl')
  112.       call checklen(ret, lab1,  'label'  )
  113.  
  114.       print *, '******...followed by the label *****'
  115.       ret = dagfid(fid, templab, MAXLEN_LAB, ISFIRST)
  116.  
  117.       call RESULT(ret, 'dagfid')
  118.       call checklab(lab1, templab, ret, 'label')
  119.  
  120.       print *, '****** Read length of the second file label ****'
  121.       ret = dagfidl(fid, NOFIRST)
  122.       call RESULT(ret, 'dagfidl')
  123.       call checklen(ret, lab2, 'label')
  124.  
  125.       print *, '******...followed by the label *****'
  126.       ret = dagfid(fid, templab, MAXLEN_LAB, NOFIRST)
  127.       call RESULT(ret, 'dagfid')
  128.       call checklab(lab2, templab, ret, 'label')
  129.  
  130.       print *, '****** Read length of the first file description ****'
  131.       ret = dagfdsl(fid, ISFIRST)
  132.       call RESULT(ret, 'dagfdsl')
  133.       call checklen(ret, desc1, 'description' )
  134.  
  135.       print *, '******...followed by the description *****'
  136.       ret = dagfds(fid, tempstr, MAXLEN_DESC, ISFIRST)
  137.       call RESULT(ret, 'dagfds')
  138.       call checkann(desc1, tempstr, ret, 'description')
  139.  
  140.       print *, '****** Read length of the second file description ****'
  141.       ret = dagfdsl(fid, NOFIRST)
  142.       call RESULT(ret, 'dagfdsl')
  143.       call checklen(ret, desc2, 'description' )
  144.  
  145.       print *, '******...followed by the description *****'
  146.       ret = dagfds(fid, tempstr, MAXLEN_DESC, NOFIRST)
  147.       call RESULT(ret, 'dagfds')
  148.       call checkann(desc2, tempstr, ret, 'description')
  149.      
  150.       ret = hclose(fid)
  151.       call RESULT(ret, 'hclose')
  152.  
  153.       print *, CR, CR
  154.  
  155.       if (number_failed .eq. 0) then
  156.          print *, '***** ALL TESTS SUCCESSFUL ******'
  157.       else
  158.          print *, '********', number_failed, ' TESTS FAILED'
  159.       endif
  160.  
  161.  
  162.       stop
  163.       end
  164.  
  165.  
  166. C*******************************************
  167. C
  168. C   RESULT
  169. C
  170. C*******************************************
  171.  
  172.       subroutine RESULT(errval, routine)
  173.       integer errval
  174.       character*(*)  routine
  175.  
  176.       integer FAIL
  177.  
  178.       FAIL = -1
  179.       if (errval .eq. FAIL) then
  180.          number_failed = number_failed + 1
  181.          print *, '    >>>', routine, ' FAILED: ret = ',
  182.      *               errval, '   <<<'
  183.       else
  184.          print *, routine, '  SUCCESSFUL'
  185.       endif
  186.       return
  187.       end
  188.  
  189. C*********************************************
  190. C
  191. C  checklen
  192. C
  193. C*********************************************
  194.  
  195.       subroutine checklen(ret, oldstr, type)
  196.       character*(*) type, oldstr 
  197.       integer ret
  198.  
  199.       integer oldlen
  200.  
  201.       oldlen = len(oldstr) 
  202.       if (ret .ge. 0 .and.  ret .ne. oldlen) then
  203.           print *, 'Length of ', type, ' is ', len(oldstr),
  204.      *             ' instead of ', ret
  205.       endif
  206.       return
  207.       end
  208.  
  209. C***********************************************
  210. C
  211. C  checkann
  212. C
  213. C***********************************************
  214.  
  215.       subroutine checkann(oldstr, newstr, ret, type)
  216.       character*90  oldstr, newstr
  217.       character*(*) type
  218.       integer ret
  219.  
  220.  
  221.       if (ret .ge. 0 .and. oldstr .ne. newstr) then
  222.           print *, type, ' is incorrect.'
  223.           print *, ' It should be <', oldstr, '>'
  224.           print *, ' instead of   <', newstr, '>'
  225.       endif
  226.       return 
  227.       end
  228.  
  229. C***********************************************
  230. C
  231. C  checklab
  232. C
  233. C***********************************************
  234.  
  235.       subroutine checklab(oldstr, newstr, ret, type)
  236.       character*30  oldstr, newstr
  237.       character*(*) type
  238.       integer ret
  239.  
  240.  
  241.       if (ret .ge. 0 .and. oldstr .ne. newstr) then
  242.           print *, type, ' is incorrect.'
  243.           print *, ' It should be <', oldstr, '>'
  244.           print *, ' instead of   <', newstr, '>'
  245.       endif
  246.       return 
  247.       end
  248.