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
|
! { dg-do run }
! Tests that inquire(iolength=) treats derived types as if they do not
! have User Defined procedures. Fortran Draft F2016 Standard, 9.10.3
MODULE p
TYPE :: person
CHARACTER (LEN=20) :: name
INTEGER(4) :: age
END TYPE person
INTERFACE WRITE(FORMATTED)
MODULE procedure pwf
END INTERFACE
INTERFACE WRITE(UNFORMATTED)
MODULE procedure pwuf
END INTERFACE
INTERFACE read(FORMATTED)
MODULE procedure prf
END INTERFACE
INTERFACE read(UNFORMATTED)
MODULE procedure pruf
END INTERFACE
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
WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age
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
READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
END SUBROUTINE prf
SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
CLASS(person), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
print *, "in pwuf"
WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age
END SUBROUTINE pwuf
SUBROUTINE pruf (dtv,unit,iostat,iomsg)
CLASS(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
print *, "in pruf"
READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
END SUBROUTINE pruf
END MODULE p
PROGRAM test
USE p
IMPLICIT NONE
TYPE (person) :: chairman
integer(4) :: rl, tl, kl
chairman%name="Charlie"
chairman%age=62
inquire(iolength=rl) rl, kl, chairman, rl, chairman, tl
if (rl.ne.64) STOP 1
END PROGRAM test
|
