1C 2C pack_f.f: (de)compress diffraction image files 3C Copyright (C) 1995 Jan P Abrahams 4C 5C This library is free software: you can redistribute it and/or 6C modify it under the terms of the GNU Lesser General Public License 7C version 3, modified in accordance with the provisions of the 8C license to address the requirements of UK law. 9C 10C You should have received a copy of the modified GNU Lesser General 11C Public License along with this library. If not, copies may be 12C downloaded from http://www.ccp4.ac.uk/ccp4license.php 13C 14C This program is distributed in the hope that it will be useful, 15C but WITHOUT ANY WARRANTY; without even the implied warranty of 16C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17C GNU Lesser General Public License for more details. 18c 19c 20c 21 subroutine pack_wordimage (data, x, y, filn) 22c ================================= 23c 24c Pack data stored in the array DATA with dimensions x * y in file FILN. 25c 26 implicit none 27c 28 character*(*) filn 29 integer*4 x, y, j 30 integer*2 data(x, y) 31 integer*4 filnarray(1025) 32c 33c .. 34c .. External C-routine 35 external pack_wordimage_f 36 37 do 10, j = 1, len(filn) 38 if (filn(j:j) .ne. ' ') then 39 filnarray(j) = ichar(filn(j:j)) 40 else 41 filnarray(j) = 0 42 endif 43 10 continue 44 filnarray(len(filn) + 1) = 0 45 call pack_wordimage_f(data, x, y, filnarray) 46 return 47 end 48 49c******************************************************************************* 50c 51c 52c 53 subroutine v2pack_wordimage (data, x, y, filn) 54c ================================= 55c 56c Pack data stored in the array DATA with dimensions x * y in file FILN. 57c 58 implicit none 59c 60 character*(*) filn 61 integer*4 x, y, j 62 integer*2 data(x, y) 63 integer*4 filnarray(1025) 64c 65c .. 66c .. External C-routine 67 external v2pack_wordimage_f 68 69 do 10, j = 1, len(filn) 70 if (filn(j:j) .ne. ' ') then 71 filnarray(j) = ichar(filn(j:j)) 72 else 73 filnarray(j) = 0 74 endif 75 10 continue 76 filnarray(len(filn) + 1) = 0 77 call v2pack_wordimage_f(data, x, y, filnarray) 78 return 79 end 80 81c******************************************************************************* 82c 83c 84c 85 subroutine pack_longimage (data, x, y, filn) 86c ================================= 87c 88c Pack data stored in the array DATA with dimensions x * y in file FILN. 89c 90 implicit none 91c 92 character*(*) filn 93 integer*4 x, y, j 94 integer*4 data(x, y) 95 integer*4 filnarray(1025) 96c 97c .. 98c .. External C-routine 99 external pack_wordimage_f 100c 101 do 10, j = 1, len(filn) 102 if (filn(j:j) .ne. ' ') then 103 filnarray(j) = ichar(filn(j:j)) 104 else 105 filnarray(j) = 0 106 endif 107 10 continue 108 filnarray(len(filn) + 1) = 0 109 call pack_wordimage_f(data, x, y, filnarray) 110 return 111 end 112 113c******************************************************************************* 114c 115c 116c 117 subroutine v2pack_longimage (data, x, y, filn) 118c ================================= 119c 120c Pack data stored in the array DATA with dimensions x * y in file FILN. 121c 122 implicit none 123c 124 character*(*) filn 125 integer*4 x, y, j 126 integer*4 data(x, y) 127 integer*4 filnarray(1025) 128c 129c .. 130c .. External C-routine 131 external v2pack_wordimage_f 132c 133 do 10, j = 1, len(filn) 134 if (filn(j:j) .ne. ' ') then 135 filnarray(j) = ichar(filn(j:j)) 136 else 137 filnarray(j) = 0 138 endif 139 10 continue 140 filnarray(len(filn) + 1) = 0 141 call v2pack_wordimage_f(data, x, y, filnarray) 142 return 143 end 144 145c******************************************************************************* 146c 147c 148c 149 subroutine readpack_word (data, filn) 150c ================================= 151c 152c Read a packed image from file 'filn' into array 'data'. If you want 153c to generate the mirror-image, (interchange first and last stripes, etc.) 154c call "mirror_wordimg(data, nfast, nslow)", where nfast and nslow contain 155c the number of fast and slow indices, after reading the packed image. 156c 157 implicit none 158c 159 character*(*) filn 160 integer*2 data, j 161 integer*4 filnarray(1025) 162c 163c .. 164c .. External C-routine 165 external readpack_word_f 166c 167 do 10, j = 1, len(filn) 168 if (filn(j:j) .ne. ' ') then 169 filnarray(j) = ichar(filn(j:j)) 170 else 171 filnarray(j) = 0 172 endif 173 10 continue 174 filnarray(len(filn) + 1) = 0 175 call readpack_word_f(data, filnarray) 176 return 177 end 178 179c******************************************************************************* 180c 181c 182c 183 subroutine readpack_long (data, filn) 184c ================================= 185c 186c Read a packed image from file 'filn' into array 'data'. If you want 187c to generate the mirror-image, (interchange first and last stripes, etc.) 188c call "mirror_wordimg(data, nfast, nslow)", where nfast and nslow contain 189c the number of fast and slow indices, after reading the packed image. 190c 191 implicit none 192c 193 character*(*) filn 194 integer*4 data, j 195 integer*4 filnarray(1025) 196c 197c .. 198c .. External C-routine 199 external readpack_long_f 200c 201 do 10, j = 1, len(filn) 202 if (filn(j:j) .ne. ' ') then 203 filnarray(j) = ichar(filn(j:j)) 204 else 205 filnarray(j) = 0 206 endif 207 10 continue 208 filnarray(len(filn) + 1) = 0 209 call readpack_long_f(data, filnarray) 210 return 211 end 212 213c******************************************************************************* 214c 215c 216c 217 subroutine imsiz (filn, x, y) 218c ================================= 219c 220c Determines the size of the the packed image "filename" after 221c unpacking.The dimensions are returned in x and y. 222c Read a packed image from file 'filn' into array 'data'. 223c 224 implicit none 225c 226 character*(*) filn 227 integer*4 x, y, j 228 integer*4 filnarray(1025) 229c 230c .. 231c .. External C-routine 232 external imsiz_f 233c 234 do 10, j = 1, len(filn) 235 if (filn(j:j) .ne. ' ') then 236 filnarray(j) = ichar(filn(j:j)) 237 else 238 filnarray(j) = 0 239 endif 240 10 continue 241 filnarray(len(filn) + 1) = 0 242 call imsiz_f(filnarray, x, y) 243 return 244 end 245 246c******************************************************************************* 247 248 249 250 251 252 253 254