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
|
! { dg-do run }
!
! Functional test of User Defined Derived Type IO.
!
! This tests a combination of module procedure and generic procedure
! and performs reading and writing an array with a pseudo user defined
! tag at the beginning of the file.
!
module usertypes
type udt
integer :: myarray(15)
contains
procedure :: user_defined_read
generic :: read (formatted) => user_defined_read
end type udt
type, extends(udt) :: more
integer :: someinteger = -25
end type
interface write(formatted)
module procedure user_defined_write
end interface
integer :: result_array(15)
contains
subroutine user_defined_read (dtv, unit, iotype, v_list, iostat, iomsg)
class(udt), intent(inout) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, intent(in) :: v_list (:)
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
character(10) :: typestring
iomsg = 'SUCCESS'
read (unit, '(a6)', iostat=iostat, iomsg=iomsg) typestring
typestring = trim(typestring)
select type (dtv)
type is (udt)
if (typestring.eq.' UDT: ') then
read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
else
iostat = 6000
iomsg = 'FAILURE'
end if
type is (more)
if (typestring.eq.' MORE: ') then
read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
else
iostat = 6000
iomsg = 'FAILUREwhat'
end if
end select
end subroutine user_defined_read
subroutine user_defined_write (dtv, unit, iotype, v_list, iostat, iomsg)
class(udt), intent(in) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, intent(in) :: v_list (:)
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
character(10) :: typestring
select type (dtv)
type is (udt)
write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "UDT: "
write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
type is (more)
write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "MORE: "
write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
end select
write (unit,*)
end subroutine user_defined_write
end module usertypes
program test1
use usertypes
type (udt) :: udt1
type (more) :: more1
class (more), allocatable :: somemore
integer :: thesize, i, ios
character(25):: iomsg
! Create a file that contains some data for testing.
open (10, form='formatted', status='scratch')
write(10, '(a)') ' UDT: '
do i = 1, 15
write(10,'(i5)', advance='no') i
end do
write(10,*)
rewind(10)
udt1%myarray = 99
result_array = (/ (i, i = 1, 15) /)
more1%myarray = result_array
read (10, fmt='(dt)', advance='no', iomsg=iomsg) udt1
if (iomsg.ne.'SUCCESS') STOP 1
if (any(udt1%myarray.ne.result_array)) STOP 1
close(10)
open (10, form='formatted', status='scratch')
write (10, '(dt)') more1
rewind(10)
more1%myarray = 99
read (10, '(dt)', iostat=ios, iomsg=iomsg) more1
if (iomsg.ne.'SUCCESS') STOP 1
if (any(more1%myarray.ne.result_array)) STOP 1
close (10)
end program test1
|
