lxsd / fvn

Download as
Browse Code ยป

Commit c64a05f8a6b6da9ac2fb4f115f7ea401387f12c3

Authored by wdaniau
1 parent 2b83390c62
Exists in master and in 3 other branches geevx, geevx_2020, multi

Sparse Determinant : use of mantisse + exponent 

git-svn-id: https://lxsd.femto-st.fr/svn/fvn@65 b657c933-2333-4658-acf2-d3c7c2708721

Showing 5 changed files with 28 additions and 43 deletions Side-by-side Diff

fvn_sparse/fvn_sparse.f90
Diff comments   View file @ c64a05f
... ... @@ -41,7 +41,7 @@
41 41 complex(kind=dp_kind),dimension(n),intent(in) :: B
42 42 complex(kind=dp_kind),dimension(n),intent(out) :: x
43 43 integer(kind=dp_kind), intent(out) :: status
44   -complex(kind=dp_kind), optional, intent(out) :: det
  44 +real(kind=dp_kind), dimension(3), optional, intent(out) :: det
45 45  
46 46 integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj
47 47 real(kind=dp_kind),dimension(:),allocatable :: Tx,Tz
... ... @@ -52,7 +52,6 @@
52 52 real(kind=dp_kind),dimension(90) :: info
53 53 real(kind=dp_kind),dimension(20) :: control
54 54 integer(kind=dp_kind) :: sys
55   -real(kind=dp_kind) :: Mx,Mz,Ex
56 55  
57 56  
58 57 status=0
... ... @@ -99,8 +98,7 @@
99 98  
100 99 ! if parameter det is present, the determinant of the matrix is calculated
101 100 if (present(det) ) then
102   - call umfpack_zl_get_determinant(Mx,Mz,Ex,numeric,info,status)
103   - det=cmplx(Mx,Mz,kind=dp_kind)*10**Ex
  101 + call umfpack_zl_get_determinant(det(1),det(2),det(3),numeric,info,status)
104 102 ! info(1) should be zero
105 103 if (info(1) /= 0) then
106 104 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
... ... @@ -148,7 +146,7 @@
148 146 complex(kind=dp_kind),dimension(n),intent(in) :: B
149 147 complex(kind=dp_kind),dimension(n),intent(out) :: x
150 148 integer(kind=sp_kind), intent(out) :: status
151   -complex(kind=dp_kind), optional, intent(out) :: det
  149 +real(kind=dp_kind), dimension(3), optional, intent(out) :: det
152 150  
153 151 integer(kind=sp_kind),dimension(:),allocatable :: wTi,wTj
154 152 real(kind=dp_kind),dimension(:),allocatable :: Tx,Tz
... ... @@ -163,7 +161,6 @@
163 161 real(kind=dp_kind),dimension(90) :: info
164 162 real(kind=dp_kind),dimension(20) :: control
165 163 integer(kind=sp_kind) :: sys
166   -real(kind=dp_kind) :: Mx,Mz,Ex
167 164  
168 165 status=0
169 166 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
... ... @@ -208,8 +205,7 @@
208 205  
209 206 ! if parameter det is present, the determinant of the matrix is calculated
210 207 if (present(det) ) then
211   - call umfpack_zi_get_determinant(Mx,Mz,Ex,numeric,info,status)
212   - det=cmplx(Mx,Mz,kind=dp_kind)*10**Ex
  208 + call umfpack_zi_get_determinant(det(1),det(2),det(3),numeric,info,status)
213 209 ! info(1) should be zero
214 210 if (info(1) /= 0) then
215 211 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
... ... @@ -258,7 +254,7 @@
258 254 real(kind=dp_kind),dimension(n),intent(in) :: B
259 255 real(kind=dp_kind),dimension(n),intent(out) :: x
260 256 integer(kind=dp_kind), intent(out) :: status
261   -real(kind=dp_kind), optional, intent(out) :: det
  257 +real(kind=dp_kind), dimension(2), optional, intent(out) :: det
262 258  
263 259 integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj
264 260 real(kind=dp_kind),dimension(:),allocatable :: A
... ... @@ -268,7 +264,6 @@
268 264 real(kind=dp_kind),dimension(90) :: info
269 265 real(kind=dp_kind),dimension(20) :: control
270 266 integer(kind=dp_kind) :: sys
271   -real(kind=dp_kind) :: Mx,Ex
272 267  
273 268 status=0
274 269 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
... ... @@ -309,8 +304,7 @@
309 304  
310 305 ! if parameter det is present, the determinant of the matrix is calculated
311 306 if (present(det) ) then
312   - call umfpack_dl_get_determinant(Mx,Ex,numeric,info,status)
313   - det=Mx*10**Ex
  307 + call umfpack_dl_get_determinant(det(1),det(2),numeric,info,status)
314 308 ! info(1) should be zero
315 309 if (info(1) /= 0) then
316 310 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
... ... @@ -350,7 +344,7 @@
350 344 real(kind=dp_kind),dimension(n),intent(in) :: B
351 345 real(kind=dp_kind),dimension(n),intent(out) :: x
352 346 integer(kind=sp_kind), intent(out) :: status
353   -real(kind=dp_kind), optional, intent(out) :: det
  347 +real(kind=dp_kind), dimension(2), optional, intent(out) :: det
354 348  
355 349 integer(kind=sp_kind),dimension(:),allocatable :: wTi,wTj
356 350 real(kind=dp_kind),dimension(:),allocatable :: A
... ... @@ -363,7 +357,6 @@
363 357 real(kind=dp_kind),dimension(90) :: info
364 358 real(kind=dp_kind),dimension(20) :: control
365 359 integer(kind=sp_kind) :: sys
366   -real(kind=dp_kind) :: Mx,Ex
367 360  
368 361 status=0
369 362 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
... ... @@ -404,8 +397,7 @@
404 397  
405 398 ! if parameter det is present, the determinant of the matrix is calculated
406 399 if (present(det) ) then
407   - call umfpack_di_get_determinant(Mx,Ex,numeric,info,status)
408   - det=Mx*10**Ex
  400 + call umfpack_di_get_determinant(det(1),det(2),numeric,info,status)
409 401 ! info(1) should be zero
410 402 if (info(1) /= 0) then
411 403 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
... ... @@ -441,7 +433,7 @@
441 433 integer(kind=dp_kind), intent(in) :: n,nz
442 434 complex(kind=dp_kind),dimension(nz),intent(in) :: T
443 435 integer(kind=dp_kind),dimension(nz),intent(in) :: Ti,Tj
444   -complex(kind=dp_kind),intent(out) :: det
  436 +real(kind=dp_kind), dimension(3), intent(out) :: det
445 437 integer(kind=dp_kind), intent(out) :: status
446 438  
447 439 integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj
448 440  
... ... @@ -496,13 +488,12 @@
496 488 ! free the C symbolic pointer
497 489 call umfpack_zl_free_symbolic (symbolic)
498 490  
499   -call umfpack_zl_get_determinant(Mx,Mz,Ex,numeric,info,status)
  491 +call umfpack_zl_get_determinant(det(1),det(2),det(3),numeric,info,status)
500 492 ! info(1) should be zero
501 493 if (info(1) /= 0) then
502 494 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
503 495 status=info(1)
504 496 endif
505   -det=cmplx(Mx,Mz,kind=dp_kind)*10**Ex
506 497  
507 498 ! free the C numeric pointer
508 499 call umfpack_zl_free_numeric (numeric)
... ... @@ -519,7 +510,7 @@
519 510 complex(kind=dp_kind),dimension(nz),intent(in) :: T
520 511 integer(kind=sp_kind),dimension(nz),intent(in) :: Ti,Tj
521 512 integer(kind=sp_kind), intent(out) :: status
522   -complex(kind=dp_kind), intent(out) :: det
  513 +real(kind=dp_kind), dimension(3), intent(out) :: det
523 514  
524 515 integer(kind=sp_kind),dimension(:),allocatable :: wTi,wTj
525 516 real(kind=dp_kind),dimension(:),allocatable :: Tx,Tz
... ... @@ -532,7 +523,6 @@
532 523 ! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric
533 524 real(kind=dp_kind),dimension(90) :: info
534 525 real(kind=dp_kind),dimension(20) :: control
535   -real(kind=dp_kind) :: Mx,Mz,Ex
536 526  
537 527 status=0
538 528 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
539 529  
... ... @@ -575,13 +565,12 @@
575 565 ! free the C symbolic pointer
576 566 call umfpack_zi_free_symbolic (symbolic)
577 567  
578   -call umfpack_zi_get_determinant(Mx,Mz,Ex,numeric,info,status)
  568 +call umfpack_zi_get_determinant(det(1),det(2),det(3),numeric,info,status)
579 569 ! info(1) should be zero
580 570 if (info(1) /= 0) then
581 571 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
582 572 status=info(1)
583 573 endif
584   -det=cmplx(Mx,Mz,kind=dp_kind)*10**Ex
585 574  
586 575 ! free the C numeric pointer
587 576 call umfpack_zi_free_numeric (numeric)
... ... @@ -597,7 +586,7 @@
597 586 real(kind=dp_kind),dimension(nz),intent(in) :: T
598 587 integer(kind=dp_kind),dimension(nz),intent(in) :: Ti,Tj
599 588 integer(kind=dp_kind), intent(out) :: status
600   -real(kind=dp_kind), intent(out) :: det
  589 +real(kind=dp_kind), dimension(2), intent(out) :: det
601 590  
602 591 integer(kind=dp_kind),dimension(:),allocatable :: wTi,wTj
603 592 real(kind=dp_kind),dimension(:),allocatable :: A
... ... @@ -606,7 +595,6 @@
606 595 integer(kind=dp_kind) :: symbolic,numeric
607 596 real(kind=dp_kind),dimension(90) :: info
608 597 real(kind=dp_kind),dimension(20) :: control
609   -real(kind=dp_kind) :: Mx,Ex
610 598  
611 599 status=0
612 600 ! we use a working copy of Ti and Tj to perform 1-based to 0-based translation
613 601  
... ... @@ -645,13 +633,12 @@
645 633 ! free the C symbolic pointer
646 634 call umfpack_dl_free_symbolic (symbolic)
647 635  
648   -call umfpack_dl_get_determinant(Mx,Ex,numeric,info,status)
  636 +call umfpack_dl_get_determinant(det(1),det(2),numeric,info,status)
649 637 ! info(1) should be zero
650 638 if (info(1) /= 0) then
651 639 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
652 640 status=info(1)
653 641 endif
654   -det=Mx*10**Ex
655 642  
656 643 ! free the C numeric pointer
657 644 call umfpack_dl_free_numeric (numeric)
... ... @@ -667,7 +654,7 @@
667 654 real(kind=dp_kind),dimension(nz),intent(in) :: T
668 655 integer(kind=sp_kind),dimension(nz),intent(in) :: Ti,Tj
669 656 integer(kind=sp_kind), intent(out) :: status
670   -real(kind=dp_kind), intent(out) :: det
  657 +real(kind=dp_kind), dimension(2), intent(out) :: det
671 658  
672 659 integer(kind=sp_kind),dimension(:),allocatable :: wTi,wTj
673 660 real(kind=dp_kind),dimension(:),allocatable :: A
... ... @@ -680,7 +667,6 @@
680 667 real(kind=dp_kind),dimension(90) :: info
681 668 real(kind=dp_kind),dimension(20) :: control
682 669 integer(kind=sp_kind) :: sys
683   -real(kind=dp_kind) :: Mx,Ex
684 670  
685 671  
686 672 status=0
... ... @@ -721,8 +707,7 @@
721 707 ! free the C symbolic pointer
722 708 call umfpack_di_free_symbolic (symbolic)
723 709  
724   -call umfpack_di_get_determinant(Mx,Ex,numeric,info,status)
725   -det=Mx*10**Ex
  710 +call umfpack_di_get_determinant(det(1),det(2),numeric,info,status)
726 711 ! info(1) should be zero
727 712 if (info(1) /= 0) then
728 713 write(*,*) "Problem during sparse determinant, returned code : ",info(1)
fvn_test/test_sparse_di.f90
Diff comments   View file @ c64a05f
... ... @@ -9,7 +9,7 @@
9 9 integer(kind=sp_kind),dimension(nz) :: Ti,Tj
10 10 real(kind=dp_kind),dimension(n) :: B,x
11 11 integer(kind=sp_kind) :: status,i
12   -real(kind=dp_kind) :: det
  12 +real(kind=dp_kind),dimension(2) :: det
13 13 ! Description of the matrix in triplet form
14 14 A = (/ 2.,3.,3.,-1.,4.,4.,-3.,1.,2.,2.,6.,1. /)
15 15 B = (/ 8., 45., -3., 3., 19./)
16 16  
... ... @@ -35,13 +35,13 @@
35 35 ! either generic one fvn_sparse_det
36 36 call fvn_di_sparse_det(n,nz,A,Ti,Tj,det,status)
37 37 write(*,*)
38   -write(*,*) "Sparse Det = ",det
  38 +write(*,*) "Sparse Det = ",det(1)*10**det(2)
39 39 ! can use either specific interface fvn_di_sparse_solve
40 40 ! either generic one fvn_sparse_solve
41 41 ! parameter det is optional
42 42 call fvn_di_sparse_solve(n,nz,A,Ti,Tj,B,x,status,det)
43 43 write(*,*)
44   -write(*,*) "Sparse Det as solve option = ",det
  44 +write(*,*) "Sparse Det as solve option = ",det(1)*10**det(2)
45 45 write(*,*)
46 46 write(*,'("Solution :",5f8.4)') x
47 47 write(*,*)
fvn_test/test_sparse_dl.f90
Diff comments   View file @ c64a05f
... ... @@ -9,7 +9,7 @@
9 9 integer(kind=dp_kind),dimension(nz) :: Ti,Tj
10 10 real(kind=dp_kind),dimension(n) :: B,x
11 11 integer(kind=dp_kind) :: status,i
12   -real(kind=dp_kind) :: det
  12 +real(kind=dp_kind),dimension(2) :: det
13 13 ! Description of the matrix in triplet form
14 14 A = (/ 2.,3.,3.,-1.,4.,4.,-3.,1.,2.,2.,6.,1. /)
15 15 B = (/ 8., 45., -3., 3., 19./)
16 16  
... ... @@ -35,13 +35,13 @@
35 35 ! either generic one fvn_sparse_det
36 36 call fvn_dl_sparse_det(n,nz,A,Ti,Tj,det,status)
37 37 write(*,*)
38   -write(*,*) "Sparse Det = ",det
  38 +write(*,*) "Sparse Det = ",det(1)*10**det(2)
39 39 ! can use either specific interface fvn_dl_sparse_solve
40 40 ! either generic one fvn_sparse_solve
41 41 ! parameter det is optional
42 42 call fvn_dl_sparse_solve(n,nz,A,Ti,Tj,B,x,status,det)
43 43 write(*,*)
44   -write(*,*) "Sparse Det as solve option = ",det
  44 +write(*,*) "Sparse Det as solve option = ",det(1)*10**det(2)
45 45 write(*,*)
46 46 write(*,'("Solution :",5f8.4)') x
47 47 write(*,*)
fvn_test/test_sparse_zi.f90
Diff comments   View file @ c64a05f
... ... @@ -8,7 +8,7 @@
8 8 integer(kind=sp_kind),dimension(nz) :: Ti,Tj
9 9 complex(kind=dp_kind),dimension(n) :: B,x
10 10 integer(kind=sp_kind) :: status,i
11   -complex(kind=dp_kind) :: det
  11 +real(kind=dp_kind),dimension(3) :: det
12 12 character(len=80) :: fmcmplx
13 13  
14 14 fmcmplx='(5("(",f8.5,",",f8.5,") "))'
15 15  
... ... @@ -39,13 +39,13 @@
39 39 ! either generic one fvn_sparse_det
40 40 call fvn_zi_sparse_det(n,nz,A,Ti,Tj,det,status)
41 41 write(*,*)
42   -write(*,*) "Sparse Det = ",det
  42 +write(*,*) "Sparse Det = ",cmplx(det(1),det(2),kind=dp_kind)*10**det(3)
43 43 ! can use either specific interface fvn_zi_sparse_solve
44 44 ! either generic one fvn_sparse_solve
45 45 ! parameter det is optional
46 46 call fvn_zi_sparse_solve(n,nz,A,Ti,Tj,B,x,status,det)
47 47 write(*,*)
48   -write(*,*) "Sparse Det as solve option= ",det
  48 +write(*,*) "Sparse Det as solve option= ",cmplx(det(1),det(2),kind=dp_kind)*10**det(3)
49 49 write(*,*)
50 50 write(*,*) "Solution :"
51 51 write(*,fmcmplx) x
fvn_test/test_sparse_zl.f90
Diff comments   View file @ c64a05f
... ... @@ -9,7 +9,7 @@
9 9 integer(kind=dp_kind),dimension(nz) :: Ti,Tj
10 10 complex(kind=dp_kind),dimension(n) :: B,x
11 11 integer(kind=dp_kind) :: status,i
12   -complex(kind=dp_kind) :: det
  12 +real(kind=dp_kind),dimension(3) :: det
13 13 character(len=80) :: fmcmplx
14 14  
15 15 fmcmplx='(5("(",f8.5,",",f8.5,") "))'
16 16  
... ... @@ -39,13 +39,13 @@
39 39 ! either generic one fvn_sparse_det
40 40 call fvn_zl_sparse_det(n,nz,A,Ti,Tj,det,status)
41 41 write(*,*)
42   -write(*,*) "Sparse Det = ",det
  42 +write(*,*) "Sparse Det = ",cmplx(det(1),det(2),kind=dp_kind)*10**det(3)
43 43 ! can use either specific interface fvn_zl_sparse_solve
44 44 ! either generic one fvn_sparse_solve
45 45 ! parameter det is optional
46 46 call fvn_zl_sparse_solve(n,nz,A,Ti,Tj,B,x,status,det)
47 47 write(*,*)
48   -write(*,*) "Sparse Det as solve option= ",det
  48 +write(*,*) "Sparse Det as solve option= ",cmplx(det(1),det(2),kind=dp_kind)*10**det(3)
49 49 write(*,*)
50 50 write(*,*) "Solution :"
51 51 write(*,fmcmplx) x