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
|
! { dg-do run }
! PR48298, this tests function of size= specifier with DTIO.
MODULE p
USE ISO_FORTRAN_ENV
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
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
CHARACTER (LEN=30) :: udfmt
INTEGER :: myios
iomsg = "SUCCESS"
iostat=0
if (iotype.eq."DT") then
WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
if (iotype.eq."LISTDIRECTED") then
WRITE(unit, '(*(g0))', IOSTAT=iostat) dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
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 (LEN=30) :: udfmt
INTEGER :: myios
real :: areal
udfmt='(*(g0))'
iomsg = "SUCCESS"
iostat=0
if (iotype.eq."DT") then
READ(unit, FMT = '(a20,i2)', IOSTAT=iostat) dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
END SUBROUTINE prf
END MODULE p
PROGRAM test
USE p
implicit none
TYPE (person) :: chairman
integer(4) :: rl, tl, kl, thesize
rl = 1
tl = 22
kl = 333
thesize = 9999
chairman%name="Charlie"
chairman%age=62
open(28, status='scratch')
write(28, '(i10,i10,DT,i15,DT,i12)') rl, kl, chairman, rl, chairman, tl
rewind(28)
chairman%name="bogus"
chairman%age=99
!print *, chairman
read(28, '(i10,i10,DT,i15,DT,i12)', advance='no', size=thesize) rl, &
& kl, chairman, rl, chairman, tl
if (thesize.ne.91) call abort
close(28)
END PROGRAM test
|
