libsim Versione 7.1.11
|
◆ invalidatedi()
Data invalidated check.
Definizione alla linea 906 del file modqc.F90. 907! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
908! authors:
909! Davide Cesari <dcesari@arpa.emr.it>
910! Paolo Patruno <ppatruno@arpa.emr.it>
911
912! This program is free software; you can redistribute it and/or
913! modify it under the terms of the GNU General Public License as
914! published by the Free Software Foundation; either version 2 of
915! the License, or (at your option) any later version.
916
917! This program is distributed in the hope that it will be useful,
918! but WITHOUT ANY WARRANTY; without even the implied warranty of
919! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
920! GNU General Public License for more details.
921
922! You should have received a copy of the GNU General Public License
923! along with this program. If not, see <http://www.gnu.org/licenses/>.
924#include "config.h"
925
928
1080
1081
1082implicit none
1083
1084
1087 integer (kind=int_b):: att
1088 integer (kind=int_b):: gross_error ! special valuer for "*B33192" when gross error check failed
1089 integer (kind=int_b):: invalidated ! special valuer for "*B33196" when manual invalidation happen
1091
1094
1095integer, parameter :: nqcattrvars=4
1096CHARACTER(len=10),parameter :: qcattrvarsbtables(nqcattrvars)=(/"*B33196","*B33192","*B33193","*B33194"/)
1097
1098type :: qcattrvars
1099 TYPE(vol7d_var) :: vars(nqcattrvars)
1100 CHARACTER(len=10) :: btables(nqcattrvars)
1101end type qcattrvars
1102
1105 module procedure init_qcattrvars
1106end interface
1107
1110 module procedure peeledrb, peeleddb, peeledbb, peeledib, peeledcb &
1111 ,peeledri, peeleddi, peeledbi, peeledii, peeledci &
1112 ,peeledrr, peeleddr, peeledbr, peeledir, peeledcr &
1113 ,peeledrd, peeleddd, peeledbd, peeledid, peeledcd &
1114 ,peeledrc, peeleddc, peeledbc, peeledic, peeledcc
1115end interface
1116
1117
1120 module procedure vdi,vdb,vdr,vdd,vdc
1121end interface
1122
1125 module procedure vdgei,vdgeb,vdger,vdged,vdgec
1126end interface
1127
1130 module procedure invalidatedi,invalidatedb,invalidatedr,invalidatedd,invalidatedc
1131end interface
1132
1133private
1134
1136public qcattrvars, nqcattrvars, qcattrvarsbtables
1138
1139contains
1140
1141
1142! peeled routines
1143#undef VOL7D_POLY_SUBTYPE
1144#undef VOL7D_POLY_SUBTYPES
1145#undef VOL7D_POLY_ISC
1146#define VOL7D_POLY_SUBTYPE REAL
1147#define VOL7D_POLY_SUBTYPES r
1148
1149#undef VOL7D_POLY_TYPE
1150#undef VOL7D_POLY_TYPES
1151#undef VOL7D_POLY_ISC
1152#undef VOL7D_POLY_TYPES_SUBTYPES
1153#define VOL7D_POLY_TYPE REAL
1154#define VOL7D_POLY_TYPES r
1155#define VOL7D_POLY_TYPES_SUBTYPES rr
1156#include "modqc_peeled_include.F90"
1157#include "modqc_peel_util_include.F90"
1158#undef VOL7D_POLY_TYPE
1159#undef VOL7D_POLY_TYPES
1160#undef VOL7D_POLY_TYPES_SUBTYPES
1161#define VOL7D_POLY_TYPE DOUBLE PRECISION
1162#define VOL7D_POLY_TYPES d
1163#define VOL7D_POLY_TYPES_SUBTYPES dr
1164#include "modqc_peeled_include.F90"
1165#include "modqc_peel_util_include.F90"
1166#undef VOL7D_POLY_TYPE
1167#undef VOL7D_POLY_TYPES
1168#undef VOL7D_POLY_TYPES_SUBTYPES
1169#define VOL7D_POLY_TYPE INTEGER
1170#define VOL7D_POLY_TYPES i
1171#define VOL7D_POLY_TYPES_SUBTYPES ir
1172#include "modqc_peeled_include.F90"
1173#include "modqc_peel_util_include.F90"
1174#undef VOL7D_POLY_TYPE
1175#undef VOL7D_POLY_TYPES
1176#undef VOL7D_POLY_TYPES_SUBTYPES
1177#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1178#define VOL7D_POLY_TYPES b
1179#define VOL7D_POLY_TYPES_SUBTYPES br
1180#include "modqc_peeled_include.F90"
1181#include "modqc_peel_util_include.F90"
1182#undef VOL7D_POLY_TYPE
1183#undef VOL7D_POLY_TYPES
1184#undef VOL7D_POLY_TYPES_SUBTYPES
1185#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1186#define VOL7D_POLY_TYPES c
1187#define VOL7D_POLY_ISC = 1
1188#define VOL7D_POLY_TYPES_SUBTYPES cr
1189#include "modqc_peeled_include.F90"
1190#include "modqc_peel_util_include.F90"
1191
1192
1193#undef VOL7D_POLY_SUBTYPE
1194#undef VOL7D_POLY_SUBTYPES
1195#undef VOL7D_POLY_ISC
1196#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1197#define VOL7D_POLY_SUBTYPES d
1198
1199#undef VOL7D_POLY_TYPE
1200#undef VOL7D_POLY_TYPES
1201#undef VOL7D_POLY_TYPES_SUBTYPES
1202#define VOL7D_POLY_TYPE REAL
1203#define VOL7D_POLY_TYPES r
1204#define VOL7D_POLY_TYPES_SUBTYPES rd
1205#include "modqc_peeled_include.F90"
1206#undef VOL7D_POLY_TYPE
1207#undef VOL7D_POLY_TYPES
1208#undef VOL7D_POLY_TYPES_SUBTYPES
1209#define VOL7D_POLY_TYPE DOUBLE PRECISION
1210#define VOL7D_POLY_TYPES d
1211#define VOL7D_POLY_TYPES_SUBTYPES dd
1212#include "modqc_peeled_include.F90"
1213#undef VOL7D_POLY_TYPE
1214#undef VOL7D_POLY_TYPES
1215#undef VOL7D_POLY_TYPES_SUBTYPES
1216#define VOL7D_POLY_TYPE INTEGER
1217#define VOL7D_POLY_TYPES i
1218#define VOL7D_POLY_TYPES_SUBTYPES id
1219#include "modqc_peeled_include.F90"
1220#undef VOL7D_POLY_TYPE
1221#undef VOL7D_POLY_TYPES
1222#undef VOL7D_POLY_TYPES_SUBTYPES
1223#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1224#define VOL7D_POLY_TYPES b
1225#define VOL7D_POLY_TYPES_SUBTYPES bd
1226#include "modqc_peeled_include.F90"
1227#undef VOL7D_POLY_TYPE
1228#undef VOL7D_POLY_TYPES
1229#undef VOL7D_POLY_TYPES_SUBTYPES
1230#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1231#define VOL7D_POLY_TYPES c
1232#define VOL7D_POLY_TYPES_SUBTYPES cd
1233#include "modqc_peeled_include.F90"
1234
1235
1236#undef VOL7D_POLY_SUBTYPE
1237#undef VOL7D_POLY_SUBTYPES
1238#undef VOL7D_POLY_ISC
1239#define VOL7D_POLY_SUBTYPE INTEGER
1240#define VOL7D_POLY_SUBTYPES i
1241
1242#undef VOL7D_POLY_TYPE
1243#undef VOL7D_POLY_TYPES
1244#undef VOL7D_POLY_TYPES_SUBTYPES
1245#define VOL7D_POLY_TYPE REAL
1246#define VOL7D_POLY_TYPES r
1247#define VOL7D_POLY_TYPES_SUBTYPES ri
1248#include "modqc_peeled_include.F90"
1249#undef VOL7D_POLY_TYPE
1250#undef VOL7D_POLY_TYPES
1251#undef VOL7D_POLY_TYPES_SUBTYPES
1252#define VOL7D_POLY_TYPE DOUBLE PRECISION
1253#define VOL7D_POLY_TYPES d
1254#define VOL7D_POLY_TYPES_SUBTYPES di
1255#include "modqc_peeled_include.F90"
1256#undef VOL7D_POLY_TYPE
1257#undef VOL7D_POLY_TYPES
1258#undef VOL7D_POLY_TYPES_SUBTYPES
1259#define VOL7D_POLY_TYPE INTEGER
1260#define VOL7D_POLY_TYPES i
1261#define VOL7D_POLY_TYPES_SUBTYPES ii
1262#include "modqc_peeled_include.F90"
1263#undef VOL7D_POLY_TYPE
1264#undef VOL7D_POLY_TYPES
1265#undef VOL7D_POLY_TYPES_SUBTYPES
1266#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1267#define VOL7D_POLY_TYPES b
1268#define VOL7D_POLY_TYPES_SUBTYPES bi
1269#include "modqc_peeled_include.F90"
1270#undef VOL7D_POLY_TYPE
1271#undef VOL7D_POLY_TYPES
1272#undef VOL7D_POLY_TYPES_SUBTYPES
1273#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1274#define VOL7D_POLY_TYPES c
1275#define VOL7D_POLY_ISC = 1
1276#define VOL7D_POLY_TYPES_SUBTYPES ci
1277#include "modqc_peeled_include.F90"
1278
1279
1280#undef VOL7D_POLY_SUBTYPE
1281#undef VOL7D_POLY_SUBTYPES
1282#undef VOL7D_POLY_ISC
1283#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1284#define VOL7D_POLY_SUBTYPES b
1285
1286#undef VOL7D_POLY_TYPE
1287#undef VOL7D_POLY_TYPES
1288#undef VOL7D_POLY_TYPES_SUBTYPES
1289#define VOL7D_POLY_TYPE REAL
1290#define VOL7D_POLY_TYPES r
1291#define VOL7D_POLY_TYPES_SUBTYPES rb
1292#include "modqc_peeled_include.F90"
1293#undef VOL7D_POLY_TYPE
1294#undef VOL7D_POLY_TYPES
1295#undef VOL7D_POLY_TYPES_SUBTYPES
1296#define VOL7D_POLY_TYPE DOUBLE PRECISION
1297#define VOL7D_POLY_TYPES d
1298#define VOL7D_POLY_TYPES_SUBTYPES db
1299#include "modqc_peeled_include.F90"
1300#undef VOL7D_POLY_TYPE
1301#undef VOL7D_POLY_TYPES
1302#undef VOL7D_POLY_TYPES_SUBTYPES
1303#define VOL7D_POLY_TYPE INTEGER
1304#define VOL7D_POLY_TYPES i
1305#define VOL7D_POLY_TYPES_SUBTYPES ib
1306#include "modqc_peeled_include.F90"
1307#undef VOL7D_POLY_TYPE
1308#undef VOL7D_POLY_TYPES
1309#undef VOL7D_POLY_TYPES_SUBTYPES
1310#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1311#define VOL7D_POLY_TYPES b
1312#define VOL7D_POLY_TYPES_SUBTYPES bb
1313#include "modqc_peeled_include.F90"
1314#undef VOL7D_POLY_TYPE
1315#undef VOL7D_POLY_TYPES
1316#undef VOL7D_POLY_TYPES_SUBTYPES
1317#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1318#define VOL7D_POLY_TYPES c
1319#define VOL7D_POLY_ISC = 1
1320#define VOL7D_POLY_TYPES_SUBTYPES cb
1321#include "modqc_peeled_include.F90"
1322
1323
1324#undef VOL7D_POLY_SUBTYPE
1325#undef VOL7D_POLY_SUBTYPES
1326#undef VOL7D_POLY_ISC
1327#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1328#define VOL7D_POLY_SUBTYPES c
1329
1330#undef VOL7D_POLY_TYPE
1331#undef VOL7D_POLY_TYPES
1332#undef VOL7D_POLY_TYPES_SUBTYPES
1333#define VOL7D_POLY_TYPE REAL
1334#define VOL7D_POLY_TYPES r
1335#define VOL7D_POLY_TYPES_SUBTYPES rc
1336#include "modqc_peeled_include.F90"
1337#undef VOL7D_POLY_TYPE
1338#undef VOL7D_POLY_TYPES
1339#undef VOL7D_POLY_TYPES_SUBTYPES
1340#define VOL7D_POLY_TYPE DOUBLE PRECISION
1341#define VOL7D_POLY_TYPES d
1342#define VOL7D_POLY_TYPES_SUBTYPES dc
1343#include "modqc_peeled_include.F90"
1344#undef VOL7D_POLY_TYPE
1345#undef VOL7D_POLY_TYPES
1346#undef VOL7D_POLY_TYPES_SUBTYPES
1347#define VOL7D_POLY_TYPE INTEGER
1348#define VOL7D_POLY_TYPES i
1349#define VOL7D_POLY_TYPES_SUBTYPES ic
1350#include "modqc_peeled_include.F90"
1351#undef VOL7D_POLY_TYPE
1352#undef VOL7D_POLY_TYPES
1353#undef VOL7D_POLY_TYPES_SUBTYPES
1354#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1355#define VOL7D_POLY_TYPES b
1356#define VOL7D_POLY_TYPES_SUBTYPES bc
1357#include "modqc_peeled_include.F90"
1358#undef VOL7D_POLY_TYPE
1359#undef VOL7D_POLY_TYPES
1360#undef VOL7D_POLY_TYPES_SUBTYPES
1361#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1362#define VOL7D_POLY_TYPES c
1363#define VOL7D_POLY_ISC = 1
1364#define VOL7D_POLY_TYPES_SUBTYPES cc
1365#include "modqc_peeled_include.F90"
1366
1367
1368subroutine init_qcattrvars(this)
1369
1370type(qcattrvars),intent(inout) :: this
1371integer :: i
1372
1373this%btables(:) =qcattrvarsbtables
1374do i =1, nqcattrvars
1376end do
1377
1378end subroutine init_qcattrvars
1379
1380
1381type(qcattrvars) function qcattrvars_new()
1382
1384
1385end function qcattrvars_new
1386
1387
1395SUBROUTINE vol7d_peeling(this, data_id, keep_attr, delete_attr, preserve, purgeana)
1396TYPE(vol7d),INTENT(INOUT) :: this
1397integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1398CHARACTER(len=*),INTENT(in),OPTIONAL :: keep_attr(:)
1399CHARACTER(len=*),INTENT(in),OPTIONAL :: delete_attr(:)
1400logical,intent(in),optional :: preserve
1401logical,intent(in),optional :: purgeana
1402
1403integer :: inddativar,inddatiattrinv,inddatiattrcli,inddatiattrtem,inddatiattrspa,inddativarattr
1404type(qcattrvars) :: attrvars
1405
1406INTEGER(kind=int_b),pointer :: invbb(:,:,:,:,:),clibb(:,:,:,:,:),tembb(:,:,:,:,:),spabb(:,:,:,:,:)
1407INTEGER,pointer :: invbi(:,:,:,:,:),clibi(:,:,:,:,:),tembi(:,:,:,:,:),spabi(:,:,:,:,:)
1408REAL,pointer :: invbr(:,:,:,:,:),clibr(:,:,:,:,:),tembr(:,:,:,:,:),spabr(:,:,:,:,:)
1409DOUBLE PRECISION,pointer :: invbd(:,:,:,:,:),clibd(:,:,:,:,:),tembd(:,:,:,:,:),spabd(:,:,:,:,:)
1410CHARACTER(len=vol7d_cdatalen),pointer :: invbc(:,:,:,:,:),clibc(:,:,:,:,:),tembc(:,:,:,:,:),spabc(:,:,:,:,:)
1411
1412call l4f_log(l4f_info,'starting peeling')
1413
1415
1416! generate code per i vari tipi di dati di v7d
1417! tramite un template e il preprocessore
1418
1419
1420#undef VOL7D_POLY_SUBTYPE
1421#undef VOL7D_POLY_SUBTYPES
1422#define VOL7D_POLY_SUBTYPE REAL
1423#define VOL7D_POLY_SUBTYPES r
1424
1425#undef VOL7D_POLY_TYPE
1426#undef VOL7D_POLY_TYPES
1427#define VOL7D_POLY_TYPE REAL
1428#define VOL7D_POLY_TYPES r
1429#include "modqc_peeling_include.F90"
1430#undef VOL7D_POLY_TYPE
1431#undef VOL7D_POLY_TYPES
1432#define VOL7D_POLY_TYPE DOUBLE PRECISION
1433#define VOL7D_POLY_TYPES d
1434#include "modqc_peeling_include.F90"
1435#undef VOL7D_POLY_TYPE
1436#undef VOL7D_POLY_TYPES
1437#define VOL7D_POLY_TYPE INTEGER
1438#define VOL7D_POLY_TYPES i
1439#include "modqc_peeling_include.F90"
1440#undef VOL7D_POLY_TYPE
1441#undef VOL7D_POLY_TYPES
1442#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1443#define VOL7D_POLY_TYPES b
1444#include "modqc_peeling_include.F90"
1445#undef VOL7D_POLY_TYPE
1446#undef VOL7D_POLY_TYPES
1447#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1448#define VOL7D_POLY_TYPES c
1449#include "modqc_peeling_include.F90"
1450
1451
1452#undef VOL7D_POLY_SUBTYPE
1453#undef VOL7D_POLY_SUBTYPES
1454#define VOL7D_POLY_SUBTYPE DOUBLE PRECISION
1455#define VOL7D_POLY_SUBTYPES d
1456
1457#undef VOL7D_POLY_TYPE
1458#undef VOL7D_POLY_TYPES
1459#define VOL7D_POLY_TYPE REAL
1460#define VOL7D_POLY_TYPES r
1461#include "modqc_peeling_include.F90"
1462#undef VOL7D_POLY_TYPE
1463#undef VOL7D_POLY_TYPES
1464#define VOL7D_POLY_TYPE DOUBLE PRECISION
1465#define VOL7D_POLY_TYPES d
1466#include "modqc_peeling_include.F90"
1467#undef VOL7D_POLY_TYPE
1468#undef VOL7D_POLY_TYPES
1469#define VOL7D_POLY_TYPE INTEGER
1470#define VOL7D_POLY_TYPES i
1471#include "modqc_peeling_include.F90"
1472#undef VOL7D_POLY_TYPE
1473#undef VOL7D_POLY_TYPES
1474#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1475#define VOL7D_POLY_TYPES b
1476#include "modqc_peeling_include.F90"
1477#undef VOL7D_POLY_TYPE
1478#undef VOL7D_POLY_TYPES
1479#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1480#define VOL7D_POLY_TYPES c
1481#include "modqc_peeling_include.F90"
1482
1483
1484#undef VOL7D_POLY_SUBTYPE
1485#undef VOL7D_POLY_SUBTYPES
1486#define VOL7D_POLY_SUBTYPE INTEGER
1487#define VOL7D_POLY_SUBTYPES i
1488
1489#undef VOL7D_POLY_TYPE
1490#undef VOL7D_POLY_TYPES
1491#define VOL7D_POLY_TYPE REAL
1492#define VOL7D_POLY_TYPES r
1493#include "modqc_peeling_include.F90"
1494#undef VOL7D_POLY_TYPE
1495#undef VOL7D_POLY_TYPES
1496#define VOL7D_POLY_TYPE DOUBLE PRECISION
1497#define VOL7D_POLY_TYPES d
1498#include "modqc_peeling_include.F90"
1499#undef VOL7D_POLY_TYPE
1500#undef VOL7D_POLY_TYPES
1501#define VOL7D_POLY_TYPE INTEGER
1502#define VOL7D_POLY_TYPES i
1503#include "modqc_peeling_include.F90"
1504#undef VOL7D_POLY_TYPE
1505#undef VOL7D_POLY_TYPES
1506#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1507#define VOL7D_POLY_TYPES b
1508#include "modqc_peeling_include.F90"
1509#undef VOL7D_POLY_TYPE
1510#undef VOL7D_POLY_TYPES
1511#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1512#define VOL7D_POLY_TYPES c
1513#include "modqc_peeling_include.F90"
1514
1515
1516#undef VOL7D_POLY_SUBTYPE
1517#undef VOL7D_POLY_SUBTYPES
1518#define VOL7D_POLY_SUBTYPE INTEGER(kind=int_b)
1519#define VOL7D_POLY_SUBTYPES b
1520
1521#undef VOL7D_POLY_TYPE
1522#undef VOL7D_POLY_TYPES
1523#define VOL7D_POLY_TYPE REAL
1524#define VOL7D_POLY_TYPES r
1525#include "modqc_peeling_include.F90"
1526#undef VOL7D_POLY_TYPE
1527#undef VOL7D_POLY_TYPES
1528#define VOL7D_POLY_TYPE DOUBLE PRECISION
1529#define VOL7D_POLY_TYPES d
1530#include "modqc_peeling_include.F90"
1531#undef VOL7D_POLY_TYPE
1532#undef VOL7D_POLY_TYPES
1533#define VOL7D_POLY_TYPE INTEGER
1534#define VOL7D_POLY_TYPES i
1535#include "modqc_peeling_include.F90"
1536#undef VOL7D_POLY_TYPE
1537#undef VOL7D_POLY_TYPES
1538#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1539#define VOL7D_POLY_TYPES b
1540#include "modqc_peeling_include.F90"
1541#undef VOL7D_POLY_TYPE
1542#undef VOL7D_POLY_TYPES
1543#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1544#define VOL7D_POLY_TYPES c
1545#include "modqc_peeling_include.F90"
1546
1547
1548
1549#undef VOL7D_POLY_SUBTYPE
1550#undef VOL7D_POLY_SUBTYPES
1551#define VOL7D_POLY_SUBTYPE CHARACTER(len=vol7d_cdatalen)
1552#define VOL7D_POLY_SUBTYPES c
1553
1554#undef VOL7D_POLY_TYPE
1555#undef VOL7D_POLY_TYPES
1556#define VOL7D_POLY_TYPE REAL
1557#define VOL7D_POLY_TYPES r
1558#include "modqc_peeling_include.F90"
1559#undef VOL7D_POLY_TYPE
1560#undef VOL7D_POLY_TYPES
1561#define VOL7D_POLY_TYPE DOUBLE PRECISION
1562#define VOL7D_POLY_TYPES d
1563#include "modqc_peeling_include.F90"
1564#undef VOL7D_POLY_TYPE
1565#undef VOL7D_POLY_TYPES
1566#define VOL7D_POLY_TYPE INTEGER
1567#define VOL7D_POLY_TYPES i
1568#include "modqc_peeling_include.F90"
1569#undef VOL7D_POLY_TYPE
1570#undef VOL7D_POLY_TYPES
1571#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
1572#define VOL7D_POLY_TYPES b
1573#include "modqc_peeling_include.F90"
1574#undef VOL7D_POLY_TYPE
1575#undef VOL7D_POLY_TYPES
1576#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
1577#define VOL7D_POLY_TYPES c
1578#include "modqc_peeling_include.F90"
1579
1580
1581
1582IF (.NOT.PRESENT(keep_attr) .AND. .NOT.PRESENT(delete_attr) .and. .not. optio_log(preserve)) THEN ! destroy all attributes
1583 IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
1584 IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
1585 IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
1586 IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
1587 IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
1588
1589 CALL delete(this%datiattr)
1590 CALL delete(this%dativarattr)
1591END IF
1592
1593IF (PRESENT(keep_attr)) THEN ! set to missing non requested attributes and reform
1594
1595 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: keep_attr passed")
1596 CALL keep_var(this%datiattr%r)
1597 CALL keep_var(this%datiattr%d)
1598 CALL keep_var(this%datiattr%i)
1599 CALL keep_var(this%datiattr%b)
1600 CALL keep_var(this%datiattr%c)
1601 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1602
1603ELSE IF (PRESENT(delete_attr)) THEN ! set to missing requested attributes and reform
1604
1605 if (optio_log(preserve)) call l4f_log(l4f_warn,"preserve parameter ignored: delete_attr passed")
1606 CALL delete_var(this%datiattr%r)
1607 CALL delete_var(this%datiattr%d)
1608 CALL delete_var(this%datiattr%i)
1609 CALL delete_var(this%datiattr%b)
1610 CALL delete_var(this%datiattr%c)
1611 CALL qc_reform(this,data_id, miss=.true., purgeana=purgeana)
1612
1613ELSE IF (PRESENT(purgeana)) THEN
1614
1615 CALL qc_reform(this,data_id, purgeana=purgeana)
1616
1617ENDIF
1618
1619
1620CONTAINS
1621
1622
1624subroutine qc_reform(this,data_id,miss, purgeana)
1625TYPE(vol7d),INTENT(INOUT) :: this
1626integer,INTENT(inout),pointer,OPTIONAL :: data_id(:,:,:,:,:)
1627logical,intent(in),optional :: miss
1628logical,intent(in),optional :: purgeana
1629
1630integer,pointer :: data_idtmp(:,:,:,:,:)
1631logical,allocatable :: llana(:)
1632integer,allocatable :: anaind(:)
1633integer :: i,j,nana
1634
1635if (optio_log(purgeana)) then
1636 allocate(llana(size(this%ana)))
1637 llana =.false.
1638 do i =1,size(this%ana)
1639 if (associated(this%voldatii)) llana(i)= llana(i) .or. any(c_e(this%voldatii(i,:,:,:,:,:)))
1640 if (associated(this%voldatir)) llana(i)= llana(i) .or. any(c_e(this%voldatir(i,:,:,:,:,:)))
1641 if (associated(this%voldatid)) llana(i)= llana(i) .or. any(c_e(this%voldatid(i,:,:,:,:,:)))
1642 if (associated(this%voldatib)) llana(i)= llana(i) .or. any(c_e(this%voldatib(i,:,:,:,:,:)))
1643 if (associated(this%voldatic)) llana(i)= llana(i) .or. any(c_e(this%voldatic(i,:,:,:,:,:)))
1644
1645#ifdef DEBUG
1646 if (.not. llana(i)) call l4f_log(l4f_debug,"remove station"//t2c(i))
1647#endif
1648
1649 end do
1650
1651 nana=count(llana)
1652
1653
1654 allocate(anaind(nana))
1655
1656 j=0
1657 do i=1,size(this%ana)
1658 if (llana(i)) then
1659 j=j+1
1660 anaind(j)=i
1661 end if
1662 end do
1663
1664
1665 if(present(data_id)) then
1666 allocate(data_idtmp(nana,size(data_id,2),size(data_id,3),size(data_id,4),size(data_id,5)))
1667 data_idtmp=data_id(anaind,:,:,:,:)
1668 if (associated(data_id))deallocate(data_id)
1669 data_id=>data_idtmp
1670 end if
1671
1672 call vol7d_reform(this,miss=miss,lana=llana)
1673
1674 deallocate(llana,anaind)
1675
1676else
1677
1678 call vol7d_reform(this,miss=miss)
1679
1680end if
1681
1682end subroutine qc_reform
1683
1684
1685SUBROUTINE keep_var(var)
1686TYPE(vol7d_var),intent(inout),POINTER :: var(:)
1687
1688INTEGER :: i
1689
1690IF (ASSOCIATED(var)) THEN
1691 if (size(var) == 0) then
1692 var%btable = vol7d_var_miss%btable
1693 else
1694 DO i = 1, SIZE(var)
1695 IF (all(var(i)%btable /= keep_attr(:))) THEN ! n.b. ALL((//)) = .TRUE.
1696 var(i)%btable = vol7d_var_miss%btable
1697 ENDIF
1698 ENDDO
1699 end if
1700ENDIF
1701
1702END SUBROUTINE keep_var
1703
1704SUBROUTINE delete_var(var)
1705TYPE(vol7d_var),intent(inout),POINTER :: var(:)
1706
1707INTEGER :: i
1708
1709IF (ASSOCIATED(var)) THEN
1710 if (size(var) == 0) then
1711 var%btable = vol7d_var_miss%btable
1712 else
1713 DO i = 1, SIZE(var)
1714 IF (any(var(i)%btable == delete_attr(:))) THEN ! n.b. ANY((//)) = .FALSE.
1715 var(i) = vol7d_var_miss
1716 ENDIF
1717 ENDDO
1718 end if
1719ENDIF
1720
1721END SUBROUTINE delete_var
1722
1723END SUBROUTINE vol7d_peeling
1724
1725
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. Definition: missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition: optional_values.f90:28 Classe per la gestione di un volume completo di dati osservati. Definition: vol7d_class.F90:279 |