libsim Versione 7.2.1
|
◆ vdgei()
Data gross error check.
Definizione alla linea 886 del file modqc.F90. 887! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
888! authors:
889! Davide Cesari <dcesari@arpa.emr.it>
890! Paolo Patruno <ppatruno@arpa.emr.it>
891
892! This program is free software; you can redistribute it and/or
893! modify it under the terms of the GNU General Public License as
894! published by the Free Software Foundation; either version 2 of
895! the License, or (at your option) any later version.
896
897! This program is distributed in the hope that it will be useful,
898! but WITHOUT ANY WARRANTY; without even the implied warranty of
899! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
900! GNU General Public License for more details.
901
902! You should have received a copy of the GNU General Public License
903! along with this program. If not, see <http://www.gnu.org/licenses/>.
904#include "config.h"
905
908
1060
1061
1062implicit none
1063
1064
1067 integer (kind=int_b):: att
1068 integer (kind=int_b):: gross_error ! special valuer for "*B33192" when gross error check failed
1069 integer (kind=int_b):: invalidated ! special valuer for "*B33196" when manual invalidation happen
1071
1074
1075integer, parameter :: nqcattrvars=4
1076CHARACTER(len=10),parameter :: qcattrvarsbtables(nqcattrvars)=(/"*B33196","*B33192","*B33193","*B33194"/)
1077
1078type :: qcattrvars
1079 TYPE(vol7d_var) :: vars(nqcattrvars)
1080 CHARACTER(len=10) :: btables(nqcattrvars)
1081end type qcattrvars
1082
1085 module procedure init_qcattrvars
1086end interface
1087
1090 module procedure peeledrb, peeleddb, peeledbb, peeledib, peeledcb &
1091 ,peeledri, peeleddi, peeledbi, peeledii, peeledci &
1092 ,peeledrr, peeleddr, peeledbr, peeledir, peeledcr &
1093 ,peeledrd, peeleddd, peeledbd, peeledid, peeledcd &
1094 ,peeledrc, peeleddc, peeledbc, peeledic, peeledcc
1095end interface
1096
1097
1100 module procedure vdi,vdb,vdr,vdd,vdc
1101end interface
1102
1105 module procedure vdgei,vdgeb,vdger,vdged,vdgec
1106end interface
1107
1110 module procedure invalidatedi,invalidatedb,invalidatedr,invalidatedd,invalidatedc
1111end interface
1112
1113private
1114
1116public qcattrvars, nqcattrvars, qcattrvarsbtables
1118
1119contains
1120
1121
1122! peeled routines
1123#undef VOL7D_POLY_SUBTYPE
1124#undef VOL7D_POLY_SUBTYPES
1125#undef VOL7D_POLY_ISC
1126#define VOL7D_POLY_SUBTYPE REAL
1127#define VOL7D_POLY_SUBTYPES r
1128
1129#undef VOL7D_POLY_TYPE
1130#undef VOL7D_POLY_TYPES
1131#undef VOL7D_POLY_ISC
1132#undef VOL7D_POLY_TYPES_SUBTYPES
1133#define VOL7D_POLY_TYPE REAL
1134#define VOL7D_POLY_TYPES r
1135#define VOL7D_POLY_TYPES_SUBTYPES rr
1136#include "modqc_peeled_include.F90"
1137#include "modqc_peel_util_include.F90"
1138#undef VOL7D_POLY_TYPE
1139#undef VOL7D_POLY_TYPES
1140#undef VOL7D_POLY_TYPES_SUBTYPES
1141#define VOL7D_POLY_TYPE DOUBLE PRECISION
1142#define VOL7D_POLY_TYPES d
1143#define VOL7D_POLY_TYPES_SUBTYPES dr
1144#include "modqc_peeled_include.F90"
1145#include "modqc_peel_util_include.F90"
1146#undef VOL7D_POLY_TYPE
1147#undef VOL7D_POLY_TYPES
1148#undef VOL7D_POLY_TYPES_SUBTYPES
1149#define VOL7D_POLY_TYPE INTEGER
1150#define VOL7D_POLY_TYPES i
1151#define VOL7D_POLY_TYPES_SUBTYPES ir
1152#include "modqc_peeled_include.F90"
1153#include "modqc_peel_util_include.F90"
1154#undef VOL7D_POLY_TYPE
1155#undef VOL7D_POLY_TYPES
1156#undef VOL7D_POLY_TYPES_SUBTYPES
1157#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1158#define VOL7D_POLY_TYPES b
1159#define VOL7D_POLY_TYPES_SUBTYPES br
1160#include "modqc_peeled_include.F90"
1161#include "modqc_peel_util_include.F90"
1162#undef VOL7D_POLY_TYPE
1163#undef VOL7D_POLY_TYPES
1164#undef VOL7D_POLY_TYPES_SUBTYPES
1165#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1166#define VOL7D_POLY_TYPES c
1167#define VOL7D_POLY_ISC = 1
1168#define VOL7D_POLY_TYPES_SUBTYPES cr
1169#include "modqc_peeled_include.F90"
1170#include "modqc_peel_util_include.F90"
1171
1172
1173#undef VOL7D_POLY_SUBTYPE
1174#undef VOL7D_POLY_SUBTYPES
1175#undef VOL7D_POLY_ISC
1176#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1177#define VOL7D_POLY_SUBTYPES d
1178
1179#undef VOL7D_POLY_TYPE
1180#undef VOL7D_POLY_TYPES
1181#undef VOL7D_POLY_TYPES_SUBTYPES
1182#define VOL7D_POLY_TYPE REAL
1183#define VOL7D_POLY_TYPES r
1184#define VOL7D_POLY_TYPES_SUBTYPES rd
1185#include "modqc_peeled_include.F90"
1186#undef VOL7D_POLY_TYPE
1187#undef VOL7D_POLY_TYPES
1188#undef VOL7D_POLY_TYPES_SUBTYPES
1189#define VOL7D_POLY_TYPE DOUBLE PRECISION
1190#define VOL7D_POLY_TYPES d
1191#define VOL7D_POLY_TYPES_SUBTYPES dd
1192#include "modqc_peeled_include.F90"
1193#undef VOL7D_POLY_TYPE
1194#undef VOL7D_POLY_TYPES
1195#undef VOL7D_POLY_TYPES_SUBTYPES
1196#define VOL7D_POLY_TYPE INTEGER
1197#define VOL7D_POLY_TYPES i
1198#define VOL7D_POLY_TYPES_SUBTYPES id
1199#include "modqc_peeled_include.F90"
1200#undef VOL7D_POLY_TYPE
1201#undef VOL7D_POLY_TYPES
1202#undef VOL7D_POLY_TYPES_SUBTYPES
1203#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1204#define VOL7D_POLY_TYPES b
1205#define VOL7D_POLY_TYPES_SUBTYPES bd
1206#include "modqc_peeled_include.F90"
1207#undef VOL7D_POLY_TYPE
1208#undef VOL7D_POLY_TYPES
1209#undef VOL7D_POLY_TYPES_SUBTYPES
1210#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1211#define VOL7D_POLY_TYPES c
1212#define VOL7D_POLY_TYPES_SUBTYPES cd
1213#include "modqc_peeled_include.F90"
1214
1215
1216#undef VOL7D_POLY_SUBTYPE
1217#undef VOL7D_POLY_SUBTYPES
1218#undef VOL7D_POLY_ISC
1219#define VOL7D_POLY_SUBTYPE INTEGER
1220#define VOL7D_POLY_SUBTYPES i
1221
1222#undef VOL7D_POLY_TYPE
1223#undef VOL7D_POLY_TYPES
1224#undef VOL7D_POLY_TYPES_SUBTYPES
1225#define VOL7D_POLY_TYPE REAL
1226#define VOL7D_POLY_TYPES r
1227#define VOL7D_POLY_TYPES_SUBTYPES ri
1228#include "modqc_peeled_include.F90"
1229#undef VOL7D_POLY_TYPE
1230#undef VOL7D_POLY_TYPES
1231#undef VOL7D_POLY_TYPES_SUBTYPES
1232#define VOL7D_POLY_TYPE DOUBLE PRECISION
1233#define VOL7D_POLY_TYPES d
1234#define VOL7D_POLY_TYPES_SUBTYPES di
1235#include "modqc_peeled_include.F90"
1236#undef VOL7D_POLY_TYPE
1237#undef VOL7D_POLY_TYPES
1238#undef VOL7D_POLY_TYPES_SUBTYPES
1239#define VOL7D_POLY_TYPE INTEGER
1240#define VOL7D_POLY_TYPES i
1241#define VOL7D_POLY_TYPES_SUBTYPES ii
1242#include "modqc_peeled_include.F90"
1243#undef VOL7D_POLY_TYPE
1244#undef VOL7D_POLY_TYPES
1245#undef VOL7D_POLY_TYPES_SUBTYPES
1246#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1247#define VOL7D_POLY_TYPES b
1248#define VOL7D_POLY_TYPES_SUBTYPES bi
1249#include "modqc_peeled_include.F90"
1250#undef VOL7D_POLY_TYPE
1251#undef VOL7D_POLY_TYPES
1252#undef VOL7D_POLY_TYPES_SUBTYPES
1253#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1254#define VOL7D_POLY_TYPES c
1255#define VOL7D_POLY_ISC = 1
1256#define VOL7D_POLY_TYPES_SUBTYPES ci
1257#include "modqc_peeled_include.F90"
1258
1259
1260#undef VOL7D_POLY_SUBTYPE
1261#undef VOL7D_POLY_SUBTYPES
1262#undef VOL7D_POLY_ISC
1263#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1264#define VOL7D_POLY_SUBTYPES b
1265
1266#undef VOL7D_POLY_TYPE
1267#undef VOL7D_POLY_TYPES
1268#undef VOL7D_POLY_TYPES_SUBTYPES
1269#define VOL7D_POLY_TYPE REAL
1270#define VOL7D_POLY_TYPES r
1271#define VOL7D_POLY_TYPES_SUBTYPES rb
1272#include "modqc_peeled_include.F90"
1273#undef VOL7D_POLY_TYPE
1274#undef VOL7D_POLY_TYPES
1275#undef VOL7D_POLY_TYPES_SUBTYPES
1276#define VOL7D_POLY_TYPE DOUBLE PRECISION
1277#define VOL7D_POLY_TYPES d
1278#define VOL7D_POLY_TYPES_SUBTYPES db
1279#include "modqc_peeled_include.F90"
1280#undef VOL7D_POLY_TYPE
1281#undef VOL7D_POLY_TYPES
1282#undef VOL7D_POLY_TYPES_SUBTYPES
1283#define VOL7D_POLY_TYPE INTEGER
1284#define VOL7D_POLY_TYPES i
1285#define VOL7D_POLY_TYPES_SUBTYPES ib
1286#include "modqc_peeled_include.F90"
1287#undef VOL7D_POLY_TYPE
1288#undef VOL7D_POLY_TYPES
1289#undef VOL7D_POLY_TYPES_SUBTYPES
1290#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1291#define VOL7D_POLY_TYPES b
1292#define VOL7D_POLY_TYPES_SUBTYPES bb
1293#include "modqc_peeled_include.F90"
1294#undef VOL7D_POLY_TYPE
1295#undef VOL7D_POLY_TYPES
1296#undef VOL7D_POLY_TYPES_SUBTYPES
1297#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1298#define VOL7D_POLY_TYPES c
1299#define VOL7D_POLY_ISC = 1
1300#define VOL7D_POLY_TYPES_SUBTYPES cb
1301#include "modqc_peeled_include.F90"
1302
1303
1304#undef VOL7D_POLY_SUBTYPE
1305#undef VOL7D_POLY_SUBTYPES
1306#undef VOL7D_POLY_ISC
1307#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1308#define VOL7D_POLY_SUBTYPES c
1309
1310#undef VOL7D_POLY_TYPE
1311#undef VOL7D_POLY_TYPES
1312#undef VOL7D_POLY_TYPES_SUBTYPES
1313#define VOL7D_POLY_TYPE REAL
1314#define VOL7D_POLY_TYPES r
1315#define VOL7D_POLY_TYPES_SUBTYPES rc
1316#include "modqc_peeled_include.F90"
1317#undef VOL7D_POLY_TYPE
1318#undef VOL7D_POLY_TYPES
1319#undef VOL7D_POLY_TYPES_SUBTYPES
1320#define VOL7D_POLY_TYPE DOUBLE PRECISION
1321#define VOL7D_POLY_TYPES d
1322#define VOL7D_POLY_TYPES_SUBTYPES dc
1323#include "modqc_peeled_include.F90"
1324#undef VOL7D_POLY_TYPE
1325#undef VOL7D_POLY_TYPES
1326#undef VOL7D_POLY_TYPES_SUBTYPES
1327#define VOL7D_POLY_TYPE INTEGER
1328#define VOL7D_POLY_TYPES i
1329#define VOL7D_POLY_TYPES_SUBTYPES ic
1330#include "modqc_peeled_include.F90"
1331#undef VOL7D_POLY_TYPE
1332#undef VOL7D_POLY_TYPES
1333#undef VOL7D_POLY_TYPES_SUBTYPES
1334#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1335#define VOL7D_POLY_TYPES b
1336#define VOL7D_POLY_TYPES_SUBTYPES bc
1337#include "modqc_peeled_include.F90"
1338#undef VOL7D_POLY_TYPE
1339#undef VOL7D_POLY_TYPES
1340#undef VOL7D_POLY_TYPES_SUBTYPES
1341#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1342#define VOL7D_POLY_TYPES c
1343#define VOL7D_POLY_ISC = 1
1344#define VOL7D_POLY_TYPES_SUBTYPES cc
1345#include "modqc_peeled_include.F90"
1346
1347
1348subroutine init_qcattrvars(this)
1349
1350type(qcattrvars),intent(inout) :: this
1351integer :: i
1352
1353this%btables(:) =qcattrvarsbtables
1354do i =1, nqcattrvars
1356end do
1357
1358end subroutine init_qcattrvars
1359
1360
1361type(qcattrvars) function qcattrvars_new()
1362
1364
1365end function qcattrvars_new
1366
1367
1375SUBROUTINE vol7d_peeling(this, data_id, keep_attr, delete_attr, preserve, purgeana)
1376TYPE(vol7d),INTENT(INOUT) :: this
1377integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1378CHARACTER(len=*),INTENT(in),OPTIONAL :: keep_attr(:)
1379CHARACTER(len=*),INTENT(in),OPTIONAL :: delete_attr(:)
1380logical,intent(in),optional :: preserve
1381logical,intent(in),optional :: purgeana
1382
1383integer :: inddativar,inddatiattrinv,inddatiattrcli,inddatiattrtem,inddatiattrspa,inddativarattr
1384type(qcattrvars) :: attrvars
1385
1386INTEGER(kind=int_b),pointer :: invbb(:,:,:,:,:),clibb(:,:,:,:,:),tembb(:,:,:,:,:),spabb(:,:,:,:,:)
1387INTEGER,pointer :: invbi(:,:,:,:,:),clibi(:,:,:,:,:),tembi(:,:,:,:,:),spabi(:,:,:,:,:)
1388REAL,pointer :: invbr(:,:,:,:,:),clibr(:,:,:,:,:),tembr(:,:,:,:,:),spabr(:,:,:,:,:)
1389DOUBLE PRECISION,pointer :: invbd(:,:,:,:,:),clibd(:,:,:,:,:),tembd(:,:,:,:,:),spabd(:,:,:,:,:)
1390CHARACTER(len=vol7d_cdatalen),pointer :: invbc(:,:,:,:,:),clibc(:,:,:,:,:),tembc(:,:,:,:,:),spabc(:,:,:,:,:)
1391
1392call l4f_log(l4f_info,'starting peeling')
1393
1395
1396! generate code per i vari tipi di dati di v7d
1397! tramite un template e il preprocessore
1398
1399
1400#undef VOL7D_POLY_SUBTYPE
1401#undef VOL7D_POLY_SUBTYPES
1402#define VOL7D_POLY_SUBTYPE REAL
1403#define VOL7D_POLY_SUBTYPES r
1404
1405#undef VOL7D_POLY_TYPE
1406#undef VOL7D_POLY_TYPES
1407#define VOL7D_POLY_TYPE REAL
1408#define VOL7D_POLY_TYPES r
1409#include "modqc_peeling_include.F90"
1410#undef VOL7D_POLY_TYPE
1411#undef VOL7D_POLY_TYPES
1412#define VOL7D_POLY_TYPE DOUBLE PRECISION
1413#define VOL7D_POLY_TYPES d
1414#include "modqc_peeling_include.F90"
1415#undef VOL7D_POLY_TYPE
1416#undef VOL7D_POLY_TYPES
1417#define VOL7D_POLY_TYPE INTEGER
1418#define VOL7D_POLY_TYPES i
1419#include "modqc_peeling_include.F90"
1420#undef VOL7D_POLY_TYPE
1421#undef VOL7D_POLY_TYPES
1422#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1423#define VOL7D_POLY_TYPES b
1424#include "modqc_peeling_include.F90"
1425#undef VOL7D_POLY_TYPE
1426#undef VOL7D_POLY_TYPES
1427#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1428#define VOL7D_POLY_TYPES c
1429#include "modqc_peeling_include.F90"
1430
1431
1432#undef VOL7D_POLY_SUBTYPE
1433#undef VOL7D_POLY_SUBTYPES
1434#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1435#define VOL7D_POLY_SUBTYPES d
1436
1437#undef VOL7D_POLY_TYPE
1438#undef VOL7D_POLY_TYPES
1439#define VOL7D_POLY_TYPE REAL
1440#define VOL7D_POLY_TYPES r
1441#include "modqc_peeling_include.F90"
1442#undef VOL7D_POLY_TYPE
1443#undef VOL7D_POLY_TYPES
1444#define VOL7D_POLY_TYPE DOUBLE PRECISION
1445#define VOL7D_POLY_TYPES d
1446#include "modqc_peeling_include.F90"
1447#undef VOL7D_POLY_TYPE
1448#undef VOL7D_POLY_TYPES
1449#define VOL7D_POLY_TYPE INTEGER
1450#define VOL7D_POLY_TYPES i
1451#include "modqc_peeling_include.F90"
1452#undef VOL7D_POLY_TYPE
1453#undef VOL7D_POLY_TYPES
1454#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1455#define VOL7D_POLY_TYPES b
1456#include "modqc_peeling_include.F90"
1457#undef VOL7D_POLY_TYPE
1458#undef VOL7D_POLY_TYPES
1459#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1460#define VOL7D_POLY_TYPES c
1461#include "modqc_peeling_include.F90"
1462
1463
1464#undef VOL7D_POLY_SUBTYPE
1465#undef VOL7D_POLY_SUBTYPES
1466#define VOL7D_POLY_SUBTYPE INTEGER
1467#define VOL7D_POLY_SUBTYPES i
1468
1469#undef VOL7D_POLY_TYPE
1470#undef VOL7D_POLY_TYPES
1471#define VOL7D_POLY_TYPE REAL
1472#define VOL7D_POLY_TYPES r
1473#include "modqc_peeling_include.F90"
1474#undef VOL7D_POLY_TYPE
1475#undef VOL7D_POLY_TYPES
1476#define VOL7D_POLY_TYPE DOUBLE PRECISION
1477#define VOL7D_POLY_TYPES d
1478#include "modqc_peeling_include.F90"
1479#undef VOL7D_POLY_TYPE
1480#undef VOL7D_POLY_TYPES
1481#define VOL7D_POLY_TYPE INTEGER
1482#define VOL7D_POLY_TYPES i
1483#include "modqc_peeling_include.F90"
1484#undef VOL7D_POLY_TYPE
1485#undef VOL7D_POLY_TYPES
1486#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1487#define VOL7D_POLY_TYPES b
1488#include "modqc_peeling_include.F90"
1489#undef VOL7D_POLY_TYPE
1490#undef VOL7D_POLY_TYPES
1491#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1492#define VOL7D_POLY_TYPES c
1493#include "modqc_peeling_include.F90"
1494
1495
1496#undef VOL7D_POLY_SUBTYPE
1497#undef VOL7D_POLY_SUBTYPES
1498#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1499#define VOL7D_POLY_SUBTYPES b
1500
1501#undef VOL7D_POLY_TYPE
1502#undef VOL7D_POLY_TYPES
1503#define VOL7D_POLY_TYPE REAL
1504#define VOL7D_POLY_TYPES r
1505#include "modqc_peeling_include.F90"
1506#undef VOL7D_POLY_TYPE
1507#undef VOL7D_POLY_TYPES
1508#define VOL7D_POLY_TYPE DOUBLE PRECISION
1509#define VOL7D_POLY_TYPES d
1510#include "modqc_peeling_include.F90"
1511#undef VOL7D_POLY_TYPE
1512#undef VOL7D_POLY_TYPES
1513#define VOL7D_POLY_TYPE INTEGER
1514#define VOL7D_POLY_TYPES i
1515#include "modqc_peeling_include.F90"
1516#undef VOL7D_POLY_TYPE
1517#undef VOL7D_POLY_TYPES
1518#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1519#define VOL7D_POLY_TYPES b
1520#include "modqc_peeling_include.F90"
1521#undef VOL7D_POLY_TYPE
1522#undef VOL7D_POLY_TYPES
1523#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1524#define VOL7D_POLY_TYPES c
1525#include "modqc_peeling_include.F90"
1526
1527
1528
1529#undef VOL7D_POLY_SUBTYPE
1530#undef VOL7D_POLY_SUBTYPES
1531#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1532#define VOL7D_POLY_SUBTYPES c
1533
1534#undef VOL7D_POLY_TYPE
1535#undef VOL7D_POLY_TYPES
1536#define VOL7D_POLY_TYPE REAL
1537#define VOL7D_POLY_TYPES r
1538#include "modqc_peeling_include.F90"
1539#undef VOL7D_POLY_TYPE
1540#undef VOL7D_POLY_TYPES
1541#define VOL7D_POLY_TYPE DOUBLE PRECISION
1542#define VOL7D_POLY_TYPES d
1543#include "modqc_peeling_include.F90"
1544#undef VOL7D_POLY_TYPE
1545#undef VOL7D_POLY_TYPES
1546#define VOL7D_POLY_TYPE INTEGER
1547#define VOL7D_POLY_TYPES i
1548#include "modqc_peeling_include.F90"
1549#undef VOL7D_POLY_TYPE
1550#undef VOL7D_POLY_TYPES
1551#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1552#define VOL7D_POLY_TYPES b
1553#include "modqc_peeling_include.F90"
1554#undef VOL7D_POLY_TYPE
1555#undef VOL7D_POLY_TYPES
1556#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1557#define VOL7D_POLY_TYPES c
1558#include "modqc_peeling_include.F90"
1559
1560
1561
1562IF (.NOT.PRESENT(keep_attr) .AND. .NOT.PRESENT(delete_attr) .and. .not. optio_log(preserve)) THEN ! destroy all attributes
1563 IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
1564 IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
1565 IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
1566 IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
1567 IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
1568
1569 CALL delete(this%datiattr)
1570 CALL delete(this%dativarattr)
1571END IF
1572
1573IF (PRESENT(keep_attr)) THEN ! set to missing non requested attributes and reform
1574
1575 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: keep_attr passed")
1576 CALL keep_var(this%datiattr%r)
1577 CALL keep_var(this%datiattr%d)
1578 CALL keep_var(this%datiattr%i)
1579 CALL keep_var(this%datiattr%b)
1580 CALL keep_var(this%datiattr%c)
1581 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1582
1583ELSE IF (PRESENT(delete_attr)) THEN ! set to missing requested attributes and reform
1584
1585 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: delete_attr passed")
1586 CALL delete_var(this%datiattr%r)
1587 CALL delete_var(this%datiattr%d)
1588 CALL delete_var(this%datiattr%i)
1589 CALL delete_var(this%datiattr%b)
1590 CALL delete_var(this%datiattr%c)
1591 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1592
1593ELSE IF (PRESENT(purgeana)) THEN
1594
1595 CALL qc_reform(this,data_id, purgeana=purgeana)
1596
1597ENDIF
1598
1599
1600CONTAINS
1601
1602
1604subroutine qc_reform(this,data_id,miss, purgeana)
1605TYPE(vol7d),INTENT(INOUT) :: this
1606integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1607logical,intent(in),optional :: miss
1608logical,intent(in),optional :: purgeana
1609
1610integer,pointer :: data_idtmp(:,:,:,:,:)
1611logical,allocatable :: llana(:)
1612integer,allocatable :: anaind(:)
1613integer :: i,j,nana
1614
1615if (optio_log(purgeana)) then
1616 allocate(llana(size(this%ana)))
1617 llana =.false.
1618 do i =1,size(this%ana)
1619 if (associated(this%voldatii)) llana(i)= llana(i) .or. any(c_e(this%voldatii(i,:,:,:,:,:)))
1620 if (associated(this%voldatir)) llana(i)= llana(i) .or. any(c_e(this%voldatir(i,:,:,:,:,:)))
1621 if (associated(this%voldatid)) llana(i)= llana(i) .or. any(c_e(this%voldatid(i,:,:,:,:,:)))
1622 if (associated(this%voldatib)) llana(i)= llana(i) .or. any(c_e(this%voldatib(i,:,:,:,:,:)))
1623 if (associated(this%voldatic)) llana(i)= llana(i) .or. any(c_e(this%voldatic(i,:,:,:,:,:)))
1624
1625#ifdef DEBUG
1626 if (.not. llana(i)) call l4f_log(l4f_debug,"remove station"//t2c(i))
1627#endif
1628
1629 end do
1630
1631 nana=count(llana)
1632
1633
1634 allocate(anaind(nana))
1635
1636 j=0
1637 do i=1,size(this%ana)
1638 if (llana(i)) then
1639 j=j+1
1640 anaind(j)=i
1641 end if
1642 end do
1643
1644
1645 if(present(data_id)) then
1646 allocate(data_idtmp(nana,size(data_id,2),size(data_id,3),size(data_id,4),size(data_id,5)))
1647 data_idtmp=data_id(anaind,:,:,:,:)
1648 if (associated(data_id))deallocate(data_id)
1649 data_id=>data_idtmp
1650 end if
1651
1652 call vol7d_reform(this,miss=miss,lana=llana)
1653
1654 deallocate(llana,anaind)
1655
1656else
1657
1658 call vol7d_reform(this,miss=miss)
1659
1660end if
1661
1662end subroutine qc_reform
1663
1664
1665SUBROUTINE keep_var(var)
1666TYPE(vol7d_var),intent(inout),POINTER :: var(:)
1667
1668INTEGER :: i
1669
1670IF (ASSOCIATED(var)) THEN
1671 if (size(var) == 0) then
1672 var%btable = vol7d_var_miss%btable
1673 else
1674 DO i = 1, SIZE(var)
1675 IF (all(var(i)%btable /= keep_attr(:))) THEN ! n.b. ALL((//)) = .TRUE.
1676 var(i)%btable = vol7d_var_miss%btable
1677 ENDIF
1678 ENDDO
1679 end if
1680ENDIF
1681
1682END SUBROUTINE keep_var
1683
1684SUBROUTINE delete_var(var)
1685TYPE(vol7d_var),intent(inout),POINTER :: var(:)
1686
1687INTEGER :: i
1688
1689IF (ASSOCIATED(var)) THEN
1690 if (size(var) == 0) then
1691 var%btable = vol7d_var_miss%btable
1692 else
1693 DO i = 1, SIZE(var)
1694 IF (any(var(i)%btable == delete_attr(:))) THEN ! n.b. ANY((//)) = .FALSE.
1695 var(i) = vol7d_var_miss
1696 ENDIF
1697 ENDDO
1698 end if
1699ENDIF
1700
1701END SUBROUTINE delete_var
1702
1703END SUBROUTINE vol7d_peeling
1704
1705
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 Classe per la gestione di un volume completo di dati osservati. Definition vol7d_class.F90:273 |