libsim Versione 7.2.6
|
◆ csv_record_end()
Tells whether end of record was reached (
Definizione alla linea 997 del file file_utilities.F90. 998! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
999! authors:
1000! Davide Cesari <dcesari@arpa.emr.it>
1001! Paolo Patruno <ppatruno@arpa.emr.it>
1002
1003! This program is free software; you can redistribute it and/or
1004! modify it under the terms of the GNU General Public License as
1005! published by the Free Software Foundation; either version 2 of
1006! the License, or (at your option) any later version.
1007
1008! This program is distributed in the hope that it will be useful,
1009! but WITHOUT ANY WARRANTY; without even the implied warranty of
1010! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1011! GNU General Public License for more details.
1012
1013! You should have received a copy of the GNU General Public License
1014! along with this program. If not, see <http://www.gnu.org/licenses/>.
1015#include "config.h"
1016!> Utilities for managing files. This module is a collection of generic utilities
1017!! for managing files. A group of utilities is dedicated to locating
1018!! and opening configuration files in standard directories or in
1019!! directories specified by environmental variables. The module also
1020!! contains the class \a csv_record for creating and interpreting the
1021!! records of a csv file.
1022!! \ingroup base
1030IMPLICIT NONE
1031
1032CHARACTER(len=128), PARAMETER :: package_name = package
1033CHARACTER(len=128), PARAMETER :: prefix = prefix
1034
1035INTEGER, PARAMETER, PRIVATE :: nftype = 2
1036CHARACTER(len=10), PARAMETER, PRIVATE :: &
1037 preflist(2,nftype) = reshape((/ &
1038 '/usr/local', '/usr ', &
1039 '/usr/local', ' '/), &
1040 (/2,nftype/))
1041CHARACTER(len=6), PARAMETER, PRIVATE :: &
1042 postfix(nftype) = (/ '/share', '/etc ' /)
1043CHARACTER(len=6), PARAMETER, PRIVATE :: &
1044 filetypename(nftype) = (/ 'DATA ', 'CONFIG' /)
1045INTEGER, PARAMETER :: filetype_data = 1 !< Data file requested
1046INTEGER, PARAMETER :: filetype_config = 2 !< Configuration file requested
1047
1048
1049!> Class for interpreting the records of a csv file.
1050!! See http://en.wikipedia.org/wiki/Comma-separated_values for a
1051!! detailed description of the csv format.
1053 PRIVATE
1054 INTEGER :: cursor, action, nfield !, ntotal
1055 INTEGER(KIND=int_b) :: csep, cquote
1056 INTEGER(KIND=int_b), POINTER :: record(:)
1058
1059INTEGER, PARAMETER, PRIVATE :: csv_basereclen=1024, &
1060 csv_action_read=0, csv_action_write=1
1061
1062!> Constructor for the class \a csv_record. It has to be called for every
1063!! record (line) csv to be created or interpreted.
1065 MODULE PROCEDURE csv_record_init
1066END INTERFACE
1067
1068!> Destructor for the class \a csv_record. It is important to call
1069!! it before reusing the object for the following record, in order to
1070!! avoid memory leaks.
1072 MODULE PROCEDURE csv_record_delete
1073END INTERFACE
1074
1075!> Methods for successively obtaining the fields of a \a csv_record object.
1076!! The generic name \c csv_record_getfield with parameters of the
1077!! desired type should be used instead of the specific names, the
1078!! compiler will select the proper subroutine. If the optiona argument
1079!! \a ier is not provided the subroutines will log warning and error
1080!! messages and possibly stop the program in case of error, otherwise
1081!! nothing is signalled and the returned error code has the following
1082!! meaning:
1083!!
1084!! \li 0 success
1085!! \li 1 field too long for being contained in the string provided (warning, a truncated value is returned anyway)
1086!! \li 2 attempt to read past end of record (error, a missing value is returned)
1087!! \li 3 conversion to the required type impossible (error, a missing value is returned)
1089 MODULE PROCEDURE csv_record_getfield_char, csv_record_getfield_int, &
1090 csv_record_getfield_real, csv_record_getfield_double
1091END INTERFACE
1092
1093!> Methods for successively adding fields to a \a csv_record object.
1094!! The generic name \c csv_record_addfield with parameters of the
1095!! desired type should be used instead of the specific names, the
1096!! compiler will select the proper subroutine. Missing values are
1097!! literally inserted in the output without special treatment.
1099 MODULE PROCEDURE csv_record_addfield_char, csv_record_addfield_int, &
1100 csv_record_addfield_real, csv_record_addfield_double, &
1101 csv_record_addfield_csv_record
1102END INTERFACE
1103
1104!> Methods for successively adding fields to a \a csv_record object.
1105!! The generic name \c csv_record_addfield with parameters of the
1106!! desired type should be used instead of the specific names, the
1107!! compiler will select the proper subroutine. Missing values are
1108!! inserted as empty fields.
1110 MODULE PROCEDURE csv_record_addfield_char_miss, csv_record_addfield_int_miss, &
1111 csv_record_addfield_real_miss, csv_record_addfield_double_miss
1112END INTERFACE
1113
1114
1115PRIVATE csv_record_init, csv_record_delete, csv_record_getfield_char, &
1116 csv_record_getfield_int, csv_record_getfield_real, csv_record_getfield_double, &
1117 csv_record_addfield_char, csv_record_addfield_int, csv_record_addfield_real, &
1118 csv_record_addfield_double, csv_record_addfield_csv_record, &
1119 csv_record_addfield_char_miss, csv_record_addfield_int_miss, &
1120 csv_record_addfield_real_miss, csv_record_addfield_double_miss, &
1121 checkrealloc, add_byte
1122
1123CONTAINS
1124
1125!> Returns the number of a Fortran input/output unit currently unused.
1126!! It returns -1 in case of error. Example of use:
1127!! \code
1128!! USE file_utilities
1129!! ...
1130!! INTEGER :: n
1131!! ...
1132!! n=getunit()
1133!! IF (n /= -1) THEN
1134!! OPEN(n, FILE='ostregheta.txt')
1135!! ...
1136!! \endcode
1137FUNCTION getunit() RESULT(unit)
1138INTEGER :: unit
1139
1140LOGICAL :: op
1141
1142DO unit = 100, 32767
1143 INQUIRE(unit, opened=op)
1144 IF (.NOT. op) RETURN
1145ENDDO
1146
1147CALL l4f_log(l4f_error, 'Too many open files')
1148CALL raise_error()
1149unit = -1
1150
1151END FUNCTION getunit
1152
1153!> Looks for a specific file for the libsim package.
1154!! It searches in different directories in the following order:
1155!! - current working directory
1156!! - directory specified by the environmental variabile \c LIBSIM_DATA for data files or \c LIBSIM_CONFIG for configuration files, if defined
1157!! - directory \c /usr/local/share/libsim for data files or \c /usr/local/etc/libsim for configuration files
1158!! - directory \c /usr/share/libsim for data files or \c /etc/libsim for configuration files.
1159!! filename prefixed by "cwd:" or "share:" force search in current working directory or other package paths respectively
1160!! default is everywhere for data files and package paths only for config files
1161!! It returns the full path to the existing file or an empty string if not found.
1162FUNCTION get_package_filepath(filename, filetype) RESULT(path)
1163CHARACTER(len=*), INTENT(in) :: filename !< name of the file to be searched, it must be a relative path name
1164INTEGER, INTENT(in) :: filetype !< type of file, the constants \a ::filetype_data or \a ::filetype_config have to be used
1165character(len=len(filename)) :: lfilename
1166
1167INTEGER :: j
1168CHARACTER(len=512) :: path
1169LOGICAL :: exist,cwd,share
1170
1171!IF (package_name == ' ') THEN
1172! CALL getarg(0, package_name)
1173!ENDIF
1174
1175IF (filetype < 1 .OR. filetype > nftype) THEN
1176 path = ''
1178 ' not valid')
1179 CALL raise_error()
1180 RETURN
1181ENDIF
1182
1183share = filename(:6) == "share:"
1184cwd = filename(:4) == "cwd:"
1185
1186lfilename=filename
1187if (share) lfilename=filename(7:)
1188if (cwd) lfilename=filename(5:)
1189
1190if ( .not. share .and. .not. cwd .and. filetype == filetype_data) then
1191 share=.true.
1192 cwd=.true.
1193end if
1194
1195if (cwd) then
1196 ! try with current dir
1197 path = lfilename
1198 CALL l4f_log(l4f_debug, 'inquire local file '//trim(path))
1199 INQUIRE(file=path, exist=exist)
1200 IF (exist) THEN
1201 CALL l4f_log(l4f_info, 'local file '//trim(path)//' found')
1202 RETURN
1203 ENDIF
1204end if
1205
1206if (share .or. filetype == filetype_config) then
1207
1208 ! try with environment variable
1209 CALL getenv(trim(uppercase(package_name))//'_'//trim(filetypename(filetype)), path)
1210 IF (path /= ' ') THEN
1211
1212 path(len_trim(path)+1:) = '/'//lfilename
1213 CALL l4f_log(l4f_debug, 'inquire env package file '//trim(path))
1214 INQUIRE(file=path, exist=exist)
1215 IF (exist) THEN
1216 CALL l4f_log(l4f_info, 'package file '//trim(path)//' found')
1217 RETURN
1218 ENDIF
1219 ENDIF
1220
1221 ! try with install prefix
1222 path = trim(prefix)//trim(postfix(filetype)) &
1223 //'/'//trim(package_name)//'/'//lfilename
1224 CALL l4f_log(l4f_debug, 'inquire install package file '//trim(path))
1225 INQUIRE(file=path, exist=exist)
1226 IF (exist) THEN
1227 CALL l4f_log(l4f_info, 'package file '//trim(path)//' found')
1228 RETURN
1229 ENDIF
1230
1231 ! try with default install prefix
1232 DO j = 1, SIZE(preflist,1)
1233 IF (preflist(j,filetype) == ' ') EXIT
1234 path = trim(preflist(j,filetype))//trim(postfix(filetype)) &
1235 //'/'//trim(package_name)//'/'//lfilename
1236 CALL l4f_log(l4f_debug, 'inquire package file '//trim(path))
1237 INQUIRE(file=path, exist=exist)
1238 IF (exist) THEN
1239 CALL l4f_log(l4f_info, 'package file '//trim(path)//' found')
1240 RETURN
1241 ENDIF
1242 ENDDO
1243
1244end if
1245
1246CALL l4f_log(l4f_info, 'package file '//trim(lfilename)//' not found')
1247path = cmiss
1248
1249END FUNCTION get_package_filepath
1250
1251
1252!> Opens a specific file for the libsim package.
1253!! It searches in different directories using get_package_filepath to locate the file.
1254!! It returns the unit number associated to the file found and successfully opened,
1255!! or -1 if the file does not exist or an error occurred while opening it.
1256FUNCTION open_package_file(filename, filetype) RESULT(unit)
1257CHARACTER(len=*), INTENT(in) :: filename !< name of the file to be opened, it must be a relative path name
1258INTEGER, INTENT(in) :: filetype !< type of file, the constants \a ::filetype_data or \a ::filetype_config have to be used
1259INTEGER :: unit, i
1260
1261CHARACTER(len=512) :: path
1262
1263unit = -1
1264path=get_package_filepath(filename, filetype)
1265IF (path == '') RETURN
1266
1267unit = getunit()
1268IF (unit == -1) RETURN
1269
1270OPEN(unit, file=path, status='old', iostat = i)
1271IF (i == 0) THEN
1272 CALL l4f_log(l4f_info, 'package file '//trim(path)//' opened')
1273 RETURN
1274ENDIF
1275
1276CALL l4f_log(l4f_error, 'package file '//trim(filename)//' not found')
1277CALL raise_error()
1278unit = -1
1279
1280END FUNCTION open_package_file
1281
1282
1283!> Initialise a \a csv_record object.
1284!! If the record is provided in input, the object is used for decoding a
1285!! record read from a file (\a csv_record_getfield methods),
1286!! if record is not provided, then the object will be used for
1287!! coding a csv record (\a csv_record_addfield methods), for the
1288!! successive write on file.
1289!! It is possible to specify nonstandard characters for delimiting
1290!! and grouping fields, default comma (,) and double quote (").
1291!! In case of decoding, it is possible to obtain in output the number of fields
1292!! in the record, but this will take extra computing time. As an alternative,
1293!! the ::csv_record_end method can be used when extracting each field.
1294!! Warning: the \a csv_record class does not handle csv records that extend
1295!! on different lines.
1296SUBROUTINE csv_record_init(this, record, csep, cquote, nfield)
1297TYPE(csv_record),INTENT(INOUT) :: this !< object to be initialised
1298CHARACTER(len=*),INTENT(IN), OPTIONAL :: record !< csv record to be interpreted, if not provided, it means we want to code a csv record for output
1299CHARACTER(len=1),INTENT(IN),OPTIONAL :: csep !< field separator character, default \c , (comma)
1300CHARACTER(len=1),INTENT(IN),OPTIONAL :: cquote !< field grouping character, default \c " (double quote); it is usually used when a field contains comma or blanks
1301INTEGER,INTENT(OUT),OPTIONAL :: nfield !< number of fields in the record
1302
1303INTEGER :: l
1304
1305IF (PRESENT(csep)) THEN
1306 this%csep = transfer(csep, this%csep)
1307ELSE
1308 this%csep = transfer(',', this%csep)
1309ENDIF
1310IF (PRESENT(cquote)) THEN
1311 this%cquote = transfer(cquote, this%cquote)
1312ELSE
1313 this%cquote = transfer('"', this%cquote)
1314ENDIF
1315
1316this%cursor = 0
1317this%nfield = 0
1318IF (PRESENT(record)) THEN
1319 l = len_trim(record)
1320 ALLOCATE(this%record(l))
1321 this%record(:) = transfer(record, this%record, l) ! ice in pgf90 with TRIM(record)
1322
1323 IF (PRESENT(nfield)) THEN
1324 nfield = 0
1325 DO WHILE(.NOT.csv_record_end(this)) ! faccio un giro a vuoto sul record
1326 nfield = nfield + 1
1328 ENDDO
1329 this%cursor = 0 ! riazzero il cursore
1330 ENDIF
1331ELSE
1332 ALLOCATE(this%record(csv_basereclen))
1333ENDIF
1334
1335END SUBROUTINE csv_record_init
1336
1337
1338!> Destroy the \a csv_record object, freeing allocated memory.
1339SUBROUTINE csv_record_delete(this)
1340TYPE(csv_record), INTENT(INOUT) :: this !< object to be destroyed
1341
1342DEALLOCATE(this%record)
1343
1344END SUBROUTINE csv_record_delete
1345
1346
1347!> Rewind the pointer in order to allow rescan or rewrite of the same record.
1348SUBROUTINE csv_record_rewind(this)
1349TYPE(csv_record),INTENT(INOUT) :: this !< object to be rewound
1350
1351this%cursor = 0
1352this%nfield = 0
1353
1354END SUBROUTINE csv_record_rewind
1355
1356
1357!> Add a field from a \c CHARACTER variable to the csv record \a this.
1358!! The field will be quoted if necessary.
1359!! \todo Improve the trailing blank quoting.
1360SUBROUTINE csv_record_addfield_char(this, field, force_quote)
1361TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1362CHARACTER(len=*),INTENT(IN) :: field !< field to be added
1363LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1364
1365INTEGER :: i
1366LOGICAL :: lquote
1367
1368lquote = optio_log(force_quote)
1369IF (len(field) == 0) THEN ! Particular case to be handled separately
1370 CALL checkrealloc(this, 1)
1371 IF (this%nfield > 0) THEN
1372 CALL add_byte(this, this%csep) ! add separator if necessary
1373 ELSE
1374 CALL add_byte(this, this%cquote) ! if first record is empty it should be quoted
1375 CALL add_byte(this, this%cquote) ! in case it is the only one
1376 ENDIF
1378 .AND. index(field, transfer(this%cquote,field(1:1))) == 0 &
1379 .AND. .NOT.is_space_c(field(1:1)) &
1380 .AND. .NOT.is_space_c(field(len(field):len(field))) &
1381 .AND. .NOT.lquote) THEN ! quote not required
1382 CALL checkrealloc(this, len(field)+1)
1383 IF (this%nfield > 0) CALL add_byte(this, this%csep) ! add separator if necessary
1384 this%record(this%cursor+1:this%cursor+len(field)) = transfer(field, this%record)
1385 this%cursor = this%cursor + len(field)
1386ELSE ! quote required
1387 CALL checkrealloc(this, 2*len(field)+3) ! worst case """""""""
1388 IF (this%nfield > 0) CALL add_byte(this, this%csep) ! add separator if necessary
1389 CALL add_byte(this, this%cquote) ! add quote
1390 DO i = 1, len(field)
1391 CALL add_char(field(i:i))
1392 ENDDO
1393 CALL add_byte(this, this%cquote) ! add quote
1394ENDIF
1395
1396this%nfield = this%nfield + 1
1397
1398CONTAINS
1399
1400! add a character, doubling it if it's a quote
1401SUBROUTINE add_char(char)
1402CHARACTER(len=1) :: char
1403
1404this%cursor = this%cursor+1
1405this%record(this%cursor) = transfer(char, this%record(1))
1406IF (this%record(this%cursor) == this%cquote) THEN ! double the quote
1407 this%cursor = this%cursor+1
1408 this%record(this%cursor) = this%cquote
1409ENDIF
1410
1411END SUBROUTINE add_char
1412
1413END SUBROUTINE csv_record_addfield_char
1414
1415
1416! Reallocate record if necessary
1417SUBROUTINE checkrealloc(this, enlarge)
1418TYPE(csv_record),INTENT(INOUT) :: this
1419INTEGER, INTENT(in) :: enlarge
1420
1421INTEGER(KIND=int_b), POINTER :: tmpptr(:)
1422
1423IF (this%cursor+enlarge+1 > SIZE(this%record)) THEN
1424 ALLOCATE(tmpptr(SIZE(this%record)+max(csv_basereclen, enlarge)))
1425 tmpptr(1:SIZE(this%record)) = this%record(:)
1426 DEALLOCATE(this%record)
1427 this%record => tmpptr
1428ENDIF
1429
1430END SUBROUTINE checkrealloc
1431
1432
1433! add a byte
1434SUBROUTINE add_byte(this, char)
1435TYPE(csv_record),INTENT(INOUT) :: this
1436INTEGER(kind=int_b) :: char
1437
1438this%cursor = this%cursor+1
1439this%record(this%cursor) = char
1440
1441END SUBROUTINE add_byte
1442
1443
1444!> Add a field from a \c CHARACTER variable to the csv record \a this.
1445!! The field will be quoted if necessary. A missing value is inserted
1446!! as an empty field.
1447SUBROUTINE csv_record_addfield_char_miss(this, field, force_quote)
1448TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1449CHARACTER(len=*),INTENT(IN) :: field !< field to be added
1450LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1451
1453
1454END SUBROUTINE csv_record_addfield_char_miss
1455
1456
1457!> Add a field from an \c INTEGER variable to the csv record \a this.
1458!! The field will be quoted if necessary.
1459SUBROUTINE csv_record_addfield_int(this, field, form, force_quote)
1460TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1461INTEGER,INTENT(IN) :: field !< field to be added
1462CHARACTER(len=*),INTENT(in),OPTIONAL :: form !< optional format
1463LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1464
1465IF (PRESENT(form)) THEN
1467ELSE
1469ENDIF
1470
1471END SUBROUTINE csv_record_addfield_int
1472
1473
1474!> Add a field from an \c INTEGER variable to the csv record \a this.
1475!! The field will be quoted if necessary. A missing value is inserted
1476!! as an empty field.
1477SUBROUTINE csv_record_addfield_int_miss(this, field, force_quote)
1478TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1479INTEGER,INTENT(IN) :: field !< field to be added
1480LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1481
1483
1484END SUBROUTINE csv_record_addfield_int_miss
1485
1486
1487!> Add a field from a \c REAL variable to the csv record \a this.
1488!! The field will be quoted if necessary.
1489SUBROUTINE csv_record_addfield_real(this, field, form, force_quote)
1490TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1491REAL,INTENT(IN) :: field !< field to be added
1492CHARACTER(len=*),INTENT(in),OPTIONAL :: form !< optional format
1493LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1494
1495IF (PRESENT(form)) THEN
1497ELSE
1499ENDIF
1500
1501END SUBROUTINE csv_record_addfield_real
1502
1503
1504!> Add a field from a \c REAL variable to the csv record \a this.
1505!! The field will be quoted if necessary. A missing value is inserted
1506!! as an empty field.
1507SUBROUTINE csv_record_addfield_real_miss(this, field, force_quote)
1508TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1509REAL,INTENT(IN) :: field !< field to be added
1510LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1511
1513
1514END SUBROUTINE csv_record_addfield_real_miss
1515
1516
1517!> Add a field from a \c DOUBLE PRECISION variable to the csv record \a this.
1518!! The field will be quoted if necessary.
1519SUBROUTINE csv_record_addfield_double(this, field, form, force_quote)
1520TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1521DOUBLE PRECISION,INTENT(IN) :: field !< field to be added
1522CHARACTER(len=*),INTENT(in),OPTIONAL :: form !< optional format
1523LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1524
1525IF (PRESENT(form)) THEN
1527ELSE
1529ENDIF
1530
1531END SUBROUTINE csv_record_addfield_double
1532
1533
1534!> Add a field from a \c DOUBLE PRECISION variable to the csv record \a this.
1535!! The field will be quoted if necessary. A missing value is inserted
1536!! as an empty field.
1537SUBROUTINE csv_record_addfield_double_miss(this, field, force_quote)
1538TYPE(csv_record),INTENT(INOUT) :: this !< object where to add field
1539DOUBLE PRECISION,INTENT(IN) :: field !< field to be added
1540LOGICAL, INTENT(in), OPTIONAL :: force_quote !< if provided and \c .TRUE. , the field will be quoted even if not necessary
1541
1543
1544END SUBROUTINE csv_record_addfield_double_miss
1545
1546
1547!> Add a full \a csv_record object to the csv record \a this.
1548!! The object to be added must have been generated through \a
1549!! csv_record_addfield calls (csv encoding mode). Both \a csv_record
1550!! objects \a this and \a record must use the same delimiter and
1551!! quoting characters, otherwise the operation will silently fail.
1552SUBROUTINE csv_record_addfield_csv_record(this, record)
1553TYPE(csv_record),INTENT(INOUT) :: this !< object where to add record
1554TYPE(csv_record),INTENT(IN) :: record !< record to be added
1555
1556IF (this%csep /= record%csep .OR. this%cquote /= record%cquote) RETURN ! error
1557CALL checkrealloc(this, record%cursor)
1558IF (this%nfield > 0) CALL add_byte(this, this%csep)
1559
1560this%record(this%cursor+1:this%cursor+record%cursor) = &
1561 record%record(1:record%cursor)
1562this%cursor = this%cursor + record%cursor
1563this%nfield = this%nfield + record%nfield
1564
1565END SUBROUTINE csv_record_addfield_csv_record
1566
1567
1568!> Return current csv-coded record as a \a CHARACTER variable, ready to be written
1569!! to a file. It is not necessary to trim the result for trailing blanks.
1570FUNCTION csv_record_getrecord(this, nfield)
1571TYPE(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
1572INTEGER, INTENT(out), OPTIONAL :: nfield !< number of fields contained in the record
1573
1574CHARACTER(len=this%cursor) :: csv_record_getrecord
1575
1576csv_record_getrecord = transfer(this%record(1:this%cursor), csv_record_getrecord)
1577IF (present(nfield)) nfield = this%nfield
1578
1579END FUNCTION csv_record_getrecord
1580
1581
1582!> Returns next field from the record \a this as a \c CHARACTER variable.
1583!! The field pointer is advanced to the next field.
1584!! If all the fields have already been interpreted it returns an empty string
1585!! anyway; in order to verify the end-of-record condition the \a ier parameter
1586!! must be used.
1587SUBROUTINE csv_record_getfield_char(this, field, flen, ier)
1588TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
1589CHARACTER(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;
1590!< the variable is space-terminated anyway, so the \a flen parameter has to be used in order to evaluate possible significant trailing spaces
1591INTEGER,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
1592INTEGER,INTENT(OUT),OPTIONAL :: ier!< error code, 0 = OK, 1 = \a field too short, 2 = end of record
1593
1594LOGICAL :: inquote, inpre, inpost, firstquote
1595INTEGER :: i, ocursor, ofcursor
1596
1597! check end of record
1598IF (csv_record_end(this)) THEN
1599 IF (PRESENT(field)) field = cmiss
1600 IF (PRESENT(ier))THEN
1601 ier = 2
1602 ELSE
1603 CALL l4f_log(l4f_error, &
1604 'in csv_record_getfield, attempt to read past end of record')
1605 CALL raise_error()
1606 ENDIF
1607 RETURN
1608ENDIF
1609! start decoding
1610IF (PRESENT(field)) field = ''
1611IF (PRESENT(ier)) ier = 0
1612ocursor = 0
1613ofcursor = 0
1614inquote = .false.
1615inpre = .true.
1616inpost = .false.
1617firstquote = .false.
1618
1619DO i = this%cursor+1, SIZE(this%record)
1620 IF (inpre) THEN ! sono nel preludio, butto via gli spazi
1621 IF (is_space_b(this%record(i))) THEN
1622 cycle
1623 ELSE
1624 inpre = .false.
1625 ENDIF
1626 ENDIF
1627
1628 IF (.NOT.inquote) THEN ! fuori da " "
1629 IF (this%record(i) == this%cquote) THEN ! ": inizia " "
1630 inquote = .true.
1631 cycle
1632 ELSE IF (this%record(i) == this%csep) THEN ! ,: fine campo
1633 EXIT
1634 ELSE ! carattere normale, elimina "trailing blanks"
1635 CALL add_char(this%record(i), .true., field)
1636 cycle
1637 ENDIF
1638 ELSE ! dentro " "
1639 IF (.NOT.firstquote) THEN ! il precedente non e` "
1640 IF (this%record(i) == this%cquote) THEN ! ": fine " " oppure ""
1641 firstquote = .true.
1642 cycle
1643 ELSE ! carattere normale
1644 CALL add_char(this%record(i), .false., field)
1645 cycle
1646 ENDIF
1647 ELSE ! il precedente e` "
1648 firstquote = .false.
1649 IF (this%record(i) == this%cquote) THEN ! ": sequenza ""
1650 CALL add_char(this%cquote, .false., field)
1651 cycle
1652 ELSE ! carattere normale: e` terminata " "
1653 inquote = .false.
1654 IF (this%record(i) == this%csep) THEN ! , fine campo
1655 EXIT
1656 ELSE ! carattere normale, elimina "trailing blanks"
1657 CALL add_char(this%record(i), .true., field)
1658 cycle
1659 ENDIF
1660 ENDIF
1661 ENDIF
1662 ENDIF
1663ENDDO
1664
1665this%cursor = min(i, SIZE(this%record) + 1)
1666IF (PRESENT(flen)) flen = ofcursor ! restituisco la lunghezza
1667IF (PRESENT(field)) THEN ! controllo overflow di field
1668 IF (ofcursor > len(field)) THEN
1669 IF (PRESENT(ier)) THEN
1670 ier = 1
1671 ELSE
1672 CALL l4f_log(l4f_warn, &
1673 'in csv_record_getfield, CHARACTER variable too short for field: '// &
1675 ENDIF
1676 ENDIF
1677ENDIF
1678
1679CONTAINS
1680
1681SUBROUTINE add_char(char, check_space, field)
1682INTEGER(kind=int_b) :: char
1683LOGICAL,INTENT(IN) :: check_space
1684CHARACTER(len=*),INTENT(OUT),OPTIONAL :: field
1685
1686CHARACTER(len=1) :: dummy ! this prevents a memory leak in TRANSFER()???
1687
1688ocursor = ocursor + 1
1689 IF (PRESENT(field)) THEN
1690 IF (ocursor <= len(field)) THEN
1691 field(ocursor:ocursor) = transfer(char, dummy)
1692 ENDIF
1693ENDIF
1694IF (check_space) THEN
1695 IF (.NOT.is_space_b(char)) ofcursor = ocursor
1696ELSE
1697 ofcursor = ocursor
1698ENDIF
1699
1700END SUBROUTINE add_char
1701
1702END SUBROUTINE csv_record_getfield_char
1703
1704
1705!> Returns next field from the record \a this as an \c INTEGER variable.
1706!! The field pointer is advanced to the next field.
1707!! If all the fields have already been interpreted or the field cannot be
1708!! interpreted as an integer, or if it is longer than 32 characters,
1709!! it returns a missing value.
1710SUBROUTINE csv_record_getfield_int(this, field, ier)
1711TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
1712INTEGER,INTENT(OUT) :: field !< value of the field, = \a imiss if conversion fails
1713INTEGER,INTENT(OUT),OPTIONAL :: ier !< error code, 0 = OK, 2 = end of record, 3 = cannot convert to integer
1714
1715CHARACTER(len=32) :: cfield
1716INTEGER :: lier
1717
1720 READ(cfield, '(I32)', iostat=lier) field
1721 IF (lier /= 0) THEN
1722 field = imiss
1723 IF (.NOT.PRESENT(ier)) THEN
1724 CALL l4f_log(l4f_error, &
1725 'in csv_record_getfield, invalid integer field: '//trim(cfield))
1726 CALL raise_error()
1727 ELSE
1728 ier = 3 ! conversion error
1729 ENDIF
1730 ENDIF
1731ELSE
1732 field = imiss
1733ENDIF
1734
1735END SUBROUTINE csv_record_getfield_int
1736
1737
1738!> Returns next field from the record \a this as a \c REAL variable.
1739!! The field pointer is advanced to the next field.
1740!! If all the fields have already been interpreted or the field cannot be
1741!! interpreted as a real, or if it is longer than 32 characters,
1742!! it returns a missing value.
1743SUBROUTINE csv_record_getfield_real(this, field, ier)
1744TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
1745REAL,INTENT(OUT) :: field !< value of the field, = \a rmiss if conversion fails
1746INTEGER,INTENT(OUT),OPTIONAL :: ier !< error code, 0 = OK, 2 = end of record, 3 = cannot convert to real
1747
1748CHARACTER(len=32) :: cfield
1749INTEGER :: lier
1750
1753 READ(cfield, '(F32.0)', iostat=lier) field
1754 IF (lier /= 0) THEN
1755 field = rmiss
1756 IF (.NOT.PRESENT(ier)) THEN
1757 CALL l4f_log(l4f_error, &
1758 'in csv_record_getfield, invalid real field: '//trim(cfield))
1759 CALL raise_error()
1760 ELSE
1761 ier = 3 ! conversion error
1762 ENDIF
1763 ENDIF
1764ELSE
1765 field = rmiss
1766ENDIF
1767
1768END SUBROUTINE csv_record_getfield_real
1769
1770
1771!> Returns next field from the record \a this as a \c DOUBLE PRECISION variable.
1772!! The field pointer is advanced to the next field.
1773!! If all the fields have already been interpreted or the field cannot be
1774!! interpreted as double, or if it is longer than 32 characters,
1775!! it returns a missing value.
1776SUBROUTINE csv_record_getfield_double(this, field, ier)
1777TYPE(csv_record),INTENT(INOUT) :: this !< object to be decoded
1778DOUBLE PRECISION,INTENT(OUT) :: field !< value of the field, = \a dmiss if conversion fails
1779INTEGER,INTENT(OUT),OPTIONAL :: ier !< error code, 0 = OK, 2 = end of record, 3 = cannot convert to double
1780
1781CHARACTER(len=32) :: cfield
1782INTEGER :: lier
1783
1786 READ(cfield, '(F32.0)', iostat=lier) field
1787 IF (lier /= 0) THEN
1788 field = dmiss
1789 IF (.NOT.PRESENT(ier)) THEN
1790 CALL l4f_log(l4f_error, &
1791 'in csv_record_getfield, invalid double precision field: '//trim(cfield))
1792 CALL raise_error()
1793 ELSE
1794 ier = 3 ! conversion error
1795 ENDIF
1796 ENDIF
1797ELSE
1798 field = dmiss
1799ENDIF
1800
1801END SUBROUTINE csv_record_getfield_double
1802
1803
1804!> Tells whether end of record was reached (\c .TRUE.)
1805!! or there are still some fields left (\c .FALSE.).
1806FUNCTION csv_record_end(this)
1807TYPE(csv_record), INTENT(IN) :: this !< object to be checked for end of record
1808LOGICAL :: csv_record_end
1809
1810csv_record_end = this%cursor > SIZE(this%record)
1811
1812END FUNCTION csv_record_end
1813
1814
1815FUNCTION is_space_c(char) RESULT(is_space)
1816CHARACTER(len=1) :: char
1817LOGICAL :: is_space
1818
1819is_space = (ichar(char) == 32 .OR. ichar(char) == 9) ! improve
1820
1821END FUNCTION is_space_c
1822
1823
1824FUNCTION is_space_b(char) RESULT(is_space)
1825INTEGER(kind=int_b) :: char
1826LOGICAL :: is_space
1827
1828is_space = (char == 32 .OR. char == 9) ! improve
1829
1830END FUNCTION is_space_b
1831
1832
Set of functions that return a trimmed CHARACTER representation of the input variable. Definition char_utilities.F90:278 Set of functions that return a CHARACTER representation of the input variable. Definition char_utilities.F90:253 Methods for successively adding fields to a csv_record object. Definition file_utilities.F90:300 Methods for successively adding fields to a csv_record object. Definition file_utilities.F90:289 Methods for successively obtaining the fields of a csv_record object. Definition file_utilities.F90:279 Function to check whether a value is missing or not. Definition missing_values.f90:72 Definition of constants to be used for declaring variables of a desired type. Definition kinds.F90:245 Definitions of constants and functions for working with missing values. Definition missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition optional_values.f90:28 Class for interpreting the records of a csv file. Definition file_utilities.F90:243 |