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
|
! { dg-do run }
!
! Test the fix for PR84155 and PR84141.
!
! Contributed by Juergen Reuter <juergen.reuter@desy.de>
!
module test_case
implicit none
type :: array_t
integer, dimension(:), allocatable :: child
contains
procedure :: write_raw => particle_write_raw
end type array_t
type :: container_t
type(array_t), dimension(:), allocatable :: array
end type container_t
contains
subroutine proc ()
type(container_t) :: container
integer :: unit, check
integer, parameter :: ival = 42
allocate (container%array(1))
allocate (container%array(1)%child (1), source = [ival])
unit = 33
open (unit, action="readwrite", form="unformatted", status="scratch")
call container%array(1)%write_raw (unit)
rewind (unit)
read (unit) check
close (unit)
if (ival .ne. check) STOP 1
end subroutine proc
subroutine particle_write_raw (array, u)
class(array_t), intent(in) :: array
integer, intent(in) :: u
write (u) array%child
end subroutine particle_write_raw
subroutine particle_read_raw (array)
class(array_t), intent(out) :: array
allocate (array%child (1)) ! comment this out
end subroutine particle_read_raw
end module test_case
program main
use test_case
call proc ()
end program main
|
