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
|
! { dg-do run }
! PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4)
! Exercise TRANSFER intrinsic to check character result length and shape
program p
implicit none
character(len=*,kind=4), parameter :: a = 4_'ABCDEF'
character(len=6,kind=4) :: b = 4_'abcdef'
character(len=*,kind=4), parameter :: c = 4_'XY'
character(len=2,kind=4) :: d = 4_'xy'
integer :: k, l
k = len (a)
l = len (c)
! print *, transfer(4_'xy', [4_'a'])
! TRANSFER with rank-0 result
call chk0 (transfer (4_'ABCD', 4_'XY'), 2, 1)
call chk0 (transfer (4_'ABCD', c ), l, 2)
call chk0 (transfer (4_'ABCD', d ), l, 3)
call chk0 (transfer (a , 4_'XY'), 2, 4)
call chk0 (transfer (a , c ), l, 5)
call chk0 (transfer (a , d ), l, 6)
call chk0 (transfer (b , 4_'XY'), 2, 7)
call chk0 (transfer (b , c ), l, 8)
call chk0 (transfer (b , d ), l, 9)
call chk0 (transfer ([4_'ABCD'], 4_'XY'), 2, 11)
call chk0 (transfer ([4_'ABCD'], c ), l, 12)
call chk0 (transfer ([4_'ABCD'], d ), l, 13)
call chk0 (transfer ([a ], 4_'XY'), 2, 14)
call chk0 (transfer ([a ], c ), l, 15)
call chk0 (transfer ([a ], d ), l, 16)
call chk0 (transfer ([b ], 4_'XY'), 2, 17)
call chk0 (transfer ([b ], c ), l, 18)
call chk0 (transfer ([b ], d ), l, 19)
! TRANSFER with rank-1 result
call chk1 (transfer (4_'ABCD', [4_'XY']), 2, 2, 21)
call chk1 (transfer (4_'ABCD', [c] ), 2, 2, 22)
call chk1 (transfer (4_'ABCD', [d] ), 2, 2, 23)
call chk1 (transfer (a , [4_'XY']), 2, k/2, 24)
call chk1 (transfer (a , [c] ), l, k/l, 25)
call chk1 (transfer (a , [d] ), l, k/l, 26)
call chk1 (transfer (b , [4_'XY']), 2, k/2, 27)
call chk1 (transfer (b , [c] ), l, k/l, 28)
call chk1 (transfer (b , [d] ), l, k/l, 29)
call chk1 (transfer (4_'ABCD', 4_'XY',size=2), 2, 2, 31)
call chk1 (transfer (4_'ABCD', c ,size=2), 2, 2, 32)
call chk1 (transfer (4_'ABCD', d ,size=2), 2, 2, 33)
call chk1 (transfer (a , 4_'XY',size=3), 2, 3, 34)
call chk1 (transfer (a , c ,size=3), l, 3, 35)
call chk1 (transfer (a , d ,size=3), l, 3, 36)
call chk1 (transfer (b , 4_'XY',size=3), 2, 3, 37)
call chk1 (transfer (b , c ,size=3), l, 3, 38)
call chk1 (transfer (b , d ,size=3), l, 3, 39)
call chk1 (transfer (4_'ABCD', [4_'XY'],size=2), 2, 2, 41)
call chk1 (transfer (4_'ABCD', [c] ,size=2), 2, 2, 42)
call chk1 (transfer (4_'ABCD', [d] ,size=2), 2, 2, 43)
call chk1 (transfer (a , [4_'XY'],size=3), 2, 3, 44)
call chk1 (transfer (a , [c] ,size=3), l, 3, 45)
call chk1 (transfer (a , [d] ,size=3), l, 3, 46)
call chk1 (transfer (b , [4_'XY'],size=3), 2, 3, 47)
call chk1 (transfer (b , [c] ,size=3), l, 3, 48)
call chk1 (transfer (b , [d] ,size=3), l, 3, 49)
call chk1 (transfer ([4_'ABCD'], [4_'XY']), 2, 2, 51)
call chk1 (transfer ([4_'ABCD'], [c] ), 2, 2, 52)
call chk1 (transfer ([4_'ABCD'], [d] ), 2, 2, 53)
call chk1 (transfer ([a ], [4_'XY']), 2, k/2, 54)
call chk1 (transfer ([a ], [c] ), l, k/l, 55)
call chk1 (transfer ([a ], [d] ), l, k/l, 56)
call chk1 (transfer ([b ], [4_'XY']), 2, k/2, 57)
call chk1 (transfer ([b ], [c] ), l, k/l, 58)
call chk1 (transfer ([b ], [d] ), l, k/l, 59)
call chk1 (transfer (4_'ABCD', c ,size=4/l), l, 4/l, 62)
call chk1 (transfer (4_'ABCD', d ,size=4/l), l, 4/l, 63)
call chk1 (transfer (a , 4_'XY',size=k/2), 2, k/2, 64)
call chk1 (transfer (a , c ,size=k/l), l, k/l, 65)
call chk1 (transfer (a , d ,size=k/l), l, k/l, 66)
call chk1 (transfer (b , 4_'XY',size=k/2), 2, k/2, 67)
call chk1 (transfer (b , c ,size=k/l), l, k/l, 68)
call chk1 (transfer (b , d ,size=k/l), l, k/l, 69)
contains
! Validate rank-0 result
subroutine chk0 (str, l, stopcode)
character(kind=4,len=*), intent(in) :: str
integer, intent(in) :: l, stopcode
integer :: i, p
i = len (str)
p = verify (str, a // b) ! Check for junk characters
if (i /= l .or. p > 0) then
print *, stopcode, "len=", i, i == l, ">", str, "<"
stop stopcode
end if
end subroutine chk0
! Validate rank-1 result
subroutine chk1 (str, l, m, stopcode)
character(kind=4,len=*), intent(in) :: str(:)
integer, intent(in) :: l, m, stopcode
integer :: i, j, p
i = len (str)
j = size (str)
p = maxval (verify (str, a // b)) ! Check for junk characters
if (i /= l .or. j /= m .or. p > 0) then
print *, stopcode, "len=", i, i == l, "size=", j, j == m, ">", str, "<"
stop stopcode
end if
end subroutine chk1
end
|
