home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / general / hdf / unix / hdf3_2r2.lha / HDF3.2r2 / test / tr8f.f < prev    next >
Encoding:
Text File  |  1992-10-28  |  9.2 KB  |  330 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/tr8f.f,v 1.5 1992/09/15 19:39:10 koziol beta koziol $
  26. C
  27. C $Log: tr8f.f,v $
  28. c Revision 1.5  1992/09/15  19:39:10  koziol
  29. c Added Shiming's changes to a couple of boolean tests
  30. c
  31. c Revision 1.4  1992/06/22  15:48:20  chouck
  32. c Changed integer*2 to integers.  The HP Fortran compiler
  33. c generates bogus code if you use a local called 'error'
  34. c so I renamed it.
  35. c
  36. c Revision 1.3  1992/05/08  18:40:08  sxu
  37. c fixed an typo.
  38. c
  39. c Revision 1.2  1992/05/04  16:29:28  sxu
  40. c Changed set write ref3 to ref1.
  41. c
  42. c Revision 1.1  1992/04/27  17:07:49  sxu
  43. c Initial revision
  44. c
  45. C
  46.       program tdfr8F
  47. C
  48. C Test program:
  49. C             Writes images together with pals to a file.
  50. C        Reads images from the file.
  51. C        Writes and reads images with speicfied ref's.
  52. C Input file: none
  53. C Output file: tdfr8f.hdf
  54. C
  55.       integer d8spal, d8pimg, d8aimg, d8gdims, d8nims
  56.       integer d8gimg, d8rref, d8wref, d8first, d8lref
  57.       integer DFTAG_RLE, DFTAG_IMCOMP
  58.  
  59.       character im1(100,100), im2(321, 111)
  60.       character ii1(100, 100), ii2(321, 111)
  61.       character pal1(768), pal2(768), ipal(768)
  62.       character*64 TESTFILE
  63.       character*1 CR
  64.  
  65.       integer x, y, ret, num_images, number_failed
  66.       integer d1, d2, ispal, FALSE, TRUE
  67.       integer ref1, ref2, ref3
  68.  
  69.       DFTAG_RLE = 11
  70.       DFTAG_IMCOMP = 12
  71.       TESTFILE = 'tdfr8f.hdf' 
  72.       FALSE = 0
  73.       TRUE = 1
  74.       number_failed = 0
  75.       CR = char(10)  
  76.  
  77.       do 120 x=1, 100
  78.           do 100 y=1, 100
  79.               im1(y,x) = char(x+y)
  80. 100       continue
  81. 120   continue
  82.  
  83.       do 180 x=1, 111
  84.           do 150 y=1, 321
  85.               im2(y,x) = char(y-x)
  86. 150       continue
  87. 180   continue
  88.  
  89.       do 200 x=1, 256
  90.           pal1(3*x - 2) = char(x)
  91.           pal1(3*x - 1) = char(x)
  92.           pal1(3*x ) = char(x)
  93.           pal2(x) = char(x)
  94.           pal2(x+256) = char(x)
  95.           pal2(x+512) = char(x)
  96. 200   continue
  97.  
  98. C Start here
  99.  
  100.       print *, 'Setting palette 1'
  101.       ret = d8spal(pal1)
  102.       call RESULT(ret, 'd8spal')
  103.       print *, 'Putting image 1 with pal 1, no compression'
  104.       ret=d8pimg(TESTFILE, im1, 100, 100, 0)
  105.       call RESULT(ret, 'd8pimg')
  106.       num_images = num_images + 1
  107.       print *, 'Getting ref1'
  108.       ref1 = d8lref()
  109.       print *, 'ref1 is ', ref1
  110.       
  111.       print *, 'Putting image 2 with pal 1, REL compression'
  112.       ret=d8aimg(TESTFILE, im2, 321, 111, DFTAG_RLE)
  113.       call RESULT(ret, 'd8aimg')
  114.       num_images = num_images + 1
  115.       print *, 'Getting ref2'
  116.       ref2 = d8lref()
  117.       print *, 'ref2 is ', ref2
  118.       
  119.       print *, 'Setting palette 2'
  120.       ret = d8spal(pal2)
  121.       call RESULT(ret, 'd8spal')
  122.       print *, 'Putting image 2 with pal 2, IMCOMP  compression'
  123.       ret=d8aimg(TESTFILE, im2, 321, 111, DFTAG_IMCOMP)
  124.       call RESULT(ret, 'd8aimg')
  125.       num_images = num_images + 1
  126.       print *, 'Getting ref3'
  127.       ref3 = d8lref()
  128.       print *, 'ref3 is ', ref3
  129.       
  130.       print *, 'Getting number of images'
  131.       ret = d8nims(TESTFILE)
  132.       if (ret .ne. num_images) then 
  133.           print *, '    >>>> WRONG NUMBER OF IMAGES  <<<   '
  134.       else 
  135.       print *, ret, ' images in the file'
  136.       endif
  137.       print *, 'Restarting file'
  138.       ret = d8first()
  139.       call RESULT(ret, 'd8first')
  140.       print *, 'Getting dimensions of first image'
  141.       ret=d8gdims(TESTFILE, d1, d2, ispal)
  142.       call RESULT(ret, 'd8gdims')
  143.       print *, 'Getting image 1'
  144.       ret=d8gimg(TESTFILE, ii1, 100, 100, ipal)
  145.       call RESULT(ret, 'd8gimg')
  146.       call check_im1_pal(100, 100, d1, d2, im1, ii1, pal1, ipal)
  147.       print *, 'Getting dimensions of image2'
  148.       ret=d8gdims(TESTFILE, d1, d2, ispal)
  149.       call RESULT(ret, 'd8gdims')
  150.       print *, 'd1= ',d1,' d2= ',d2,' ispal= ', ispal
  151.       print *, 'Getting dimensions of image 3'
  152.       ret=d8gdims(TESTFILE, d1, d2, ispal)
  153.       call RESULT(ret, ' d8gdims')
  154.       print *,'d1= ',d1, ' d2= ',d2,' ispal= ',ispal
  155.       print *, 'Getting image 3'
  156.       ret = d8gimg(TESTFILE, ii2, 321, 111, ipal)
  157.       call RESULT(ret, 'd8gimg')
  158.  
  159.       print *, 'setting read ref2'
  160.       ret = d8rref(TESTFILE, ref2)
  161.       call RESULT(ret, 'd8rref')
  162.  
  163.       print *, 'Getting image 2'
  164.       ret = d8gimg(TESTFILE, ii2, 321, 111,ipal)
  165.       call RESULT(ret, 'd8gimg')
  166.       call check_im2_pal(321,111,321, 111, im2, ii2, pal1, ipal)
  167.       print *,'Setting write ref1'
  168.       ret = d8wref(TESTFILE, ref1)
  169.       call RESULT(ret, 'd8wref')
  170.       print *, 'Setting palette 2'
  171.       ret = d8spal(pal2)
  172.       call RESULT(ret, 'd8spal')
  173.       print *,'Putting image 1 with pal 2, RLE'
  174.       ret = d8aimg(TESTFILE, im1, 100, 100, DFTAG_RLE)
  175.       call RESULT(ret, 'd8aimg')
  176.       print *, 'Setting read ref1'
  177.       ret = d8rref(TESTFILE, ref1)
  178.       call RESULT(ret, 'd8rref')
  179.       print *, 'Getting dimensions of first image'
  180.       ret = d8gdims(TESTFILE, d1, d2, ispal)
  181.       call RESULT(ret, 'd8gdims')
  182.       print *, 'd1= ', d1, ' d2= ',d2, ' ispal= ', ispal
  183.       print *, 'Getting image 1'
  184.       ret = d8gimg(TESTFILE, ii1, d1, d2, ipal)
  185.       call RESULT(ret, 'd8gimg')
  186.       call check_im1_pal(100, 100, d1, d2, im1, ii1, pal2, ipal)
  187.       print *, CR, CR
  188.  
  189.       if (number_failed .eq. 0) then
  190.           print *, '******  ALL TESTS SUCCESSFUL  *******'
  191.       else 
  192.           print *, '****' , number_failed, ' TESTS FAILED ****'
  193.       endif
  194.  
  195.       stop
  196.       end
  197.  
  198. C********************************************************
  199. C
  200. C RESUTL
  201. C
  202. C********************************************************
  203.  
  204.       subroutine RESULT(errval, routine)
  205.       integer errval
  206.       character*(*) routine
  207.     
  208.       integer FAIL
  209.  
  210.       FAIL = -1
  211.       if (errval .eq. FAIL)   then
  212.           number_failed = number_failed + 1
  213.           print *, '   >>> ', routine, '  FAILED: ret = ',
  214.      *               errval, '   <<<'
  215.       else 
  216.           print *, routine, '  SUCEESSFUL'
  217.       endif
  218.       return
  219.       end
  220.     
  221. C********************************************************
  222. C
  223. C check_im1_pal
  224. C 
  225. C********************************************************
  226.  
  227.       subroutine check_im1_pal(od1,od2,nd1,nd2,oim,nim,opal,npal)
  228.       integer od1, od2, nd1, nd2
  229.       character oim(100, 100), nim(100, 100)
  230.       character opal(768), npal(768)
  231.  
  232.  
  233.       integer prob, i, j
  234.       
  235.       prob = 0 
  236.       print *, 'Checking image and palette'
  237.  
  238.       if (od1 .ne. nd1 .OR. od2 .ne. nd2) then
  239.           print *,'    >>> DIMENSIONS WRONG <<<    '
  240.           prob = 1
  241.       endif
  242.       do 520 j=1, 100
  243.           do 500 i=1,100
  244.               if (oim(i,j) .ne. nim(i,j)) then
  245.               print *, '     ERROR at ', i, j,' old image: ',
  246.      *                    oim(i,j), ' new image: ', nim(i,j)
  247.                   prob = 1
  248.               endif
  249. 500       continue
  250. 520   continue
  251.        
  252.       if (prob .eq. 0) then
  253.           print *, 'Image is correct'
  254.       endif
  255.  
  256.       prob = 0
  257.       do 550 i=1,768
  258.           if (opal(i) .ne. npal(i)) then
  259.               print *, '    ERROR at ',i, 'old pal: ', opal(i),
  260.      *                  ' new pal: ', npal(i)
  261.           prob = 1
  262.       endif
  263. 550   continue
  264.       if (prob .eq. 0) then
  265.           print *, 'Palette is correct'
  266.       endif
  267.       return
  268.       end
  269.  
  270.     
  271. C********************************************************
  272. C
  273. C check_im2_pal
  274. C 
  275. C********************************************************
  276.  
  277.       subroutine check_im2_pal(od1,od2,nd1,nd2,oim,nim,opal,npal)
  278.       integer od1, od2, nd1, nd2
  279.       character oim(321, 111), nim(321, 111)
  280.       character opal(768), npal(768)
  281.  
  282.  
  283.       integer prob, i, j
  284.       
  285.       prob = 0
  286.       print *, 'Checking image and palette'
  287.  
  288.       if (od1 .ne. nd1 .OR. od2 .ne. nd2) then
  289.           print *,'    >>> DIMENSIONS WRONG <<<    '
  290.           prob = 1
  291.       endif
  292.       do 520 j=1, 111
  293.           do 500 i=1,321
  294.               if (oim(i,j) .ne. nim(i,j)) then
  295.               print *, '     ERROR at ', i, j,' old image: ',
  296.      *                    oim(i,j), ' new image: ', nim(i,j)
  297.                   prob = 1
  298.               endif
  299. 500       continue
  300. 520   continue
  301.        
  302.       if (prob .eq. 0) then
  303.           print *, 'Image is correct'
  304.       endif
  305.  
  306.       prob = 0
  307.       do 550 i=1,768
  308.           if (opal(i) .ne. npal(i)) then
  309.               print *, '    ERROR at ',i, 'old pal: ', opal(i),
  310.      *                  ' new pal: ', npal(i)
  311.           prob = 1
  312.       endif
  313. 550   continue
  314.       if (prob .eq. 0) then
  315.           print *, 'Palette is correct'
  316.       endif
  317.       return
  318.       end
  319.  
  320.  
  321.       
  322.       
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329.  
  330.