lxsd / fvn

Download as
Browse Code ยป

Commit 68642e5d21b0cb88b82aa6c7a681e3b448197363

Authored by William Daniau
1 parent 204ded3d3d
Exists in geevx_2020

Using [SDCZ]GEEVX instead of [SDCZ]GEEV to avoid use of 

[SDCZ]GEBAL which cause NaN in some circumstances

Showing 1 changed file with 49 additions and 9 deletions Side-by-side Diff

fvn_linear/fvn_linear.f90
Diff comments   View file @ 68642e5
... ... @@ -1095,6 +1095,7 @@
1095 1095 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
1096 1096 !
1097 1097 ! interfacing Lapack routine SGEEV
  1098 + ! 2020 11 03 : SGEEVX with BALANC='N'
1098 1099 implicit none
1099 1100 integer(kind=ip_kind), intent(in) :: d
1100 1101 real(kind=sp_kind), intent(in) :: a(d,d)
... ... @@ -1114,6 +1115,10 @@
1114 1115 integer(kind=ip_kind) i
1115 1116 integer(kind=ip_kind) j
1116 1117  
  1118 + integer(kind=ip_kind) :: ilo,ihi, iwork
  1119 + real(kind=sp_kind), allocatable, dimension(:) :: scal, rconde, rcondv
  1120 + real(kind=sp_kind) :: abnrm
  1121 +
1117 1122 if (present(status)) status=1
1118 1123  
1119 1124 ! making a working copy of a
1120 1125  
1121 1126  
1122 1127  
... ... @@ -1124,12 +1129,16 @@
1124 1129 allocate(wr(d))
1125 1130 allocate(wi(d))
1126 1131 allocate(vr(d,d))
  1132 + allocate(scal(d),rconde(d),rcondv(d))
1127 1133 ! query optimal work size
1128   - call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
  1134 + ! call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
  1135 + call sgeevx('N','N','V','N',d,wc_a,d,wr,wi,vl,1,vr,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,twork,-1,IWORK,info)
1129 1136 lwork=int(twork(1))
1130 1137 allocate(work(lwork))
1131   - call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
  1138 + ! call sgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
  1139 + call sgeevx('N','N','V','N',d,wc_a,d,wr,wi,vl,1,vr,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,work,lwork,IWORK,info)
1132 1140  
  1141 +
1133 1142 if (info /= 0) then
1134 1143 if (present(status)) status=0
1135 1144 deallocate(work)
... ... @@ -1137,6 +1146,7 @@
1137 1146 deallocate(wi)
1138 1147 deallocate(wr)
1139 1148 deallocate(wc_a)
  1149 + deallocate(scal,rconde,rcondv)
1140 1150 return
1141 1151 end if
1142 1152  
... ... @@ -1159,6 +1169,7 @@
1159 1169 deallocate(wi)
1160 1170 deallocate(wr)
1161 1171 deallocate(wc_a)
  1172 + deallocate(scal,rconde,rcondv)
1162 1173  
1163 1174 ! sorting
1164 1175 if (present(sortval) .and. sortval) then
... ... @@ -1176,6 +1187,7 @@
1176 1187 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
1177 1188 !
1178 1189 ! interfacing Lapack routine DGEEV
  1190 + ! 2020 11 03 : DGEEVX with BALANC='N'
1179 1191 implicit none
1180 1192 integer(kind=ip_kind), intent(in) :: d
1181 1193 real(kind=dp_kind), intent(in) :: a(d,d)
... ... @@ -1195,6 +1207,10 @@
1195 1207 integer(kind=ip_kind) i
1196 1208 integer(kind=ip_kind) j
1197 1209  
  1210 + integer(kind=ip_kind) :: ilo,ihi, iwork
  1211 + real(kind=dp_kind), allocatable, dimension(:) :: scal, rconde, rcondv
  1212 + real(kind=dp_kind) :: abnrm
  1213 +
1198 1214 if (present(status)) status=1
1199 1215  
1200 1216 ! making a working copy of a
1201 1217  
1202 1218  
... ... @@ -1205,11 +1221,14 @@
1205 1221 allocate(wr(d))
1206 1222 allocate(wi(d))
1207 1223 allocate(vr(d,d))
  1224 + allocate(scal(d),rconde(d),rcondv(d))
1208 1225 ! query optimal work size
1209   - call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
  1226 + ! call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,twork,-1,info)
  1227 + call dgeevx('N','N','V','N',d,wc_a,d,wr,wi,vl,1,vr,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,twork,-1,IWORK,info)
1210 1228 lwork=int(twork(1))
1211 1229 allocate(work(lwork))
1212   - call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
  1230 + ! call dgeev('N','V',d,wc_a,d,wr,wi,vl,1,vr,d,work,lwork,info)
  1231 + call dgeevx('N','N','V','N',d,wc_a,d,wr,wi,vl,1,vr,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,work,lwork,IWORK,info)
1213 1232  
1214 1233 if (info /= 0) then
1215 1234 if (present(status)) status=0
... ... @@ -1218,6 +1237,7 @@
1218 1237 deallocate(wi)
1219 1238 deallocate(wr)
1220 1239 deallocate(wc_a)
  1240 + deallocate(scal,rconde,rcondv)
1221 1241 return
1222 1242 end if
1223 1243  
... ... @@ -1241,6 +1261,7 @@
1241 1261 deallocate(wi)
1242 1262 deallocate(wr)
1243 1263 deallocate(wc_a)
  1264 + deallocate(scal,rconde,rcondv)
1244 1265  
1245 1266 ! sorting
1246 1267 if (present(sortval) .and. sortval) then
... ... @@ -1258,6 +1279,7 @@
1258 1279 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
1259 1280 !
1260 1281 ! interfacing Lapack routine CGEEV
  1282 + ! 2020 11 03 : CGEEVX with BALANC='N'
1261 1283 implicit none
1262 1284 integer(kind=ip_kind), intent(in) :: d
1263 1285 complex(kind=sp_kind), intent(in) :: a(d,d)
... ... @@ -1274,6 +1296,10 @@
1274 1296 real(kind=sp_kind), allocatable :: rwork(:)
1275 1297 complex(kind=sp_kind) :: vl ! unused but necessary for the call
1276 1298  
  1299 + integer(kind=ip_kind) :: ilo,ihi
  1300 + real(kind=sp_kind), allocatable, dimension(:) :: scal, rconde, rcondv
  1301 + real(kind=sp_kind) :: abnrm
  1302 +
1277 1303 if (present(status)) status=1
1278 1304  
1279 1305 ! making a working copy of a
1280 1306  
1281 1307  
... ... @@ -1283,11 +1309,14 @@
1283 1309  
1284 1310 ! rwork must be allocated before query
1285 1311 allocate(rwork(2*d))
  1312 + allocate(scal(d),rconde(d),rcondv(d))
1286 1313 ! query optimal work size
1287   - call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
  1314 + ! call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
  1315 + call cgeevx('N','N','V','N',d,wc_a,d,evala,vl,1,eveca,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,twork,-1,rwork,info)
1288 1316 lwork=int(twork(1))
1289 1317 allocate(work(lwork))
1290   - call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
  1318 + ! call cgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
  1319 + call cgeevx('N','N','V','N',d,wc_a,d,evala,vl,1,eveca,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,work,lwork,rwork,info)
1291 1320  
1292 1321 if (info /= 0) then
1293 1322 if (present(status)) status=0
... ... @@ -1295,6 +1324,7 @@
1295 1324 deallocate(rwork)
1296 1325 deallocate(work)
1297 1326 deallocate(wc_a)
  1327 + deallocate(scal,rconde,rcondv)
1298 1328  
1299 1329 ! sorting
1300 1330 if (present(sortval) .and. sortval) then
... ... @@ -1312,6 +1342,7 @@
1312 1342 ! integer(kind=ip_kind) (out) : status =0 if something went wrong
1313 1343 !
1314 1344 ! interfacing Lapack routine ZGEEV
  1345 + ! 2020 11 03 : ZGEEVX with BALANC='N'
1315 1346 implicit none
1316 1347 integer(kind=ip_kind), intent(in) :: d
1317 1348 complex(kind=dp_kind), intent(in) :: a(d,d)
... ... @@ -1328,6 +1359,11 @@
1328 1359 real(kind=dp_kind), allocatable :: rwork(:)
1329 1360 complex(kind=dp_kind) :: vl ! unused but necessary for the call
1330 1361  
  1362 + integer(kind=ip_kind) :: ilo,ihi
  1363 + real(kind=dp_kind), allocatable, dimension(:) :: scal, rconde, rcondv
  1364 + real(kind=dp_kind) :: abnrm
  1365 +
  1366 +
1331 1367 if (present(status)) status=1
1332 1368  
1333 1369 ! making a working copy of a
1334 1370  
1335 1371  
... ... @@ -1337,11 +1373,14 @@
1337 1373  
1338 1374 ! rwork must be allocated before query
1339 1375 allocate(rwork(2*d))
  1376 + allocate(scal(d),rconde(d),rcondv(d))
1340 1377 ! query optimal work size
1341   - call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
  1378 + ! call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,twork,-1,rwork,info)
  1379 + call zgeevx('N','N','V','N',d,wc_a,d,evala,vl,1,eveca,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,twork,-1,rwork,info)
1342 1380 lwork=int(twork(1))
1343 1381 allocate(work(lwork))
1344   - call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
  1382 + ! call zgeev('N','V',d,wc_a,d,evala,vl,1,eveca,d,work,lwork,rwork,info)
  1383 + call zgeevx('N','N','V','N',d,wc_a,d,evala,vl,1,eveca,d,ILO,IHI,SCAL,ABNRM,RCONDE,RCONDV,work,lwork,rwork,info)
1345 1384  
1346 1385 if (info /= 0) then
1347 1386 if (present(status)) status=0
... ... @@ -1349,6 +1388,7 @@
1349 1388 deallocate(rwork)
1350 1389 deallocate(work)
1351 1390 deallocate(wc_a)
  1391 + deallocate(scal,rconde,rcondv)
1352 1392  
1353 1393 ! sorting
1354 1394 if (present(sortval) .and. sortval) then