OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfac_process_blocfacto_LDLT.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, University of Bordeaux.
8C
9C This version of MUMPS is provided to you free of charge. It is
10C released under the CeCILL-C license
11C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 RECURSIVE SUBROUTINE dmumps_process_sym_blocfacto(
15 & COMM_LOAD, ASS_IRECV,
16 & BUFR, LBUFR,
17 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU,
18 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW,
19 & A, LA, PTRIST, PTRAST, NSTK_S, PERM,
20 & COMP, STEP, PIMASTER, PAMASTER, POSFAC,
21 & MYID, COMM, IFLAG, IERROR, NBFIN,
22 &
23 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW,
24 & ITLOC, RHS_MUMPS, FILS, DAD,
25 & PTRARW, PTRAIW, INTARR, DBLARR,
26 & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS,
27 & LPTRAR, NELT, FRTPTR, FRTELT,
28 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
29 & , LRGROUPS
30 & )
31 USE dmumps_ooc, ONLY : io_block
32 USE mumps_ooc_common, ONLY : typef_l, strat_try_write
33 USE dmumps_load
34 USE dmumps_buf
35 USE dmumps_lr_core
36 USE dmumps_lr_type
37 USE dmumps_lr_stats
38 USE dmumps_fac_lr
39 USE dmumps_ana_lr, ONLY : get_cut
40 USE dmumps_lr_data_m
41 USE dmumps_struc_def, ONLY : dmumps_root_struc
42 USE dmumps_dynamic_memory_m, ONLY : dmumps_dm_set_dynptr
43 USE dmumps_fac_front_aux_m, ONLY : dmumps_get_size_schur_in_front
44!$ USE OMP_LIB
45 IMPLICIT NONE
46 include 'mumps_headers.h'
47 TYPE (dmumps_root_struc) :: root
48 INTEGER icntl( 60 ), keep( 500 )
49 INTEGER(8) keep8(150)
50 DOUBLE PRECISION dkeep(230)
51 INTEGER comm_load, ass_irecv
52 INTEGER lbufr, lbufr_bytes
53 INTEGER bufr( lbufr )
54 INTEGER n, slavef, iwpos, iwposcb, liw
55 INTEGER(8) iptrlu, lrlu, lrlus, la, posfac
56 INTEGER comp
57 INTEGER iflag, ierror, nbfin, msgsou
58 INTEGER procnode_steps(keep(28)), ptrist(keep(28)),
59 & nstk_s(keep(28))
60 INTEGER(8) ptrast(keep(28)), ptrfac(keep(28)), pamaster(keep(28))
61 INTEGER PERM(n), step(n),
62 & pimaster(keep(28))
63 INTEGER iw( liw )
64 DOUBLE PRECISION a( la )
65 INTEGER, intent(in) :: lrgroups(n)
66 INTEGER lptrar, nelt
67 INTEGER frtptr( n+1 ), frtelt( nelt )
68 INTEGER comm, myid
69 INTEGER ptlust_s(keep(28)),
70 & itloc(n+keep(253)), fils(n), dad(keep(28)), nd(keep(28))
71 DOUBLE PRECISION :: rhs_mumps(keep(255))
72 INTEGER(8), INTENT(IN) :: ptraiw( lptrar ), ptrarw( lptrar )
73 INTEGER frere_steps(keep(28))
74 DOUBLE PRECISION opassw, opeliw
75 DOUBLE PRECISION flop1
76 INTEGER intarr( keep8(27) )
77 DOUBLE PRECISION dblarr( keep8(26) )
78 INTEGER leaf, lpool
79 INTEGER ipool( lpool )
80 INTEGER istep_to_iniv2(keep(71)),
81 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
82 INTEGER pivi
83 INTEGER (8) pospv1,pospv2,offdag,lpos1
84 INTEGER j2
85 DOUBLE PRECISION mult1,mult2, a11, detpiv, a22, a12
86 INTEGER :: nfs4father, nvschur_k253, nslaves_l, irow_l
87 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: m_array
88 INTEGER nbrowsinf
89 include 'mpif.h'
90 include 'mumps_tags.h'
91 INTEGER :: status(mpi_status_size)
92 INTEGER lp
93 INTEGER inode, position, npiv, ierr
94 INTEGER ncol
95 INTEGER(8) :: posblocfacto
96 INTEGER :: ld_blocfacto
97 INTEGER(8) :: la_blocfacto
98 INTEGER(8) :: la_ptr
99 INTEGER(8) :: poselt
100 DOUBLE PRECISION, DIMENSION(:), POINTER :: a_ptr
101 INTEGER ioldps, lcont1, nass1, nrow1, ncol1, npiv1
102 INTEGER nslav1, hs, isw, dest
103 INTEGER ICT11
104 INTEGER(8) lpos, lpos2, dpos, upos
105 INTEGER (8) ipos, KPOS
106 INTEGER i, ipiv, fpere, nslaves_tot,
107 & nslaves_follow, nb_bloc_fac
108 INTEGER iposk, jposk, npivsent, block, irow, blsize
109 INTEGER allocok, to_update_cpt_end
110 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: uip21k
111 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: dyn_blocfacto
112 INTEGER, DIMENSION(:), ALLOCATABLE :: list_slaves_follow
113 INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO
114 LOGICAL lastbl
115 INTEGER src_descband
116 LOGICAL blocking, set_irecv, message_received
117 DOUBLE PRECISION one,alpha
118 parameter(one = 1.0d0, alpha=-1.0d0)
119 INTEGER liwfac, strat, nextpivdummy
120 TYPE(io_block) :: monbloc
121 LOGICAL last_call
122 INTEGER lrelay_info
123 LOGICAL counter_was_huge
124 INTEGER to_update_cpt_recur
125 INTEGER :: lr_activated_int
126 LOGICAL :: lr_activated, compress_cb, compress_panel
127 LOGICAL :: dynamic_alloc
128 LOGICAL oocwrite_compatible_with_blr
129 INTEGER :: xsize, current_blr, nslaves_prec, info_tmp(2)
130 INTEGER :: nelim, nb_blr_lm, nb_blr_ls,
131 & maxi_cluster_lm, maxi_cluster_ls, maxi_cluster,
132 & npartsass, npartscb, npartscb_col, npartsass_col,
133 & nb_blr_col, maxi_cluster_col
134 INTEGER :: npartsass_master, ipanel, nb_accesses_init
135 TYPE (lrb_type), DIMENSION(:), ALLOCATABLE :: blr_lm
136 TYPE (lrb_type), DIMENSION(:), POINTER :: blr_ls
137 TYPE(lrb_type), POINTER, DIMENSION(:,:) :: cb_lrb
138 INTEGER, POINTER, DIMENSION(:) :: begs_blr_lm, begs_blr_ls,
139 & begs_blr_col, begs_blr_col_tmp
140 LOGICAL keep_begs_blr_ls, keep_begs_blr_col, keep_blr_ls
141 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: work, tau
142 INTEGER, ALLOCATABLE, DIMENSION(:) :: jpvt
143 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: blocklr
144 DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: rwork
145 INTEGER :: omp_num, lwork
146 INTEGER :: ii,jj, shift
147 INTEGER mumps_procnode
148 EXTERNAL mumps_procnode
149 lp = icntl(1)
150 IF (icntl(4) .LE. 0) lp = -1
151 position = 0
152 to_update_cpt_end = -654321
153 CALL mpi_unpack( bufr, lbufr_bytes, position, inode, 1,
154 & mpi_integer, comm, ierr )
155 CALL mpi_unpack( bufr, lbufr_bytes, position, npiv, 1,
156 & mpi_integer, comm, ierr )
157 CALL mpi_unpack( bufr, lbufr_bytes, position, fpere, 1,
158 & mpi_integer, comm, ierr )
159 lastbl = (npiv.LE.0)
160 IF (lastbl) THEN
161 npiv = -npiv
162 CALL mpi_unpack( bufr, lbufr_bytes, position, nslaves_tot, 1,
163 & mpi_integer, comm, ierr )
164 CALL mpi_unpack( bufr, lbufr_bytes, position, nb_bloc_fac, 1,
165 & mpi_integer, comm, ierr )
166 ENDIF
167 CALL mpi_unpack( bufr, lbufr_bytes, position, ncol, 1,
168 & mpi_integer, comm, ierr )
169 CALL mpi_unpack( bufr, lbufr_bytes, position, nelim, 1,
170 & mpi_integer, comm, ierr )
171 CALL mpi_unpack( bufr, lbufr_bytes, position,
172 & npartsass_master, 1,
173 & mpi_integer, comm, ierr )
174 npartsass_col = npartsass_master
175 CALL mpi_unpack( bufr, lbufr_bytes, position, ipanel,
176 & 1, mpi_integer, comm, ierr )
177 CALL mpi_unpack( bufr, lbufr_bytes, position, lr_activated_int, 1,
178 & mpi_integer, comm, ierr )
179 lr_activated = (lr_activated_int.EQ.1)
180 CALL mpi_unpack( bufr, lbufr_bytes, position, nslaves_tot, 1,
181 & mpi_integer, comm, ierr )
182 xsize = keep(ixsz)
183 keep_begs_blr_ls =.false.
184 keep_begs_blr_col =.false.
185 keep_blr_ls =.false.
186 IF ( lr_activated ) THEN
187 la_blocfacto = int(npiv,8) * int(npiv+nelim,8)
188 ld_blocfacto = max(npiv+nelim,1)
189 ELSE
190 la_blocfacto = int(npiv,8) * int(ncol,8)
191 ld_blocfacto = max(ncol,1)
192 ENDIF
193 IF (lr_activated) THEN
194 dynamic_alloc = .true.
195 ELSE
196 dynamic_alloc = .false.
197 ENDIF
198 IF ( .NOT. dynamic_alloc ) THEN
199 IF ( npiv .EQ. 0 ) THEN
200 ipiv = 1
201 posblocfacto = 1_8
202 ELSE
203 CALL dmumps_get_size_needed(
204 & npiv, la_blocfacto, .false.,
205 & keep(1), keep8(1),
206 & n, iw, liw, a, la,
207 & lrlu, iptrlu,
208 & iwpos, iwposcb, ptrist, ptrast,
209 & step, pimaster, pamaster, lrlus,
210 & keep(ixsz),comp,dkeep(97),
211 & myid, slavef, procnode_steps, dad,
212 & iflag, ierror)
213 IF (iflag.LT.0) GOTO 700
214 lrlu = lrlu - la_blocfacto
215 lrlus = lrlus - la_blocfacto
216 keep8(69) = keep8(69) + la_blocfacto
217 keep8(67) = min(lrlus, keep8(67))
218 keep8(68) = max(keep8(69), keep8(68))
219 posblocfacto = posfac
220 posfac = posfac + la_blocfacto
221 ipiv = iwpos
222 iwpos = iwpos + npiv
223 CALL dmumps_load_mem_update(.false.,.false.,
224 & la-lrlus,0_8,la_blocfacto,keep,keep8,lrlus)
225 ENDIF
226 ELSE
227 ALLOCATE(dyn_pivinfo(max(1,npiv)),
228 & dyn_blocfacto(max(1_8,la_blocfacto)),
229 & stat=allocok)
230 IF (allocok.GT.0) THEN
231 IF (lp > 0 ) WRITE(lp,*) myid,
232 & ": ALLOCATION FAILURE FOR DYN_PIVINFO and DYN_BLOCFACTO IN ",
233 & "DMUMPS_PROCESS_SYM_BLOCFACTO"
234 iflag = -13
235 CALL mumps_set_ierror(max(1_8,la_blocfacto), ierror)
236 GOTO 700
237 ENDIF
238 posblocfacto = 1_8
239 ipiv = 1
240 ENDIF
241 IF (npiv.GT.0) THEN
242 IF (dynamic_alloc) THEN
243 CALL mpi_unpack( bufr, lbufr_bytes, position,
244 & dyn_pivinfo, npiv,
245 & mpi_integer, comm, ierr )
246 ELSE
247 CALL mpi_unpack( bufr, lbufr_bytes, position,
248 & iw( ipiv ), npiv,
249 & mpi_integer, comm, ierr )
250 ENDIF
251 IF (dynamic_alloc) THEN
252 CALL mpi_unpack( bufr, lbufr_bytes, position,
253 & dyn_blocfacto, int(la_blocfacto),
254 & mpi_double_precision,
255 & comm, ierr )
256 ELSE
257 CALL mpi_unpack( bufr, lbufr_bytes, position,
258 & a(posblocfacto), int(la_blocfacto),
259 & mpi_double_precision,
260 & comm, ierr )
261 ENDIF
262 IF ( lr_activated ) THEN
263 CALL mpi_unpack( bufr, lbufr_bytes, position,
264 & nb_blr_lm, 1, mpi_integer,
265 & comm, ierr )
266 ALLOCATE(blr_lm(max(nb_blr_lm,1)), stat=allocok)
267 IF ( allocok .GT. 0 ) THEN
268 IF (lp > 0 ) WRITE(lp,*) myid,
269 & ": ALLOCATION FAILURE FOR BLR_LM IN ",
270 & "DMUMPS_PROCESS_SYM_BLOCFACTO"
271 iflag = -13
272 ierror = max(nb_blr_lm,1)
273 GOTO 700
274 END IF
275 ALLOCATE(begs_blr_lm(nb_blr_lm+2), stat=allocok)
276 IF ( allocok .GT. 0 ) THEN
277 IF (lp > 0 ) WRITE(lp,*) myid,
278 & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ",
279 & "DMUMPS_PROCESS_SYM_BLOCFACTO"
280 iflag = -13
281 ierror = nb_blr_lm+2
282 GOTO 700
283 END IF
284 CALL dmumps_mpi_unpack_lr(
285 & bufr, lbufr, lbufr_bytes, position, npiv, nelim,
286 & 'V', blr_lm, nb_blr_lm,
287 & begs_blr_lm(1), keep8, comm, ierr, iflag, ierror)
288 IF (iflag.LT.0) GOTO 700
289 ENDIF
290 ENDIF
291 CALL mpi_unpack( bufr, lbufr_bytes, position,
292 & lrelay_info, 1,
293 & mpi_integer, comm, ierr )
294 IF (ptrist(step( inode )) .EQ. 0) THEN
295 src_descband =
296 & mumps_procnode( procnode_steps(step(inode)), keep(199) )
297 CALL dmumps_treat_descband( inode, comm_load, ass_irecv,
298 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
299 & iwpos, iwposcb, iptrlu,
300 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
301 & ptlust_s, ptrfac,
302 & ptrast, step, pimaster, pamaster, nstk_s, comp,
303 & iflag, ierror, comm,
304 & perm, ipool, lpool, leaf, nbfin, myid, slavef,
305 &
306 & root, opassw, opeliw, itloc, rhs_mumps,
307 & fils, dad, ptrarw, ptraiw,
308 & intarr, dblarr, icntl,keep,keep8,dkeep,nd, frere_steps,
309 & lptrar, nelt, frtptr, frtelt,
310 & istep_to_iniv2, tab_pos_in_pere, .true.
311 & , lrgroups
312 & )
313 IF ( iflag .LT. 0 ) GOTO 600
314 ENDIF
315 IF ( iw( ptrist(step(inode)) + 3 + keep(ixsz)) .EQ. 0 ) THEN
316 DO WHILE ( iw(ptrist(step(inode)) + xxnbpr) .NE. 0)
317 blocking = .true.
318 set_irecv = .false.
319 message_received = .false.
320 CALL dmumps_try_recvtreat( comm_load,
321 & ass_irecv, blocking, set_irecv, message_received,
322 & mpi_any_source, contrib_type2,
323 & status,
324 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
325 & iwpos, iwposcb, iptrlu,
326 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
327 & ptlust_s, ptrfac,
328 & ptrast, step, pimaster, pamaster, nstk_s, comp,
329 & iflag, ierror, comm,
330 & perm, ipool, lpool, leaf, nbfin, myid, slavef,
331 &
332 & root, opassw, opeliw, itloc, rhs_mumps,
333 & fils, dad, ptrarw, ptraiw,
334 & intarr, dblarr, icntl,keep,keep8,dkeep,nd, frere_steps,
335 & lptrar, nelt, frtptr, frtelt,
336 & istep_to_iniv2, tab_pos_in_pere, .true.
337 & , lrgroups
338 & )
339 IF ( iflag .LT. 0 ) GOTO 600
340 END DO
341 ENDIF
342 set_irecv = .true.
343 blocking = .false.
344 message_received = .true.
345 CALL dmumps_try_recvtreat( comm_load, ass_irecv,
346 & blocking, set_irecv, message_received,
347 & mpi_any_source, mpi_any_tag,
348 & status,
349 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
350 & iwpos, iwposcb, iptrlu,
351 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
352 & ptlust_s, ptrfac,
353 & ptrast, step, pimaster, pamaster, nstk_s, comp,
354 & iflag, ierror, comm,
355 & perm, ipool, lpool, leaf, nbfin, myid, slavef,
356 &
357 & root, opassw, opeliw, itloc, rhs_mumps,
358 & fils, dad, ptrarw, ptraiw,
359 & intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere_steps,
360 & lptrar, nelt, frtptr, frtelt,
361 & istep_to_iniv2, tab_pos_in_pere, .true.
362 & , lrgroups
363 & )
364 ioldps = ptrist(step(inode))
365 CALL dmumps_dm_set_dynptr( iw(ioldps+xxs), a, la,
366 & ptrast(step(inode)), iw(ioldps+xxd), iw(ioldps+xxr),
367 & a_ptr, poselt, la_ptr )
368 lcont1 = iw( ioldps + keep(ixsz))
369 nass1 = iw( ioldps + 1 + keep(ixsz))
370 compress_panel = (iw(ioldps+xxlr).GE.2)
371 oocwrite_compatible_with_blr =
372 & ( .NOT.lr_activated.OR. (.NOT.compress_panel).OR.
373 & (keep(486).NE.2)
374 & )
375 IF ( nass1 < 0 ) THEN
376 nass1 = -nass1
377 iw( ioldps + 1 + keep(ixsz)) = nass1
378 IF (keep(55) .EQ. 0) THEN
379 CALL dmumps_asm_slave_arrowheads(inode, n, iw, liw,
380 & ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
381 & fils, ptraiw,
382 & ptrarw, intarr, dblarr, keep8(27), keep8(26), rhs_mumps,
383 & lrgroups)
384 ELSE
385 CALL dmumps_asm_slave_elements(inode, n, nelt, iw, liw,
386 & ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
387 & fils, ptraiw,
388 & ptrarw, intarr, dblarr, keep8(27), keep8(26),
389 & frtptr, frtelt, rhs_mumps, lrgroups)
390 ENDIF
391 ENDIF
392 nrow1 = iw( ioldps + 2 +keep(ixsz))
393 npiv1 = iw( ioldps + 3 +keep(ixsz))
394 nslav1 = iw( ioldps + 5 + keep(ixsz))
395 nslaves_follow = nslav1 - xtra_slaves_sym
396 hs = 6 + nslav1 + keep(ixsz)
397 ncol1 = lcont1 + npiv1
398 IF ( lastbl ) THEN
399 to_update_cpt_end = ( nslaves_tot - nslaves_follow - 1 ) *
400 & nb_bloc_fac
401 END IF
402 IF (npiv.GT.0) THEN
403 ict11 = ioldps+hs+nrow1+npiv1 - 1
404 DO i = 1, npiv
405 IF (dynamic_alloc) THEN
406 pivi = abs(dyn_pivinfo(i))
407 ELSE
408 pivi = abs(iw(ipiv+i-1))
409 ENDIF
410 IF (pivi.EQ.i) cycle
411 isw = iw(ict11+i)
412 iw(ict11+i) = iw(ict11+pivi)
413 iw(ict11+pivi) = isw
414 ipos = poselt + int(npiv1 + i - 1,8)
415 kpos = poselt + int(npiv1 + pivi - 1,8)
416 CALL dswap(nrow1, a_ptr(ipos), ncol1, a_ptr(kpos), ncol1)
417 ENDDO
418 IF (.NOT.lr_activated) THEN
419 ALLOCATE( uip21k( npiv * nrow1 ), stat = allocok )
420 IF ( allocok .GT. 0 ) THEN
421 IF (lp > 0 ) WRITE(lp,*) myid,
422 &": ALLOCATION FAILURE FOR UIP21K IN DMUMPS_PROCESS_SYM_BLOCFACTO"
423 iflag = -13
424 ierror = npiv * nrow1
425 GOTO 700
426 END IF
427 ELSE
428 ALLOCATE( uip21k( 1 ), stat = allocok )
429 IF ( allocok .GT. 0 ) THEN
430 IF (lp > 0 ) WRITE(lp,*) myid,
431 &": ALLOCATION FAILURE FOR UIP21K IN DMUMPS_PROCESS_SYM_BLOCFACTO"
432 iflag = -13
433 ierror = npiv * 1
434 GOTO 700
435 END IF
436 ENDIF
437 IF ( nslaves_follow .NE. 0 .and. npiv .NE. 0 ) THEN
438 ALLOCATE( list_slaves_follow( nslaves_follow ),
439 & stat = allocok )
440 IF ( allocok .GT. 0 ) THEN
441 IF (lp > 0 ) WRITE(lp,*) myid,
442 &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW
443 & IN DMUMPS_PROCESS_SYM_BLOCFACTO"
444 iflag = -13
445 ierror = nslaves_follow
446 GOTO 700
447 END IF
448 list_slaves_follow(1:nslaves_follow)=
449 & iw(ioldps+6+xtra_slaves_sym+keep(ixsz):
450 & ioldps+5+xtra_slaves_sym+keep(ixsz)+nslaves_follow)
451 END IF
452 IF ((.NOT. lr_activated).OR.keep(475).EQ.0) THEN
453 IF (dynamic_alloc) THEN
454 CALL dtrsm( 'L', 'U', 'T', 'U', npiv, nrow1, one,
455 & dyn_blocfacto, ld_blocfacto,
456 & a_ptr(poselt+int(npiv1,8)), ncol1)
457 ELSE
458 CALL dtrsm( 'L', 'u', 't', 'u', NPIV, NROW1, ONE,
459 & A( POSBLOCFACTO ), LD_BLOCFACTO,
460 & A_PTR(POSELT+int(NPIV1,8)), NCOL1)
461 ENDIF
462 ENDIF
463.NOT. IF (LR_ACTIVATED) THEN
464 LPOS = POSELT + int(NPIV1,8)
465 UPOS = 1_8
466 DO I = 1, NROW1
467 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) =
468 & A_PTR(LPOS: LPOS+int(NPIV-1,8))
469 LPOS = LPOS + int(NCOL1,8)
470 UPOS = UPOS + int(NPIV,8)
471 END DO
472 ENDIF
473.NOT..OR..EQ. IF (( LR_ACTIVATED)KEEP(475)0) THEN
474 LPOS = POSELT + int(NPIV1,8)
475 IF (DYNAMIC_ALLOC) THEN
476 DPOS = 1_8
477 ELSE
478 DPOS = POSBLOCFACTO
479 ENDIF
480 I = 1
481 DO
482.GT. IF(I NPIV) EXIT
483 IF (DYNAMIC_ALLOC) THEN
484 PIVI = DYN_PIVINFO(I)
485 ELSE
486 PIVI = IW(IPIV+I-1)
487 ENDIF
488.GT. IF(PIVI 0) THEN
489 IF (DYNAMIC_ALLOC) THEN
490 A11 = ONE/DYN_BLOCFACTO(DPOS)
491 ELSE
492 A11 = ONE/A(DPOS)
493 ENDIF
494 CALL dscal( NROW1, A11, A_PTR(LPOS), NCOL1 )
495 LPOS = LPOS + 1_8
496 DPOS = DPOS + int(LD_BLOCFACTO + 1,8)
497 I = I+1
498 ELSE
499 POSPV1 = DPOS
500 POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8)
501 OFFDAG = POSPV1+1_8
502 IF (DYNAMIC_ALLOC) THEN
503 A11 = DYN_BLOCFACTO(POSPV1)
504 A22 = DYN_BLOCFACTO(POSPV2)
505 A12 = DYN_BLOCFACTO(OFFDAG)
506 DETPIV = A11*A22 - A12**2
507 A22 = A11/DETPIV
508 A11 = DYN_BLOCFACTO(POSPV2)/DETPIV
509 A12 = -A12/DETPIV
510 ELSE
511 A11 = A(POSPV1)
512 A22 = A(POSPV2)
513 A12 = A(OFFDAG)
514 DETPIV = A11*A22 - A12**2
515 A22 = A11/DETPIV
516 A11 = A(POSPV2)/DETPIV
517 A12 = -A12/DETPIV
518 ENDIF
519 LPOS1 = LPOS
520 DO J2 = 1,NROW1
521 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8)
522 MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8)
523 A_PTR(LPOS1) = MULT1
524 A_PTR(LPOS1+1_8) = MULT2
525 LPOS1 = LPOS1 + int(NCOL1,8)
526 ENDDO
527 LPOS = LPOS + 2_8
528 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8)
529 I = I+2
530 ENDIF
531 ENDDO
532 ENDIF
533 ENDIF
534 COMPRESS_CB = .FALSE.
535 IF ( LR_ACTIVATED) THEN
536 NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1
537.EQ..OR. COMPRESS_CB = ((IW(IOLDPS+XXLR)1)
538.EQ. & (IW(IOLDPS+XXLR)3))
539 ENDIF
540.AND..EQ. IF (COMPRESS_CBNPIV0) THEN
541 COMPRESS_CB = .FALSE.
542 IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1
543 ENDIF
544.GT. IF (NPIV0) THEN
545.LE. IF (NROW10) THEN
546 CALL MUMPS_ABORT()
547 ENDIF
548 IF (LR_ACTIVATED) THEN
549.NE. IF (NPIV10) THEN
550 CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF),
551 & BEGS_BLR_LS)
552 KEEP_BEGS_BLR_LS = .TRUE.
553 NB_BLR_LS = size(BEGS_BLR_LS) - 2
554 NPARTSCB = NB_BLR_LS
555 ELSE
556 CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0,
557 & NROW1, LRGROUPS, NPARTSCB,
558 & NPARTSASS, BEGS_BLR_LS)
559 CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, 0, NPARTSCB,
560 & NROW1-0, KEEP(488), .TRUE., KEEP(472))
561 NB_BLR_LS = NPARTSCB
562 ENDIF
563 call MAX_CLUSTER(BEGS_BLR_LM,NB_BLR_LM+1,MAXI_CLUSTER_LM)
564 call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS)
565 MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV)
566 IF (COMPRESS_CB) THEN
567.EQ. IF (NPIV10) THEN
568 CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1),
569 & NASS1,
570 & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL,
571 & NPARTSASS_COL, BEGS_BLR_COL)
572 CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1,
573 & NPARTSCB_COL,
574 & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472))
575 NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL
576.NE. IF (NPARTSASS_MASTERNPARTSASS_COL) THEN
577.GT. IF (NPARTSASS_MASTERNPARTSASS_COL) THEN
578 ENDIF
579 SHIFT = NPARTSASS_COL-NPARTSASS_MASTER
580 ALLOCATE(BEGS_BLR_COL_TMP(size(BEGS_BLR_COL)-SHIFT),
581 & stat=allocok)
582.GT. IF ( allocok 0 ) THEN
583 IF (LP > 0 ) WRITE(LP,*) MYID,
584 & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in",
585 & "DMUMPS_PROCESS_SYM_BLOCFACTO"
586 IFLAG = -13
587 IERROR = size(BEGS_BLR_COL)-SHIFT
588 GOTO 700
589 END IF
590 DO II= 1, size(BEGS_BLR_COL)-SHIFT
591 BEGS_BLR_COL_TMP (II) = BEGS_BLR_COL(II+SHIFT)
592 ENDDO
593 BEGS_BLR_COL_TMP(1) = 1
594 DEALLOCATE(BEGS_BLR_COL)
595 BEGS_BLR_COL => BEGS_BLR_COL_TMP
596 NPARTSASS_COL = NPARTSASS_MASTER
597 NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL
598 ENDIF
599 ELSE
600 CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF),
601 & BEGS_BLR_COL, NPARTSASS_COL )
602 KEEP_BEGS_BLR_COL = .TRUE.
603 NB_BLR_COL = size(BEGS_BLR_COL) - 1
604 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL
605 ENDIF
606 CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL)
607 MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL+NELIM)
608 ELSE
609 NULLIFY(BEGS_BLR_COL)
610 ENDIF
611.EQ. IF (NPIV10) THEN
612 INFO_TMP(1) = IFLAG
613 INFO_TMP(2) = IERROR
614 NB_ACCESSES_INIT=0
615.GT. IF (NSLAVES_PREC0) THEN
616 NB_ACCESSES_INIT=NSLAVES_PREC+1
617 ENDIF
618.EQ. IF ( (KEEP(486)2)
619 & ) THEN
620 NB_ACCESSES_INIT = huge(NPARTSASS_MASTER)
621 END IF
622 INFO_TMP(1) = IFLAG
623 INFO_TMP(2) = IERROR
624.LT. IF (IFLAG0) GOTO 700
625 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF),
626 & .TRUE., .TRUE., .TRUE., NPARTSASS_COL,
627 & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT,
628 & INFO_TMP)
629 IFLAG = INFO_TMP(1)
630 IERROR = INFO_TMP(2)
631.LT. IF (IFLAG0) GOTO 700
632 ENDIF
633 LWORK = MAXI_CLUSTER*MAXI_CLUSTER
634 OMP_NUM = 1
635#if defined(BLR_MT)
636!$ OMP_NUM = OMP_GET_MAX_THREADS()
637#endif
638 ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER),
639 & RWORK(2*MAXI_CLUSTER*OMP_NUM),
640 & TAU(MAXI_CLUSTER*OMP_NUM),
641 & JPVT(MAXI_CLUSTER*OMP_NUM),
642 & WORK(LWORK*OMP_NUM),
643 & stat=allocok)
644 IF (allocok > 0 ) THEN
645 IFLAG = -13
646 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4))
647 GOTO 700
648 ENDIF
649 CURRENT_BLR = 1
650 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok)
651 IF (allocok > 0 ) THEN
652 IFLAG = -13
653 IERROR = NB_BLR_LS
654 GOTO 700
655 ENDIF
656#if defined(BLR_MT)
657!$OMP PARALLEL
658#endif
659 CALL DMUMPS_COMPRESS_PANEL_I_NOOPT
660 & (A_PTR(POSELT), LA_PTR, 1_8,
661 & IFLAG, IERROR, NCOL1,
662 & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1,
663 & DKEEP(8), KEEP(466), KEEP(473),
664 & BLR_LS(1),
665 & CURRENT_BLR, 'v', WORK, TAU, JPVT, LWORK, RWORK,
666 & BLOCKLR, MAXI_CLUSTER, NELIM,
667 & .TRUE.,
668 & NPIV, NPIV1,
669 & 2, KEEP(483), KEEP8,
670 & OMP_NUM)
671#if defined(BLR_MT)
672!$OMP BARRIER
673#endif
674.LT. IF (IFLAG0) GOTO 300
675.GE. IF (KEEP(475)1) THEN
676 IF (DYNAMIC_ALLOC) THEN
677 CALL DMUMPS_BLR_PANEL_LRTRSM(
678 & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8,
679 & LD_BLOCFACTO, -6666,
680 & NB_BLR_LS+1,
681 & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1,
682 & 2, 1, 0,
683 & .TRUE.,
684 & DYN_PIVINFO, OFFSET_IW=1)
685 ELSE
686 CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO,
687 & LD_BLOCFACTO, -6666,
688 & NB_BLR_LS+1,
689 & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1,
690 & 2, 1, 0,
691 & .TRUE.,
692 & IW, OFFSET_IW=IPIV)
693 ENDIF
694#if defined(BLR_MT)
695!$OMP BARRIER
696#endif
697.NE. IF (KEEP(486)2) THEN
698 CALL DMUMPS_DECOMPRESS_PANEL_I_NOOPT(
699 & A_PTR(POSELT), LA_PTR, 1_8,
700 & NCOL1, NCOL1,
701 & .TRUE.,
702 & NPIV1+1,
703 & 1,
704 & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'v', 1)
705 ENDIF
706 ENDIF
707 300 CONTINUE
708#if defined(BLR_MT)
709!$OMP END PARALLEL
710#endif
711.LT. IF (IFLAG0) GOTO 700
712 ENDIF
713 ENDIF
714.eq..AND. IF ( (KEEP(201)1)
715.OR..EQ. & (OOCWRITE_COMPATIBLE_WITH_BLR NPIV0) ) THEN
716 MonBloc%INODE = INODE
717 MonBloc%MASTER = .FALSE.
718 MonBloc%Typenode = 2
719 MonBloc%NROW = NROW1
720 MonBloc%NCOL = NCOL1
721 MonBloc%NFS = NASS1
722 MonBloc%LastPiv = NPIV1 + NPIV
723 MonBloc%LastPanelWritten_L = -9999
724 MonBloc%LastPanelWritten_U = -9999
725 NULLIFY(MonBloc%INDICES)
726 MonBloc%Last = LASTBL
727 STRAT = STRAT_TRY_WRITE
728 NextPivDummy = -8888
729 LIWFAC = IW(IOLDPS+XXI)
730 LAST_CALL = .FALSE.
731 CALL DMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L,
732 & A_PTR(POSELT),
733 & LA_PTR, MonBloc, NextPivDummy, NextPivDummy,
734 & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL)
735 ENDIF
736.GT. IF (NPIV0) THEN
737 IF (LR_ACTIVATED) THEN
738.GT. IF (NELIM0) THEN
739 LPOS2 = POSELT + int(NPIV1,8)
740 UPOS = 1_8+int(NPIV,8)
741 LPOS = LPOS2 + int(NPIV,8)
742 IF (DYNAMIC_ALLOC) THEN
743 CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I(
744 & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS,
745 & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8,
746 & IFLAG, IERROR, LD_BLOCFACTO, NCOL1,
747 & BEGS_BLR_LS(1), size(BEGS_BLR_LS),
748 & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1,
749 & CURRENT_BLR+1, NELIM, 'n')
750 ELSE
751 CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I(
752 & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS,
753 & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8,
754 & IFLAG, IERROR, LD_BLOCFACTO, NCOL1,
755 & BEGS_BLR_LS(1), size(BEGS_BLR_LS),
756 & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1,
757 & CURRENT_BLR+1, NELIM, 'n')
758 ENDIF
759 ENDIF
760#if defined(BLR_MT)
761!$OMP PARALLEL
762#endif
763 IF (DYNAMIC_ALLOC) THEN
764 CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(
765 & A_PTR(POSELT), LA_PTR, 1_8,
766 & IFLAG, IERROR, NCOL1, NROW1,
767 & DYN_BLOCFACTO, LA_BLOCFACTO,
768 & LD_BLOCFACTO,
769 & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1,
770 & BLR_LM(1), NPIV1,
771 & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1,
772 & BLR_LS(1), 0,
773 & CURRENT_BLR, CURRENT_BLR,
774 & DYN_PIVINFO,
775 & BLOCKLR,
776 & MAXI_CLUSTER, OMP_NUM,
777 & KEEP(481), DKEEP(11), KEEP(466), KEEP(477)
778 & )
779 ELSE
780 CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(
781 & A_PTR(POSELT), LA_PTR, 1_8,
782 & IFLAG, IERROR, NCOL1, NROW1,
783 & A(POSBLOCFACTO), LA_BLOCFACTO,
784 & LD_BLOCFACTO,
785 & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1,
786 & BLR_LM(1), NPIV1,
787 & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1,
788 & BLR_LS(1), 0,
789 & CURRENT_BLR, CURRENT_BLR,
790 & IW(IPIV),
791 & BLOCKLR,
792 & MAXI_CLUSTER, OMP_NUM,
793 & KEEP(481), DKEEP(11), KEEP(466), KEEP(477)
794 & )
795 ENDIF
796.LT. IF (IFLAG0) GOTO 400
797 400 CONTINUE
798#if defined(BLR_MT)
799!$OMP END PARALLEL
800#endif
801.LT. IF (IFLAG0) GOTO 700
802 CALL UPD_MRY_LU_LRGAIN(BLR_LS, NPARTSCB
803 & )
804 CALL DEALLOC_BLR_PANEL(BLR_LM, NB_BLR_LM, KEEP8, KEEP(34))
805 DEALLOCATE(BLR_LM)
806.GT. IF (NSLAVES_PREC0
807.OR. &
808 & (
809.EQ. & (KEEP(486)2)
810 & )
811 & ) THEN
812 CALL DMUMPS_BLR_SAVE_PANEL_LORU(
813 & IW(IOLDPS+XXF),
814 & 0,
815 & IPANEL, BLR_LS)
816 KEEP_BLR_LS = .TRUE.
817 ENDIF
818 ELSE
819.GT..AND..GT. IF (NPIV 0 NCOL-NPIV0)THEN
820 LPOS2 = POSELT + int(NPIV1,8)
821 LPOS = LPOS2 + int(NPIV,8)
822 IF (DYNAMIC_ALLOC) THEN
823 UPOS = int(NPIV+1,8)
824 CALL dgemm('n','n', NCOL-NPIV, NROW1, NPIV,
825 & ALPHA, DYN_BLOCFACTO(UPOS), NCOL,
826 & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1)
827 ELSE
828 UPOS = POSBLOCFACTO+int(NPIV,8)
829 CALL dgemm('n','n', NCOL-NPIV, NROW1, NPIV,
830 & ALPHA,A(UPOS), NCOL,
831 & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1)
832 ENDIF
833 ENDIF
834 DPOS = POSELT + int(NCOL1 - NROW1,8)
835#if defined(GEMMT_AVAILABLE)
836.EQ. IF ( KEEP(421) -1) THEN
837 LPOS2 = POSELT + int(NPIV1,8)
838 UPOS = 1_8
839 CALL dgemmt( 'u', 't', 'n', NROW1, NPIV, ALPHA,
840 & UIP21K( UPOS ), NPIV,
841 & A_PTR( LPOS2 ), NCOL1, ONE,
842 & A_PTR( DPOS ), NCOL1 )
843 ELSE
844#endif
845.GT. IF ( NROW1 KEEP(7) ) THEN
846 BLSIZE = KEEP(8)
847 ELSE
848 BLSIZE = NROW1
849 ENDIF
850.GT. IF ( NROW1 0 ) THEN
851 DO IROW = 1, NROW1, BLSIZE
852 Block = min( BLSIZE, NROW1 - IROW + 1 )
853 DPOS = POSELT + int(NCOL1 - NROW1,8)
854 & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 )
855 LPOS2 = POSELT + int(NPIV1,8)
856 & + int( IROW - 1, 8 ) * int( NCOL1, 8 )
857 UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8
858 DO I = 1, Block
859 CALL dgemv( 't', NPIV, Block-I+1, ALPHA,
860 & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1,
861 & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ),
862 & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 )
863 END DO
864.ne. IF ( NROW1-IROW+1-Block 0 )
865 & CALL dgemm( 't', 'n', Block, NROW1-IROW+1-Block,
866 & NPIV, ALPHA,
867 & UIP21K( UPOS ), NPIV,
868 & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1,
869 & ONE,
870 & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 )
871 ENDDO
872 ENDIF
873#if defined(GEMMT_AVAILABLE)
874 ENDIF
875#endif
876 ENDIF
877 FLOP1 = dble(NROW1) * dble(NPIV) *
878 & dble( 2 * NCOL - NPIV + NROW1 +1 )
879 FLOP1 = -FLOP1
880 CALL DMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 )
881 ENDIF
882 IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV
883 IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV
884 IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS + 3+KEEP(IXSZ))
885.NOT. IF ( LR_ACTIVATED ) THEN
886 IF (DYNAMIC_ALLOC) THEN
887 IF (allocated(DYN_PIVINFO) ) DEALLOCATE(DYN_PIVINFO)
888 IF (allocated(DYN_BLOCFACTO)) THEN
889 DEALLOCATE(DYN_BLOCFACTO)
890 ENDIF
891 ELSE
892 LRLU = LRLU + LA_BLOCFACTO
893 LRLUS = LRLUS + LA_BLOCFACTO
894 KEEP8(69) = KEEP8(69) - LA_BLOCFACTO
895 POSFAC = POSFAC - LA_BLOCFACTO
896 IWPOS = IWPOS - NPIV
897 CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
898 & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
899 ENDIF
900 ENDIF
901.NE..and..NE. IF ( NSLAVES_FOLLOW 0 NPIV 0 ) THEN
902 IPOSK = NPIV1 + 1
903 JPOSK = NCOL1 - NROW1 + 1
904 NPIVSENT = NPIV
905 IERR = -1
906.eq. DO WHILE ( IERR -1 )
907 IF (DYNAMIC_ALLOC) THEN
908 CALL DMUMPS_BUF_SEND_BLFAC_SLAVE(
909 & INODE, NPIVSENT, FPERE,
910 & IPOSK, JPOSK,
911 & UIP21K, NROW1,
912 & NSLAVES_FOLLOW,
913 & LIST_SLAVES_FOLLOW(1),
914 & COMM, KEEP,
915 & LR_ACTIVATED, BLR_LS, IPANEL,
916 & DYN_BLOCFACTO, LA_BLOCFACTO,
917 & 1_8, LD_BLOCFACTO,
918 & DYN_PIVINFO, MAXI_CLUSTER,
919 & IERR )
920 ELSE
921 CALL DMUMPS_BUF_SEND_BLFAC_SLAVE(
922 & INODE, NPIVSENT, FPERE,
923 & IPOSK, JPOSK,
924 & UIP21K, NROW1,
925 & NSLAVES_FOLLOW,
926 & LIST_SLAVES_FOLLOW(1),
927 & COMM, KEEP,
928 & LR_ACTIVATED, BLR_LS, IPANEL,
929 & A, LA,
930 & POSBLOCFACTO, LD_BLOCFACTO,
931 & IW(IPIV), MAXI_CLUSTER,
932 & IERR )
933 ENDIF
934.EQ. IF (IERR -1 ) THEN
935 IOLDPS = PTRIST(STEP(INODE))
936.eq. IF ( IW(IOLDPS+6+KEEP(IXSZ))
937 & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN
938 COUNTER_WAS_HUGE=.TRUE.
939 IW(IOLDPS+6+KEEP(IXSZ)) = 1
940 ELSE
941 COUNTER_WAS_HUGE=.FALSE.
942 ENDIF
943 TO_UPDATE_CPT_RECUR =
944 & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) *
945 & (2*NASS1/KEEP(6))
946 IW(IOLDPS+6+KEEP(IXSZ)) =
947 & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10
948 BLOCKING = .FALSE.
949 SET_IRECV= .TRUE.
950 MESSAGE_RECEIVED = .FALSE.
951 CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV,
952 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
953 & MPI_ANY_SOURCE, MPI_ANY_TAG,
954 & STATUS,
955 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
956 & IWPOS, IWPOSCB, IPTRLU,
957 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
958 & PTLUST_S, PTRFAC,
959 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
960 & IFLAG, IERROR, COMM,
961 & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
962 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
963 & FILS, DAD, PTRARW, PTRAIW,
964 & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
965 & LPTRAR, NELT, FRTPTR, FRTELT,
966 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.
967 & , LRGROUPS
968 & )
969 IOLDPS = PTRIST(STEP(INODE))
970 IW(IOLDPS+6+KEEP(IXSZ)) =
971 & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10
972.AND. IF ( COUNTER_WAS_HUGE
973.EQ. & IW(IOLDPS+6+KEEP(IXSZ))1 ) THEN
974 IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ)))
975 ENDIF
976.LT. IF ( IFLAG 0 ) GOTO 600
977 END IF
978 END DO
979.eq. IF ( IERR -2 ) THEN
980 IF (LP > 0 ) WRITE(LP,*) MYID,
981 &": FAILURE, SEND BUFFER TOO SMALL DURING
982 & DMUMPS_PROCESS_SYM_BLOCFACTO"
983 WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1
984 IFLAG = -17
985 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35)
986 GOTO 700
987 END IF
988.eq. IF ( IERR -3 ) THEN
989 IF (LP > 0 ) WRITE(LP,*) MYID,
990 &": FAILURE, RECV BUFFER TOO SMALL DURING
991 & DMUMPS_PROCESS_SYM_BLOCFACTO"
992 IFLAG = -20
993 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35)
994 GOTO 700
995 END IF
996 DEALLOCATE(LIST_SLAVES_FOLLOW)
997 END IF
998 IF ( LR_ACTIVATED ) THEN
999.GT..AND..GT. IF (NPIV0 NSLAVES_PREC0
1000.AND..EQ. & KEEP(486)3
1001 & ) THEN
1002 IOLDPS = PTRIST(STEP(INODE))
1003 CALL DMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL,
1004 & KEEP8, KEEP(34))
1005 ENDIF
1006 IF (DYNAMIC_ALLOC) THEN
1007 IF (allocated(DYN_PIVINFO)) DEALLOCATE(DYN_PIVINFO)
1008 IF (allocated(DYN_BLOCFACTO)) THEN
1009 DEALLOCATE(DYN_BLOCFACTO)
1010 ENDIF
1011.GT. ELSE IF (NPIV 0) THEN
1012 LRLU = LRLU + LA_BLOCFACTO
1013 LRLUS = LRLUS + LA_BLOCFACTO
1014 KEEP8(69) = KEEP8(69) - LA_BLOCFACTO
1015 POSFAC = POSFAC - LA_BLOCFACTO
1016 IWPOS = IWPOS - NPIV
1017 CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
1018 & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
1019 ENDIF
1020 ENDIF
1021.NE. IF ( NPIV 0 ) THEN
1022 IF (allocated(UIP21K)) THEN
1023 DEALLOCATE( UIP21K )
1024 ENDIF
1025 ENDIF
1026 IOLDPS = PTRIST(STEP(INODE))
1027 CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA,
1028 & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR),
1029 & A_PTR, POSELT, LA_PTR )
1030 IF (LASTBL) THEN
1031.NE. IF ( KEEP(486) 0) THEN
1032 IF (LR_ACTIVATED) THEN
1033 CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1,
1034 & KEEP(50), INODE)
1035 ELSE
1036 CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1,
1037 & KEEP(50), INODE)
1038 ENDIF
1039 ENDIF
1040.EQ. IF ( IW(IOLDPS+6+KEEP(IXSZ))
1041 & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN
1042 IW(IOLDPS+6+KEEP(IXSZ)) = 1
1043 ENDIF
1044 IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ))
1045 & - TO_UPDATE_CPT_END
1046 & - 1
1047.eq. IF ( IW(IOLDPS+6+KEEP(IXSZ) ) 0
1048.and..ne..and..eq. & KEEP(50) 0 NSLAVES_FOLLOW 0
1049.and..NE. & NSLAVES_TOT1 ) THEN
1050 DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)),
1051 & KEEP(199) )
1052 CALL DMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT,
1053 & COMM, KEEP, IERR )
1054.LT. IF ( IERR 0 ) THEN
1055 write(*,*) ' internal error in process_sym_blocfacto.'
1056 IFLAG = -99
1057 GOTO 700
1058 END IF
1059 ENDIF
1060 END IF
1061.eq. IF (IW(IOLDPS+6+KEEP(IXSZ)) 0 ) THEN
1062 NELIM = IW( IOLDPS + 4 + KEEP(IXSZ)) -
1063 & IW( IOLDPS + 3 + KEEP(IXSZ))
1064 IF (LR_ACTIVATED) THEN
1065 IF (COMPRESS_CB) THEN
1066 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL),
1067 & stat=allocok)
1068 IF (allocok > 0) THEN
1069 IFLAG = -13
1070 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL)
1071 GOTO 700
1072 ENDIF
1073 DO II=1,NB_BLR_LS
1074 DO JJ=1,NB_BLR_COL-NPARTSASS_COL
1075 CB_LRB(II,JJ)%M=0
1076 CB_LRB(II,JJ)%N=0
1077 NULLIFY(CB_LRB(II,JJ)%Q)
1078 NULLIFY(CB_LRB(II,JJ)%R)
1079 CB_LRB(II,JJ)%ISLR = .FALSE.
1080 ENDDO
1081 ENDDO
1082 CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB)
1083 ENDIF
1084 IF (COMPRESS_CB) THEN
1085 NFS4FATHER = -9999
1086.NE..AND..EQ. IF ( (KEEP(219)0)(KEEP(50)2) ) THEN
1087 CALL DMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF),
1088 & NFS4FATHER )
1089 NFS4FATHER = max(NFS4FATHER,0) + NELIM
1090 ENDIF
1091 ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok)
1092.GT. IF ( allocok 0 ) THEN
1093 IF (LP > 0 ) WRITE(LP,*) MYID,
1094 & ": ALLOCATION FAILURE FOR M_ARRAY ",
1095 & "DMUMPS_PROCESS_SYM_BLOCFACTO"
1096 IFLAG = -13
1097 IERROR = max(1,NFS4FATHER)
1098 ENDIF
1099 BEGS_BLR_COL(1+NPARTSASS_COL) =
1100 & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM
1101 NBROWSinF = 0
1102 NVSCHUR_K253 = 0
1103.NE..AND..EQ..AND. IF ( (KEEP(219)0)(KEEP(50)2)
1104.GT. & NFS4FATHER0 ) THEN
1105 CALL DMUMPS_COMPUTE_NBROWSinF (
1106 & N, INODE, FPERE, KEEP,
1107 & IOLDPS, HS,
1108 & IW, LIW,
1109 & NROW1, NCOL1, NPIV+NPIV1,
1110 & NELIM, NFS4FATHER,
1111 & NBROWSinF
1112 & )
1113.EQ..AND..GT. IF ((KEEP(114)1) (KEEP(116)0) ) THEN
1114 NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ))
1115 IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L +
1116 & KEEP(IXSZ)
1117 CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT (
1118 & N,
1119 & NROW1,
1120 & KEEP(116),
1121 & IW(IROW_L),
1122 & PERM, NVSCHUR_K253 )
1123.NE. ELSE IF (KEEP(253)0) THEN
1124 NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ))
1125 IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L +
1126 & KEEP(IXSZ)
1127 CALL DMUMPS_GET_SIZE_SCHUR_IN_FRONT (
1128 & N,
1129 & NROW1,
1130 & 0,
1131 & IW(IROW_L),
1132 & PERM, NVSCHUR_K253 )
1133 ENDIF
1134 ENDIF
1135.LT. IF (IFLAG0) GOTO 700
1136#if defined(BLR_MT)
1137!$OMP PARALLEL
1138#endif
1139 CALL DMUMPS_COMPRESS_CB_I(
1140 & A_PTR(POSELT), LA_PTR, 1_8, NCOL1,
1141 & BEGS_BLR_LS(1), size(BEGS_BLR_LS),
1142 & BEGS_BLR_COL(1), size(BEGS_BLR_COL),
1143 & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL,
1144 & NPARTSASS_COL,
1145 & NROW1, NCOL1-NPIV1-NPIV, INODE,
1146 & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR,
1147 & DKEEP(12), KEEP(466), KEEP(484), KEEP(489),
1148 & CB_LRB(1,1),
1149 & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR,
1150 & MAXI_CLUSTER, KEEP8, OMP_NUM,
1151 & NFS4FATHER, NPIV1+NPIV, NVSCHUR_K253, KEEP(1),
1152 & M_ARRAY
1153 & , NELIM, NBROWSinF
1154 & )
1155#if defined(BLR_MT)
1156!$OMP END PARALLEL
1157#endif
1158.LT. IF (IFLAG0) GOTO 650
1159.NE..AND..EQ..AND. IF ( (KEEP(219)0)(KEEP(50)2)
1160.GT. & NFS4FATHER0 ) THEN
1161 INFO_TMP(1) = IFLAG
1162 INFO_TMP(2) = IERROR
1163 CALL DMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF),
1164 & M_ARRAY, INFO_TMP)
1165 IFLAG = INFO_TMP(1)
1166 IERROR = INFO_TMP(2)
1167 ENDIF
1168 DEALLOCATE(M_ARRAY)
1169 650 CONTINUE
1170 ENDIF
1171.LT. IF (IFLAG0) GOTO 700
1172 ENDIF
1173 CALL DMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV,
1174 & N, INODE, FPERE,
1175 & root,
1176 & MYID, COMM,
1177 &
1178 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
1179 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA,
1180 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER,
1181 & PAMASTER,
1182 & NSTK_S, COMP, IFLAG, IERROR, PERM,
1183 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF,
1184 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW,
1185 & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS,
1186 & LPTRAR, NELT, FRTPTR, FRTELT,
1187 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
1188 & , LRGROUPS
1189 & )
1190 ENDIF
1191 IF (LR_ACTIVATED) THEN
1192 IF (allocated(RWORK)) DEALLOCATE(RWORK)
1193 IF (allocated(WORK)) DEALLOCATE(WORK)
1194 IF (allocated(TAU)) DEALLOCATE(TAU)
1195 IF (allocated(JPVT)) DEALLOCATE(JPVT)
1196 IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR)
1197.GT. IF (NPIV0) THEN
1198.NOT. IF (KEEP_BEGS_BLR_LS) THEN
1199 IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS)
1200 ENDIF
1201.NOT. IF (KEEP_BLR_LS) THEN
1202 CALL DEALLOC_BLR_PANEL(BLR_LS, NB_BLR_LS, KEEP8, KEEP(34))
1203 IF (associated(BLR_LS)) DEALLOCATE(BLR_LS)
1204 ENDIF
1205 IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM)
1206.NOT. IF (KEEP_BEGS_BLR_COL) THEN
1207 IF (COMPRESS_CB) THEN
1208 IF (associated(BEGS_BLR_COL)) THEN
1209 DEALLOCATE( BEGS_BLR_COL)
1210 ENDIF
1211 ENDIF
1212 ENDIF
1213 ENDIF
1214 ENDIF
1215 600 CONTINUE
1216 RETURN
1217 700 CONTINUE
1218 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
1219 RETURN
1220 END SUBROUTINE DMUMPS_PROCESS_SYM_BLOCFACTO
dmumps_asm_slave_arrowheads
subroutine dmumps_asm_slave_arrowheads(inode, n, iw, liw, ioldps, a, la, poselt, keep, keep8, itloc, fils, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, rhs_mumps, lrgroups)
Definition dfac_asm.F:637
dmumps_asm_slave_elements
subroutine dmumps_asm_slave_elements(inode, n, nelt, iw, liw, ioldps, a, la, poselt, keep, keep8, itloc, fils, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, frt_ptr, frt_elt, rhs_mumps, lrgroups)
Definition dfac_asm_ELT.F:83
dmumps_get_size_needed
subroutine dmumps_get_size_needed(sizei_needed, sizer_needed, skip_top_stack, keep, keep8, n, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad, iflag, ierror)
Definition dfac_mem_compress_cb.F:437
dmumps_treat_descband
recursive subroutine dmumps_treat_descband(inode, comm_load, ass_irecv, 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_band.F:254
dmumps_mpi_unpack_lr
subroutine dmumps_mpi_unpack_lr(bufr, lbufr, lbufr_bytes, position, npiv, nelim, dir, blr_u, nb_block_u, begs_blr_u, keep8, comm, ierr, iflag, ierror)
Definition dfac_process_blocfacto.F:758
dmumps_process_sym_blocfacto
recursive subroutine dmumps_process_sym_blocfacto(comm_load, ass_irecv, bufr, lbufr, lbufr_bytes, procnode_steps, msgsou, slavef, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptrast, nstk_s, perm, comp, step, pimaster, pamaster, posfac, myid, comm, iflag, ierror, nbfin ptlust_s, ptrfac, root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, ipool, lpool, leaf, nd, frere_steps, lptrar, nelt, frtptr, frtelt, istep_to_iniv2, tab_pos_in_pere, lrgroups)
Definition dfac_process_blocfacto_LDLT.F:31
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
dswap
subroutine dswap(n, dx, incx, dy, incy)
DSWAP
Definition dswap.f:82
dtrsm
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
mpi_unpack
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
dmumps_ana_lr
Definition dana_lr.F:14
dmumps_ana_lr::get_cut
subroutine get_cut(iwr, nass, ncb, lrgroups, npartscb, npartsass, cut)
Definition dana_lr.F:25
dmumps_buf
Definition dmumps_comm_buffer.F:14
dmumps_dynamic_memory_m
Definition dfac_mem_dynamic.F:14
dmumps_dynamic_memory_m::dmumps_dm_set_dynptr
subroutine dmumps_dm_set_dynptr(cb_state, a, la, pamaster_or_ptrast, ixxd, ixxr, son_a, iachk, recsize)
Definition dfac_mem_dynamic.F:19
dmumps_fac_front_aux_m
Definition dfac_front_aux.F:14
dmumps_fac_front_aux_m::dmumps_get_size_schur_in_front
subroutine dmumps_get_size_schur_in_front(n, ncb, size_schur, row_indices, perm, nvschur)
Definition dfac_front_aux.F:2505
dmumps_fac_lr
Definition dfac_lr.F:14
dmumps_load
Definition dmumps_load.F:14
dmumps_load::dmumps_load_mem_update
subroutine, public dmumps_load_mem_update(ssarbr, process_bande_arg, mem_value, new_lu, inc_mem_arg, keep, keep8, lrlus)
Definition dmumps_load.F:920
dmumps_load::alpha
double precision, save, private alpha
Definition dmumps_load.F:55
dmumps_load::myid
integer, save, private myid
Definition dmumps_load.F:57
dmumps_lr_core
Definition dlr_core.F:18
dmumps_lr_data_m
Definition dmumps_lr_data_m.F:14
dmumps_lr_stats
Definition dlr_stats.F:14
dmumps_lr_type
Definition dlr_type.F:14
dmumps_ooc
Definition dmumps_ooc.F:14
dmumps_struc_def
Definition dmumps_struc_def.F:14
mumps_ooc_common
Definition mumps_ooc_common.F:14
mumps_ooc_common::strat_try_write
integer, public strat_try_write
Definition mumps_ooc_common.F:45
mumps_ooc_common::typef_l
integer, public typef_l
Definition mumps_ooc_common.F:18
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102
dmumps_lr_type::lrb_type
Definition dlr_type.F:16
mumps_ooc_common::io_block
Definition mumps_ooc_common.F:33
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865