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