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