5 &(npoin,nsegb,gloseg,maxseg,da,xa,xinc,rhs,typext,knolg,
37 #if defined HAVE_MUMPS 38 include
'dmumps_struc.h' 43 INTEGER,
INTENT(IN) :: NPOIN,NSEGB,MAXSEG,NPOIN_TOT
44 INTEGER,
INTENT(IN) :: GLOSEG(maxseg,2)
45 DOUBLE PRECISION,
INTENT(INOUT) :: XA(*),RHS(npoin)
46 DOUBLE PRECISION,
INTENT(INOUT) :: XINC(npoin),DA(npoin)
47 CHARACTER(LEN=1),
INTENT(IN) :: TYPEXT
48 INTEGER,
INTENT(IN) :: KNOLG(*)
52 #if defined HAVE_MUMPS 54 DOUBLE PRECISION TIME_IN_SECONDS2
55 EXTERNAL time_in_seconds2
56 type(dmumps_struc) mumps_par
58 DOUBLE PRECISION ,
ALLOCATABLE :: TEMP1(:),TEMP2(:)
59 INTEGER,
ALLOCATABLE :: TEMP3(:)
60 INTEGER I,J,K,ERR,NBELEM,IER, IAUX, KTRI, NPOIN2, N2
62 DOUBLE PRECISION :: RMIN, RMAX, RAUX, EPSBLR
63 INTEGER :: INIV, INPREC, NAUX
64 CHARACTER(LEN=80) :: KVERS, KSTRATEGY, KNOM, KRENUM, KPRE, KMEM,
66 LOGICAL :: LAUTOCORREC, LTRI, LPIVOTSTAT, LDEFAULT
76 knom=
'<solve_mumps_par>' 77 knom=trim(adjustl(knom))
105 mumps_par%COMM =
comm 107 IF(typext.EQ.
'S')
THEN 113 CALL dmumps(mumps_par)
116 kvers=mumps_par%VERSION_NUMBER
117 kvers=trim(adjustl(kvers))
119 CASE(
'4.10.0',
'5.2.1',
'5.2.1consortium')
121 WRITE(
lu,*)
'*************************************************' 122 WRITE(
lu,*)knom//
' * Warning *, MUMPS version not validated' 123 WRITE(
lu,*)
'version=',kvers
124 WRITE(
lu,*)
'*************************************************' 130 mumps_par%ICNTL(1)=
lu 135 mumps_par%ICNTL(1)=
lu 136 mumps_par%ICNTL(2)=
lu 137 mumps_par%ICNTL(3)=
lu 143 mumps_par%ICNTL(18)=3
145 IF (kpre(1:4).EQ.
'AUTO')
THEN 147 mumps_par%ICNTL(8)=77
148 mumps_par%ICNTL(12)=0
149 ELSE IF (kpre(1:4).EQ.
'SANS')
THEN 152 mumps_par%ICNTL(12)=1
154 WRITE(
lu,*)
'***************************************************' 155 WRITE(
lu,*)knom//
' *** Syntax Error ****, Mauvaise option kpre' 156 WRITE(
lu,*)
'***************************************************' 163 mumps_par%ICNTL(35)=0
165 mumps_par%KEEP(370)=1
166 mumps_par%KEEP(371)=1
167 mumps_par%ICNTL(35)=0
169 mumps_par%ICNTL(35)=2
170 mumps_par%ICNTL(36)=0
171 mumps_par%ICNTL(37)=0
172 mumps_par%CNTL(7)=epsblr
174 mumps_par%KEEP(370)=1
175 mumps_par%KEEP(371)=1
176 mumps_par%ICNTL(35)=2
177 mumps_par%ICNTL(36)=0
178 mumps_par%ICNTL(37)=0
179 mumps_par%CNTL(7)=epsblr
181 WRITE(
lu,*)
'***************************************************' 182 WRITE(
lu,*)knom//
' ** Syntax Error ***, Mauvaise option kacce' 183 WRITE(
lu,*)
'***************************************************' 191 mumps_par%ICNTL(28)=1
192 mumps_par%ICNTL(29)=0
195 mumps_par%ICNTL(28)=1
196 mumps_par%ICNTL(29)=0
199 mumps_par%ICNTL(28)=1
200 mumps_par%ICNTL(29)=0
203 mumps_par%ICNTL(28)=1
204 mumps_par%ICNTL(29)=0
207 mumps_par%ICNTL(28)=2
208 mumps_par%ICNTL(29)=1
211 mumps_par%ICNTL(28)=1
212 mumps_par%ICNTL(29)=0
215 mumps_par%ICNTL(28)=1
216 mumps_par%ICNTL(29)=0
219 mumps_par%ICNTL(28)=2
220 mumps_par%ICNTL(29)=2
223 mumps_par%ICNTL(28)=1
224 mumps_par%ICNTL(29)=0
226 WRITE(
lu,*)
'***************************************************' 227 WRITE(
lu,*)knom//
' ** Syntax Error ***, Mauvaise option krenum' 228 WRITE(
lu,*)
'***************************************************' 233 mumps_par%ICNTL(25)=0
234 IF (inprec .GE. 0)
THEN 235 mumps_par%ICNTL(13)=1
236 mumps_par%ICNTL(24)=1
237 mumps_par%CNTL(3)=-10.d0**(-inprec)
238 mumps_par%CNTL(5)=1.d+6
240 mumps_par%ICNTL(13)=0
241 mumps_par%ICNTL(24)=0
242 mumps_par%CNTL(3)=0.d0
243 mumps_par%CNTL(5)=0.d0
247 mumps_par%CNTL(1)=-1.d0
250 mumps_par%ICNTL(14)=50
251 IF (kmem(1:2).EQ.
'IC')
THEN 252 mumps_par%ICNTL(22)=0
253 mumps_par%ICNTL(23)=0
254 ELSE IF (kmem(1:3).EQ.
'OOC')
THEN 255 mumps_par%ICNTL(22)=1
256 mumps_par%ICNTL(23)=0
257 mumps_par%OOC_TMPDIR=
'.' 259 WRITE(
lu,*)
'***************************************************' 260 WRITE(
lu,*)knom//
' *** Syntax Error ***, Mauvaise option kmem' 261 WRITE(
lu,*)
'***************************************************' 268 mumps_par%CNTL(2)=1.d-14
269 mumps_par%ICNTL(10)=4
270 mumps_par%ICNTL(11)=2
272 mumps_par%CNTL(2)=0.d0
273 mumps_par%ICNTL(10)=0
274 mumps_par%ICNTL(11)=0
276 mumps_par%CNTL(2)=0.d0
277 mumps_par%ICNTL(10)=-2
278 mumps_par%ICNTL(11)=0
280 mumps_par%CNTL(2)=1.d-50
281 mumps_par%ICNTL(10)=10
282 mumps_par%ICNTL(11)=1
284 WRITE(
lu,*)
'***************************************************' 285 WRITE(
lu,*)knom//
' *** Syntax Error ****, Mauvaise option kpost' 286 WRITE(
lu,*)
'***************************************************' 292 mumps_par%N = 2*npoin_tot
293 IF(typext.EQ.
'S')
THEN 294 mumps_par%NZ_LOC = npoin+nsegb
296 mumps_par%NZ_LOC = npoin+2*nsegb
299 ALLOCATE(temp1(mumps_par%N),stat=err)
300 CALL check_allocate(err,
"TEMP1")
301 ALLOCATE(temp2(mumps_par%N),stat=err)
302 CALL check_allocate(err,
"TEMP2")
303 ALLOCATE(temp3(npoin),stat=err)
304 CALL check_allocate(err,
"TEMP3")
305 ALLOCATE(mumps_par%IRN_LOC(mumps_par%NZ_LOC),stat=err)
306 CALL check_allocate(err,
"MUMPS_PAR%IRN_LOC")
307 ALLOCATE(mumps_par%JCN_LOC(mumps_par%NZ_LOC),stat=err)
308 CALL check_allocate(err,
"MUMPS_PAR%JCN_LOC")
309 ALLOCATE(mumps_par%A_LOC(mumps_par%NZ_LOC),stat=err)
310 CALL check_allocate(err,
"MUMPS_PAR%A_LOC")
311 ALLOCATE(mumps_par%RHS(mumps_par%N),stat=err)
312 CALL check_allocate(err,
"MUMPS_PAR%RHS")
317 mumps_par%IRN_LOC(:)=0
318 mumps_par%JCN_LOC(:)=0
319 mumps_par%A_LOC(:)=0.0
328 IF (k.LE.npoin2)
THEN 331 iaux = knolg(k-npoin2) + n2
333 IF ((raux.GT.rmin).AND.(raux.LT.rmax).AND.(iaux.GT.0))
THEN 334 mumps_par%IRN_LOC(ktri) = iaux
335 mumps_par%JCN_LOC(ktri) = iaux
336 mumps_par%A_LOC(ktri) = da(k)
344 IF (k .LE. npoin/2)
THEN 345 mumps_par%IRN_LOC(k) = knolg(k)
346 mumps_par%JCN_LOC(k) = knolg(k)
347 temp1(knolg(k))=rhs(k)
350 mumps_par%IRN_LOC(k) = knolg(k-npoin/2) + mumps_par%N/2
351 mumps_par%JCN_LOC(k) = knolg(k-npoin/2) + mumps_par%N/2
352 temp1(knolg(k-npoin/2)+ mumps_par%N/2)=rhs(k)
353 temp3(k)=knolg(k-npoin/2)+ mumps_par%N/2
355 mumps_par%A_LOC(k) = da(k)
359 WRITE(
lu,*)
'(AD) COMPAD :: SOLVE_MUMPS_PAR.F: DIRECT CALL OF ',
360 &
'MPI_ALLREDUCE NOT AD-READY.' 361 WRITE(
lu,*)
' PLEASE CONTACT JR @ ADJOINTWARE' 370 mumps_par%RHS(i)=temp2(i)
375 raux=100.d0*ktri/(npoin*1.0)
376 WRITE(
lu,*)
'*************************************************' 377 WRITE(
lu,*)knom//
'MATRIX n: ',mumps_par%N
378 WRITE(
lu,*)knom//
'MATRIX filtering 1: ',raux,
' %' 379 WRITE(
lu,*)
'*************************************************' 383 IF(typext.EQ.
'S')
THEN 388 i = temp3(gloseg(k,1))
389 j = temp3(gloseg(k,2))
390 IF ((raux.GT.rmin).AND.(raux.LT.rmax).AND.(i.GT.0).
394 mumps_par%IRN_LOC(nbelem) = i
395 mumps_par%JCN_LOC(nbelem) = j
397 mumps_par%IRN_LOC(nbelem) = j
398 mumps_par%JCN_LOC(nbelem) = i
400 mumps_par%A_LOC(nbelem) = xa(k)
405 raux=100.d0*naux/(1.d0*nsegb)
406 WRITE(
lu,*)
'*************************************************' 407 WRITE(
lu,*)knom//
'MATRIX nz_loc: ',mumps_par%NZ_LOC
408 WRITE(
lu,*)knom//
'MATRIX filtering 2: ',raux,
' %' 409 WRITE(
lu,*)
'*************************************************' 412 i = temp3(gloseg(k,1))
413 j = temp3(gloseg(k,2))
416 mumps_par%IRN_LOC(nbelem) = i
417 mumps_par%JCN_LOC(nbelem) = j
419 mumps_par%IRN_LOC(nbelem) = j
420 mumps_par%JCN_LOC(nbelem) = i
422 mumps_par%A_LOC(nbelem) = xa(k)
430 i = temp3(gloseg(k,1))
431 j = temp3(gloseg(k,2))
432 IF ((raux.GT.rmin).AND.(raux.LT.rmax).AND.(i.GT.0).
435 mumps_par%A_LOC(nbelem) = xa(k)
441 raux = abs(xa(k+nsegb))
442 i = temp3(gloseg(k,2))
443 j = temp3(gloseg(k,1))
444 IF ((raux.GT.rmin).AND.(raux.LT.rmax).AND.(i.GT.0).
447 mumps_par%IRN_LOC(nbelem) = i
448 mumps_par%JCN_LOC(nbelem) = j
449 mumps_par%A_LOC(nbelem) = xa(k+nsegb)
454 raux=100.d0*naux/(2.d0*nsegb)
455 WRITE(
lu,*)
'*************************************************' 456 WRITE(
lu,*)knom//
'MATRIX nz_loc: ',mumps_par%NZ_LOC
457 WRITE(
lu,*)knom//
'MATRIX filtering 2: ',raux,
' %' 458 WRITE(
lu,*)
'*************************************************' 461 i = temp3(gloseg(k,1))
462 j = temp3(gloseg(k,2))
464 mumps_par%IRN_LOC(nbelem) = i
465 mumps_par%JCN_LOC(nbelem) = j
466 mumps_par%A_LOC(nbelem) = xa(k)
469 i = temp3(gloseg(k,2))
470 j = temp3(gloseg(k,1))
472 mumps_par%IRN_LOC(nbelem) = i
473 mumps_par%JCN_LOC(nbelem) = j
474 mumps_par%A_LOC(nbelem) = xa(k+nsegb)
484 CALL dmumps(mumps_par)
487 CALL dmumps(mumps_par)
490 CALL dmumps(mumps_par)
493 IF(mumps_par%MYID.EQ. 0 )
THEN 495 IF(mumps_par%INFO(1).LT.0)
THEN 496 WRITE(
lu,2001) mumps_par%INFO(1)
501 temp1(k)=mumps_par%RHS(k)
508 WRITE(
lu,*)
'(AD) COMPAD :: SOLVE_MUMPS_PAR.F: DIRECT CALL OF ',
509 &
'MPI_ALLREDUCE NOT AD-READY.' 510 WRITE(
lu,*)
' PLEASE CONTACT JR @ ADJOINTWARE' 517 CALL mpi_barrier(
comm,ier)
529 DEALLOCATE(mumps_par%IRN_LOC)
530 DEALLOCATE(mumps_par%JCN_LOC)
531 DEALLOCATE(mumps_par%A_LOC)
532 DEALLOCATE(mumps_par%RHS)
533 CALL mpi_barrier(
comm,ier)
538 CALL dmumps(mumps_par)
540 2001
FORMAT(1x,
'SOLVE_MUMPS: ERROR DURING SOLVE: ' 541 & ,/,1x,
'ERROR CODE INFO(1): ',1i6)
544 2019
FORMAT(1x,
'MUMPS_PAR NOT INSTALLED IN THIS SYSTEM',/,1x,
545 &
'CHOOSE OTHER METHOD ',///)
integer, parameter mpi_double_precision
subroutine solve_mumps_par(NPOIN, NSEGB, GLOSEG, MAXSEG, DA, XA, XINC, RHS, TYPEXT, KNOLG, NPOIN_TOT)