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