source: XMLF90/src/sax/m_reader.f90 @ 295

Last change on this file since 295 was 6, checked in by ymipsl, 12 years ago

Import des sources XMLF90

File size: 6.9 KB
Line 
1module m_reader
2
3use m_io
4
5private
6
7integer, parameter, public              :: BUFFER_NOT_CONNECTED = -2048
8integer, private, parameter             :: MAXLENGTH = 1024
9
10type, public :: file_buffer_t
11private
12      logical                           :: connected
13      logical                           :: eof
14      integer                           :: lun
15      character(len=50)                 :: filename
16      integer                           :: counter
17      character(len=MAXLENGTH)          :: buffer
18      integer                           :: line
19      integer                           :: col
20      integer                           :: pos 
21      integer                           :: nchars
22      logical                           :: debug
23end type file_buffer_t
24
25public  :: get_character, sync_file
26public  :: line, column, nchars_processed
27public  :: open_file, close_file_buffer, rewind_file, mark_eof_file
28public  :: eof_file
29
30private :: fill_buffer
31
32CONTAINS
33
34!-----------------------------------------
35!
36subroutine open_file(fname,fb,iostat,record_size,verbose)
37character(len=*), intent(in)      :: fname
38type(file_buffer_t), intent(out)  :: fb
39integer, intent(out)              :: iostat
40integer, intent(in), optional     :: record_size
41logical, intent(in), optional     :: verbose
42
43iostat = 0
44
45call setup_io()
46
47fb%connected = .false.
48
49call get_unit(fb%lun,iostat)
50if (iostat /= 0) then
51   if (fb%debug) print *, "Cannot get unit"
52   return
53endif
54
55if (present(verbose)) then
56   fb%debug = verbose
57else
58   fb%debug = .false.
59endif
60
61if (present(record_size)) then
62   open(unit=fb%lun,file=fname,form="formatted",status="old", &
63        action="read",position="rewind",recl=record_size,iostat=iostat)
64else
65   open(unit=fb%lun,file=fname,form="formatted",status="old", &
66        action="read",position="rewind",recl=65536,iostat=iostat)
67endif
68if (iostat /= 0) then
69   if (fb%debug) print *, "Cannot open file ", trim(fname), " iostat: ", iostat
70   return
71endif
72
73fb%connected = .true.
74fb%counter = 0
75fb%eof = .false.
76fb%line = 1
77fb%col = 0
78fb%filename = fname
79fb%pos = 0
80fb%nchars = 0
81fb%buffer = ""
82
83end subroutine open_file
84
85!-------------------------------------------------
86subroutine rewind_file(fb)
87type(file_buffer_t), intent(inout)  :: fb
88
89fb%eof = .false.
90fb%counter = 0
91fb%line = 1
92fb%col = 0
93fb%pos = 0
94fb%nchars = 0
95fb%buffer = ""
96
97rewind(unit=fb%lun)
98
99end subroutine rewind_file
100!-----------------------------------------
101subroutine mark_eof_file(fb)
102type(file_buffer_t), intent(inout)  :: fb
103
104fb%eof = .true.
105
106end subroutine mark_eof_file
107
108!-----------------------------------------
109subroutine close_file_buffer(fb)
110type(file_buffer_t), intent(inout)  :: fb
111
112if (fb%connected) then
113    close(unit=fb%lun)
114    fb%connected = .false.
115endif
116
117end subroutine close_file_buffer
118
119!-------------------------------------------------
120function eof_file(fb) result (res)
121type(file_buffer_t), intent(in)  :: fb
122logical                          :: res
123
124res = fb%eof
125
126end function eof_file
127!-----------------------------------------
128!-----------------------------------------
129! New version, able to cope with arbitrarily long lines
130! (still need to specify a big enough record_size if necessary)
131!
132subroutine fill_buffer(fb,iostat)
133type(file_buffer_t), intent(inout)  :: fb
134integer, intent(out)  :: iostat
135!
136!
137character(len=41)  :: str       ! 40 seems like a good compromise?
138                                ! (1 extra for added newline, see below)
139integer            :: len
140!
141read(unit=fb%lun,iostat=iostat,advance="no",size=len,fmt="(a40)") str
142
143if (iostat == io_eof) then
144   
145   ! End of file
146   if (fb%debug) print *, "End of file."
147   return
148
149else if (iostat > 0) then
150
151   ! Hard i/o error
152   if (fb%debug) print *, "Hard i/o error. iostat:", iostat
153   RETURN
154
155else
156!
157 if (fb%debug) then
158   print *, "Buffer: len, iostat", len, iostat
159   print *, trim(str)
160 endif
161
162   fb%pos = 0
163
164   if (iostat == 0) then
165
166      !  Normal read, with more stuff left on the line
167      !
168      fb%buffer = str(1:len) 
169      fb%nchars = len
170
171   else         ! (end of record)
172      !
173      !  End of record. We mark it with an LF, whatever it is the native marker.
174      !
175!!      fb%buffer = str(1:len) // char(10)
176      fb%buffer = str(1:len)             !! Avoid allocation of string
177      len = len + 1                      !! by compiler
178      fb%buffer(len:len) = char(10)   
179      fb%nchars = len
180      iostat = 0
181   endif
182
183endif
184
185end subroutine fill_buffer
186
187!---------------------------------------------------------------
188subroutine get_character(fb,c,iostat)
189character(len=1), intent(out) :: c
190type(file_buffer_t), intent(inout)  :: fb
191integer, intent(out)          :: iostat
192
193character(len=1)   :: c_next
194
195if (.not. fb%connected) then
196      iostat = BUFFER_NOT_CONNECTED
197      return
198endif
199
200if (fb%pos >= fb%nchars) then
201      call fill_buffer(fb,iostat)
202      if (iostat /= 0) return
203endif
204fb%pos = fb%pos + 1
205c = fb%buffer(fb%pos:fb%pos)
206fb%counter = fb%counter + 1              ! Raw counter
207fb%col = fb%col + 1
208!
209! Deal with end-of-line handling on the processor...
210!
211if (c == char(10)) then
212   ! Our own marker for end of line
213   fb%line = fb%line + 1
214   fb%col = 0
215endif
216if (c == char(13)) then
217   c_next = fb%buffer(fb%pos+1:fb%pos+1)
218   if (c_next == char(10)) then
219      !
220      ! Found CRLF. We replace it by LF, as per specs.
221      c = c_next
222      fb%pos = fb%pos + 1
223      if (fb%debug) print *, "-/-> Removed CR before LF in get_character"
224   else
225      ! Replace single CR by LF
226      c = char(10)
227      if (fb%debug) print *, "-/-> Changed CR to LF in get_character -- line++"
228      !
229   endif
230   ! In both cases we increase the line counter and reset the column
231   !
232   fb%line = fb%line + 1
233   fb%col = 0
234endif
235
236iostat = 0
237
238end subroutine get_character
239
240!----------------------------------------------------
241!----------------------------------------------------
242! Error Location functions
243!
244function line(fb) result (ll)
245type(file_buffer_t), intent(in)  :: fb
246integer                          :: ll
247
248ll = fb%line
249end function line
250
251!----------------------------------------------------
252function column(fb) result (col)
253type(file_buffer_t), intent(in)  :: fb
254integer                          :: col
255
256col = fb%col
257end function column
258!----------------------------------------------------
259!----------------------------------------------------
260function nchars_processed(fb) result (nc)
261type(file_buffer_t), intent(in)  :: fb
262integer                          :: nc
263
264nc = fb%counter
265end function nchars_processed
266!----------------------------------------------------
267
268subroutine sync_file(fb,iostat)
269type(file_buffer_t), intent(inout)  :: fb
270integer, intent(out)                :: iostat
271!
272! Repositions the file so that it matches with
273! the stored file_buffer information
274!
275integer          :: target_counter
276character(len=1) :: c
277
278target_counter = fb%counter
279call rewind_file(fb)
280iostat = 0
281do
282   if (fb%counter == target_counter) exit
283   call get_character(fb,c,iostat)
284   if (iostat /= 0) return
285enddo
286
287end subroutine sync_file
288
289end module m_reader
290
291
292
293
294
295
296
297
298
Note: See TracBrowser for help on using the repository browser.