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