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