35 CHARACTER(len=128),
PARAMETER :: package_name = package
36 CHARACTER(len=128),
PARAMETER :: prefix = prefix
38 INTEGER,
PARAMETER,
PRIVATE :: nftype = 2
39 CHARACTER(len=10),
PARAMETER,
PRIVATE :: &
40 preflist(2,nftype) = reshape((/ &
41 '/usr/local',
'/usr ', &
42 '/usr/local',
' '/), &
44 CHARACTER(len=6),
PARAMETER,
PRIVATE :: &
45 postfix(nftype) = (/
'/share',
'/etc ' /)
46 CHARACTER(len=6),
PARAMETER,
PRIVATE :: &
47 filetypename(nftype) = (/
'DATA ',
'CONFIG' /)
48 INTEGER,
PARAMETER :: filetype_data = 1
49 INTEGER,
PARAMETER :: filetype_config = 2
57 INTEGER :: cursor, action, nfield
58 INTEGER(KIND=int_b) :: csep, cquote
59 INTEGER(KIND=int_b),
POINTER :: record(:)
62 INTEGER,
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
118 PRIVATE 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
140 FUNCTION getunit()
RESULT(unit)
146 INQUIRE(unit, opened=op)
150 CALL l4f_log(l4f_error,
'Too many open files')
165 FUNCTION get_package_filepath(filename, filetype)
RESULT(path)
166 CHARACTER(len=*),
INTENT(in) :: filename
167 INTEGER,
INTENT(in) :: filetype
168 character(len=len(filename)) :: lfilename
171 CHARACTER(len=512) :: path
172 LOGICAL :: exist,cwd,share
178 IF (filetype < 1 .OR. filetype > nftype)
THEN 180 CALL l4f_log(l4f_error,
'package file type '//
t2c(filetype)// &
186 share = filename(:6) ==
"share:" 187 cwd = filename(:4) ==
"cwd:" 190 if (share) lfilename=filename(7:)
191 if (cwd) lfilename=filename(5:)
193 if ( .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')
209 if (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')
249 CALL l4f_log(l4f_info,
'package file '//trim(lfilename)//
' not found')
252 END FUNCTION get_package_filepath
259 FUNCTION open_package_file(filename, filetype)
RESULT(unit)
260 CHARACTER(len=*),
INTENT(in) :: filename
261 INTEGER,
INTENT(in) :: filetype
264 CHARACTER(len=512) :: path
267 path=get_package_filepath(filename, filetype)
268 IF (path ==
'')
RETURN 271 IF (unit == -1)
RETURN 273 OPEN(unit, file=path, status=
'old', iostat = i)
275 CALL l4f_log(l4f_info,
'package file '//trim(path)//
' opened')
279 CALL l4f_log(l4f_error,
'package file '//trim(filename)//
' not found')
283 END FUNCTION open_package_file
299 SUBROUTINE csv_record_init(this, record, csep, cquote, nfield)
300 TYPE(csv_record),
INTENT(INOUT) :: this
301 CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: record
302 CHARACTER(len=1),
INTENT(IN),
OPTIONAL :: csep
303 CHARACTER(len=1),
INTENT(IN),
OPTIONAL :: cquote
304 INTEGER,
INTENT(OUT),
OPTIONAL :: nfield
308 IF (
PRESENT(csep))
THEN 309 this%csep = transfer(csep, this%csep)
311 this%csep = transfer(
',', this%csep)
313 IF (
PRESENT(cquote))
THEN 314 this%cquote = transfer(cquote, this%cquote)
316 this%cquote = transfer(
'"', this%cquote)
321 IF (
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))
338 END SUBROUTINE csv_record_init
342 SUBROUTINE csv_record_delete(this)
343 TYPE(csv_record),
INTENT(INOUT) :: this
345 DEALLOCATE(this%record)
347 END SUBROUTINE csv_record_delete
351 SUBROUTINE csv_record_rewind(this)
352 TYPE(csv_record),
INTENT(INOUT) :: this
357 END SUBROUTINE csv_record_rewind
363 SUBROUTINE csv_record_addfield_char(this, field, force_quote)
365 CHARACTER(len=*),
INTENT(IN) :: field
366 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
371 lquote = optio_log(force_quote)
372 IF (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)
380 ELSE 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)
399 this%nfield = this%nfield + 1
404 SUBROUTINE add_char(char)
405 CHARACTER(len=1) :: char
407 this%cursor = this%cursor+1
408 this%record(this%cursor) = transfer(char, this%record(1))
409 IF (this%record(this%cursor) == this%cquote)
THEN 410 this%cursor = this%cursor+1
411 this%record(this%cursor) = this%cquote
414 END SUBROUTINE add_char
416 END SUBROUTINE csv_record_addfield_char
420 SUBROUTINE checkrealloc(this, enlarge)
422 INTEGER,
INTENT(in) :: enlarge
424 INTEGER(KIND=int_b),
POINTER :: tmpptr(:)
426 IF (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
433 END SUBROUTINE checkrealloc
437 SUBROUTINE add_byte(this, char)
439 INTEGER(kind=int_b) :: char
441 this%cursor = this%cursor+1
442 this%record(this%cursor) = char
444 END SUBROUTINE add_byte
450 SUBROUTINE csv_record_addfield_char_miss(this, field, force_quote)
452 CHARACTER(len=*),
INTENT(IN) :: field
453 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
457 END SUBROUTINE csv_record_addfield_char_miss
462 SUBROUTINE csv_record_addfield_int(this, field, form, force_quote)
464 INTEGER,
INTENT(IN) :: field
465 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
466 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
468 IF (
PRESENT(form))
THEN 474 END SUBROUTINE csv_record_addfield_int
480 SUBROUTINE csv_record_addfield_int_miss(this, field, force_quote)
482 INTEGER,
INTENT(IN) :: field
483 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
487 END SUBROUTINE csv_record_addfield_int_miss
492 SUBROUTINE csv_record_addfield_real(this, field, form, force_quote)
494 REAL,
INTENT(IN) :: field
495 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
496 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
498 IF (
PRESENT(form))
THEN 504 END SUBROUTINE csv_record_addfield_real
510 SUBROUTINE csv_record_addfield_real_miss(this, field, force_quote)
512 REAL,
INTENT(IN) :: field
513 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
517 END SUBROUTINE csv_record_addfield_real_miss
522 SUBROUTINE csv_record_addfield_double(this, field, form, force_quote)
524 DOUBLE PRECISION,
INTENT(IN) :: field
525 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
526 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
528 IF (
PRESENT(form))
THEN 534 END SUBROUTINE csv_record_addfield_double
540 SUBROUTINE csv_record_addfield_double_miss(this, field, force_quote)
542 DOUBLE PRECISION,
INTENT(IN) :: field
543 LOGICAL,
INTENT(in),
OPTIONAL :: force_quote
547 END SUBROUTINE csv_record_addfield_double_miss
555 SUBROUTINE csv_record_addfield_csv_record(this, record)
559 IF (this%csep /= record%csep .OR. this%cquote /= record%cquote)
RETURN 560 CALL checkrealloc(this, record%cursor)
561 IF (this%nfield > 0)
CALL add_byte(this, this%csep)
563 this%record(this%cursor+1:this%cursor+record%cursor) = &
564 record%record(1:record%cursor)
565 this%cursor = this%cursor + record%cursor
566 this%nfield = this%nfield + record%nfield
568 END SUBROUTINE csv_record_addfield_csv_record
573 FUNCTION csv_record_getrecord(this, nfield)
574 TYPE(csv_record),
INTENT(IN) :: this
575 INTEGER,
INTENT(out),
OPTIONAL :: nfield
577 CHARACTER(len=this%cursor) :: csv_record_getrecord
579 csv_record_getrecord = transfer(this%record(1:this%cursor), csv_record_getrecord)
580 IF (
present(nfield)) nfield = this%nfield
582 END FUNCTION csv_record_getrecord
590 SUBROUTINE csv_record_getfield_char(this, field, flen, ier)
592 CHARACTER(len=*),
INTENT(OUT),
OPTIONAL :: field
594 INTEGER,
INTENT(OUT),
OPTIONAL :: flen
595 INTEGER,
INTENT(OUT),
OPTIONAL :: ier
597 LOGICAL :: inquote, inpre, inpost, firstquote
598 INTEGER :: i, ocursor, ofcursor
601 IF (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')
613 IF (
PRESENT(field)) field =
'' 614 IF (
PRESENT(ier)) ier = 0
622 DO 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)
668 this%cursor = min(i,
SIZE(this%record) + 1)
669 IF (
PRESENT(flen)) flen = ofcursor
670 IF (
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))
684 SUBROUTINE add_char(char, check_space, field)
685 INTEGER(kind=int_b) :: char
686 LOGICAL,
INTENT(IN) :: check_space
687 CHARACTER(len=*),
INTENT(OUT),
OPTIONAL :: field
689 CHARACTER(len=1) :: dummy
691 ocursor = ocursor + 1
692 IF (
PRESENT(field))
THEN 693 IF (ocursor <= len(field))
THEN 694 field(ocursor:ocursor) = transfer(char, dummy)
697 IF (check_space)
THEN 698 IF (.NOT.is_space_b(char)) ofcursor = ocursor
703 END SUBROUTINE add_char
705 END SUBROUTINE csv_record_getfield_char
713 SUBROUTINE csv_record_getfield_int(this, field, ier)
715 INTEGER,
INTENT(OUT) :: field
716 INTEGER,
INTENT(OUT),
OPTIONAL :: ier
718 CHARACTER(len=32) :: cfield
722 IF (
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))
738 END SUBROUTINE csv_record_getfield_int
746 SUBROUTINE csv_record_getfield_real(this, field, ier)
748 REAL,
INTENT(OUT) :: field
749 INTEGER,
INTENT(OUT),
OPTIONAL :: ier
751 CHARACTER(len=32) :: cfield
755 IF (
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))
771 END SUBROUTINE csv_record_getfield_real
779 SUBROUTINE csv_record_getfield_double(this, field, ier)
781 DOUBLE PRECISION,
INTENT(OUT) :: field
782 INTEGER,
INTENT(OUT),
OPTIONAL :: ier
784 CHARACTER(len=32) :: cfield
788 IF (
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))
804 END SUBROUTINE csv_record_getfield_double
809 FUNCTION csv_record_end(this)
811 LOGICAL :: csv_record_end
813 csv_record_end = this%cursor >
SIZE(this%record)
815 END FUNCTION csv_record_end
818 FUNCTION is_space_c(char)
RESULT(is_space)
819 CHARACTER(len=1) :: char
822 is_space = (ichar(char) == 32 .OR. ichar(char) == 9)
824 END FUNCTION is_space_c
827 FUNCTION is_space_b(char)
RESULT(is_space)
828 INTEGER(kind=int_b) :: char
831 is_space = (char == 32 .OR. char == 9)
833 END FUNCTION is_space_b
Function to check whether a value is missing or not.
Set of functions that return a trimmed CHARACTER representation of the input variable.
Constructor for the class csv_record.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Methods for successively adding fields to a csv_record object.
Utilities for managing files.
Methods for successively obtaining the fields of a csv_record object.
Methods for successively adding fields to a csv_record object.
Destructor for the class csv_record.
Set of functions that return a CHARACTER representation of the input variable.
Definitions of constants and functions for working with missing values.
Class for interpreting the records of a csv file.
classe per la gestione del logging
Utilities for CHARACTER variables.
Definition of constants to be used for declaring variables of a desired type.