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
|
! { dg-do run }
! Testing fix for
! PR fortran/60414
!
module m
implicit none
Type T
real, public :: expectedScalar;
contains
procedure :: FCheck
procedure :: FCheckArr
generic :: Check => FCheck, FCheckArr
end Type
contains
subroutine FCheck(this,X)
class(T) this
class(*) X
real :: r
select type (X)
type is (real)
if ( abs (X - this%expectedScalar) > 0.0001 ) then
STOP 1
end if
class default
STOP 2
end select
end subroutine FCheck
subroutine FCheckArr(this,X)
class(T) this
class(*) X(:)
integer i
do i = 1,6
this%expectedScalar = i - 1.0
call this%FCheck(X(i))
end do
end subroutine FCheckArr
subroutine CheckTextVector(vec, n, scal)
integer, intent(in) :: n
class(*), intent(in) :: vec(n)
class(*), intent(in) :: scal
integer j
Type(T) :: Tester
! Check full vector
call Tester%Check(vec)
! Check a scalar of the same class like the vector
Tester%expectedScalar = 5.0
call Tester%Check(scal)
! Check an element of the vector, which is a scalar
j=3
Tester%expectedScalar = 2.0
call Tester%Check(vec(j))
end subroutine CheckTextVector
end module
program test
use :: m
implicit none
real :: vec(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
call checktextvector(vec, 6, 5.0)
end program test
|
