libsim Versione 7.2.4

◆ volgrid6d_compute_vert_coord_var()

subroutine volgrid6d_compute_vert_coord_var ( type(volgrid6d), intent(in) this,
type(vol7d_level), intent(in) level,
type(volgrid6d), intent(out) volgrid_lev )

Method for building a volume containing the vertical coordinate as a variable.

This method produces a volgrid6d volume, derived from this, containing a single variable, horizontally constant, on the same input levels, which describes the vertical coordinate in the form of a physical variable. The grid, time and timerange metadata are the same as for the original volume. Only a single vertical level type, the one matching the level argument, is converted to a variable. The level argument can also indicate the layer between two surfaces of the same type, in that case the variable representing the vertical coordinate will be set to the value of the midpoint between the two layers. If something goes wrong, e.g. no level matches level argument or the level canot be converted to a physical value, an empty volume is returned.

Parametri
[in]thisvolume with the vertical levels
[in]levelvertical level to be converted to variable, only the type(s) of level are used not the value(s)
[out]volgrid_levoutput volume with the variable describing the vertical coordinate

Definizione alla linea 1038 del file volgrid6d_class_compute.F90.

1039! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1040! authors:
1041! Davide Cesari <dcesari@arpa.emr.it>
1042! Paolo Patruno <ppatruno@arpa.emr.it>
1043
1044! This program is free software; you can redistribute it and/or
1045! modify it under the terms of the GNU General Public License as
1046! published by the Free Software Foundation; either version 2 of
1047! the License, or (at your option) any later version.
1048
1049! This program is distributed in the hope that it will be useful,
1050! but WITHOUT ANY WARRANTY; without even the implied warranty of
1051! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1052! GNU General Public License for more details.
1053
1054! You should have received a copy of the GNU General Public License
1055! along with this program. If not, see <http://www.gnu.org/licenses/>.
1056#include "config.h"
1057
1068USE grid_id_class
1070USE simple_stat
1071IMPLICIT NONE
1072
1073CONTAINS
1074
1140SUBROUTINE volgrid6d_compute_stat_proc(this, that, stat_proc_input, stat_proc, &
1141 step, start, full_steps, frac_valid, max_step, weighted, clone)
1142TYPE(volgrid6d),INTENT(inout) :: this
1143TYPE(volgrid6d),INTENT(out) :: that
1144INTEGER,INTENT(in) :: stat_proc_input
1145INTEGER,INTENT(in) :: stat_proc
1146TYPE(timedelta),INTENT(in) :: step
1147TYPE(datetime),INTENT(in),OPTIONAL :: start
1148LOGICAL,INTENT(in),OPTIONAL :: full_steps
1149REAL,INTENT(in),OPTIONAL :: frac_valid
1150TYPE(timedelta),INTENT(in),OPTIONAL :: max_step ! maximum allowed distance in time between two single valid data within a dataset, for the dataset to be eligible for statistical processing
1151LOGICAL,INTENT(in),OPTIONAL :: weighted
1152LOGICAL , INTENT(in),OPTIONAL :: clone
1153
1154INTEGER :: dtmax, dtstep
1155
1156
1157IF (stat_proc_input == 254) THEN
1158 CALL l4f_category_log(this%category, l4f_info, &
1159 'computing statistical processing by aggregation '//&
1160 trim(to_char(stat_proc_input))//':'//trim(to_char(stat_proc)))
1161
1162 CALL volgrid6d_compute_stat_proc_agg(this, that, stat_proc, &
1163 step, start, full_steps, max_step, clone)
1164
1165ELSE IF (stat_proc == 254) THEN
1166 CALL l4f_category_log(this%category, l4f_error, &
1167 'statistical processing to instantaneous data not implemented for gridded fields')
1168 CALL raise_error()
1169
1170ELSE IF (stat_proc_input == stat_proc .OR. &
1171 (stat_proc == 0 .OR. stat_proc == 2 .OR. stat_proc == 3)) THEN
1172! avg, min and max can be computed from any input, with care
1173
1174 IF (count(this%timerange(:)%timerange == stat_proc_input) == 0) THEN
1175 CALL l4f_category_log(this%category, l4f_warn, &
1176 'no timeranges of the desired statistical processing type '//t2c(stat_proc)//' available')
1177! return an empty volume, without signaling error
1178 CALL init(that)
1179 CALL volgrid6d_alloc_vol(that)
1180
1181 ELSE
1182! euristically determine whether aggregation or difference is more suitable
1183 dtmax = maxval(this%timerange(:)%p2, &
1184 mask=(this%timerange(:)%timerange == stat_proc))
1185 CALL getval(step, asec=dtstep)
1186
1187#ifdef DEBUG
1188 CALL l4f_category_log(this%category, l4f_debug, &
1189 'stat_proc='//t2c(stat_proc)//' dtmax='//t2c(dtmax)//' dtstep='//t2c(dtstep))
1190#endif
1191
1192 IF (dtstep <= dtmax) THEN
1193 CALL l4f_category_log(this%category, l4f_info, &
1194 'recomputing statistically processed data by difference '// &
1195 t2c(stat_proc_input)//':'//t2c(stat_proc))
1196 CALL volgrid6d_recompute_stat_proc_diff(this, that, stat_proc, step, &
1197 full_steps, start, clone)
1198 ELSE
1199 CALL l4f_category_log(this%category, l4f_info, &
1200 'recomputing statistically processed data by aggregation '// &
1201 t2c(stat_proc_input)//':'//t2c(stat_proc))
1202 CALL volgrid6d_recompute_stat_proc_agg(this, that, stat_proc, step, start, &
1203 full_steps, frac_valid, clone, stat_proc_input)
1204 ENDIF
1205 ENDIF
1206
1207ELSE ! IF (stat_proc_input /= stat_proc) THEN
1208 IF ((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
1209 (stat_proc_input == 1 .AND. stat_proc == 0)) THEN
1210 CALL l4f_category_log(this%category, l4f_info, &
1211 'computing statistically processed data by integration/differentiation '// &
1212 t2c(stat_proc_input)//':'//t2c(stat_proc))
1213 CALL volgrid6d_compute_stat_proc_metamorph(this, that, stat_proc_input, &
1214 stat_proc, clone)
1215 ELSE
1216 CALL l4f_category_log(this%category, l4f_error, &
1217 'statistical processing '//t2c(stat_proc_input)//':'//t2c(stat_proc)// &
1218 ' not implemented or does not make sense')
1219 CALL raise_error()
1220 ENDIF
1221
1222ENDIF
1223
1224END SUBROUTINE volgrid6d_compute_stat_proc
1225
1226
1269SUBROUTINE volgrid6d_recompute_stat_proc_agg(this, that, stat_proc, &
1270 step, start, full_steps, frac_valid, clone, stat_proc_input)
1271TYPE(volgrid6d),INTENT(inout) :: this
1272TYPE(volgrid6d),INTENT(out) :: that
1273INTEGER,INTENT(in) :: stat_proc
1274TYPE(timedelta),INTENT(in) :: step
1275TYPE(datetime),INTENT(in),OPTIONAL :: start
1276LOGICAL,INTENT(in),OPTIONAL :: full_steps
1277REAL,INTENT(in),OPTIONAL :: frac_valid
1278LOGICAL, INTENT(in),OPTIONAL :: clone
1279INTEGER,INTENT(in),OPTIONAL :: stat_proc_input
1280
1281INTEGER :: tri
1282INTEGER i, j, n, n1, ndtr, i3, i6
1283TYPE(arrayof_ttr_mapper),POINTER :: map_ttr(:,:)
1284INTEGER,POINTER :: dtratio(:)
1285REAL :: lfrac_valid
1286LOGICAL :: lclone
1287REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
1288
1289
1290NULLIFY(voldatiin, voldatiout)
1291IF (PRESENT(stat_proc_input)) THEN
1292 tri = stat_proc_input
1293ELSE
1294 tri = stat_proc
1295ENDIF
1296IF (PRESENT(frac_valid)) THEN
1297 lfrac_valid = frac_valid
1298ELSE
1299 lfrac_valid = 1.0
1300ENDIF
1301
1302CALL init(that)
1303! be safe
1304CALL volgrid6d_alloc_vol(this)
1305
1306! when volume is not decoded it is better to clone anyway to avoid
1307! overwriting fields
1308lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
1309! initialise the output volume
1310CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
1311CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntimerange=1, &
1312 nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
1313that%level = this%level
1314that%var = this%var
1315
1316CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
1317 step, this%time_definition, that%time, that%timerange, map_ttr, &
1318 dtratio=dtratio, start=start, full_steps=full_steps)
1319
1320CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
1321
1322do_otimerange: DO j = 1, SIZE(that%timerange)
1323 do_otime: DO i = 1, SIZE(that%time)
1324
1325 DO n1 = 1, SIZE(dtratio)
1326 IF (dtratio(n1) <= 0) cycle ! safety check
1327
1328 DO i6 = 1, SIZE(this%var)
1329 DO i3 = 1, SIZE(this%level)
1330 CALL volgrid_get_vol_2d(that, i3, i, j, i6, voldatiout)
1331 ndtr = 0
1332 DO n = 1, map_ttr(i,j)%arraysize
1333 IF (map_ttr(i,j)%array(n)%extra_info == dtratio(n1)) THEN
1334 ndtr = ndtr + 1
1335 CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(n)%it, &
1336 map_ttr(i,j)%array(n)%itr, i6, voldatiin)
1337
1338 IF (ndtr == 1) THEN
1339 voldatiout = voldatiin
1340 IF (lclone) THEN
1341 CALL copy(this%gaid(i3, map_ttr(i,j)%array(n)%it,&
1342 map_ttr(i,j)%array(n)%itr,i6), that%gaid(i3,i,j,i6))
1343 ELSE
1344 that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(n)%it, &
1345 map_ttr(i,j)%array(n)%itr,i6)
1346 ENDIF
1347
1348 ELSE ! second or more time
1349 SELECT CASE(stat_proc)
1350 CASE (0, 200, 1, 4) ! average, vectorial mean, accumulation, difference
1351 WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
1352 voldatiout(:,:) = voldatiout(:,:) + voldatiin(:,:)
1353 ELSEWHERE
1354 voldatiout(:,:) = rmiss
1355 END WHERE
1356 CASE(2) ! maximum
1357 WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
1358 voldatiout(:,:) = max(voldatiout(:,:), voldatiin(:,:))
1359 ELSEWHERE
1360 voldatiout(:,:) = rmiss
1361 END WHERE
1362 CASE(3) ! minimum
1363 WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
1364 voldatiout(:,:) = min(voldatiout(:,:), voldatiin(:,:))
1365 ELSEWHERE
1366 voldatiout(:,:) = rmiss
1367 END WHERE
1368 END SELECT
1369
1370 ENDIF ! first time
1371 ENDIF ! dtratio(n1)
1372 ENDDO ! ttr
1373
1374#ifdef DEBUG
1375 CALL l4f_log(l4f_debug, &
1376 'compute_stat_proc_agg, ndtr/dtratio/frac_valid: '// &
1377 t2c(ndtr)//'/'//t2c(dtratio(n1))//'/'//t2c(lfrac_valid))
1378#endif
1379 IF (ndtr > 0) THEN ! why this condition was not here before?
1380 IF (real(ndtr)/real(dtratio(n1)) >= lfrac_valid) THEN ! success
1381 IF (stat_proc == 0) THEN ! average
1382 WHERE(c_e(voldatiout(:,:)))
1383 voldatiout(:,:) = voldatiout(:,:)/ndtr
1384 END WHERE
1385 ENDIF
1386 CALL volgrid_set_vol_2d(that, i3, i, j, i6, voldatiout)
1387#ifdef DEBUG
1388 CALL l4f_log(l4f_debug, &
1389 'compute_stat_proc_agg, coding lev/t/tr/var: '// &
1390 t2c(i3)//'/'//t2c(i)//'/'//t2c(j)//'/'//t2c(i6))
1391#endif
1392 ELSE
1393! must nullify the output gaid here, otherwise an incomplete field will be output
1394 IF (lclone) THEN
1395 CALL delete(that%gaid(i3,i,j,i6))
1396 ELSE
1397 CALL init(that%gaid(i3,i,j,i6)) ! grid_id lacks a nullify method
1398 ENDIF
1399#ifdef DEBUG
1400 CALL l4f_log(l4f_debug, &
1401 'compute_stat_proc_agg, skipping lev/t/tr/var: '// &
1402 t2c(i3)//'/'//t2c(i)//'/'//t2c(j)//'/'//t2c(i6))
1403#endif
1404 ENDIF
1405 ENDIF ! ndtr > 0
1406
1407 ENDDO ! level
1408 ENDDO ! var
1409 ENDDO ! dtratio
1410 CALL delete(map_ttr(i,j))
1411 ENDDO do_otime
1412ENDDO do_otimerange
1413
1414DEALLOCATE(dtratio, map_ttr)
1415
1416END SUBROUTINE volgrid6d_recompute_stat_proc_agg
1417
1418
1442SUBROUTINE volgrid6d_compute_stat_proc_agg(this, that, stat_proc, &
1443 step, start, full_steps, max_step, clone)
1444TYPE(volgrid6d),INTENT(inout) :: this
1445TYPE(volgrid6d),INTENT(out) :: that
1446INTEGER,INTENT(in) :: stat_proc
1447TYPE(timedelta),INTENT(in) :: step
1448TYPE(datetime),INTENT(in),OPTIONAL :: start
1449LOGICAL,INTENT(in),OPTIONAL :: full_steps
1450TYPE(timedelta),INTENT(in),OPTIONAL :: max_step
1451LOGICAL , INTENT(in),OPTIONAL :: clone
1452
1453INTEGER :: tri
1454INTEGER i, j, n, ninp, i3, i6
1455TYPE(arrayof_ttr_mapper),POINTER :: map_ttr(:,:)
1456TYPE(timedelta) :: lmax_step
1457LOGICAL :: lclone
1458REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
1459
1460
1461NULLIFY(voldatiin, voldatiout)
1462tri = 254
1463IF (PRESENT(max_step)) THEN
1464 lmax_step = max_step
1465ELSE
1466 lmax_step = timedelta_max
1467ENDIF
1468
1469CALL init(that)
1470! be safe
1471CALL volgrid6d_alloc_vol(this)
1472
1473! when volume is not decoded it is better to clone anyway to avoid
1474! overwriting fields
1475lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
1476! initialise the output volume
1477CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
1478CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntimerange=1, &
1479 nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
1480that%level = this%level
1481that%var = this%var
1482
1483CALL recompute_stat_proc_agg_common(this%time, this%timerange, stat_proc, tri, &
1484 step, this%time_definition, that%time, that%timerange, map_ttr, &
1485 start=start, full_steps=full_steps)
1486
1487CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
1488
1489do_otimerange: DO j = 1, SIZE(that%timerange)
1490 do_otime: DO i = 1, SIZE(that%time)
1491 ninp = map_ttr(i,j)%arraysize
1492 IF (ninp <= 0) cycle do_otime
1493
1494 IF (stat_proc == 4) THEN ! check validity for difference
1495 IF (map_ttr(i,j)%array(1)%extra_info /= 1 .OR. &
1496 map_ttr(i,j)%array(ninp)%extra_info /= 2) THEN
1497 CALL delete(map_ttr(i,j))
1498 cycle do_otime
1499 ENDIF
1500 ELSE
1501! check validity condition (missing values in volume are not accounted for)
1502 DO n = 2, ninp
1503 IF (map_ttr(i,j)%array(n)%time - map_ttr(i,j)%array(n-1)%time > &
1504 lmax_step) THEN
1505 CALL delete(map_ttr(i,j))
1506 cycle do_otime
1507 ENDIF
1508 ENDDO
1509 ENDIF
1510
1511 DO i6 = 1, SIZE(this%var)
1512 DO i3 = 1, SIZE(this%level)
1513 CALL volgrid_get_vol_2d(that, i3, i, j, i6, voldatiout)
1514
1515 IF (stat_proc == 4) THEN ! special treatment for difference
1516 IF (lclone) THEN
1517 CALL copy(this%gaid(i3, map_ttr(i,j)%array(1)%it,&
1518 map_ttr(i,j)%array(1)%itr,i6), that%gaid(i3,i,j,i6))
1519 ELSE
1520 that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(1)%it, &
1521 map_ttr(i,j)%array(1)%itr,i6)
1522 ENDIF
1523! improve the next workflow?
1524 CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(ninp)%it, &
1525 map_ttr(i,j)%array(ninp)%itr, i6, voldatiin)
1526 voldatiout = voldatiin
1527 CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(1)%it, &
1528 map_ttr(i,j)%array(1)%itr, i6, voldatiin)
1529
1530 WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
1531 voldatiout(:,:) = voldatiout(:,:) - voldatiin(:,:)
1532 ELSEWHERE
1533 voldatiout(:,:) = rmiss
1534 END WHERE
1535
1536 ELSE ! other stat_proc
1537 DO n = 1, ninp
1538 CALL volgrid_get_vol_2d(this, i3, map_ttr(i,j)%array(n)%it, &
1539 map_ttr(i,j)%array(n)%itr, i6, voldatiin)
1540
1541 IF (n == 1) THEN
1542 voldatiout = voldatiin
1543 IF (lclone) THEN
1544 CALL copy(this%gaid(i3, map_ttr(i,j)%array(n)%it,&
1545 map_ttr(i,j)%array(n)%itr,i6), that%gaid(i3,i,j,i6))
1546 ELSE
1547 that%gaid(i3,i,j,i6) = this%gaid(i3, map_ttr(i,j)%array(n)%it, &
1548 map_ttr(i,j)%array(n)%itr,i6)
1549 ENDIF
1550
1551 ELSE ! second or more time
1552 SELECT CASE(stat_proc)
1553 CASE (0, 1) ! average, accumulation
1554 WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
1555 voldatiout(:,:) = voldatiout(:,:) + voldatiin(:,:)
1556 ELSEWHERE
1557 voldatiout(:,:) = rmiss
1558 END WHERE
1559 CASE(2) ! maximum
1560 WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
1561 voldatiout(:,:) = max(voldatiout(:,:), voldatiin(:,:))
1562 ELSEWHERE
1563 voldatiout(:,:) = rmiss
1564 END WHERE
1565 CASE(3) ! minimum
1566 WHERE(c_e(voldatiin(:,:)) .AND. c_e(voldatiout(:,:)))
1567 voldatiout(:,:) = min(voldatiout(:,:), voldatiin(:,:))
1568 ELSEWHERE
1569 voldatiout(:,:) = rmiss
1570 END WHERE
1571 END SELECT
1572
1573 ENDIF ! first time
1574 ENDDO
1575 IF (stat_proc == 0) THEN ! average
1576 WHERE(c_e(voldatiout(:,:)))
1577 voldatiout(:,:) = voldatiout(:,:)/ninp
1578 END WHERE
1579 ENDIF
1580 ENDIF
1581 CALL volgrid_set_vol_2d(that, i3, i, j, i6, voldatiout)
1582 ENDDO ! level
1583 ENDDO ! var
1584 CALL delete(map_ttr(i,j))
1585 ENDDO do_otime
1586ENDDO do_otimerange
1587
1588DEALLOCATE(map_ttr)
1589
1590
1591END SUBROUTINE volgrid6d_compute_stat_proc_agg
1592
1593
1618SUBROUTINE volgrid6d_recompute_stat_proc_diff(this, that, stat_proc, step, full_steps, start, clone)
1619TYPE(volgrid6d),INTENT(inout) :: this
1620TYPE(volgrid6d),INTENT(out) :: that
1621INTEGER,INTENT(in) :: stat_proc
1622TYPE(timedelta),INTENT(in) :: step
1623LOGICAL,INTENT(in),OPTIONAL :: full_steps
1624TYPE(datetime),INTENT(in),OPTIONAL :: start
1625LOGICAL,INTENT(in),OPTIONAL :: clone
1626INTEGER :: i3, i4, i6, i, j, k, l, nitr, steps
1627INTEGER,ALLOCATABLE :: map_tr(:,:,:,:,:), f(:), keep_tr(:,:,:)
1628REAL,POINTER :: voldatiin1(:,:), voldatiin2(:,:), voldatiout(:,:)
1629!LOGICAL,POINTER :: mask_timerange(:)
1630LOGICAL :: lclone
1631TYPE(vol7d_var),ALLOCATABLE :: varbufr(:)
1632
1633
1634! be safe
1635CALL volgrid6d_alloc_vol(this)
1636! when volume is not decoded it is better to clone anyway to avoid
1637! overwriting fields
1638lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
1639! initialise the output volume
1640CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
1641CALL volgrid6d_alloc(that, dim=this%griddim%dim, &
1642 nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
1643that%level = this%level
1644that%var = this%var
1645
1646! compute length of cumulation step in seconds
1647CALL getval(step, asec=steps)
1648
1649! compute the statistical processing relations, output time and
1650! timerange are defined here
1651CALL recompute_stat_proc_diff_common(this%time, this%timerange, stat_proc, step, &
1652 that%time, that%timerange, map_tr, f, keep_tr, &
1653 this%time_definition, full_steps, start)
1654nitr = SIZE(f)
1655
1656! complete the definition of the output volume
1657CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
1658! allocate workspace once
1659IF (.NOT.ASSOCIATED(that%voldati)) THEN
1660 ALLOCATE(voldatiin1(this%griddim%dim%nx, this%griddim%dim%ny), &
1661 voldatiin2(this%griddim%dim%nx, this%griddim%dim%ny), &
1662 voldatiout(this%griddim%dim%nx, this%griddim%dim%ny))
1663ENDIF
1664
1665! copy the timeranges already satisfying the requested step, if any
1666DO i4 = 1, SIZE(this%time)
1667 DO i = 1, nitr
1668 IF (c_e(keep_tr(i, i4, 2))) THEN
1669 l = keep_tr(i, i4, 1)
1670 k = keep_tr(i, i4, 2)
1671#ifdef DEBUG
1672 CALL l4f_category_log(this%category, l4f_debug, &
1673 'volgrid6d_recompute_stat_proc_diff, good timerange: '//t2c(f(i))// &
1674 '->'//t2c(k))
1675#endif
1676 DO i6 = 1, SIZE(this%var)
1677 DO i3 = 1, SIZE(this%level)
1678 IF (c_e(this%gaid(i3,i4,f(i),i6))) THEN
1679 IF (lclone) THEN
1680 CALL copy(this%gaid(i3,i4,f(i),i6), that%gaid(i3,l,k,i6))
1681 ELSE
1682 that%gaid(i3,l,k,i6) = this%gaid(i3,i4,f(i),i6)
1683 ENDIF
1684 IF (ASSOCIATED(that%voldati)) THEN
1685 that%voldati(:,:,i3,l,k,i6) = this%voldati(:,:,i3,i4,f(i),i6)
1686 ELSE
1687 CALL volgrid_get_vol_2d(this, i3, i4, f(i), i6, voldatiout)
1688 CALL volgrid_set_vol_2d(that, i3, l, k, i6, voldatiout)
1689 ENDIF
1690 ENDIF
1691 ENDDO
1692 ENDDO
1693 ENDIF
1694 ENDDO
1695ENDDO
1696
1697! varbufr required for setting posdef, optimize with an array
1698ALLOCATE(varbufr(SIZE(this%var)))
1699DO i6 = 1, SIZE(this%var)
1700 varbufr(i6) = convert(this%var(i6))
1701ENDDO
1702! compute statistical processing
1703DO l = 1, SIZE(this%time)
1704 DO k = 1, nitr
1705 DO j = 1, SIZE(this%time)
1706 DO i = 1, nitr
1707 IF (c_e(map_tr(i,j,k,l,1))) THEN
1708 DO i6 = 1, SIZE(this%var)
1709 DO i3 = 1, SIZE(this%level)
1710
1711 IF (c_e(this%gaid(i3,j,f(i),i6)) .AND. &
1712 c_e(this%gaid(i3,l,f(k),i6))) THEN
1713! take the gaid from the second time/timerange contributing to the
1714! result (l,f(k))
1715 IF (lclone) THEN
1716 CALL copy(this%gaid(i3,l,f(k),i6), &
1717 that%gaid(i3,map_tr(i,j,k,l,1),map_tr(i,j,k,l,2),i6))
1718 ELSE
1719 that%gaid(i3,map_tr(i,j,k,l,1),map_tr(i,j,k,l,2),i6) = &
1720 this%gaid(i3,l,f(k),i6)
1721 ENDIF
1722
1723! get/set 2d sections API is used
1724 CALL volgrid_get_vol_2d(this, i3, l, f(k), i6, voldatiin1)
1725 CALL volgrid_get_vol_2d(this, i3, j, f(i), i6, voldatiin2)
1726 IF (ASSOCIATED(that%voldati)) &
1727 CALL volgrid_get_vol_2d(that, i3, &
1728 map_tr(i,j,k,l,1), map_tr(i,j,k,l,2), i6, voldatiout)
1729
1730 IF (stat_proc == 0) THEN ! average
1731 WHERE(c_e(voldatiin1(:,:)) .AND. c_e(voldatiin2(:,:)))
1732 voldatiout(:,:) = &
1733 (voldatiin1(:,:)*this%timerange(f(k))%p2 - &
1734 voldatiin2(:,:)*this%timerange(f(i))%p2)/ &
1735 steps
1736 ELSEWHERE
1737 voldatiout(:,:) = rmiss
1738 END WHERE
1739 ELSE IF (stat_proc == 1 .OR. stat_proc == 4) THEN ! acc, diff
1740 WHERE(c_e(voldatiin1(:,:)) .AND. c_e(voldatiin2(:,:)))
1741 voldatiout(:,:) = voldatiin1(:,:) - voldatiin2(:,:)
1742 ELSEWHERE
1743 voldatiout(:,:) = rmiss
1744 END WHERE
1745 IF (stat_proc == 1) THEN
1746 CALL vol7d_var_features_posdef_apply(varbufr(i6), voldatiout)
1747 ENDIF
1748 ENDIF
1749
1750 CALL volgrid_set_vol_2d(that, i3, &
1751 map_tr(i,j,k,l,1), map_tr(i,j,k,l,2), i6, voldatiout)
1752
1753 ENDIF
1754 ENDDO
1755 ENDDO
1756 ENDIF
1757 ENDDO
1758 ENDDO
1759 ENDDO
1760ENDDO
1761
1762IF (.NOT.ASSOCIATED(that%voldati)) THEN
1763 DEALLOCATE(voldatiin1, voldatiin2, voldatiout)
1764ENDIF
1765
1766END SUBROUTINE volgrid6d_recompute_stat_proc_diff
1767
1768
1796SUBROUTINE volgrid6d_compute_stat_proc_metamorph(this, that, stat_proc_input, stat_proc, clone)
1797TYPE(volgrid6d),INTENT(inout) :: this
1798TYPE(volgrid6d),INTENT(out) :: that
1799INTEGER,INTENT(in) :: stat_proc_input
1800INTEGER,INTENT(in) :: stat_proc
1801LOGICAL , INTENT(in),OPTIONAL :: clone
1802
1803INTEGER :: j, i3, i4, i6
1804INTEGER,POINTER :: map_tr(:)
1805REAL,POINTER :: voldatiin(:,:), voldatiout(:,:)
1806REAL,ALLOCATABLE :: int_ratio(:)
1807LOGICAL :: lclone
1808
1809NULLIFY(voldatiin, voldatiout)
1810
1811! be safe
1812CALL volgrid6d_alloc_vol(this)
1813! when volume is not decoded it is better to clone anyway to avoid
1814! overwriting fields
1815lclone = optio_log(clone) .OR. .NOT.ASSOCIATED(this%voldati)
1816
1817IF (.NOT.((stat_proc_input == 0 .AND. stat_proc == 1) .OR. &
1818 (stat_proc_input == 1 .AND. stat_proc == 0))) THEN
1819
1820 CALL l4f_category_log(this%category, l4f_warn, &
1821 'compute_stat_proc_metamorph, can only be applied to average->accumulated timerange and viceversa')
1822! return an empty volume, without signaling error
1823 CALL init(that)
1824 CALL volgrid6d_alloc_vol(that)
1825 RETURN
1826ENDIF
1827
1828! initialise the output volume
1829CALL init(that, griddim=this%griddim, time_definition=this%time_definition)
1830CALL volgrid6d_alloc(that, dim=this%griddim%dim, ntime=SIZE(this%time), &
1831 nlevel=SIZE(this%level), nvar=SIZE(this%var), ini=.false.)
1832that%time = this%time
1833that%level = this%level
1834that%var = this%var
1835
1836CALL compute_stat_proc_metamorph_common(stat_proc_input, this%timerange, stat_proc, &
1837 that%timerange, map_tr)
1838
1839! complete the definition of the output volume
1840CALL volgrid6d_alloc_vol(that, decode=ASSOCIATED(this%voldati))
1841
1842IF (stat_proc == 0) THEN ! average -> integral
1843 int_ratio = 1./real(that%timerange(:)%p2)
1844ELSE ! cumulation
1845 int_ratio = real(that%timerange(:)%p2)
1846ENDIF
1847
1848DO i6 = 1, SIZE(this%var)
1849 DO j = 1, SIZE(map_tr)
1850 DO i4 = 1, SIZE(that%time)
1851 DO i3 = 1, SIZE(this%level)
1852
1853 IF (lclone) THEN
1854 CALL copy(this%gaid(i3,i4,map_tr(j),i6), that%gaid(i3,i4,j,i6))
1855 ELSE
1856 that%gaid(i3,i4,map_tr(j),i6) = this%gaid(i3,i4,j,i6)
1857 ENDIF
1858 CALL volgrid_get_vol_2d(this, i3, i4, map_tr(j), i6, voldatiin)
1859 CALL volgrid_get_vol_2d(that, i3, i4, j, i6, voldatiout)
1860 WHERE (c_e(voldatiin))
1861 voldatiout = voldatiin*int_ratio(j)
1862 ELSEWHERE
1863 voldatiout = rmiss
1864 END WHERE
1865 CALL volgrid_set_vol_2d(that, i3, i4, j, i6, voldatiout)
1866 ENDDO
1867 ENDDO
1868 ENDDO
1869ENDDO
1870
1871
1872END SUBROUTINE volgrid6d_compute_stat_proc_metamorph
1873
1888SUBROUTINE volgrid6d_compute_vert_coord_var(this, level, volgrid_lev)
1889TYPE(volgrid6d),INTENT(in) :: this
1890TYPE(vol7d_level),INTENT(in) :: level
1891TYPE(volgrid6d),INTENT(out) :: volgrid_lev
1892
1893INTEGER :: nlev, i, ii, iii, iiii
1894TYPE(grid_id) :: out_gaid
1895LOGICAL,ALLOCATABLE :: levmask(:)
1896TYPE(volgrid6d_var) :: lev_var
1897
1898CALL init(volgrid_lev) ! initialise to null
1899IF (.NOT.ASSOCIATED(this%gaid)) THEN
1900 CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: input volume not allocated')
1901 RETURN
1902ENDIF
1903! if layer, both surfaces must be of the same type
1904IF (c_e(level%level2) .AND. level%level1 /= level%level2) THEN
1905 CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: requested (mixed) layer type not valid')
1906 RETURN
1907ENDIF
1908
1909! look for valid levels to be converted to vars
1910ALLOCATE(levmask(SIZE(this%level)))
1911levmask = this%level%level1 == level%level1 .AND. &
1912 this%level%level2 == level%level2 .AND. c_e(this%level%l1)
1913IF (c_e(level%level2)) levmask = levmask .AND. c_e(this%level%l2)
1914nlev = count(levmask)
1915IF (nlev == 0) THEN
1916 CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: requested level type not available')
1917 RETURN
1918ENDIF
1919
1920out_gaid = grid_id_new()
1921gaidloop: DO i=1 ,SIZE(this%gaid,1)
1922 DO ii=1 ,SIZE(this%gaid,2)
1923 DO iii=1 ,SIZE(this%gaid,3)
1924 DO iiii=1 ,SIZE(this%gaid,4)
1925 IF (c_e(this%gaid(i,ii,iii,iiii))) THEN ! conserve first valid gaid
1926 CALL copy(this%gaid(i,ii,iii,iiii), out_gaid)
1927 EXIT gaidloop
1928 ENDIF
1929 ENDDO
1930 ENDDO
1931 ENDDO
1932ENDDO gaidloop
1933
1934! look for variable corresponding to level
1935lev_var = convert(vol7d_var_new(btable=vol7d_level_to_var(level)), &
1936 grid_id_template=out_gaid)
1937IF (.NOT.c_e(lev_var)) THEN
1938 CALL l4f_log(l4f_error, 'volgrid6d_compute_vert_coord_var: no variable corresponds to requested level type')
1939 RETURN
1940ENDIF
1941
1942! prepare output volume
1943CALL init(volgrid_lev, griddim=this%griddim, &
1944 time_definition=this%time_definition) !, categoryappend=categoryappend)
1945CALL volgrid6d_alloc(volgrid_lev, ntime=SIZE(this%time), nlevel=nlev, &
1946 ntimerange=SIZE(this%timerange), nvar=1)
1947! fill metadata
1948volgrid_lev%time = this%time
1949volgrid_lev%level = pack(this%level, mask=levmask)
1950volgrid_lev%timerange = this%timerange
1951volgrid_lev%var(1) = lev_var
1952
1953CALL volgrid6d_alloc_vol(volgrid_lev, decode=.true.)
1954! fill data
1955DO i = 1, nlev
1956 IF (c_e(level%level2)) THEN
1957 volgrid_lev%voldati(:,:,i,:,:,:) = real(volgrid_lev%level(i)%l1 + &
1958 volgrid_lev%level(i)%l2)* &
1959 vol7d_level_to_var_factor(volgrid_lev%level(i))/2.
1960 ELSE
1961 volgrid_lev%voldati(:,:,i,:,:,:) = real(volgrid_lev%level(i)%l1)* &
1962 vol7d_level_to_var_factor(volgrid_lev%level(i))
1963 ENDIF
1964ENDDO
1965! fill gaid for subsequent export
1966IF (c_e(out_gaid)) THEN
1967 DO i=1 ,SIZE(volgrid_lev%gaid,1)
1968 DO ii=1 ,SIZE(volgrid_lev%gaid,2)
1969 DO iii=1 ,SIZE(volgrid_lev%gaid,3)
1970 DO iiii=1 ,SIZE(volgrid_lev%gaid,4)
1971 CALL copy(out_gaid, volgrid_lev%gaid(i,ii,iii,iiii))
1972 ENDDO
1973 ENDDO
1974 ENDDO
1975 ENDDO
1976 CALL delete(out_gaid)
1977ENDIF
1978
1979END SUBROUTINE volgrid6d_compute_vert_coord_var
1980
1981END MODULE volgrid6d_class_compute
Distruttori per le 2 classi.
Restituiscono il valore dell'oggetto nella forma desiderata.
Costruttori per le classi datetime e timedelta.
Functions that return a trimmed CHARACTER representation of the input variable.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Make a deep copy, if possible, of the grid identifier.
Apply the conversion function this to values.
Classi per la gestione delle coordinate temporali.
This module defines an abstract interface to different drivers for access to files containing gridded...
Module for basic statistical computations taking into account missing data.
This module contains functions that are only for internal use of the library.
Extension of volgrid6d_class with methods for performing simple statistical operations on entire volu...
This module defines objects and methods for managing data volumes on rectangular georeferenced grids.
Class for managing physical variables in a grib 1/2 fashion.

Generated with Doxygen.