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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
! { dg-do run }
!
! This program checks that passing allocatable and pointer arrays to
! and from Fortran functions with C binding works.
module mm
use iso_c_binding
type, bind (c) :: m
integer(C_INT) :: i, j
end type
end module
program testit
use iso_c_binding
use mm
implicit none
type(m), allocatable :: a(:)
type(m), target :: t(3,10)
type(m), pointer :: p(:,:)
p => NULL()
call testc (a, t, p)
call testf (a, t, p)
contains
! C binding version
subroutine checkc (a, t, p, initp) bind (c)
use iso_c_binding
use mm
type(m), allocatable :: a(:)
type(m), target :: t(3,10)
type(m), pointer :: p(:,:)
logical, value :: initp
integer :: i, j
if (rank (a) .ne. 1) stop 101
if (rank (t) .ne. 2) stop 102
if (rank (p) .ne. 2) stop 103
if (initp) then
if (.not. allocated (a)) stop 104
if (.not. associated (p)) stop 105
if (.not. associated (p, t)) stop 106
if (size (a, 1) .ne. 5) stop 107
if (size (p, 1) .ne. 3) stop 108
if (size (p, 2) .ne. 10) stop 109
else
if (allocated (a)) stop 121
if (associated (p)) stop 122
end if
end subroutine
! Fortran binding version
subroutine checkf (a, t, p, initp)
use iso_c_binding
use mm
type(m), allocatable :: a(:)
type(m), target :: t(3,10)
type(m), pointer :: p(:,:)
logical, value :: initp
integer :: i, j
if (rank (a) .ne. 1) stop 201
if (rank (t) .ne. 2) stop 202
if (rank (p) .ne. 2) stop 203
if (initp) then
if (.not. allocated (a)) stop 204
if (.not. associated (p)) stop 205
if (.not. associated (p, t)) stop 206
if (size (a, 1) .ne. 5) stop 207
if (size (p, 1) .ne. 3) stop 208
if (size (p, 2) .ne. 10) stop 209
else
if (allocated (a)) stop 221
if (associated (p)) stop 222
end if
end subroutine
! C binding version
subroutine allocatec (a, t, p) bind (c)
use iso_c_binding
use mm
type(m), allocatable :: a(:)
type(m), target :: t(3,10)
type(m), pointer :: p(:,:)
allocate (a(10:20))
p => t
end subroutine
! Fortran binding version
subroutine allocatef (a, t, p) bind (c)
use iso_c_binding
use mm
type(m), allocatable :: a(:)
type(m), target :: t(3,10)
type(m), pointer :: p(:,:)
allocate (a(5:15))
p => t
end subroutine
! C binding version
subroutine testc (a, t, p) bind (c)
use iso_c_binding
use mm
type(m), allocatable :: a(:)
type(m), target :: t(3,10)
type(m), pointer :: p(:,:)
! Call both the C and Fortran binding check functions
call checkc (a, t, p, .false.)
call checkf (a, t, p, .false.)
! Allocate/associate and check again.
allocate (a(5))
p => t
call checkc (a, t, p, .true.)
call checkf (a, t, p, .true.)
! Reset and check a third time.
deallocate (a)
p => NULL ()
call checkc (a, t, p, .false.)
call checkf (a, t, p, .false.)
! Allocate/associate inside a function with Fortran binding.
call allocatef (a, t, p)
if (.not. allocated (a)) stop 301
if (.not. associated (p)) stop 302
if (lbound (a, 1) .ne. 5) stop 303
if (ubound (a, 1) .ne. 15) stop 304
deallocate (a)
p => NULL ()
! Allocate/associate inside a function with C binding.
call allocatec (a, t, p)
if (.not. allocated (a)) stop 311
if (.not. associated (p)) stop 312
if (lbound (a, 1) .ne. 10) stop 313
if (ubound (a, 1) .ne. 20) stop 314
deallocate (a)
p => NULL ()
end subroutine
! Fortran binding version
subroutine testf (a, t, p)
use iso_c_binding
use mm
type(m), allocatable :: a(:)
type(m), target :: t(3,10)
type(m), pointer :: p(:,:)
! Call both the C and Fortran binding check functions
call checkc (a, t, p, .false.)
call checkf (a, t, p, .false.)
! Allocate/associate and check again.
allocate (a(5))
p => t
call checkc (a, t, p, .true.)
call checkf (a, t, p, .true.)
! Reset and check a third time.
deallocate (a)
p => NULL ()
call checkc (a, t, p, .false.)
call checkf (a, t, p, .false.)
! Allocate/associate inside a function with Fortran binding.
call allocatef (a, t, p)
if (.not. allocated (a)) stop 401
if (.not. associated (p)) stop 402
if (lbound (a, 1) .ne. 5) stop 403
if (ubound (a, 1) .ne. 15) stop 404
deallocate (a)
p => NULL ()
! Allocate/associate inside a function with C binding.
call allocatec (a, t, p)
if (.not. allocated (a)) stop 411
if (.not. associated (p)) stop 412
if (lbound (a, 1) .ne. 10) stop 413
if (ubound (a, 1) .ne. 20) stop 414
deallocate (a)
p => NULL ()
end subroutine
end program
|
