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