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