Commit db6500dcfb6c82b1630b7a6d35067cd1ee90cf78
1 parent
b5f099f3cf
Exists in
multi
First draft for a multi resolution
Showing 1 changed file with 83 additions and 0 deletions Side-by-side Diff
fvn_sparse/fvn_sparse.f90
| ... | ... | @@ -345,6 +345,89 @@ |
| 345 | 345 | end subroutine |
| 346 | 346 | |
| 347 | 347 | |
| 348 | +subroutine fvn_di_sparse_solve_multi(n,nz,T,Ti,Tj,m,B,x,status,det) | |
| 349 | +implicit none | |
| 350 | +integer(kind=sp_kind), intent(in) :: n,nz,m | |
| 351 | +real(kind=dp_kind),dimension(nz),intent(in) :: T | |
| 352 | +integer(kind=sp_kind),dimension(nz),intent(in) :: Ti,Tj | |
| 353 | +real(kind=dp_kind),dimension(n,m),intent(in) :: B | |
| 354 | +real(kind=dp_kind),dimension(n,m),intent(out) :: x | |
| 355 | +integer(kind=sp_kind), intent(out) :: status | |
| 356 | +real(kind=dp_kind), dimension(2), optional, intent(out) :: det | |
| 357 | + | |
| 358 | +real(kind=dp_kind),dimension(:),allocatable :: A | |
| 359 | +integer(kind=sp_kind),dimension(:),allocatable :: Ap,Ai | |
| 360 | +!integer(kind=dp_kind) :: symbolic,numeric | |
| 361 | +integer(kind=sp_kind),dimension(2) :: symbolic,numeric | |
| 362 | +! As symbolic and numeric are used to store a C pointer, it is necessary to | |
| 363 | +! still use an integer(kind=dp_kind) for 64bits machines | |
| 364 | +! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric | |
| 365 | +real(kind=dp_kind),dimension(90) :: info | |
| 366 | +real(kind=dp_kind),dimension(20) :: control | |
| 367 | +integer(kind=sp_kind) :: sys | |
| 368 | +integer(kind=sp_kind) :: i | |
| 369 | + | |
| 370 | +status=0 | |
| 371 | +allocate(A(nz)) | |
| 372 | +allocate(Ap(n+1),Ai(nz)) | |
| 373 | + | |
| 374 | +! perform the triplet to compressed column form -> Ap,Ai,Ax,Az | |
| 375 | +call umfpack_di_triplet_to_col(n,n,nz,Ti,Tj,T,Ap,Ai,A,status) | |
| 376 | +! if status is not zero a problem has occured | |
| 377 | +if (status /= 0) then | |
| 378 | + write(*,*) "Problem during umfpack_di_triplet_to_col : ",trim(umfpack_return_code(status)) | |
| 379 | +endif | |
| 380 | + | |
| 381 | +! Define defaults control values | |
| 382 | +call umfpack_di_defaults(control) | |
| 383 | + | |
| 384 | +! Symbolic analysis | |
| 385 | +call umfpack_di_symbolic(n,n,Ap,Ai,A,symbolic, control, info) | |
| 386 | +! info(1) should be zero | |
| 387 | +if (info(1) /= 0) then | |
| 388 | + write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind))) | |
| 389 | + status=info(1) | |
| 390 | +endif | |
| 391 | + | |
| 392 | +! Numerical factorization | |
| 393 | +call umfpack_di_numeric (Ap, Ai, A, symbolic, numeric, control, info) | |
| 394 | +! info(1) should be zero | |
| 395 | +if (info(1) /= 0) then | |
| 396 | + write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind))) | |
| 397 | + status=info(1) | |
| 398 | +endif | |
| 399 | + | |
| 400 | +! free the C symbolic pointer | |
| 401 | +call umfpack_di_free_symbolic (symbolic) | |
| 402 | + | |
| 403 | +! if parameter det is present, the determinant of the matrix is calculated | |
| 404 | +if (present(det) ) then | |
| 405 | + call umfpack_di_get_determinant(det(1),det(2),numeric,info,status) | |
| 406 | + ! info(1) should be zero | |
| 407 | + if (info(1) /= 0) then | |
| 408 | + if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning | |
| 409 | + write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind))) | |
| 410 | + endif | |
| 411 | + status=info(1) | |
| 412 | + endif | |
| 413 | +endif | |
| 414 | + | |
| 415 | +sys=0 | |
| 416 | +! sys may be used to define type of solving -> see umfpack.h | |
| 417 | +do i=1,m | |
| 418 | + ! Solving | |
| 419 | + call umfpack_di_solve (sys, Ap, Ai, A, x(:,i), B(:,i), numeric, control, info) | |
| 420 | + ! info(1) should be zero | |
| 421 | + if (info(1) /= 0) then | |
| 422 | + write(*,*) "Problem during solving : ",trim(umfpack_return_code(int(info(1),kind=sp_kind))) | |
| 423 | + status=info(1) | |
| 424 | + endif | |
| 425 | +end do | |
| 426 | +! free the C numeric pointer | |
| 427 | +call umfpack_di_free_numeric (numeric) | |
| 428 | + | |
| 429 | +deallocate(A) | |
| 430 | +end subroutine | |
| 348 | 431 | |
| 349 | 432 | |
| 350 | 433 |