libsim Versione 7.2.0
|
◆ 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 1339 del file vol7d_level_class.F90. 1340! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1341! authors:
1342! Davide Cesari <dcesari@arpa.emr.it>
1343! Paolo Patruno <ppatruno@arpa.emr.it>
1344
1345! This program is free software; you can redistribute it and/or
1346! modify it under the terms of the GNU General Public License as
1347! published by the Free Software Foundation; either version 2 of
1348! the License, or (at your option) any later version.
1349
1350! This program is distributed in the hope that it will be useful,
1351! but WITHOUT ANY WARRANTY; without even the implied warranty of
1352! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1353! GNU General Public License for more details.
1354
1355! You should have received a copy of the GNU General Public License
1356! along with this program. If not, see <http://www.gnu.org/licenses/>.
1357#include "config.h"
1358
1368IMPLICIT NONE
1369
1375 INTEGER :: level1
1376 INTEGER :: l1
1377 INTEGER :: level2
1378 INTEGER :: l2
1380
1383
1388 MODULE PROCEDURE vol7d_level_init
1389END INTERFACE
1390
1394 MODULE PROCEDURE vol7d_level_delete
1395END INTERFACE
1396
1400INTERFACE OPERATOR (==)
1401 MODULE PROCEDURE vol7d_level_eq
1402END INTERFACE
1403
1407INTERFACE OPERATOR (/=)
1408 MODULE PROCEDURE vol7d_level_ne
1409END INTERFACE
1410
1416INTERFACE OPERATOR (>)
1417 MODULE PROCEDURE vol7d_level_gt
1418END INTERFACE
1419
1425INTERFACE OPERATOR (<)
1426 MODULE PROCEDURE vol7d_level_lt
1427END INTERFACE
1428
1434INTERFACE OPERATOR (>=)
1435 MODULE PROCEDURE vol7d_level_ge
1436END INTERFACE
1437
1443INTERFACE OPERATOR (<=)
1444 MODULE PROCEDURE vol7d_level_le
1445END INTERFACE
1446
1450INTERFACE OPERATOR (.almosteq.)
1451 MODULE PROCEDURE vol7d_level_almost_eq
1452END INTERFACE
1453
1454
1455! da documentare in inglese assieme al resto
1458 MODULE PROCEDURE vol7d_level_c_e
1459END INTERFACE
1460
1461#define VOL7D_POLY_TYPE TYPE(vol7d_level)
1462#define VOL7D_POLY_TYPES _level
1463#define ENABLE_SORT
1464#include "array_utilities_pre.F90"
1465
1468 MODULE PROCEDURE display_level
1469END INTERFACE
1470
1473 MODULE PROCEDURE to_char_level
1474END INTERFACE
1475
1478 MODULE PROCEDURE vol7d_level_to_var_int, vol7d_level_to_var_lev
1480
1483 MODULE PROCEDURE vol7d_level_to_var_factor_int, vol7d_level_to_var_factor_lev
1485
1488 MODULE PROCEDURE vol7d_level_to_var_log10_int, vol7d_level_to_var_log10_lev
1490
1491type(vol7d_level) :: almost_equal_levels(3)=(/&
1492 vol7d_level( 1,imiss,imiss,imiss),&
1493 vol7d_level(103,imiss,imiss,imiss),&
1494 vol7d_level(106,imiss,imiss,imiss)/)
1495
1496! levels requiring conversion from internal to physical representation
1497INTEGER, PARAMETER :: &
1498 height_level(6) = (/102,103,106,117,160,161/), & ! 10**-3
1499 thermo_level(3) = (/20,107,235/), & ! 10**-1
1500 sigma_level(2) = (/104,111/) ! 10**-4
1501
1502TYPE level_var
1503 INTEGER :: level
1504 CHARACTER(len=10) :: btable
1505END TYPE level_var
1506
1507! Conversion table from GRIB2 vertical level codes to corresponding
1508! BUFR B table variables
1509TYPE(level_var),PARAMETER :: level_var_converter(7) = (/ &
1510 level_var(20, 'B12101'), & ! isothermal (K)
1511 level_var(100, 'B10004'), & ! isobaric (Pa)
1512 level_var(102, 'B10007'), & ! height over sea level (m)
1513 level_var(103, 'B10007'), & ! height over surface (m) (special treatment needed!)
1514 level_var(107, 'B12192'), & ! isentropical (K)
1515 level_var(108, 'B10004'), & ! pressure difference from surface (Pa) (special treatment needed!)
1516 level_var(161, 'B22195') /) ! depth below sea surface
1517
1518PRIVATE level_var, level_var_converter
1519
1520CONTAINS
1521
1527FUNCTION vol7d_level_new(level1, l1, level2, l2) RESULT(this)
1528INTEGER,INTENT(IN),OPTIONAL :: level1
1529INTEGER,INTENT(IN),OPTIONAL :: l1
1530INTEGER,INTENT(IN),OPTIONAL :: level2
1531INTEGER,INTENT(IN),OPTIONAL :: l2
1532
1533TYPE(vol7d_level) :: this
1534
1536
1537END FUNCTION vol7d_level_new
1538
1539
1543SUBROUTINE vol7d_level_init(this, level1, l1, level2, l2)
1544TYPE(vol7d_level),INTENT(INOUT) :: this
1545INTEGER,INTENT(IN),OPTIONAL :: level1
1546INTEGER,INTENT(IN),OPTIONAL :: l1
1547INTEGER,INTENT(IN),OPTIONAL :: level2
1548INTEGER,INTENT(IN),OPTIONAL :: l2
1549
1550this%level1 = imiss
1551this%l1 = imiss
1552this%level2 = imiss
1553this%l2 = imiss
1554
1555IF (PRESENT(level1)) THEN
1556 this%level1 = level1
1557ELSE
1558 RETURN
1559END IF
1560
1561IF (PRESENT(l1)) this%l1 = l1
1562
1563IF (PRESENT(level2)) THEN
1564 this%level2 = level2
1565ELSE
1566 RETURN
1567END IF
1568
1569IF (PRESENT(l2)) this%l2 = l2
1570
1571END SUBROUTINE vol7d_level_init
1572
1573
1575SUBROUTINE vol7d_level_delete(this)
1576TYPE(vol7d_level),INTENT(INOUT) :: this
1577
1578this%level1 = imiss
1579this%l1 = imiss
1580this%level2 = imiss
1581this%l2 = imiss
1582
1583END SUBROUTINE vol7d_level_delete
1584
1585
1586SUBROUTINE display_level(this)
1587TYPE(vol7d_level),INTENT(in) :: this
1588
1589print*,trim(to_char(this))
1590
1591END SUBROUTINE display_level
1592
1593
1594FUNCTION to_char_level(this)
1595#ifdef HAVE_DBALLE
1596USE dballef
1597#endif
1598TYPE(vol7d_level),INTENT(in) :: this
1599CHARACTER(len=255) :: to_char_level
1600
1601#ifdef HAVE_DBALLE
1602INTEGER :: handle, ier
1603
1604handle = 0
1605ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
1606ier = idba_spiegal(handle,this%level1,this%l1,this%level2,this%l2,to_char_level)
1607ier = idba_fatto(handle)
1608
1609to_char_level="LEVEL: "//to_char_level
1610
1611#else
1612
1613to_char_level="LEVEL: "//&
1616
1617#endif
1618
1619END FUNCTION to_char_level
1620
1621
1622ELEMENTAL FUNCTION vol7d_level_eq(this, that) RESULT(res)
1623TYPE(vol7d_level),INTENT(IN) :: this, that
1624LOGICAL :: res
1625
1626res = &
1627 this%level1 == that%level1 .AND. &
1628 this%level2 == that%level2 .AND. &
1629 this%l1 == that%l1 .AND. this%l2 == that%l2
1630
1631END FUNCTION vol7d_level_eq
1632
1633
1634ELEMENTAL FUNCTION vol7d_level_ne(this, that) RESULT(res)
1635TYPE(vol7d_level),INTENT(IN) :: this, that
1636LOGICAL :: res
1637
1638res = .NOT.(this == that)
1639
1640END FUNCTION vol7d_level_ne
1641
1642
1643ELEMENTAL FUNCTION vol7d_level_almost_eq(this, that) RESULT(res)
1644TYPE(vol7d_level),INTENT(IN) :: this, that
1645LOGICAL :: res
1646
1651 res = .true.
1652ELSE
1653 res = .false.
1654ENDIF
1655
1656END FUNCTION vol7d_level_almost_eq
1657
1658
1659ELEMENTAL FUNCTION vol7d_level_gt(this, that) RESULT(res)
1660TYPE(vol7d_level),INTENT(IN) :: this, that
1661LOGICAL :: res
1662
1663IF (&
1664 this%level1 > that%level1 .OR. &
1665 (this%level1 == that%level1 .AND. this%l1 > that%l1) .OR. &
1666 (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
1667 (&
1668 this%level2 > that%level2 .OR. &
1669 (this%level2 == that%level2 .AND. this%l2 > that%l2) &
1670 ))) THEN
1671 res = .true.
1672ELSE
1673 res = .false.
1674ENDIF
1675
1676END FUNCTION vol7d_level_gt
1677
1678
1679ELEMENTAL FUNCTION vol7d_level_lt(this, that) RESULT(res)
1680TYPE(vol7d_level),INTENT(IN) :: this, that
1681LOGICAL :: res
1682
1683IF (&
1684 this%level1 < that%level1 .OR. &
1685 (this%level1 == that%level1 .AND. this%l1 < that%l1) .OR. &
1686 (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
1687 (&
1688 this%level2 < that%level2 .OR. &
1689 (this%level2 == that%level2 .AND. this%l2 < that%l2) &
1690 ))) THEN
1691 res = .true.
1692ELSE
1693 res = .false.
1694ENDIF
1695
1696END FUNCTION vol7d_level_lt
1697
1698
1699ELEMENTAL FUNCTION vol7d_level_ge(this, that) RESULT(res)
1700TYPE(vol7d_level),INTENT(IN) :: this, that
1701LOGICAL :: res
1702
1703IF (this == that) THEN
1704 res = .true.
1705ELSE IF (this > that) THEN
1706 res = .true.
1707ELSE
1708 res = .false.
1709ENDIF
1710
1711END FUNCTION vol7d_level_ge
1712
1713
1714ELEMENTAL FUNCTION vol7d_level_le(this, that) RESULT(res)
1715TYPE(vol7d_level),INTENT(IN) :: this, that
1716LOGICAL :: res
1717
1718IF (this == that) THEN
1719 res = .true.
1720ELSE IF (this < that) THEN
1721 res = .true.
1722ELSE
1723 res = .false.
1724ENDIF
1725
1726END FUNCTION vol7d_level_le
1727
1728
1729ELEMENTAL FUNCTION vol7d_level_c_e(this) RESULT(c_e)
1730TYPE(vol7d_level),INTENT(IN) :: this
1731LOGICAL :: c_e
1732c_e = this /= vol7d_level_miss
1733END FUNCTION vol7d_level_c_e
1734
1735
1736#include "array_utilities_inc.F90"
1737
1738
1739FUNCTION vol7d_level_to_var_lev(level) RESULT(btable)
1740TYPE(vol7d_level),INTENT(in) :: level
1741CHARACTER(len=10) :: btable
1742
1743btable = vol7d_level_to_var_int(level%level1)
1744
1745END FUNCTION vol7d_level_to_var_lev
1746
1747FUNCTION vol7d_level_to_var_int(level) RESULT(btable)
1748INTEGER,INTENT(in) :: level
1749CHARACTER(len=10) :: btable
1750
1751INTEGER :: i
1752
1753DO i = 1, SIZE(level_var_converter)
1754 IF (level_var_converter(i)%level == level) THEN
1755 btable = level_var_converter(i)%btable
1756 RETURN
1757 ENDIF
1758ENDDO
1759
1760btable = cmiss
1761
1762END FUNCTION vol7d_level_to_var_int
1763
1764
1765FUNCTION vol7d_level_to_var_factor_lev(level) RESULT(factor)
1766TYPE(vol7d_level),INTENT(in) :: level
1767REAL :: factor
1768
1769factor = vol7d_level_to_var_factor_int(level%level1)
1770
1771END FUNCTION vol7d_level_to_var_factor_lev
1772
1773FUNCTION vol7d_level_to_var_factor_int(level) RESULT(factor)
1774INTEGER,INTENT(in) :: level
1775REAL :: factor
1776
1777factor = 1.
1778IF (any(level == height_level)) THEN
1779 factor = 1.e-3
1780ELSE IF (any(level == thermo_level)) THEN
1781 factor = 1.e-1
1782ELSE IF (any(level == sigma_level)) THEN
1783 factor = 1.e-4
1784ENDIF
1785
1786END FUNCTION vol7d_level_to_var_factor_int
1787
1788
1789FUNCTION vol7d_level_to_var_log10_lev(level) RESULT(log10)
1790TYPE(vol7d_level),INTENT(in) :: level
1791REAL :: log10
1792
1793log10 = vol7d_level_to_var_log10_int(level%level1)
1794
1795END FUNCTION vol7d_level_to_var_log10_lev
1796
1797FUNCTION vol7d_level_to_var_log10_int(level) RESULT(log10)
1798INTEGER,INTENT(in) :: level
1799REAL :: log10
1800
1801log10 = 0.
1802IF (any(level == height_level)) THEN
1803 log10 = -3.
1804ELSE IF (any(level == thermo_level)) THEN
1805 log10 = -1.
1806ELSE IF (any(level == sigma_level)) THEN
1807 log10 = -4.
1808ENDIF
1809
1810END FUNCTION vol7d_level_to_var_log10_int
1811
Distruttore per la classe vol7d_level. Definition: vol7d_level_class.F90:242 Represent level object in a pretty string. Definition: vol7d_level_class.F90:376 Return the conversion factor for multiplying the level value when converting to variable. Definition: vol7d_level_class.F90:386 Return the scale value (base 10 log of conversion factor) for multiplying the level value when conver... Definition: vol7d_level_class.F90:391 Convert a level type to a physical variable. Definition: vol7d_level_class.F90:381 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 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition: vol7d_level_class.F90:213 Definisce il livello verticale di un'osservazione. Definition: vol7d_level_class.F90:223 |