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