libsim Versione 7.1.11

◆ map_inv_distinct_var6d()

integer function, dimension(dim) map_inv_distinct_var6d ( type(volgrid6d_var), dimension(:), intent(in)  vect,
integer, intent(in)  dim,
logical, dimension(:), intent(in), optional  mask,
logical, intent(in), optional  back 
)
private

map inv distinct

Definizione alla linea 916 del file volgrid6d_var_class.F90.

918! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
919! authors:
920! Davide Cesari <dcesari@arpa.emr.it>
921! Paolo Patruno <ppatruno@arpa.emr.it>
922
923! This program is free software; you can redistribute it and/or
924! modify it under the terms of the GNU General Public License as
925! published by the Free Software Foundation; either version 2 of
926! the License, or (at your option) any later version.
927
928! This program is distributed in the hope that it will be useful,
929! but WITHOUT ANY WARRANTY; without even the implied warranty of
930! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
931! GNU General Public License for more details.
932
933! You should have received a copy of the GNU General Public License
934! along with this program. If not, see <http://www.gnu.org/licenses/>.
935#include "config.h"
936
948USE kinds
950USE err_handling
954
955IMPLICIT NONE
956
961TYPE volgrid6d_var
962 integer :: centre
963 integer :: category
964 integer :: number
965 integer :: discipline
966 CHARACTER(len=65) :: description
967 CHARACTER(len=24) :: unit
968END TYPE volgrid6d_var
969
970TYPE(volgrid6d_var),PARAMETER :: volgrid6d_var_miss= &
971 volgrid6d_var(imiss,imiss,imiss,imiss,cmiss,cmiss)
972
973TYPE(vol7d_var),PARAMETER :: vol7d_var_horstag(2) = (/ &
974 vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
975 vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0) &
976 /)
977
978TYPE(vol7d_var),PARAMETER :: vol7d_var_horcomp(4) = (/ &! RESHAPE( (/ &
979 vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
980 vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0), &
981 vol7d_var('B11200', '', '', 0, 0, 0, 0, 0, 0), &
982 vol7d_var('B11201', '', '', 0, 0, 0, 0, 0, 0) &
983/)
984!/), (/2,2/)) ! bug in gfortran
985
994TYPE conv_func
995 PRIVATE
996 REAL :: a, b
997END TYPE conv_func
998
999TYPE(conv_func), PARAMETER :: conv_func_miss=conv_func(rmiss,rmiss)
1000TYPE(conv_func), PARAMETER :: conv_func_identity=conv_func(1.0,0.0)
1001
1002TYPE vg6d_v7d_var_conv
1003 TYPE(volgrid6d_var) :: vg6d_var
1004 TYPE(vol7d_var) :: v7d_var
1005 TYPE(conv_func) :: c_func
1006! aggiungere informazioni ad es. su rotazione del vento
1007END TYPE vg6d_v7d_var_conv
1008
1009TYPE(vg6d_v7d_var_conv), PARAMETER :: vg6d_v7d_var_conv_miss= &
1010 vg6d_v7d_var_conv(volgrid6d_var_miss, vol7d_var_miss, conv_func_miss)
1011
1012TYPE(vg6d_v7d_var_conv), ALLOCATABLE :: conv_fwd(:), conv_bwd(:)
1013
1027INTERFACE init
1028 MODULE PROCEDURE volgrid6d_var_init
1029END INTERFACE
1030
1033INTERFACE delete
1034 MODULE PROCEDURE volgrid6d_var_delete
1035END INTERFACE
1036
1037INTERFACE c_e
1038 MODULE PROCEDURE volgrid6d_var_c_e
1039END INTERFACE
1040
1041
1046INTERFACE OPERATOR (==)
1047 MODULE PROCEDURE volgrid6d_var_eq, conv_func_eq
1048END INTERFACE
1049
1054INTERFACE OPERATOR (/=)
1055 MODULE PROCEDURE volgrid6d_var_ne, conv_func_ne
1056END INTERFACE
1057
1058#define VOL7D_POLY_TYPE TYPE(volgrid6d_var)
1059#define VOL7D_POLY_TYPES _var6d
1060#include "array_utilities_pre.F90"
1061
1063INTERFACE display
1064 MODULE PROCEDURE display_volgrid6d_var
1065END INTERFACE
1066
1071INTERFACE OPERATOR (*)
1072 MODULE PROCEDURE conv_func_mult
1073END INTERFACE OPERATOR (*)
1074
1077INTERFACE compute
1078 MODULE PROCEDURE conv_func_compute
1079END INTERFACE
1080
1083INTERFACE convert
1084 MODULE PROCEDURE varbufr2vargrib_convert, vargrib2varbufr_convert, &
1085 conv_func_convert
1086END INTERFACE
1087
1088PRIVATE
1089PUBLIC volgrid6d_var, volgrid6d_var_miss, volgrid6d_var_new, init, delete, &
1090 c_e, volgrid6d_var_normalize, &
1091 OPERATOR(==), OPERATOR(/=), OPERATOR(*), &
1092 count_distinct, pack_distinct, count_and_pack_distinct, &
1093 map_distinct, map_inv_distinct, &
1094 index, display, &
1095 vargrib2varbufr, varbufr2vargrib, &
1096 conv_func, conv_func_miss, compute, convert, &
1097 volgrid6d_var_hor_comp_index, volgrid6d_var_is_hor_comp
1098
1099
1100CONTAINS
1101
1102
1103ELEMENTAL FUNCTION volgrid6d_var_new(centre, category, number, &
1104 discipline, description, unit) RESULT(this)
1105integer,INTENT(in),OPTIONAL :: centre
1106integer,INTENT(in),OPTIONAL :: category
1107integer,INTENT(in),OPTIONAL :: number
1108integer,INTENT(in),OPTIONAL :: discipline
1109CHARACTER(len=*),INTENT(in),OPTIONAL :: description
1110CHARACTER(len=*),INTENT(in),OPTIONAL :: unit
1111
1112TYPE(volgrid6d_var) :: this
1113
1114CALL init(this, centre, category, number, discipline, description, unit)
1115
1116END FUNCTION volgrid6d_var_new
1117
1118
1119! documented in the interface
1120ELEMENTAL SUBROUTINE volgrid6d_var_init(this, centre, category, number, discipline,description,unit)
1121TYPE(volgrid6d_var),INTENT(INOUT) :: this ! object to be initialized
1122INTEGER,INTENT(in),OPTIONAL :: centre ! centre
1123INTEGER,INTENT(in),OPTIONAL :: category ! grib2: category / grib1: grib table version number
1124INTEGER,INTENT(in),OPTIONAL :: number ! parameter number
1125INTEGER,INTENT(in),OPTIONAL :: discipline ! grib2: discipline / grib1: 255
1126CHARACTER(len=*),INTENT(in),OPTIONAL :: description ! optional textual description of the variable
1127CHARACTER(len=*),INTENT(in),OPTIONAL :: unit ! optional textual description of the variable's unit
1128
1129IF (PRESENT(centre)) THEN
1130 this%centre = centre
1131ELSE
1132 this%centre = imiss
1133 this%category = imiss
1134 this%number = imiss
1135 this%discipline = imiss
1136 RETURN
1137ENDIF
1138
1139IF (PRESENT(category)) THEN
1140 this%category = category
1141ELSE
1142 this%category = imiss
1143 this%number = imiss
1144 this%discipline = imiss
1145 RETURN
1146ENDIF
1147
1148
1149IF (PRESENT(number)) THEN
1150 this%number = number
1151ELSE
1152 this%number = imiss
1153 this%discipline = imiss
1154 RETURN
1155ENDIF
1156
1157! se sono arrivato fino a qui ho impostato centre, category e number
1158!per il grib 1 manca discipline e imposto 255 (missing del grib2)
1159
1160IF (PRESENT(discipline)) THEN
1161 this%discipline = discipline
1162ELSE
1163 this%discipline = 255
1164ENDIF
1165
1166IF (PRESENT(description)) THEN
1167 this%description = description
1168ELSE
1169 this%description = cmiss
1170ENDIF
1171
1172IF (PRESENT(unit)) THEN
1173 this%unit = unit
1174ELSE
1175 this%unit = cmiss
1176ENDIF
1177
1178
1179
1180END SUBROUTINE volgrid6d_var_init
1181
1182
1183! documented in the interface
1184SUBROUTINE volgrid6d_var_delete(this)
1185TYPE(volgrid6d_var),INTENT(INOUT) :: this
1186
1187this%centre = imiss
1188this%category = imiss
1189this%number = imiss
1190this%discipline = imiss
1191this%description = cmiss
1192this%unit = cmiss
1193
1194END SUBROUTINE volgrid6d_var_delete
1195
1196
1197ELEMENTAL FUNCTION volgrid6d_var_c_e(this) RESULT(c_e)
1198TYPE(volgrid6d_var),INTENT(IN) :: this
1199LOGICAL :: c_e
1200c_e = this /= volgrid6d_var_miss
1201END FUNCTION volgrid6d_var_c_e
1202
1203
1204ELEMENTAL FUNCTION volgrid6d_var_eq(this, that) RESULT(res)
1205TYPE(volgrid6d_var),INTENT(IN) :: this, that
1206LOGICAL :: res
1207
1208IF (this%discipline == that%discipline) THEN
1209
1210 IF (this%discipline == 255) THEN ! grib1, WMO tables are all equivalent
1211 res = ((this%category == that%category) .OR. &
1212 (this%category >= 1 .AND. this%category <=3 .AND. &
1213 that%category >= 1 .AND. that%category <=3)) .AND. &
1214 this%number == that%number
1215
1216 IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
1217 (this%number >= 128 .AND. this%number <= 254)) THEN
1218 res = res .AND. this%centre == that%centre ! local definition, centre matters
1219 ENDIF
1220
1221 ELSE ! grib2
1222 res = this%category == that%category .AND. &
1223 this%number == that%number
1224
1225 IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
1226 (this%category >= 192 .AND. this%category <= 254) .OR. &
1227 (this%number >= 192 .AND. this%number <= 254)) THEN
1228 res = res .AND. this%centre == that%centre ! local definition, centre matters
1229 ENDIF
1230 ENDIF
1231
1232ELSE ! different edition or different discipline
1233 res = .false.
1234ENDIF
1235
1236END FUNCTION volgrid6d_var_eq
1237
1238
1239ELEMENTAL FUNCTION volgrid6d_var_ne(this, that) RESULT(res)
1240TYPE(volgrid6d_var),INTENT(IN) :: this, that
1241LOGICAL :: res
1242
1243res = .NOT.(this == that)
1244
1245END FUNCTION volgrid6d_var_ne
1246
1247
1248#include "array_utilities_inc.F90"
1249
1250
1252SUBROUTINE display_volgrid6d_var(this)
1253TYPE(volgrid6d_var),INTENT(in) :: this
1254
1255print*,"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
1256
1257END SUBROUTINE display_volgrid6d_var
1258
1259
1272SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
1273TYPE(volgrid6d_var),INTENT(in) :: vargrib(:)
1274TYPE(vol7d_var),INTENT(out) :: varbufr(:)
1275TYPE(conv_func),POINTER :: c_func(:)
1276
1277INTEGER :: i, n, stallo
1278
1279n = min(SIZE(varbufr), SIZE(vargrib))
1280ALLOCATE(c_func(n),stat=stallo)
1281IF (stallo /= 0) THEN
1282 call l4f_log(l4f_fatal,"allocating memory")
1283 call raise_fatal_error()
1284ENDIF
1285
1286DO i = 1, n
1287 varbufr(i) = convert(vargrib(i), c_func(i))
1288ENDDO
1289
1290END SUBROUTINE vargrib2varbufr
1291
1292
1303FUNCTION vargrib2varbufr_convert(vargrib, c_func) RESULT(convert)
1304TYPE(volgrid6d_var),INTENT(in) :: vargrib
1305TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
1306TYPE(vol7d_var) :: convert
1307
1308INTEGER :: i
1309
1310IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
1311
1312DO i = 1, SIZE(conv_fwd)
1313 IF (vargrib == conv_fwd(i)%vg6d_var) THEN
1314 convert = conv_fwd(i)%v7d_var
1315 IF (PRESENT(c_func)) c_func = conv_fwd(i)%c_func
1316 RETURN
1317 ENDIF
1318ENDDO
1319! not found
1320convert = vol7d_var_miss
1321IF (PRESENT(c_func)) c_func = conv_func_miss
1322
1323! set hint for backwards conversion
1324convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
1325 vargrib%discipline/)
1326
1327CALL l4f_log(l4f_warn, 'vargrib2varbufr: variable '// &
1328 trim(to_char(vargrib%centre))//':'//trim(to_char(vargrib%category))//':'// &
1329 trim(to_char(vargrib%number))//':'//trim(to_char(vargrib%discipline))// &
1330 ' not found in table')
1331
1332END FUNCTION vargrib2varbufr_convert
1333
1334
1350SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
1351TYPE(vol7d_var),INTENT(in) :: varbufr(:)
1352TYPE(volgrid6d_var),INTENT(out) :: vargrib(:)
1353TYPE(conv_func),POINTER :: c_func(:)
1354TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
1355
1356INTEGER :: i, n, stallo
1357
1358n = min(SIZE(varbufr), SIZE(vargrib))
1359ALLOCATE(c_func(n),stat=stallo)
1360IF (stallo /= 0) THEN
1361 CALL l4f_log(l4f_fatal,"allocating memory")
1362 CALL raise_fatal_error()
1363ENDIF
1364
1365DO i = 1, n
1366 vargrib(i) = convert(varbufr(i), c_func(i), grid_id_template)
1367ENDDO
1368
1369END SUBROUTINE varbufr2vargrib
1370
1371
1385FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template) RESULT(convert)
1386TYPE(vol7d_var),INTENT(in) :: varbufr
1387TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
1388TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
1389TYPE(volgrid6d_var) :: convert
1390
1391INTEGER :: i
1392#ifdef HAVE_LIBGRIBAPI
1393INTEGER :: gaid, editionnumber, category, centre
1394#endif
1395
1396IF (.NOT. ALLOCATED(conv_bwd)) CALL vg6d_v7d_var_conv_setup()
1397
1398#ifdef HAVE_LIBGRIBAPI
1399editionnumber=255; category=255; centre=255
1400#endif
1401IF (PRESENT(grid_id_template)) THEN
1402#ifdef HAVE_LIBGRIBAPI
1403 gaid = grid_id_get_gaid(grid_id_template)
1404 IF (c_e(gaid)) THEN
1405 CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
1406 IF (editionnumber == 1) THEN
1407 CALL grib_get(gaid,'gribTablesVersionNo',category)
1408 ENDIF
1409 CALL grib_get(gaid,'centre',centre)
1410 ENDIF
1411#endif
1412ENDIF
1413
1414DO i = 1, SIZE(conv_bwd)
1415 IF (varbufr == conv_bwd(i)%v7d_var) THEN
1416#ifdef HAVE_LIBGRIBAPI
1417 IF (editionnumber /= 255) THEN ! further check required (gaid present)
1418 IF (editionnumber == 1) THEN
1419 IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle ! wrong edition
1420 ELSE IF (editionnumber == 2) THEN
1421 IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle ! wrong edition
1422 ENDIF
1423 IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
1424 conv_bwd(i)%vg6d_var%centre /= centre) cycle ! wrong centre
1425 ENDIF
1426#endif
1427 convert = conv_bwd(i)%vg6d_var
1428 IF (PRESENT(c_func)) c_func = conv_bwd(i)%c_func
1429 RETURN
1430 ENDIF
1431ENDDO
1432! not found
1433convert = volgrid6d_var_miss
1434IF (PRESENT(c_func)) c_func = conv_func_miss
1435
1436! if hint available use it as a fallback
1437IF (any(varbufr%gribhint /= imiss)) THEN
1438 convert%centre = varbufr%gribhint(1)
1439 convert%category = varbufr%gribhint(2)
1440 convert%number = varbufr%gribhint(3)
1441 convert%discipline = varbufr%gribhint(4)
1442ENDIF
1443
1444CALL l4f_log(l4f_warn, 'varbufr2vargrib: variable '// &
1445 trim(varbufr%btable)//" : "//trim(varbufr%description)//" : "//trim(varbufr%unit)// &
1446 ' not found in table')
1447
1448END FUNCTION varbufr2vargrib_convert
1449
1450
1458SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
1459TYPE(volgrid6d_var),INTENT(inout) :: this
1460TYPE(conv_func),INTENT(out) :: c_func
1461TYPE(grid_id),INTENT(in) :: grid_id_template
1462
1463LOGICAL :: eqed, eqcentre
1464INTEGER :: gaid, editionnumber, centre
1465TYPE(volgrid6d_var) :: tmpgrib
1466TYPE(vol7d_var) :: tmpbufr
1467TYPE(conv_func) tmpc_func1, tmpc_func2
1468
1469eqed = .true.
1470eqcentre = .true.
1471c_func = conv_func_miss
1472
1473#ifdef HAVE_LIBGRIBAPI
1474gaid = grid_id_get_gaid(grid_id_template)
1475IF (c_e(gaid)) THEN
1476 CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
1477 CALL grib_get(gaid, 'centre', centre)
1478 eqed = editionnumber == 1 .EQV. this%discipline == 255
1479 eqcentre = centre == this%centre
1480ENDIF
1481#endif
1482
1483IF (eqed .AND. eqcentre) RETURN ! nothing to do
1484
1485tmpbufr = convert(this, tmpc_func1)
1486tmpgrib = convert(tmpbufr, tmpc_func2, grid_id_template)
1487
1488IF (tmpgrib /= volgrid6d_var_miss) THEN
1489! conversion back and forth successful, set also conversion function
1490 this = tmpgrib
1491 c_func = tmpc_func1 * tmpc_func2
1492! set to missing in common case to avoid useless computation
1493 IF (c_func == conv_func_identity) c_func = conv_func_miss
1494ELSE IF (.NOT.eqed) THEN
1495! conversion back and forth unsuccessful and grib edition incompatible, set to miss
1496 this = tmpgrib
1497ENDIF
1498
1499END SUBROUTINE volgrid6d_var_normalize
1500
1501
1502! Private subroutine for reading forward and backward conversion tables
1503! todo: better error handling
1504SUBROUTINE vg6d_v7d_var_conv_setup()
1505INTEGER :: un, i, n, stallo
1506
1507! forward, grib to bufr
1508un = open_package_file('vargrib2bufr.csv', filetype_data)
1509n=0
1510DO WHILE(.true.)
1511 READ(un,*,END=100)
1512 n = n + 1
1513ENDDO
1514
1515100 CONTINUE
1516
1517rewind(un)
1518ALLOCATE(conv_fwd(n),stat=stallo)
1519IF (stallo /= 0) THEN
1520 CALL l4f_log(l4f_fatal,"allocating memory")
1521 CALL raise_fatal_error()
1522ENDIF
1523
1524conv_fwd(:) = vg6d_v7d_var_conv_miss
1525CALL import_var_conv(un, conv_fwd)
1526CLOSE(un)
1527
1528! backward, bufr to grib
1529un = open_package_file('vargrib2bufr.csv', filetype_data)
1530! use the same file for now
1531!un = open_package_file('varbufr2grib.csv', filetype_data)
1532n=0
1533DO WHILE(.true.)
1534 READ(un,*,END=300)
1535 n = n + 1
1536ENDDO
1537
1538300 CONTINUE
1539
1540rewind(un)
1541ALLOCATE(conv_bwd(n),stat=stallo)
1542IF (stallo /= 0) THEN
1543 CALL l4f_log(l4f_fatal,"allocating memory")
1544 CALL raise_fatal_error()
1545end if
1546
1547conv_bwd(:) = vg6d_v7d_var_conv_miss
1548CALL import_var_conv(un, conv_bwd)
1549DO i = 1, n
1550 conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
1551 conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
1552ENDDO
1553CLOSE(un)
1554
1555CONTAINS
1556
1557SUBROUTINE import_var_conv(un, conv_type)
1558INTEGER, INTENT(in) :: un
1559TYPE(vg6d_v7d_var_conv), INTENT(out) :: conv_type(:)
1560
1561INTEGER :: i
1562TYPE(csv_record) :: csv
1563CHARACTER(len=1024) :: line
1564CHARACTER(len=10) :: btable
1565INTEGER :: centre, category, number, discipline
1566
1567DO i = 1, SIZE(conv_type)
1568 READ(un,'(A)',END=200)line
1569 CALL init(csv, line)
1570 CALL csv_record_getfield(csv, btable)
1571 CALL csv_record_getfield(csv) ! skip fields for description and unit,
1572 CALL csv_record_getfield(csv) ! they correspond to grib information, not bufr Btable
1573 CALL init(conv_type(i)%v7d_var, btable=btable)
1574
1575 CALL csv_record_getfield(csv, centre)
1576 CALL csv_record_getfield(csv, category)
1577 CALL csv_record_getfield(csv, number)
1578 CALL csv_record_getfield(csv, discipline)
1579 CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
1580 number=number, discipline=discipline) ! controllare l'ordine
1581
1582 CALL csv_record_getfield(csv, conv_type(i)%c_func%a)
1583 CALL csv_record_getfield(csv, conv_type(i)%c_func%b)
1584 CALL delete(csv)
1585ENDDO
1586
1587200 CONTINUE
1588
1589END SUBROUTINE import_var_conv
1590
1591END SUBROUTINE vg6d_v7d_var_conv_setup
1592
1593
1594ELEMENTAL FUNCTION conv_func_eq(this, that) RESULT(res)
1595TYPE(conv_func),INTENT(IN) :: this, that
1596LOGICAL :: res
1597
1598res = this%a == that%a .AND. this%b == that%b
1599
1600END FUNCTION conv_func_eq
1601
1602
1603ELEMENTAL FUNCTION conv_func_ne(this, that) RESULT(res)
1604TYPE(conv_func),INTENT(IN) :: this, that
1605LOGICAL :: res
1606
1607res = .NOT.(this == that)
1608
1609END FUNCTION conv_func_ne
1610
1611
1612FUNCTION conv_func_mult(this, that) RESULT(mult)
1613TYPE(conv_func),INTENT(in) :: this
1614TYPE(conv_func),INTENT(in) :: that
1615
1616TYPE(conv_func) :: mult
1617
1618IF (this == conv_func_miss .OR. that == conv_func_miss) THEN
1619 mult = conv_func_miss
1620ELSE
1621 mult%a = this%a*that%a
1622 mult%b = this%a*that%b+this%b
1623ENDIF
1624
1625END FUNCTION conv_func_mult
1626
1634ELEMENTAL SUBROUTINE conv_func_compute(this, values)
1635TYPE(conv_func),INTENT(in) :: this
1636REAL,INTENT(inout) :: values
1637
1638IF (this /= conv_func_miss) THEN
1639 IF (c_e(values)) values = values*this%a + this%b
1640ELSE
1641 values=rmiss
1642ENDIF
1643
1644END SUBROUTINE conv_func_compute
1645
1646
1654ELEMENTAL FUNCTION conv_func_convert(this, values) RESULT(convert)
1655TYPE(conv_func),intent(in) :: this
1656REAL,INTENT(in) :: values
1657REAL :: convert
1658
1659convert = values
1660CALL compute(this, convert)
1661
1662END FUNCTION conv_func_convert
1663
1664
1678SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
1679TYPE(volgrid6d_var),INTENT(in) :: this(:)
1680INTEGER,POINTER :: xind(:), yind(:)
1681
1682TYPE(vol7d_var) :: varbufr(SIZE(this))
1683TYPE(conv_func),POINTER :: c_func(:)
1684INTEGER :: i, nv, counts(SIZE(vol7d_var_horcomp))
1685
1686NULLIFY(xind, yind)
1687counts(:) = 0
1688
1689CALL vargrib2varbufr(this, varbufr, c_func)
1690
1691DO i = 1, SIZE(vol7d_var_horcomp)
1692 counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
1693ENDDO
1694
1695IF (any(counts(1::2) > 1)) THEN
1696 CALL l4f_log(l4f_warn, '> 1 variable refer to x component of the same field, (un)rotation impossible')
1697 DEALLOCATE(c_func)
1698 RETURN
1699ENDIF
1700IF (any(counts(2::2) > 1)) THEN
1701 CALL l4f_log(l4f_warn, '> 1 variable refer to y component of the same field, (un)rotation impossible')
1702 DEALLOCATE(c_func)
1703 RETURN
1704ENDIF
1705
1706! check that variables are paired and count pairs
1707nv = 0
1708DO i = 1, SIZE(vol7d_var_horcomp), 2
1709 IF (counts(i) == 0 .AND. counts(i+1) > 0) THEN
1710 CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
1711 ' present but the corresponding x-component '// &
1712 trim(vol7d_var_horcomp(i)%btable)//' is missing, (un)rotation impossible')
1713 RETURN
1714 ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0) THEN
1715 CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i)%btable)// &
1716 ' present but the corresponding y-component '// &
1717 trim(vol7d_var_horcomp(i+1)%btable)//' is missing, (un)rotation impossible')
1718 RETURN
1719 ENDIF
1720 IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
1721ENDDO
1722
1723! repeat the loop storing indices
1724ALLOCATE(xind(nv), yind(nv))
1725nv = 0
1726DO i = 1, SIZE(vol7d_var_horcomp), 2
1727 IF (counts(i) == 1 .AND. counts(i+1) == 1) THEN
1728 nv = nv + 1
1729 xind(nv) = index(varbufr(:), vol7d_var_horcomp(i))
1730 yind(nv) = index(varbufr(:), vol7d_var_horcomp(i+1))
1731 ENDIF
1732ENDDO
1733DEALLOCATE(c_func)
1734
1735END SUBROUTINE volgrid6d_var_hor_comp_index
1736
1737
1742FUNCTION volgrid6d_var_is_hor_comp(this) RESULT(is_hor_comp)
1743TYPE(volgrid6d_var),INTENT(in) :: this
1744LOGICAL :: is_hor_comp
1745
1746TYPE(vol7d_var) :: varbufr
1747
1748varbufr = convert(this)
1749is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
1750
1751END FUNCTION volgrid6d_var_is_hor_comp
1752
1753! before unstaggering??
1754
1755!IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
1756!
1757!call init(varu,btable="B11003")
1758!call init(varv,btable="B11004")
1759!
1760! test about presence of u and v in standard table
1761!if ( index(conv_fwd(:)%v7d_var,varu) == 0 .or. index(conv_fwd(:)%v7d_var,varv) == 0 )then
1762! call l4f_category_log(this%category,L4F_FATAL, &
1763! "variables B11003 and/or B11004 (wind components) not defined by vg6d_v7d_var_conv_setup")
1764! CALL raise_error()
1765! RETURN
1766!end if
1767!
1768!if (associated(this%var))then
1769! nvar=size(this%var)
1770! allocate(varbufr(nvar),stat=stallo)
1771! if (stallo /=0)then
1772! call l4f_log(L4F_FATAL,"allocating memory")
1773! call raise_fatal_error("allocating memory")
1774! end if
1775!
1776! CALL vargrib2varbufr(this%var, varbufr)
1777!ELSE
1778! CALL l4f_category_log(this%category, L4F_ERROR, &
1779! "trying to destagger an incomplete volgrid6d object")
1780! CALL raise_error()
1781! RETURN
1782!end if
1783!
1784!nvaru=COUNT(varbufr==varu)
1785!nvarv=COUNT(varbufr==varv)
1786!
1787!if (nvaru > 1 )then
1788! call l4f_category_log(this%category,L4F_WARN, &
1789! ">1 variables refer to u wind component, destaggering will not be done ")
1790! DEALLOCATE(varbufr)
1791! RETURN
1792!endif
1793!
1794!if (nvarv > 1 )then
1795! call l4f_category_log(this%category,L4F_WARN, &
1796! ">1 variables refer to v wind component, destaggering will not be done ")
1797! DEALLOCATE(varbufr)
1798! RETURN
1799!endif
1800!
1801!if (nvaru == 0 .and. nvarv == 0) then
1802! call l4f_category_log(this%category,L4F_WARN, &
1803! "no u or v wind component found in volume, nothing to do")
1804! DEALLOCATE(varbufr)
1805! RETURN
1806!endif
1807!
1808!if (COUNT(varbufr/=varu .and. varbufr/=varv) > 0) then
1809! call l4f_category_log(this%category,L4F_WARN, &
1810! "there are variables different from u and v wind component in C grid")
1811!endif
1812
1813
1814END 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.