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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
! { dg-do run }
!
! Tests dtio transfer of arrays of derived types and classes
!
MODULE p
TYPE :: person
CHARACTER (LEN=20) :: name
INTEGER(4) :: age
CONTAINS
procedure :: pwf
procedure :: prf
GENERIC :: WRITE(FORMATTED) => pwf
GENERIC :: READ(FORMATTED) => prf
END TYPE person
type, extends(person) :: employee
character(20) :: job_title
end type
type, extends(person) :: officer
character(20) :: position
end type
type, extends(person) :: member
integer :: membership_number
end type
type :: club
type(employee), allocatable :: staff(:)
class(person), allocatable :: committee(:)
class(person), allocatable :: membership(:)
end type
CONTAINS
SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
select type (dtv)
type is (employee)
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee"
WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title
type is (officer)
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer"
WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position
type is (member)
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member"
WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number
class default
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!"
WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age
end select
END SUBROUTINE pwf
SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
character (20) :: header, rname, jtitle, oposition
integer :: i
integer :: no
integer :: age
iostat = 0
select type (dtv)
type is (employee)
read (unit = unit, fmt = *) header
READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle
if (trim (rname) .ne. dtv%name) iostat = 1
if (age .ne. dtv%age) iostat = 2
if (trim (jtitle) .ne. dtv%job_title) iostat = 3
if (iotype .ne. "DTstaff") iostat = 4
type is (officer)
read (unit = unit, fmt = *) header
READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition
if (trim (rname) .ne. dtv%name) iostat = 1
if (age .ne. dtv%age) iostat = 2
if (trim (oposition) .ne. dtv%position) iostat = 3
if (iotype .ne. "DTofficers") iostat = 4
type is (member)
read (unit = unit, fmt = *) header
READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no
if (trim (rname) .ne. dtv%name) iostat = 1
if (age .ne. dtv%age) iostat = 2
if (no .ne. dtv%membership_number) iostat = 3
if (iotype .ne. "DTmembers") iostat = 4
class default
STOP 1
end select
end subroutine
END MODULE p
PROGRAM test
USE p
type (club) :: social_club
TYPE (person) :: chairman
CLASS (person), allocatable :: president(:)
character (40) :: line
integer :: i, j
allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), &
employee ("Joy",16,"Auditor")])
allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), &
officer ("Ann", 29, "Secretary")])
allocate (social_club%membership, source = [member ("Dan",52,1), &
member ("Sue",39,2)])
chairman%name="Charlie"
chairman%age=62
open (7, status = "scratch")
write (7,*) social_club%staff ! Tests array of derived types
write (7,*) social_club%committee ! Tests class array
do i = 1, size (social_club%membership, 1)
write (7,*) social_club%membership(i) ! Tests class array elements
end do
rewind (7)
read (7, "(DT'staff')", iostat = i) social_club%staff
if (i .ne. 0) STOP 2
social_club%committee(2)%age = 33 ! Introduce an error
read (7, "(DT'officers')", iostat = i) social_club%committee
if (i .ne. 2) STOP 3! Pick up error
do j = 1, size (social_club%membership, 1)
read (7, "(DT'members')", iostat = i) social_club%membership(j)
if (i .ne. 0) STOP 4
end do
close (7)
END PROGRAM test
|
