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
|
! { dg-do run }
! { dg-options "-fcheck=pointer" }
!
! { dg-shouldfail "pointer check" }
! { dg-output ".*At line 104 of file .*Fortran runtime error: Pointer actual argument 'a' is not associated.*" }
!
! PR fortran/40604
!
! The following cases are all valid, but were failing
! for one or the other reason.
!
! Contributed by Janus Weil and Tobias Burnus.
!
subroutine test1()
call test(uec=-1)
contains
subroutine test(str,uec)
implicit none
character*(*), intent(in), optional:: str
integer, intent(in), optional :: uec
end subroutine
end subroutine test1
module m
interface matrixMult
Module procedure matrixMult_C2
End Interface
contains
subroutine test
implicit none
complex, dimension(0:3,0:3) :: m1,m2
print *,Trace(MatrixMult(m1,m2))
end subroutine
complex function trace(a)
implicit none
complex, intent(in), dimension(0:3,0:3) :: a
end function trace
function matrixMult_C2(a,b) result(matrix)
implicit none
complex, dimension(0:3,0:3) :: matrix,a,b
end function matrixMult_C2
end module m
SUBROUTINE plotdop(amat)
IMPLICIT NONE
REAL, INTENT (IN) :: amat(3,3)
integer :: i1
real :: pt(3)
i1 = 1
pt = MATMUL(amat,(/i1,i1,i1/))
END SUBROUTINE plotdop
FUNCTION evaluateFirst(s,n)result(number)
IMPLICIT NONE
CHARACTER(len =*), INTENT(inout) :: s
INTEGER,OPTIONAL :: n
REAL :: number
number = 1.1
end function
SUBROUTINE rw_inp(scpos)
IMPLICIT NONE
REAL scpos
interface
FUNCTION evaluateFirst(s,n)result(number)
IMPLICIT NONE
CHARACTER(len =*), INTENT(inout) :: s
INTEGER,OPTIONAL :: n
REAL :: number
end function
end interface
CHARACTER(len=100) :: line
scpos = evaluatefirst(line)
END SUBROUTINE rw_inp
program test
integer, pointer :: a
! nullify(a)
allocate(a)
a = 1
call sub1a(a)
call sub1b(a)
call sub1c()
contains
subroutine sub1a(a)
integer, pointer :: a
call sub2(a)
call sub3(a)
call sub4(a)
end subroutine sub1a
subroutine sub1b(a)
integer, pointer,optional :: a
call sub2(a)
call sub3(a)
call sub4(a)
end subroutine sub1b
subroutine sub1c(a)
integer, pointer,optional :: a
call sub4(a)
! call sub2(a) ! << Invalid - working correctly, but not allowed in F2003
call sub3(a) ! << INVALID
end subroutine sub1c
subroutine sub4(b)
integer, optional,pointer :: b
end subroutine
subroutine sub2(b)
integer, optional :: b
end subroutine
subroutine sub3(b)
integer :: b
end subroutine
end
! { dg-final { cleanup-modules "m" } }
|
