|
111
|
1 ! { dg-do run }
|
|
|
2 !
|
|
|
3 implicit none
|
|
|
4 character(len=5), pointer :: a(:), b(:)
|
|
|
5 character(len=5), pointer :: c, d
|
|
|
6 allocate (a(2), b(2), c, d)
|
|
|
7 a = [ "abcde", "ABCDE" ]
|
|
|
8 call aloct_pointer_copy_4 (b, a)
|
|
|
9 !print *, b(1)
|
|
|
10 !print *, b(2)
|
|
|
11 if (any (a /= b)) stop 'WRONG'
|
|
|
12
|
|
|
13 call aloct_copy_4 (b, a)
|
|
|
14 !print *, b(1)
|
|
|
15 !print *, b(2)
|
|
|
16 if (any (a /= b)) stop 'WRONG'
|
|
|
17
|
|
|
18 d = '12345'
|
|
|
19 c = "abcde"
|
|
|
20 call test2 (d, c)
|
|
|
21 !print *, d
|
|
|
22 if (d /= '1cb15') stop 'WRONG'
|
|
|
23
|
|
|
24 call test2p (d, c)
|
|
|
25 !print *, d
|
|
|
26 if (d /= '1cb15') stop 'WRONG'
|
|
|
27
|
|
|
28 contains
|
|
|
29 subroutine aloct_pointer_copy_4(o, i)
|
|
|
30 character(len=*), pointer :: o(:), i(:)
|
|
|
31 integer :: nl1, nu1
|
|
|
32 integer :: i1
|
|
|
33 nl1 = lbound(i,dim=1)
|
|
|
34 nu1 = ubound(i,dim=1)
|
|
|
35 forall (i1 = nl1:nu1) o(i1) = i(i1)
|
|
|
36 end subroutine aloct_pointer_copy_4
|
|
|
37 subroutine aloct_copy_4(o, i)
|
|
|
38 character(len=*), pointer :: o(:), i(:)
|
|
|
39 integer :: nl1, nu1
|
|
|
40 integer :: i1
|
|
|
41 nl1 = lbound(i,dim=1)
|
|
|
42 nu1 = ubound(i,dim=1)
|
|
|
43 forall (i1 = nl1:nu1) o(i1) = i(i1)
|
|
|
44 end subroutine aloct_copy_4
|
|
|
45 subroutine test2(o, i)
|
|
|
46 character(len=*) :: o, i
|
|
|
47 integer :: nl1, nu1
|
|
|
48 integer :: i1
|
|
|
49 nl1 = 2
|
|
|
50 nu1 = 4
|
|
|
51 forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
|
|
|
52 forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
|
|
|
53 end subroutine test2
|
|
|
54 subroutine test2p(o, i)
|
|
|
55 character(len=*), pointer :: o, i
|
|
|
56 integer :: nl1, nu1
|
|
|
57 integer :: i1
|
|
|
58 nl1 = 2
|
|
|
59 nu1 = 4
|
|
|
60 forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE
|
|
|
61 forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
|
|
|
62 end subroutine test2p
|
|
|
63 end
|
