1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_10.c }
!
! Test the fix of PR89843.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_section_01
use, intrinsic :: iso_c_binding
implicit none
interface
subroutine si(this, flag, status) bind(c)
import :: c_float, c_int
real(c_float) :: this(:,:)
integer(c_int), value :: flag
integer(c_int) :: status
end subroutine si
end interface
contains
subroutine sa(this, flag, status) bind(c)
real(c_float) :: this(:)
integer(c_int), value :: flag
integer(c_int) :: status
status = 0
select case (flag)
case (0)
if (is_contiguous(this)) then
write(*,*) 'FAIL 1:'
status = status + 1
end if
if (size(this,1) /= 3) then
write(*,*) 'FAIL 2:',size(this)
status = status + 1
goto 10
end if
if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 3:',abs(this)
status = status + 1
end if
10 continue
case (1)
if (size(this,1) /= 3) then
write(*,*) 'FAIL 4:',size(this)
status = status + 1
goto 20
end if
if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 5:',this
status = status + 1
end if
20 continue
case (2)
if (size(this,1) /= 4) then
write(*,*) 'FAIL 6:',size(this)
status = status + 1
goto 30
end if
if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 7:',this
status = status + 1
end if
30 continue
end select
! if (status == 0) then
! write(*,*) 'OK'
! end if
end subroutine sa
end module mod_section_01
program section_01
use mod_section_01
implicit none
real(c_float) :: v(5,4)
integer :: i
integer :: status
v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] )
call si(v, 0, status)
if (status .ne. 0) stop 1
call sa(v(1:5:2, 1), 0, status)
if (status .ne. 0) stop 2
call si(v, 1, status)
if (status .ne. 0) stop 3
call sa(v(1:3, 3), 1, status)
if (status .ne. 0) stop 4
call si(v, 2, status)
if (status .ne. 0) stop 5
call sa(v(2,1:4), 2, status)
if (status .ne. 0) stop 6
end program section_01
|
