libsim Versione 7.1.11
|
◆ sort_level()
Sorts inline into ascending order - Quicksort Quicksort chooses a "pivot" in the set, and explores the array from both ends, looking for a value > pivot with the increasing index, for a value <= pivot with the decreasing index, and swapping them when it has found one of each. The array is then subdivided in 2 ([3]) subsets: { values <= pivot} {pivot} {values > pivot} One then call recursively the program to sort each subset. When the size of the subarray is small enough or the maximum level of recursion is gained, one uses an insertion sort that is faster for very small sets.
Definizione alla linea 1345 del file vol7d_level_class.F90. 1346! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1347! authors:
1348! Davide Cesari <dcesari@arpa.emr.it>
1349! Paolo Patruno <ppatruno@arpa.emr.it>
1350
1351! This program is free software; you can redistribute it and/or
1352! modify it under the terms of the GNU General Public License as
1353! published by the Free Software Foundation; either version 2 of
1354! the License, or (at your option) any later version.
1355
1356! This program is distributed in the hope that it will be useful,
1357! but WITHOUT ANY WARRANTY; without even the implied warranty of
1358! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1359! GNU General Public License for more details.
1360
1361! You should have received a copy of the GNU General Public License
1362! along with this program. If not, see <http://www.gnu.org/licenses/>.
1363#include "config.h"
1364
1374IMPLICIT NONE
1375
1381 INTEGER :: level1
1382 INTEGER :: l1
1383 INTEGER :: level2
1384 INTEGER :: l2
1386
1389
1394 MODULE PROCEDURE vol7d_level_init
1395END INTERFACE
1396
1400 MODULE PROCEDURE vol7d_level_delete
1401END INTERFACE
1402
1406INTERFACE OPERATOR (==)
1407 MODULE PROCEDURE vol7d_level_eq
1408END INTERFACE
1409
1413INTERFACE OPERATOR (/=)
1414 MODULE PROCEDURE vol7d_level_ne
1415END INTERFACE
1416
1422INTERFACE OPERATOR (>)
1423 MODULE PROCEDURE vol7d_level_gt
1424END INTERFACE
1425
1431INTERFACE OPERATOR (<)
1432 MODULE PROCEDURE vol7d_level_lt
1433END INTERFACE
1434
1440INTERFACE OPERATOR (>=)
1441 MODULE PROCEDURE vol7d_level_ge
1442END INTERFACE
1443
1449INTERFACE OPERATOR (<=)
1450 MODULE PROCEDURE vol7d_level_le
1451END INTERFACE
1452
1456INTERFACE OPERATOR (.almosteq.)
1457 MODULE PROCEDURE vol7d_level_almost_eq
1458END INTERFACE
1459
1460
1461! da documentare in inglese assieme al resto
1464 MODULE PROCEDURE vol7d_level_c_e
1465END INTERFACE
1466
1467#define VOL7D_POLY_TYPE TYPE(vol7d_level)
1468#define VOL7D_POLY_TYPES _level
1469#define ENABLE_SORT
1470#include "array_utilities_pre.F90"
1471
1474 MODULE PROCEDURE display_level
1475END INTERFACE
1476
1479 MODULE PROCEDURE to_char_level
1480END INTERFACE
1481
1484 MODULE PROCEDURE vol7d_level_to_var_int, vol7d_level_to_var_lev
1486
1489 MODULE PROCEDURE vol7d_level_to_var_factor_int, vol7d_level_to_var_factor_lev
1491
1494 MODULE PROCEDURE vol7d_level_to_var_log10_int, vol7d_level_to_var_log10_lev
1496
1497type(vol7d_level) :: almost_equal_levels(3)=(/&
1498 vol7d_level( 1,imiss,imiss,imiss),&
1499 vol7d_level(103,imiss,imiss,imiss),&
1500 vol7d_level(106,imiss,imiss,imiss)/)
1501
1502! levels requiring conversion from internal to physical representation
1503INTEGER, PARAMETER :: &
1504 height_level(6) = (/102,103,106,117,160,161/), & ! 10**-3
1505 thermo_level(3) = (/20,107,235/), & ! 10**-1
1506 sigma_level(2) = (/104,111/) ! 10**-4
1507
1508TYPE level_var
1509 INTEGER :: level
1510 CHARACTER(len=10) :: btable
1511END TYPE level_var
1512
1513! Conversion table from GRIB2 vertical level codes to corresponding
1514! BUFR B table variables
1515TYPE(level_var),PARAMETER :: level_var_converter(7) = (/ &
1516 level_var(20, 'B12101'), & ! isothermal (K)
1517 level_var(100, 'B10004'), & ! isobaric (Pa)
1518 level_var(102, 'B10007'), & ! height over sea level (m)
1519 level_var(103, 'B10007'), & ! height over surface (m) (special treatment needed!)
1520 level_var(107, 'B12192'), & ! isentropical (K)
1521 level_var(108, 'B10004'), & ! pressure difference from surface (Pa) (special treatment needed!)
1522 level_var(161, 'B22195') /) ! depth below sea surface
1523
1524PRIVATE level_var, level_var_converter
1525
1526CONTAINS
1527
1533FUNCTION vol7d_level_new(level1, l1, level2, l2) RESULT(this)
1534INTEGER,INTENT(IN),OPTIONAL :: level1
1535INTEGER,INTENT(IN),OPTIONAL :: l1
1536INTEGER,INTENT(IN),OPTIONAL :: level2
1537INTEGER,INTENT(IN),OPTIONAL :: l2
1538
1539TYPE(vol7d_level) :: this
1540
1542
1543END FUNCTION vol7d_level_new
1544
1545
1549SUBROUTINE vol7d_level_init(this, level1, l1, level2, l2)
1550TYPE(vol7d_level),INTENT(INOUT) :: this
1551INTEGER,INTENT(IN),OPTIONAL :: level1
1552INTEGER,INTENT(IN),OPTIONAL :: l1
1553INTEGER,INTENT(IN),OPTIONAL :: level2
1554INTEGER,INTENT(IN),OPTIONAL :: l2
1555
1556this%level1 = imiss
1557this%l1 = imiss
1558this%level2 = imiss
1559this%l2 = imiss
1560
1561IF (PRESENT(level1)) THEN
1562 this%level1 = level1
1563ELSE
1564 RETURN
1565END IF
1566
1567IF (PRESENT(l1)) this%l1 = l1
1568
1569IF (PRESENT(level2)) THEN
1570 this%level2 = level2
1571ELSE
1572 RETURN
1573END IF
1574
1575IF (PRESENT(l2)) this%l2 = l2
1576
1577END SUBROUTINE vol7d_level_init
1578
1579
1581SUBROUTINE vol7d_level_delete(this)
1582TYPE(vol7d_level),INTENT(INOUT) :: this
1583
1584this%level1 = imiss
1585this%l1 = imiss
1586this%level2 = imiss
1587this%l2 = imiss
1588
1589END SUBROUTINE vol7d_level_delete
1590
1591
1592SUBROUTINE display_level(this)
1593TYPE(vol7d_level),INTENT(in) :: this
1594
1595print*,trim(to_char(this))
1596
1597END SUBROUTINE display_level
1598
1599
1600FUNCTION to_char_level(this)
1601#ifdef HAVE_DBALLE
1602USE dballef
1603#endif
1604TYPE(vol7d_level),INTENT(in) :: this
1605CHARACTER(len=255) :: to_char_level
1606
1607#ifdef HAVE_DBALLE
1608INTEGER :: handle, ier
1609
1610handle = 0
1611ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
1612ier = idba_spiegal(handle,this%level1,this%l1,this%level2,this%l2,to_char_level)
1613ier = idba_fatto(handle)
1614
1615to_char_level="LEVEL: "//to_char_level
1616
1617#else
1618
1619to_char_level="LEVEL: "//&
1622
1623#endif
1624
1625END FUNCTION to_char_level
1626
1627
1628ELEMENTAL FUNCTION vol7d_level_eq(this, that) RESULT(res)
1629TYPE(vol7d_level),INTENT(IN) :: this, that
1630LOGICAL :: res
1631
1632res = &
1633 this%level1 == that%level1 .AND. &
1634 this%level2 == that%level2 .AND. &
1635 this%l1 == that%l1 .AND. this%l2 == that%l2
1636
1637END FUNCTION vol7d_level_eq
1638
1639
1640ELEMENTAL FUNCTION vol7d_level_ne(this, that) RESULT(res)
1641TYPE(vol7d_level),INTENT(IN) :: this, that
1642LOGICAL :: res
1643
1644res = .NOT.(this == that)
1645
1646END FUNCTION vol7d_level_ne
1647
1648
1649ELEMENTAL FUNCTION vol7d_level_almost_eq(this, that) RESULT(res)
1650TYPE(vol7d_level),INTENT(IN) :: this, that
1651LOGICAL :: res
1652
1657 res = .true.
1658ELSE
1659 res = .false.
1660ENDIF
1661
1662END FUNCTION vol7d_level_almost_eq
1663
1664
1665ELEMENTAL FUNCTION vol7d_level_gt(this, that) RESULT(res)
1666TYPE(vol7d_level),INTENT(IN) :: this, that
1667LOGICAL :: res
1668
1669IF (&
1670 this%level1 > that%level1 .OR. &
1671 (this%level1 == that%level1 .AND. this%l1 > that%l1) .OR. &
1672 (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
1673 (&
1674 this%level2 > that%level2 .OR. &
1675 (this%level2 == that%level2 .AND. this%l2 > that%l2) &
1676 ))) THEN
1677 res = .true.
1678ELSE
1679 res = .false.
1680ENDIF
1681
1682END FUNCTION vol7d_level_gt
1683
1684
1685ELEMENTAL FUNCTION vol7d_level_lt(this, that) RESULT(res)
1686TYPE(vol7d_level),INTENT(IN) :: this, that
1687LOGICAL :: res
1688
1689IF (&
1690 this%level1 < that%level1 .OR. &
1691 (this%level1 == that%level1 .AND. this%l1 < that%l1) .OR. &
1692 (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
1693 (&
1694 this%level2 < that%level2 .OR. &
1695 (this%level2 == that%level2 .AND. this%l2 < that%l2) &
1696 ))) THEN
1697 res = .true.
1698ELSE
1699 res = .false.
1700ENDIF
1701
1702END FUNCTION vol7d_level_lt
1703
1704
1705ELEMENTAL FUNCTION vol7d_level_ge(this, that) RESULT(res)
1706TYPE(vol7d_level),INTENT(IN) :: this, that
1707LOGICAL :: res
1708
1709IF (this == that) THEN
1710 res = .true.
1711ELSE IF (this > that) THEN
1712 res = .true.
1713ELSE
1714 res = .false.
1715ENDIF
1716
1717END FUNCTION vol7d_level_ge
1718
1719
1720ELEMENTAL FUNCTION vol7d_level_le(this, that) RESULT(res)
1721TYPE(vol7d_level),INTENT(IN) :: this, that
1722LOGICAL :: res
1723
1724IF (this == that) THEN
1725 res = .true.
1726ELSE IF (this < that) THEN
1727 res = .true.
1728ELSE
1729 res = .false.
1730ENDIF
1731
1732END FUNCTION vol7d_level_le
1733
1734
1735ELEMENTAL FUNCTION vol7d_level_c_e(this) RESULT(c_e)
1736TYPE(vol7d_level),INTENT(IN) :: this
1737LOGICAL :: c_e
1738c_e = this /= vol7d_level_miss
1739END FUNCTION vol7d_level_c_e
1740
1741
1742#include "array_utilities_inc.F90"
1743
1744
1745FUNCTION vol7d_level_to_var_lev(level) RESULT(btable)
1746TYPE(vol7d_level),INTENT(in) :: level
1747CHARACTER(len=10) :: btable
1748
1749btable = vol7d_level_to_var_int(level%level1)
1750
1751END FUNCTION vol7d_level_to_var_lev
1752
1753FUNCTION vol7d_level_to_var_int(level) RESULT(btable)
1754INTEGER,INTENT(in) :: level
1755CHARACTER(len=10) :: btable
1756
1757INTEGER :: i
1758
1759DO i = 1, SIZE(level_var_converter)
1760 IF (level_var_converter(i)%level == level) THEN
1761 btable = level_var_converter(i)%btable
1762 RETURN
1763 ENDIF
1764ENDDO
1765
1766btable = cmiss
1767
1768END FUNCTION vol7d_level_to_var_int
1769
1770
1771FUNCTION vol7d_level_to_var_factor_lev(level) RESULT(factor)
1772TYPE(vol7d_level),INTENT(in) :: level
1773REAL :: factor
1774
1775factor = vol7d_level_to_var_factor_int(level%level1)
1776
1777END FUNCTION vol7d_level_to_var_factor_lev
1778
1779FUNCTION vol7d_level_to_var_factor_int(level) RESULT(factor)
1780INTEGER,INTENT(in) :: level
1781REAL :: factor
1782
1783factor = 1.
1784IF (any(level == height_level)) THEN
1785 factor = 1.e-3
1786ELSE IF (any(level == thermo_level)) THEN
1787 factor = 1.e-1
1788ELSE IF (any(level == sigma_level)) THEN
1789 factor = 1.e-4
1790ENDIF
1791
1792END FUNCTION vol7d_level_to_var_factor_int
1793
1794
1795FUNCTION vol7d_level_to_var_log10_lev(level) RESULT(log10)
1796TYPE(vol7d_level),INTENT(in) :: level
1797REAL :: log10
1798
1799log10 = vol7d_level_to_var_log10_int(level%level1)
1800
1801END FUNCTION vol7d_level_to_var_log10_lev
1802
1803FUNCTION vol7d_level_to_var_log10_int(level) RESULT(log10)
1804INTEGER,INTENT(in) :: level
1805REAL :: log10
1806
1807log10 = 0.
1808IF (any(level == height_level)) THEN
1809 log10 = -3.
1810ELSE IF (any(level == thermo_level)) THEN
1811 log10 = -1.
1812ELSE IF (any(level == sigma_level)) THEN
1813 log10 = -4.
1814ENDIF
1815
1816END FUNCTION vol7d_level_to_var_log10_int
1817
Distruttore per la classe vol7d_level. Definition: vol7d_level_class.F90:248 Represent level object in a pretty string. Definition: vol7d_level_class.F90:382 Return the conversion factor for multiplying the level value when converting to variable. Definition: vol7d_level_class.F90:392 Return the scale value (base 10 log of conversion factor) for multiplying the level value when conver... Definition: vol7d_level_class.F90:397 Convert a level type to a physical variable. Definition: vol7d_level_class.F90:387 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 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition: vol7d_level_class.F90:219 Definisce il livello verticale di un'osservazione. Definition: vol7d_level_class.F90:229 |