libsim  Versione7.2.3
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 
26 MODULE file_utilities
27 USE kinds
31 USE log4fortran
32 USE err_handling
33 IMPLICIT NONE
34 
35 CHARACTER(len=128), PARAMETER :: package_name = package
36 CHARACTER(len=128), PARAMETER :: prefix = prefix
37 
38 INTEGER, PARAMETER, PRIVATE :: nftype = 2
39 CHARACTER(len=10), PARAMETER, PRIVATE :: &
40  preflist(2,nftype) = reshape((/ &
41  '/usr/local', '/usr ', &
42  '/usr/local', ' '/), &
43  (/2,nftype/))
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
50 
51 
55 TYPE csv_record
56  PRIVATE
57  INTEGER :: cursor, action, nfield !, ntotal
58  INTEGER(KIND=int_b) :: csep, cquote
59  INTEGER(KIND=int_b), POINTER :: record(:)
60 END TYPE csv_record
61 
62 INTEGER, PARAMETER, PRIVATE :: csv_basereclen=1024, &
63  csv_action_read=0, csv_action_write=1
64 
67 INTERFACE init
68  MODULE PROCEDURE csv_record_init
69 END INTERFACE
70 
74 INTERFACE delete
75  MODULE PROCEDURE csv_record_delete
76 END INTERFACE
77 
91 INTERFACE csv_record_getfield
92  MODULE PROCEDURE csv_record_getfield_char, csv_record_getfield_int, &
93  csv_record_getfield_real, csv_record_getfield_double
94 END INTERFACE
95 
101 INTERFACE 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
105 END INTERFACE
106 
112 INTERFACE csv_record_addfield_miss
113  MODULE PROCEDURE csv_record_addfield_char_miss, csv_record_addfield_int_miss, &
114  csv_record_addfield_real_miss, csv_record_addfield_double_miss
115 END INTERFACE
116 
117 
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
125 
126 CONTAINS
127 
140 FUNCTION getunit() RESULT(unit)
141 INTEGER :: unit
142 
143 LOGICAL :: op
144 
145 DO unit = 100, 32767
146  INQUIRE(unit, opened=op)
147  IF (.NOT. op) RETURN
148 ENDDO
149 
150 CALL l4f_log(l4f_error, 'Too many open files')
151 CALL raise_error()
152 unit = -1
153 
154 END FUNCTION getunit
155 
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
169 
170 INTEGER :: j
171 CHARACTER(len=512) :: path
172 LOGICAL :: exist,cwd,share
173 
174 !IF (package_name == ' ') THEN
175 ! CALL getarg(0, package_name)
176 !ENDIF
177 
178 IF (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
184 ENDIF
185 
186 share = filename(:6) == "share:"
187 cwd = filename(:4) == "cwd:"
188 
189 lfilename=filename
190 if (share) lfilename=filename(7:)
191 if (cwd) lfilename=filename(5:)
192 
193 if ( .not. share .and. .not. cwd .and. filetype == filetype_data) then
194  share=.true.
195  cwd=.true.
196 end if
197 
198 if (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
207 end if
208 
209 if (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
214 
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
247 end if
248 
249 CALL l4f_log(l4f_info, 'package file '//trim(lfilename)//' not found')
250 path = cmiss
251 
252 END FUNCTION get_package_filepath
254 
259 FUNCTION open_package_file(filename, filetype) RESULT(unit)
260 CHARACTER(len=*), INTENT(in) :: filename
261 INTEGER, INTENT(in) :: filetype
262 INTEGER :: unit, i
263 
264 CHARACTER(len=512) :: path
266 unit = -1
267 path=get_package_filepath(filename, filetype)
268 IF (path == '') RETURN
269 
270 unit = getunit()
271 IF (unit == -1) RETURN
273 OPEN(unit, file=path, status='old', iostat = i)
274 IF (i == 0) THEN
275  CALL l4f_log(l4f_info, 'package file '//trim(path)//' opened')
276  RETURN
277 ENDIF
278 
279 CALL l4f_log(l4f_error, 'package file '//trim(filename)//' not found')
280 CALL raise_error()
281 unit = -1
282 
283 END FUNCTION open_package_file
284 
285 
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
305 
306 INTEGER :: l
307 
308 IF (PRESENT(csep)) THEN
309  this%csep = transfer(csep, this%csep)
310 ELSE
311  this%csep = transfer(',', this%csep)
312 ENDIF
313 IF (PRESENT(cquote)) THEN
314  this%cquote = transfer(cquote, this%cquote)
315 ELSE
316  this%cquote = transfer('"', this%cquote)
317 ENDIF
318 
319 this%cursor = 0
320 this%nfield = 0
321 IF (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
334 ELSE
335  ALLOCATE(this%record(csv_basereclen))
336 ENDIF
337 
338 END SUBROUTINE csv_record_init
340 
342 SUBROUTINE csv_record_delete(this)
343 TYPE(csv_record), INTENT(INOUT) :: this
344 
345 DEALLOCATE(this%record)
346 
347 END SUBROUTINE csv_record_delete
348 
349 
351 SUBROUTINE csv_record_rewind(this)
352 TYPE(csv_record),INTENT(INOUT) :: this
353 
354 this%cursor = 0
355 this%nfield = 0
356 
357 END SUBROUTINE csv_record_rewind
358 
359 
363 SUBROUTINE csv_record_addfield_char(this, field, force_quote)
364 TYPE(csv_record),INTENT(INOUT) :: this
365 CHARACTER(len=*),INTENT(IN) :: field
366 LOGICAL, INTENT(in), OPTIONAL :: force_quote
367 
368 INTEGER :: i
369 LOGICAL :: lquote
370 
371 lquote = optio_log(force_quote)
372 IF (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
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 ! 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)
389 ELSE ! 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
397 ENDIF
398 
399 this%nfield = this%nfield + 1
400 
401 CONTAINS
402 
403 ! add a character, doubling it if it's a quote
404 SUBROUTINE add_char(char)
405 CHARACTER(len=1) :: char
406 
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 ! double the quote
410  this%cursor = this%cursor+1
411  this%record(this%cursor) = this%cquote
412 ENDIF
413 
414 END SUBROUTINE add_char
415 
416 END SUBROUTINE csv_record_addfield_char
417 
418 
419 ! Reallocate record if necessary
420 SUBROUTINE checkrealloc(this, enlarge)
421 TYPE(csv_record),INTENT(INOUT) :: this
422 INTEGER, INTENT(in) :: enlarge
423 
424 INTEGER(KIND=int_b), POINTER :: tmpptr(:)
425 
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
431 ENDIF
432 
433 END SUBROUTINE checkrealloc
434 
435 
436 ! add a byte
437 SUBROUTINE add_byte(this, char)
438 TYPE(csv_record),INTENT(INOUT) :: this
439 INTEGER(kind=int_b) :: char
440 
441 this%cursor = this%cursor+1
442 this%record(this%cursor) = char
443 
444 END SUBROUTINE add_byte
445 
446 
450 SUBROUTINE csv_record_addfield_char_miss(this, field, force_quote)
451 TYPE(csv_record),INTENT(INOUT) :: this
452 CHARACTER(len=*),INTENT(IN) :: field
453 LOGICAL, INTENT(in), OPTIONAL :: force_quote
454 
455 CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
456 
457 END SUBROUTINE csv_record_addfield_char_miss
459 
462 SUBROUTINE csv_record_addfield_int(this, field, form, force_quote)
463 TYPE(csv_record),INTENT(INOUT) :: this
464 INTEGER,INTENT(IN) :: field
465 CHARACTER(len=*),INTENT(in),OPTIONAL :: form
466 LOGICAL, INTENT(in), OPTIONAL :: force_quote
467 
468 IF (PRESENT(form)) THEN
469  CALL csv_record_addfield(this, trim(to_char(field, form)), force_quote=force_quote)
470 ELSE
471  CALL csv_record_addfield(this, t2c(field), force_quote=force_quote)
472 ENDIF
473 
474 END SUBROUTINE csv_record_addfield_int
475 
476 
480 SUBROUTINE csv_record_addfield_int_miss(this, field, force_quote)
481 TYPE(csv_record),INTENT(INOUT) :: this
482 INTEGER,INTENT(IN) :: field
483 LOGICAL, INTENT(in), OPTIONAL :: force_quote
484 
485 CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
486 
487 END SUBROUTINE csv_record_addfield_int_miss
488 
489 
492 SUBROUTINE csv_record_addfield_real(this, field, form, force_quote)
493 TYPE(csv_record),INTENT(INOUT) :: this
494 REAL,INTENT(IN) :: field
495 CHARACTER(len=*),INTENT(in),OPTIONAL :: form
496 LOGICAL, INTENT(in), OPTIONAL :: force_quote
497 
498 IF (PRESENT(form)) THEN
499  CALL csv_record_addfield(this, trim(to_char(field, form)), force_quote=force_quote)
500 ELSE
501  CALL csv_record_addfield(this, t2c(field), force_quote=force_quote)
502 ENDIF
503 
504 END SUBROUTINE csv_record_addfield_real
505 
506 
510 SUBROUTINE csv_record_addfield_real_miss(this, field, force_quote)
511 TYPE(csv_record),INTENT(INOUT) :: this
512 REAL,INTENT(IN) :: field
513 LOGICAL, INTENT(in), OPTIONAL :: force_quote
514 
515 CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
516 
517 END SUBROUTINE csv_record_addfield_real_miss
518 
519 
522 SUBROUTINE csv_record_addfield_double(this, field, form, force_quote)
523 TYPE(csv_record),INTENT(INOUT) :: this
524 DOUBLE PRECISION,INTENT(IN) :: field
525 CHARACTER(len=*),INTENT(in),OPTIONAL :: form
526 LOGICAL, INTENT(in), OPTIONAL :: force_quote
527 
528 IF (PRESENT(form)) THEN
529  CALL csv_record_addfield(this, trim(to_char(field, form)), force_quote=force_quote)
530 ELSE
531  CALL csv_record_addfield(this, t2c(field), force_quote=force_quote)
532 ENDIF
533 
534 END SUBROUTINE csv_record_addfield_double
535 
536 
540 SUBROUTINE csv_record_addfield_double_miss(this, field, force_quote)
541 TYPE(csv_record),INTENT(INOUT) :: this
542 DOUBLE PRECISION,INTENT(IN) :: field
543 LOGICAL, INTENT(in), OPTIONAL :: force_quote
544 
545 CALL csv_record_addfield(this, t2c(field, ''), force_quote=force_quote)
546 
547 END SUBROUTINE csv_record_addfield_double_miss
548 
549 
555 SUBROUTINE csv_record_addfield_csv_record(this, record)
556 TYPE(csv_record),INTENT(INOUT) :: this
557 TYPE(csv_record),INTENT(IN) :: record
558 
559 IF (this%csep /= record%csep .OR. this%cquote /= record%cquote) RETURN ! error
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
567 
568 END SUBROUTINE csv_record_addfield_csv_record
569 
570 
573 FUNCTION csv_record_getrecord(this, nfield)
574 TYPE(csv_record),INTENT(IN) :: this
575 INTEGER, INTENT(out), OPTIONAL :: nfield
576 
577 CHARACTER(len=this%cursor) :: csv_record_getrecord
578 
579 csv_record_getrecord = transfer(this%record(1:this%cursor), csv_record_getrecord)
580 IF (present(nfield)) nfield = this%nfield
581 
582 END FUNCTION csv_record_getrecord
583 
584 
590 SUBROUTINE csv_record_getfield_char(this, field, flen, ier)
591 TYPE(csv_record),INTENT(INOUT) :: this
592 CHARACTER(len=*),INTENT(OUT),OPTIONAL :: field
594 INTEGER,INTENT(OUT),OPTIONAL :: flen
595 INTEGER,INTENT(OUT),OPTIONAL :: ier
596 
597 LOGICAL :: inquote, inpre, inpost, firstquote
598 INTEGER :: i, ocursor, ofcursor
599 
600 ! check end of record
601 IF (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
611 ENDIF
612 ! start decoding
613 IF (PRESENT(field)) field = ''
614 IF (PRESENT(ier)) ier = 0
615 ocursor = 0
616 ofcursor = 0
617 inquote = .false.
618 inpre = .true.
619 inpost = .false.
620 firstquote = .false.
621 
622 DO 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
666 ENDDO
667 
668 this%cursor = min(i, SIZE(this%record) + 1)
669 IF (PRESENT(flen)) flen = ofcursor ! restituisco la lunghezza
670 IF (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
680 ENDIF
681 
682 CONTAINS
683 
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
688 
689 CHARACTER(len=1) :: dummy ! this prevents a memory leak in TRANSFER()???
690 
691 ocursor = ocursor + 1
692  IF (PRESENT(field)) THEN
693  IF (ocursor <= len(field)) THEN
694  field(ocursor:ocursor) = transfer(char, dummy)
695  ENDIF
696 ENDIF
697 IF (check_space) THEN
698  IF (.NOT.is_space_b(char)) ofcursor = ocursor
699 ELSE
700  ofcursor = ocursor
701 ENDIF
702 
703 END SUBROUTINE add_char
704 
705 END SUBROUTINE csv_record_getfield_char
706 
707 
713 SUBROUTINE csv_record_getfield_int(this, field, ier)
714 TYPE(csv_record),INTENT(INOUT) :: this
715 INTEGER,INTENT(OUT) :: field
716 INTEGER,INTENT(OUT),OPTIONAL :: ier
717 
718 CHARACTER(len=32) :: cfield
719 INTEGER :: lier
720 
721 CALL csv_record_getfield(this, field=cfield, ier=ier)
722 IF (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
734 ELSE
735  field = imiss
736 ENDIF
737 
738 END SUBROUTINE csv_record_getfield_int
740 
746 SUBROUTINE csv_record_getfield_real(this, field, ier)
747 TYPE(csv_record),INTENT(INOUT) :: this
748 REAL,INTENT(OUT) :: field
749 INTEGER,INTENT(OUT),OPTIONAL :: ier
750 
751 CHARACTER(len=32) :: cfield
752 INTEGER :: lier
753 
754 CALL csv_record_getfield(this, field=cfield, ier=ier)
755 IF (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
767 ELSE
768  field = rmiss
769 ENDIF
770 
771 END SUBROUTINE csv_record_getfield_real
773 
779 SUBROUTINE csv_record_getfield_double(this, field, ier)
780 TYPE(csv_record),INTENT(INOUT) :: this
781 DOUBLE PRECISION,INTENT(OUT) :: field
782 INTEGER,INTENT(OUT),OPTIONAL :: ier
783 
784 CHARACTER(len=32) :: cfield
785 INTEGER :: lier
786 
787 CALL csv_record_getfield(this, field=cfield, ier=ier)
788 IF (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
800 ELSE
801  field = dmiss
802 ENDIF
803 
804 END SUBROUTINE csv_record_getfield_double
805 
806 
809 FUNCTION csv_record_end(this)
810 TYPE(csv_record), INTENT(IN) :: this
811 LOGICAL :: csv_record_end
812 
813 csv_record_end = this%cursor > SIZE(this%record)
814 
815 END FUNCTION csv_record_end
816 
817 
818 FUNCTION is_space_c(char) RESULT(is_space)
819 CHARACTER(len=1) :: char
820 LOGICAL :: is_space
821 
822 is_space = (ichar(char) == 32 .OR. ichar(char) == 9) ! improve
823 
824 END FUNCTION is_space_c
825 
826 
827 FUNCTION is_space_b(char) RESULT(is_space)
828 INTEGER(kind=int_b) :: char
829 LOGICAL :: is_space
830 
831 is_space = (char == 32 .OR. char == 9) ! improve
832 
833 END FUNCTION is_space_b
834 
835 
836 END MODULE file_utilities
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.
Index method.
Set of functions that return a CHARACTER representation of the input variable.
Gestione degli errori.
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.
Definition: kinds.F90:255

Generated with Doxygen.