Blame view

fvn_sparse/fvn_sparse.f90 22.3 KB
b93026039   daniau   git-svn-id: https...
1
2
3
4
5
6
7
8
  module fvn_sparse
  use fvn_common
  implicit none
  
  ! Sparse solving
  interface fvn_sparse_solve
      module procedure fvn_zl_sparse_solve,fvn_zi_sparse_solve,fvn_dl_sparse_solve,fvn_di_sparse_solve
  end interface fvn_sparse_solve
2b83390c6   wdaniau   1) added fvn_spar...
9
10
11
  interface fvn_sparse_det
      module procedure fvn_zl_sparse_det,fvn_zi_sparse_det,fvn_dl_sparse_det,fvn_di_sparse_det
  end interface fvn_sparse_det
b93026039   daniau   git-svn-id: https...
12
  contains
aee8aaaf1   wdaniau   Added a function ...
13
14
15
  
  function umfpack_return_code(c)
    implicit none
14c923613   wdaniau   Return explicit u...
16
    integer(kind=sp_kind), intent(in) :: c
aee8aaaf1   wdaniau   Added a function ...
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
    character(len=80) :: umfpack_return_code
    select case(c)
      case(0)
        umfpack_return_code="UMFPACK_OK"
      case(1)
        umfpack_return_code="UMFPACK_WARNING_singular_matrix"
      case(2)
        umfpack_return_code="UMFPACK_WARNING_determinant_underflow"
      case(3)
        umfpack_return_code="UMFPACK_WARNING_determinant_overflow"
      case(-1)
        umfpack_return_code="UMFPACK_ERROR_out_of_memory"
      case(-3)
        umfpack_return_code="UMFPACK_ERROR_invalid_Numeric_object"
      case(-4)
        umfpack_return_code="UMFPACK_ERROR_invalid_Symbolic_object"
      case(-5)
        umfpack_return_code="UMFPACK_ERROR_argument_missing"
      case(-6)
        umfpack_return_code="UMFPACK_ERROR_n_nonpositive"
      case(-8)
        umfpack_return_code="UMFPACK_ERROR_invalid_matrix"
      case(-11)
        umfpack_return_code="UMFPACK_ERROR_different_pattern"
      case(-13)
        umfpack_return_code="UMFPACK_ERROR_invalid_system"
      case(-15)
        umfpack_return_code="UMFPACK_ERROR_invalid_permutation"
      case(-911)
        umfpack_return_code="UMFPACK_ERROR_internal_error"
      case(-17)
        umfpack_return_code="UMFPACK_ERROR_file_IO"
      case default
        umfpack_return_code="Unknown return code"
    end select
  end function
14c923613   wdaniau   Return explicit u...
53

b93026039   daniau   git-svn-id: https...
54
55
56
57
58
59
60
61
62
63
64
65
66
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! SPARSE RESOLUTION
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 
  ! Sparse resolution is done by interfaçing Tim Davi's UMFPACK
  ! http://www.cise.ufl.edu/research/sparse/SuiteSparse/
  ! Used packages from SuiteSparse : AMD,UMFPACK,UFconfig
  !
  ! Solve Ax=B using UMFPACK
  !
  ! Where A is a sparse matrix given in its triplet form 
4bd212285   wdaniau   Changed sparse ro...
67
68
  ! T -> non zero elements (Tx and Tz for real and imaginary part if complex)
  ! Ti,Tj -> row and column index (0-based) of the given elt
b93026039   daniau   git-svn-id: https...
69
70
71
72
  ! n : rank of matrix A
  ! nz : number of non zero elts
  !
  ! fvn_*_sparse_solve
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
73
74
  ! * = zl : double complex + integer(kind=dp_kind)
  ! * = zi : double complex + integer(kind=sp_kind)
b93026039   daniau   git-svn-id: https...
75
  !
4bd212285   wdaniau   Changed sparse ro...
76
  subroutine fvn_zl_sparse_solve(n,nz,Tx,Tz,Ti,Tj,Bx,Bz,x,status,det)
b93026039   daniau   git-svn-id: https...
77
  implicit none
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
78
  integer(kind=dp_kind), intent(in) :: n,nz
4bd212285   wdaniau   Changed sparse ro...
79
  real(kind=dp_kind),dimension(nz),intent(in) :: Tx,Tz
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
80
  integer(kind=dp_kind),dimension(nz),intent(in)  :: Ti,Tj
4bd212285   wdaniau   Changed sparse ro...
81
  real(kind=dp_kind),dimension(n),intent(in) :: Bx,Bz
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
82
83
  complex(kind=dp_kind),dimension(n),intent(out) :: x
  integer(kind=dp_kind), intent(out) :: status
c64a05f8a   wdaniau   Sparse Determinan...
84
  real(kind=dp_kind), dimension(3), optional, intent(out) :: det
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
85

f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
86
87
88
  real(kind=dp_kind),dimension(:),allocatable :: Ax,Az
  integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai
  integer(kind=dp_kind) :: symbolic,numeric
4bd212285   wdaniau   Changed sparse ro...
89
  real(kind=dp_kind),dimension(:),allocatable :: xx,xz
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
90
91
92
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
  integer(kind=dp_kind) :: sys
b93026039   daniau   git-svn-id: https...
93
94
95
  
  
  status=0
b93026039   daniau   git-svn-id: https...
96
97
98
99
  allocate(Ax(nz),Az(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
100
  call umfpack_zl_triplet_to_col(n,n,nz,Ti,Tj,Tx,Tz,Ap,Ai,Ax,Az,status)
b93026039   daniau   git-svn-id: https...
101
102
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
103
      write(*,*) "Problem during umfpack_zl_triplet_to_col : ",trim(umfpack_return_code(int(status,kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
104
105
106
107
108
109
110
111
112
  endif
  
  ! Define defaults control values
  call umfpack_zl_defaults(control)
  
  ! Symbolic analysis
  call umfpack_zl_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
113
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
114
115
116
117
118
119
120
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_zl_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
121
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
122
123
124
125
126
      status=info(1)
  endif
  
  ! free the C symbolic pointer
  call umfpack_zl_free_symbolic (symbolic)
2b83390c6   wdaniau   1) added fvn_spar...
127
128
  ! if parameter det is present, the determinant of the matrix is calculated
  if (present(det) ) then
c64a05f8a   wdaniau   Sparse Determinan...
129
    call umfpack_zl_get_determinant(det(1),det(2),det(3),numeric,info,status)  
2b83390c6   wdaniau   1) added fvn_spar...
130
131
    ! info(1) should be zero
    if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
132
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
133
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
134
        endif
2b83390c6   wdaniau   1) added fvn_spar...
135
136
137
        status=info(1)
    endif
  endif
4bd212285   wdaniau   Changed sparse ro...
138
  allocate(xx(n),xz(n))
b93026039   daniau   git-svn-id: https...
139
140
141
142
143
144
145
  sys=0
  ! sys may be used to define type of solving -> see umfpack.h
  
  ! Solving
  call umfpack_zl_solve (sys, Ap, Ai, Ax,Az, xx,xz, bx,bz, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
146
      write(*,*) "Problem during solving : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
147
148
149
150
151
152
      status=info(1)
  endif
  
  
  ! free the C numeric pointer
  call umfpack_zl_free_numeric (numeric)
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
153
  x=cmplx(xx,xz,dp_kind)
b93026039   daniau   git-svn-id: https...
154

4bd212285   wdaniau   Changed sparse ro...
155
  deallocate(xx,xz)
b93026039   daniau   git-svn-id: https...
156
  deallocate(Ax,Az)
b93026039   daniau   git-svn-id: https...
157
  end subroutine
4bd212285   wdaniau   Changed sparse ro...
158
  subroutine fvn_zi_sparse_solve(n,nz,Tx,Tz,Ti,Tj,Bx,Bz,x,status,det)
b93026039   daniau   git-svn-id: https...
159
  implicit none
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
160
  integer(kind=sp_kind), intent(in) :: n,nz
4bd212285   wdaniau   Changed sparse ro...
161
  real(kind=dp_kind),dimension(nz),intent(in) :: Tx,Tz
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
162
  integer(kind=sp_kind),dimension(nz),intent(in)  :: Ti,Tj
4bd212285   wdaniau   Changed sparse ro...
163
  real(kind=dp_kind),dimension(n),intent(in) :: Bx,Bz
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
164
165
  complex(kind=dp_kind),dimension(n),intent(out) :: x
  integer(kind=sp_kind), intent(out) :: status
c64a05f8a   wdaniau   Sparse Determinan...
166
  real(kind=dp_kind), dimension(3), optional, intent(out) :: det
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
167

f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
168
169
170
171
  real(kind=dp_kind),dimension(:),allocatable :: Ax,Az
  integer(kind=sp_kind),dimension(:),allocatable :: Ap,Ai
  !integer(kind=dp_kind) :: symbolic,numeric
  integer(kind=sp_kind),dimension(2) :: symbolic,numeric
b93026039   daniau   git-svn-id: https...
172
  ! As symbolic and numeric are used to store a C pointer, it is necessary to
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
173
174
  ! still use an integer(kind=dp_kind) for 64bits machines
  ! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric
4bd212285   wdaniau   Changed sparse ro...
175
  real(kind=dp_kind),dimension(:),allocatable :: xx,xz
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
176
177
178
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
  integer(kind=sp_kind) :: sys
b93026039   daniau   git-svn-id: https...
179
180
  
  status=0
b93026039   daniau   git-svn-id: https...
181
182
183
184
  allocate(Ax(nz),Az(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
185
  call umfpack_zi_triplet_to_col(n,n,nz,Ti,Tj,Tx,Tz,Ap,Ai,Ax,Az,status)
b93026039   daniau   git-svn-id: https...
186
187
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
188
      write(*,*) "Problem during umfpack_zl_triplet_to_col : ",trim(umfpack_return_code(status))
b93026039   daniau   git-svn-id: https...
189
190
191
192
193
194
195
196
197
  endif
  
  ! Define defaults control values
  call umfpack_zi_defaults(control)
  
  ! Symbolic analysis
  call umfpack_zi_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
198
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
199
200
201
202
203
204
205
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_zi_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
206
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
207
208
209
210
211
      status=info(1)
  endif
  
  ! free the C symbolic pointer
  call umfpack_zi_free_symbolic (symbolic)
2b83390c6   wdaniau   1) added fvn_spar...
212
213
  ! if parameter det is present, the determinant of the matrix is calculated
  if (present(det) ) then
c64a05f8a   wdaniau   Sparse Determinan...
214
    call umfpack_zi_get_determinant(det(1),det(2),det(3),numeric,info,status)
2b83390c6   wdaniau   1) added fvn_spar...
215
216
    ! info(1) should be zero
    if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
217
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
218
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
219
        endif
2b83390c6   wdaniau   1) added fvn_spar...
220
221
222
        status=info(1)
    endif
  endif
4bd212285   wdaniau   Changed sparse ro...
223
  allocate(xx(n),xz(n))
b93026039   daniau   git-svn-id: https...
224
225
226
227
228
229
230
  sys=0
  ! sys may be used to define type of solving -> see umfpack.h
  
  ! Solving
  call umfpack_zi_solve (sys, Ap, Ai, Ax,Az, xx,xz, bx,bz, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
231
      write(*,*) "Problem during solving : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
232
233
234
235
236
      status=info(1)
  endif
  
  ! free the C numeric pointer
  call umfpack_zi_free_numeric (numeric)
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
237
  x=cmplx(xx,xz,dp_kind)
b93026039   daniau   git-svn-id: https...
238

4bd212285   wdaniau   Changed sparse ro...
239
  deallocate(xx,xz)
b93026039   daniau   git-svn-id: https...
240
  deallocate(Ax,Az)
b93026039   daniau   git-svn-id: https...
241
  end subroutine
2b83390c6   wdaniau   1) added fvn_spar...
242
  subroutine fvn_dl_sparse_solve(n,nz,T,Ti,Tj,B,x,status,det)
b93026039   daniau   git-svn-id: https...
243
  implicit none
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
244
245
246
247
248
249
  integer(kind=dp_kind), intent(in) :: n,nz
  real(kind=dp_kind),dimension(nz),intent(in) :: T
  integer(kind=dp_kind),dimension(nz),intent(in)  :: Ti,Tj
  real(kind=dp_kind),dimension(n),intent(in) :: B
  real(kind=dp_kind),dimension(n),intent(out) :: x
  integer(kind=dp_kind), intent(out) :: status
c64a05f8a   wdaniau   Sparse Determinan...
250
  real(kind=dp_kind), dimension(2), optional, intent(out) :: det
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
251

f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
252
253
254
255
256
257
258
  real(kind=dp_kind),dimension(:),allocatable :: A
  integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai
  !integer(kind=dp_kind) :: symbolic,numeric
  integer(kind=dp_kind) :: symbolic,numeric
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
  integer(kind=dp_kind) :: sys
b93026039   daniau   git-svn-id: https...
259
260
  
  status=0
b93026039   daniau   git-svn-id: https...
261
262
263
264
  allocate(A(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
265
  call umfpack_dl_triplet_to_col(n,n,nz,Ti,Tj,T,Ap,Ai,A,status)
b93026039   daniau   git-svn-id: https...
266
267
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
268
      write(*,*) "Problem during umfpack_dl_triplet_to_col : ",trim(umfpack_return_code(int(status,kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
269
270
271
272
273
274
275
276
277
  endif
  
  ! Define defaults control values
  call umfpack_dl_defaults(control)
  
  ! Symbolic analysis
  call umfpack_dl_symbolic(n,n,Ap,Ai,A,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
278
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
279
280
281
282
283
284
285
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_dl_numeric (Ap, Ai, A, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
286
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
287
288
289
290
291
      status=info(1)
  endif
  
  ! free the C symbolic pointer
  call umfpack_dl_free_symbolic (symbolic)
2b83390c6   wdaniau   1) added fvn_spar...
292
293
  ! if parameter det is present, the determinant of the matrix is calculated
  if (present(det) ) then
c64a05f8a   wdaniau   Sparse Determinan...
294
    call umfpack_dl_get_determinant(det(1),det(2),numeric,info,status)
2b83390c6   wdaniau   1) added fvn_spar...
295
296
    ! info(1) should be zero
    if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
297
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
298
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
299
        endif
2b83390c6   wdaniau   1) added fvn_spar...
300
301
302
        status=info(1)
    endif
  endif
b93026039   daniau   git-svn-id: https...
303
304
305
306
307
308
309
  sys=0
  ! sys may be used to define type of solving -> see umfpack.h
  
  ! Solving
  call umfpack_dl_solve (sys, Ap, Ai, A, x, B, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
310
      write(*,*) "Problem during solving : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
311
312
313
314
315
316
317
      status=info(1)
  endif
  
  ! free the C numeric pointer
  call umfpack_dl_free_numeric (numeric)
  
  deallocate(A)
b93026039   daniau   git-svn-id: https...
318
  end subroutine
2b83390c6   wdaniau   1) added fvn_spar...
319
  subroutine fvn_di_sparse_solve(n,nz,T,Ti,Tj,B,x,status,det)
b93026039   daniau   git-svn-id: https...
320
  implicit none
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
321
322
323
324
325
326
  integer(kind=sp_kind), intent(in) :: n,nz
  real(kind=dp_kind),dimension(nz),intent(in) :: T
  integer(kind=sp_kind),dimension(nz),intent(in)  :: Ti,Tj
  real(kind=dp_kind),dimension(n),intent(in) :: B
  real(kind=dp_kind),dimension(n),intent(out) :: x
  integer(kind=sp_kind), intent(out) :: status
c64a05f8a   wdaniau   Sparse Determinan...
327
  real(kind=dp_kind), dimension(2), optional, intent(out) :: det
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
328

f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
329
330
331
332
  real(kind=dp_kind),dimension(:),allocatable :: A
  integer(kind=sp_kind),dimension(:),allocatable :: Ap,Ai
  !integer(kind=dp_kind) :: symbolic,numeric
  integer(kind=sp_kind),dimension(2) :: symbolic,numeric
b93026039   daniau   git-svn-id: https...
333
  ! As symbolic and numeric are used to store a C pointer, it is necessary to
f6bacaf83   cwaterkeyn   ChW 11/09: ANSI c...
334
335
336
337
338
  ! still use an integer(kind=dp_kind) for 64bits machines
  ! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
  integer(kind=sp_kind) :: sys
b93026039   daniau   git-svn-id: https...
339
340
  
  status=0
b93026039   daniau   git-svn-id: https...
341
342
343
344
  allocate(A(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
345
  call umfpack_di_triplet_to_col(n,n,nz,Ti,Tj,T,Ap,Ai,A,status)
b93026039   daniau   git-svn-id: https...
346
347
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
348
      write(*,*) "Problem during umfpack_di_triplet_to_col : ",trim(umfpack_return_code(status))
b93026039   daniau   git-svn-id: https...
349
350
351
352
353
354
355
356
357
  endif
  
  ! Define defaults control values
  call umfpack_di_defaults(control)
  
  ! Symbolic analysis
  call umfpack_di_symbolic(n,n,Ap,Ai,A,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
358
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
359
360
361
362
363
364
365
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_di_numeric (Ap, Ai, A, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
366
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
367
368
369
370
371
      status=info(1)
  endif
  
  ! free the C symbolic pointer
  call umfpack_di_free_symbolic (symbolic)
2b83390c6   wdaniau   1) added fvn_spar...
372
373
  ! if parameter det is present, the determinant of the matrix is calculated
  if (present(det) ) then
c64a05f8a   wdaniau   Sparse Determinan...
374
    call umfpack_di_get_determinant(det(1),det(2),numeric,info,status)  
2b83390c6   wdaniau   1) added fvn_spar...
375
376
    ! info(1) should be zero
    if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
377
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
378
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
379
        endif
2b83390c6   wdaniau   1) added fvn_spar...
380
381
382
        status=info(1)
    endif
  endif
b93026039   daniau   git-svn-id: https...
383
384
  sys=0
  ! sys may be used to define type of solving -> see umfpack.h
b93026039   daniau   git-svn-id: https...
385
386
387
388
  ! Solving
  call umfpack_di_solve (sys, Ap, Ai, A, x, B, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
389
      write(*,*) "Problem during solving : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
b93026039   daniau   git-svn-id: https...
390
391
392
393
394
395
396
      status=info(1)
  endif
  
  ! free the C numeric pointer
  call umfpack_di_free_numeric (numeric)
  
  deallocate(A)
b93026039   daniau   git-svn-id: https...
397
  end subroutine
2b83390c6   wdaniau   1) added fvn_spar...
398
399
400
401
402
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! SPARSE DETERMINANT
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4bd212285   wdaniau   Changed sparse ro...
403
  subroutine fvn_zl_sparse_det(n,nz,Tx,Tz,Ti,Tj,det,status)
2b83390c6   wdaniau   1) added fvn_spar...
404
405
  implicit none
  integer(kind=dp_kind), intent(in) :: n,nz
4bd212285   wdaniau   Changed sparse ro...
406
  real(kind=dp_kind),dimension(nz),intent(in) :: Tx,Tz
2b83390c6   wdaniau   1) added fvn_spar...
407
  integer(kind=dp_kind),dimension(nz),intent(in)  :: Ti,Tj
c64a05f8a   wdaniau   Sparse Determinan...
408
  real(kind=dp_kind), dimension(3), intent(out) :: det
2b83390c6   wdaniau   1) added fvn_spar...
409
  integer(kind=dp_kind), intent(out) :: status
2b83390c6   wdaniau   1) added fvn_spar...
410
411
412
413
414
415
416
417
418
  real(kind=dp_kind),dimension(:),allocatable :: Ax,Az
  integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai
  integer(kind=dp_kind) :: symbolic,numeric
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
  real(kind=dp_kind) :: Mx,Mz,Ex
  
  
  status=0
2b83390c6   wdaniau   1) added fvn_spar...
419
420
421
422
  allocate(Ax(nz),Az(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
423
  call umfpack_zl_triplet_to_col(n,n,nz,Ti,Tj,Tx,Tz,Ap,Ai,Ax,Az,status)
2b83390c6   wdaniau   1) added fvn_spar...
424
425
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
426
      write(*,*) "Problem during umfpack_zl_triplet_to_col ",trim(umfpack_return_code(int(status,kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
427
428
429
430
431
432
433
434
435
  endif
  
  ! Define defaults control values
  call umfpack_zl_defaults(control)
  
  ! Symbolic analysis
  call umfpack_zl_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
436
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
437
438
439
440
441
442
443
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_zl_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
444
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
445
446
447
448
449
      status=info(1)
  endif
  
  ! free the C symbolic pointer
  call umfpack_zl_free_symbolic (symbolic)
c64a05f8a   wdaniau   Sparse Determinan...
450
  call umfpack_zl_get_determinant(det(1),det(2),det(3),numeric,info,status)
2b83390c6   wdaniau   1) added fvn_spar...
451
452
  ! info(1) should be zero
  if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
453
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
454
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
455
        endif
2b83390c6   wdaniau   1) added fvn_spar...
456
457
      status=info(1)
  endif
2b83390c6   wdaniau   1) added fvn_spar...
458
459
460
461
462
  
  ! free the C numeric pointer
  call umfpack_zl_free_numeric (numeric)
  
  deallocate(Ax,Az)
2b83390c6   wdaniau   1) added fvn_spar...
463
  end subroutine
4bd212285   wdaniau   Changed sparse ro...
464
  subroutine fvn_zi_sparse_det(n,nz,Tx,Tz,Ti,Tj,det,status)
2b83390c6   wdaniau   1) added fvn_spar...
465
466
  implicit none
  integer(kind=sp_kind), intent(in) :: n,nz
4bd212285   wdaniau   Changed sparse ro...
467
  real(kind=dp_kind),dimension(nz),intent(in) :: Tx,Tz
2b83390c6   wdaniau   1) added fvn_spar...
468
469
  integer(kind=sp_kind),dimension(nz),intent(in)  :: Ti,Tj
  integer(kind=sp_kind), intent(out) :: status
c64a05f8a   wdaniau   Sparse Determinan...
470
  real(kind=dp_kind), dimension(3), intent(out) :: det
2b83390c6   wdaniau   1) added fvn_spar...
471

2b83390c6   wdaniau   1) added fvn_spar...
472
473
474
475
476
477
478
479
480
  real(kind=dp_kind),dimension(:),allocatable :: Ax,Az
  integer(kind=sp_kind),dimension(:),allocatable :: Ap,Ai
  !integer(kind=dp_kind) :: symbolic,numeric
  integer(kind=sp_kind),dimension(2) :: symbolic,numeric
  ! As symbolic and numeric are used to store a C pointer, it is necessary to
  ! still use an integer(kind=dp_kind) for 64bits machines
  ! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
2b83390c6   wdaniau   1) added fvn_spar...
481
482
  
  status=0
2b83390c6   wdaniau   1) added fvn_spar...
483
484
485
486
  allocate(Ax(nz),Az(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
487
  call umfpack_zi_triplet_to_col(n,n,nz,Ti,Tj,Tx,Tz,Ap,Ai,Ax,Az,status)
2b83390c6   wdaniau   1) added fvn_spar...
488
489
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
490
      write(*,*) "Problem during umfpack_zl_triplet_to_col : ",trim(umfpack_return_code(status))
2b83390c6   wdaniau   1) added fvn_spar...
491
492
493
494
495
496
497
498
499
  endif
  
  ! Define defaults control values
  call umfpack_zi_defaults(control)
  
  ! Symbolic analysis
  call umfpack_zi_symbolic(n,n,Ap,Ai,Ax,Az,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
500
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
501
502
503
504
505
506
507
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_zi_numeric (Ap, Ai, Ax, Az, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
508
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
509
510
511
512
513
      status=info(1)
  endif
  
  ! free the C symbolic pointer
  call umfpack_zi_free_symbolic (symbolic)
c64a05f8a   wdaniau   Sparse Determinan...
514
  call umfpack_zi_get_determinant(det(1),det(2),det(3),numeric,info,status)
2b83390c6   wdaniau   1) added fvn_spar...
515
516
  ! info(1) should be zero
  if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
517
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
518
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
519
        endif
2b83390c6   wdaniau   1) added fvn_spar...
520
521
      status=info(1)
  endif
2b83390c6   wdaniau   1) added fvn_spar...
522
523
524
525
526
  
  ! free the C numeric pointer
  call umfpack_zi_free_numeric (numeric)
  
  deallocate(Ax,Az)
2b83390c6   wdaniau   1) added fvn_spar...
527
528
529
530
531
532
533
534
  end subroutine
  
  subroutine fvn_dl_sparse_det(n,nz,T,Ti,Tj,det,status)
  implicit none
  integer(kind=dp_kind), intent(in) :: n,nz
  real(kind=dp_kind),dimension(nz),intent(in) :: T
  integer(kind=dp_kind),dimension(nz),intent(in)  :: Ti,Tj
  integer(kind=dp_kind), intent(out) :: status
c64a05f8a   wdaniau   Sparse Determinan...
535
  real(kind=dp_kind), dimension(2), intent(out) :: det
2b83390c6   wdaniau   1) added fvn_spar...
536

2b83390c6   wdaniau   1) added fvn_spar...
537
538
539
540
541
542
  real(kind=dp_kind),dimension(:),allocatable :: A
  integer(kind=dp_kind),dimension(:),allocatable :: Ap,Ai
  !integer(kind=dp_kind) :: symbolic,numeric
  integer(kind=dp_kind) :: symbolic,numeric
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
2b83390c6   wdaniau   1) added fvn_spar...
543
544
  
  status=0
2b83390c6   wdaniau   1) added fvn_spar...
545
546
547
548
  allocate(A(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
549
  call umfpack_dl_triplet_to_col(n,n,nz,Ti,Tj,T,Ap,Ai,A,status)
2b83390c6   wdaniau   1) added fvn_spar...
550
551
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
552
      write(*,*) "Problem during umfpack_dl_triplet_to_col : ",trim(umfpack_return_code(int(status,kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
553
554
555
556
557
558
559
560
561
  endif
  
  ! Define defaults control values
  call umfpack_dl_defaults(control)
  
  ! Symbolic analysis
  call umfpack_dl_symbolic(n,n,Ap,Ai,A,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
562
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
563
564
565
566
567
568
569
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_dl_numeric (Ap, Ai, A, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
570
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
571
572
573
574
575
      status=info(1)
  endif
  
  ! free the C symbolic pointer
  call umfpack_dl_free_symbolic (symbolic)
c64a05f8a   wdaniau   Sparse Determinan...
576
  call umfpack_dl_get_determinant(det(1),det(2),numeric,info,status)
2b83390c6   wdaniau   1) added fvn_spar...
577
578
  ! info(1) should be zero
  if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
579
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
580
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
581
        endif
2b83390c6   wdaniau   1) added fvn_spar...
582
583
      status=info(1)
  endif
2b83390c6   wdaniau   1) added fvn_spar...
584
585
586
587
588
  
  ! free the C numeric pointer
  call umfpack_dl_free_numeric (numeric)
  
  deallocate(A)
2b83390c6   wdaniau   1) added fvn_spar...
589
590
591
592
593
594
595
596
597
  end subroutine
  
  
  subroutine fvn_di_sparse_det(n,nz,T,Ti,Tj,det,status)
  implicit none
  integer(kind=sp_kind), intent(in) :: n,nz
  real(kind=dp_kind),dimension(nz),intent(in) :: T
  integer(kind=sp_kind),dimension(nz),intent(in)  :: Ti,Tj
  integer(kind=sp_kind), intent(out) :: status
c64a05f8a   wdaniau   Sparse Determinan...
598
  real(kind=dp_kind), dimension(2), intent(out) :: det
2b83390c6   wdaniau   1) added fvn_spar...
599

2b83390c6   wdaniau   1) added fvn_spar...
600
601
602
603
604
605
606
607
608
609
  real(kind=dp_kind),dimension(:),allocatable :: A
  integer(kind=sp_kind),dimension(:),allocatable :: Ap,Ai
  !integer(kind=dp_kind) :: symbolic,numeric
  integer(kind=sp_kind),dimension(2) :: symbolic,numeric
  ! As symbolic and numeric are used to store a C pointer, it is necessary to
  ! still use an integer(kind=dp_kind) for 64bits machines
  ! An other possibility : integer(kind=sp_kind),dimension(2) :: symbolic,numeric
  real(kind=dp_kind),dimension(90) :: info
  real(kind=dp_kind),dimension(20) :: control
  integer(kind=sp_kind) :: sys
2b83390c6   wdaniau   1) added fvn_spar...
610
611
612
  
  
  status=0
2b83390c6   wdaniau   1) added fvn_spar...
613
614
615
616
  allocate(A(nz))
  allocate(Ap(n+1),Ai(nz))
  
  ! perform the triplet to compressed column form -> Ap,Ai,Ax,Az
4bd212285   wdaniau   Changed sparse ro...
617
  call umfpack_di_triplet_to_col(n,n,nz,Ti,Tj,T,Ap,Ai,A,status)
2b83390c6   wdaniau   1) added fvn_spar...
618
619
  ! if status is not zero a problem has occured
  if (status /= 0) then
7dc628d15   wdaniau   Added error outpu...
620
      write(*,*) "Problem during umfpack_di_triplet_to_col : ",trim(umfpack_return_code(status))
2b83390c6   wdaniau   1) added fvn_spar...
621
622
623
624
625
626
627
628
629
  endif
  
  ! Define defaults control values
  call umfpack_di_defaults(control)
  
  ! Symbolic analysis
  call umfpack_di_symbolic(n,n,Ap,Ai,A,symbolic, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
630
      write(*,*) "Problem during symbolic analysis : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
631
632
633
634
635
636
637
      status=info(1)
  endif
  
  ! Numerical factorization
  call umfpack_di_numeric (Ap, Ai, A, symbolic, numeric, control, info)
  ! info(1) should be zero
  if (info(1) /= 0) then
7dc628d15   wdaniau   Added error outpu...
638
      write(*,*) "Problem during numerical factorization : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
2b83390c6   wdaniau   1) added fvn_spar...
639
640
641
642
643
644
      status=info(1)
  endif
  
  
  ! free the C symbolic pointer
  call umfpack_di_free_symbolic (symbolic)
c64a05f8a   wdaniau   Sparse Determinan...
645
  call umfpack_di_get_determinant(det(1),det(2),numeric,info,status)
2b83390c6   wdaniau   1) added fvn_spar...
646
647
  ! info(1) should be zero
  if (info(1) /= 0) then
ba393a269   wdaniau   1) updated docume...
648
        if ( (info(1) < 1) .or. (info(1) >3) ) then ! not a warning
7dc628d15   wdaniau   Added error outpu...
649
            write(*,*) "Problem during sparse determinant : ",trim(umfpack_return_code(int(info(1),kind=sp_kind)))
ba393a269   wdaniau   1) updated docume...
650
        endif
2b83390c6   wdaniau   1) added fvn_spar...
651
652
653
654
655
656
657
      status=info(1)
  endif
  
  ! free the C numeric pointer
  call umfpack_di_free_numeric (numeric)
  
  deallocate(A)
2b83390c6   wdaniau   1) added fvn_spar...
658
  end subroutine
b93026039   daniau   git-svn-id: https...
659
  end module fvn_sparse