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
|
! { dg-do run }
!
! PR fortran/58793
!
! Contributed by Vladimir Fuka
!
! Had the wrong value for the storage_size for complex
!
module m
use iso_fortran_env
implicit none
integer, parameter :: c1 = real_kinds(1)
integer, parameter :: c2 = real_kinds(2)
integer, parameter :: c3 = real_kinds(size(real_kinds)-1)
integer, parameter :: c4 = real_kinds(size(real_kinds))
real(c1) :: r1
real(c2) :: r2
real(c3) :: r3
real(c4) :: r4
contains
subroutine s(o, k)
class(*) :: o
integer :: k
integer :: sz
sz = 0
select case (k)
case (4)
sz = storage_size(r1)*2
end select
select case (k)
case (8)
sz = storage_size(r2)*2
end select
select case (k)
case (real_kinds(size(real_kinds)-1))
sz = storage_size(r3)*2
end select
select case (k)
case (real_kinds(size(real_kinds)))
sz = storage_size(r4)*2
end select
if (sz .eq. 0) STOP 1
if (storage_size(o) /= sz) STOP 2
! Break up the SELECT TYPE to pre-empt collisions in the value of 'cn'
select type (o)
type is (complex(c1))
if (storage_size(o) /= sz) STOP 3
end select
select type (o)
type is (complex(c2))
if (storage_size(o) /= sz) STOP 4
end select
select type (o)
type is (complex(c3))
if (storage_size(o) /= sz) STOP 5
end select
select type (o)
type is (complex(c4))
if (storage_size(o) /= sz) STOP 6
end select
end subroutine s
end module m
program p
use m
call s((1._c1, 2._c1), c1)
call s((1._c2, 2._c2), c2)
call s((1._c3, 2._c3), c3)
call s((1._c4, 2._c4), c4)
end program p
|
