OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dmumps_fac_front_type2_aux_m Module Reference

Functions/Subroutines

subroutine dmumps_fac_i_ldlt_niv2 (diag_orig, sizediag_orig, gw_factcumul, nfront, nass, ibeg_block_to_send, ibeg_block, iend_block, nass2, tipiv, n, inode, iw, liw, a, la, nnegw, nb22t2w, nbtinyw, det_expw, det_mantw, det_signw, inopv, iflag, ioldps, poselt, uu, seuil, keep, keep8, pivsiz, dkeep, pivnul_list, lpn_list, pp_first2swap_l, pp_lastpanelondisk, pp_lastpivrptrindexfilled, pivot_option, inextpiv, iend_blr, lr_activated, ooc_effective_on_front)
subroutine dmumps_fac_mq_ldlt_niv2 (iend_block, nass, npiv, inode, a, la, ldafs, poselt, ifinb, pivsiz, k219, pivot_option, iend_blr, lr_activated)
subroutine dmumps_send_factored_blk (comm_load, ass_irecv, n, inode, fpere, iw, liw, ioldps, poselt, a, la, lda_fs, ibeg_block, iend, tipiv, lpiv, lastbl, nb_bloc_fac, comm, myid, bufr, lbufr, lbufr_bytes, nbfin, leaf, iflag, ierror, ipool, lpool, slavef, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, comp, ptrist, ptrast, ptlust_s, ptrfac, step, pimaster, pamaster, nstk_s, perm, procnode_steps, root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, nd, frere, lptrar, nelt, frtptr, frtelt, istep_to_iniv2, tab_pos_in_pere, nelim, lr_activated, npartsass, current_blr_panel, blr_loru, lrgroups)

Function/Subroutine Documentation

◆ dmumps_fac_i_ldlt_niv2()

subroutine dmumps_fac_front_type2_aux_m::dmumps_fac_i_ldlt_niv2 ( double precision, dimension(sizediag_orig) diag_orig,
integer sizediag_orig,
double precision gw_factcumul,
integer nfront,
integer nass,
integer ibeg_block_to_send,
integer ibeg_block,
integer iend_block,
integer nass2,
integer, dimension( nass2 ) tipiv,
integer n,
integer inode,
integer, dimension(liw) iw,
integer liw,
double precision, dimension(la) a,
integer(8) la,
integer, intent(inout) nnegw,
integer, intent(inout) nb22t2w,
integer, intent(inout) nbtinyw,
integer, intent(inout) det_expw,
double precision, intent(inout) det_mantw,
integer, intent(inout) det_signw,
integer inopv,
integer iflag,
integer ioldps,
integer(8) poselt,
double precision uu,
double precision seuil,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer pivsiz,
double precision, dimension(230) dkeep,
integer, dimension(lpn_list) pivnul_list,
integer lpn_list,
integer pp_first2swap_l,
integer pp_lastpanelondisk,
integer pp_lastpivrptrindexfilled,
integer, intent(in) pivot_option,
integer, intent(inout) inextpiv,
integer, intent(in) iend_blr,
logical, intent(in) lr_activated,
logical, intent(in) ooc_effective_on_front )

Definition at line 16 of file dfac_front_type2_aux.F.

31 USE mumps_ooc_common, ONLY : typef_l
32 USE dmumps_fac_front_aux_m
33 IMPLICIT NONE
34 INTEGER SIZEDIAG_ORIG
35 DOUBLE PRECISION DIAG_ORIG(SIZEDIAG_ORIG)
36 DOUBLE PRECISION GW_FACTCUMUL
37 INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV
38 INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK
39 INTEGER, intent(inout) :: NNEGW, NB22T2W, NBTINYW
40 INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW
41 DOUBLE PRECISION, intent(inout) :: DET_MANTW
42 INTEGER TIPIV( NASS2 )
43 INTEGER PIVSIZ,LPIV
44 INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR
45 LOGICAL, intent(in) :: LR_ACTIVATED
46 INTEGER, intent(inout) :: Inextpiv
47 LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT
48 INTEGER(8) :: LA
49 DOUBLE PRECISION A(LA)
50 DOUBLE PRECISION UU, UULOC, SEUIL
51 DOUBLE PRECISION CSEUIL
52 INTEGER IW(LIW)
53 INTEGER IOLDPS
54 INTEGER(8) :: POSELT
55 INTEGER KEEP(500)
56 INTEGER(8) KEEP8(150)
57 INTEGER LPN_LIST
58 INTEGER PIVNUL_LIST(LPN_LIST)
59 DOUBLE PRECISION DKEEP(230)
60 INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk
61 INTEGER PP_LastPIVRPTRIndexFilled
62 include 'mpif.h'
63 INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ
64 INTEGER JMAX
65 INTEGER :: IPIVNUL, HF
66 DOUBLE PRECISION RMAX,AMAX,TMAX,RMAX_NORELAX,MAX_PREV_in_PARPIV
67 DOUBLE PRECISION MAXPIV, ABS_PIVOT
68 DOUBLE PRECISION RMAX_NOSLAVE, TMAX_NOSLAVE
69 DOUBLE PRECISION PIVOT,DETPIV
70 DOUBLE PRECISION ABSDETPIV
71 include 'mumps_headers.h'
72 INTEGER(8) :: APOSMAX, APOSROW
73 INTEGER(8) :: APOS
74 INTEGER(8) :: J1, J2, JJ, KK
75 DOUBLE PRECISION :: GROWTH, RSWOP
76 DOUBLE PRECISION :: UULOCM1
77 INTEGER :: LDAFS
78 INTEGER(8) :: LDAFS8
79 DOUBLE PRECISION, PARAMETER :: RZERO = 0.0d0
80 DOUBLE PRECISION, PARAMETER :: RONE = 1.0d0
81 DOUBLE PRECISION ZERO, ONE
82 parameter( zero = 0.0d0 )
83 parameter( one = 1.0d0 )
84 DOUBLE PRECISION PIVNUL, VALTMP
85 DOUBLE PRECISION FIXA
86 INTEGER NPIV,IPIV,K219
87 INTEGER NPIVP1,ILOC,K,J
88 INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT
89 INTRINSIC max
90 INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L
91 DOUBLE PRECISION GW_FACT
92 gw_fact = rone
93 amax = rzero
94 rmax = rzero
95 tmax = rzero
96 rmax_noslave = rzero
97 pivot = one
98 hf = 6 + iw(ioldps+5+keep(ixsz)) + keep(ixsz)
99 k206 = keep(206)
100 pivnul = dkeep(1)
101 fixa = dkeep(2)
102 cseuil = seuil
103 ldafs = nass
104 ldafs8 = int(ldafs,8)
105 IF ((keep(50).NE.1) .AND. ooc_effective_on_front) THEN
106 CALL dmumps_get_ooc_perm_ptr(typef_l, nbpanels_l,
107 & i_pivrptr, i_pivr,
108 & ioldps+2*nfront+6+iw(ioldps+5+keep(ixsz))
109 & +keep(ixsz),
110 & iw, liw)
111 ENDIF
112 uuloc = uu
113 k219 = keep(219)
114 IF (uuloc.GT.rzero) THEN
115 uulocm1 = rone/uuloc
116 ELSE
117 k219=0
118 uulocm1 = rone
119 ENDIF
120 IF (k219.LT.2) gw_factcumul = rone
121 pivsiz = 1
122 npiv = iw(ioldps+1+keep(ixsz))
123 npivp1 = npiv + 1
124 iloc = npivp1 - ibeg_block_to_send + 1
125 tipiv( iloc ) = iloc
126 aposmax = poselt+ldafs8*ldafs8-1_8
127 IF(inopv .EQ. -1) THEN
128 apos = poselt + ldafs8*int(npivp1-1,8) + int(npiv,8)
129 pospv1 = apos
130 abs_pivot = abs(pivot)
131 CALL dmumps_update_minmax_pivot
132 & ( abs_pivot,
133 & dkeep, keep, .true.)
134 IF(abs_pivot.LT.seuil) THEN
135 IF(dble(a(apos)) .GE. rzero) THEN
136 a(apos) = cseuil
137 ELSE
138 a(apos) = -cseuil
139 nnegw = nnegw+1
140 ENDIF
141 nbtinyw = nbtinyw + 1
142 ELSE IF (keep(258) .NE.0 ) THEN
143 CALL dmumps_updatedeter( a(apos), det_mantw, det_expw )
144 ENDIF
145 IF ((keep(50).NE.1) .AND. ooc_effective_on_front) THEN
146 CALL dmumps_store_perminfo( iw(i_pivrptr), nbpanels_l,
147 & iw(i_pivr), nass, npivp1, npivp1,
148 & pp_lastpanelondisk,
149 & pp_lastpivrptrindexfilled)
150 ENDIF
151 GO TO 420
152 ENDIF
153 inopv = 0
154 IF ((k219.GE.2).AND.(npivp1.EQ.1)) THEN
155 gw_factcumul = rone
156 IF (k219.EQ.3) THEN
157 DO ipiv=1,nass
158 diag_orig(ipiv) = abs(a(poselt +
159 & (ldafs8+1_8)*int(ipiv-1,8)))
160 ENDDO
161 ELSE IF (k219.GE.4) THEN
162 diag_orig = rzero
163 DO ipiv=1,nass
164 apos = poselt + ldafs8*int(ipiv-1,8)
165 pospv1 = apos + int(ipiv - 1,8)
166 diag_orig(ipiv) = max( abs(a(pospv1)), diag_orig(ipiv) )
167 DO j=ipiv+1,nass
168 diag_orig(ipiv) = max( abs(a(pospv1)), diag_orig(ipiv) )
169 diag_orig(ipiv+j-ipiv) = max( abs(a(pospv1)),
170 & diag_orig(ipiv+j-ipiv) )
171 pospv1 = pospv1 + ldafs8
172 ENDDO
173 ENDDO
174 ENDIF
175 ENDIF
176 ishift = 0
177 ipiv_end = iend_block
178 IF (k206.GE.1) THEN
179 IF (inextpiv.GT.npivp1.AND.inextpiv.LE.iend_block) THEN
180 ishift = inextpiv - npivp1
181 ENDIF
182 IF ( k206.EQ.1
183 & .OR. (k206 .GT.1 .AND. iend_block.EQ.iend_blr) ) THEN
184 ipiv_end = iend_block + ishift
185 ENDIF
186 ENDIF
187 DO 460 ipiv_shift = npivp1+ishift, ipiv_end
188 IF (ipiv_shift .LE. iend_block) THEN
189 ipiv=ipiv_shift
190 ELSE
191 ipiv = ipiv_shift-iend_block-1+npivp1
192 IF (ibeg_block.EQ.npivp1) THEN
193 EXIT
194 ENDIF
195 ENDIF
196 apos = poselt + ldafs8*int(ipiv-1,8) + int(npiv,8)
197 pospv1 = apos + int(ipiv - npivp1,8)
198 pivot = a(pospv1)
199 abs_pivot = abs(pivot)
200 IF (uuloc.EQ.rzero.OR.pivot_option.EQ.0) THEN
201 IF(abs_pivot.LT.seuil) THEN
202 CALL dmumps_update_minmax_pivot
203 & ( abs_pivot,
204 & dkeep, keep, .true.)
205 IF(dble(pivot) .GE. rzero) THEN
206 a(pospv1) = cseuil
207 ELSE
208 a(pospv1) = -cseuil
209 nnegw = nnegw+1
210 ENDIF
211 nbtinyw = nbtinyw + 1
212 ELSE IF (abs_pivot.EQ.rzero) THEN
213 GO TO 630
214 ELSE
215 IF (pivot.LT.rzero) nnegw = nnegw+1
216 CALL dmumps_update_minmax_pivot
217 & ( abs_pivot, dkeep, keep, .false.)
218 IF (keep(258) .NE. 0) THEN
219 CALL dmumps_updatedeter(pivot, det_mantw, det_expw )
220 ENDIF
221 ENDIF
222 GO TO 420
223 ENDIF
224 amax = -rone
225 jmax = 0
226 j1 = apos
227 j2 = pospv1 - 1_8
228 DO jj=j1,j2
229 IF(abs(a(jj)) .GT. amax) THEN
230 amax = abs(a(jj))
231 jmax = ipiv - int(pospv1-jj)
232 ENDIF
233 ENDDO
234 j1 = pospv1 + ldafs8
235 DO j=1, iend_block - ipiv
236 IF(abs(a(j1)) .GT. amax) THEN
237 amax = abs(a(j1))
238 jmax = ipiv + j
239 ENDIF
240 j1 = j1 + ldafs8
241 ENDDO
242 rmax_noslave = rzero
243 IF (pivot_option.EQ.2) THEN
244 DO j=1,nass - iend_block
245 rmax_noslave = max(abs(a(j1+ldafs8*int(j-1,8))),
246 & rmax_noslave)
247 ENDDO
248 ENDIF
249 IF (k219.NE.0) THEN
250 rmax_norelax = dble(a(aposmax+int(ipiv,8)))
251 rmax = rmax_norelax
252 IF (k219.GE.2) THEN
253 IF (abs_pivot.NE.rzero.AND.
254 & abs_pivot.GE.uuloc*max(rmax,rmax_noslave,amax))
255 & THEN
256 growth = rone
257 IF (k219.EQ.3) THEN
258 IF (diag_orig(ipiv).EQ.rzero) THEN
259 diag_orig(ipiv) = abs_pivot
260 ELSE
261 growth = abs_pivot / diag_orig(ipiv)
262 ENDIF
263 ELSE IF (k219.GE.4) THEN
264 IF (diag_orig(ipiv).EQ.rzero) THEN
265 diag_orig(ipiv) = max(amax,rmax_noslave)
266 ELSE
267 growth = max(abs_pivot,amax,rmax_noslave)/
268 & diag_orig(ipiv)
269 ENDIF
270 ENDIF
271 rmax = rmax*max(growth,gw_factcumul)
272 ENDIF
273 ENDIF
274 ELSE
275 rmax = rzero
276 rmax_norelax = rzero
277 ENDIF
278 rmax_noslave = max(rmax_norelax,rmax_noslave)
279 rmax = max(rmax,rmax_noslave)
280 IF (max(amax,rmax,abs_pivot).LE.pivnul) THEN
281 IF ((k219.NE.0)
282 & .AND.(k219.NE.-1)
283 & .AND.(rmax_norelax.LT.0)
284 & .AND.(ipiv.GT.1)) THEN
285 max_prev_in_parpiv = rzero
286 DO jj=1,ipiv-1
287 max_prev_in_parpiv= max( max_prev_in_parpiv,
288 & dble(a(aposmax+int(jj,8))) )
289 ENDDO
290 IF (max_prev_in_parpiv.GT.pivnul) THEN
291 aposrow = poselt + ldafs8*int(ipiv-1,8)
292 DO jj=1,ipiv-1
293 IF (abs(a(aposrow+jj-1)).GT.pivnul) THEN
294 GOTO 460
295 ENDIF
296 ENDDO
297 ENDIF
298 ENDIF
299 CALL dmumps_update_minmax_pivot
300 & ( abs(a(pospv1)), dkeep, keep, .true.)
301 keep(109) = keep(109) + 1
302 ipivnul = keep(109)
303 pivnul_list(ipivnul) = iw( ioldps+hf+npiv+ipiv-npivp1 )
304 IF (dble(fixa).GT.rzero) THEN
305 IF(dble(pivot) .GE. rzero) THEN
306 a(pospv1) = fixa
307 ELSE
308 a(pospv1) = -fixa
309 ENDIF
310 ELSE
311 j1 = apos
312 j2 = pospv1 - 1_8
313 DO jj=j1,j2
314 a(jj) = zero
315 ENDDO
316 DO j=1, nass-ipiv
317 a(pospv1+int(j,8)*ldafs8) = zero
318 ENDDO
319 valtmp = max(1.0d10*rmax, sqrt(huge(rmax))/1.0d8)
320 a(pospv1) = valtmp
321 ENDIF
322 pivot = a(pospv1)
323 abs_pivot = abs(pivot)
324 GO TO 415
325 ENDIF
326 rmax = max(rmax,abs(rmax_norelax))
327 IF (abs_pivot.GE.uuloc*max(rmax,amax)
328 & .AND. abs_pivot .GT. max(seuil, tiny(rmax))) THEN
329 IF (a(pospv1).LT.rzero) nnegw = nnegw+1
330 CALL dmumps_update_minmax_pivot
331 & ( abs_pivot, dkeep, keep, .false.)
332 IF (keep(258) .NE.0 ) THEN
333 CALL dmumps_updatedeter(pivot, det_mantw, det_expw )
334 ENDIF
335 GO TO 415
336 END IF
337 IF (npivp1.EQ.iend_block) THEN
338 GOTO 460
339 ELSE IF (jmax .EQ.0) THEN
340 GOTO 460
341 ENDIF
342 IF (max(abs(pivot),rmax,amax).LE.tiny(rmax)) THEN
343 GOTO 460
344 ENDIF
345 IF (rmax_noslave.LT.amax) THEN
346 j1 = apos
347 j2 = pospv1 - 1_8
348 DO jj=j1,j2
349 IF(int(pospv1-jj) .NE. ipiv-jmax) THEN
350 rmax_noslave = max(rmax_noslave,abs(a(jj)))
351 ENDIF
352 ENDDO
353 DO j=1,nass-ipiv
354 IF(ipiv+j .NE. jmax) THEN
355 rmax_noslave = max(abs(a(pospv1+ldafs8*int(j,8))),
356 & rmax_noslave)
357 ENDIF
358 ENDDO
359 rmax = max(rmax, rmax_noslave)
360 ENDIF
361 aposj = poselt + int(jmax-1,8)*ldafs8 + int(npiv,8)
362 pospv2 = aposj + int(jmax - npivp1,8)
363 IF (ipiv.LT.jmax) THEN
364 offdag = aposj + int(ipiv - npivp1,8)
365 ELSE
366 offdag = apos + int(jmax - npivp1,8)
367 END IF
368 tmax_noslave = rzero
369 IF(jmax .LT. ipiv) THEN
370 jj = pospv2
371 DO k = 1, nass-jmax
372 jj = jj+ldafs8
373 IF (jmax+k.NE.ipiv) THEN
374 tmax_noslave=max(tmax_noslave,abs(a(jj)))
375 ENDIF
376 ENDDO
377 DO kk = aposj, pospv2-1_8
378 tmax_noslave = max(tmax_noslave,abs(a(kk)))
379 ENDDO
380 ELSE
381 jj = pospv2
382 DO k = 1, nass-jmax
383 jj = jj+ldafs8
384 tmax_noslave=max(tmax_noslave,abs(a(jj)))
385 ENDDO
386 DO kk = aposj, pospv2 - 1_8
387 IF (kk.NE.offdag) THEN
388 tmax_noslave = max(tmax_noslave,abs(a(kk)))
389 ENDIF
390 ENDDO
391 ENDIF
392 IF (k219.NE.0) THEN
393 tmax = max(seuil*uulocm1,
394 & abs(dble(a(aposmax+int(jmax,8))))
395 & )
396 ELSE
397 tmax = seuil*uulocm1
398 ENDIF
399 IF (k219.GE.2) THEN
400 growth = rone
401 IF (k219.EQ.3) THEN
402 IF (diag_orig(jmax).EQ.rzero) THEN
403 diag_orig(jmax) = abs(a(pospv2))
404 ELSE
405 growth = abs(a(pospv2))/diag_orig(jmax)
406 ENDIF
407 ELSE IF (k219.EQ.4) THEN
408 IF (diag_orig(jmax).EQ.rzero) THEN
409 diag_orig(jmax)=max(abs(a(pospv2)),amax,tmax_noslave)
410 ELSE
411 growth = max(abs(a(pospv2)),amax,tmax_noslave)
412 & / diag_orig(jmax)
413 ENDIF
414 ENDIF
415 tmax = tmax*max(growth,gw_factcumul)
416 ENDIF
417 tmax = max(tmax,tmax_noslave)
418 detpiv = a(pospv1)*a(pospv2) - a(offdag)*a(offdag)
419 absdetpiv = abs(detpiv)
420 IF (seuil.GT.rzero) THEN
421 IF (sqrt(absdetpiv) .LE. seuil ) THEN
422 GOTO 460
423 ENDIF
424 ENDIF
425 maxpiv = max(abs(a(pospv1)),abs(a(pospv2)))
426 IF (maxpiv.EQ.rzero) maxpiv = rone
427 IF ((abs(a(pospv2))*rmax+amax*tmax)*uuloc.GT.
428 & absdetpiv .OR. absdetpiv .EQ. rzero) THEN
429 GO TO 460
430 ENDIF
431 IF ((abs(a(pospv1))*tmax+amax*rmax)*uuloc.GT.
432 & absdetpiv .OR. absdetpiv .EQ. rzero) THEN
433 GO TO 460
434 ENDIF
435 CALL dmumps_update_minmax_pivot
436 & ( sqrt(abs(detpiv)),
437 & dkeep, keep, .false.)
438 IF (keep(258).NE.0) THEN
439 CALL dmumps_updatedeter(detpiv, det_mantw, det_expw )
440 ENDIF
441 pivsiz = 2
442 nb22t2w = nb22t2w+1
443 IF(detpiv .LT. rzero) THEN
444 nnegw = nnegw+1
445 ELSE IF(a(pospv2) .LT. rzero) THEN
446 nnegw = nnegw+2
447 ENDIF
448 415 CONTINUE
449 IF (k206.GE.1) THEN
450 inextpiv = max(npivp1+pivsiz, ipiv+1)
451 ENDIF
452 DO k=1,pivsiz
453 IF (pivsiz .EQ. 2 ) THEN
454 IF (k==1) THEN
455 lpiv = min(ipiv, jmax)
456 tipiv(iloc) = -(lpiv - ibeg_block_to_send + 1)
457 ELSE
458 lpiv = max(ipiv, jmax)
459 tipiv(iloc+1) = -(lpiv - ibeg_block_to_send + 1)
460 ENDIF
461 ELSE
462 lpiv = ipiv
463 tipiv(iloc) = ipiv - ibeg_block_to_send + 1
464 ENDIF
465 IF (lpiv.EQ.npivp1) THEN
466 GOTO 416
467 ENDIF
468 keep8(80) = keep8(80)+1
469 CALL dmumps_swap_ldlt( a, la, iw, liw,
470 & ioldps, npivp1, lpiv, poselt, nass,
471 & ldafs, nfront, 2, k219, keep(50),
472 & keep(ixsz), ibeg_block_to_send )
473 IF (k219.GE.3) THEN
474 rswop = diag_orig(lpiv)
475 diag_orig(lpiv) = diag_orig(npivp1)
476 diag_orig(npivp1) = rswop
477 ENDIF
478 416 CONTINUE
479 IF ((keep(50).NE.1) .AND. ooc_effective_on_front) THEN
480 CALL dmumps_store_perminfo(
481 & iw(i_pivrptr), nbpanels_l,
482 & iw(i_pivr), nass, npivp1, lpiv, pp_lastpanelondisk,
483 & pp_lastpivrptrindexfilled)
484 ENDIF
485 npivp1 = npivp1+1
486 ENDDO
487 IF(pivsiz .EQ. 2) THEN
488 a(poselt+ldafs8*int(npiv,8)+int(npiv+1,8)) = detpiv
489 ENDIF
490 GOTO 420
491 460 CONTINUE
492 IF (k206 .GE. 1) THEN
493 inextpiv=iend_block+1
494 ENDIF
495 IF (iend_block.EQ.nass) THEN
496 inopv = 1
497 ELSE
498 inopv = 2
499 ENDIF
500 GO TO 420
501 630 CONTINUE
502 iflag = -10
503 420 CONTINUE
504 IF (k219.GE.2) THEN
505 IF(inopv .EQ. 0) THEN
506 IF(pivsiz .EQ. 1) THEN
507 gw_fact = max(amax,rmax_noslave)/abs_pivot
508 ELSE IF(pivsiz .EQ. 2) THEN
509 gw_fact = max(
510 & (abs(a(pospv2))*rmax_noslave+amax*tmax_noslave)
511 & / absdetpiv ,
512 & (abs(a(pospv1))*tmax_noslave+amax*rmax_noslave)
513 & / absdetpiv
514 & )
515 ENDIF
516 gw_fact = min(gw_fact, uulocm1)
517 gw_factcumul = max(gw_fact,gw_factcumul)
518 ENDIF
519 ENDIF
520 RETURN
dmumps_updatedeter
subroutine dmumps_updatedeter(piv, deter, nexp)
Definition dfac_determinant.F:15
dmumps_get_ooc_perm_ptr
subroutine dmumps_get_ooc_perm_ptr(typef, nbpanels, i_pivptr, i_piv, ipos, iw, liw)
Definition dooc_panel_piv.F:133
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
dmumps_fac_front_aux_m
Definition dfac_front_aux.F:14
dmumps_fac_front_aux_m::dmumps_store_perminfo
subroutine dmumps_store_perminfo(pivrptr, nbpanels, pivr, nass, k, p, lastpanelondisk, lastpivrptrindexfilled)
Definition dfac_front_aux.F:2450
dmumps_fac_front_aux_m::dmumps_swap_ldlt
subroutine dmumps_swap_ldlt(a, la, iw, liw, ioldps, npivp1, ipiv, poselt, lastrow2swap, lda, nfront, level, parpiv, k50, xsize, ibeg_block_to_send)
Definition dfac_front_aux.F:2037
dmumps_fac_front_aux_m::dmumps_update_minmax_pivot
subroutine dmumps_update_minmax_pivot(diag, dkeep, keep, nullpivot)
Definition dfac_front_aux.F:2474
mumps_ooc_common
Definition mumps_ooc_common.F:14
mumps_ooc_common::typef_l
integer, public typef_l
Definition mumps_ooc_common.F:18

◆ dmumps_fac_mq_ldlt_niv2()

subroutine dmumps_fac_front_type2_aux_m::dmumps_fac_mq_ldlt_niv2 ( integer, intent(in) iend_block,
integer, intent(in) nass,
integer, intent(in) npiv,
integer, intent(in) inode,
double precision, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer, intent(in) ldafs,
integer(8), intent(in) poselt,
integer, intent(out) ifinb,
integer, intent(in) pivsiz,
integer, intent(in) k219,
integer, intent(in) pivot_option,
integer, intent(in) iend_blr,
logical, intent(in) lr_activated )

Definition at line 522 of file dfac_front_type2_aux.F.

527 IMPLICIT NONE
528 INTEGER(8), intent(in) :: LA, POSELT
529 INTEGER, intent(in) :: K219
530 DOUBLE PRECISION, intent(inout) :: A(LA)
531 INTEGER, intent(in) :: IEND_BLOCK
532 INTEGER, intent(in) :: NPIV, PIVSIZ
533 INTEGER, intent(in) :: NASS,INODE,LDAFS
534 INTEGER, intent(out) :: IFINB
535 INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR
536 LOGICAL, intent(in) :: LR_ACTIVATED
537 DOUBLE PRECISION VALPIV
538 INTEGER NCB1
539 INTEGER(8) :: APOS, APOSMAX
540 INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS
541 INTEGER(8) :: JJ, K1, K2
542 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD
543 INTEGER(8) :: LDAFS8
544 INTEGER NEL2
545 DOUBLE PRECISION ONE, ALPHA
546 DOUBLE PRECISION ZERO
547 INTEGER NPIV_NEW, I
548 INTEGER(8) :: IBEG, IEND, IROW, J8
549 INTEGER :: J2
550 DOUBLE PRECISION SWOP,DETPIV,MULT1,MULT2, A11, A22, A12
551 parameter(one = 1.0d0, alpha=-1.0d0)
552 parameter(zero=0.0d0)
553 include 'mumps_headers.h'
554 ldafs8 = int(ldafs,8)
555 npiv_new = npiv + pivsiz
556 ifinb = 0
557 nel2 = iend_block - npiv_new
558 IF (nel2.EQ.0) THEN
559 IF (iend_block.EQ.nass) THEN
560 ifinb = -1
561 ELSE
562 ifinb = 1
563 ENDIF
564 ENDIF
565 IF(pivsiz .EQ. 1) THEN
566 apos = poselt + int(npiv,8)*(ldafs8 + 1_8)
567 valpiv = one/a(apos)
568 lpos = apos + ldafs8
569 DO i = 1, nel2
570 k1pos = lpos + int(i-1,8)*ldafs8
571 a(apos+int(i,8))=a(k1pos)
572 a(k1pos) = a(k1pos) * valpiv
573 DO jj=1_8, int(i,8)
574 a(k1pos+jj)=a(k1pos+jj) - a(k1pos) * a(apos+jj)
575 ENDDO
576 ENDDO
577 IF (pivot_option.EQ.2) THEN
578 ncb1 = nass - iend_block
579 ELSE
580 ncb1 = iend_blr - iend_block
581 ENDIF
582!$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300)
583 DO i=nel2+1, nel2 + ncb1
584 k1pos = lpos+ int(i-1,8)*ldafs8
585 a(apos+int(i,8))=a(k1pos)
586 a(k1pos) = a(k1pos) * valpiv
587 DO jj = 1_8, int(nel2,8)
588 a(k1pos+jj)=a(k1pos+jj) - a(k1pos) * a(apos+jj)
589 ENDDO
590 ENDDO
591!$OMP END PARALLEL DO
592 IF (k219.eq. -1) THEN
593 aposmax = poselt + int(nass,8) * ldafs8 + int(npiv,8)
594 a(aposmax) = a(aposmax) * abs(valpiv)
595 DO j8 = 1_8, int(nel2+ncb1,8)
596 a(aposmax+j8) = a(aposmax+j8) +
597 & a(aposmax) * abs(a(apos+j8))
598 ENDDO
599 ENDIF
600 ELSE
601 pospv1 = poselt + int(npiv,8)*(ldafs8 + 1_8)
602 pospv2 = pospv1+ldafs8+1_8
603 offdag_old = pospv2 - 1_8
604 offdag = pospv1+1_8
605 swop = a(pospv2)
606 detpiv = a(offdag)
607 a22 = a(pospv1)/detpiv
608 a11 = swop/detpiv
609 a12 = -a(offdag_old)/detpiv
610 a(offdag) = a(offdag_old)
611 a(offdag_old) = zero
612 lpos1 = pospv2 + ldafs8 - 1_8
613 lpos2 = lpos1 + 1_8
614 CALL dcopy(nass-npiv_new, a(lpos1), ldafs, a(pospv1+2_8), 1)
615 CALL dcopy(nass-npiv_new, a(lpos2), ldafs, a(pospv2+1_8), 1)
616 jj = pospv2 + int(nass-1,8)
617 ibeg = jj + 2_8
618 iend = ibeg
619 DO j2 = 1,nel2
620 k1 = jj
621 k2 = jj+1_8
622 mult1 = - (a11*a(k1)+a12*a(k2))
623 mult2 = - (a12*a(k1)+a22*a(k2))
624 k1 = pospv1+2_8
625 k2 = pospv2+1_8
626 DO irow = ibeg,iend
627 a(irow) = a(irow) + mult1*a(k1) + mult2*a(k2)
628 k1 = k1 + 1_8
629 k2 = k2 + 1_8
630 ENDDO
631 a(jj) = -mult1
632 a(jj+1_8) = -mult2
633 ibeg = ibeg + int(nass,8)
634 iend = iend + int(nass + 1,8)
635 jj = jj+int(nass,8)
636 ENDDO
637 iend = iend-1_8
638 DO j2 = iend_block+1,nass
639 k1 = jj
640 k2 = jj+1_8
641 mult1 = - (a11*a(k1)+a12*a(k2))
642 mult2 = - (a12*a(k1)+a22*a(k2))
643 k1 = pospv1+2_8
644 k2 = pospv2+1_8
645 DO irow = ibeg,iend
646 a(irow) = a(irow) + mult1*a(k1) + mult2*a(k2)
647 k1 = k1 + 1_8
648 k2 = k2 + 1_8
649 ENDDO
650 a(jj) = -mult1
651 a(jj+1_8) = -mult2
652 ibeg = ibeg + int(nass,8)
653 iend = iend + int(nass,8)
654 jj = jj+int(nass,8)
655 ENDDO
656 IF (k219.eq. -1) THEN
657 aposmax = poselt + int(nass,8) * ldafs8 + int(npiv,8)
658 jj = aposmax
659 k1 = jj
660 k2 = jj + 1_8
661 mult1 = abs(a11)*a(k1)+abs(a12)*a(k2)
662 mult2 = abs(a12)*a(k1)+abs(a22)*a(k2)
663 k1 = pospv1 + 2_8
664 k2 = pospv2 + 1_8
665 ibeg = aposmax + 2_8
666 iend = aposmax + 1_8 + nass - npiv_new
667 DO irow = ibeg, iend
668 a(irow) = a(irow) + mult1*abs(a(k1)) + mult2*abs(a(k2))
669 k1 = k1 + 1_8
670 k2 = k2 + 1_8
671 ENDDO
672 a(jj) = mult1
673 a(jj+1_8) = mult2
674 ENDIF
675 ENDIF
676 RETURN
alpha
#define alpha
Definition eval.h:35
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82

◆ dmumps_send_factored_blk()

subroutine dmumps_fac_front_type2_aux_m::dmumps_send_factored_blk ( integer comm_load,
integer ass_irecv,
integer n,
integer inode,
integer fpere,
integer, dimension(liw) iw,
integer liw,
integer ioldps,
integer(8) poselt,
double precision, dimension(la) a,
integer(8) la,
integer lda_fs,
integer ibeg_block,
integer iend,
integer, dimension(lpiv) tipiv,
integer lpiv,
logical lastbl,
integer nb_bloc_fac,
integer comm,
integer myid,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer nbfin,
integer leaf,
integer iflag,
integer ierror,
integer, dimension(lpool) ipool,
integer lpool,
integer slavef,
integer(8) posfac,
integer iwpos,
integer iwposcb,
integer(8) iptrlu,
integer(8) lrlu,
integer(8) lrlus,
integer comp,
integer, dimension(keep(28)) ptrist,
integer(8), dimension (keep(28)) ptrast,
integer, dimension(keep(28)) ptlust_s,
integer(8), dimension (keep(28)) ptrfac,
integer, dimension(n) step,
integer, dimension(keep(28)) pimaster,
integer(8), dimension(keep(28)) pamaster,
integer, dimension(keep(28)) nstk_s,
integer, dimension(n) perm,
integer, dimension(keep(28)) procnode_steps,
type (dmumps_root_struc) root,
double precision opassw,
double precision opeliw,
integer, dimension(n+keep(253)) itloc,
double precision, dimension(keep(255)) rhs_mumps,
integer, dimension(n) fils,
integer, dimension( keep(28) ) dad,
integer(8), dimension(lptrar), intent(in) ptrarw,
integer(8), dimension(lptrar), intent(in) ptraiw,
integer, dimension(keep8(27)) intarr,
double precision, dimension(keep8(26)) dblarr,
integer, dimension(60) icntl,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230) dkeep,
integer, dimension( keep(28) ) nd,
integer, dimension( keep(28) ) frere,
integer lptrar,
integer nelt,
integer, dimension( n+1 ) frtptr,
integer, dimension( nelt ) frtelt,
integer, dimension(keep(71)) istep_to_iniv2,
integer, dimension(slavef+2,max(1,keep(56))) tab_pos_in_pere,
integer nelim,
logical, intent(in) lr_activated,
integer, intent(in) npartsass,
integer, intent(in) current_blr_panel,
type (lrb_type), dimension(:) blr_loru,
integer, dimension(n), intent(in) lrgroups )

Definition at line 678 of file dfac_front_type2_aux.F.

696 USE dmumps_buf
697 USE dmumps_load
698 USE dmumps_lr_type
699 USE dmumps_struc_def, ONLY : dmumps_root_struc
700 IMPLICIT NONE
701 include 'mpif.h'
702 TYPE (DMUMPS_ROOT_STRUC) :: root
703 INTEGER COMM_LOAD, ASS_IRECV
704 INTEGER N, INODE, FPERE, LIW, IBEG_BLOCK, IEND, LPIV,
705 & IOLDPS, LDA_FS, NB_BLOC_FAC
706 INTEGER(8) :: POSELT, LA
707 INTEGER IW(LIW), TIPIV(LPIV)
708 LOGICAL LASTBL
709 DOUBLE PRECISION A(LA)
710 INTEGER COMM, MYID, LBUFR, LBUFR_BYTES
711 INTEGER NELT, LPTRAR
712 INTEGER FRTPTR( N+1 ), FRTELT( NELT )
713 INTEGER KEEP(500)
714 INTEGER(8) KEEP8(150)
715 DOUBLE PRECISION DKEEP(230)
716 INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL,
717 & SLAVEF, ICNTL(60)
718 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS
719 INTEGER IWPOS, IWPOSCB, COMP
720 INTEGER BUFR( LBUFR ), IPOOL(LPOOL),
721 & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ),
722 & ND( KEEP(28) ), FRERE( KEEP(28) )
723 INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR)
724 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
725 INTEGER(8) :: PTRAST (KEEP(28))
726 INTEGER(8) :: PTRFAC (KEEP(28))
727 INTEGER(8) :: PAMASTER(KEEP(28))
728 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)),
729 & STEP(N), PIMASTER(KEEP(28)),
730 & NSTK_S(KEEP(28)),
731 & PERM(N), PROCNODE_STEPS(KEEP(28))
732 INTEGER ISTEP_TO_INIV2(KEEP(71)),
733 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
734 DOUBLE PRECISION OPASSW, OPELIW
735 DOUBLE PRECISION DBLARR(KEEP8(26))
736 INTEGER INTARR(KEEP8(27))
737 LOGICAL, intent(in) :: LR_ACTIVATED
738 TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU
739 INTEGER, intent(in) :: LRGROUPS(N)
740 INTEGER :: NELIM
741 INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL
742 include 'mumps_headers.h'
743 INTEGER(8) :: APOS, LREQA
744 INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH
745 INTEGER IERR, LREQI
746 INTEGER :: STATUS(MPI_STATUS_SIZE)
747 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
748 DOUBLE PRECISION FLOP1,FLOP2
749 LOGICAL COMPRESS_CB
750 compress_cb = ((iw(ioldps+xxlr).EQ.1).OR.
751 & (iw(ioldps+xxlr).EQ.3))
752 nslaves= iw(ioldps+5+keep(ixsz))
753 IF (nslaves.EQ.0) THEN
754 WRITE(6,*) ' ERROR 1 in DMUMPS_SEND_FACTORED_BLK '
755 CALL mumps_abort()
756 ENDIF
757 npiv = iend - ibeg_block + 1
758 ncol = lda_fs - ibeg_block + 1
759 apos = poselt + int(lda_fs,8)*int(ibeg_block-1,8) +
760 & int(ibeg_block - 1,8)
761 IF (ibeg_block > 0) THEN
762 CALL mumps_get_flops_cost( lda_fs, ibeg_block-1, lpiv,
763 & keep(50),2,flop1)
764 ELSE
765 flop1=0.0d0
766 ENDIF
767 CALL mumps_get_flops_cost( lda_fs, iend, lpiv,
768 & keep(50),2,flop2)
769 flop2 = flop1 - flop2
770 CALL dmumps_load_update(1, .false., flop2, keep,keep8)
771 IF ((npiv.GT.0) .OR.
772 & ((npiv.EQ.0).AND.(lastbl))
773 & ) THEN
774 IF ((npiv.EQ.0).AND.(lastbl)) THEN
775 IF (compress_cb) THEN
776 iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
777 compress_cb = .false.
778 ENDIF
779 ENDIF
780 pdest = ioldps + 6 + keep(ixsz)
781 IF (( npiv .NE. 0 ).AND.(keep(50).NE.0)) THEN
782 nb_bloc_fac = nb_bloc_fac + 1
783 END IF
784 ierr = -1
785 DO WHILE (ierr .EQ.-1)
786 width = nslaves
787 CALL dmumps_buf_send_blocfacto( inode, lda_fs, ncol,
788 & npiv, fpere, lastbl, tipiv, a(apos),
789 & iw(pdest), nslaves, keep,
790 & nb_bloc_fac,
791 & nslaves, width, comm,
792 & nelim, npartsass, current_blr_panel,
793 & lr_activated, blr_loru,
794 & ierr )
795 IF (ierr.EQ.-1) THEN
796 blocking = .false.
797 set_irecv = .true.
798 message_received = .false.
799 CALL dmumps_try_recvtreat( comm_load, ass_irecv,
800 & blocking, set_irecv, message_received,
801 & mpi_any_source, mpi_any_tag,
802 & status, bufr, lbufr,
803 & lbufr_bytes,
804 & procnode_steps, posfac, iwpos, iwposcb, iptrlu,
805 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
806 & ptlust_s, ptrfac,
807 & ptrast, step, pimaster, pamaster, nstk_s, comp, iflag,
808 & ierror, comm,
809 & perm,
810 & ipool, lpool, leaf, nbfin, myid, slavef,
811 & root, opassw, opeliw, itloc, rhs_mumps,
812 & fils, dad, ptrarw, ptraiw,
813 & intarr, dblarr, icntl, keep,keep8,dkeep, nd, frere,
814 & lptrar, nelt, frtptr, frtelt,
815 & istep_to_iniv2, tab_pos_in_pere, .true.
816 & , lrgroups
817 & )
818 IF (message_received) THEN
819 poselt = ptrast(step(inode))
820 apos = poselt + int(lda_fs,8)*int(ibeg_block-1,8) +
821 & int(ibeg_block - 1,8)
822 ENDIF
823 IF ( iflag .LT. 0 ) GOTO 500
824 ENDIF
825 ENDDO
826 IF (ierr .EQ. -2 .OR. ierr.EQ.-3 ) THEN
827 IF (ierr.EQ.-2) iflag = -17
828 IF (ierr.EQ.-3) iflag = -20
829 lreqa = int(ncol,8)*int(npiv,8)
830 lreqi = npiv + 6 + 2*nslaves + 2
831 CALL mumps_set_ierror(
832 & int(lreqi,8) * int(keep(34),8) + lreqa * int(keep(35),8),
833 & ierror)
834 GOTO 300
835 ENDIF
836 ENDIF
837 GOTO 500
838 300 CONTINUE
839 CALL dmumps_bdc_error( myid, slavef, comm, keep )
840 500 CONTINUE
841 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
dmumps_bdc_error
subroutine dmumps_bdc_error(myid, slavef, comm, keep)
Definition dbcast_int.F:38
dmumps_try_recvtreat
recursive subroutine dmumps_try_recvtreat(comm_load, ass_irecv, blocking, set_irecv, message_received, msgsou, msgtag, status, bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptlust, ptrfac, ptrast, step, pimaster, pamaster, nstk_s, comp, iflag, ierror, comm, perm, ipool, lpool, leaf, nbfin, myid, slavef root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, nd, frere, lptrar, nelt, frtptr, frtelt istep_to_iniv2, tab_pos_in_pere, stack_right_authorized, lrgroups)
Definition dfac_process_message.F:560
mumps_get_flops_cost
subroutine mumps_get_flops_cost(nfront, npiv, nass, keep50, level, cost)
Definition estim_flops.F:74
dmumps_buf
Definition dmumps_comm_buffer.F:14
dmumps_buf::dmumps_buf_send_blocfacto
subroutine, public dmumps_buf_send_blocfacto(inode, nfront, ncol, npiv, fpere, lastbl, ipiv, val, pdest, ndest, keep, nb_bloc_fac, nslaves_tot, width, comm, nelim, npartsass, current_blr_panel, lr_activated, blr_loru ierr)
Definition dmumps_comm_buffer.F:1824
dmumps_load
Definition dmumps_load.F:14
dmumps_load::myid
integer, save, private myid
Definition dmumps_load.F:57
dmumps_load::dmumps_load_update
subroutine, public dmumps_load_update(check_flops, process_bande, inc_load, keep, keep8)
Definition dmumps_load.F:824
dmumps_lr_type
Definition dlr_type.F:14
dmumps_struc_def
Definition dmumps_struc_def.F:14
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865