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
|
! { dg-do run }
! { dg-options "-ftest-forall-temp" }
!
implicit none
character(len=5), pointer :: a(:), b(:)
character(len=5), pointer :: c, d
allocate (a(2), b(2), c, d)
a = [ "abcde", "ABCDE" ]
call aloct_pointer_copy_4 (b, a)
!print *, b(1)
!print *, b(2)
if (any (a /= b)) stop 'WRONG'
call aloct_copy_4 (b, a)
!print *, b(1)
!print *, b(2)
if (any (a /= b)) stop 'WRONG'
d = '12345'
c = "abcde"
call test2 (d, c)
!print *, d
if (d /= '1cb15') stop 'WRONG'
call test2p (d, c)
!print *, d
if (d /= '1cb15') stop 'WRONG'
contains
subroutine aloct_pointer_copy_4(o, i)
character(len=*), pointer :: o(:), i(:)
integer :: nl1, nu1
integer :: i1
nl1 = lbound(i,dim=1)
nu1 = ubound(i,dim=1)
forall (i1 = nl1:nu1) o(i1) = i(i1)
end subroutine aloct_pointer_copy_4
subroutine aloct_copy_4(o, i)
character(len=*), pointer :: o(:), i(:)
integer :: nl1, nu1
integer :: i1
nl1 = lbound(i,dim=1)
nu1 = ubound(i,dim=1)
forall (i1 = nl1:nu1) o(i1) = i(i1)
end subroutine aloct_copy_4
subroutine test2(o, i)
character(len=*) :: o, i
integer :: nl1, nu1
integer :: i1
nl1 = 2
nu1 = 4
forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
end subroutine test2
subroutine test2p(o, i)
character(len=*), pointer :: o, i
integer :: nl1, nu1
integer :: i1
nl1 = 2
nu1 = 4
forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE
forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
end subroutine test2p
end
|
