libsim Versione 7.1.11
|
◆ vdb()
Data validity check for confidence.
Definizione alla linea 1063 del file modqc.F90. 1064! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1065! authors:
1066! Davide Cesari <dcesari@arpa.emr.it>
1067! Paolo Patruno <ppatruno@arpa.emr.it>
1068
1069! This program is free software; you can redistribute it and/or
1070! modify it under the terms of the GNU General Public License as
1071! published by the Free Software Foundation; either version 2 of
1072! the License, or (at your option) any later version.
1073
1074! This program is distributed in the hope that it will be useful,
1075! but WITHOUT ANY WARRANTY; without even the implied warranty of
1076! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1077! GNU General Public License for more details.
1078
1079! You should have received a copy of the GNU General Public License
1080! along with this program. If not, see <http://www.gnu.org/licenses/>.
1081#include "config.h"
1082
1085
1237
1238
1239implicit none
1240
1241
1244 integer (kind=int_b):: att
1245 integer (kind=int_b):: gross_error ! special valuer for "*B33192" when gross error check failed
1246 integer (kind=int_b):: invalidated ! special valuer for "*B33196" when manual invalidation happen
1248
1251
1252integer, parameter :: nqcattrvars=4
1253CHARACTER(len=10),parameter :: qcattrvarsbtables(nqcattrvars)=(/"*B33196","*B33192","*B33193","*B33194"/)
1254
1255type :: qcattrvars
1256 TYPE(vol7d_var) :: vars(nqcattrvars)
1257 CHARACTER(len=10) :: btables(nqcattrvars)
1258end type qcattrvars
1259
1262 module procedure init_qcattrvars
1263end interface
1264
1267 module procedure peeledrb, peeleddb, peeledbb, peeledib, peeledcb &
1268 ,peeledri, peeleddi, peeledbi, peeledii, peeledci &
1269 ,peeledrr, peeleddr, peeledbr, peeledir, peeledcr &
1270 ,peeledrd, peeleddd, peeledbd, peeledid, peeledcd &
1271 ,peeledrc, peeleddc, peeledbc, peeledic, peeledcc
1272end interface
1273
1274
1277 module procedure vdi,vdb,vdr,vdd,vdc
1278end interface
1279
1282 module procedure vdgei,vdgeb,vdger,vdged,vdgec
1283end interface
1284
1287 module procedure invalidatedi,invalidatedb,invalidatedr,invalidatedd,invalidatedc
1288end interface
1289
1290private
1291
1293public qcattrvars, nqcattrvars, qcattrvarsbtables
1295
1296contains
1297
1298
1299! peeled routines
1300#undef VOL7D_POLY_SUBTYPE
1301#undef VOL7D_POLY_SUBTYPES
1302#undef VOL7D_POLY_ISC
1303#define VOL7D_POLY_SUBTYPE REAL
1304#define VOL7D_POLY_SUBTYPES r
1305
1306#undef VOL7D_POLY_TYPE
1307#undef VOL7D_POLY_TYPES
1308#undef VOL7D_POLY_ISC
1309#undef VOL7D_POLY_TYPES_SUBTYPES
1310#define VOL7D_POLY_TYPE REAL
1311#define VOL7D_POLY_TYPES r
1312#define VOL7D_POLY_TYPES_SUBTYPES rr
1313#include "modqc_peeled_include.F90"
1314#include "modqc_peel_util_include.F90"
1315#undef VOL7D_POLY_TYPE
1316#undef VOL7D_POLY_TYPES
1317#undef VOL7D_POLY_TYPES_SUBTYPES
1318#define VOL7D_POLY_TYPE DOUBLE PRECISION
1319#define VOL7D_POLY_TYPES d
1320#define VOL7D_POLY_TYPES_SUBTYPES dr
1321#include "modqc_peeled_include.F90"
1322#include "modqc_peel_util_include.F90"
1323#undef VOL7D_POLY_TYPE
1324#undef VOL7D_POLY_TYPES
1325#undef VOL7D_POLY_TYPES_SUBTYPES
1326#define VOL7D_POLY_TYPE INTEGER
1327#define VOL7D_POLY_TYPES i
1328#define VOL7D_POLY_TYPES_SUBTYPES ir
1329#include "modqc_peeled_include.F90"
1330#include "modqc_peel_util_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 br
1337#include "modqc_peeled_include.F90"
1338#include "modqc_peel_util_include.F90"
1339#undef VOL7D_POLY_TYPE
1340#undef VOL7D_POLY_TYPES
1341#undef VOL7D_POLY_TYPES_SUBTYPES
1342#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1343#define VOL7D_POLY_TYPES c
1344#define VOL7D_POLY_ISC = 1
1345#define VOL7D_POLY_TYPES_SUBTYPES cr
1346#include "modqc_peeled_include.F90"
1347#include "modqc_peel_util_include.F90"
1348
1349
1350#undef VOL7D_POLY_SUBTYPE
1351#undef VOL7D_POLY_SUBTYPES
1352#undef VOL7D_POLY_ISC
1353#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1354#define VOL7D_POLY_SUBTYPES d
1355
1356#undef VOL7D_POLY_TYPE
1357#undef VOL7D_POLY_TYPES
1358#undef VOL7D_POLY_TYPES_SUBTYPES
1359#define VOL7D_POLY_TYPE REAL
1360#define VOL7D_POLY_TYPES r
1361#define VOL7D_POLY_TYPES_SUBTYPES rd
1362#include "modqc_peeled_include.F90"
1363#undef VOL7D_POLY_TYPE
1364#undef VOL7D_POLY_TYPES
1365#undef VOL7D_POLY_TYPES_SUBTYPES
1366#define VOL7D_POLY_TYPE DOUBLE PRECISION
1367#define VOL7D_POLY_TYPES d
1368#define VOL7D_POLY_TYPES_SUBTYPES dd
1369#include "modqc_peeled_include.F90"
1370#undef VOL7D_POLY_TYPE
1371#undef VOL7D_POLY_TYPES
1372#undef VOL7D_POLY_TYPES_SUBTYPES
1373#define VOL7D_POLY_TYPE INTEGER
1374#define VOL7D_POLY_TYPES i
1375#define VOL7D_POLY_TYPES_SUBTYPES id
1376#include "modqc_peeled_include.F90"
1377#undef VOL7D_POLY_TYPE
1378#undef VOL7D_POLY_TYPES
1379#undef VOL7D_POLY_TYPES_SUBTYPES
1380#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1381#define VOL7D_POLY_TYPES b
1382#define VOL7D_POLY_TYPES_SUBTYPES bd
1383#include "modqc_peeled_include.F90"
1384#undef VOL7D_POLY_TYPE
1385#undef VOL7D_POLY_TYPES
1386#undef VOL7D_POLY_TYPES_SUBTYPES
1387#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1388#define VOL7D_POLY_TYPES c
1389#define VOL7D_POLY_TYPES_SUBTYPES cd
1390#include "modqc_peeled_include.F90"
1391
1392
1393#undef VOL7D_POLY_SUBTYPE
1394#undef VOL7D_POLY_SUBTYPES
1395#undef VOL7D_POLY_ISC
1396#define VOL7D_POLY_SUBTYPE INTEGER
1397#define VOL7D_POLY_SUBTYPES i
1398
1399#undef VOL7D_POLY_TYPE
1400#undef VOL7D_POLY_TYPES
1401#undef VOL7D_POLY_TYPES_SUBTYPES
1402#define VOL7D_POLY_TYPE REAL
1403#define VOL7D_POLY_TYPES r
1404#define VOL7D_POLY_TYPES_SUBTYPES ri
1405#include "modqc_peeled_include.F90"
1406#undef VOL7D_POLY_TYPE
1407#undef VOL7D_POLY_TYPES
1408#undef VOL7D_POLY_TYPES_SUBTYPES
1409#define VOL7D_POLY_TYPE DOUBLE PRECISION
1410#define VOL7D_POLY_TYPES d
1411#define VOL7D_POLY_TYPES_SUBTYPES di
1412#include "modqc_peeled_include.F90"
1413#undef VOL7D_POLY_TYPE
1414#undef VOL7D_POLY_TYPES
1415#undef VOL7D_POLY_TYPES_SUBTYPES
1416#define VOL7D_POLY_TYPE INTEGER
1417#define VOL7D_POLY_TYPES i
1418#define VOL7D_POLY_TYPES_SUBTYPES ii
1419#include "modqc_peeled_include.F90"
1420#undef VOL7D_POLY_TYPE
1421#undef VOL7D_POLY_TYPES
1422#undef VOL7D_POLY_TYPES_SUBTYPES
1423#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1424#define VOL7D_POLY_TYPES b
1425#define VOL7D_POLY_TYPES_SUBTYPES bi
1426#include "modqc_peeled_include.F90"
1427#undef VOL7D_POLY_TYPE
1428#undef VOL7D_POLY_TYPES
1429#undef VOL7D_POLY_TYPES_SUBTYPES
1430#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1431#define VOL7D_POLY_TYPES c
1432#define VOL7D_POLY_ISC = 1
1433#define VOL7D_POLY_TYPES_SUBTYPES ci
1434#include "modqc_peeled_include.F90"
1435
1436
1437#undef VOL7D_POLY_SUBTYPE
1438#undef VOL7D_POLY_SUBTYPES
1439#undef VOL7D_POLY_ISC
1440#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1441#define VOL7D_POLY_SUBTYPES b
1442
1443#undef VOL7D_POLY_TYPE
1444#undef VOL7D_POLY_TYPES
1445#undef VOL7D_POLY_TYPES_SUBTYPES
1446#define VOL7D_POLY_TYPE REAL
1447#define VOL7D_POLY_TYPES r
1448#define VOL7D_POLY_TYPES_SUBTYPES rb
1449#include "modqc_peeled_include.F90"
1450#undef VOL7D_POLY_TYPE
1451#undef VOL7D_POLY_TYPES
1452#undef VOL7D_POLY_TYPES_SUBTYPES
1453#define VOL7D_POLY_TYPE DOUBLE PRECISION
1454#define VOL7D_POLY_TYPES d
1455#define VOL7D_POLY_TYPES_SUBTYPES db
1456#include "modqc_peeled_include.F90"
1457#undef VOL7D_POLY_TYPE
1458#undef VOL7D_POLY_TYPES
1459#undef VOL7D_POLY_TYPES_SUBTYPES
1460#define VOL7D_POLY_TYPE INTEGER
1461#define VOL7D_POLY_TYPES i
1462#define VOL7D_POLY_TYPES_SUBTYPES ib
1463#include "modqc_peeled_include.F90"
1464#undef VOL7D_POLY_TYPE
1465#undef VOL7D_POLY_TYPES
1466#undef VOL7D_POLY_TYPES_SUBTYPES
1467#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1468#define VOL7D_POLY_TYPES b
1469#define VOL7D_POLY_TYPES_SUBTYPES bb
1470#include "modqc_peeled_include.F90"
1471#undef VOL7D_POLY_TYPE
1472#undef VOL7D_POLY_TYPES
1473#undef VOL7D_POLY_TYPES_SUBTYPES
1474#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1475#define VOL7D_POLY_TYPES c
1476#define VOL7D_POLY_ISC = 1
1477#define VOL7D_POLY_TYPES_SUBTYPES cb
1478#include "modqc_peeled_include.F90"
1479
1480
1481#undef VOL7D_POLY_SUBTYPE
1482#undef VOL7D_POLY_SUBTYPES
1483#undef VOL7D_POLY_ISC
1484#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1485#define VOL7D_POLY_SUBTYPES c
1486
1487#undef VOL7D_POLY_TYPE
1488#undef VOL7D_POLY_TYPES
1489#undef VOL7D_POLY_TYPES_SUBTYPES
1490#define VOL7D_POLY_TYPE REAL
1491#define VOL7D_POLY_TYPES r
1492#define VOL7D_POLY_TYPES_SUBTYPES rc
1493#include "modqc_peeled_include.F90"
1494#undef VOL7D_POLY_TYPE
1495#undef VOL7D_POLY_TYPES
1496#undef VOL7D_POLY_TYPES_SUBTYPES
1497#define VOL7D_POLY_TYPE DOUBLE PRECISION
1498#define VOL7D_POLY_TYPES d
1499#define VOL7D_POLY_TYPES_SUBTYPES dc
1500#include "modqc_peeled_include.F90"
1501#undef VOL7D_POLY_TYPE
1502#undef VOL7D_POLY_TYPES
1503#undef VOL7D_POLY_TYPES_SUBTYPES
1504#define VOL7D_POLY_TYPE INTEGER
1505#define VOL7D_POLY_TYPES i
1506#define VOL7D_POLY_TYPES_SUBTYPES ic
1507#include "modqc_peeled_include.F90"
1508#undef VOL7D_POLY_TYPE
1509#undef VOL7D_POLY_TYPES
1510#undef VOL7D_POLY_TYPES_SUBTYPES
1511#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1512#define VOL7D_POLY_TYPES b
1513#define VOL7D_POLY_TYPES_SUBTYPES bc
1514#include "modqc_peeled_include.F90"
1515#undef VOL7D_POLY_TYPE
1516#undef VOL7D_POLY_TYPES
1517#undef VOL7D_POLY_TYPES_SUBTYPES
1518#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1519#define VOL7D_POLY_TYPES c
1520#define VOL7D_POLY_ISC = 1
1521#define VOL7D_POLY_TYPES_SUBTYPES cc
1522#include "modqc_peeled_include.F90"
1523
1524
1525subroutine init_qcattrvars(this)
1526
1527type(qcattrvars),intent(inout) :: this
1528integer :: i
1529
1530this%btables(:) =qcattrvarsbtables
1531do i =1, nqcattrvars
1533end do
1534
1535end subroutine init_qcattrvars
1536
1537
1538type(qcattrvars) function qcattrvars_new()
1539
1541
1542end function qcattrvars_new
1543
1544
1552SUBROUTINE vol7d_peeling(this, data_id, keep_attr, delete_attr, preserve, purgeana)
1553TYPE(vol7d),INTENT(INOUT) :: this
1554integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1555CHARACTER(len=*),INTENT(in),OPTIONAL :: keep_attr(:)
1556CHARACTER(len=*),INTENT(in),OPTIONAL :: delete_attr(:)
1557logical,intent(in),optional :: preserve
1558logical,intent(in),optional :: purgeana
1559
1560integer :: inddativar,inddatiattrinv,inddatiattrcli,inddatiattrtem,inddatiattrspa,inddativarattr
1561type(qcattrvars) :: attrvars
1562
1563INTEGER(kind=int_b),pointer :: invbb(:,:,:,:,:),clibb(:,:,:,:,:),tembb(:,:,:,:,:),spabb(:,:,:,:,:)
1564INTEGER,pointer :: invbi(:,:,:,:,:),clibi(:,:,:,:,:),tembi(:,:,:,:,:),spabi(:,:,:,:,:)
1565REAL,pointer :: invbr(:,:,:,:,:),clibr(:,:,:,:,:),tembr(:,:,:,:,:),spabr(:,:,:,:,:)
1566DOUBLE PRECISION,pointer :: invbd(:,:,:,:,:),clibd(:,:,:,:,:),tembd(:,:,:,:,:),spabd(:,:,:,:,:)
1567CHARACTER(len=vol7d_cdatalen),pointer :: invbc(:,:,:,:,:),clibc(:,:,:,:,:),tembc(:,:,:,:,:),spabc(:,:,:,:,:)
1568
1569call l4f_log(l4f_info,'starting peeling')
1570
1572
1573! generate code per i vari tipi di dati di v7d
1574! tramite un template e il preprocessore
1575
1576
1577#undef VOL7D_POLY_SUBTYPE
1578#undef VOL7D_POLY_SUBTYPES
1579#define VOL7D_POLY_SUBTYPE REAL
1580#define VOL7D_POLY_SUBTYPES r
1581
1582#undef VOL7D_POLY_TYPE
1583#undef VOL7D_POLY_TYPES
1584#define VOL7D_POLY_TYPE REAL
1585#define VOL7D_POLY_TYPES r
1586#include "modqc_peeling_include.F90"
1587#undef VOL7D_POLY_TYPE
1588#undef VOL7D_POLY_TYPES
1589#define VOL7D_POLY_TYPE DOUBLE PRECISION
1590#define VOL7D_POLY_TYPES d
1591#include "modqc_peeling_include.F90"
1592#undef VOL7D_POLY_TYPE
1593#undef VOL7D_POLY_TYPES
1594#define VOL7D_POLY_TYPE INTEGER
1595#define VOL7D_POLY_TYPES i
1596#include "modqc_peeling_include.F90"
1597#undef VOL7D_POLY_TYPE
1598#undef VOL7D_POLY_TYPES
1599#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1600#define VOL7D_POLY_TYPES b
1601#include "modqc_peeling_include.F90"
1602#undef VOL7D_POLY_TYPE
1603#undef VOL7D_POLY_TYPES
1604#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1605#define VOL7D_POLY_TYPES c
1606#include "modqc_peeling_include.F90"
1607
1608
1609#undef VOL7D_POLY_SUBTYPE
1610#undef VOL7D_POLY_SUBTYPES
1611#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1612#define VOL7D_POLY_SUBTYPES d
1613
1614#undef VOL7D_POLY_TYPE
1615#undef VOL7D_POLY_TYPES
1616#define VOL7D_POLY_TYPE REAL
1617#define VOL7D_POLY_TYPES r
1618#include "modqc_peeling_include.F90"
1619#undef VOL7D_POLY_TYPE
1620#undef VOL7D_POLY_TYPES
1621#define VOL7D_POLY_TYPE DOUBLE PRECISION
1622#define VOL7D_POLY_TYPES d
1623#include "modqc_peeling_include.F90"
1624#undef VOL7D_POLY_TYPE
1625#undef VOL7D_POLY_TYPES
1626#define VOL7D_POLY_TYPE INTEGER
1627#define VOL7D_POLY_TYPES i
1628#include "modqc_peeling_include.F90"
1629#undef VOL7D_POLY_TYPE
1630#undef VOL7D_POLY_TYPES
1631#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1632#define VOL7D_POLY_TYPES b
1633#include "modqc_peeling_include.F90"
1634#undef VOL7D_POLY_TYPE
1635#undef VOL7D_POLY_TYPES
1636#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1637#define VOL7D_POLY_TYPES c
1638#include "modqc_peeling_include.F90"
1639
1640
1641#undef VOL7D_POLY_SUBTYPE
1642#undef VOL7D_POLY_SUBTYPES
1643#define VOL7D_POLY_SUBTYPE INTEGER
1644#define VOL7D_POLY_SUBTYPES i
1645
1646#undef VOL7D_POLY_TYPE
1647#undef VOL7D_POLY_TYPES
1648#define VOL7D_POLY_TYPE REAL
1649#define VOL7D_POLY_TYPES r
1650#include "modqc_peeling_include.F90"
1651#undef VOL7D_POLY_TYPE
1652#undef VOL7D_POLY_TYPES
1653#define VOL7D_POLY_TYPE DOUBLE PRECISION
1654#define VOL7D_POLY_TYPES d
1655#include "modqc_peeling_include.F90"
1656#undef VOL7D_POLY_TYPE
1657#undef VOL7D_POLY_TYPES
1658#define VOL7D_POLY_TYPE INTEGER
1659#define VOL7D_POLY_TYPES i
1660#include "modqc_peeling_include.F90"
1661#undef VOL7D_POLY_TYPE
1662#undef VOL7D_POLY_TYPES
1663#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1664#define VOL7D_POLY_TYPES b
1665#include "modqc_peeling_include.F90"
1666#undef VOL7D_POLY_TYPE
1667#undef VOL7D_POLY_TYPES
1668#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1669#define VOL7D_POLY_TYPES c
1670#include "modqc_peeling_include.F90"
1671
1672
1673#undef VOL7D_POLY_SUBTYPE
1674#undef VOL7D_POLY_SUBTYPES
1675#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1676#define VOL7D_POLY_SUBTYPES b
1677
1678#undef VOL7D_POLY_TYPE
1679#undef VOL7D_POLY_TYPES
1680#define VOL7D_POLY_TYPE REAL
1681#define VOL7D_POLY_TYPES r
1682#include "modqc_peeling_include.F90"
1683#undef VOL7D_POLY_TYPE
1684#undef VOL7D_POLY_TYPES
1685#define VOL7D_POLY_TYPE DOUBLE PRECISION
1686#define VOL7D_POLY_TYPES d
1687#include "modqc_peeling_include.F90"
1688#undef VOL7D_POLY_TYPE
1689#undef VOL7D_POLY_TYPES
1690#define VOL7D_POLY_TYPE INTEGER
1691#define VOL7D_POLY_TYPES i
1692#include "modqc_peeling_include.F90"
1693#undef VOL7D_POLY_TYPE
1694#undef VOL7D_POLY_TYPES
1695#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1696#define VOL7D_POLY_TYPES b
1697#include "modqc_peeling_include.F90"
1698#undef VOL7D_POLY_TYPE
1699#undef VOL7D_POLY_TYPES
1700#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1701#define VOL7D_POLY_TYPES c
1702#include "modqc_peeling_include.F90"
1703
1704
1705
1706#undef VOL7D_POLY_SUBTYPE
1707#undef VOL7D_POLY_SUBTYPES
1708#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1709#define VOL7D_POLY_SUBTYPES c
1710
1711#undef VOL7D_POLY_TYPE
1712#undef VOL7D_POLY_TYPES
1713#define VOL7D_POLY_TYPE REAL
1714#define VOL7D_POLY_TYPES r
1715#include "modqc_peeling_include.F90"
1716#undef VOL7D_POLY_TYPE
1717#undef VOL7D_POLY_TYPES
1718#define VOL7D_POLY_TYPE DOUBLE PRECISION
1719#define VOL7D_POLY_TYPES d
1720#include "modqc_peeling_include.F90"
1721#undef VOL7D_POLY_TYPE
1722#undef VOL7D_POLY_TYPES
1723#define VOL7D_POLY_TYPE INTEGER
1724#define VOL7D_POLY_TYPES i
1725#include "modqc_peeling_include.F90"
1726#undef VOL7D_POLY_TYPE
1727#undef VOL7D_POLY_TYPES
1728#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1729#define VOL7D_POLY_TYPES b
1730#include "modqc_peeling_include.F90"
1731#undef VOL7D_POLY_TYPE
1732#undef VOL7D_POLY_TYPES
1733#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1734#define VOL7D_POLY_TYPES c
1735#include "modqc_peeling_include.F90"
1736
1737
1738
1739IF (.NOT.PRESENT(keep_attr) .AND. .NOT.PRESENT(delete_attr) .and. .not. optio_log(preserve)) THEN ! destroy all attributes
1740 IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
1741 IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
1742 IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
1743 IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
1744 IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
1745
1746 CALL delete(this%datiattr)
1747 CALL delete(this%dativarattr)
1748END IF
1749
1750IF (PRESENT(keep_attr)) THEN ! set to missing non requested attributes and reform
1751
1752 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: keep_attr passed")
1753 CALL keep_var(this%datiattr%r)
1754 CALL keep_var(this%datiattr%d)
1755 CALL keep_var(this%datiattr%i)
1756 CALL keep_var(this%datiattr%b)
1757 CALL keep_var(this%datiattr%c)
1758 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1759
1760ELSE IF (PRESENT(delete_attr)) THEN ! set to missing requested attributes and reform
1761
1762 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: delete_attr passed")
1763 CALL delete_var(this%datiattr%r)
1764 CALL delete_var(this%datiattr%d)
1765 CALL delete_var(this%datiattr%i)
1766 CALL delete_var(this%datiattr%b)
1767 CALL delete_var(this%datiattr%c)
1768 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1769
1770ELSE IF (PRESENT(purgeana)) THEN
1771
1772 CALL qc_reform(this,data_id, purgeana=purgeana)
1773
1774ENDIF
1775
1776
1777CONTAINS
1778
1779
1781subroutine qc_reform(this,data_id,miss, purgeana)
1782TYPE(vol7d),INTENT(INOUT) :: this
1783integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1784logical,intent(in),optional :: miss
1785logical,intent(in),optional :: purgeana
1786
1787integer,pointer :: data_idtmp(:,:,:,:,:)
1788logical,allocatable :: llana(:)
1789integer,allocatable :: anaind(:)
1790integer :: i,j,nana
1791
1792if (optio_log(purgeana)) then
1793 allocate(llana(size(this%ana)))
1794 llana =.false.
1795 do i =1,size(this%ana)
1796 if (associated(this%voldatii)) llana(i)= llana(i) .or. any(c_e(this%voldatii(i,:,:,:,:,:)))
1797 if (associated(this%voldatir)) llana(i)= llana(i) .or. any(c_e(this%voldatir(i,:,:,:,:,:)))
1798 if (associated(this%voldatid)) llana(i)= llana(i) .or. any(c_e(this%voldatid(i,:,:,:,:,:)))
1799 if (associated(this%voldatib)) llana(i)= llana(i) .or. any(c_e(this%voldatib(i,:,:,:,:,:)))
1800 if (associated(this%voldatic)) llana(i)= llana(i) .or. any(c_e(this%voldatic(i,:,:,:,:,:)))
1801
1802#ifdef DEBUG
1803 if (.not. llana(i)) call l4f_log(l4f_debug,"remove station"//t2c(i))
1804#endif
1805
1806 end do
1807
1808 nana=count(llana)
1809
1810
1811 allocate(anaind(nana))
1812
1813 j=0
1814 do i=1,size(this%ana)
1815 if (llana(i)) then
1816 j=j+1
1817 anaind(j)=i
1818 end if
1819 end do
1820
1821
1822 if(present(data_id)) then
1823 allocate(data_idtmp(nana,size(data_id,2),size(data_id,3),size(data_id,4),size(data_id,5)))
1824 data_idtmp=data_id(anaind,:,:,:,:)
1825 if (associated(data_id))deallocate(data_id)
1826 data_id=>data_idtmp
1827 end if
1828
1829 call vol7d_reform(this,miss=miss,lana=llana)
1830
1831 deallocate(llana,anaind)
1832
1833else
1834
1835 call vol7d_reform(this,miss=miss)
1836
1837end if
1838
1839end subroutine qc_reform
1840
1841
1842SUBROUTINE keep_var(var)
1843TYPE(vol7d_var),intent(inout),POINTER :: var(:)
1844
1845INTEGER :: i
1846
1847IF (ASSOCIATED(var)) THEN
1848 if (size(var) == 0) then
1849 var%btable = vol7d_var_miss%btable
1850 else
1851 DO i = 1, SIZE(var)
1852 IF (all(var(i)%btable /= keep_attr(:))) THEN ! n.b. ALL((//)) = .TRUE.
1853 var(i)%btable = vol7d_var_miss%btable
1854 ENDIF
1855 ENDDO
1856 end if
1857ENDIF
1858
1859END SUBROUTINE keep_var
1860
1861SUBROUTINE delete_var(var)
1862TYPE(vol7d_var),intent(inout),POINTER :: var(:)
1863
1864INTEGER :: i
1865
1866IF (ASSOCIATED(var)) THEN
1867 if (size(var) == 0) then
1868 var%btable = vol7d_var_miss%btable
1869 else
1870 DO i = 1, SIZE(var)
1871 IF (any(var(i)%btable == delete_attr(:))) THEN ! n.b. ANY((//)) = .FALSE.
1872 var(i) = vol7d_var_miss
1873 ENDIF
1874 ENDDO
1875 end if
1876ENDIF
1877
1878END SUBROUTINE delete_var
1879
1880END SUBROUTINE vol7d_peeling
1881
1882
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 |