libsim Versione 7.2.1
|
◆ invalidatedc()
Data invalidated check.
Definizione alla linea 1264 del file modqc.F90. 1265! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1266! authors:
1267! Davide Cesari <dcesari@arpa.emr.it>
1268! Paolo Patruno <ppatruno@arpa.emr.it>
1269
1270! This program is free software; you can redistribute it and/or
1271! modify it under the terms of the GNU General Public License as
1272! published by the Free Software Foundation; either version 2 of
1273! the License, or (at your option) any later version.
1274
1275! This program is distributed in the hope that it will be useful,
1276! but WITHOUT ANY WARRANTY; without even the implied warranty of
1277! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1278! GNU General Public License for more details.
1279
1280! You should have received a copy of the GNU General Public License
1281! along with this program. If not, see <http://www.gnu.org/licenses/>.
1282#include "config.h"
1283
1286
1438
1439
1440implicit none
1441
1442
1445 integer (kind=int_b):: att
1446 integer (kind=int_b):: gross_error ! special valuer for "*B33192" when gross error check failed
1447 integer (kind=int_b):: invalidated ! special valuer for "*B33196" when manual invalidation happen
1449
1452
1453integer, parameter :: nqcattrvars=4
1454CHARACTER(len=10),parameter :: qcattrvarsbtables(nqcattrvars)=(/"*B33196","*B33192","*B33193","*B33194"/)
1455
1456type :: qcattrvars
1457 TYPE(vol7d_var) :: vars(nqcattrvars)
1458 CHARACTER(len=10) :: btables(nqcattrvars)
1459end type qcattrvars
1460
1463 module procedure init_qcattrvars
1464end interface
1465
1468 module procedure peeledrb, peeleddb, peeledbb, peeledib, peeledcb &
1469 ,peeledri, peeleddi, peeledbi, peeledii, peeledci &
1470 ,peeledrr, peeleddr, peeledbr, peeledir, peeledcr &
1471 ,peeledrd, peeleddd, peeledbd, peeledid, peeledcd &
1472 ,peeledrc, peeleddc, peeledbc, peeledic, peeledcc
1473end interface
1474
1475
1478 module procedure vdi,vdb,vdr,vdd,vdc
1479end interface
1480
1483 module procedure vdgei,vdgeb,vdger,vdged,vdgec
1484end interface
1485
1488 module procedure invalidatedi,invalidatedb,invalidatedr,invalidatedd,invalidatedc
1489end interface
1490
1491private
1492
1494public qcattrvars, nqcattrvars, qcattrvarsbtables
1496
1497contains
1498
1499
1500! peeled routines
1501#undef VOL7D_POLY_SUBTYPE
1502#undef VOL7D_POLY_SUBTYPES
1503#undef VOL7D_POLY_ISC
1504#define VOL7D_POLY_SUBTYPE REAL
1505#define VOL7D_POLY_SUBTYPES r
1506
1507#undef VOL7D_POLY_TYPE
1508#undef VOL7D_POLY_TYPES
1509#undef VOL7D_POLY_ISC
1510#undef VOL7D_POLY_TYPES_SUBTYPES
1511#define VOL7D_POLY_TYPE REAL
1512#define VOL7D_POLY_TYPES r
1513#define VOL7D_POLY_TYPES_SUBTYPES rr
1514#include "modqc_peeled_include.F90"
1515#include "modqc_peel_util_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 dr
1522#include "modqc_peeled_include.F90"
1523#include "modqc_peel_util_include.F90"
1524#undef VOL7D_POLY_TYPE
1525#undef VOL7D_POLY_TYPES
1526#undef VOL7D_POLY_TYPES_SUBTYPES
1527#define VOL7D_POLY_TYPE INTEGER
1528#define VOL7D_POLY_TYPES i
1529#define VOL7D_POLY_TYPES_SUBTYPES ir
1530#include "modqc_peeled_include.F90"
1531#include "modqc_peel_util_include.F90"
1532#undef VOL7D_POLY_TYPE
1533#undef VOL7D_POLY_TYPES
1534#undef VOL7D_POLY_TYPES_SUBTYPES
1535#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1536#define VOL7D_POLY_TYPES b
1537#define VOL7D_POLY_TYPES_SUBTYPES br
1538#include "modqc_peeled_include.F90"
1539#include "modqc_peel_util_include.F90"
1540#undef VOL7D_POLY_TYPE
1541#undef VOL7D_POLY_TYPES
1542#undef VOL7D_POLY_TYPES_SUBTYPES
1543#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1544#define VOL7D_POLY_TYPES c
1545#define VOL7D_POLY_ISC = 1
1546#define VOL7D_POLY_TYPES_SUBTYPES cr
1547#include "modqc_peeled_include.F90"
1548#include "modqc_peel_util_include.F90"
1549
1550
1551#undef VOL7D_POLY_SUBTYPE
1552#undef VOL7D_POLY_SUBTYPES
1553#undef VOL7D_POLY_ISC
1554#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1555#define VOL7D_POLY_SUBTYPES d
1556
1557#undef VOL7D_POLY_TYPE
1558#undef VOL7D_POLY_TYPES
1559#undef VOL7D_POLY_TYPES_SUBTYPES
1560#define VOL7D_POLY_TYPE REAL
1561#define VOL7D_POLY_TYPES r
1562#define VOL7D_POLY_TYPES_SUBTYPES rd
1563#include "modqc_peeled_include.F90"
1564#undef VOL7D_POLY_TYPE
1565#undef VOL7D_POLY_TYPES
1566#undef VOL7D_POLY_TYPES_SUBTYPES
1567#define VOL7D_POLY_TYPE DOUBLE PRECISION
1568#define VOL7D_POLY_TYPES d
1569#define VOL7D_POLY_TYPES_SUBTYPES dd
1570#include "modqc_peeled_include.F90"
1571#undef VOL7D_POLY_TYPE
1572#undef VOL7D_POLY_TYPES
1573#undef VOL7D_POLY_TYPES_SUBTYPES
1574#define VOL7D_POLY_TYPE INTEGER
1575#define VOL7D_POLY_TYPES i
1576#define VOL7D_POLY_TYPES_SUBTYPES id
1577#include "modqc_peeled_include.F90"
1578#undef VOL7D_POLY_TYPE
1579#undef VOL7D_POLY_TYPES
1580#undef VOL7D_POLY_TYPES_SUBTYPES
1581#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1582#define VOL7D_POLY_TYPES b
1583#define VOL7D_POLY_TYPES_SUBTYPES bd
1584#include "modqc_peeled_include.F90"
1585#undef VOL7D_POLY_TYPE
1586#undef VOL7D_POLY_TYPES
1587#undef VOL7D_POLY_TYPES_SUBTYPES
1588#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1589#define VOL7D_POLY_TYPES c
1590#define VOL7D_POLY_TYPES_SUBTYPES cd
1591#include "modqc_peeled_include.F90"
1592
1593
1594#undef VOL7D_POLY_SUBTYPE
1595#undef VOL7D_POLY_SUBTYPES
1596#undef VOL7D_POLY_ISC
1597#define VOL7D_POLY_SUBTYPE INTEGER
1598#define VOL7D_POLY_SUBTYPES i
1599
1600#undef VOL7D_POLY_TYPE
1601#undef VOL7D_POLY_TYPES
1602#undef VOL7D_POLY_TYPES_SUBTYPES
1603#define VOL7D_POLY_TYPE REAL
1604#define VOL7D_POLY_TYPES r
1605#define VOL7D_POLY_TYPES_SUBTYPES ri
1606#include "modqc_peeled_include.F90"
1607#undef VOL7D_POLY_TYPE
1608#undef VOL7D_POLY_TYPES
1609#undef VOL7D_POLY_TYPES_SUBTYPES
1610#define VOL7D_POLY_TYPE DOUBLE PRECISION
1611#define VOL7D_POLY_TYPES d
1612#define VOL7D_POLY_TYPES_SUBTYPES di
1613#include "modqc_peeled_include.F90"
1614#undef VOL7D_POLY_TYPE
1615#undef VOL7D_POLY_TYPES
1616#undef VOL7D_POLY_TYPES_SUBTYPES
1617#define VOL7D_POLY_TYPE INTEGER
1618#define VOL7D_POLY_TYPES i
1619#define VOL7D_POLY_TYPES_SUBTYPES ii
1620#include "modqc_peeled_include.F90"
1621#undef VOL7D_POLY_TYPE
1622#undef VOL7D_POLY_TYPES
1623#undef VOL7D_POLY_TYPES_SUBTYPES
1624#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1625#define VOL7D_POLY_TYPES b
1626#define VOL7D_POLY_TYPES_SUBTYPES bi
1627#include "modqc_peeled_include.F90"
1628#undef VOL7D_POLY_TYPE
1629#undef VOL7D_POLY_TYPES
1630#undef VOL7D_POLY_TYPES_SUBTYPES
1631#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1632#define VOL7D_POLY_TYPES c
1633#define VOL7D_POLY_ISC = 1
1634#define VOL7D_POLY_TYPES_SUBTYPES ci
1635#include "modqc_peeled_include.F90"
1636
1637
1638#undef VOL7D_POLY_SUBTYPE
1639#undef VOL7D_POLY_SUBTYPES
1640#undef VOL7D_POLY_ISC
1641#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1642#define VOL7D_POLY_SUBTYPES b
1643
1644#undef VOL7D_POLY_TYPE
1645#undef VOL7D_POLY_TYPES
1646#undef VOL7D_POLY_TYPES_SUBTYPES
1647#define VOL7D_POLY_TYPE REAL
1648#define VOL7D_POLY_TYPES r
1649#define VOL7D_POLY_TYPES_SUBTYPES rb
1650#include "modqc_peeled_include.F90"
1651#undef VOL7D_POLY_TYPE
1652#undef VOL7D_POLY_TYPES
1653#undef VOL7D_POLY_TYPES_SUBTYPES
1654#define VOL7D_POLY_TYPE DOUBLE PRECISION
1655#define VOL7D_POLY_TYPES d
1656#define VOL7D_POLY_TYPES_SUBTYPES db
1657#include "modqc_peeled_include.F90"
1658#undef VOL7D_POLY_TYPE
1659#undef VOL7D_POLY_TYPES
1660#undef VOL7D_POLY_TYPES_SUBTYPES
1661#define VOL7D_POLY_TYPE INTEGER
1662#define VOL7D_POLY_TYPES i
1663#define VOL7D_POLY_TYPES_SUBTYPES ib
1664#include "modqc_peeled_include.F90"
1665#undef VOL7D_POLY_TYPE
1666#undef VOL7D_POLY_TYPES
1667#undef VOL7D_POLY_TYPES_SUBTYPES
1668#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1669#define VOL7D_POLY_TYPES b
1670#define VOL7D_POLY_TYPES_SUBTYPES bb
1671#include "modqc_peeled_include.F90"
1672#undef VOL7D_POLY_TYPE
1673#undef VOL7D_POLY_TYPES
1674#undef VOL7D_POLY_TYPES_SUBTYPES
1675#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1676#define VOL7D_POLY_TYPES c
1677#define VOL7D_POLY_ISC = 1
1678#define VOL7D_POLY_TYPES_SUBTYPES cb
1679#include "modqc_peeled_include.F90"
1680
1681
1682#undef VOL7D_POLY_SUBTYPE
1683#undef VOL7D_POLY_SUBTYPES
1684#undef VOL7D_POLY_ISC
1685#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1686#define VOL7D_POLY_SUBTYPES c
1687
1688#undef VOL7D_POLY_TYPE
1689#undef VOL7D_POLY_TYPES
1690#undef VOL7D_POLY_TYPES_SUBTYPES
1691#define VOL7D_POLY_TYPE REAL
1692#define VOL7D_POLY_TYPES r
1693#define VOL7D_POLY_TYPES_SUBTYPES rc
1694#include "modqc_peeled_include.F90"
1695#undef VOL7D_POLY_TYPE
1696#undef VOL7D_POLY_TYPES
1697#undef VOL7D_POLY_TYPES_SUBTYPES
1698#define VOL7D_POLY_TYPE DOUBLE PRECISION
1699#define VOL7D_POLY_TYPES d
1700#define VOL7D_POLY_TYPES_SUBTYPES dc
1701#include "modqc_peeled_include.F90"
1702#undef VOL7D_POLY_TYPE
1703#undef VOL7D_POLY_TYPES
1704#undef VOL7D_POLY_TYPES_SUBTYPES
1705#define VOL7D_POLY_TYPE INTEGER
1706#define VOL7D_POLY_TYPES i
1707#define VOL7D_POLY_TYPES_SUBTYPES ic
1708#include "modqc_peeled_include.F90"
1709#undef VOL7D_POLY_TYPE
1710#undef VOL7D_POLY_TYPES
1711#undef VOL7D_POLY_TYPES_SUBTYPES
1712#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1713#define VOL7D_POLY_TYPES b
1714#define VOL7D_POLY_TYPES_SUBTYPES bc
1715#include "modqc_peeled_include.F90"
1716#undef VOL7D_POLY_TYPE
1717#undef VOL7D_POLY_TYPES
1718#undef VOL7D_POLY_TYPES_SUBTYPES
1719#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1720#define VOL7D_POLY_TYPES c
1721#define VOL7D_POLY_ISC = 1
1722#define VOL7D_POLY_TYPES_SUBTYPES cc
1723#include "modqc_peeled_include.F90"
1724
1725
1726subroutine init_qcattrvars(this)
1727
1728type(qcattrvars),intent(inout) :: this
1729integer :: i
1730
1731this%btables(:) =qcattrvarsbtables
1732do i =1, nqcattrvars
1734end do
1735
1736end subroutine init_qcattrvars
1737
1738
1739type(qcattrvars) function qcattrvars_new()
1740
1742
1743end function qcattrvars_new
1744
1745
1753SUBROUTINE vol7d_peeling(this, data_id, keep_attr, delete_attr, preserve, purgeana)
1754TYPE(vol7d),INTENT(INOUT) :: this
1755integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1756CHARACTER(len=*),INTENT(in),OPTIONAL :: keep_attr(:)
1757CHARACTER(len=*),INTENT(in),OPTIONAL :: delete_attr(:)
1758logical,intent(in),optional :: preserve
1759logical,intent(in),optional :: purgeana
1760
1761integer :: inddativar,inddatiattrinv,inddatiattrcli,inddatiattrtem,inddatiattrspa,inddativarattr
1762type(qcattrvars) :: attrvars
1763
1764INTEGER(kind=int_b),pointer :: invbb(:,:,:,:,:),clibb(:,:,:,:,:),tembb(:,:,:,:,:),spabb(:,:,:,:,:)
1765INTEGER,pointer :: invbi(:,:,:,:,:),clibi(:,:,:,:,:),tembi(:,:,:,:,:),spabi(:,:,:,:,:)
1766REAL,pointer :: invbr(:,:,:,:,:),clibr(:,:,:,:,:),tembr(:,:,:,:,:),spabr(:,:,:,:,:)
1767DOUBLE PRECISION,pointer :: invbd(:,:,:,:,:),clibd(:,:,:,:,:),tembd(:,:,:,:,:),spabd(:,:,:,:,:)
1768CHARACTER(len=vol7d_cdatalen),pointer :: invbc(:,:,:,:,:),clibc(:,:,:,:,:),tembc(:,:,:,:,:),spabc(:,:,:,:,:)
1769
1770call l4f_log(l4f_info,'starting peeling')
1771
1773
1774! generate code per i vari tipi di dati di v7d
1775! tramite un template e il preprocessore
1776
1777
1778#undef VOL7D_POLY_SUBTYPE
1779#undef VOL7D_POLY_SUBTYPES
1780#define VOL7D_POLY_SUBTYPE REAL
1781#define VOL7D_POLY_SUBTYPES r
1782
1783#undef VOL7D_POLY_TYPE
1784#undef VOL7D_POLY_TYPES
1785#define VOL7D_POLY_TYPE REAL
1786#define VOL7D_POLY_TYPES r
1787#include "modqc_peeling_include.F90"
1788#undef VOL7D_POLY_TYPE
1789#undef VOL7D_POLY_TYPES
1790#define VOL7D_POLY_TYPE DOUBLE PRECISION
1791#define VOL7D_POLY_TYPES d
1792#include "modqc_peeling_include.F90"
1793#undef VOL7D_POLY_TYPE
1794#undef VOL7D_POLY_TYPES
1795#define VOL7D_POLY_TYPE INTEGER
1796#define VOL7D_POLY_TYPES i
1797#include "modqc_peeling_include.F90"
1798#undef VOL7D_POLY_TYPE
1799#undef VOL7D_POLY_TYPES
1800#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1801#define VOL7D_POLY_TYPES b
1802#include "modqc_peeling_include.F90"
1803#undef VOL7D_POLY_TYPE
1804#undef VOL7D_POLY_TYPES
1805#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1806#define VOL7D_POLY_TYPES c
1807#include "modqc_peeling_include.F90"
1808
1809
1810#undef VOL7D_POLY_SUBTYPE
1811#undef VOL7D_POLY_SUBTYPES
1812#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1813#define VOL7D_POLY_SUBTYPES d
1814
1815#undef VOL7D_POLY_TYPE
1816#undef VOL7D_POLY_TYPES
1817#define VOL7D_POLY_TYPE REAL
1818#define VOL7D_POLY_TYPES r
1819#include "modqc_peeling_include.F90"
1820#undef VOL7D_POLY_TYPE
1821#undef VOL7D_POLY_TYPES
1822#define VOL7D_POLY_TYPE DOUBLE PRECISION
1823#define VOL7D_POLY_TYPES d
1824#include "modqc_peeling_include.F90"
1825#undef VOL7D_POLY_TYPE
1826#undef VOL7D_POLY_TYPES
1827#define VOL7D_POLY_TYPE INTEGER
1828#define VOL7D_POLY_TYPES i
1829#include "modqc_peeling_include.F90"
1830#undef VOL7D_POLY_TYPE
1831#undef VOL7D_POLY_TYPES
1832#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1833#define VOL7D_POLY_TYPES b
1834#include "modqc_peeling_include.F90"
1835#undef VOL7D_POLY_TYPE
1836#undef VOL7D_POLY_TYPES
1837#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1838#define VOL7D_POLY_TYPES c
1839#include "modqc_peeling_include.F90"
1840
1841
1842#undef VOL7D_POLY_SUBTYPE
1843#undef VOL7D_POLY_SUBTYPES
1844#define VOL7D_POLY_SUBTYPE INTEGER
1845#define VOL7D_POLY_SUBTYPES i
1846
1847#undef VOL7D_POLY_TYPE
1848#undef VOL7D_POLY_TYPES
1849#define VOL7D_POLY_TYPE REAL
1850#define VOL7D_POLY_TYPES r
1851#include "modqc_peeling_include.F90"
1852#undef VOL7D_POLY_TYPE
1853#undef VOL7D_POLY_TYPES
1854#define VOL7D_POLY_TYPE DOUBLE PRECISION
1855#define VOL7D_POLY_TYPES d
1856#include "modqc_peeling_include.F90"
1857#undef VOL7D_POLY_TYPE
1858#undef VOL7D_POLY_TYPES
1859#define VOL7D_POLY_TYPE INTEGER
1860#define VOL7D_POLY_TYPES i
1861#include "modqc_peeling_include.F90"
1862#undef VOL7D_POLY_TYPE
1863#undef VOL7D_POLY_TYPES
1864#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1865#define VOL7D_POLY_TYPES b
1866#include "modqc_peeling_include.F90"
1867#undef VOL7D_POLY_TYPE
1868#undef VOL7D_POLY_TYPES
1869#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1870#define VOL7D_POLY_TYPES c
1871#include "modqc_peeling_include.F90"
1872
1873
1874#undef VOL7D_POLY_SUBTYPE
1875#undef VOL7D_POLY_SUBTYPES
1876#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1877#define VOL7D_POLY_SUBTYPES b
1878
1879#undef VOL7D_POLY_TYPE
1880#undef VOL7D_POLY_TYPES
1881#define VOL7D_POLY_TYPE REAL
1882#define VOL7D_POLY_TYPES r
1883#include "modqc_peeling_include.F90"
1884#undef VOL7D_POLY_TYPE
1885#undef VOL7D_POLY_TYPES
1886#define VOL7D_POLY_TYPE DOUBLE PRECISION
1887#define VOL7D_POLY_TYPES d
1888#include "modqc_peeling_include.F90"
1889#undef VOL7D_POLY_TYPE
1890#undef VOL7D_POLY_TYPES
1891#define VOL7D_POLY_TYPE INTEGER
1892#define VOL7D_POLY_TYPES i
1893#include "modqc_peeling_include.F90"
1894#undef VOL7D_POLY_TYPE
1895#undef VOL7D_POLY_TYPES
1896#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1897#define VOL7D_POLY_TYPES b
1898#include "modqc_peeling_include.F90"
1899#undef VOL7D_POLY_TYPE
1900#undef VOL7D_POLY_TYPES
1901#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1902#define VOL7D_POLY_TYPES c
1903#include "modqc_peeling_include.F90"
1904
1905
1906
1907#undef VOL7D_POLY_SUBTYPE
1908#undef VOL7D_POLY_SUBTYPES
1909#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1910#define VOL7D_POLY_SUBTYPES c
1911
1912#undef VOL7D_POLY_TYPE
1913#undef VOL7D_POLY_TYPES
1914#define VOL7D_POLY_TYPE REAL
1915#define VOL7D_POLY_TYPES r
1916#include "modqc_peeling_include.F90"
1917#undef VOL7D_POLY_TYPE
1918#undef VOL7D_POLY_TYPES
1919#define VOL7D_POLY_TYPE DOUBLE PRECISION
1920#define VOL7D_POLY_TYPES d
1921#include "modqc_peeling_include.F90"
1922#undef VOL7D_POLY_TYPE
1923#undef VOL7D_POLY_TYPES
1924#define VOL7D_POLY_TYPE INTEGER
1925#define VOL7D_POLY_TYPES i
1926#include "modqc_peeling_include.F90"
1927#undef VOL7D_POLY_TYPE
1928#undef VOL7D_POLY_TYPES
1929#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1930#define VOL7D_POLY_TYPES b
1931#include "modqc_peeling_include.F90"
1932#undef VOL7D_POLY_TYPE
1933#undef VOL7D_POLY_TYPES
1934#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1935#define VOL7D_POLY_TYPES c
1936#include "modqc_peeling_include.F90"
1937
1938
1939
1940IF (.NOT.PRESENT(keep_attr) .AND. .NOT.PRESENT(delete_attr) .and. .not. optio_log(preserve)) THEN ! destroy all attributes
1941 IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
1942 IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
1943 IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
1944 IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
1945 IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
1946
1947 CALL delete(this%datiattr)
1948 CALL delete(this%dativarattr)
1949END IF
1950
1951IF (PRESENT(keep_attr)) THEN ! set to missing non requested attributes and reform
1952
1953 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: keep_attr passed")
1954 CALL keep_var(this%datiattr%r)
1955 CALL keep_var(this%datiattr%d)
1956 CALL keep_var(this%datiattr%i)
1957 CALL keep_var(this%datiattr%b)
1958 CALL keep_var(this%datiattr%c)
1959 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1960
1961ELSE IF (PRESENT(delete_attr)) THEN ! set to missing requested attributes and reform
1962
1963 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: delete_attr passed")
1964 CALL delete_var(this%datiattr%r)
1965 CALL delete_var(this%datiattr%d)
1966 CALL delete_var(this%datiattr%i)
1967 CALL delete_var(this%datiattr%b)
1968 CALL delete_var(this%datiattr%c)
1969 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1970
1971ELSE IF (PRESENT(purgeana)) THEN
1972
1973 CALL qc_reform(this,data_id, purgeana=purgeana)
1974
1975ENDIF
1976
1977
1978CONTAINS
1979
1980
1982subroutine qc_reform(this,data_id,miss, purgeana)
1983TYPE(vol7d),INTENT(INOUT) :: this
1984integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1985logical,intent(in),optional :: miss
1986logical,intent(in),optional :: purgeana
1987
1988integer,pointer :: data_idtmp(:,:,:,:,:)
1989logical,allocatable :: llana(:)
1990integer,allocatable :: anaind(:)
1991integer :: i,j,nana
1992
1993if (optio_log(purgeana)) then
1994 allocate(llana(size(this%ana)))
1995 llana =.false.
1996 do i =1,size(this%ana)
1997 if (associated(this%voldatii)) llana(i)= llana(i) .or. any(c_e(this%voldatii(i,:,:,:,:,:)))
1998 if (associated(this%voldatir)) llana(i)= llana(i) .or. any(c_e(this%voldatir(i,:,:,:,:,:)))
1999 if (associated(this%voldatid)) llana(i)= llana(i) .or. any(c_e(this%voldatid(i,:,:,:,:,:)))
2000 if (associated(this%voldatib)) llana(i)= llana(i) .or. any(c_e(this%voldatib(i,:,:,:,:,:)))
2001 if (associated(this%voldatic)) llana(i)= llana(i) .or. any(c_e(this%voldatic(i,:,:,:,:,:)))
2002
2003#ifdef DEBUG
2004 if (.not. llana(i)) call l4f_log(l4f_debug,"remove station"//t2c(i))
2005#endif
2006
2007 end do
2008
2009 nana=count(llana)
2010
2011
2012 allocate(anaind(nana))
2013
2014 j=0
2015 do i=1,size(this%ana)
2016 if (llana(i)) then
2017 j=j+1
2018 anaind(j)=i
2019 end if
2020 end do
2021
2022
2023 if(present(data_id)) then
2024 allocate(data_idtmp(nana,size(data_id,2),size(data_id,3),size(data_id,4),size(data_id,5)))
2025 data_idtmp=data_id(anaind,:,:,:,:)
2026 if (associated(data_id))deallocate(data_id)
2027 data_id=>data_idtmp
2028 end if
2029
2030 call vol7d_reform(this,miss=miss,lana=llana)
2031
2032 deallocate(llana,anaind)
2033
2034else
2035
2036 call vol7d_reform(this,miss=miss)
2037
2038end if
2039
2040end subroutine qc_reform
2041
2042
2043SUBROUTINE keep_var(var)
2044TYPE(vol7d_var),intent(inout),POINTER :: var(:)
2045
2046INTEGER :: i
2047
2048IF (ASSOCIATED(var)) THEN
2049 if (size(var) == 0) then
2050 var%btable = vol7d_var_miss%btable
2051 else
2052 DO i = 1, SIZE(var)
2053 IF (all(var(i)%btable /= keep_attr(:))) THEN ! n.b. ALL((//)) = .TRUE.
2054 var(i)%btable = vol7d_var_miss%btable
2055 ENDIF
2056 ENDDO
2057 end if
2058ENDIF
2059
2060END SUBROUTINE keep_var
2061
2062SUBROUTINE delete_var(var)
2063TYPE(vol7d_var),intent(inout),POINTER :: var(:)
2064
2065INTEGER :: i
2066
2067IF (ASSOCIATED(var)) THEN
2068 if (size(var) == 0) then
2069 var%btable = vol7d_var_miss%btable
2070 else
2071 DO i = 1, SIZE(var)
2072 IF (any(var(i)%btable == delete_attr(:))) THEN ! n.b. ANY((//)) = .FALSE.
2073 var(i) = vol7d_var_miss
2074 ENDIF
2075 ENDDO
2076 end if
2077ENDIF
2078
2079END SUBROUTINE delete_var
2080
2081END SUBROUTINE vol7d_peeling
2082
2083
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 |