libsim Versione 7.1.11

◆ map_inv_distinct_level()

integer function, dimension(dim) map_inv_distinct_level ( type(vol7d_level), dimension(:), intent(in)  vect,
integer, intent(in)  dim,
logical, dimension(:), intent(in), optional  mask,
logical, intent(in), optional  back 
)

map inv distinct

Definizione alla linea 1060 del file vol7d_level_class.F90.

1062! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1063! authors:
1064! Davide Cesari <dcesari@arpa.emr.it>
1065! Paolo Patruno <ppatruno@arpa.emr.it>
1066
1067! This program is free software; you can redistribute it and/or
1068! modify it under the terms of the GNU General Public License as
1069! published by the Free Software Foundation; either version 2 of
1070! the License, or (at your option) any later version.
1071
1072! This program is distributed in the hope that it will be useful,
1073! but WITHOUT ANY WARRANTY; without even the implied warranty of
1074! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1075! GNU General Public License for more details.
1076
1077! You should have received a copy of the GNU General Public License
1078! along with this program. If not, see <http://www.gnu.org/licenses/>.
1079#include "config.h"
1080
1086MODULE vol7d_level_class
1087USE kinds
1090IMPLICIT NONE
1091
1096TYPE vol7d_level
1097 INTEGER :: level1
1098 INTEGER :: l1
1099 INTEGER :: level2
1100 INTEGER :: l2
1101END TYPE vol7d_level
1102
1104TYPE(vol7d_level),PARAMETER :: vol7d_level_miss=vol7d_level(imiss,imiss,imiss,imiss)
1105
1109INTERFACE init
1110 MODULE PROCEDURE vol7d_level_init
1111END INTERFACE
1112
1115INTERFACE delete
1116 MODULE PROCEDURE vol7d_level_delete
1117END INTERFACE
1118
1122INTERFACE OPERATOR (==)
1123 MODULE PROCEDURE vol7d_level_eq
1124END INTERFACE
1125
1129INTERFACE OPERATOR (/=)
1130 MODULE PROCEDURE vol7d_level_ne
1131END INTERFACE
1132
1138INTERFACE OPERATOR (>)
1139 MODULE PROCEDURE vol7d_level_gt
1140END INTERFACE
1141
1147INTERFACE OPERATOR (<)
1148 MODULE PROCEDURE vol7d_level_lt
1149END INTERFACE
1150
1156INTERFACE OPERATOR (>=)
1157 MODULE PROCEDURE vol7d_level_ge
1158END INTERFACE
1159
1165INTERFACE OPERATOR (<=)
1166 MODULE PROCEDURE vol7d_level_le
1167END INTERFACE
1168
1172INTERFACE OPERATOR (.almosteq.)
1173 MODULE PROCEDURE vol7d_level_almost_eq
1174END INTERFACE
1175
1176
1177! da documentare in inglese assieme al resto
1179INTERFACE c_e
1180 MODULE PROCEDURE vol7d_level_c_e
1181END INTERFACE
1182
1183#define VOL7D_POLY_TYPE TYPE(vol7d_level)
1184#define VOL7D_POLY_TYPES _level
1185#define ENABLE_SORT
1186#include "array_utilities_pre.F90"
1187
1189INTERFACE display
1190 MODULE PROCEDURE display_level
1191END INTERFACE
1192
1194INTERFACE to_char
1195 MODULE PROCEDURE to_char_level
1196END INTERFACE
1197
1199INTERFACE vol7d_level_to_var
1200 MODULE PROCEDURE vol7d_level_to_var_int, vol7d_level_to_var_lev
1201END INTERFACE vol7d_level_to_var
1202
1205 MODULE PROCEDURE vol7d_level_to_var_factor_int, vol7d_level_to_var_factor_lev
1206END INTERFACE vol7d_level_to_var_factor
1207
1210 MODULE PROCEDURE vol7d_level_to_var_log10_int, vol7d_level_to_var_log10_lev
1211END INTERFACE vol7d_level_to_var_log10
1212
1213type(vol7d_level) :: almost_equal_levels(3)=(/&
1214 vol7d_level( 1,imiss,imiss,imiss),&
1215 vol7d_level(103,imiss,imiss,imiss),&
1216 vol7d_level(106,imiss,imiss,imiss)/)
1217
1218! levels requiring conversion from internal to physical representation
1219INTEGER, PARAMETER :: &
1220 height_level(6) = (/102,103,106,117,160,161/), & ! 10**-3
1221 thermo_level(3) = (/20,107,235/), & ! 10**-1
1222 sigma_level(2) = (/104,111/) ! 10**-4
1223
1224TYPE level_var
1225 INTEGER :: level
1226 CHARACTER(len=10) :: btable
1227END TYPE level_var
1228
1229! Conversion table from GRIB2 vertical level codes to corresponding
1230! BUFR B table variables
1231TYPE(level_var),PARAMETER :: level_var_converter(7) = (/ &
1232 level_var(20, 'B12101'), & ! isothermal (K)
1233 level_var(100, 'B10004'), & ! isobaric (Pa)
1234 level_var(102, 'B10007'), & ! height over sea level (m)
1235 level_var(103, 'B10007'), & ! height over surface (m) (special treatment needed!)
1236 level_var(107, 'B12192'), & ! isentropical (K)
1237 level_var(108, 'B10004'), & ! pressure difference from surface (Pa) (special treatment needed!)
1238 level_var(161, 'B22195') /) ! depth below sea surface
1239
1240PRIVATE level_var, level_var_converter
1241
1242CONTAINS
1243
1249FUNCTION vol7d_level_new(level1, l1, level2, l2) RESULT(this)
1250INTEGER,INTENT(IN),OPTIONAL :: level1
1251INTEGER,INTENT(IN),OPTIONAL :: l1
1252INTEGER,INTENT(IN),OPTIONAL :: level2
1253INTEGER,INTENT(IN),OPTIONAL :: l2
1254
1255TYPE(vol7d_level) :: this
1256
1257CALL init(this, level1, l1, level2, l2)
1258
1259END FUNCTION vol7d_level_new
1260
1261
1265SUBROUTINE vol7d_level_init(this, level1, l1, level2, l2)
1266TYPE(vol7d_level),INTENT(INOUT) :: this
1267INTEGER,INTENT(IN),OPTIONAL :: level1
1268INTEGER,INTENT(IN),OPTIONAL :: l1
1269INTEGER,INTENT(IN),OPTIONAL :: level2
1270INTEGER,INTENT(IN),OPTIONAL :: l2
1271
1272this%level1 = imiss
1273this%l1 = imiss
1274this%level2 = imiss
1275this%l2 = imiss
1276
1277IF (PRESENT(level1)) THEN
1278 this%level1 = level1
1279ELSE
1280 RETURN
1281END IF
1282
1283IF (PRESENT(l1)) this%l1 = l1
1284
1285IF (PRESENT(level2)) THEN
1286 this%level2 = level2
1287ELSE
1288 RETURN
1289END IF
1290
1291IF (PRESENT(l2)) this%l2 = l2
1292
1293END SUBROUTINE vol7d_level_init
1294
1295
1297SUBROUTINE vol7d_level_delete(this)
1298TYPE(vol7d_level),INTENT(INOUT) :: this
1299
1300this%level1 = imiss
1301this%l1 = imiss
1302this%level2 = imiss
1303this%l2 = imiss
1304
1305END SUBROUTINE vol7d_level_delete
1306
1307
1308SUBROUTINE display_level(this)
1309TYPE(vol7d_level),INTENT(in) :: this
1310
1311print*,trim(to_char(this))
1312
1313END SUBROUTINE display_level
1314
1315
1316FUNCTION to_char_level(this)
1317#ifdef HAVE_DBALLE
1318USE dballef
1319#endif
1320TYPE(vol7d_level),INTENT(in) :: this
1321CHARACTER(len=255) :: to_char_level
1322
1323#ifdef HAVE_DBALLE
1324INTEGER :: handle, ier
1325
1326handle = 0
1327ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
1328ier = idba_spiegal(handle,this%level1,this%l1,this%level2,this%l2,to_char_level)
1329ier = idba_fatto(handle)
1330
1331to_char_level="LEVEL: "//to_char_level
1332
1333#else
1334
1335to_char_level="LEVEL: "//&
1336 " typelev1:"//trim(to_char(this%level1))//" L1:"//trim(to_char(this%l1))//&
1337 " typelev2:"//trim(to_char(this%level2))//" L2:"//trim(to_char(this%l2))
1338
1339#endif
1340
1341END FUNCTION to_char_level
1342
1343
1344ELEMENTAL FUNCTION vol7d_level_eq(this, that) RESULT(res)
1345TYPE(vol7d_level),INTENT(IN) :: this, that
1346LOGICAL :: res
1347
1348res = &
1349 this%level1 == that%level1 .AND. &
1350 this%level2 == that%level2 .AND. &
1351 this%l1 == that%l1 .AND. this%l2 == that%l2
1352
1353END FUNCTION vol7d_level_eq
1354
1355
1356ELEMENTAL FUNCTION vol7d_level_ne(this, that) RESULT(res)
1357TYPE(vol7d_level),INTENT(IN) :: this, that
1358LOGICAL :: res
1359
1360res = .NOT.(this == that)
1361
1362END FUNCTION vol7d_level_ne
1363
1364
1365ELEMENTAL FUNCTION vol7d_level_almost_eq(this, that) RESULT(res)
1366TYPE(vol7d_level),INTENT(IN) :: this, that
1367LOGICAL :: res
1368
1369IF ( .not. c_e(this%level1) .or. .not. c_e(that%level1) .or. this%level1 == that%level1 .AND. &
1370 .not. c_e(this%level2) .or. .not. c_e(that%level2) .or. this%level2 == that%level2 .AND. &
1371 .not. c_e(this%l1) .or. .not. c_e(that%l1) .or. this%l1 == that%l1 .AND. &
1372 .not. c_e(this%l2) .or. .not. c_e(that%l2) .or. this%l2 == that%l2) THEN
1373 res = .true.
1374ELSE
1375 res = .false.
1376ENDIF
1377
1378END FUNCTION vol7d_level_almost_eq
1379
1380
1381ELEMENTAL FUNCTION vol7d_level_gt(this, that) RESULT(res)
1382TYPE(vol7d_level),INTENT(IN) :: this, that
1383LOGICAL :: res
1384
1385IF (&
1386 this%level1 > that%level1 .OR. &
1387 (this%level1 == that%level1 .AND. this%l1 > that%l1) .OR. &
1388 (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
1389 (&
1390 this%level2 > that%level2 .OR. &
1391 (this%level2 == that%level2 .AND. this%l2 > that%l2) &
1392 ))) THEN
1393 res = .true.
1394ELSE
1395 res = .false.
1396ENDIF
1397
1398END FUNCTION vol7d_level_gt
1399
1400
1401ELEMENTAL FUNCTION vol7d_level_lt(this, that) RESULT(res)
1402TYPE(vol7d_level),INTENT(IN) :: this, that
1403LOGICAL :: res
1404
1405IF (&
1406 this%level1 < that%level1 .OR. &
1407 (this%level1 == that%level1 .AND. this%l1 < that%l1) .OR. &
1408 (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
1409 (&
1410 this%level2 < that%level2 .OR. &
1411 (this%level2 == that%level2 .AND. this%l2 < that%l2) &
1412 ))) THEN
1413 res = .true.
1414ELSE
1415 res = .false.
1416ENDIF
1417
1418END FUNCTION vol7d_level_lt
1419
1420
1421ELEMENTAL FUNCTION vol7d_level_ge(this, that) RESULT(res)
1422TYPE(vol7d_level),INTENT(IN) :: this, that
1423LOGICAL :: res
1424
1425IF (this == that) THEN
1426 res = .true.
1427ELSE IF (this > that) THEN
1428 res = .true.
1429ELSE
1430 res = .false.
1431ENDIF
1432
1433END FUNCTION vol7d_level_ge
1434
1435
1436ELEMENTAL FUNCTION vol7d_level_le(this, that) RESULT(res)
1437TYPE(vol7d_level),INTENT(IN) :: this, that
1438LOGICAL :: res
1439
1440IF (this == that) THEN
1441 res = .true.
1442ELSE IF (this < that) THEN
1443 res = .true.
1444ELSE
1445 res = .false.
1446ENDIF
1447
1448END FUNCTION vol7d_level_le
1449
1450
1451ELEMENTAL FUNCTION vol7d_level_c_e(this) RESULT(c_e)
1452TYPE(vol7d_level),INTENT(IN) :: this
1453LOGICAL :: c_e
1454c_e = this /= vol7d_level_miss
1455END FUNCTION vol7d_level_c_e
1456
1457
1458#include "array_utilities_inc.F90"
1459
1460
1461FUNCTION vol7d_level_to_var_lev(level) RESULT(btable)
1462TYPE(vol7d_level),INTENT(in) :: level
1463CHARACTER(len=10) :: btable
1464
1465btable = vol7d_level_to_var_int(level%level1)
1466
1467END FUNCTION vol7d_level_to_var_lev
1468
1469FUNCTION vol7d_level_to_var_int(level) RESULT(btable)
1470INTEGER,INTENT(in) :: level
1471CHARACTER(len=10) :: btable
1472
1473INTEGER :: i
1474
1475DO i = 1, SIZE(level_var_converter)
1476 IF (level_var_converter(i)%level == level) THEN
1477 btable = level_var_converter(i)%btable
1478 RETURN
1479 ENDIF
1480ENDDO
1481
1482btable = cmiss
1483
1484END FUNCTION vol7d_level_to_var_int
1485
1486
1487FUNCTION vol7d_level_to_var_factor_lev(level) RESULT(factor)
1488TYPE(vol7d_level),INTENT(in) :: level
1489REAL :: factor
1490
1491factor = vol7d_level_to_var_factor_int(level%level1)
1492
1493END FUNCTION vol7d_level_to_var_factor_lev
1494
1495FUNCTION vol7d_level_to_var_factor_int(level) RESULT(factor)
1496INTEGER,INTENT(in) :: level
1497REAL :: factor
1498
1499factor = 1.
1500IF (any(level == height_level)) THEN
1501 factor = 1.e-3
1502ELSE IF (any(level == thermo_level)) THEN
1503 factor = 1.e-1
1504ELSE IF (any(level == sigma_level)) THEN
1505 factor = 1.e-4
1506ENDIF
1507
1508END FUNCTION vol7d_level_to_var_factor_int
1509
1510
1511FUNCTION vol7d_level_to_var_log10_lev(level) RESULT(log10)
1512TYPE(vol7d_level),INTENT(in) :: level
1513REAL :: log10
1514
1515log10 = vol7d_level_to_var_log10_int(level%level1)
1516
1517END FUNCTION vol7d_level_to_var_log10_lev
1518
1519FUNCTION vol7d_level_to_var_log10_int(level) RESULT(log10)
1520INTEGER,INTENT(in) :: level
1521REAL :: log10
1522
1523log10 = 0.
1524IF (any(level == height_level)) THEN
1525 log10 = -3.
1526ELSE IF (any(level == thermo_level)) THEN
1527 log10 = -1.
1528ELSE IF (any(level == sigma_level)) THEN
1529 log10 = -4.
1530ENDIF
1531
1532END FUNCTION vol7d_level_to_var_log10_int
1533
1534END MODULE vol7d_level_class
Distruttore per la classe vol7d_level.
Costruttore per la classe vol7d_level.
Represent level object in a pretty string.
Return the conversion factor for multiplying the level value when converting to variable.
Return the scale value (base 10 log of conversion factor) for multiplying the level value when conver...
Convert a level type to a physical variable.
Utilities for CHARACTER variables.
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 dei livelli verticali in osservazioni meteo e affini.
Definisce il livello verticale di un'osservazione.

Generated with Doxygen.