libsim Versione 7.1.11

◆ 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 1002 del file volgrid6d_var_class.F90.

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