libsim  Versione6.3.0

◆ dba2v7d()

subroutine dba2v7d ( type(vol7d), intent(inout)  this,
type(dbametaanddata), dimension(:), intent(inout)  metaanddatav,
integer, intent(in), optional  time_definition,
type(vol7d_network), intent(in), optional  set_network 
)

import dba objects in vol7d

Parametri
[in]time_definition0=time is reference time ; 1=time is validity time (default=1)

Definizione alla linea 852 del file vol7d_dballe_class.F03.

852  allocate(anastarvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
853  cycle dn
854  end if
855  end if
856  end do
857  end do
858  end do
859 end do dn
860 
861 
862 !!--------------------------------------------------------------------------
863 
864 
865 !!
866 !! count all unique metadata
867 !!
868 
869 if(ldegnet) then
870  nnetwork=1
871 else
872  !nnetwork = count_distinct(metaanddatav(:)%metadata%network%vol7d_network, back=.TRUE.)
873  allocate (tmpnetwork(size(metaanddatav(:))),&
874  source=metaanddatav(:)%metadata%network%vol7d_network)
875  call sort(tmpnetwork)
876  nnetwork = count_distinct_sorted(tmpnetwork)
877 end if
878 
879 !ntime = count_distinct(metaanddatav(:)%metadata%datetime%datetime, &
880 ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.)
881 allocate (tmptime(size(metaanddatav(:))),&
882  source=metaanddatav(:)%metadata%datetime%datetime)
883 call sort(tmptime)
884 ntime = count_distinct_sorted(tmptime,mask=c_e(tmptime))
885 
886 !ntimerange = count_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, &
887 ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
888 allocate (tmptimerange(size(metaanddatav(:))),&
889  source=metaanddatav(:)%metadata%timerange%vol7d_timerange)
890 call sort(tmptimerange)
891 ntimerange = count_distinct_sorted(tmptimerange,mask=c_e(tmptimerange))
892 
893 !nlevel = count_distinct(metaanddatav(:)%metadata%level%vol7d_level, &
894 ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level),back=.TRUE.)
895 allocate (tmplevel(size(metaanddatav(:))),&
896  source=metaanddatav(:)%metadata%level%vol7d_level)
897 call sort(tmplevel)
898 nlevel = count_distinct_sorted(tmplevel,mask=c_e(tmplevel))
899 
900 !nana = count_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, back=.TRUE.)
901 allocate (tmpana(size(metaanddatav(:))),&
902  source=metaanddatav(:)%metadata%ana%vol7d_ana)
903 call sort(tmpana)
904 nana = count_distinct_sorted(tmpana)
905 
906 !!$if(ldegnet) then
907 !!$ nnetwork=1
908 !!$else
909 !!$ nnetwork = size(metaanddatav(:)%metadata%network%vol7d_network)
910 !!$end if
911 !!$ntime = size(metaanddatav(:)%metadata%datetime%datetime)
912 !!$ntimerange = size(metaanddatav(:)%metadata%timerange%vol7d_timerange)
913 !!$nlevel = size(metaanddatav(:)%metadata%level%vol7d_level)
914 !!$nana = size(metaanddatav(:)%metadata%ana%vol7d_ana)
915 
916  ! var
917 
918 ndativarr = 0
919 ndativari = 0
920 ndativarb = 0
921 ndativard = 0
922 ndativarc = 0
923 
924 do i =1 ,size(vars%dcv)
925  associate(dato => vars%dcv(i)%dat)
926  select type (dato)
927  type is (dbadatar)
928  ndativarr = ndativarr + 1
929  type is (dbadatai)
930  ndativari = ndativari + 1
931  type is (dbadatab)
932  ndativarb = ndativarb + 1
933  type is (dbadatad)
934  ndativard = ndativard + 1
935  type is (dbadatac)
936  ndativarc = ndativarc + 1
937  end select
938  end associate
939 end do
940 
941 
942  !attr
943 
944 ndatiattrr = 0
945 ndatiattri = 0
946 ndatiattrb = 0
947 ndatiattrd = 0
948 ndatiattrc = 0
949 
950 do i =1 ,size(starvars%dcv)
951  associate(dato => starvars%dcv(i)%dat)
952  select type (dato)
953  type is (dbadatar)
954  ndatiattrr = ndatiattrr + 1
955  type is (dbadatai)
956  ndatiattri = ndatiattri + 1
957  type is (dbadatab)
958  ndatiattrb = ndatiattrb + 1
959  type is (dbadatad)
960  ndatiattrd = ndatiattrd + 1
961  type is (dbadatac)
962  ndatiattrc = ndatiattrc + 1
963  end select
964  end associate
965 end do
966 
967 
968  ! ana var
969 
970 nanavarr = 0
971 nanavari = 0
972 nanavarb = 0
973 nanavard = 0
974 nanavarc = 0
975 
976 do i =1 ,size(anavars%dcv)
977  associate(dato => anavars%dcv(i)%dat)
978  select type (dato)
979  type is (dbadatar)
980  nanavarr = nanavarr + 1
981  type is (dbadatai)
982  nanavari = nanavari + 1
983  type is (dbadatab)
984  nanavarb = nanavarb + 1
985  type is (dbadatad)
986  nanavard = nanavard + 1
987  type is (dbadatac)
988  nanavarc = nanavarc + 1
989  end select
990  end associate
991 end do
992 
993 
994  ! ana attr
995 
996 nanaattrr = 0
997 nanaattri = 0
998 nanaattrb = 0
999 nanaattrd = 0
1000 nanaattrc = 0
1001 
1002 do i =1 ,size(anastarvars%dcv)
1003  associate(dato => anastarvars%dcv(i)%dat)
1004  select type (dato)
1005  type is (dbadatar)
1006  nanaattrr = nanaattrr + 1
1007  type is (dbadatai)
1008  nanaattri = nanaattri + 1
1009  type is (dbadatab)
1010  nanaattrb = nanaattrb + 1
1011  type is (dbadatad)
1012  nanaattrd = nanaattrd + 1
1013  type is (dbadatac)
1014  nanaattrc = nanaattrc + 1
1015  end select
1016  end associate
1017 end do
1018 
1019 
1020  !refine
1021 
1022 ndativarattrr=0
1023 ndativarattri=0
1024 ndativarattrb=0
1025 ndativarattrd=0
1026 ndativarattrc=0
1027 
1028 if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1029 if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1030 if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1031 if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1032 if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1033 
1034 
1035 nanavarattrr=0
1036 nanavarattri=0
1037 nanavarattrb=0
1038 nanavarattrd=0
1039 nanavarattrc=0
1040 
1041 if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1042 if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1043 if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1044 if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1045 if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1046 
1047 
1048 CALL init(this,time_definition=ltime_definition)
1049 
1050 !!$print *, "nana=",nana, "ntime=",ntime, "ntimerange=",ntimerange, &
1051 !!$ "nlevel=",nlevel, "nnetwork=",nnetwork, &
1052 !!$ "ndativarr=",ndativarr, "ndativari=",ndativari, &
1053 !!$ "ndativarb=",ndativarb, "ndativard=",ndativard, "ndativarc=",ndativarc,&
1054 !!$ "ndatiattrr=",ndatiattrr, "ndatiattri=",ndatiattri, "ndatiattrb=",ndatiattrb,&
1055 !!$ "ndatiattrd=",ndatiattrd, "ndatiattrc=",ndatiattrc,&
1056 !!$ "ndativarattrr=",ndativarattrr, "ndativarattri=",ndativarattri, "ndativarattrb=",ndativarattrb,&
1057 !!$ "ndativarattrd=",ndativarattrd, "ndativarattrc=",ndativarattrc
1058 !!$
1059 !!$print *,"nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc"
1060 !!$print *,nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc
1061 
1062 
1063 call vol7d_alloc (this, &
1064 nana=nana, ntime=ntime, ntimerange=ntimerange, &
1065 nlevel=nlevel, nnetwork=nnetwork, &
1066 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
1067 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
1068 ndativarattrr=ndativarattrr, &
1069 ndativarattri=ndativarattri, &
1070 ndativarattrb=ndativarattrb, &
1071 ndativarattrd=ndativarattrd, &
1072 ndativarattrc=ndativarattrc,&
1073 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
1074 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
1075 nanavarattrr=nanavarattrr, &
1076 nanavarattri=nanavarattri, &
1077 nanavarattrb=nanavarattrb, &
1078 nanavarattrd=nanavarattrd, &
1079 nanavarattrc=nanavarattrc)
1080 
1081 
1082 ! fill metadata removing contextana metadata
1083 
1084 !nana=count_and_pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana,this%ana, back=.TRUE.)
1085 !this%ana=pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, nana, back=.TRUE.)
1086 this%ana=pack_distinct_sorted(tmpana, nana)
1087 deallocate(tmpana)
1088 !call sort(this%ana)
1089 
1090 !ntime=count_and_pack_distinct(metaanddatav(:)%metadata%datetime%datetime,this%time, &
1091 ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime), back=.TRUE.)
1092 !this%time=pack_distinct(metaanddatav(:)%metadata%datetime%datetime, ntime, &
1093 ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.)
1094 this%time=pack_distinct_sorted(tmptime, ntime,mask=c_e(tmptime))
1095 deallocate(tmptime)
1096 !call sort(this%time)
1097 
1098 !ntimerange=count_and_pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange,this%timerange, &
1099 ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
1100 !this%timerange=pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, ntimerange, &
1101 ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
1102 this%timerange=pack_distinct_sorted(tmptimerange, ntimerange,mask=c_e(tmptimerange))
1103 deallocate(tmptimerange)
1104 !call sort(this%timerange)
1105 
1106 !nlevel=count_and_pack_distinct(metaanddatav(:)%metadata%level%vol7d_level,this%level, &
1107 ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.)
1108 !this%level=pack_distinct(metaanddatav(:)%metadata%level%vol7d_level, nlevel, &
1109 ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.)
1110 this%level=pack_distinct_sorted(tmplevel, nlevel,mask=c_e(tmplevel))
1111 deallocate(tmplevel)
1112 !call sort(this%level)
1113 
1114 if(ldegnet)then
1115  nnetwork=1
1116  ALLOCATE(this%network(1))
1117  this%network(1)=set_network
1118 else
1119  !nnetwork=count_and_pack_distinct(metaanddatav(:)%metadata%network%vol7d_network,this%network, back=.TRUE.)
1120  !this%network=pack_distinct(metaanddatav(:)%metadata%network%vol7d_network, nnetwork, back=.TRUE.)
1121  this%network=pack_distinct_sorted(tmpnetwork, nnetwork)
1122  deallocate(tmpnetwork)
1123 end if
1124 !call sort(this%network)
1125 
1126  ! var
1127 
1128 ndativarr = 0
1129 ndativari = 0
1130 ndativarb = 0
1131 ndativard = 0
1132 ndativarc = 0
1133 
1134 do i =1 ,size(vars%dcv)
1135  associate(dato => vars%dcv(i)%dat)
1136  select type (dato)
1137  type is (dbadatar)
1138  ndativarr = ndativarr + 1
1139  call init (this%dativar%r(ndativarr), btable=dato%btable)
1140  type is (dbadatai)
1141  ndativari = ndativari + 1
1142  call init (this%dativar%i(ndativari), btable=dato%btable)
1143  type is (dbadatab)
1144  ndativarb = ndativarb + 1
1145  call init (this%dativar%b(ndativarb), btable=dato%btable)
1146  type is (dbadatad)
1147  ndativard = ndativard + 1
1148  call init (this%dativar%d(ndativard), btable=dato%btable)
1149  type is (dbadatac)
1150  ndativarc = ndativarc + 1
1151  call init (this%dativar%c(ndativarc), btable=dato%btable)
1152  end select
1153  end associate
1154 end do
1155 
1156 
1157  !attr
1158 
1159 ndatiattrr = 0
1160 ndatiattri = 0
1161 ndatiattrb = 0
1162 ndatiattrd = 0
1163 ndatiattrc = 0
1164 
1165 do i =1 ,size(starvars%dcv)
1166  associate(dato => starvars%dcv(i)%dat)
1167  select type (dato)
1168  type is (dbadatar)
1169  ndatiattrr = ndatiattrr + 1
1170  call init (this%datiattr%r(ndatiattrr), btable=dato%btable)
1171  type is (dbadatai)
1172  ndatiattri = ndatiattri + 1
1173  call init (this%datiattr%i(ndatiattri), btable=dato%btable)
1174  type is (dbadatab)
1175  ndatiattrb = ndatiattrb + 1
1176  call init (this%datiattr%b(ndatiattrb), btable=dato%btable)
1177  type is (dbadatad)
1178  ndatiattrd = ndatiattrd + 1
1179  call init (this%datiattr%d(ndatiattrd), btable=dato%btable)
1180  type is (dbadatac)
1181  ndatiattrc = ndatiattrc + 1
1182  call init (this%datiattr%c(ndatiattrc), btable=dato%btable)
1183  end select
1184  end associate
1185 end do
1186 
1187 
1188  ! ana var
1189 
1190 nanavarr = 0
1191 nanavari = 0
1192 nanavarb = 0
1193 nanavard = 0
1194 nanavarc = 0
1195 
1196 do i =1 ,size(anavars%dcv)
1197  associate(dato => anavars%dcv(i)%dat)
1198  select type (dato)
1199  type is (dbadatar)
1200  nanavarr = nanavarr + 1
1201  call init (this%anavar%r(nanavarr), btable=dato%btable)
1202  type is (dbadatai)
1203  nanavari = nanavari + 1
1204  call init (this%anavar%i(nanavari), btable=dato%btable)
1205  type is (dbadatab)
1206  nanavarb = nanavarb + 1
1207  call init (this%anavar%b(nanavarb), btable=dato%btable)
1208  type is (dbadatad)
1209  nanavard = nanavard + 1
1210  call init (this%anavar%d(nanavard), btable=dato%btable)
1211  type is (dbadatac)
1212  nanavarc = nanavarc + 1
1213  call init (this%anavar%c(nanavarc), btable=dato%btable)
1214  end select
1215  end associate
1216 end do
1217 
1218 
1219  ! ana attr
1220 
1221 nanaattrr = 0
1222 nanaattri = 0
1223 nanaattrb = 0
1224 nanaattrd = 0
1225 nanaattrc = 0
1226 
1227 do i =1 ,size(anastarvars%dcv)
1228  associate(dato => anastarvars%dcv(i)%dat)
1229  select type (dato)
1230  type is (dbadatar)
1231  nanaattrr = nanaattrr + 1
1232  call init (this%anaattr%r(nanaattrr), btable=dato%btable)
1233  type is (dbadatai)
1234  nanaattri = nanaattri + 1
1235  call init (this%anaattr%i(nanaattri), btable=dato%btable)
1236  type is (dbadatab)
1237  nanaattrb = nanaattrb + 1
1238  call init (this%anaattr%b(nanaattrb), btable=dato%btable)
1239  type is (dbadatad)
1240  nanaattrd = nanaattrd + 1
1241  call init (this%anaattr%d(nanaattrd), btable=dato%btable)
1242  type is (dbadatac)
1243  nanaattrc = nanaattrc + 1
1244  call init (this%anaattr%c(nanaattrc), btable=dato%btable)
1245  end select
1246  end associate
1247 end do
1248 
1249 
1250  ! here we colcolate the link from attributes and vars
1251 do i =1, size(vars%dcv)
1252  associate(dato => vars%dcv(i)%dat)
1253  if ( ndativarattri > 0 ) call init(this%dativarattr%i(i),btable=dato%btable)
1254  if ( ndativarattrr > 0 ) call init(this%dativarattr%r(i),btable=dato%btable)
1255  if ( ndativarattrd > 0 ) call init(this%dativarattr%d(i),btable=dato%btable)
1256  if ( ndativarattrb > 0 ) call init(this%dativarattr%b(i),btable=dato%btable)
1257  if ( ndativarattrc > 0 ) call init(this%dativarattr%c(i),btable=dato%btable)
1258  end associate
1259 end do
1260 
1261 do i =1, size(anavars%dcv)
1262  associate(dato => anavars%dcv(i)%dat)
1263  if ( nanavarattri > 0 ) call init(this%anavarattr%i(i),btable=dato%btable)
1264  if ( nanavarattrr > 0 ) call init(this%anavarattr%r(i),btable=dato%btable)
1265  if ( nanavarattrd > 0 ) call init(this%anavarattr%d(i),btable=dato%btable)
1266  if ( nanavarattrb > 0 ) call init(this%anavarattr%b(i),btable=dato%btable)
1267  if ( nanavarattrc > 0 ) call init(this%anavarattr%c(i),btable=dato%btable)
1268  end associate
1269 end do
1270 
1271  ! set index in dativaratt*
1272 call vol7d_set_attr_ind(this)
1273 
1274 call vol7d_alloc_vol (this)
1275 
1276  ! Ora qui bisogna metterci dentro idati
1277 indana = 0
1278 indtime = 0
1279 indnetwork = 0
1280 indtime = 0
1281 indtimerange = 0
1282 indlevel = 0
1283 do i =1, size(metaanddatav)
1284 
1285  indana = index_sorted(this%ana, metaanddatav(i)%metadata%ana%vol7d_ana)
1286 
1287  if (ldegnet)then
1288  indnetwork=1
1289  else
1290  indnetwork = index_sorted(this%network, metaanddatav(i)%metadata%network%vol7d_network)
1291  endif
1292 
1293  if (c_e(metaanddatav(i)%metadata%datetime%datetime) .and. &
1294  c_e(metaanddatav(i)%metadata%timerange%vol7d_timerange) .and. &
1295  c_e(metaanddatav(i)%metadata%level%vol7d_level) ) then ! dati
1296 
1297  indtime = index_sorted(this%time, metaanddatav(i)%metadata%datetime%datetime)
1298  indtimerange = index_sorted(this%timerange, metaanddatav(i)%metadata%timerange%vol7d_timerange)
1299  indlevel = index_sorted(this%level, metaanddatav(i)%metadata%level%vol7d_level)
1300 
1301  do j=1, size(metaanddatav(i)%dataattrv%dataattr)
1302 
1303  associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat)
1304  select type (dato)
1305  type is (dbadatai)
1306  inddativar = firsttrue(dato%btable == this%dativar%i%btable)
1307  this%voldatii( &
1308  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1309  ) = dato%value
1310 
1311  type is (dbadatar)
1312  inddativar = firsttrue(dato%btable == this%dativar%r%btable)
1313  this%voldatir( &
1314  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1315  ) = dato%value
1316 
1317  type is (dbadatad)
1318  inddativar = firsttrue(dato%btable == this%dativar%d%btable)
1319  this%voldatid( &
1320  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1321  ) = dato%value
1322 
1323  type is (dbadatab)
1324  inddativar = firsttrue(dato%btable == this%dativar%b%btable)
1325  this%voldatib( &
1326  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1327  ) = dato%value
1328 
1329  type is (dbadatac)
1330  inddativar = firsttrue(dato%btable == this%dativar%c%btable)
1331  this%voldatic( &
1332  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1333  ) = dato%value
1334 
1335  end select
1336 
1337 
1338  ! dati attributes
1339  do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
1340  associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
1341  select type (attr)
1342 
1343  type is (dbadatai)
1344  inddativarattr = firsttrue(dato%btable == this%dativarattr%i%btable)
1345  indattrvar = firsttrue(attr%btable == this%datiattr%i%btable)
1346  this%voldatiattri( &
1347  indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1348  ) = attr%value
1349  type is (dbadatar)
1350  inddativarattr = firsttrue(dato%btable == this%dativarattr%r%btable)
1351  indattrvar = firsttrue(attr%btable == this%datiattr%r%btable)
1352  this%voldatiattrr( &
1353  indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1354  ) = attr%value
1355  type is (dbadatad)
1356  inddativarattr = firsttrue(dato%btable == this%dativarattr%d%btable)
1357  indattrvar = firsttrue(attr%btable == this%datiattr%d%btable)
1358  this%voldatiattrd( &
1359  indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1360  ) = attr%value
1361  type is (dbadatab)
1362  inddativarattr = firsttrue(dato%btable == this%dativarattr%b%btable)
1363  indattrvar = firsttrue(attr%btable == this%datiattr%b%btable)
1364  this%voldatiattrb( &
1365  indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1366  ) = attr%value
1367  type is (dbadatac)
1368  inddativarattr = firsttrue(dato%btable == this%dativarattr%c%btable)
1369  indattrvar = firsttrue(attr%btable == this%datiattr%c%btable)
1370  this%voldatiattrc( &
1371  indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1372  ) = attr%value
1373 
1374  end select
1375  end associate
1376  end do
1377  end associate
1378  end do
1379 
1380  else
1381  ! ana
1382  do j=1, size(metaanddatav(i)%dataattrv%dataattr)
1383 
1384  associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat)
1385  select type (dato)
1386  type is (dbadatai)
1387  indanavar = firsttrue(dato%btable == this%anavar%i%btable)
1388  this%volanai( &
1389  indana,indanavar,indnetwork &
1390  ) = dato%value
1391 
1392  type is (dbadatar)
1393  indanavar = firsttrue(dato%btable == this%anavar%r%btable)
1394  this%volanar( &
1395  indana,indanavar,indnetwork &
1396  ) = dato%value
1397 
1398  type is (dbadatad)
1399  indanavar = firsttrue(dato%btable == this%anavar%d%btable)
1400  this%volanad( &
1401  indana,indanavar,indnetwork &
1402  ) = dato%value
1403 
1404  type is (dbadatab)
1405  indanavar = firsttrue(dato%btable == this%anavar%b%btable)
1406  this%volanab( &
1407  indana,indanavar,indnetwork &
1408  ) = dato%value
1409 
1410  type is (dbadatac)
1411  indanavar = firsttrue(dato%btable == this%anavar%c%btable)
1412  this%volanac( &
1413  indana,indanavar,indnetwork &
1414  ) = dato%value
1415 
1416  end select
1417 
1418 
1419  ! ana attributes
1420  do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
1421  associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
1422  select type (attr)
1423 
1424  type is (dbadatai)
1425  indanavarattr = firsttrue(dato%btable == this%anavarattr%i%btable)
1426  indattrvar = firsttrue(attr%btable == this%anaattr%i%btable)
1427  this%volanaattri( &
1428  indana,indanavarattr,indnetwork,indattrvar &
1429  ) = attr%value
1430  type is (dbadatar)
1431  indanavarattr = firsttrue(dato%btable == this%anavarattr%r%btable)
1432  indattrvar = firsttrue(attr%btable == this%anaattr%r%btable)
1433  this%volanaattrr( &
1434  indana,indanavarattr,indnetwork,indattrvar &
1435  ) = attr%value
1436  type is (dbadatad)
1437  indanavarattr = firsttrue(dato%btable == this%anavarattr%d%btable)
1438  indattrvar = firsttrue(attr%btable == this%anaattr%d%btable)
1439  this%volanaattrd( &
1440  indana,indanavarattr,indnetwork,indattrvar &
1441  ) = attr%value
1442  type is (dbadatab)
1443  indanavarattr = firsttrue(dato%btable == this%anavarattr%b%btable)
1444  indattrvar = firsttrue(attr%btable == this%anaattr%b%btable)
1445  this%volanaattrb( &
1446  indana,indanavarattr,indnetwork,indattrvar &
1447  ) = attr%value
1448  type is (dbadatac)
1449  indanavarattr = firsttrue(dato%btable == this%anavarattr%c%btable)
1450  indattrvar = firsttrue(attr%btable == this%anaattr%c%btable)
1451  this%volanaattrc( &
1452  indana,indanavarattr,indnetwork,indattrvar &
1453  ) = attr%value
1454 
1455  end select
1456  end associate
1457  end do
1458  end associate
1459  end do
1460  end if
1461 end do
1462 
1463 contains
1464 
1465 !!$!> /brief Return an dbadcv from a mixlist with dbadata* type
1466 !!$function todcv_dbadat(this)
1467 !!$type(dbadcv) :: todcv_dbadat !< array
1468 !!$type(mixlist) :: this
1469 !!$
1470 !!$integer :: i
1471 !!$
1472 !!$allocate (todcv_dbadat%dcv(this%countelements()))
1473 !!$
1474 !!$call this%rewind()
1475 !!$i=0
1476 !!$do while(this%element())
1477 !!$ i=i+1
1478 !!$
1479 !!$ associate (dato => this%current())
1480 !!$ select type (dato)
1481 !!$ type is (dbadatar)
1482 !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1483 !!$ type is (dbadatai)
1484 !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1485 !!$ type is (dbadatab)
1486 !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1487 !!$ type is (dbadatad)
1488 !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1489 !!$ type is (dbadatac)
1490 !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1491 !!$ end select
1492 !!$ end associate
1493 !!$
1494 !!$ call this%next()
1495 !!$end do
1496 !!$end function todcv_dbadat
1497 
1498 !!$! Definisce le funzioni count_distinct e pack_distinct
1499 !!$#define VOL7D_POLY_TYPE TYPE(dbadata)
1500 !!$#define VOL7D_POLY_TYPES _dbadata
1501 !!$#undef ENABLE_SORT
1502 !!$#include "array_utilities_inc.F90"
1503 !!$#undef VOL7D_POLY_TYPE
1504 !!$#undef VOL7D_POLY_TYPES
1505 
1506 
1507 end subroutine dba2v7d
1508 
1509 
1510 subroutine vol7d_dballe_import_dballevar(this)
1511 
1512 type(vol7d_var),pointer :: this(:)
1513 INTEGER :: i,un,n
1514 
1515 IF (associated(this)) return
1516 IF (allocated(blocal)) then
1517  ALLOCATE(this(size(blocal)))
1518  this=blocal
1519  return
1520 end if
1521 
1522 un = open_dballe_file('dballe.txt', filetype_data)
1523 IF (un < 0) then
1524 
1525  call l4f_log(l4f_error,"error open_dballe_file: dballe.txt")
1526  CALL raise_error("error open_dballe_file: dballe.txt")
1527  return
1528 end if
1529 
1530 n = 0
1531 DO WHILE(.true.)
1532  READ(un,*,end=100)
1533  n = n + 1
1534 ENDDO
1535 100 CONTINUE
1536 
1537 IF (n > 0) THEN
1538  ALLOCATE(this(n))
1539  ALLOCATE(blocal(n))
1540  rewind(un)
1541  readline: do i = 1 ,n
1542  READ(un,'(1x,A6,1x,a65,a24,i4)')blocal(i)%btable,blocal(i)%description,blocal(i)%unit,&
1543  blocal(i)%scalefactor
1544  blocal(i)%btable(:1)="B"
1545  !print*,"B=",blocal(i)%btable
1546  !print*," D=",blocal(i)%description
1547  !PRINT*," U=",blocal(i)%unit
1548  !PRINT*," D=",blocal(i)%scalefactor
1549  ENDDO readline
1550 
1551  CALL l4f_log(l4f_info,'Found '//trim(to_char(i-1))//' variables in dballe master table')
1552 
1553  this=blocal
1554 
1555 ENDIF
1556 CLOSE(un)
1557 
1558 END SUBROUTINE vol7d_dballe_import_dballevar
1559 
1560 
1561 
1564 
1565 subroutine vol7d_dballe_set_var_du(this)
1566 
1567 TYPE(vol7d) :: this
1568 integer :: i,j
1569 type(vol7d_var),pointer :: dballevar(:)
1570 
1571 nullify(dballevar)
1572 call vol7d_dballe_import_dballevar(dballevar)
1573 
1574 #undef VOL7D_POLY_NAME
1575 #define VOL7D_POLY_NAME dativar
1576 
1577 
1578 #undef VOL7D_POLY_TYPES_V
1579 #define VOL7D_POLY_TYPES_V r
1580 #include "vol7d_dballe_class_var_du.F90"
1581 #undef VOL7D_POLY_TYPES_V
1582 #define VOL7D_POLY_TYPES_V i
1583 #include "vol7d_dballe_class_var_du.F90"
1584 #undef VOL7D_POLY_TYPES_V
1585 #define VOL7D_POLY_TYPES_V b
1586 #include "vol7d_dballe_class_var_du.F90"
1587 #undef VOL7D_POLY_TYPES_V
1588 #define VOL7D_POLY_TYPES_V d
1589 #include "vol7d_dballe_class_var_du.F90"
1590 #undef VOL7D_POLY_TYPES_V
1591 #define VOL7D_POLY_TYPES_V c
1592 #include "vol7d_dballe_class_var_du.F90"
1593 #undef VOL7D_POLY_TYPES_V
1594 
1595 #undef VOL7D_POLY_NAME
1596 #define VOL7D_POLY_NAME anavar
1597 
1598 
1599 #undef VOL7D_POLY_TYPES_V
1600 #define VOL7D_POLY_TYPES_V r
1601 #include "vol7d_dballe_class_var_du.F90"
1602 #undef VOL7D_POLY_TYPES_V
1603 #define VOL7D_POLY_TYPES_V i
1604 #include "vol7d_dballe_class_var_du.F90"
1605 #undef VOL7D_POLY_TYPES_V
1606 #define VOL7D_POLY_TYPES_V b
1607 #include "vol7d_dballe_class_var_du.F90"
1608 #undef VOL7D_POLY_TYPES_V
1609 #define VOL7D_POLY_TYPES_V d
1610 #include "vol7d_dballe_class_var_du.F90"
1611 #undef VOL7D_POLY_TYPES_V
1612 #define VOL7D_POLY_TYPES_V c
1613 #include "vol7d_dballe_class_var_du.F90"
1614 #undef VOL7D_POLY_TYPES_V
1615 
1616 
1617 #undef VOL7D_POLY_NAME
1618 #define VOL7D_POLY_NAME datiattr
1619 
1620 
1621 #undef VOL7D_POLY_TYPES_V
1622 #define VOL7D_POLY_TYPES_V r
1623 #include "vol7d_dballe_class_var_du.F90"
1624 #undef VOL7D_POLY_TYPES_V
1625 #define VOL7D_POLY_TYPES_V i
1626 #include "vol7d_dballe_class_var_du.F90"
1627 #undef VOL7D_POLY_TYPES_V
1628 #define VOL7D_POLY_TYPES_V b
1629 #include "vol7d_dballe_class_var_du.F90"
1630 #undef VOL7D_POLY_TYPES_V
1631 #define VOL7D_POLY_TYPES_V d
1632 #include "vol7d_dballe_class_var_du.F90"
1633 #undef VOL7D_POLY_TYPES_V
1634 #define VOL7D_POLY_TYPES_V c
1635 #include "vol7d_dballe_class_var_du.F90"
1636 #undef VOL7D_POLY_TYPES_V
1637 
1638 
1639 #undef VOL7D_POLY_NAME
1640 #define VOL7D_POLY_NAME anaattr
1641 
1642 
1643 #undef VOL7D_POLY_TYPES_V
1644 #define VOL7D_POLY_TYPES_V r
1645 #include "vol7d_dballe_class_var_du.F90"
1646 #undef VOL7D_POLY_TYPES_V
1647 #define VOL7D_POLY_TYPES_V i
1648 #include "vol7d_dballe_class_var_du.F90"
1649 #undef VOL7D_POLY_TYPES_V
1650 #define VOL7D_POLY_TYPES_V b
1651 #include "vol7d_dballe_class_var_du.F90"
1652 #undef VOL7D_POLY_TYPES_V
1653 #define VOL7D_POLY_TYPES_V d
1654 #include "vol7d_dballe_class_var_du.F90"
1655 #undef VOL7D_POLY_TYPES_V
1656 #define VOL7D_POLY_TYPES_V c
1657 #include "vol7d_dballe_class_var_du.F90"
1658 #undef VOL7D_POLY_TYPES_V
1659 
1660 
1661 deallocate(dballevar)
1662 
1663 return
1664 
1665 end subroutine vol7d_dballe_set_var_du
1666 
1667 
1668 
1669 FUNCTION get_dballe_filepath(filename, filetype) RESULT(path)
1670 CHARACTER(len=*), INTENT(in) :: filename
1671 INTEGER, INTENT(in) :: filetype
1672 
1673 INTEGER :: j
1674 CHARACTER(len=512) :: path
1675 LOGICAL :: exist
1676 
1677 IF (dballe_name == ' ') THEN
1678  CALL getarg(0, dballe_name)
1679  ! dballe_name_env
1680 ENDIF
1681 
1682 IF (filetype < 1 .OR. filetype > nftype) THEN
1683  path = ""
Index method with sorted array.
Restituiscono il valore dell&#39;oggetto in forma di stringa stampabile.
Costruttori per le classi datetime e timedelta.

Generated with Doxygen.