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