35CHARACTER(len=128),
PARAMETER :: package_name = package
36CHARACTER(len=128),
PARAMETER :: prefix = prefix
38INTEGER,
PARAMETER,
PRIVATE :: nftype = 2
39CHARACTER(len=10),
PARAMETER,
PRIVATE :: &
40 preflist(2,nftype) = reshape((/ &
41 '/usr/local',
'/usr ', &
42 '/usr/local',
' '/), &
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
49INTEGER,
PARAMETER :: filetype_config = 2
57 INTEGER :: cursor, action, nfield
58 INTEGER(KIND=int_b) :: csep, cquote
59 INTEGER(KIND=int_b),
POINTER :: record(:)
62INTEGER,
PARAMETER,
PRIVATE :: csv_basereclen=1024, &
63 csv_action_read=0, csv_action_write=1
68 MODULE PROCEDURE csv_record_init
75 MODULE PROCEDURE csv_record_delete
92 MODULE PROCEDURE csv_record_getfield_char, csv_record_getfield_int, &
93 csv_record_getfield_real, csv_record_getfield_double
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
113 MODULE PROCEDURE csv_record_addfield_char_miss, csv_record_addfield_int_miss, &
114 csv_record_addfield_real_miss, csv_record_addfield_double_miss
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
140FUNCTION getunit()
RESULT(unit)
146 INQUIRE(unit, opened=op)
150CALL l4f_log(l4f_error,
'Too many open files')
165FUNCTION get_package_filepath(filename, filetype)
RESULT(path)
166CHARACTER(len=*),
INTENT(in) :: filename
167INTEGER,
INTENT(in) :: filetype
168character(len=len(filename)) :: lfilename
171CHARACTER(len=512) :: path
172LOGICAL :: exist,cwd,share
178IF (filetype < 1 .OR. filetype > nftype)
THEN
180 CALL l4f_log(l4f_error,
'package file type '//
t2c(filetype)// &
186share = filename(:6) ==
"share:"
187cwd = filename(:4) ==
"cwd:"
190if (share) lfilename=filename(7:)
191if (cwd) lfilename=filename(5:)
193if ( .not. share .and. .not. cwd .and. filetype == filetype_data)
then
201 CALL l4f_log(l4f_debug,
'inquire local file '//trim(path))
202 INQUIRE(file=path, exist=exist)
204 CALL l4f_log(l4f_info,
'local file '//trim(path)//
' found')
209if (share .or. filetype == filetype_config)
then
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)
219 CALL l4f_log(l4f_info,
'package file '//trim(path)//
' found')
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)
230 CALL l4f_log(l4f_info,
'package file '//trim(path)//
' found')
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)
242 CALL l4f_log(l4f_info,
'package file '//trim(path)//
' found')
249CALL l4f_log(l4f_info,
'package file '//trim(lfilename)//
' not found')
252END FUNCTION get_package_filepath
259FUNCTION open_package_file(filename, filetype)
RESULT(unit)
260CHARACTER(len=*),
INTENT(in) :: filename
261INTEGER,
INTENT(in) :: filetype
264CHARACTER(len=512) :: path
267path=get_package_filepath(filename, filetype)
268IF (path ==
'')
RETURN
271IF (unit == -1)
RETURN
273OPEN(unit, file=path, status=
'old', iostat = i)
275 CALL l4f_log(l4f_info,
'package file '//trim(path)//
' opened')
279CALL l4f_log(l4f_error,
'package file '//trim(filename)//
' not found')
283END FUNCTION open_package_file
299SUBROUTINE csv_record_init(this, record, csep, cquote, nfield)
300TYPE(csv_record),
INTENT(INOUT) :: this
301CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: record
302CHARACTER(len=1),
INTENT(IN),
OPTIONAL :: csep
303CHARACTER(len=1),
INTENT(IN),
OPTIONAL :: cquote
304INTEGER,
INTENT(OUT),
OPTIONAL :: nfield
308IF (
PRESENT(csep))
THEN
309 this%csep = transfer(csep, this%csep)
311 this%csep = transfer(
',', this%csep)
313IF (
PRESENT(cquote))
THEN
314 this%cquote = transfer(cquote, this%cquote)
316 this%cquote = transfer(
'"', this%cquote)
321IF (
PRESENT(record))
THEN
323 ALLOCATE(this%record(l))
324 this%record(:) = transfer(record, this%record, l)
326 IF (
PRESENT(nfield))
THEN
328 DO WHILE(.NOT.csv_record_end(this))
335 ALLOCATE(this%record(csv_basereclen))
338END SUBROUTINE csv_record_init
342SUBROUTINE csv_record_delete(this)
345DEALLOCATE(this%record)
347END SUBROUTINE csv_record_delete
351SUBROUTINE csv_record_rewind(this)
357END SUBROUTINE csv_record_rewind
363SUBROUTINE csv_record_addfield_char(this, field, force_quote)
365CHARACTER(len=*),
INTENT(IN) :: field
366LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
371lquote = optio_log(force_quote)
372IF (len(field) == 0)
THEN
373 CALL checkrealloc(this, 1)
374 IF (this%nfield > 0)
THEN
375 CALL add_byte(this, this%csep)
377 CALL add_byte(this, this%cquote)
378 CALL add_byte(this, this%cquote)
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
385 CALL checkrealloc(this, len(field)+1)
386 IF (this%nfield > 0)
CALL add_byte(this, this%csep)
387 this%record(this%cursor+1:this%cursor+len(field)) = transfer(field, this%record)
388 this%cursor = this%cursor + len(field)
390 CALL checkrealloc(this, 2*len(field)+3)
391 IF (this%nfield > 0)
CALL add_byte(this, this%csep)
392 CALL add_byte(this, this%cquote)
394 CALL add_char(field(i:i))
396 CALL add_byte(this, this%cquote)
399this%nfield = this%nfield + 1
404SUBROUTINE add_char(char)
405CHARACTER(len=1) :: char
407this%cursor = this%cursor+1
408this%record(this%cursor) = transfer(char, this%record(1))
409IF (this%record(this%cursor) == this%cquote)
THEN
410 this%cursor = this%cursor+1
411 this%record(this%cursor) = this%cquote
414END SUBROUTINE add_char
416END SUBROUTINE csv_record_addfield_char
420SUBROUTINE checkrealloc(this, enlarge)
422INTEGER,
INTENT(in) :: enlarge
424INTEGER(KIND=int_b),
POINTER :: tmpptr(:)
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
433END SUBROUTINE checkrealloc
437SUBROUTINE add_byte(this, char)
439INTEGER(kind=int_b) :: char
441this%cursor = this%cursor+1
442this%record(this%cursor) = char
444END SUBROUTINE add_byte
450SUBROUTINE csv_record_addfield_char_miss(this, field, force_quote)
452CHARACTER(len=*),
INTENT(IN) :: field
453LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
457END SUBROUTINE csv_record_addfield_char_miss
462SUBROUTINE csv_record_addfield_int(this, field, form, force_quote)
464INTEGER,
INTENT(IN) :: field
465CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
466LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
468IF (
PRESENT(form))
THEN
474END SUBROUTINE csv_record_addfield_int
480SUBROUTINE csv_record_addfield_int_miss(this, field, force_quote)
482INTEGER,
INTENT(IN) :: field
483LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
487END SUBROUTINE csv_record_addfield_int_miss
492SUBROUTINE csv_record_addfield_real(this, field, form, force_quote)
494REAL,
INTENT(IN) :: field
495CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
496LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
498IF (
PRESENT(form))
THEN
504END SUBROUTINE csv_record_addfield_real
510SUBROUTINE csv_record_addfield_real_miss(this, field, force_quote)
512REAL,
INTENT(IN) :: field
513LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
517END SUBROUTINE csv_record_addfield_real_miss
522SUBROUTINE csv_record_addfield_double(this, field, form, force_quote)
524DOUBLE PRECISION,
INTENT(IN) :: field
525CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
526LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
528IF (
PRESENT(form))
THEN
534END SUBROUTINE csv_record_addfield_double
540SUBROUTINE csv_record_addfield_double_miss(this, field, force_quote)
542DOUBLE PRECISION,
INTENT(IN) :: field
543LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
547END SUBROUTINE csv_record_addfield_double_miss
555SUBROUTINE csv_record_addfield_csv_record(this, record)
559IF (this%csep /= record%csep .OR. this%cquote /= record%cquote)
RETURN
560CALL checkrealloc(this, record%cursor)
561IF (this%nfield > 0)
CALL add_byte(this, this%csep)
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
568END SUBROUTINE csv_record_addfield_csv_record
573FUNCTION csv_record_getrecord(this, nfield)
575INTEGER,
INTENT(out),
OPTIONAL :: nfield
577CHARACTER(len=this%cursor) :: csv_record_getrecord
579csv_record_getrecord = transfer(this%record(1:this%cursor), csv_record_getrecord)
580IF (
present(nfield)) nfield = this%nfield
582END FUNCTION csv_record_getrecord
590SUBROUTINE csv_record_getfield_char(this, field, flen, ier)
592CHARACTER(len=*),
INTENT(OUT),
OPTIONAL :: field
594INTEGER,
INTENT(OUT),
OPTIONAL :: flen
595INTEGER,
INTENT(OUT),
OPTIONAL :: ier
597LOGICAL :: inquote, inpre, inpost, firstquote
598INTEGER :: i, ocursor, ofcursor
601IF (csv_record_end(this))
THEN
602 IF (
PRESENT(field)) field = cmiss
603 IF (
PRESENT(ier))
THEN
606 CALL l4f_log(l4f_error, &
607 'in csv_record_getfield, attempt to read past end of record')
613IF (
PRESENT(field)) field =
''
614IF (
PRESENT(ier)) ier = 0
622DO i = this%cursor+1,
SIZE(this%record)
624 IF (is_space_b(this%record(i)))
THEN
631 IF (.NOT.inquote)
THEN
632 IF (this%record(i) == this%cquote)
THEN
635 ELSE IF (this%record(i) == this%csep)
THEN
638 CALL add_char(this%record(i), .true., field)
642 IF (.NOT.firstquote)
THEN
643 IF (this%record(i) == this%cquote)
THEN
647 CALL add_char(this%record(i), .false., field)
652 IF (this%record(i) == this%cquote)
THEN
653 CALL add_char(this%cquote, .false., field)
657 IF (this%record(i) == this%csep)
THEN
660 CALL add_char(this%record(i), .true., field)
668this%cursor = min(i,
SIZE(this%record) + 1)
669IF (
PRESENT(flen)) flen = ofcursor
670IF (
PRESENT(field))
THEN
671 IF (ofcursor > len(field))
THEN
672 IF (
PRESENT(ier))
THEN
675 CALL l4f_log(l4f_warn, &
676 'in csv_record_getfield, CHARACTER variable too short for field: '// &
677 t2c(len(field))//
'/'//
t2c(ocursor))
684SUBROUTINE add_char(char, check_space, field)
685INTEGER(kind=int_b) :: char
686LOGICAL,
INTENT(IN) :: check_space
687CHARACTER(len=*),
INTENT(OUT),
OPTIONAL :: field
689CHARACTER(len=1) :: dummy
692 IF (
PRESENT(field))
THEN
693 IF (ocursor <= len(field))
THEN
694 field(ocursor:ocursor) = transfer(char, dummy)
698 IF (.NOT.is_space_b(char)) ofcursor = ocursor
703END SUBROUTINE add_char
705END SUBROUTINE csv_record_getfield_char
713SUBROUTINE csv_record_getfield_int(this, field, ier)
715INTEGER,
INTENT(OUT) :: field
716INTEGER,
INTENT(OUT),
OPTIONAL :: ier
718CHARACTER(len=32) :: cfield
722IF (
c_e(cfield) .AND. len_trim(cfield) /= 0)
THEN
723 READ(cfield,
'(I32)', iostat=lier) field
726 IF (.NOT.
PRESENT(ier))
THEN
727 CALL l4f_log(l4f_error, &
728 'in csv_record_getfield, invalid integer field: '//trim(cfield))
738END SUBROUTINE csv_record_getfield_int
746SUBROUTINE csv_record_getfield_real(this, field, ier)
748REAL,
INTENT(OUT) :: field
749INTEGER,
INTENT(OUT),
OPTIONAL :: ier
751CHARACTER(len=32) :: cfield
755IF (
c_e(cfield) .AND. len_trim(cfield) /= 0)
THEN
756 READ(cfield,
'(F32.0)', iostat=lier) field
759 IF (.NOT.
PRESENT(ier))
THEN
760 CALL l4f_log(l4f_error, &
761 'in csv_record_getfield, invalid real field: '//trim(cfield))
771END SUBROUTINE csv_record_getfield_real
779SUBROUTINE csv_record_getfield_double(this, field, ier)
781DOUBLE PRECISION,
INTENT(OUT) :: field
782INTEGER,
INTENT(OUT),
OPTIONAL :: ier
784CHARACTER(len=32) :: cfield
788IF (
c_e(cfield) .AND. len_trim(cfield) /= 0)
THEN
789 READ(cfield,
'(F32.0)', iostat=lier) field
792 IF (.NOT.
PRESENT(ier))
THEN
793 CALL l4f_log(l4f_error, &
794 'in csv_record_getfield, invalid double precision field: '//trim(cfield))
804END SUBROUTINE csv_record_getfield_double
809FUNCTION csv_record_end(this)
811LOGICAL :: csv_record_end
813csv_record_end = this%cursor >
SIZE(this%record)
815END FUNCTION csv_record_end
818FUNCTION is_space_c(char)
RESULT(is_space)
819CHARACTER(len=1) :: char
822is_space = (ichar(char) == 32 .OR. ichar(char) == 9)
824END FUNCTION is_space_c
827FUNCTION is_space_b(char)
RESULT(is_space)
828INTEGER(kind=int_b) :: char
831is_space = (char == 32 .OR. char == 9)
833END FUNCTION is_space_b
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.
Function to check whether a value is missing or not.
Utilities for CHARACTER variables.
Utilities for managing files.
Definition of constants to be used for declaring variables of a desired type.
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.