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