3 ! Functional test of User Defined Derived Type IO, Formatted WRITE/READ
5 ! 1) Tests passing of iostat out of the user procedure.
6 ! 2) Tests parsing of the DT optional string and passing in and using
7 ! to control execution.
8 ! 3) Tests parsing of the optional vlist, passing in and using it to
9 ! generate a user defined format string.
10 ! 4) Tests passing an iostat or iomsg out of libgfortranthe child procedure back to
16 CHARACTER (LEN
=20) :: name
21 GENERIC
:: WRITE(FORMATTED
) => pwf
22 GENERIC
:: READ(FORMATTED
) => prf
25 SUBROUTINE pwf (dtv
,unit
,iotype
,vlist
,iostat
,iomsg
)
26 CLASS(person
), INTENT(IN
) :: dtv
27 INTEGER, INTENT(IN
) :: unit
28 CHARACTER (LEN
=*), INTENT(IN
) :: iotype
29 INTEGER, INTENT(IN
) :: vlist(:)
30 INTEGER, INTENT(OUT
) :: iostat
31 CHARACTER (LEN
=*), INTENT(INOUT
) :: iomsg
32 CHARACTER (LEN
=30) :: udfmt
38 if (iotype
.eq
."DT") then
39 if (size(vlist
).ne
.0) print *, 36
40 WRITE(unit
, FMT
= '(a,5x,i2)', IOSTAT
=iostat
, advance
='no') trim(dtv
%name
), dtv
%age
41 if (iostat
.ne
.0) iomsg
= "Fail PWF DT"
43 if (iotype
.eq
."DTzeroth") then
44 if (size(vlist
).ne
.0) print *, 40
45 WRITE(unit
, FMT
= '(g0,g0)', advance
='no') dtv
%name
, dtv
%age
46 if (iostat
.ne
.0) iomsg
= "Fail PWF DTzeroth"
48 if (iotype
.eq
."DTtwo") then
49 if (size(vlist
).ne
.2) STOP 1
50 WRITE(udfmt
,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
51 WRITE(unit
, FMT
='(A8,I2)') dtv
%name
, dtv
%age
52 if (iostat
.ne
.0) iomsg
= "Fail PWF DTtwo"
54 if (iotype
.eq
."DTthree") then
55 WRITE(udfmt
,'(2A,I2,A,I1,A,I2,A)',iostat
=myios
) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
56 WRITE(unit
, FMT
=udfmt
, IOSTAT
=iostat
, advance
='no') trim(dtv
%name
), dtv
%age
, 3.14
57 if (iostat
.ne
.0) iomsg
= "Fail PWF DTthree"
59 if (iotype
.eq
."LISTDIRECTED") then
60 if (size(vlist
).ne
.0) print *, 55
61 WRITE(unit
, FMT
= *) dtv
%name
, dtv
%age
62 if (iostat
.ne
.0) iomsg
= "Fail PWF LISTDIRECTED"
64 if (iotype
.eq
."NAMELIST") then
65 if (size(vlist
).ne
.0) print *, 59
70 SUBROUTINE prf (dtv
,unit
,iotype
,vlist
,iostat
,iomsg
)
71 CLASS(person
), INTENT(INOUT
) :: dtv
72 INTEGER, INTENT(IN
) :: unit
73 CHARACTER (LEN
=*), INTENT(IN
) :: iotype
74 INTEGER, INTENT(IN
) :: vlist(:)
75 INTEGER, INTENT(OUT
) :: iostat
76 CHARACTER (LEN
=*), INTENT(INOUT
) :: iomsg
77 CHARACTER (LEN
=30) :: udfmt
83 if (iotype
.eq
."DT") then
84 if (size(vlist
).ne
.0) print *, 36
85 READ(unit
, FMT
= '(a,5x,i2)', IOSTAT
=iostat
, advance
='no') dtv
%name
, dtv
%age
86 if (iostat
.ne
.0) iomsg
= "Fail PWF DT"
88 if (iotype
.eq
."DTzeroth") then
89 if (size(vlist
).ne
.0) print *, 40
90 READ(unit
, FMT
= '(a,I2)', advance
='no') dtv
%name
, dtv
%age
91 if (iostat
.ne
.0) iomsg
= "Fail PWF DTzeroth"
93 if (iotype
.eq
."DTtwo") then
94 if (size(vlist
).ne
.2) STOP 2
95 WRITE(udfmt
,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
96 READ(unit
, FMT
='(A8,I2)') dtv
%name
, dtv
%age
97 if (iostat
.ne
.0) iomsg
= "Fail PWF DTtwo"
99 if (iotype
.eq
."DTthree") then
100 WRITE(udfmt
,'(2A,I2,A,I1,A,I2,A)',iostat
=myios
) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
101 READ(unit
, FMT
=udfmt
, IOSTAT
=iostat
, advance
='no') dtv
%name
, dtv
%age
, areal
102 if (iostat
.ne
.0) iomsg
= "Fail PWF DTthree"
104 if (iotype
.eq
."LISTDIRECTED") then
105 if (size(vlist
).ne
.0) print *, 55
106 READ(unit
, FMT
= *) dtv
%name
, dtv
%age
107 if (iostat
.ne
.0) iomsg
= "Fail PWF LISTDIRECTED"
109 if (iotype
.eq
."NAMELIST") then
110 if (size(vlist
).ne
.0) print *, 59
113 !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
120 TYPE (person
), SAVE :: chairman
121 TYPE (person
), SAVE :: member
122 character(80) :: astring
125 chairman
%name
="Charlie"
130 write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", &
131 & iostat
=myiostat
, iomsg
=astring
) member
, chairman
, member
132 if (myiostat
.ne
.0) STOP 3
133 if (astring
.ne
."SUCCESS") STOP 4
135 write (10, *, iostat
=myiostat
, iomsg
=astring
) member
, chairman
, member
136 if (myiostat
.ne
.0) STOP 5
137 if (astring
.ne
."SUCCESS") STOP 6
138 write(10,*) ! See note below
140 chairman
%name
="bogus1"
145 read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member
, chairman
, member
146 if (member
%name
.ne
."George") STOP 7
147 if (chairman
%name
.ne
." Charlie") STOP 8
148 if (member
%age
.ne
.42) STOP 9
149 if (chairman
%age
.ne
.62) STOP 10
150 chairman
%name
="bogus1"
155 read (10, *, iostat
=myiostat
, iomsg
=astring
) member
, chairman
, member
156 ! The user defined procedure reads to the end of the line/file, then finalizing the parent
157 ! reads past, so we wrote a blank line above. User needs to address these nuances in their
158 ! procedures. (subject to interpretation)
159 if (astring
.ne
."SUCCESS") STOP 11
160 if (member
%name
.ne
."George") STOP 12
161 if (chairman
%name
.ne
."Charlie") STOP 13
162 if (member
%age
.ne
.42) STOP 14
163 if (chairman
%age
.ne
.62) STOP 15