libsim Versione 7.1.11

◆ 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 1034 del file volgrid6d_class_compute.F90.

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