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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
c
c $Id: fortran.F,v 1.1 2005/03/31 13:13:00 baud Exp $
c
c $Log: fortran.F,v $
c Revision 1.1 2005/03/31 13:13:00 baud
c imported from CASTOR
c
c Revision 1.2 1999/07/20 12:47:58 jdurand
c 20-JUL-1999 Jean-Damien Durand
c Timeouted version of RFIO. Using netread_timeout() and netwrite_timeout
c on all control and data sockets.
c
c
c Copyright (C) 1990,1991 by CERN/CN/SW/DC
c All rights reserved
c
c fortran.F remote file I/O - C callable server fortran interface
c
c fopn_us(int *unit, char *file, int *filen, int *append, int *irc)
c fopn_ud(int *unit, char *file, int *filen, int *lrecl, int *irc)
c fwr_us(int *unit, char *buf, int *nwrit, int *irc)
c fwr_ud(int *unit, char *buf, int *nrec, int *nwrit, int *irc)
c frd_us(int *unit, char *buf, int *nwant, int *irc)
c frd_ud(int *unit, char *buf, int *nrec, int *nwant, int *irc)
c fcls_f(int *unit, int *irc);
c frdc(int *unit, char *buf, int *nwant, int *ngot, int *irc)
c
c
subroutine fopn_us(unit, file, filen, append, irc)
c
implicit none
integer unit
character*256 file
integer filen
integer append
integer irc
c
character*80 SCCSID
data SCCSID /
+ "@(#)fortran.F 3.5 09/24/92 CERN CN-SW/DC F. Hemmer"/
c
c
#if (defined(ultrix) && defined(mips))
c this helps getfilep in getting the fp.Apparently the binding which is
c done by a fortran main program at runtime is not done when a subroutine
c is called from a C program.This command forces it . AK 14/02/92
c It is a temporary solution till a better one is found.
c
write(*,*)
c
#endif
c
if (append .eq. 0) then
open(unit=unit,file=file(1:filen),iostat=irc,
+ FORM='UNFORMATTED',ACCESS='SEQUENTIAL')
else
#if defined(sun) || defined(sgi) || defined(hpux) || ( defined(ultrix) && defined(mips) )
open(unit=unit,file=file(1:filen),iostat=irc,
+ FORM='UNFORMATTED',ACCESS='APPEND')
#endif /* sun || sgi || hpux || ( ultrix && mips ) */
#if defined(apollo)
open(unit=unit,file=file(1:filen),iostat=irc,
+ FORM='UNFORMATTED',ACCESS='SEQUENTIAL',STATUS='APPEND')
#endif /* apollo */
#if defined(_AIX)
open(unit=unit,file=file(1:filen),iostat=irc,
+ FORM='UNFORMATTED',ACCESS='SEQUENTIAL',STATUS='OLD')
#if defined(_IBMESA)
1 read(unit=unit,end=2)
go to 1
2 backspace unit
#endif
#endif /* AIX */
#if defined(CRAY)
open(unit=unit,file=file(1:filen),iostat=irc,FORM='UNFORMATTED',
+ ACCESS='SEQUENTIAL', POSITION='APPEND')
#endif /* CRAY */
endif
end
c
subroutine fopn_ud(unit, file, filen, lrecl, irc)
implicit none
integer unit
character*256 file
integer filen
integer lrecl
integer irc
c
#if defined(sgi)
lrecl=(lrecl+3)/4
#endif /* sgi */
open(unit=unit,file=file(1:filen),iostat=irc,FORM='UNFORMATTED',
+ ACCESS='DIRECT',RECL=lrecl)
end
c
subroutine fcls_f(unit, irc)
implicit none
integer unit
integer irc
c
close(unit=unit,iostat=irc)
end
c
subroutine fwr_us(unit, buf, nwrit, irc)
implicit none
integer unit
integer nwrit
character*1 buf(nwrit)
integer irc
c
write(unit,iostat=irc) buf
end
c
subroutine fwr_ud(unit, buf, nrec, nwrit, irc)
implicit none
integer nwrit
integer unit
character*1 buf(nwrit)
integer nrec
integer irc
c
write(unit,rec=nrec,iostat=irc) buf
end
c
subroutine frd_us(unit, buf, nwant, irc)
implicit none
integer unit
integer nwant
character*1 buf(nwant)
integer irc
c
read(unit,iostat=irc) buf
end
c
subroutine frd_ud(unit, buf, nrec, nwant, irc)
implicit none
integer unit
integer nwant
character*1 buf(nwant)
integer nrec
integer irc
c
read(unit,rec=nrec,iostat=irc) buf
end
c
subroutine frdc(unit, buf, nwant, ngot, irc)
implicit none
integer unit
integer nwant
character*1 buf(nwant)
integer ngot
integer irc
integer count
#if defined(CRAY)
integer ubc
c
count = (nwant+7)/8
call read(unit,buf,count,irc,ubc)
ngot = count*8 - ubc/8
end
#else
c
count = nwant
call readf(unit,buf(1),count,irc)
ngot = count
end
#endif /* CRAY */
|
