libsim Versione 7.2.1

◆ index_var6d()

integer function index_var6d ( type(volgrid6d_var), dimension(:), intent(in) vect,
type(volgrid6d_var), intent(in) search,
logical, dimension(:), intent(in), optional mask,
logical, intent(in), optional back,
integer, intent(in), optional cache )

Cerca l'indice del primo o ultimo elemento di vect uguale a search.

Definizione alla linea 996 del file volgrid6d_var_class.F90.

998! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
999! authors:
1000! Davide Cesari <dcesari@arpa.emr.it>
1001! Paolo Patruno <ppatruno@arpa.emr.it>
1002
1003! This program is free software; you can redistribute it and/or
1004! modify it under the terms of the GNU General Public License as
1005! published by the Free Software Foundation; either version 2 of
1006! the License, or (at your option) any later version.
1007
1008! This program is distributed in the hope that it will be useful,
1009! but WITHOUT ANY WARRANTY; without even the implied warranty of
1010! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1011! GNU General Public License for more details.
1012
1013! You should have received a copy of the GNU General Public License
1014! along with this program. If not, see <http://www.gnu.org/licenses/>.
1015#include "config.h"
1016
1028USE kinds
1030USE err_handling
1033USE grid_id_class
1034
1035IMPLICIT NONE
1036
1041TYPE volgrid6d_var
1042 integer :: centre
1043 integer :: category
1044 integer :: number
1045 integer :: discipline
1046 CHARACTER(len=65) :: description
1047 CHARACTER(len=24) :: unit
1048END TYPE volgrid6d_var
1049
1050TYPE(volgrid6d_var),PARAMETER :: volgrid6d_var_miss= &
1051 volgrid6d_var(imiss,imiss,imiss,imiss,cmiss,cmiss)
1052
1053TYPE(vol7d_var),PARAMETER :: vol7d_var_horstag(2) = (/ &
1054 vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
1055 vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0) &
1056 /)
1057
1058TYPE(vol7d_var),PARAMETER :: vol7d_var_horcomp(4) = (/ &! RESHAPE( (/ &
1059 vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
1060 vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0), &
1061 vol7d_var('B11200', '', '', 0, 0, 0, 0, 0, 0), &
1062 vol7d_var('B11201', '', '', 0, 0, 0, 0, 0, 0) &
1063/)
1064!/), (/2,2/)) ! bug in gfortran
1065
1074TYPE conv_func
1075 PRIVATE
1076 REAL :: a, b
1077END TYPE conv_func
1078
1079TYPE(conv_func), PARAMETER :: conv_func_miss=conv_func(rmiss,rmiss)
1080TYPE(conv_func), PARAMETER :: conv_func_identity=conv_func(1.0,0.0)
1081
1082TYPE vg6d_v7d_var_conv
1083 TYPE(volgrid6d_var) :: vg6d_var
1084 TYPE(vol7d_var) :: v7d_var
1085 TYPE(conv_func) :: c_func
1086! aggiungere informazioni ad es. su rotazione del vento
1087END TYPE vg6d_v7d_var_conv
1088
1089TYPE(vg6d_v7d_var_conv), PARAMETER :: vg6d_v7d_var_conv_miss= &
1090 vg6d_v7d_var_conv(volgrid6d_var_miss, vol7d_var_miss, conv_func_miss)
1091
1092TYPE(vg6d_v7d_var_conv), ALLOCATABLE :: conv_fwd(:), conv_bwd(:)
1093
1107INTERFACE init
1108 MODULE PROCEDURE volgrid6d_var_init
1109END INTERFACE
1110
1113INTERFACE delete
1114 MODULE PROCEDURE volgrid6d_var_delete
1115END INTERFACE
1116
1117INTERFACE c_e
1118 MODULE PROCEDURE volgrid6d_var_c_e
1119END INTERFACE
1120
1121
1126INTERFACE OPERATOR (==)
1127 MODULE PROCEDURE volgrid6d_var_eq, conv_func_eq
1128END INTERFACE
1129
1134INTERFACE OPERATOR (/=)
1135 MODULE PROCEDURE volgrid6d_var_ne, conv_func_ne
1136END INTERFACE
1137
1138#define VOL7D_POLY_TYPE TYPE(volgrid6d_var)
1139#define VOL7D_POLY_TYPES _var6d
1140#include "array_utilities_pre.F90"
1141
1143INTERFACE display
1144 MODULE PROCEDURE display_volgrid6d_var
1145END INTERFACE
1146
1151INTERFACE OPERATOR (*)
1152 MODULE PROCEDURE conv_func_mult
1153END INTERFACE OPERATOR (*)
1154
1157INTERFACE compute
1158 MODULE PROCEDURE conv_func_compute
1159END INTERFACE
1160
1163INTERFACE convert
1164 MODULE PROCEDURE varbufr2vargrib_convert, vargrib2varbufr_convert, &
1165 conv_func_convert
1166END INTERFACE
1167
1168PRIVATE
1169PUBLIC volgrid6d_var, volgrid6d_var_miss, volgrid6d_var_new, init, delete, &
1170 c_e, volgrid6d_var_normalize, &
1171 OPERATOR(==), OPERATOR(/=), OPERATOR(*), &
1172 count_distinct, pack_distinct, count_and_pack_distinct, &
1173 map_distinct, map_inv_distinct, &
1174 index, display, &
1175 vargrib2varbufr, varbufr2vargrib, &
1176 conv_func, conv_func_miss, compute, convert, &
1177 volgrid6d_var_hor_comp_index, volgrid6d_var_is_hor_comp
1178
1179
1180CONTAINS
1181
1182
1183ELEMENTAL FUNCTION volgrid6d_var_new(centre, category, number, &
1184 discipline, description, unit) RESULT(this)
1185integer,INTENT(in),OPTIONAL :: centre
1186integer,INTENT(in),OPTIONAL :: category
1187integer,INTENT(in),OPTIONAL :: number
1188integer,INTENT(in),OPTIONAL :: discipline
1189CHARACTER(len=*),INTENT(in),OPTIONAL :: description
1190CHARACTER(len=*),INTENT(in),OPTIONAL :: unit
1191
1192TYPE(volgrid6d_var) :: this
1193
1194CALL init(this, centre, category, number, discipline, description, unit)
1195
1196END FUNCTION volgrid6d_var_new
1197
1198
1199! documented in the interface
1200ELEMENTAL SUBROUTINE volgrid6d_var_init(this, centre, category, number, discipline,description,unit)
1201TYPE(volgrid6d_var),INTENT(INOUT) :: this ! object to be initialized
1202INTEGER,INTENT(in),OPTIONAL :: centre ! centre
1203INTEGER,INTENT(in),OPTIONAL :: category ! grib2: category / grib1: grib table version number
1204INTEGER,INTENT(in),OPTIONAL :: number ! parameter number
1205INTEGER,INTENT(in),OPTIONAL :: discipline ! grib2: discipline / grib1: 255
1206CHARACTER(len=*),INTENT(in),OPTIONAL :: description ! optional textual description of the variable
1207CHARACTER(len=*),INTENT(in),OPTIONAL :: unit ! optional textual description of the variable's unit
1208
1209IF (PRESENT(centre)) THEN
1210 this%centre = centre
1211ELSE
1212 this%centre = imiss
1213 this%category = imiss
1214 this%number = imiss
1215 this%discipline = imiss
1216 RETURN
1217ENDIF
1218
1219IF (PRESENT(category)) THEN
1220 this%category = category
1221ELSE
1222 this%category = imiss
1223 this%number = imiss
1224 this%discipline = imiss
1225 RETURN
1226ENDIF
1227
1228
1229IF (PRESENT(number)) THEN
1230 this%number = number
1231ELSE
1232 this%number = imiss
1233 this%discipline = imiss
1234 RETURN
1235ENDIF
1236
1237! se sono arrivato fino a qui ho impostato centre, category e number
1238!per il grib 1 manca discipline e imposto 255 (missing del grib2)
1239
1240IF (PRESENT(discipline)) THEN
1241 this%discipline = discipline
1242ELSE
1243 this%discipline = 255
1244ENDIF
1245
1246IF (PRESENT(description)) THEN
1247 this%description = description
1248ELSE
1249 this%description = cmiss
1250ENDIF
1251
1252IF (PRESENT(unit)) THEN
1253 this%unit = unit
1254ELSE
1255 this%unit = cmiss
1256ENDIF
1257
1258
1259
1260END SUBROUTINE volgrid6d_var_init
1261
1262
1263! documented in the interface
1264SUBROUTINE volgrid6d_var_delete(this)
1265TYPE(volgrid6d_var),INTENT(INOUT) :: this
1266
1267this%centre = imiss
1268this%category = imiss
1269this%number = imiss
1270this%discipline = imiss
1271this%description = cmiss
1272this%unit = cmiss
1273
1274END SUBROUTINE volgrid6d_var_delete
1275
1276
1277ELEMENTAL FUNCTION volgrid6d_var_c_e(this) RESULT(c_e)
1278TYPE(volgrid6d_var),INTENT(IN) :: this
1279LOGICAL :: c_e
1280c_e = this /= volgrid6d_var_miss
1281END FUNCTION volgrid6d_var_c_e
1282
1283
1284ELEMENTAL FUNCTION volgrid6d_var_eq(this, that) RESULT(res)
1285TYPE(volgrid6d_var),INTENT(IN) :: this, that
1286LOGICAL :: res
1287
1288IF (this%discipline == that%discipline) THEN
1289
1290 IF (this%discipline == 255) THEN ! grib1, WMO tables are all equivalent
1291 res = ((this%category == that%category) .OR. &
1292 (this%category >= 1 .AND. this%category <=3 .AND. &
1293 that%category >= 1 .AND. that%category <=3)) .AND. &
1294 this%number == that%number
1295
1296 IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
1297 (this%number >= 128 .AND. this%number <= 254)) THEN
1298 res = res .AND. this%centre == that%centre ! local definition, centre matters
1299 ENDIF
1300
1301 ELSE ! grib2
1302 res = this%category == that%category .AND. &
1303 this%number == that%number
1304
1305 IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
1306 (this%category >= 192 .AND. this%category <= 254) .OR. &
1307 (this%number >= 192 .AND. this%number <= 254)) THEN
1308 res = res .AND. this%centre == that%centre ! local definition, centre matters
1309 ENDIF
1310 ENDIF
1311
1312ELSE ! different edition or different discipline
1313 res = .false.
1314ENDIF
1315
1316END FUNCTION volgrid6d_var_eq
1317
1318
1319ELEMENTAL FUNCTION volgrid6d_var_ne(this, that) RESULT(res)
1320TYPE(volgrid6d_var),INTENT(IN) :: this, that
1321LOGICAL :: res
1322
1323res = .NOT.(this == that)
1324
1325END FUNCTION volgrid6d_var_ne
1326
1327
1328#include "array_utilities_inc.F90"
1329
1330
1332SUBROUTINE display_volgrid6d_var(this)
1333TYPE(volgrid6d_var),INTENT(in) :: this
1334
1335print*,"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
1336
1337END SUBROUTINE display_volgrid6d_var
1338
1339
1352SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
1353TYPE(volgrid6d_var),INTENT(in) :: vargrib(:)
1354TYPE(vol7d_var),INTENT(out) :: varbufr(:)
1355TYPE(conv_func),POINTER :: c_func(:)
1356
1357INTEGER :: i, n, stallo
1358
1359n = min(SIZE(varbufr), SIZE(vargrib))
1360ALLOCATE(c_func(n),stat=stallo)
1361IF (stallo /= 0) THEN
1362 call l4f_log(l4f_fatal,"allocating memory")
1363 call raise_fatal_error()
1364ENDIF
1365
1366DO i = 1, n
1367 varbufr(i) = convert(vargrib(i), c_func(i))
1368ENDDO
1369
1370END SUBROUTINE vargrib2varbufr
1371
1372
1383FUNCTION vargrib2varbufr_convert(vargrib, c_func) RESULT(convert)
1384TYPE(volgrid6d_var),INTENT(in) :: vargrib
1385TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
1386TYPE(vol7d_var) :: convert
1387
1388INTEGER :: i
1389
1390IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
1391
1392DO i = 1, SIZE(conv_fwd)
1393 IF (vargrib == conv_fwd(i)%vg6d_var) THEN
1394 convert = conv_fwd(i)%v7d_var
1395 IF (PRESENT(c_func)) c_func = conv_fwd(i)%c_func
1396 RETURN
1397 ENDIF
1398ENDDO
1399! not found
1400convert = vol7d_var_miss
1401IF (PRESENT(c_func)) c_func = conv_func_miss
1402
1403! set hint for backwards conversion
1404convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
1405 vargrib%discipline/)
1406
1407CALL l4f_log(l4f_warn, 'vargrib2varbufr: variable '// &
1408 trim(to_char(vargrib%centre))//':'//trim(to_char(vargrib%category))//':'// &
1409 trim(to_char(vargrib%number))//':'//trim(to_char(vargrib%discipline))// &
1410 ' not found in table')
1411
1412END FUNCTION vargrib2varbufr_convert
1413
1414
1430SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
1431TYPE(vol7d_var),INTENT(in) :: varbufr(:)
1432TYPE(volgrid6d_var),INTENT(out) :: vargrib(:)
1433TYPE(conv_func),POINTER :: c_func(:)
1434TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
1435
1436INTEGER :: i, n, stallo
1437
1438n = min(SIZE(varbufr), SIZE(vargrib))
1439ALLOCATE(c_func(n),stat=stallo)
1440IF (stallo /= 0) THEN
1441 CALL l4f_log(l4f_fatal,"allocating memory")
1442 CALL raise_fatal_error()
1443ENDIF
1444
1445DO i = 1, n
1446 vargrib(i) = convert(varbufr(i), c_func(i), grid_id_template)
1447ENDDO
1448
1449END SUBROUTINE varbufr2vargrib
1450
1451
1465FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template) RESULT(convert)
1466TYPE(vol7d_var),INTENT(in) :: varbufr
1467TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
1468TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
1469TYPE(volgrid6d_var) :: convert
1470
1471INTEGER :: i
1472#ifdef HAVE_LIBGRIBAPI
1473INTEGER :: gaid, editionnumber, category, centre
1474#endif
1475
1476IF (.NOT. ALLOCATED(conv_bwd)) CALL vg6d_v7d_var_conv_setup()
1477
1478#ifdef HAVE_LIBGRIBAPI
1479editionnumber=255; category=255; centre=255
1480#endif
1481IF (PRESENT(grid_id_template)) THEN
1482#ifdef HAVE_LIBGRIBAPI
1483 gaid = grid_id_get_gaid(grid_id_template)
1484 IF (c_e(gaid)) THEN
1485 CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
1486 IF (editionnumber == 1) THEN
1487 CALL grib_get(gaid,'gribTablesVersionNo',category)
1488 ENDIF
1489 CALL grib_get(gaid,'centre',centre)
1490 ENDIF
1491#endif
1492ENDIF
1493
1494DO i = 1, SIZE(conv_bwd)
1495 IF (varbufr == conv_bwd(i)%v7d_var) THEN
1496#ifdef HAVE_LIBGRIBAPI
1497 IF (editionnumber /= 255) THEN ! further check required (gaid present)
1498 IF (editionnumber == 1) THEN
1499 IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle ! wrong edition
1500 ELSE IF (editionnumber == 2) THEN
1501 IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle ! wrong edition
1502 ENDIF
1503 IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
1504 conv_bwd(i)%vg6d_var%centre /= centre) cycle ! wrong centre
1505 ENDIF
1506#endif
1507 convert = conv_bwd(i)%vg6d_var
1508 IF (PRESENT(c_func)) c_func = conv_bwd(i)%c_func
1509 RETURN
1510 ENDIF
1511ENDDO
1512! not found
1513convert = volgrid6d_var_miss
1514IF (PRESENT(c_func)) c_func = conv_func_miss
1515
1516! if hint available use it as a fallback
1517IF (any(varbufr%gribhint /= imiss)) THEN
1518 convert%centre = varbufr%gribhint(1)
1519 convert%category = varbufr%gribhint(2)
1520 convert%number = varbufr%gribhint(3)
1521 convert%discipline = varbufr%gribhint(4)
1522ENDIF
1523
1524CALL l4f_log(l4f_warn, 'varbufr2vargrib: variable '// &
1525 trim(varbufr%btable)//" : "//trim(varbufr%description)//" : "//trim(varbufr%unit)// &
1526 ' not found in table')
1527
1528END FUNCTION varbufr2vargrib_convert
1529
1530
1538SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
1539TYPE(volgrid6d_var),INTENT(inout) :: this
1540TYPE(conv_func),INTENT(out) :: c_func
1541TYPE(grid_id),INTENT(in) :: grid_id_template
1542
1543LOGICAL :: eqed, eqcentre
1544INTEGER :: gaid, editionnumber, centre
1545TYPE(volgrid6d_var) :: tmpgrib
1546TYPE(vol7d_var) :: tmpbufr
1547TYPE(conv_func) tmpc_func1, tmpc_func2
1548
1549eqed = .true.
1550eqcentre = .true.
1551c_func = conv_func_miss
1552
1553#ifdef HAVE_LIBGRIBAPI
1554gaid = grid_id_get_gaid(grid_id_template)
1555IF (c_e(gaid)) THEN
1556 CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
1557 CALL grib_get(gaid, 'centre', centre)
1558 eqed = editionnumber == 1 .EQV. this%discipline == 255
1559 eqcentre = centre == this%centre
1560ENDIF
1561#endif
1562
1563IF (eqed .AND. eqcentre) RETURN ! nothing to do
1564
1565tmpbufr = convert(this, tmpc_func1)
1566tmpgrib = convert(tmpbufr, tmpc_func2, grid_id_template)
1567
1568IF (tmpgrib /= volgrid6d_var_miss) THEN
1569! conversion back and forth successful, set also conversion function
1570 this = tmpgrib
1571 c_func = tmpc_func1 * tmpc_func2
1572! set to missing in common case to avoid useless computation
1573 IF (c_func == conv_func_identity) c_func = conv_func_miss
1574ELSE IF (.NOT.eqed) THEN
1575! conversion back and forth unsuccessful and grib edition incompatible, set to miss
1576 this = tmpgrib
1577ENDIF
1578
1579END SUBROUTINE volgrid6d_var_normalize
1580
1581
1582! Private subroutine for reading forward and backward conversion tables
1583! todo: better error handling
1584SUBROUTINE vg6d_v7d_var_conv_setup()
1585INTEGER :: un, i, n, stallo
1586
1587! forward, grib to bufr
1588un = open_package_file('vargrib2bufr.csv', filetype_data)
1589n=0
1590DO WHILE(.true.)
1591 READ(un,*,END=100)
1592 n = n + 1
1593ENDDO
1594
1595100 CONTINUE
1596
1597rewind(un)
1598ALLOCATE(conv_fwd(n),stat=stallo)
1599IF (stallo /= 0) THEN
1600 CALL l4f_log(l4f_fatal,"allocating memory")
1601 CALL raise_fatal_error()
1602ENDIF
1603
1604conv_fwd(:) = vg6d_v7d_var_conv_miss
1605CALL import_var_conv(un, conv_fwd)
1606CLOSE(un)
1607
1608! backward, bufr to grib
1609un = open_package_file('vargrib2bufr.csv', filetype_data)
1610! use the same file for now
1611!un = open_package_file('varbufr2grib.csv', filetype_data)
1612n=0
1613DO WHILE(.true.)
1614 READ(un,*,END=300)
1615 n = n + 1
1616ENDDO
1617
1618300 CONTINUE
1619
1620rewind(un)
1621ALLOCATE(conv_bwd(n),stat=stallo)
1622IF (stallo /= 0) THEN
1623 CALL l4f_log(l4f_fatal,"allocating memory")
1624 CALL raise_fatal_error()
1625end if
1626
1627conv_bwd(:) = vg6d_v7d_var_conv_miss
1628CALL import_var_conv(un, conv_bwd)
1629DO i = 1, n
1630 conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
1631 conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
1632ENDDO
1633CLOSE(un)
1634
1635CONTAINS
1636
1637SUBROUTINE import_var_conv(un, conv_type)
1638INTEGER, INTENT(in) :: un
1639TYPE(vg6d_v7d_var_conv), INTENT(out) :: conv_type(:)
1640
1641INTEGER :: i
1642TYPE(csv_record) :: csv
1643CHARACTER(len=1024) :: line
1644CHARACTER(len=10) :: btable
1645INTEGER :: centre, category, number, discipline
1646
1647DO i = 1, SIZE(conv_type)
1648 READ(un,'(A)',END=200)line
1649 CALL init(csv, line)
1650 CALL csv_record_getfield(csv, btable)
1651 CALL csv_record_getfield(csv) ! skip fields for description and unit,
1652 CALL csv_record_getfield(csv) ! they correspond to grib information, not bufr Btable
1653 CALL init(conv_type(i)%v7d_var, btable=btable)
1654
1655 CALL csv_record_getfield(csv, centre)
1656 CALL csv_record_getfield(csv, category)
1657 CALL csv_record_getfield(csv, number)
1658 CALL csv_record_getfield(csv, discipline)
1659 CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
1660 number=number, discipline=discipline) ! controllare l'ordine
1661
1662 CALL csv_record_getfield(csv, conv_type(i)%c_func%a)
1663 CALL csv_record_getfield(csv, conv_type(i)%c_func%b)
1664 CALL delete(csv)
1665ENDDO
1666
1667200 CONTINUE
1668
1669END SUBROUTINE import_var_conv
1670
1671END SUBROUTINE vg6d_v7d_var_conv_setup
1672
1673
1674ELEMENTAL FUNCTION conv_func_eq(this, that) RESULT(res)
1675TYPE(conv_func),INTENT(IN) :: this, that
1676LOGICAL :: res
1677
1678res = this%a == that%a .AND. this%b == that%b
1679
1680END FUNCTION conv_func_eq
1681
1682
1683ELEMENTAL FUNCTION conv_func_ne(this, that) RESULT(res)
1684TYPE(conv_func),INTENT(IN) :: this, that
1685LOGICAL :: res
1686
1687res = .NOT.(this == that)
1688
1689END FUNCTION conv_func_ne
1690
1691
1692FUNCTION conv_func_mult(this, that) RESULT(mult)
1693TYPE(conv_func),INTENT(in) :: this
1694TYPE(conv_func),INTENT(in) :: that
1695
1696TYPE(conv_func) :: mult
1697
1698IF (this == conv_func_miss .OR. that == conv_func_miss) THEN
1699 mult = conv_func_miss
1700ELSE
1701 mult%a = this%a*that%a
1702 mult%b = this%a*that%b+this%b
1703ENDIF
1704
1705END FUNCTION conv_func_mult
1706
1714ELEMENTAL SUBROUTINE conv_func_compute(this, values)
1715TYPE(conv_func),INTENT(in) :: this
1716REAL,INTENT(inout) :: values
1717
1718IF (this /= conv_func_miss) THEN
1719 IF (c_e(values)) values = values*this%a + this%b
1720ELSE
1721 values=rmiss
1722ENDIF
1723
1724END SUBROUTINE conv_func_compute
1725
1726
1734ELEMENTAL FUNCTION conv_func_convert(this, values) RESULT(convert)
1735TYPE(conv_func),intent(in) :: this
1736REAL,INTENT(in) :: values
1737REAL :: convert
1738
1739convert = values
1740CALL compute(this, convert)
1741
1742END FUNCTION conv_func_convert
1743
1744
1758SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
1759TYPE(volgrid6d_var),INTENT(in) :: this(:)
1760INTEGER,POINTER :: xind(:), yind(:)
1761
1762TYPE(vol7d_var) :: varbufr(SIZE(this))
1763TYPE(conv_func),POINTER :: c_func(:)
1764INTEGER :: i, nv, counts(SIZE(vol7d_var_horcomp))
1765
1766NULLIFY(xind, yind)
1767counts(:) = 0
1768
1769CALL vargrib2varbufr(this, varbufr, c_func)
1770
1771DO i = 1, SIZE(vol7d_var_horcomp)
1772 counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
1773ENDDO
1774
1775IF (any(counts(1::2) > 1)) THEN
1776 CALL l4f_log(l4f_warn, '> 1 variable refer to x component of the same field, (un)rotation impossible')
1777 DEALLOCATE(c_func)
1778 RETURN
1779ENDIF
1780IF (any(counts(2::2) > 1)) THEN
1781 CALL l4f_log(l4f_warn, '> 1 variable refer to y component of the same field, (un)rotation impossible')
1782 DEALLOCATE(c_func)
1783 RETURN
1784ENDIF
1785
1786! check that variables are paired and count pairs
1787nv = 0
1788DO i = 1, SIZE(vol7d_var_horcomp), 2
1789 IF (counts(i) == 0 .AND. counts(i+1) > 0) THEN
1790 CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
1791 ' present but the corresponding x-component '// &
1792 trim(vol7d_var_horcomp(i)%btable)//' is missing, (un)rotation impossible')
1793 RETURN
1794 ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0) THEN
1795 CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i)%btable)// &
1796 ' present but the corresponding y-component '// &
1797 trim(vol7d_var_horcomp(i+1)%btable)//' is missing, (un)rotation impossible')
1798 RETURN
1799 ENDIF
1800 IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
1801ENDDO
1802
1803! repeat the loop storing indices
1804ALLOCATE(xind(nv), yind(nv))
1805nv = 0
1806DO i = 1, SIZE(vol7d_var_horcomp), 2
1807 IF (counts(i) == 1 .AND. counts(i+1) == 1) THEN
1808 nv = nv + 1
1809 xind(nv) = index(varbufr(:), vol7d_var_horcomp(i))
1810 yind(nv) = index(varbufr(:), vol7d_var_horcomp(i+1))
1811 ENDIF
1812ENDDO
1813DEALLOCATE(c_func)
1814
1815END SUBROUTINE volgrid6d_var_hor_comp_index
1816
1817
1822FUNCTION volgrid6d_var_is_hor_comp(this) RESULT(is_hor_comp)
1823TYPE(volgrid6d_var),INTENT(in) :: this
1824LOGICAL :: is_hor_comp
1825
1826TYPE(vol7d_var) :: varbufr
1827
1828varbufr = convert(this)
1829is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
1830
1831END FUNCTION volgrid6d_var_is_hor_comp
1832
1833! before unstaggering??
1834
1835!IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
1836!
1837!call init(varu,btable="B11003")
1838!call init(varv,btable="B11004")
1839!
1840! test about presence of u and v in standard table
1841!if ( index(conv_fwd(:)%v7d_var,varu) == 0 .or. index(conv_fwd(:)%v7d_var,varv) == 0 )then
1842! call l4f_category_log(this%category,L4F_FATAL, &
1843! "variables B11003 and/or B11004 (wind components) not defined by vg6d_v7d_var_conv_setup")
1844! CALL raise_error()
1845! RETURN
1846!end if
1847!
1848!if (associated(this%var))then
1849! nvar=size(this%var)
1850! allocate(varbufr(nvar),stat=stallo)
1851! if (stallo /=0)then
1852! call l4f_log(L4F_FATAL,"allocating memory")
1853! call raise_fatal_error("allocating memory")
1854! end if
1855!
1856! CALL vargrib2varbufr(this%var, varbufr)
1857!ELSE
1858! CALL l4f_category_log(this%category, L4F_ERROR, &
1859! "trying to destagger an incomplete volgrid6d object")
1860! CALL raise_error()
1861! RETURN
1862!end if
1863!
1864!nvaru=COUNT(varbufr==varu)
1865!nvarv=COUNT(varbufr==varv)
1866!
1867!if (nvaru > 1 )then
1868! call l4f_category_log(this%category,L4F_WARN, &
1869! ">1 variables refer to u wind component, destaggering will not be done ")
1870! DEALLOCATE(varbufr)
1871! RETURN
1872!endif
1873!
1874!if (nvarv > 1 )then
1875! call l4f_category_log(this%category,L4F_WARN, &
1876! ">1 variables refer to v wind component, destaggering will not be done ")
1877! DEALLOCATE(varbufr)
1878! RETURN
1879!endif
1880!
1881!if (nvaru == 0 .and. nvarv == 0) then
1882! call l4f_category_log(this%category,L4F_WARN, &
1883! "no u or v wind component found in volume, nothing to do")
1884! DEALLOCATE(varbufr)
1885! RETURN
1886!endif
1887!
1888!if (COUNT(varbufr/=varu .and. varbufr/=varv) > 0) then
1889! call l4f_category_log(this%category,L4F_WARN, &
1890! "there are variables different from u and v wind component in C grid")
1891!endif
1892
1893
1894END 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.