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
|
! { dg-do run }
!
! Test contributed by Thomas L. Clune via pr60322
! and Antony Lewis via pr64692
program class_array_20
implicit none
type Foo
end type
type(foo), dimension(2:3) :: arg
integer :: oneDarr(2)
integer :: twoDarr(2,3)
integer :: x, y
double precision :: P(2, 2)
! Checking for PR/60322
call copyFromClassArray([Foo(), Foo()])
call copyFromClassArray(arg)
call copyFromClassArray(arg(:))
x= 3
y= 4
oneDarr = [x, y]
call W([x, y])
call W(oneDarr)
call W([3, 4])
twoDarr = reshape([3, 4, 5, 5, 6, 7], [2, 3])
call WtwoD(twoDarr)
call WtwoD(reshape([3, 4, 5, 5, 6, 7], [2, 3]))
! Checking for PR/64692
P(1:2, 1) = [1.d0, 2.d0]
P(1:2, 2) = [3.d0, 4.d0]
call AddArray(P(1:2, 2))
contains
subroutine copyFromClassArray(classarray)
class (Foo), intent(in) :: classarray(:)
if (lbound(classarray, 1) .ne. 1) STOP 1
if (ubound(classarray, 1) .ne. 2) STOP 2
if (size(classarray) .ne. 2) STOP 3
end subroutine
subroutine AddArray(P)
class(*), target, intent(in) :: P(:)
class(*), pointer :: Pt(:)
allocate(Pt(1:size(P)), source= P)
select type (P)
type is (double precision)
if (abs(P(1)-3.d0) .gt. 1.d-8) STOP 4
if (abs(P(2)-4.d0) .gt. 1.d-8) STOP 5
class default
STOP 6
end select
select type (Pt)
type is (double precision)
if (abs(Pt(1)-3.d0) .gt. 1.d-8) STOP 7
if (abs(Pt(2)-4.d0) .gt. 1.d-8) STOP 8
class default
STOP 9
end select
end subroutine
subroutine W(ar)
class(*), intent(in) :: ar(:)
if (lbound(ar, 1) /= 1) STOP 10
select type (ar)
type is (integer)
! The indeces 1:2 are essential here, or else one would not
! note, that the array internally starts at 0, although the
! check for the lbound above went fine.
if (any (ar(1:2) .ne. [3, 4])) STOP 11
class default
STOP 12
end select
end subroutine
subroutine WtwoD(ar)
class(*), intent(in) :: ar(:,:)
if (any (lbound(ar) /= [1, 1])) STOP 13
select type (ar)
type is (integer)
if (any (reshape(ar(1:2,1:3), [6]) .ne. [3, 4, 5, 5, 6, 7])) &
STOP 14
class default
STOP 15
end select
end subroutine
end program class_array_20
|
