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