libsim Versione 7.2.1

◆ display_volgrid6d_var()

subroutine display_volgrid6d_var ( type(volgrid6d_var), intent(in)  this)
private

Display on the screen a brief content of volgrid6d_var object.

Parametri
[in]thisvolgrid6d_var object to display

Definizione alla linea 1073 del file volgrid6d_var_class.F90.

1074! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1075! authors:
1076! Davide Cesari <dcesari@arpa.emr.it>
1077! Paolo Patruno <ppatruno@arpa.emr.it>
1078
1079! This program is free software; you can redistribute it and/or
1080! modify it under the terms of the GNU General Public License as
1081! published by the Free Software Foundation; either version 2 of
1082! the License, or (at your option) any later version.
1083
1084! This program is distributed in the hope that it will be useful,
1085! but WITHOUT ANY WARRANTY; without even the implied warranty of
1086! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1087! GNU General Public License for more details.
1088
1089! You should have received a copy of the GNU General Public License
1090! along with this program. If not, see <http://www.gnu.org/licenses/>.
1091#include "config.h"
1092
1104USE kinds
1106USE err_handling
1109USE grid_id_class
1110
1111IMPLICIT NONE
1112
1117TYPE volgrid6d_var
1118 integer :: centre
1119 integer :: category
1120 integer :: number
1121 integer :: discipline
1122 CHARACTER(len=65) :: description
1123 CHARACTER(len=24) :: unit
1124END TYPE volgrid6d_var
1125
1126TYPE(volgrid6d_var),PARAMETER :: volgrid6d_var_miss= &
1127 volgrid6d_var(imiss,imiss,imiss,imiss,cmiss,cmiss)
1128
1129TYPE(vol7d_var),PARAMETER :: vol7d_var_horstag(2) = (/ &
1130 vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
1131 vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0) &
1132 /)
1133
1134TYPE(vol7d_var),PARAMETER :: vol7d_var_horcomp(4) = (/ &! RESHAPE( (/ &
1135 vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
1136 vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0), &
1137 vol7d_var('B11200', '', '', 0, 0, 0, 0, 0, 0), &
1138 vol7d_var('B11201', '', '', 0, 0, 0, 0, 0, 0) &
1139/)
1140!/), (/2,2/)) ! bug in gfortran
1141
1150TYPE conv_func
1151 PRIVATE
1152 REAL :: a, b
1153END TYPE conv_func
1154
1155TYPE(conv_func), PARAMETER :: conv_func_miss=conv_func(rmiss,rmiss)
1156TYPE(conv_func), PARAMETER :: conv_func_identity=conv_func(1.0,0.0)
1157
1158TYPE vg6d_v7d_var_conv
1159 TYPE(volgrid6d_var) :: vg6d_var
1160 TYPE(vol7d_var) :: v7d_var
1161 TYPE(conv_func) :: c_func
1162! aggiungere informazioni ad es. su rotazione del vento
1163END TYPE vg6d_v7d_var_conv
1164
1165TYPE(vg6d_v7d_var_conv), PARAMETER :: vg6d_v7d_var_conv_miss= &
1166 vg6d_v7d_var_conv(volgrid6d_var_miss, vol7d_var_miss, conv_func_miss)
1167
1168TYPE(vg6d_v7d_var_conv), ALLOCATABLE :: conv_fwd(:), conv_bwd(:)
1169
1183INTERFACE init
1184 MODULE PROCEDURE volgrid6d_var_init
1185END INTERFACE
1186
1189INTERFACE delete
1190 MODULE PROCEDURE volgrid6d_var_delete
1191END INTERFACE
1192
1193INTERFACE c_e
1194 MODULE PROCEDURE volgrid6d_var_c_e
1195END INTERFACE
1196
1197
1202INTERFACE OPERATOR (==)
1203 MODULE PROCEDURE volgrid6d_var_eq, conv_func_eq
1204END INTERFACE
1205
1210INTERFACE OPERATOR (/=)
1211 MODULE PROCEDURE volgrid6d_var_ne, conv_func_ne
1212END INTERFACE
1213
1214#define VOL7D_POLY_TYPE TYPE(volgrid6d_var)
1215#define VOL7D_POLY_TYPES _var6d
1216#include "array_utilities_pre.F90"
1217
1219INTERFACE display
1220 MODULE PROCEDURE display_volgrid6d_var
1221END INTERFACE
1222
1227INTERFACE OPERATOR (*)
1228 MODULE PROCEDURE conv_func_mult
1229END INTERFACE OPERATOR (*)
1230
1233INTERFACE compute
1234 MODULE PROCEDURE conv_func_compute
1235END INTERFACE
1236
1239INTERFACE convert
1240 MODULE PROCEDURE varbufr2vargrib_convert, vargrib2varbufr_convert, &
1241 conv_func_convert
1242END INTERFACE
1243
1244PRIVATE
1245PUBLIC volgrid6d_var, volgrid6d_var_miss, volgrid6d_var_new, init, delete, &
1246 c_e, volgrid6d_var_normalize, &
1247 OPERATOR(==), OPERATOR(/=), OPERATOR(*), &
1248 count_distinct, pack_distinct, count_and_pack_distinct, &
1249 map_distinct, map_inv_distinct, &
1250 index, display, &
1251 vargrib2varbufr, varbufr2vargrib, &
1252 conv_func, conv_func_miss, compute, convert, &
1253 volgrid6d_var_hor_comp_index, volgrid6d_var_is_hor_comp
1254
1255
1256CONTAINS
1257
1258
1259ELEMENTAL FUNCTION volgrid6d_var_new(centre, category, number, &
1260 discipline, description, unit) RESULT(this)
1261integer,INTENT(in),OPTIONAL :: centre
1262integer,INTENT(in),OPTIONAL :: category
1263integer,INTENT(in),OPTIONAL :: number
1264integer,INTENT(in),OPTIONAL :: discipline
1265CHARACTER(len=*),INTENT(in),OPTIONAL :: description
1266CHARACTER(len=*),INTENT(in),OPTIONAL :: unit
1267
1268TYPE(volgrid6d_var) :: this
1269
1270CALL init(this, centre, category, number, discipline, description, unit)
1271
1272END FUNCTION volgrid6d_var_new
1273
1274
1275! documented in the interface
1276ELEMENTAL SUBROUTINE volgrid6d_var_init(this, centre, category, number, discipline,description,unit)
1277TYPE(volgrid6d_var),INTENT(INOUT) :: this ! object to be initialized
1278INTEGER,INTENT(in),OPTIONAL :: centre ! centre
1279INTEGER,INTENT(in),OPTIONAL :: category ! grib2: category / grib1: grib table version number
1280INTEGER,INTENT(in),OPTIONAL :: number ! parameter number
1281INTEGER,INTENT(in),OPTIONAL :: discipline ! grib2: discipline / grib1: 255
1282CHARACTER(len=*),INTENT(in),OPTIONAL :: description ! optional textual description of the variable
1283CHARACTER(len=*),INTENT(in),OPTIONAL :: unit ! optional textual description of the variable's unit
1284
1285IF (PRESENT(centre)) THEN
1286 this%centre = centre
1287ELSE
1288 this%centre = imiss
1289 this%category = imiss
1290 this%number = imiss
1291 this%discipline = imiss
1292 RETURN
1293ENDIF
1294
1295IF (PRESENT(category)) THEN
1296 this%category = category
1297ELSE
1298 this%category = imiss
1299 this%number = imiss
1300 this%discipline = imiss
1301 RETURN
1302ENDIF
1303
1304
1305IF (PRESENT(number)) THEN
1306 this%number = number
1307ELSE
1308 this%number = imiss
1309 this%discipline = imiss
1310 RETURN
1311ENDIF
1312
1313! se sono arrivato fino a qui ho impostato centre, category e number
1314!per il grib 1 manca discipline e imposto 255 (missing del grib2)
1315
1316IF (PRESENT(discipline)) THEN
1317 this%discipline = discipline
1318ELSE
1319 this%discipline = 255
1320ENDIF
1321
1322IF (PRESENT(description)) THEN
1323 this%description = description
1324ELSE
1325 this%description = cmiss
1326ENDIF
1327
1328IF (PRESENT(unit)) THEN
1329 this%unit = unit
1330ELSE
1331 this%unit = cmiss
1332ENDIF
1333
1334
1335
1336END SUBROUTINE volgrid6d_var_init
1337
1338
1339! documented in the interface
1340SUBROUTINE volgrid6d_var_delete(this)
1341TYPE(volgrid6d_var),INTENT(INOUT) :: this
1342
1343this%centre = imiss
1344this%category = imiss
1345this%number = imiss
1346this%discipline = imiss
1347this%description = cmiss
1348this%unit = cmiss
1349
1350END SUBROUTINE volgrid6d_var_delete
1351
1352
1353ELEMENTAL FUNCTION volgrid6d_var_c_e(this) RESULT(c_e)
1354TYPE(volgrid6d_var),INTENT(IN) :: this
1355LOGICAL :: c_e
1356c_e = this /= volgrid6d_var_miss
1357END FUNCTION volgrid6d_var_c_e
1358
1359
1360ELEMENTAL FUNCTION volgrid6d_var_eq(this, that) RESULT(res)
1361TYPE(volgrid6d_var),INTENT(IN) :: this, that
1362LOGICAL :: res
1363
1364IF (this%discipline == that%discipline) THEN
1365
1366 IF (this%discipline == 255) THEN ! grib1, WMO tables are all equivalent
1367 res = ((this%category == that%category) .OR. &
1368 (this%category >= 1 .AND. this%category <=3 .AND. &
1369 that%category >= 1 .AND. that%category <=3)) .AND. &
1370 this%number == that%number
1371
1372 IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
1373 (this%number >= 128 .AND. this%number <= 254)) THEN
1374 res = res .AND. this%centre == that%centre ! local definition, centre matters
1375 ENDIF
1376
1377 ELSE ! grib2
1378 res = this%category == that%category .AND. &
1379 this%number == that%number
1380
1381 IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
1382 (this%category >= 192 .AND. this%category <= 254) .OR. &
1383 (this%number >= 192 .AND. this%number <= 254)) THEN
1384 res = res .AND. this%centre == that%centre ! local definition, centre matters
1385 ENDIF
1386 ENDIF
1387
1388ELSE ! different edition or different discipline
1389 res = .false.
1390ENDIF
1391
1392END FUNCTION volgrid6d_var_eq
1393
1394
1395ELEMENTAL FUNCTION volgrid6d_var_ne(this, that) RESULT(res)
1396TYPE(volgrid6d_var),INTENT(IN) :: this, that
1397LOGICAL :: res
1398
1399res = .NOT.(this == that)
1400
1401END FUNCTION volgrid6d_var_ne
1402
1403
1404#include "array_utilities_inc.F90"
1405
1406
1408SUBROUTINE display_volgrid6d_var(this)
1409TYPE(volgrid6d_var),INTENT(in) :: this
1410
1411print*,"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
1412
1413END SUBROUTINE display_volgrid6d_var
1414
1415
1428SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
1429TYPE(volgrid6d_var),INTENT(in) :: vargrib(:)
1430TYPE(vol7d_var),INTENT(out) :: varbufr(:)
1431TYPE(conv_func),POINTER :: c_func(:)
1432
1433INTEGER :: i, n, stallo
1434
1435n = min(SIZE(varbufr), SIZE(vargrib))
1436ALLOCATE(c_func(n),stat=stallo)
1437IF (stallo /= 0) THEN
1438 call l4f_log(l4f_fatal,"allocating memory")
1439 call raise_fatal_error()
1440ENDIF
1441
1442DO i = 1, n
1443 varbufr(i) = convert(vargrib(i), c_func(i))
1444ENDDO
1445
1446END SUBROUTINE vargrib2varbufr
1447
1448
1459FUNCTION vargrib2varbufr_convert(vargrib, c_func) RESULT(convert)
1460TYPE(volgrid6d_var),INTENT(in) :: vargrib
1461TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
1462TYPE(vol7d_var) :: convert
1463
1464INTEGER :: i
1465
1466IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
1467
1468DO i = 1, SIZE(conv_fwd)
1469 IF (vargrib == conv_fwd(i)%vg6d_var) THEN
1470 convert = conv_fwd(i)%v7d_var
1471 IF (PRESENT(c_func)) c_func = conv_fwd(i)%c_func
1472 RETURN
1473 ENDIF
1474ENDDO
1475! not found
1476convert = vol7d_var_miss
1477IF (PRESENT(c_func)) c_func = conv_func_miss
1478
1479! set hint for backwards conversion
1480convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
1481 vargrib%discipline/)
1482
1483CALL l4f_log(l4f_warn, 'vargrib2varbufr: variable '// &
1484 trim(to_char(vargrib%centre))//':'//trim(to_char(vargrib%category))//':'// &
1485 trim(to_char(vargrib%number))//':'//trim(to_char(vargrib%discipline))// &
1486 ' not found in table')
1487
1488END FUNCTION vargrib2varbufr_convert
1489
1490
1506SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
1507TYPE(vol7d_var),INTENT(in) :: varbufr(:)
1508TYPE(volgrid6d_var),INTENT(out) :: vargrib(:)
1509TYPE(conv_func),POINTER :: c_func(:)
1510TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
1511
1512INTEGER :: i, n, stallo
1513
1514n = min(SIZE(varbufr), SIZE(vargrib))
1515ALLOCATE(c_func(n),stat=stallo)
1516IF (stallo /= 0) THEN
1517 CALL l4f_log(l4f_fatal,"allocating memory")
1518 CALL raise_fatal_error()
1519ENDIF
1520
1521DO i = 1, n
1522 vargrib(i) = convert(varbufr(i), c_func(i), grid_id_template)
1523ENDDO
1524
1525END SUBROUTINE varbufr2vargrib
1526
1527
1541FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template) RESULT(convert)
1542TYPE(vol7d_var),INTENT(in) :: varbufr
1543TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
1544TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
1545TYPE(volgrid6d_var) :: convert
1546
1547INTEGER :: i
1548#ifdef HAVE_LIBGRIBAPI
1549INTEGER :: gaid, editionnumber, category, centre
1550#endif
1551
1552IF (.NOT. ALLOCATED(conv_bwd)) CALL vg6d_v7d_var_conv_setup()
1553
1554#ifdef HAVE_LIBGRIBAPI
1555editionnumber=255; category=255; centre=255
1556#endif
1557IF (PRESENT(grid_id_template)) THEN
1558#ifdef HAVE_LIBGRIBAPI
1559 gaid = grid_id_get_gaid(grid_id_template)
1560 IF (c_e(gaid)) THEN
1561 CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
1562 IF (editionnumber == 1) THEN
1563 CALL grib_get(gaid,'gribTablesVersionNo',category)
1564 ENDIF
1565 CALL grib_get(gaid,'centre',centre)
1566 ENDIF
1567#endif
1568ENDIF
1569
1570DO i = 1, SIZE(conv_bwd)
1571 IF (varbufr == conv_bwd(i)%v7d_var) THEN
1572#ifdef HAVE_LIBGRIBAPI
1573 IF (editionnumber /= 255) THEN ! further check required (gaid present)
1574 IF (editionnumber == 1) THEN
1575 IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle ! wrong edition
1576 ELSE IF (editionnumber == 2) THEN
1577 IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle ! wrong edition
1578 ENDIF
1579 IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
1580 conv_bwd(i)%vg6d_var%centre /= centre) cycle ! wrong centre
1581 ENDIF
1582#endif
1583 convert = conv_bwd(i)%vg6d_var
1584 IF (PRESENT(c_func)) c_func = conv_bwd(i)%c_func
1585 RETURN
1586 ENDIF
1587ENDDO
1588! not found
1589convert = volgrid6d_var_miss
1590IF (PRESENT(c_func)) c_func = conv_func_miss
1591
1592! if hint available use it as a fallback
1593IF (any(varbufr%gribhint /= imiss)) THEN
1594 convert%centre = varbufr%gribhint(1)
1595 convert%category = varbufr%gribhint(2)
1596 convert%number = varbufr%gribhint(3)
1597 convert%discipline = varbufr%gribhint(4)
1598ENDIF
1599
1600CALL l4f_log(l4f_warn, 'varbufr2vargrib: variable '// &
1601 trim(varbufr%btable)//" : "//trim(varbufr%description)//" : "//trim(varbufr%unit)// &
1602 ' not found in table')
1603
1604END FUNCTION varbufr2vargrib_convert
1605
1606
1614SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
1615TYPE(volgrid6d_var),INTENT(inout) :: this
1616TYPE(conv_func),INTENT(out) :: c_func
1617TYPE(grid_id),INTENT(in) :: grid_id_template
1618
1619LOGICAL :: eqed, eqcentre
1620INTEGER :: gaid, editionnumber, centre
1621TYPE(volgrid6d_var) :: tmpgrib
1622TYPE(vol7d_var) :: tmpbufr
1623TYPE(conv_func) tmpc_func1, tmpc_func2
1624
1625eqed = .true.
1626eqcentre = .true.
1627c_func = conv_func_miss
1628
1629#ifdef HAVE_LIBGRIBAPI
1630gaid = grid_id_get_gaid(grid_id_template)
1631IF (c_e(gaid)) THEN
1632 CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
1633 CALL grib_get(gaid, 'centre', centre)
1634 eqed = editionnumber == 1 .EQV. this%discipline == 255
1635 eqcentre = centre == this%centre
1636ENDIF
1637#endif
1638
1639IF (eqed .AND. eqcentre) RETURN ! nothing to do
1640
1641tmpbufr = convert(this, tmpc_func1)
1642tmpgrib = convert(tmpbufr, tmpc_func2, grid_id_template)
1643
1644IF (tmpgrib /= volgrid6d_var_miss) THEN
1645! conversion back and forth successful, set also conversion function
1646 this = tmpgrib
1647 c_func = tmpc_func1 * tmpc_func2
1648! set to missing in common case to avoid useless computation
1649 IF (c_func == conv_func_identity) c_func = conv_func_miss
1650ELSE IF (.NOT.eqed) THEN
1651! conversion back and forth unsuccessful and grib edition incompatible, set to miss
1652 this = tmpgrib
1653ENDIF
1654
1655END SUBROUTINE volgrid6d_var_normalize
1656
1657
1658! Private subroutine for reading forward and backward conversion tables
1659! todo: better error handling
1660SUBROUTINE vg6d_v7d_var_conv_setup()
1661INTEGER :: un, i, n, stallo
1662
1663! forward, grib to bufr
1664un = open_package_file('vargrib2bufr.csv', filetype_data)
1665n=0
1666DO WHILE(.true.)
1667 READ(un,*,END=100)
1668 n = n + 1
1669ENDDO
1670
1671100 CONTINUE
1672
1673rewind(un)
1674ALLOCATE(conv_fwd(n),stat=stallo)
1675IF (stallo /= 0) THEN
1676 CALL l4f_log(l4f_fatal,"allocating memory")
1677 CALL raise_fatal_error()
1678ENDIF
1679
1680conv_fwd(:) = vg6d_v7d_var_conv_miss
1681CALL import_var_conv(un, conv_fwd)
1682CLOSE(un)
1683
1684! backward, bufr to grib
1685un = open_package_file('vargrib2bufr.csv', filetype_data)
1686! use the same file for now
1687!un = open_package_file('varbufr2grib.csv', filetype_data)
1688n=0
1689DO WHILE(.true.)
1690 READ(un,*,END=300)
1691 n = n + 1
1692ENDDO
1693
1694300 CONTINUE
1695
1696rewind(un)
1697ALLOCATE(conv_bwd(n),stat=stallo)
1698IF (stallo /= 0) THEN
1699 CALL l4f_log(l4f_fatal,"allocating memory")
1700 CALL raise_fatal_error()
1701end if
1702
1703conv_bwd(:) = vg6d_v7d_var_conv_miss
1704CALL import_var_conv(un, conv_bwd)
1705DO i = 1, n
1706 conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
1707 conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
1708ENDDO
1709CLOSE(un)
1710
1711CONTAINS
1712
1713SUBROUTINE import_var_conv(un, conv_type)
1714INTEGER, INTENT(in) :: un
1715TYPE(vg6d_v7d_var_conv), INTENT(out) :: conv_type(:)
1716
1717INTEGER :: i
1718TYPE(csv_record) :: csv
1719CHARACTER(len=1024) :: line
1720CHARACTER(len=10) :: btable
1721INTEGER :: centre, category, number, discipline
1722
1723DO i = 1, SIZE(conv_type)
1724 READ(un,'(A)',END=200)line
1725 CALL init(csv, line)
1726 CALL csv_record_getfield(csv, btable)
1727 CALL csv_record_getfield(csv) ! skip fields for description and unit,
1728 CALL csv_record_getfield(csv) ! they correspond to grib information, not bufr Btable
1729 CALL init(conv_type(i)%v7d_var, btable=btable)
1730
1731 CALL csv_record_getfield(csv, centre)
1732 CALL csv_record_getfield(csv, category)
1733 CALL csv_record_getfield(csv, number)
1734 CALL csv_record_getfield(csv, discipline)
1735 CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
1736 number=number, discipline=discipline) ! controllare l'ordine
1737
1738 CALL csv_record_getfield(csv, conv_type(i)%c_func%a)
1739 CALL csv_record_getfield(csv, conv_type(i)%c_func%b)
1740 CALL delete(csv)
1741ENDDO
1742
1743200 CONTINUE
1744
1745END SUBROUTINE import_var_conv
1746
1747END SUBROUTINE vg6d_v7d_var_conv_setup
1748
1749
1750ELEMENTAL FUNCTION conv_func_eq(this, that) RESULT(res)
1751TYPE(conv_func),INTENT(IN) :: this, that
1752LOGICAL :: res
1753
1754res = this%a == that%a .AND. this%b == that%b
1755
1756END FUNCTION conv_func_eq
1757
1758
1759ELEMENTAL FUNCTION conv_func_ne(this, that) RESULT(res)
1760TYPE(conv_func),INTENT(IN) :: this, that
1761LOGICAL :: res
1762
1763res = .NOT.(this == that)
1764
1765END FUNCTION conv_func_ne
1766
1767
1768FUNCTION conv_func_mult(this, that) RESULT(mult)
1769TYPE(conv_func),INTENT(in) :: this
1770TYPE(conv_func),INTENT(in) :: that
1771
1772TYPE(conv_func) :: mult
1773
1774IF (this == conv_func_miss .OR. that == conv_func_miss) THEN
1775 mult = conv_func_miss
1776ELSE
1777 mult%a = this%a*that%a
1778 mult%b = this%a*that%b+this%b
1779ENDIF
1780
1781END FUNCTION conv_func_mult
1782
1790ELEMENTAL SUBROUTINE conv_func_compute(this, values)
1791TYPE(conv_func),INTENT(in) :: this
1792REAL,INTENT(inout) :: values
1793
1794IF (this /= conv_func_miss) THEN
1795 IF (c_e(values)) values = values*this%a + this%b
1796ELSE
1797 values=rmiss
1798ENDIF
1799
1800END SUBROUTINE conv_func_compute
1801
1802
1810ELEMENTAL FUNCTION conv_func_convert(this, values) RESULT(convert)
1811TYPE(conv_func),intent(in) :: this
1812REAL,INTENT(in) :: values
1813REAL :: convert
1814
1815convert = values
1816CALL compute(this, convert)
1817
1818END FUNCTION conv_func_convert
1819
1820
1834SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
1835TYPE(volgrid6d_var),INTENT(in) :: this(:)
1836INTEGER,POINTER :: xind(:), yind(:)
1837
1838TYPE(vol7d_var) :: varbufr(SIZE(this))
1839TYPE(conv_func),POINTER :: c_func(:)
1840INTEGER :: i, nv, counts(SIZE(vol7d_var_horcomp))
1841
1842NULLIFY(xind, yind)
1843counts(:) = 0
1844
1845CALL vargrib2varbufr(this, varbufr, c_func)
1846
1847DO i = 1, SIZE(vol7d_var_horcomp)
1848 counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
1849ENDDO
1850
1851IF (any(counts(1::2) > 1)) THEN
1852 CALL l4f_log(l4f_warn, '> 1 variable refer to x component of the same field, (un)rotation impossible')
1853 DEALLOCATE(c_func)
1854 RETURN
1855ENDIF
1856IF (any(counts(2::2) > 1)) THEN
1857 CALL l4f_log(l4f_warn, '> 1 variable refer to y component of the same field, (un)rotation impossible')
1858 DEALLOCATE(c_func)
1859 RETURN
1860ENDIF
1861
1862! check that variables are paired and count pairs
1863nv = 0
1864DO i = 1, SIZE(vol7d_var_horcomp), 2
1865 IF (counts(i) == 0 .AND. counts(i+1) > 0) THEN
1866 CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
1867 ' present but the corresponding x-component '// &
1868 trim(vol7d_var_horcomp(i)%btable)//' is missing, (un)rotation impossible')
1869 RETURN
1870 ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0) THEN
1871 CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i)%btable)// &
1872 ' present but the corresponding y-component '// &
1873 trim(vol7d_var_horcomp(i+1)%btable)//' is missing, (un)rotation impossible')
1874 RETURN
1875 ENDIF
1876 IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
1877ENDDO
1878
1879! repeat the loop storing indices
1880ALLOCATE(xind(nv), yind(nv))
1881nv = 0
1882DO i = 1, SIZE(vol7d_var_horcomp), 2
1883 IF (counts(i) == 1 .AND. counts(i+1) == 1) THEN
1884 nv = nv + 1
1885 xind(nv) = index(varbufr(:), vol7d_var_horcomp(i))
1886 yind(nv) = index(varbufr(:), vol7d_var_horcomp(i+1))
1887 ENDIF
1888ENDDO
1889DEALLOCATE(c_func)
1890
1891END SUBROUTINE volgrid6d_var_hor_comp_index
1892
1893
1898FUNCTION volgrid6d_var_is_hor_comp(this) RESULT(is_hor_comp)
1899TYPE(volgrid6d_var),INTENT(in) :: this
1900LOGICAL :: is_hor_comp
1901
1902TYPE(vol7d_var) :: varbufr
1903
1904varbufr = convert(this)
1905is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
1906
1907END FUNCTION volgrid6d_var_is_hor_comp
1908
1909! before unstaggering??
1910
1911!IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
1912!
1913!call init(varu,btable="B11003")
1914!call init(varv,btable="B11004")
1915!
1916! test about presence of u and v in standard table
1917!if ( index(conv_fwd(:)%v7d_var,varu) == 0 .or. index(conv_fwd(:)%v7d_var,varv) == 0 )then
1918! call l4f_category_log(this%category,L4F_FATAL, &
1919! "variables B11003 and/or B11004 (wind components) not defined by vg6d_v7d_var_conv_setup")
1920! CALL raise_error()
1921! RETURN
1922!end if
1923!
1924!if (associated(this%var))then
1925! nvar=size(this%var)
1926! allocate(varbufr(nvar),stat=stallo)
1927! if (stallo /=0)then
1928! call l4f_log(L4F_FATAL,"allocating memory")
1929! call raise_fatal_error("allocating memory")
1930! end if
1931!
1932! CALL vargrib2varbufr(this%var, varbufr)
1933!ELSE
1934! CALL l4f_category_log(this%category, L4F_ERROR, &
1935! "trying to destagger an incomplete volgrid6d object")
1936! CALL raise_error()
1937! RETURN
1938!end if
1939!
1940!nvaru=COUNT(varbufr==varu)
1941!nvarv=COUNT(varbufr==varv)
1942!
1943!if (nvaru > 1 )then
1944! call l4f_category_log(this%category,L4F_WARN, &
1945! ">1 variables refer to u wind component, destaggering will not be done ")
1946! DEALLOCATE(varbufr)
1947! RETURN
1948!endif
1949!
1950!if (nvarv > 1 )then
1951! call l4f_category_log(this%category,L4F_WARN, &
1952! ">1 variables refer to v wind component, destaggering will not be done ")
1953! DEALLOCATE(varbufr)
1954! RETURN
1955!endif
1956!
1957!if (nvaru == 0 .and. nvarv == 0) then
1958! call l4f_category_log(this%category,L4F_WARN, &
1959! "no u or v wind component found in volume, nothing to do")
1960! DEALLOCATE(varbufr)
1961! RETURN
1962!endif
1963!
1964!if (COUNT(varbufr/=varu .and. varbufr/=varv) > 0) then
1965! call l4f_category_log(this%category,L4F_WARN, &
1966! "there are variables different from u and v wind component in C grid")
1967!endif
1968
1969
1970END MODULE volgrid6d_var_class
Index method.
Apply the conversion function this to values.
Apply the conversion function this to values.
Destructor for the corresponding object, it assigns it to a missing value.
Display on the screen a brief content of object.
Initialize a volgrid6d_var object with the optional arguments provided.
Gestione degli errori.
Utilities for managing files.
This module defines an abstract interface to different drivers for access to files containing gridded...
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.
Classe per la gestione delle variabili osservate da stazioni meteo e affini.
Class for managing physical variables in a grib 1/2 fashion.
Definisce una variabile meteorologica osservata o un suo attributo.
Class defining a real conversion function between units.
Definition of a physical variable in grib coding style.

Generated with Doxygen.