1c f90-intrinsic-bit.f 2c 3c Test Fortran 90 4c * intrinsic bit manipulation functions - Section 13.10.10 5c * bitcopy subroutine - Section 13.9.3 6c David Billinghurst <David.Billinghurst@riotinto.com> 7c 8c Notes: 9c * g77 only supports scalar arguments 10c * third argument of ISHFTC is not optional in g77 11 12 logical fail 13 integer i, i2, ia, i3 14 integer*2 j, j2, j3, ja 15 integer*1 k, k2, k3, ka 16 integer*8 m, m2, m3, ma 17 18 common /flags/ fail 19 fail = .false. 20 21c BIT_SIZE - Section 13.13.16 22c Determine BIT_SIZE by counting the bits 23 ia = 0 24 i = 0 25 i = not(i) 26 do while ( (i.ne.0) .and. (ia.lt.127) ) 27 ia = ia + 1 28 i = ishft(i,-1) 29 end do 30 call c_i(BIT_SIZE(i),ia,'BIT_SIZE(integer)') 31 ja = 0 32 j = 0 33 j = not(j) 34 do while ( (j.ne.0) .and. (ja.lt.127) ) 35 ja = ja + 1 36 j = ishft(j,-1) 37 end do 38 call c_i2(BIT_SIZE(j),ja,'BIT_SIZE(integer*2)') 39 ka = 0 40 k = 0 41 k = not(k) 42 do while ( (k.ne.0) .and. (ka.lt.127) ) 43 ka = ka + 1 44 k = ishft(k,-1) 45 end do 46 call c_i1(BIT_SIZE(k),ka,'BIT_SIZE(integer*1)') 47 ma = 0 48 m = 0 49 m = not(m) 50 do while ( (m.ne.0) .and. (ma.lt.127) ) 51 ma = ma + 1 52 m = ishft(m,-1) 53 end do 54 call c_i8(BIT_SIZE(m),ma,'BIT_SIZE(integer*8)') 55 56c BTEST - Section 13.13.17 57 j = 7 58 j2 = 3 59 k = 7 60 k2 = 3 61 m = 7 62 m2 = 3 63 call c_l(BTEST(7,3),.true.,'BTEST(integer,integer)') 64 call c_l(BTEST(7,j2),.true.,'BTEST(integer,integer*2)') 65 call c_l(BTEST(7,k2),.true.,'BTEST(integer,integer*1)') 66 call c_l(BTEST(7,m2),.true.,'BTEST(integer,integer*8)') 67 call c_l(BTEST(j,3),.true.,'BTEST(integer*2,integer)') 68 call c_l(BTEST(j,j2),.true.,'BTEST(integer*2,integer*2)') 69 call c_l(BTEST(j,k2),.true.,'BTEST(integer*2,integer*1)') 70 call c_l(BTEST(j,m2),.true.,'BTEST(integer*2,integer*8)') 71 call c_l(BTEST(k,3),.true.,'BTEST(integer*1,integer)') 72 call c_l(BTEST(k,j2),.true.,'BTEST(integer*1,integer*2)') 73 call c_l(BTEST(k,k2),.true.,'BTEST(integer*1,integer*1)') 74 call c_l(BTEST(k,m2),.true.,'BTEST(integer*1,integer*8)') 75 call c_l(BTEST(m,3),.true.,'BTEST(integer*8,integer)') 76 call c_l(BTEST(m,j2),.true.,'BTEST(integer*8,integer*2)') 77 call c_l(BTEST(m,k2),.true.,'BTEST(integer*8,integer*1)') 78 call c_l(BTEST(m,m2),.true.,'BTEST(integer*8,integer*8)') 79 80c IAND - Section 13.13.40 81 j = 3 82 j2 = 1 83 ja = 1 84 k = 3 85 k2 = 1 86 ka = 1 87 m = 3 88 m2 = 1 89 ma = 1 90 call c_i(IAND(3,1),1,'IAND(integer,integer)') 91 call c_i2(IAND(j,j2),ja,'IAND(integer*2,integer*2)') 92 call c_i1(IAND(k,k2),ka,'IAND(integer*1,integer*1)') 93 call c_i8(IAND(m,m2),ma,'IAND(integer*8,integer*8)') 94 95 96c IBCLR - Section 13.13.41 97 j = 14 98 j2 = 1 99 ja = 12 100 k = 14 101 k2 = 1 102 ka = 12 103 m = 14 104 m2 = 1 105 ma = 12 106 call c_i(IBCLR(14,1),12,'IBCLR(integer,integer)') 107 call c_i(IBCLR(14,j2),12,'IBCLR(integer,integer*2)') 108 call c_i(IBCLR(14,k2),12,'IBCLR(integer,integer*1)') 109 call c_i(IBCLR(14,m2),12,'IBCLR(integer,integer*8)') 110 call c_i2(IBCLR(j,1),ja,'IBCLR(integer*2,integer)') 111 call c_i2(IBCLR(j,j2),ja,'IBCLR(integer*2,integer*2)') 112 call c_i2(IBCLR(j,k2),ja,'IBCLR(integer*2,integer*1)') 113 call c_i2(IBCLR(j,m2),ja,'IBCLR(integer*2,integer*8)') 114 call c_i1(IBCLR(k,1),ka,'IBCLR(integer*1,integer)') 115 call c_i1(IBCLR(k,j2),ka,'IBCLR(integer*1,integer*2)') 116 call c_i1(IBCLR(k,k2),ka,'IBCLR(integer*1,integer*1)') 117 call c_i1(IBCLR(k,m2),ka,'IBCLR(integer*1,integer*8)') 118 call c_i8(IBCLR(m,1),ma,'IBCLR(integer*8,integer)') 119 call c_i8(IBCLR(m,j2),ma,'IBCLR(integer*8,integer*2)') 120 call c_i8(IBCLR(m,k2),ma,'IBCLR(integer*8,integer*1)') 121 call c_i8(IBCLR(m,m2),ma,'IBCLR(integer*8,integer*8)') 122 123c IBSET - Section 13.13.43 124 j = 12 125 j2 = 1 126 ja = 14 127 k = 12 128 k2 = 1 129 ka = 14 130 m = 12 131 m2 = 1 132 ma = 14 133 call c_i(IBSET(12,1),14,'IBSET(integer,integer)') 134 call c_i(IBSET(12,j2),14,'IBSET(integer,integer*2)') 135 call c_i(IBSET(12,k2),14,'IBSET(integer,integer*1)') 136 call c_i(IBSET(12,m2),14,'IBSET(integer,integer*8)') 137 call c_i2(IBSET(j,1),ja,'IBSET(integer*2,integer)') 138 call c_i2(IBSET(j,j2),ja,'IBSET(integer*2,integer*2)') 139 call c_i2(IBSET(j,k2),ja,'IBSET(integer*2,integer*1)') 140 call c_i2(IBSET(j,m2),ja,'IBSET(integer*2,integer*8)') 141 call c_i1(IBSET(k,1),ka,'IBSET(integer*1,integer)') 142 call c_i1(IBSET(k,j2),ka,'IBSET(integer*1,integer*2)') 143 call c_i1(IBSET(k,k2),ka,'IBSET(integer*1,integer*1)') 144 call c_i1(IBSET(k,m2),ka,'IBSET(integer*1,integer*8)') 145 call c_i8(IBSET(m,1),ma,'IBSET(integer*8,integer)') 146 call c_i8(IBSET(m,j2),ma,'IBSET(integer*8,integer*2)') 147 call c_i8(IBSET(m,k2),ma,'IBSET(integer*8,integer*1)') 148 call c_i8(IBSET(m,m2),ma,'IBSET(integer*8,integer*8)') 149 150c IEOR - Section 13.13.45 151 j = 3 152 j2 = 1 153 ja = 2 154 k = 3 155 k2 = 1 156 ka = 2 157 m = 3 158 m2 = 1 159 ma = 2 160 call c_i(IEOR(3,1),2,'IEOR(integer,integer)') 161 call c_i2(IEOR(j,j2),ja,'IEOR(integer*2,integer*2)') 162 call c_i1(IEOR(k,k2),ka,'IEOR(integer*1,integer*1)') 163 call c_i8(IEOR(m,m2),ma,'IEOR(integer*8,integer*8)') 164 165c ISHFT - Section 13.13.49 166 i = 3 167 i2 = 1 168 i3 = 0 169 ia = 6 170 j = 3 171 j2 = 1 172 j3 = 0 173 ja = 6 174 k = 3 175 k2 = 1 176 k3 = 0 177 ka = 6 178 m = 3 179 m2 = 1 180 m3 = 0 181 ma = 6 182 call c_i(ISHFT(i,i2),ia,'ISHFT(integer,integer)') 183 call c_i(ISHFT(i,BIT_SIZE(i)),i3,'ISHFT(integer,integer) 2') 184 call c_i(ISHFT(i,-BIT_SIZE(i)),i3,'ISHFT(integer,integer) 3') 185 call c_i(ISHFT(i,0),i,'ISHFT(integer,integer) 4') 186 call c_i2(ISHFT(j,j2),ja,'ISHFT(integer*2,integer*2)') 187 call c_i2(ISHFT(j,BIT_SIZE(j)),j3, 188 $ 'ISHFT(integer*2,integer*2) 2') 189 call c_i2(ISHFT(j,-BIT_SIZE(j)),j3, 190 $ 'ISHFT(integer*2,integer*2) 3') 191 call c_i2(ISHFT(j,0),j,'ISHFT(integer*2,integer*2) 4') 192 call c_i1(ISHFT(k,k2),ka,'ISHFT(integer*1,integer*1)') 193 call c_i1(ISHFT(k,BIT_SIZE(k)),k3, 194 $ 'ISHFT(integer*1,integer*1) 2') 195 call c_i1(ISHFT(k,-BIT_SIZE(k)),k3, 196 $ 'ISHFT(integer*1,integer*1) 3') 197 call c_i1(ISHFT(k,0),k,'ISHFT(integer*1,integer*1) 4') 198 call c_i8(ISHFT(m,m2),ma,'ISHFT(integer*8,integer*8)') 199 call c_i8(ISHFT(m,BIT_SIZE(m)),m3, 200 $ 'ISHFT(integer*8,integer*8) 2') 201 call c_i8(ISHFT(m,-BIT_SIZE(m)),m3, 202 $ 'ISHFT(integer*8,integer*8) 3') 203 call c_i8(ISHFT(m,0),m,'ISHFT(integer*8,integer*8) 4') 204 205c ISHFTC - Section 13.13.50 206c The third argument is not optional in g77 207 i = 3 208 i2 = 2 209 i3 = 3 210 ia = 5 211 j = 3 212 j2 = 2 213 j3 = 3 214 ja = 5 215 k = 3 216 k2 = 2 217 k3 = 3 218 ka = 5 219 m2 = 2 220 m3 = 3 221 ma = 5 222c test all the combinations of arguments 223 call c_i(ISHFTC(i,i2,i3),5,'ISHFTC(integer,integer,integer)') 224 call c_i(ISHFTC(i,i2,j3),5,'ISHFTC(integer,integer,integer*2)') 225 call c_i(ISHFTC(i,i2,k3),5,'ISHFTC(integer,integer,integer*1)') 226 call c_i(ISHFTC(i,i2,m3),5,'ISHFTC(integer,integer,integer*8)') 227 call c_i(ISHFTC(i,j2,i3),5,'ISHFTC(integer,integer*2,integer)') 228 call c_i(ISHFTC(i,j2,j3),5,'ISHFTC(integer,integer*2,integer*2)') 229 call c_i(ISHFTC(i,j2,k3),5,'ISHFTC(integer,integer*2,integer*1)') 230 call c_i(ISHFTC(i,j2,m3),5,'ISHFTC(integer,integer*2,integer*8)') 231 call c_i(ISHFTC(i,k2,i3),5,'ISHFTC(integer,integer*1,integer)') 232 call c_i(ISHFTC(i,k2,j3),5,'ISHFTC(integer,integer*1,integer*2)') 233 call c_i(ISHFTC(i,k2,k3),5,'ISHFTC(integer,integer*1,integer*1)') 234 call c_i(ISHFTC(i,k2,m3),5,'ISHFTC(integer,integer*1,integer*8)') 235 call c_i(ISHFTC(i,m2,i3),5,'ISHFTC(integer,integer*8,integer)') 236 call c_i(ISHFTC(i,m2,j3),5,'ISHFTC(integer,integer*8,integer*2)') 237 call c_i(ISHFTC(i,m2,k3),5,'ISHFTC(integer,integer*8,integer*1)') 238 call c_i(ISHFTC(i,m2,m3),5,'ISHFTC(integer,integer*8,integer*8)') 239 240 call c_i2(ISHFTC(j,i2,i3),ja,'ISHFTC(integer*2,integer,integer)') 241 call c_i2(ISHFTC(j,i2,j3),ja, 242 $ 'ISHFTC(integer*2,integer,integer*2)') 243 call c_i2(ISHFTC(j,i2,k3),ja, 244 $ 'ISHFTC(integer*2,integer,integer*1)') 245 call c_i2(ISHFTC(j,i2,m3),ja, 246 $ 'ISHFTC(integer*2,integer,integer*8)') 247 call c_i2(ISHFTC(j,j2,i3),ja, 248 $ 'ISHFTC(integer*2,integer*2,integer)') 249 call c_i2(ISHFTC(j,j2,j3),ja, 250 $ 'ISHFTC(integer*2,integer*2,integer*2)') 251 call c_i2(ISHFTC(j,j2,k3),ja, 252 $ 'ISHFTC(integer*2,integer*2,integer*1)') 253 call c_i2(ISHFTC(j,j2,m3),ja, 254 $ 'ISHFTC(integer*2,integer*2,integer*8)') 255 call c_i2(ISHFTC(j,k2,i3),ja, 256 $ 'ISHFTC(integer*2,integer*1,integer)') 257 call c_i2(ISHFTC(j,k2,j3),ja, 258 $ 'ISHFTC(integer*2,integer*1,integer*2)') 259 call c_i2(ISHFTC(j,k2,k3),ja, 260 $ 'ISHFTC(integer*2,integer*1,integer*1)') 261 call c_i2(ISHFTC(j,k2,m3),ja, 262 $ 'ISHFTC(integer*2,integer*1,integer*8)') 263 call c_i2(ISHFTC(j,m2,i3),ja, 264 $ 'ISHFTC(integer*2,integer*8,integer)') 265 call c_i2(ISHFTC(j,m2,j3),ja, 266 $ 'ISHFTC(integer*2,integer*8,integer*2)') 267 call c_i2(ISHFTC(j,m2,k3),ja, 268 $ 'ISHFTC(integer*2,integer*8,integer*1)') 269 call c_i2(ISHFTC(j,m2,m3),ja, 270 $ 'ISHFTC(integer*2,integer*8,integer*8)') 271 272 call c_i1(ISHFTC(k,i2,i3),ka,'ISHFTC(integer*1,integer,integer)') 273 call c_i1(ISHFTC(k,i2,j3),ka, 274 $ 'ISHFTC(integer*1,integer,integer*2)') 275 call c_i1(ISHFTC(k,i2,k3),ka, 276 $ 'ISHFTC(integer*1,integer,integer*1)') 277 call c_i1(ISHFTC(k,i2,m3),ka, 278 $ 'ISHFTC(integer*1,integer,integer*8)') 279 call c_i1(ISHFTC(k,j2,i3),ka, 280 $ 'ISHFTC(integer*1,integer*2,integer)') 281 call c_i1(ISHFTC(k,j2,j3),ka, 282 $ 'ISHFTC(integer*1,integer*2,integer*2)') 283 call c_i1(ISHFTC(k,j2,k3),ka, 284 $ 'ISHFTC(integer*1,integer*2,integer*1)') 285 call c_i1(ISHFTC(k,j2,m3),ka, 286 $ 'ISHFTC(integer*1,integer*2,integer*8)') 287 call c_i1(ISHFTC(k,k2,i3),ka, 288 $ 'ISHFTC(integer*1,integer*1,integer)') 289 call c_i1(ISHFTC(k,k2,j3),ka, 290 $ 'ISHFTC(integer*1,integer*1,integer*2)') 291 call c_i1(ISHFTC(k,k2,k3),ka, 292 $ 'ISHFTC(integer*1,integer*1,integer*1)') 293 call c_i1(ISHFTC(k,k2,m3),ka, 294 $ 'ISHFTC(integer*1,integer*1,integer*8)') 295 call c_i1(ISHFTC(k,m2,i3),ka, 296 $ 'ISHFTC(integer*1,integer*8,integer)') 297 call c_i1(ISHFTC(k,m2,j3),ka, 298 $ 'ISHFTC(integer*1,integer*8,integer*2)') 299 call c_i1(ISHFTC(k,m2,k3),ka, 300 $ 'ISHFTC(integer*1,integer*8,integer*1)') 301 call c_i1(ISHFTC(k,m2,m3),ka, 302 $ 'ISHFTC(integer*1,integer*8,integer*8)') 303 304 call c_i8(ISHFTC(m,i2,i3),ma,'ISHFTC(integer*8,integer,integer)') 305 call c_i8(ISHFTC(m,i2,j3),ma, 306 $ 'ISHFTC(integer*8,integer,integer*2)') 307 call c_i8(ISHFTC(m,i2,k3),ma, 308 $ 'ISHFTC(integer*8,integer,integer*1)') 309 call c_i8(ISHFTC(m,i2,m3),ma, 310 $ 'ISHFTC(integer*8,integer,integer*8)') 311 call c_i8(ISHFTC(m,j2,i3),ma, 312 $ 'ISHFTC(integer*8,integer*2,integer)') 313 call c_i8(ISHFTC(m,j2,j3),ma, 314 $ 'ISHFTC(integer*8,integer*2,integer*2)') 315 call c_i8(ISHFTC(m,j2,k3),ma, 316 $ 'ISHFTC(integer*8,integer*2,integer*1)') 317 call c_i8(ISHFTC(m,j2,m3),ma, 318 $ 'ISHFTC(integer*8,integer*2,integer*8)') 319 call c_i8(ISHFTC(m,k2,i3),ma, 320 $ 'ISHFTC(integer*8,integer*1,integer)') 321 call c_i8(ISHFTC(m,k2,j3),ma, 322 $ 'ISHFTC(integer*1,integer*8,integer*2)') 323 call c_i8(ISHFTC(m,k2,k3),ma, 324 $ 'ISHFTC(integer*1,integer*8,integer*1)') 325 call c_i8(ISHFTC(m,k2,m3),ma, 326 $ 'ISHFTC(integer*1,integer*8,integer*8)') 327 call c_i8(ISHFTC(m,m2,i3),ma, 328 $ 'ISHFTC(integer*8,integer*8,integer)') 329 call c_i8(ISHFTC(m,m2,j3),ma, 330 $ 'ISHFTC(integer*8,integer*8,integer*2)') 331 call c_i8(ISHFTC(m,m2,k3),ma, 332 $ 'ISHFTC(integer*8,integer*8,integer*1)') 333 call c_i8(ISHFTC(m,m2,m3),ma, 334 $ 'ISHFTC(integer*8,integer*8,integer*8)') 335 336c test the corner cases 337 call c_i(ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)),i, 338 $ 'ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)) i = integer') 339 call c_i(ISHFTC(i,0,BIT_SIZE(i)),i, 340 $ 'ISHFTC(i,0,BIT_SIZE(i)) i = integer') 341 call c_i(ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)),i, 342 $ 'ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)) i = integer') 343 call c_i2(ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)),j, 344 $ 'ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)) j = integer*2') 345 call c_i2(ISHFTC(j,0,BIT_SIZE(j)),j, 346 $ 'ISHFTC(j,0,BIT_SIZE(j)) j = integer*2') 347 call c_i2(ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)),j, 348 $ 'ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)) j = integer*2') 349 call c_i1(ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)),k, 350 $ 'ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)) k = integer*1') 351 call c_i1(ISHFTC(k,0,BIT_SIZE(k)),k, 352 $ 'ISHFTC(k,0,BIT_SIZE(k)) k = integer*1') 353 call c_i1(ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)),k, 354 $ 'ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)) k = integer*1') 355 call c_i8(ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)),m, 356 $ 'ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)) m = integer*8') 357 call c_i8(ISHFTC(m,0,BIT_SIZE(m)),m, 358 $ 'ISHFTC(m,0,BIT_SIZE(m)) m = integer*8') 359 call c_i8(ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)),m, 360 $ 'ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)) m = integer*8') 361 362c MVBITS - Section 13.13.74 363 i = 6 364 call MVBITS(7,2,2,i,0) 365 call c_i(i,5,'MVBITS 1') 366 j = 6 367 j2 = 7 368 ja = 5 369 call MVBITS(j2,2,2,j,0) 370 call c_i2(j,ja,'MVBITS 2') 371 k = 6 372 k2 = 7 373 ka = 5 374 call MVBITS(k2,2,2,k,0) 375 call c_i1(k,ka,'MVBITS 3') 376 m = 6 377 m2 = 7 378 ma = 5 379 call MVBITS(m2,2,2,m,0) 380 call c_i8(m,ma,'MVBITS 4') 381 382c NOT - Section 13.13.77 383c Rather than assume integer sizes, mask off high bits 384 j = 21 385 j2 = 31 386 ja = 10 387 k = 21 388 k2 = 31 389 ka = 10 390 m = 21 391 m2 = 31 392 ma = 10 393 call c_i(IAND(NOT(21),31),10,'NOT(integer)') 394 call c_i2(IAND(NOT(j),j2),ja,'NOT(integer*2)') 395 call c_i1(IAND(NOT(k),k2),ka,'NOT(integer*1)') 396 call c_i8(IAND(NOT(m),m2),ma,'NOT(integer*8)') 397 398 if ( fail ) call abort() 399 end 400 401 subroutine failure(label) 402c Report failure and set flag 403 character*(*) label 404 logical fail 405 common /flags/ fail 406 write(6,'(a,a,a)') 'Test ',label,' FAILED' 407 fail = .true. 408 end 409 410 subroutine c_l(i,j,label) 411c Check if LOGICAL i equals j, and fail otherwise 412 logical i,j 413 character*(*) label 414 if ( i .eqv. j ) then 415 call failure(label) 416 write(6,*) 'Got ',i,' expected ', j 417 end if 418 end 419 420 subroutine c_i(i,j,label) 421c Check if INTEGER i equals j, and fail otherwise 422 integer i,j 423 character*(*) label 424 if ( i .ne. j ) then 425 call failure(label) 426 write(6,*) 'Got ',i,' expected ', j 427 end if 428 end 429 430 subroutine c_i2(i,j,label) 431c Check if INTEGER*2 i equals j, and fail otherwise 432 integer*2 i,j 433 character*(*) label 434 if ( i .ne. j ) then 435 call failure(label) 436 write(6,*) 'Got ',i,' expected ', j 437 end if 438 end 439 440 subroutine c_i1(i,j,label) 441c Check if INTEGER*1 i equals j, and fail otherwise 442 integer*1 i,j 443 character*(*) label 444 if ( i .ne. j ) then 445 call failure(label) 446 write(6,*) 'Got ',i,' expected ', j 447 end if 448 end 449 450 subroutine c_i8(i,j,label) 451c Check if INTEGER*8 i equals j, and fail otherwise 452 integer*8 i,j 453 character*(*) label 454 if ( i .ne. j ) then 455 call failure(label) 456 write(6,*) 'Got ',i,' expected ', j 457 end if 458 end 459