The TELEMAC-MASCARET system  trunk
fv_aed2_csv_reader.F90
Go to the documentation of this file.
1 !###############################################################################
2 !# #
3 !# fv_aed2_csv_reader.F90 #
4 !# #
5 !# Read csv input files for libaed2 variable spatial initialisation. #
6 !# #
7 !# ----------------------------------------------------------------------- #
8 !# #
9 !# Developed by : #
10 !# AquaticEcoDynamics (AED) Group #
11 !# School of Earth & Environment #
12 !# (C) The University of Western Australia #
13 !# #
14 !# Copyright by the AED-team @ UWA under the GNU Public License - www.gnu.org #
15 !# #
16 !# ----------------------------------------------------------------------- #
17 !# #
18 !# Created Feb 2016 #
19 !# #
20 !###############################################################################
21 
23 
25  IMPLICIT NONE
26 
27 !-------------------------------------------------------------------------------
28 !
29  PRIVATE ! by default, make everything private
30 !
31 ! TODO: MAKE THIS BELOW GENERIC TO ALL COMPILERS /!\
32 !
33 #if defined SINGLE
34 #define AED_REAL real(KIND=R4)
35 #else
36 #define AED_REAL real(KIND=R8)
37 #endif
38 
39  INTEGER,PARAMETER :: bufsize=2048
40 
41 
42  !----------------------------------------------------------------------------
43  !# The AED_READER user type is used internally in the parser to track the #
44  !# file being read. #
45  !----------------------------------------------------------------------------
47  CHARACTER(len=bufsize) :: buf
48  INTEGER :: buf_pos
49  INTEGER :: buf_len
50  INTEGER :: lun
51  INTEGER :: n_cols
52  END TYPE aed_reader
53 
54  !----------------------------------------------------------------------------
55  !# The AED_SYMBOL type is a form of variable length string #
56  !----------------------------------------------------------------------------
58  INTEGER :: length
59  CHARACTER,POINTER :: sym(:)
60  END TYPE aed_symbol
61 
62 !-------------------------------------------------------------------------------
63 
64  CHARACTER(len=1), parameter :: eoln=achar(10)
65  CHARACTER(len=1), parameter :: ctab=achar(8)
66  CHARACTER(len=1), parameter :: cnul=achar(0)
67 !
68  CHARACTER(len=32) :: t_strs(0:32)
69 !
70  !TYPE(AED_READER),POINTER :: units(10)
71  TYPE arp
72  TYPE(aed_reader),POINTER :: p
73  END TYPE arp
74  TYPE(arp) :: units(10)
75 !
76 !-------------------------------------------------------------------------------
78 
79 CONTAINS
80 
81 !###############################################################################
82 SUBROUTINE init_t_strs
83 !-------------------------------------------------------------------------------
84  t_strs( 0) = ""
85  t_strs( 1) = " "
86  t_strs( 2) = " "
87  t_strs( 3) = " "
88  t_strs( 4) = " "
89  t_strs( 5) = " "
90  t_strs( 6) = " "
91  t_strs( 7) = " "
92  t_strs( 8) = " "
93  t_strs( 9) = " "
94  t_strs(10) = " "
95  t_strs(11) = " "
96  t_strs(12) = " "
97  t_strs(13) = " "
98  t_strs(14) = " "
99  t_strs(15) = " "
100  t_strs(16) = " "
101  t_strs(17) = " "
102  t_strs(18) = " "
103  t_strs(19) = " "
104  t_strs(20) = " "
105  t_strs(21) = " "
106  t_strs(22) = " "
107  t_strs(23) = " "
108  t_strs(24) = " "
109  t_strs(25) = " "
110  t_strs(26) = " "
111  t_strs(27) = " "
112  t_strs(28) = " "
113  t_strs(29) = " "
114  t_strs(30) = " "
115  t_strs(31) = " "
116  t_strs(32) = " "
117 END SUBROUTINE init_t_strs
118 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
119 
120 
121 !###############################################################################
122 INTEGER FUNCTION f_get_lun()
123 !-------------------------------------------------------------------------------
124 ! Find the first free logical unit number
125 !-------------------------------------------------------------------------------
126  INTEGER :: lun
127  LOGICAL :: opened
128 !
129 !-------------------------------------------------------------------------------
130 !BEGIN
131  DO lun = 10,99
132  inquire(unit=lun, opened=opened)
133  IF ( .not. opened ) THEN
134  f_get_lun = lun
135  RETURN
136  ENDIF
137  ENDDO
138  f_get_lun = -1
139 END FUNCTION f_get_lun
140 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
141 
142 
143 !###############################################################################
144 INTEGER FUNCTION fopen(filename)
145 !-------------------------------------------------------------------------------
146 ! open a file and return it logical unit number
147 !-------------------------------------------------------------------------------
148 !ARGUMENTS
149  CHARACTER(len=*),INTENT(in) :: filename
150 !
151 !-------------------------------------------------------------------------------
152 !LOCALS
153  INTEGER :: iostat=-1
154  INTEGER :: lun=-1
155 
156 !BEGIN
157  lun = f_get_lun()
158  IF ( lun .GT. 0 ) open(lun, status='old', file=filename, iostat=iostat)
159 
160  IF (iostat .NE. 0) lun = -1
161 
162  fopen = lun
163 END FUNCTION fopen
164 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
165 
166 
167 !###############################################################################
168 LOGICAL FUNCTION init_parser(filename, aedr)
169 !-------------------------------------------------------------------------------
170 ! open a file and initialise the parser structure for it
171 !-------------------------------------------------------------------------------
172 !ARGUMENTS
173  CHARACTER(len=*), INTENT(in) :: filename
174  TYPE(aed_reader),POINTER :: aedr
175 
176 !LOCALS
177  INTEGER :: lun
178 !
179 !-------------------------------------------------------------------------------
180 !BEGIN
181  CALL init_t_strs
182  lun = fopen(filename)
183  IF ( lun .gt. 0 ) THEN
184  ALLOCATE(aedr)
185  aedr%lun=lun
186  aedr%buf_pos=-1
187  aedr%buf_len=0
188  init_parser = .true.
189  ELSE
190  init_parser = .false.
191  ENDIF
192 END FUNCTION init_parser
193 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
194 
195 
196 !###############################################################################
197 INTEGER FUNCTION char_in_str(ch, str, s)
198 !-------------------------------------------------------------------------------
199 ! char_in_str returns the index of the first match of character ch in string str
200 !-------------------------------------------------------------------------------
201 !ARGUMENTS
202  CHARACTER, INTENT(in) :: ch
203  CHARACTER(len=*), INTENT(in) :: str
204  INTEGER, optional, INTENT(in) :: s
205 
206 !LOCALS
207  INTEGER res
208  INTEGER lnt
209 !
210 !-------------------------------------------------------------------------------
211 !BEGIN
212  lnt=len_trim(str)
213  IF (present(s)) THEN
214  res=s
215  ELSE
216  res=1
217  ENDIF
218  DO WHILE ( (str(res:res) .NE. ch) .AND. (res .LE. lnt) )
219  res=res+1
220  ENDDO
221  IF (res .GT. lnt) res = 0
222  char_in_str = res
223 END FUNCTION char_in_str
224 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
225 
226 
227 !###############################################################################
228 LOGICAL FUNCTION next_symbol(aedr, sym)
229 !-------------------------------------------------------------------------------
230 ! get the next "symbol" from the file, if there is one
231 !-------------------------------------------------------------------------------
232 !ARGUMENTS
233  TYPE(aed_reader),POINTER :: aedr
234  TYPE(aed_symbol),INTENT(out) :: sym
235 
236 !LOCALS
237  INTEGER :: iostat, s1, e1, i, j
238  CHARACTER :: quot
239  CHARACTER(len=4) :: term
240  LOGICAL :: endln
241 !
242 !-------------------------------------------------------------------------------
243 !BEGIN
244  IF ( ASSOCIATED(sym%sym) ) DEALLOCATE(sym%sym)
245  next_symbol = .false.
246  endln = .false.
247  quot=cnul
248 
249  IF (aedr%buf_pos .GE. 0) THEN
250  IF (aedr%buf_pos .GT. aedr%buf_len) THEN
251  aedr%buf_pos = -1
252  ALLOCATE(sym%sym(1))
253  sym%length=1
254  sym%sym(1) = eoln
255  next_symbol = .true.
256  RETURN
257  ENDIF
258  ENDIF
259 
260  term=' '
261  term(1:1)='"'
262  term(2:2)="'"
263  term(3:3)=","
264 
265  s1=bufsize+1
266  DO WHILE ( s1 .GT. bufsize )
267  DO WHILE ( (aedr%buf_pos .LE. 0) .OR. (aedr%buf_pos .GT. aedr%buf_len) )
268  read(unit=aedr%lun,fmt='(A)', iostat=iostat) aedr%buf
269  IF ( iostat .NE. 0) RETURN
270 
271  aedr%buf_len=len_trim(aedr%buf)
272  IF ( (aedr%buf_len .GT. 0) .AND. &
273  (aedr%buf(1:1) .NE. '#') .AND. &
274  (aedr%buf(1:1) .NE. '!') ) THEN
275  aedr%buf_pos=1
276  ELSE
277  aedr%buf_pos=-1
278  ENDIF
279  ENDDO
280 
281  s1=aedr%buf_pos
282 
283  !* Skip leading blanks
284  DO WHILE( ( (aedr%buf(s1:s1) .EQ. ' ') .OR. &
285  (aedr%buf(s1:s1) .EQ. ctab) .OR. &
286  (aedr%buf(s1:s1) .EQ. cnul) .OR. &
287  (aedr%buf(s1:s1) .EQ. eoln) ) .AND. &
288  (s1 .LE. aedr%buf_len) )
289  s1=s1+1
290  ENDDO
291 
292  !* If we have a # skip the rest of the line
293  IF (aedr%buf(s1:s1) .EQ. '#') THEN
294  s1=bufsize+1
295  aedr%buf_pos=aedr%buf_len+1
296  ENDIF
297  ENDDO
298 
299  IF (aedr%buf(s1:s1) .EQ. '"') quot='"'
300  IF (aedr%buf(s1:s1) .EQ. "'") quot="'"
301 
302  IF (quot .NE. cnul) THEN
303  !* looking for an end of quote
304  s1=s1+1
305  e1=s1+1
306  DO WHILE((e1 .LE. aedr%buf_len) .AND. (aedr%buf(e1:e1) .NE. quot))
307  e1=e1+1
308  ENDDO
309  ELSE
310  e1=s1+1
311  DO WHILE((e1 .LE. aedr%buf_len) .AND. (char_in_str(aedr%buf(e1:e1),term) .EQ. 0))
312  e1=e1+1
313  ENDDO
314  ENDIF
315 
316  next_symbol = .true.
317  ALLOCATE(sym%sym(e1-s1))
318  sym%length=e1-s1
319  j=1
320  DO i=s1,e1-1
321  sym%sym(j:j)=aedr%buf(i:i)
322  j=j+1
323  ENDDO
324 
325  IF (quot .NE. cnul) e1=e1+1
326 
327  if (aedr%buf(e1:e1) == ",") e1 = e1+1
328  aedr%buf_pos=e1
329 END FUNCTION next_symbol
330 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
331 
332 
333 !###############################################################################
334 LOGICAL FUNCTION end_parse(aedr)
335 !-------------------------------------------------------------------------------
336 ! Close the file and free the parser storage
337 !-------------------------------------------------------------------------------
338 !ARGUMENTS
339  TYPE(aed_reader),POINTER :: aedr
340 
341 !LOCALS
342  INTEGER :: iostat
343 !
344 !-------------------------------------------------------------------------------
345 !BEGIN
346  close(aedr%lun, iostat=iostat)
347  DEALLOCATE(aedr)
348  end_parse=(iostat .eq. 0)
349 END FUNCTION end_parse
350 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
351 
352 
353 !###############################################################################
354 FUNCTION extract_number(sym) RESULT(num)
355 !-------------------------------------------------------------------------------
356 !
357 !-------------------------------------------------------------------------------
358 !ARGUMENTS
359  TYPE(aed_symbol) :: sym
360 
361 !LOCALS
362  DOUBLE PRECISION :: num
363  CHARACTER(len=80) :: tbuf
364  INTEGER :: i
365 !
366 !-------------------------------------------------------------------------------
367 !BEGIN
368  DO i=1,sym%length
369  tbuf(i:i)=sym%sym(i)
370  ENDDO
371  tbuf(sym%length+1:)=' '
372 
373  read(tbuf,*) num
374 END FUNCTION extract_number
375 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
376 
377 
378 !###############################################################################
379 SUBROUTINE copy_name(sym, name)
380 !-------------------------------------------------------------------------------
381 !ARGUMENTS
382 !-------------------------------------------------------------------------------
383  TYPE(aed_symbol),INTENT(in) :: sym
384  CHARACTER(len=*),INTENT(inout) :: name
385 !
386 !LOCALS
387  INTEGER i
388 !
389 !-------------------------------------------------------------------------------
390 !BEGIN
391  name = t_strs(sym%length)
392  DO i=1,sym%length
393  name(i:i) = sym%sym(i)
394  ENDDO
395 END SUBROUTINE copy_name
396 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
397 
398 
399 !###############################################################################
400 FUNCTION scan_csv_header(aedr,titles) RESULT(count)
401 !-------------------------------------------------------------------------------
402 !ARGUMENTS
403  TYPE(aed_reader),POINTER,INTENT(inout) :: aedr
404  CHARACTER(len=32),POINTER :: titles(:)
405 !
406 !LOCALS
407  TYPE(aed_symbol) :: sym
408  INTEGER :: count, i
409 !
410 !-------------------------------------------------------------------------------
411 !BEGIN
412  NULLIFY(sym%sym)
413  count = 0
414 
415  DO WHILE( next_symbol(aedr, sym) )
416  IF ( sym%sym(1) .EQ. eoln ) THEN
417  rewind(aedr%lun)
418  aedr%buf_pos=-1
419  aedr%buf_len=0
420  i = 0;
421  ALLOCATE(titles(count))
422  titles = ' '
423  DO WHILE( next_symbol(aedr, sym) )
424  IF ( sym%sym(1) .EQ. eoln ) RETURN
425  i = i + 1
426  CALL copy_name(sym,titles(i))
427  ENDDO
428  RETURN
429  ENDIF
430  count=count+1
431  ENDDO
432 END FUNCTION scan_csv_header
433 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
434 
435 
436 !###############################################################################
437 INTEGER FUNCTION aed_csv_read_header(fname, names, ncols)
438 !-------------------------------------------------------------------------------
439 !ARGUMENTS
440  CHARACTER(*),INTENT(in) :: fname
441  CHARACTER(len=32),DIMENSION(:),POINTER :: names
442  INTEGER,INTENT(out) :: ncols
443 !
444 !LOCALS
445  INTEGER :: unit, i
446  TYPE(aed_reader),POINTER :: aedr
447  LOGICAL :: res
448 !
449 !-------------------------------------------------------------------------------
450 !BEGIN
451  NULLIFY(aedr)
452 
453  IF ( .NOT. init_parser(fname, aedr) ) THEN
454  write(lu, *) "Failed to open file '",fname,"'"
455  call plante(1)
456  ENDIF
457  DO i=1,10
458  IF ( .NOT. ASSOCIATED(units(i)%p) ) THEN
459  units(i)%p => aedr
460  unit = i
461  exit
462  ENDIF
463  ENDDO
464  IF ( unit == 0 ) THEN
465  res = end_parse(aedr)
466  ELSE
467  ncols = scan_csv_header(aedr, names)
468  ENDIF
469 
470  aedr%n_cols = ncols
471  aed_csv_read_header = unit
472 END FUNCTION aed_csv_read_header
473 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
474 
475 
476 !###############################################################################
477 LOGICAL FUNCTION aed_csv_read_row(unit, values)
478 !-------------------------------------------------------------------------------
479 !ARGUMENTS
480  INTEGER,INTENT(in) :: unit
481  aed_real,DIMENSION(:),ALLOCATABLE,INTENT(inout) :: values
482 !
483 !LOCALS
484  TYPE(aed_reader),POINTER :: aedr
485  INTEGER :: i, ncols
486  TYPE(aed_symbol) :: sym
487 !
488 !-------------------------------------------------------------------------------
489 !BEGIN
490  aedr => units(unit)%p
491  ncols = aedr%n_cols
492 
493  values(1:ncols) = 0.
494  i = 0
495  DO WHILE ( next_symbol(aedr, sym) ) !#
496  IF ( sym%sym(1) .EQ. eoln ) EXIT
497  i = i + 1
498  IF ( i <= ncols ) values(i) = extract_number(sym)
499  ENDDO
500  IF ( i > 0 .AND. i /= ncols ) &
501  write(lu,*) "data row had ", i, " columns : expecting ", ncols
502 
503  aed_csv_read_row = (i > 0)
504 END FUNCTION aed_csv_read_row
505 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
506 
507 
508 !###############################################################################
509 LOGICAL FUNCTION aed_csv_close(unit)
510 !-------------------------------------------------------------------------------
511 !ARGUMENTS
512  INTEGER,INTENT(in) :: unit
513 !
514 !LOCALS
515  TYPE(aed_reader),POINTER :: aedr
516 !
517 !-------------------------------------------------------------------------------
518 !BEGIN
519  aedr => units(unit)%p
520  aed_csv_close = end_parse(aedr)
521  DEALLOCATE(aedr)
522  NULLIFY(aedr)
523  units(unit)%p => aedr
524 END FUNCTION aed_csv_close
525 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
526 
527 
528 END MODULE fv_aed2_csv_reader
character(len=1), parameter cnul
type(arp), dimension(10) units
integer, parameter bufsize
character(len=32), dimension(0:32) t_strs
character(len=1), parameter ctab
character(len=1), parameter eoln