libsim Versione 7.2.6
file_utilities.F90
1! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2! authors:
3! Davide Cesari <dcesari@arpa.emr.it>
4! Paolo Patruno <ppatruno@arpa.emr.it>
5
6! This program is free software; you can redistribute it and/or
7! modify it under the terms of the GNU General Public License as
8! published by the Free Software Foundation; either version 2 of
9! the License, or (at your option) any later version.
10
11! This program is distributed in the hope that it will be useful,
12! but WITHOUT ANY WARRANTY; without even the implied warranty of
13! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14! GNU General Public License for more details.
15
16! You should have received a copy of the GNU General Public License
17! along with this program. If not, see <http://www.gnu.org/licenses/>.
18#include "config.h"
19!> Utilities for managing files. This module is a collection of generic utilities
20!! for managing files. A group of utilities is dedicated to locating
21!! and opening configuration files in standard directories or in
22!! directories specified by environmental variables. The module also
23!! contains the class \a csv_record for creating and interpreting the
24!! records of a csv file.
25!! \ingroup base
26MODULE file_utilities
27USE kinds
33IMPLICIT NONE
34
35CHARACTER(len=128), PARAMETER :: package_name = package
36CHARACTER(len=128), PARAMETER :: prefix = prefix
37
38INTEGER, PARAMETER, PRIVATE :: nftype = 2
39CHARACTER(len=10), PARAMETER, PRIVATE :: &
40 preflist(2,nftype) = reshape((/ &
41 '/usr/local', '/usr ', &
42 '/usr/local', ' '/), &
43 (/2,nftype/))
44CHARACTER(len=6), PARAMETER, PRIVATE :: &
45 postfix(nftype) = (/ '/share', '/etc ' /)
46CHARACTER(len=6), PARAMETER, PRIVATE :: &
47 filetypename(nftype) = (/ 'DATA ', 'CONFIG' /)
48INTEGER, PARAMETER :: filetype_data = 1 !< Data file requested
49INTEGER, PARAMETER :: filetype_config = 2 !< Configuration file requested
50
51
52!> Class for interpreting the records of a csv file.
53!! See http://en.wikipedia.org/wiki/Comma-separated_values for a
54!! detailed description of the csv format.
55TYPE csv_record
56 PRIVATE
57 INTEGER :: cursor, action, nfield !, ntotal
58 INTEGER(KIND=int_b) :: csep, cquote
59 INTEGER(KIND=int_b), POINTER :: record(:)
60END TYPE csv_record
61
62INTEGER, PARAMETER, PRIVATE :: csv_basereclen=1024, &
63 csv_action_read=0, csv_action_write=1
64
65!> Constructor for the class \a csv_record. It has to be called for every
66!! record (line) csv to be created or interpreted.
67INTERFACE init
68 MODULE PROCEDURE csv_record_init
69END INTERFACE
70
71!> Destructor for the class \a csv_record. It is important to call
72!! it before reusing the object for the following record, in order to
73!! avoid memory leaks.
74INTERFACE delete
75 MODULE PROCEDURE csv_record_delete
76END INTERFACE
77
78!> Methods for successively obtaining the fields of a \a csv_record object.
79!! The generic name \c csv_record_getfield with parameters of the
80!! desired type should be used instead of the specific names, the
81!! compiler will select the proper subroutine. If the optiona argument
82!! \a ier is not provided the subroutines will log warning and error
83!! messages and possibly stop the program in case of error, otherwise
84!! nothing is signalled and the returned error code has the following
85!! meaning:
86!!
87!! \li 0 success
88!! \li 1 field too long for being contained in the string provided (warning, a truncated value is returned anyway)
89!! \li 2 attempt to read past end of record (error, a missing value is returned)
90!! \li 3 conversion to the required type impossible (error, a missing value is returned)
91INTERFACE csv_record_getfield
92 MODULE PROCEDURE csv_record_getfield_char, csv_record_getfield_int, &
93 csv_record_getfield_real, csv_record_getfield_double
94END INTERFACE
95
96!> Methods for successively adding fields to a \a csv_record object.
97!! The generic name \c csv_record_addfield with parameters of the
98!! desired type should be used instead of the specific names, the
99!! compiler will select the proper subroutine. Missing values are
100!! literally inserted in the output without special treatment.
101INTERFACE csv_record_addfield
102 MODULE PROCEDURE csv_record_addfield_char, csv_record_addfield_int, &
103 csv_record_addfield_real, csv_record_addfield_double, &
104 csv_record_addfield_csv_record
105END INTERFACE
106
107!> Methods for successively adding fields to a \a csv_record object.
108!! The generic name \c csv_record_addfield with parameters of the
109!! desired type should be used instead of the specific names, the
110!! compiler will select the proper subroutine. Missing values are
111!! inserted as empty fields.
113 MODULE PROCEDURE csv_record_addfield_char_miss, csv_record_addfield_int_miss, &
114 csv_record_addfield_real_miss, csv_record_addfield_double_miss
115END INTERFACE
116
117
118PRIVATE csv_record_init, csv_record_delete, csv_record_getfield_char, &
119 csv_record_getfield_int, csv_record_getfield_real, csv_record_getfield_double, &
120 csv_record_addfield_char, csv_record_addfield_int, csv_record_addfield_real, &
121 csv_record_addfield_double, csv_record_addfield_csv_record, &
122 csv_record_addfield_char_miss, csv_record_addfield_int_miss, &
123 csv_record_addfield_real_miss, csv_record_addfield_double_miss, &
124 checkrealloc, add_byte
125
126CONTAINS
127
128!> Returns the number of a Fortran input/output unit currently unused.
129!! It returns -1 in case of error. Example of use:
130!! \code
131!! USE file_utilities
132!! ...
133!! INTEGER :: n
134!! ...
135!! n=getunit()
136!! IF (n /= -1) THEN
137!! OPEN(n, FILE='ostregheta.txt')
138!! ...
139!! \endcode
140FUNCTION getunit() RESULT(unit)
141INTEGER :: unit
142
143LOGICAL :: op
144
145DO unit = 100, 32767
146 INQUIRE(unit, opened=op)
147 IF (.NOT. op) RETURN
148ENDDO
149
150CALL l4f_log(l4f_error, 'Too many open files')
151CALL raise_error()
152unit = -1
153
154END FUNCTION getunit
155
156!> Looks for a specific file for the libsim package.
157!! It searches in different directories in the following order:
158!! - current working directory
159!! - directory specified by the environmental variabile \c LIBSIM_DATA for data files or \c LIBSIM_CONFIG for configuration files, if defined
160!! - directory \c /usr/local/share/libsim for data files or \c /usr/local/etc/libsim for configuration files
161!! - directory \c /usr/share/libsim for data files or \c /etc/libsim for configuration files.
162!! filename prefixed by "cwd:" or "share:" force search in current working directory or other package paths respectively
163!! default is everywhere for data files and package paths only for config files
164!! It returns the full path to the existing file or an empty string if not found.
165FUNCTION get_package_filepath(filename, filetype) RESULT(path)
166CHARACTER(len=*), INTENT(in) :: filename !< name of the file to be searched, it must be a relative path name
167INTEGER, INTENT(in) :: filetype !< type of file, the constants \a ::filetype_data or \a ::filetype_config have to be used
168character(len=len(filename)) :: lfilename
169
170INTEGER :: j
171CHARACTER(len=512) :: path
172LOGICAL :: exist,cwd,share
173
174!IF (package_name == ' ') THEN
175! CALL getarg(0, package_name)
176!ENDIF
177
178IF (filetype < 1 .OR. filetype > nftype) THEN
179 path = ''
180 CALL l4f_log(l4f_error, 'package file type '//t2c(filetype)// &
181 ' not valid')
182 CALL raise_error()
183 RETURN
184ENDIF
185
186share = filename(:6) == "share:"
187cwd = filename(:4) == "cwd:"
188
189lfilename=filename
190if (share) lfilename=filename(7:)
191if (cwd) lfilename=filename(5:)
192
193if ( .not. share .and. .not. cwd .and. filetype == filetype_data) then
194 share=.true.
195 cwd=.true.
196end if
197
198if (cwd) then
199 ! try with current dir
200 path = lfilename
201 CALL l4f_log(l4f_debug, 'inquire local file '//trim(path))
202 INQUIRE(file=path, exist=exist)
203 IF (exist) THEN
204 CALL l4f_log(l4f_info, 'local file '//trim(path)//' found')
205 RETURN
206 ENDIF
207end if
208
209if (share .or. filetype == filetype_config) then
210
211 ! try with environment variable
212 CALL getenv(trim(uppercase(package_name))//'_'//trim(filetypename(filetype)), path)
213 IF (path /= ' ') THEN
215 path(len_trim(path)+1:) = '/'//lfilename
216 CALL l4f_log(l4f_debug, 'inquire env package file '//trim(path))
217 INQUIRE(file=path, exist=exist)
218 IF (exist) THEN
219 CALL l4f_log(l4f_info, 'package file '//trim(path)//' found')
220 RETURN
221 ENDIF
222 ENDIF
223
224 ! try with install prefix
225 path = trim(prefix)//trim(postfix(filetype)) &
226 //'/'//trim(package_name)//'/'//lfilename
227 CALL l4f_log(l4f_debug, 'inquire install package file '//trim(path))
228 INQUIRE(file=path, exist=exist)
229 IF (exist) THEN
230 CALL l4f_log(l4f_info, 'package file '//trim(path)//' found')
231 RETURN
232 ENDIF
233
234 ! try with default install prefix
235 DO j = 1, SIZE(preflist,1)
236 IF (preflist(j,filetype) == ' ') EXIT
237 path = trim(preflist(j,filetype))//trim(postfix(filetype)) &
238 //'/'//trim(package_name)//'/'//lfilename
239 CALL l4f_log(l4f_debug, 'inquire package file '//trim(path))
240 INQUIRE(file=path, exist=exist)
241 IF (exist) THEN
242 CALL l4f_log(l4f_info, 'package file '//trim(path)//' found')
243 RETURN
244 ENDIF
245 ENDDO
246
247end if
248
249CALL l4f_log(l4f_info, 'package file '//trim(lfilename)//' not found')
250path = cmiss
251
252END FUNCTION get_package_filepath
253
254
255!> Opens a specific file for the libsim package.
256!! It searches in different directories using get_package_filepath to locate the file.
257!! It returns the unit number associated to the file found and successfully opened,
258!! or -1 if the file does not exist or an error occurred while opening it.
259FUNCTION open_package_file(filename, filetype) RESULT(unit)
260CHARACTER(len=*), INTENT(in) :: filename !< name of the file to be opened, it must be a relative path name
261INTEGER, INTENT(in) :: filetype !< type of file, the constants \a ::filetype_data or \a ::filetype_config have to be used
262INTEGER :: unit, i
263
264CHARACTER(len=512) :: path
265
266unit = -1
267path=get_package_filepath(filename, filetype)
268IF (path == '') RETURN
269
270unit = getunit()
271IF (unit == -1) RETURN
272
273OPEN(unit, file=path, status='old', iostat = i)
274IF (i == 0) THEN
275 CALL l4f_log(l4f_info, 'package file '//trim(path)//' opened')
276 RETURN
277ENDIF
278
279CALL l4f_log(l4f_error, 'package file '//trim(filename)//' not found')
280CALL raise_error()
281unit = -1
282
283END FUNCTION open_package_file
284
285
286!> Initialise a \a csv_record object.
287!! If the record is provided in input, the object is used for decoding a
288!! record read from a file (\a csv_record_getfield methods),
289!! if record is not provided, then the object will be used for
290!! coding a csv record (\a csv_record_addfield methods), for the
291!! successive write on file.
292!! It is possible to specify nonstandard characters for delimiting
293!! and grouping fields, default comma (,) and double quote (").
294!! In case of decoding, it is possible to obtain in output the number of fields
295!! in the record, but this will take extra computing time. As an alternative,
296!! the ::csv_record_end method can be used when extracting each field.
297!! Warning: the \a csv_record class does not handle csv records that extend
298!! on different lines.
299SUBROUTINE csv_record_init(this, record, csep, cquote, nfield)
300TYPE(csv_record),INTENT(INOUT) :: this !< object to be initialised
301CHARACTER(len=*),INTENT(IN), OPTIONAL :: record !< csv record to be interpreted, if not provided, it means we want to code a csv record for output
302CHARACTER(len=1),INTENT(IN),OPTIONAL :: csep !< field separator character, default \c , (comma)
303CHARACTER(len=1),INTENT(IN),OPTIONAL :: cquote !< field grouping character, default \c " (double quote); it is usually used when a field contains comma or blanks
304INTEGER,INTENT(OUT),OPTIONAL :: nfield !< number of fields in the record
305
306INTEGER :: l
307
308IF (PRESENT(csep)) THEN
309 this%csep = transfer(csep, this%csep)
310ELSE
311 this%csep = transfer(',', this%csep)
312ENDIF
313IF (PRESENT(cquote)) THEN
314 this%cquote = transfer(cquote, this%cquote)
315ELSE
316 this%cquote = transfer('"', this%cquote)
317ENDIF
318
319this%cursor = 0
320this%nfield = 0
321IF (PRESENT(record)) THEN
322 l = len_trim(record)
323 ALLOCATE(this%record(l))
324 this%record(:) = transfer(record, this%record, l) ! ice in pgf90 with TRIM(record)
325
326 IF (PRESENT(nfield)) THEN
327 nfield = 0
328 DO WHILE(.NOT.csv_record_end(this)) ! faccio un giro a vuoto sul record
329 nfield = nfield + 1
330 CALL csv_record_getfield(this)
331 ENDDO
332 this%cursor = 0 ! riazzero il cursore
333 ENDIF
334ELSE
335 ALLOCATE(this%record(csv_basereclen))
336ENDIF
337
338END SUBROUTINE csv_record_init
339
340
341!> Destroy the \a csv_record object, freeing allocated memory.
342SUBROUTINE csv_record_delete(this)
343TYPE(csv_record), INTENT(INOUT) :: this !< object to be destroyed
344
345DEALLOCATE(this%record)
346
347END SUBROUTINE csv_record_delete
348
349
350!> Rewind the pointer in order to allow rescan or rewrite of the same record.
351SUBROUTINE csv_record_rewind(this)
352TYPE(csv_record),INTENT(INOUT) :: this !< object to be rewound
354this%cursor = 0
355this%nfield = 0
356
357END SUBROUTINE csv_record_rewind
358
359
360!> Add a field from a \c CHARACTER variable to the csv record \a this.
361!! The field will be quoted if necessary.
362!! \todo Improve the trailing blank quoting.
363SUBROUTINE csv_record_addfield_char(this, field, force_quote)
364TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
365CHARACTER(len=*),INTENT(IN) :: field !< field to be added
366LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
367
368INTEGER :: i
369LOGICAL :: lquote
370
371lquote = optio_log(force_quote)
372IF (len(field) == 0) THEN ! Particular case to be handled separately
373 CALL checkrealloc(this, 1)
374 IF (this%nfield > 0) THEN
375 CALL add_byte(this, this%csep) ! add separator if necessary
376 ELSE
377 CALL add_byte(this, this%cquote) ! if first record is empty it should be quoted
378 CALL add_byte(this, this%cquote) ! in case it is the only one
379 ENDIF
380ELSE IF (index(field, transfer(this%csep,field(1:1))) == 0 &
381 .AND. index(field, transfer(this%cquote,field(1:1))) == 0 &
382 .AND. .NOT.is_space_c(field(1:1)) &
383 .AND. .NOT.is_space_c(field(len(field):len(field))) &
384 .AND. .NOT.lquote) THEN ! quote not required
385 CALL checkrealloc(this, len(field)+1)
386 IF (this%nfield > 0) CALL add_byte(this, this%csep) ! add separator if necessary
387 this%record(this%cursor+1:this%cursor+len(field)) = transfer(field, this%record)
388 this%cursor = this%cursor + len(field)
389ELSE ! quote required
390 CALL checkrealloc(this, 2*len(field)+3) ! worst case """""""""
391 IF (this%nfield > 0) CALL add_byte(this, this%csep) ! add separator if necessary
392 CALL add_byte(this, this%cquote) ! add quote
393 DO i = 1, len(field)
394 CALL add_char(field(i:i))
395 ENDDO
396 CALL add_byte(this, this%cquote) ! add quote
397ENDIF
398
399this%nfield = this%nfield + 1
400
401CONTAINS
402
403! add a character, doubling it if it's a quote
404SUBROUTINE add_char(char)
405CHARACTER(len=1) :: char
406
407this%cursor = this%cursor+1
408this%record(this%cursor) = transfer(char, this%record(1))
409IF (this%record(this%cursor) == this%cquote) THEN ! double the quote
410 this%cursor = this%cursor+1
411 this%record(this%cursor) = this%cquote
412ENDIF
413
414END SUBROUTINE add_char
415
416END SUBROUTINE csv_record_addfield_char
417
418
419! Reallocate record if necessary
420SUBROUTINE checkrealloc(this, enlarge)
421TYPE(csv_record),INTENT(INOUT) :: this
422INTEGER, INTENT(in) :: enlarge
423
424INTEGER(KIND=int_b), POINTER :: tmpptr(:)
425
426IF (this%cursor+enlarge+1 > SIZE(this%record)) THEN
427 ALLOCATE(tmpptr(SIZE(this%record)+max(csv_basereclen, enlarge)))
428 tmpptr(1:SIZE(this%record)) = this%record(:)
429 DEALLOCATE(this%record)
430 this%record => tmpptr
431ENDIF
432
433END SUBROUTINE checkrealloc
434
435
436! add a byte
437SUBROUTINE add_byte(this, char)
438TYPE(csv_record),INTENT(INOUT) :: this
439INTEGER(kind=int_b) :: char
440
441this%cursor = this%cursor+1
442this%record(this%cursor) = char
443
444END SUBROUTINE add_byte
445
446
447!> Add a field from a \c CHARACTER variable to the csv record \a this.
448!! The field will be quoted if necessary. A missing value is inserted
449!! as an empty field.
450SUBROUTINE csv_record_addfield_char_miss(this, field, force_quote)
451TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
452CHARACTER(len=*),INTENT(IN) :: field !< field to be added
453LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
454
455CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
456
457END SUBROUTINE csv_record_addfield_char_miss
458
459
460!> Add a field from an \c INTEGER variable to the csv record \a this.
461!! The field will be quoted if necessary.
462SUBROUTINE csv_record_addfield_int(this, field, form, force_quote)
463TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
464INTEGER,INTENT(IN) :: field !< field to be added
465CHARACTER(len=*),INTENT(in),OPTIONAL :: form !< optional format
466LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
467
468IF (PRESENT(form)) THEN
469 CALL csv_record_addfield(this, trim(to_char(field, form)), force_quote=force_quote)
470ELSE
471 CALL csv_record_addfield(this, t2c(field), force_quote=force_quote)
472ENDIF
473
474END SUBROUTINE csv_record_addfield_int
475
476
477!> Add a field from an \c INTEGER variable to the csv record \a this.
478!! The field will be quoted if necessary. A missing value is inserted
479!! as an empty field.
480SUBROUTINE csv_record_addfield_int_miss(this, field, force_quote)
481TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
482INTEGER,INTENT(IN) :: field !< field to be added
483LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
484
485CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
486
487END SUBROUTINE csv_record_addfield_int_miss
488
489
490!> Add a field from a \c REAL variable to the csv record \a this.
491!! The field will be quoted if necessary.
492SUBROUTINE csv_record_addfield_real(this, field, form, force_quote)
493TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
494REAL,INTENT(IN) :: field !< field to be added
495CHARACTER(len=*),INTENT(in),OPTIONAL :: form !< optional format
496LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
497
498IF (PRESENT(form)) THEN
499 CALL csv_record_addfield(this, trim(to_char(field, form)), force_quote=force_quote)
500ELSE
501 CALL csv_record_addfield(this, t2c(field), force_quote=force_quote)
502ENDIF
503
504END SUBROUTINE csv_record_addfield_real
505
506
507!> Add a field from a \c REAL variable to the csv record \a this.
508!! The field will be quoted if necessary. A missing value is inserted
509!! as an empty field.
510SUBROUTINE csv_record_addfield_real_miss(this, field, force_quote)
511TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
512REAL,INTENT(IN) :: field !< field to be added
513LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
514
515CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
516
517END SUBROUTINE csv_record_addfield_real_miss
518
519
520!> Add a field from a \c DOUBLE PRECISION variable to the csv record \a this.
521!! The field will be quoted if necessary.
522SUBROUTINE csv_record_addfield_double(this, field, form, force_quote)
523TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
524DOUBLE PRECISION,INTENT(IN) :: field !< field to be added
525CHARACTER(len=*),INTENT(in),OPTIONAL :: form !< optional format
526LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
527
528IF (PRESENT(form)) THEN
529 CALL csv_record_addfield(this, trim(to_char(field, form)), force_quote=force_quote)
530ELSE
531 CALL csv_record_addfield(this, t2c(field), force_quote=force_quote)
532ENDIF
533
534END SUBROUTINE csv_record_addfield_double
535
536
537!> Add a field from a \c DOUBLE PRECISION variable to the csv record \a this.
538!! The field will be quoted if necessary. A missing value is inserted
539!! as an empty field.
540SUBROUTINE csv_record_addfield_double_miss(this, field, force_quote)
541TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
542DOUBLE PRECISION,INTENT(IN) :: field !< field to be added
543LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
544
545CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
546
547END SUBROUTINE csv_record_addfield_double_miss
548
549
550!> Add a full \a csv_record object to the csv record \a this.
551!! The object to be added must have been generated through \a
552!! csv_record_addfield calls (csv encoding mode). Both \a csv_record
553!! objects \a this and \a record must use the same delimiter and
554!! quoting characters, otherwise the operation will silently fail.
555SUBROUTINE csv_record_addfield_csv_record(this, record)
556TYPE(csv_record),INTENT(INOUT) :: this !< object where to add record
557TYPE(csv_record),INTENT(IN) :: record !< record to be added
558
559IF (this%csep /= record%csep .OR. this%cquote /= record%cquote) RETURN ! error
560CALL checkrealloc(this, record%cursor)
561IF (this%nfield > 0) CALL add_byte(this, this%csep)
562
563this%record(this%cursor+1:this%cursor+record%cursor) = &
564 record%record(1:record%cursor)
565this%cursor = this%cursor + record%cursor
566this%nfield = this%nfield + record%nfield
567
568END SUBROUTINE csv_record_addfield_csv_record
569
570
571!> Return current csv-coded record as a \a CHARACTER variable, ready to be written
572!! to a file. It is not necessary to trim the result for trailing blanks.
573FUNCTION csv_record_getrecord(this, nfield)
574TYPE(csv_record),INTENT(IN) :: this !< object to be coded, the object is not modified, so that other fields can still be added after the call to ::csv_record_getrecord
575INTEGER, INTENT(out), OPTIONAL :: nfield !< number of fields contained in the record
576
577CHARACTER(len=this%cursor) :: csv_record_getrecord
578
579csv_record_getrecord = transfer(this%record(1:this%cursor), csv_record_getrecord)
580IF (present(nfield)) nfield = this%nfield
581
582END FUNCTION csv_record_getrecord
583
584
585!> Returns next field from the record \a this as a \c CHARACTER variable.
586!! The field pointer is advanced to the next field.
587!! If all the fields have already been interpreted it returns an empty string
588!! anyway; in order to verify the end-of-record condition the \a ier parameter
589!! must be used.
590SUBROUTINE csv_record_getfield_char(this, field, flen, ier)
591TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
592CHARACTER(len=*),INTENT(OUT),OPTIONAL :: field !< contents of the field, if not provided, the field pointer is increased only; if the variable is not long enough, a warning is printed and the part that fits is returned;
593!< the variable is space-terminated anyway, so the \a flen parameter has to be used in order to evaluate possible significant trailing spaces
594INTEGER,INTENT(OUT),OPTIONAL :: flen !< actual length of the field including trailing blanks, it is correctly computed also when \a field is not provided or too short
595INTEGER,INTENT(OUT),OPTIONAL :: ier!< error code, 0 = OK, 1 = \a field too short, 2 = end of record
596
597LOGICAL :: inquote, inpre, inpost, firstquote
598INTEGER :: i, ocursor, ofcursor
599
600! check end of record
601IF (csv_record_end(this)) THEN
602 IF (PRESENT(field)) field = cmiss
603 IF (PRESENT(ier))THEN
604 ier = 2
605 ELSE
606 CALL l4f_log(l4f_error, &
607 'in csv_record_getfield, attempt to read past end of record')
608 CALL raise_error()
609 ENDIF
610 RETURN
611ENDIF
612! start decoding
613IF (PRESENT(field)) field = ''
614IF (PRESENT(ier)) ier = 0
615ocursor = 0
616ofcursor = 0
617inquote = .false.
618inpre = .true.
619inpost = .false.
620firstquote = .false.
621
622DO i = this%cursor+1, SIZE(this%record)
623 IF (inpre) THEN ! sono nel preludio, butto via gli spazi
624 IF (is_space_b(this%record(i))) THEN
625 cycle
626 ELSE
627 inpre = .false.
628 ENDIF
629 ENDIF
630
631 IF (.NOT.inquote) THEN ! fuori da " "
632 IF (this%record(i) == this%cquote) THEN ! ": inizia " "
633 inquote = .true.
634 cycle
635 ELSE IF (this%record(i) == this%csep) THEN ! ,: fine campo
636 EXIT
637 ELSE ! carattere normale, elimina "trailing blanks"
638 CALL add_char(this%record(i), .true., field)
639 cycle
640 ENDIF
641 ELSE ! dentro " "
642 IF (.NOT.firstquote) THEN ! il precedente non e` "
643 IF (this%record(i) == this%cquote) THEN ! ": fine " " oppure ""
644 firstquote = .true.
645 cycle
646 ELSE ! carattere normale
647 CALL add_char(this%record(i), .false., field)
648 cycle
649 ENDIF
650 ELSE ! il precedente e` "
651 firstquote = .false.
652 IF (this%record(i) == this%cquote) THEN ! ": sequenza ""
653 CALL add_char(this%cquote, .false., field)
654 cycle
655 ELSE ! carattere normale: e` terminata " "
656 inquote = .false.
657 IF (this%record(i) == this%csep) THEN ! , fine campo
658 EXIT
659 ELSE ! carattere normale, elimina "trailing blanks"
660 CALL add_char(this%record(i), .true., field)
661 cycle
662 ENDIF
663 ENDIF
664 ENDIF
665 ENDIF
666ENDDO
667
668this%cursor = min(i, SIZE(this%record) + 1)
669IF (PRESENT(flen)) flen = ofcursor ! restituisco la lunghezza
670IF (PRESENT(field)) THEN ! controllo overflow di field
671 IF (ofcursor > len(field)) THEN
672 IF (PRESENT(ier)) THEN
673 ier = 1
674 ELSE
675 CALL l4f_log(l4f_warn, &
676 'in csv_record_getfield, CHARACTER variable too short for field: '// &
677 t2c(len(field))//'/'//t2c(ocursor))
678 ENDIF
679 ENDIF
680ENDIF
681
682CONTAINS
683
684SUBROUTINE add_char(char, check_space, field)
685INTEGER(kind=int_b) :: char
686LOGICAL,INTENT(IN) :: check_space
687CHARACTER(len=*),INTENT(OUT),OPTIONAL :: field
688
689CHARACTER(len=1) :: dummy ! this prevents a memory leak in TRANSFER()???
690
691ocursor = ocursor + 1
692 IF (PRESENT(field)) THEN
693 IF (ocursor <= len(field)) THEN
694 field(ocursor:ocursor) = transfer(char, dummy)
695 ENDIF
696ENDIF
697IF (check_space) THEN
698 IF (.NOT.is_space_b(char)) ofcursor = ocursor
699ELSE
700 ofcursor = ocursor
701ENDIF
702
703END SUBROUTINE add_char
704
705END SUBROUTINE csv_record_getfield_char
706
707
708!> Returns next field from the record \a this as an \c INTEGER variable.
709!! The field pointer is advanced to the next field.
710!! If all the fields have already been interpreted or the field cannot be
711!! interpreted as an integer, or if it is longer than 32 characters,
712!! it returns a missing value.
713SUBROUTINE csv_record_getfield_int(this, field, ier)
714TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
715INTEGER,INTENT(OUT) :: field !< value of the field, = \a imiss if conversion fails
716INTEGER,INTENT(OUT),OPTIONAL :: ier !< error code, 0 = OK, 2 = end of record, 3 = cannot convert to integer
717
718CHARACTER(len=32) :: cfield
719INTEGER :: lier
720
721CALL csv_record_getfield(this, field=cfield, ier=ier)
722IF (c_e(cfield) .AND. len_trim(cfield) /= 0) THEN
723 READ(cfield, '(I32)', iostat=lier) field
724 IF (lier /= 0) THEN
725 field = imiss
726 IF (.NOT.PRESENT(ier)) THEN
727 CALL l4f_log(l4f_error, &
728 'in csv_record_getfield, invalid integer field: '//trim(cfield))
729 CALL raise_error()
730 ELSE
731 ier = 3 ! conversion error
732 ENDIF
733 ENDIF
734ELSE
735 field = imiss
736ENDIF
737
738END SUBROUTINE csv_record_getfield_int
739
740
741!> Returns next field from the record \a this as a \c REAL variable.
742!! The field pointer is advanced to the next field.
743!! If all the fields have already been interpreted or the field cannot be
744!! interpreted as a real, or if it is longer than 32 characters,
745!! it returns a missing value.
746SUBROUTINE csv_record_getfield_real(this, field, ier)
747TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
748REAL,INTENT(OUT) :: field !< value of the field, = \a rmiss if conversion fails
749INTEGER,INTENT(OUT),OPTIONAL :: ier !< error code, 0 = OK, 2 = end of record, 3 = cannot convert to real
750
751CHARACTER(len=32) :: cfield
752INTEGER :: lier
753
754CALL csv_record_getfield(this, field=cfield, ier=ier)
755IF (c_e(cfield) .AND. len_trim(cfield) /= 0) THEN
756 READ(cfield, '(F32.0)', iostat=lier) field
757 IF (lier /= 0) THEN
758 field = rmiss
759 IF (.NOT.PRESENT(ier)) THEN
760 CALL l4f_log(l4f_error, &
761 'in csv_record_getfield, invalid real field: '//trim(cfield))
762 CALL raise_error()
763 ELSE
764 ier = 3 ! conversion error
765 ENDIF
766 ENDIF
767ELSE
768 field = rmiss
769ENDIF
770
771END SUBROUTINE csv_record_getfield_real
772
773
774!> Returns next field from the record \a this as a \c DOUBLE PRECISION variable.
775!! The field pointer is advanced to the next field.
776!! If all the fields have already been interpreted or the field cannot be
777!! interpreted as double, or if it is longer than 32 characters,
778!! it returns a missing value.
779SUBROUTINE csv_record_getfield_double(this, field, ier)
780TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
781DOUBLE PRECISION,INTENT(OUT) :: field !< value of the field, = \a dmiss if conversion fails
782INTEGER,INTENT(OUT),OPTIONAL :: ier !< error code, 0 = OK, 2 = end of record, 3 = cannot convert to double
783
784CHARACTER(len=32) :: cfield
785INTEGER :: lier
786
787CALL csv_record_getfield(this, field=cfield, ier=ier)
788IF (c_e(cfield) .AND. len_trim(cfield) /= 0) THEN
789 READ(cfield, '(F32.0)', iostat=lier) field
790 IF (lier /= 0) THEN
791 field = dmiss
792 IF (.NOT.PRESENT(ier)) THEN
793 CALL l4f_log(l4f_error, &
794 'in csv_record_getfield, invalid double precision field: '//trim(cfield))
795 CALL raise_error()
796 ELSE
797 ier = 3 ! conversion error
798 ENDIF
799 ENDIF
800ELSE
801 field = dmiss
802ENDIF
803
804END SUBROUTINE csv_record_getfield_double
805
806
807!> Tells whether end of record was reached (\c .TRUE.)
808!! or there are still some fields left (\c .FALSE.).
809FUNCTION csv_record_end(this)
810TYPE(csv_record), INTENT(IN) :: this !< object to be checked for end of record
811LOGICAL :: csv_record_end
812
813csv_record_end = this%cursor > SIZE(this%record)
814
815END FUNCTION csv_record_end
816
817
818FUNCTION is_space_c(char) RESULT(is_space)
819CHARACTER(len=1) :: char
820LOGICAL :: is_space
821
822is_space = (ichar(char) == 32 .OR. ichar(char) == 9) ! improve
823
824END FUNCTION is_space_c
825
826
827FUNCTION is_space_b(char) RESULT(is_space)
828INTEGER(kind=int_b) :: char
829LOGICAL :: is_space
830
831is_space = (char == 32 .OR. char == 9) ! improve
832
833END FUNCTION is_space_b
834
835
836END MODULE file_utilities
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Methods for successively adding fields to a csv_record object.
Methods for successively adding fields to a csv_record object.
Methods for successively obtaining the fields of a csv_record object.
Destructor for the class csv_record.
Constructor for the class csv_record.
Index method.
Function to check whether a value is missing or not.
Utilities for CHARACTER variables.
Gestione degli errori.
Utilities for managing files.
Definition of constants to be used for declaring variables of a desired type.
Definition kinds.F90:245
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Class for interpreting the records of a csv file.

Generated with Doxygen.