1C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
2C  Copyright by The HDF Group.                                               *
3C  Copyright by the Board of Trustees of the University of Illinois.         *
4C  All rights reserved.                                                      *
5C                                                                            *
6C  This file is part of HDF.  The full HDF copyright notice, including       *
7C  terms governing use, modification, and redistribution, is contained in    *
8C  the COPYING file, which can be found at the root of the source code       *
9C  distribution tree, or in https://support.hdfgroup.org/ftp/HDF/releases/.  *
10C  If you do not have access to either file, you may request a copy from     *
11C  help@hdfgroup.org.                                                        *
12C * * * * * * * * *  * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
13C
14C $Id$
15C
16      subroutine tpf (number_failed)
17C      program tpff
18      implicit none
19      include 'fortest.inc'
20C
21C
22C Test program: Writes palettes in a file.
23C               Reads palettes from the file.
24C               Writes palette with specified reference number.
25C               Reads palette with specified reference number.
26C
27C Input file: none
28C
29C Output file: tpalf.hdf
30C
31C
32
33      integer number_failed
34      character*20 myname
35      parameter (myname = 'p')
36
37      character*64 TESTFILE
38      character*1 CR
39      character pal1(768), pal2(768), ipal(768)
40      integer ret, ref
41      integer ref1, ref2, newref1, newref2
42      integer i
43
44
45      call ptestban('Testing', myname)
46      TESTFILE = 'tpalf.hdf'
47      CR = char(10)
48      number_failed = 0
49      ref = 0
50C
51C Initialize pal1 as {1, 2, 3, 4, 5, ...}
52C Initialize pal2 as {1, 1, 1, 2, 2, 2, ...}
53      do 100 i = 0, 255
54          pal1(3*i + 1) = char(i)
55          pal1(3*i + 2) = char(i)
56          pal1(3*i + 3) = char(i)
57          pal2(i + 1) = char(i)
58          pal2(i + 256 + 1) = char(i)
59          pal2(i + 512 + 1) = char(i)
60100   continue
61
62C
63C Write out pal1, then pal2.
64C Keep their ref number in ref1 and ref2.
65      call MESSAGE(VERBO_HI, 'Putting pal1 in new file.')
66      ret = dpppal(TESTFILE, pal1, 0, 'w')
67      call VRFY(ret, 'dpppal', number_failed)
68
69      call MESSAGE(VERBO_HI, 'Getting ref1')
70      ref1 = dplref()
71      ref = ref1*1
72      call VRFY(ref, 'dplref', number_failed)
73C VRFY expects an integer, but ref1 is only integer*2.  The
74C expression promotes it to an integer expression.
75
76      call MESSAGE(VERBO_HI, 'Putting pal2 in file')
77      ret = dpapal(TESTFILE, pal2)
78      call VRFY(ret, 'dpapal', number_failed)
79
80      call MESSAGE(VERBO_HI, 'Getting ref2')
81      ref2 = dplref()
82      ref = ref2*1
83      call VRFY(ref, 'dplref', number_failed)
84
85C
86C Reset the palettes for reading
87      call MESSAGE(VERBO_HI, 'Restarting palette interface')
88      ret = dprest()
89      call VRFY(ret, 'dprest', number_failed)
90
91C
92C Get palette 1 and match it with pal1
93      call MESSAGE(VERBO_HI, 'Reading pal1')
94      ret = dpgpal(TESTFILE, ipal)
95      call VRFY(ret, 'dpgpal', number_failed)
96      do 200 i=1, 768
97          if (ipal(i) .ne. pal1(i))  then
98              print *, 'Error at ', i, ', ipal:', ipal(i),
99     *                 '      pal1(i):', pal1(i)
100          endif
101200   continue
102
103C
104C verify the ref number is updated correctly too
105      call MESSAGE(VERBO_HI, 'Getting newref1')
106      newref1 =  dplref()
107      if (newref1 .ne. ref1) then
108	print *, 'Error: newref1 is ', newref1, ', should be ', ref1
109	number_failed = number_failed + 1
110      endif
111
112C
113C Get palette 2 and match it with pal2
114      call MESSAGE(VERBO_HI, 'Reading pal2.')
115      ret = dpgpal(TESTFILE, ipal)
116      call VRFY(ret, 'dpgpal', number_failed)
117      do 300 i=1, 768
118          if (ipal(i) .ne. pal2(i)) then
119              print *, 'Error at ', i, ', ipal:', ipal(i),
120     *                 '      pal2:', pal2(i)
121          endif
122300   continue
123
124C
125C Again verify the ref number
126      call MESSAGE(VERBO_HI, 'Getting ref2')
127      newref2 =  dplref()
128      if (newref2 .ne. ref2) then
129	print *, 'Error: newref2 is ', newref2, ', should be ', ref2
130	number_failed = number_failed + 1
131      endif
132
133C
134C Check number of palettes
135      call MESSAGE(VERBO_HI, 'Getting number of palettes')
136      ret = dpnpals(TESTFILE)
137      if (ret .ne. 2) then
138	print *, 'Error: number of palette is ', ret, ', should be 2'
139	number_failed = number_failed + 1
140      endif
141
142C
143C Explicitly set to palette of ref2 for reading
144      call MESSAGE(VERBO_HI, 'Setting read ref to ref2.')
145      ret = dprref(TESTFILE, ref2)
146      call VRFY(ret, 'dprref', number_failed)
147
148      call MESSAGE(VERBO_HI, 'Reading pal2')
149      ret = dpgpal(TESTFILE, ipal)
150      call VRFY(ret, 'dpgpal', number_failed)
151
152      newref2 =  dplref()
153      if (newref2 .ne. ref2) then
154         print *, 'Error: newref2 is ', newref2, ', should be ', ref2
155         number_failed = number_failed + 1
156      endif
157
158C
159C match it with pal2
160      do 400 i=1, 768
161          if (ipal(i) .ne. pal2(i)) then
162              print *,  'Error at ', i, ', ipal:', ipal(i),
163     *                 '      pal2:', pal2(i)
164          endif
165400   continue
166
167C
168C Explicitly set to palette of ref1 for reading
169      call MESSAGE(VERBO_HI, 'Setting read ref to ref1.')
170      ret = dprref(TESTFILE, ref1)
171      call VRFY(ret, 'dprref', number_failed)
172
173      call MESSAGE(VERBO_HI, 'Reading pal1')
174      ret = dpgpal(TESTFILE, ipal)
175      call VRFY(ret, 'dpgpal', number_failed)
176
177      newref1 =  dplref()
178      if (newref1 .ne. ref1) then
179          print *, 'Error: newref1 is ', newref1, ', should be ', ref1
180          number_failed = number_failed + 1
181      endif
182
183C
184C match it with pal1
185      do 500 i=1, 768
186          if (ipal(i) .ne. pal1(i)) then
187              print *,  'Error at ', i, ', ipal:', ipal(i),
188     *                 '      pal1:', pal1(i)
189          endif
190500   continue
191
192C
193C Modify the middle chunk of pal1 and replace its file copy.
194      call MESSAGE(VERBO_HI, 'Modifying pal1')
195      do 600 i=1,256
196          pal1(i+256) = char(256-i)
197600   continue
198
199      call MESSAGE(VERBO_HI, 'Setting write ref to ref1')
200      ret = dpwref(TESTFILE, ref1)
201      call VRFY(ret, 'dpwref', number_failed)
202      call MESSAGE(VERBO_HI, 'Writing pal1')
203      ret = dpppal(TESTFILE, pal1, 1, 'a')
204      call VRFY(ret, 'dpppal', number_failed)
205      ret=dplref()
206C     print *,'last ref is: ', ret
207      call MESSAGE(VERBO_HI, 'setting read ref to ref1')
208      ret = dprref(TESTFILE, ref1)
209      call VRFY(ret, 'dprref', number_failed)
210      call MESSAGE(VERBO_HI, 'Reading pal1')
211      ret = dpgpal(TESTFILE, ipal)
212      call VRFY(ret, 'dpgpal', number_failed)
213      do 700 i=1, 768
214          if (ipal(i) .ne. pal1(i)) then
215              print *,  'Error at ', i, ', ipal:', ipal(i),
216     *                 '      pal1:', pal1(i)
217          endif
218700   continue
219
220      if (number_failed .eq. 0) then
221          call MESSAGE(VERBO_DEF + 1,
222     +                '****** ALL TESTS SUCCESSFUL ******')
223      else
224          print *, '****** ', number_failed, ' TESTS FAILES  ******'
225      endif
226
227      return
228      end
229