OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfac_process_blocfacto_LDLT.F File Reference

Go to the source code of this file.

Functions/Subroutines

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)

Function/Subroutine Documentation

◆ dmumps_process_sym_blocfacto()

recursive subroutine dmumps_process_sym_blocfacto ( integer comm_load,
integer ass_irecv,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer, dimension(keep(28)) procnode_steps,
integer msgsou,
integer slavef,
integer iwpos,
integer iwposcb,
integer(8) iptrlu,
integer(8) lrlu,
integer(8) lrlus,
integer n,
integer, dimension( liw ) iw,
integer liw,
double precision, dimension( la ) a,
integer(8) la,
integer, dimension(keep(28)) ptrist,
integer(8), dimension(keep(28)) ptrast,
integer, dimension(keep(28)) nstk_s,
integer, dimension(n) perm,
integer comp,
integer, dimension(n) step,
integer, dimension(keep(28)) pimaster,
integer(8), dimension(keep(28)) pamaster,
integer(8) posfac,
integer myid,
integer comm,
integer iflag,
integer ierror,
integer nbfin,
integer, dimension(keep(28)) ptlust_s,
integer(8), dimension(keep(28)) ptrfac,
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( lpool ) ipool,
integer lpool,
integer leaf,
integer, dimension(keep(28)) nd,
integer, dimension(keep(28)) frere_steps,
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, dimension(n), intent(in) lrgroups )

Definition at line 14 of file dfac_process_blocfacto_LDLT.F.

31 USE dmumps_ooc, ONLY : io_block
33 USE dmumps_load
34 USE dmumps_buf
39 USE dmumps_ana_lr, ONLY : get_cut
41 USE dmumps_struc_def, ONLY : dmumps_root_struc
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
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
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 IF (.NOT.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 IF ((.NOT. lr_activated).OR.keep(475).EQ.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 IF(i .GT. npiv) EXIT
483 IF (dynamic_alloc) THEN
484 pivi = dyn_pivinfo(i)
485 ELSE
486 pivi = iw(ipiv+i-1)
487 ENDIF
488 IF(pivi .GT. 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 compress_cb = ((iw(ioldps+xxlr).EQ.1).OR.
538 & (iw(ioldps+xxlr).EQ.3))
539 ENDIF
540 IF (compress_cb.AND.npiv.EQ.0) THEN
541 compress_cb = .false.
542 iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
543 ENDIF
544 IF (npiv.GT.0) THEN
545 IF (nrow1.LE.0) THEN
546 CALL mumps_abort()
547 ENDIF
548 IF (lr_activated) THEN
549 IF (npiv1.NE.0) 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 IF (npiv1.EQ.0) 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 IF (npartsass_master.NE.npartsass_col) THEN
577 IF (npartsass_master.GT.npartsass_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 IF ( allocok .GT. 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 IF (npiv1.EQ.0) THEN
612 info_tmp(1) = iflag
613 info_tmp(2) = ierror
614 nb_accesses_init=0
615 IF (nslaves_prec.GT.0) THEN
616 nb_accesses_init=nslaves_prec+1
617 ENDIF
618 IF ( (keep(486).EQ.2)
619 & ) THEN
620 nb_accesses_init = huge(npartsass_master)
621 END IF
622 info_tmp(1) = iflag
623 info_tmp(2) = ierror
624 IF (iflag.LT.0) 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 IF (iflag.LT.0) 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
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 IF (iflag.LT.0) GOTO 300
675 IF (keep(475).GE.1) THEN
676 IF (dynamic_alloc) THEN
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 IF (keep(486).NE.2) THEN
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 IF (iflag.LT.0) GOTO 700
712 ENDIF
713 ENDIF
714 IF ( (keep(201).eq.1) .AND.
715 & (oocwrite_compatible_with_blr .OR. npiv.EQ.0) ) 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.
732 & a_ptr(poselt),
733 & la_ptr, monbloc, nextpivdummy, nextpivdummy,
734 & iw(ioldps), liwfac, myid, keep8(31), iflag,last_call)
735 ENDIF
736 IF (npiv.GT.0) THEN
737 IF (lr_activated) THEN
738 IF (nelim.GT.0) 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
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
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
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
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 IF (iflag.LT.0) GOTO 400
797 400 CONTINUE
798#if defined(BLR_MT)
799!$OMP END PARALLEL
800#endif
801 IF (iflag.LT.0) 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 IF (nslaves_prec.GT.0
807 & .OR.
808 & (
809 & (keep(486).EQ.2)
810 & )
811 & ) THEN
813 & iw(ioldps+xxf),
814 & 0,
815 & ipanel, blr_ls)
816 keep_blr_ls = .true.
817 ENDIF
818 ELSE
819 IF (npiv .GT. 0 .AND. ncol-npiv.GT.0)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 IF ( keep(421).EQ. -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 IF ( nrow1 .GT. keep(7) ) THEN
846 blsize = keep(8)
847 ELSE
848 blsize = nrow1
849 ENDIF
850 IF ( nrow1 .GT. 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 IF ( nrow1-irow+1-block .ne. 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 IF ( .NOT. 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 IF ( nslaves_follow .NE. 0 .and. npiv .NE. 0 ) THEN
902 iposk = npiv1 + 1
903 jposk = ncol1 - nrow1 + 1
904 npivsent = npiv
905 ierr = -1
906 DO WHILE ( ierr .eq. -1 )
907 IF (dynamic_alloc) THEN
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
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 IF (ierr .EQ. -1 ) THEN
935 ioldps = ptrist(step(inode))
936 IF ( iw(ioldps+6+keep(ixsz)) .eq.
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 IF ( counter_was_huge .AND.
973 & iw(ioldps+6+keep(ixsz)).EQ.1 ) THEN
974 iw(ioldps+6+keep(ixsz)) = huge(iw(ioldps+6+keep(ixsz)))
975 ENDIF
976 IF ( iflag .LT. 0 ) GOTO 600
977 END IF
978 END DO
979 IF ( ierr .eq. -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 IF ( ierr .eq. -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 IF (npiv.GT.0 .AND. nslaves_prec.GT.0
1000 & .AND. keep(486).EQ.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 ELSE IF (npiv .GT. 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 IF ( npiv .NE. 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 IF ( keep(486) .NE. 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 IF ( iw(ioldps+6+keep(ixsz)).EQ.
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 IF ( iw(ioldps+6+keep(ixsz) ) .eq. 0
1048 & .and. keep(50) .ne. 0 .and. nslaves_follow .eq. 0
1049 & .and. nslaves_tot.NE.1 ) 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 IF ( ierr .LT. 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 IF (iw(ioldps+6+keep(ixsz)) .eq. 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 IF ( (keep(219).NE.0).AND.(keep(50).EQ.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 IF ( allocok .GT. 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 IF ( (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
1104 & nfs4father.GT.0 ) THEN
1106 & n, inode, fpere, keep,
1107 & ioldps, hs,
1108 & iw, liw,
1109 & nrow1, ncol1, npiv+npiv1,
1110 & nelim, nfs4father,
1111 & nbrowsinf
1112 & )
1113 IF ((keep(114).EQ.1) .AND. (keep(116).GT.0) ) THEN
1114 nslaves_l = iw(ptrist(step(inode)) + 5 + keep(ixsz))
1115 irow_l = ptrist(step(inode)) + 6 + nslaves_l +
1116 & keep(ixsz)
1118 & n,
1119 & nrow1,
1120 & keep(116),
1121 & iw(irow_l),
1122 & perm, nvschur_k253 )
1123 ELSE IF (keep(253).NE.0) THEN
1124 nslaves_l = iw(ptrist(step(inode)) + 5 + keep(ixsz))
1125 irow_l = ptrist(step(inode)) + 6 + nslaves_l +
1126 & keep(ixsz)
1128 & n,
1129 & nrow1,
1130 & 0,
1131 & iw(irow_l),
1132 & perm, nvschur_k253 )
1133 ENDIF
1134 ENDIF
1135 IF (iflag.LT.0) GOTO 700
1136#if defined(BLR_MT)
1137!$OMP PARALLEL
1138#endif
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 IF (iflag.LT.0) GOTO 650
1159 IF ( (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
1160 & nfs4father.GT.0 ) 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 IF (iflag.LT.0) 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 IF (npiv.GT.0) THEN
1198 IF (.NOT.keep_begs_blr_ls) THEN
1199 IF (associated(begs_blr_ls)) DEALLOCATE(begs_blr_ls)
1200 ENDIF
1201 IF (.NOT.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 IF (.NOT.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
#define mumps_abort
Definition VE_Metis.h:25
subroutine dmumps_bdc_error(myid, slavef, comm, keep)
Definition dbcast_int.F:38
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
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)
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)
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)
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)
recursive subroutine dmumps_end_facto_slave(comm_load, ass_irecv, n, inode, fpere, root, myid, comm bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la, ptrist, ptlust_s, ptrfac, ptrast, step, pimaster, pamaster, nstk, comp, iflag, ierror, perm, ipool, lpool, leaf, nbfin, slavef, 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, lrgroups)
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)
subroutine dmumps_ooc_io_lu_panel_i(strat, typefile, afac, lafac, monbloc, lnextpiv2bewritten, unextpiv2bewritten, iw, liwfac, myid, filesize, ierr, last_call)
Definition dtools.F:1854
subroutine dmumps_compute_nbrowsinf(n, inode, ifath, keep, ioldps, hf, iw, liw, nrows, ncols, npiv, nelim, nfs4father, nbrowsinf)
Definition dtools.F:1584
subroutine dmumps_compress_panel_i_noopt(a, la, poselt, iflag, ierror, nfront, begs_blr, sizebegs_blr, nb_blr, toleps, tol_opt, k473, blr_panel, current_blr, dir, work, tau, jpvt, lwork, rwork, block, maxi_cluster, nelim, lbandslave, npiv, ishift, niv, kpercent, keep8, omp_num)
Definition dtools.F:2008
subroutine dmumps_blr_slv_upd_trail_ldlt_i(a, la, poselt, iflag, ierror, ncol, nrow, a_blocfacto, la_blocfacto, ld_blocfacto, begs_blr_lm, sizebegs_blr_lm, nb_blr_lm, blr_lm, ishift_lm, begs_blr_ls, sizebegs_blr_ls, nb_blr_ls, blr_ls, ishift_ls, current_blr_lm, current_blr_ls, iw2, block, maxi_cluster, omp_num, midblk_compress, toleps, tol_opt, kpercent)
Definition dtools.F:2106
subroutine dmumps_blr_upd_nelim_var_l_i(a_u, la_u, upos, a_l, la_l, lpos, iflag, ierror, ldu, ldl, begs_blr_l, sizebegs_blr_l, current_blr, blr_l, nb_blr_l, first_block, nelim, utrans)
Definition dtools.F:2075
subroutine dmumps_decompress_panel_i_noopt(a, la, poselt, lda11, lda21, copy_dense_blocks, begs_blr_diag, begs_blr_first_offdiag, nb_blr, blr_panel, current_blr, dir, decomp_timer)
Definition dtools.F:2050
subroutine dmumps_compress_cb_i(a_ptr, la_ptr, poselt, lda, begs_blr, sizebegs_blr, begs_blr_u, sizebegs_blr_u, nb_rows, nb_cols, nb_inasm, nrows, ncols, inode, iwhandler, sym, niv, iflag, ierror, toleps, tol_opt, kpercent, k489, cb_lrb, work, tau, jpvt, lwork, rwork, block, maxi_cluster, keep8, omp_num, nfs4father, npiv, nvschur_k253, keep, m_array, nelim, nbrowsinf)
Definition dtools.F:1957
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
subroutine dswap(n, dx, incx, dy, incy)
DSWAP
Definition dswap.f:82
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181
#define min(a, b)
Definition macros.h:20
#define max(a, b)
Definition macros.h:21
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
subroutine get_cut(iwr, nass, ncb, lrgroups, npartscb, npartsass, cut)
Definition dana_lr.F:25
subroutine, public dmumps_buf_send_1int(i, dest, tag, comm, keep, ierr)
subroutine, public dmumps_buf_send_blfac_slave(inode, npiv, fpere, iposk, jposk, uip21k, ncolu, ndest, pdest, comm, keep, lr_activated, blr_ls, ipanel, a, la, posblocfacto, ld_blocfacto, ipiv, maxi_cluster, ierr)
subroutine dmumps_dm_set_dynptr(cb_state, a, la, pamaster_or_ptrast, ixxd, ixxr, son_a, iachk, recsize)
subroutine dmumps_get_size_schur_in_front(n, ncb, size_schur, row_indices, perm, nvschur)
subroutine dmumps_blr_panel_lrtrsm(a, la, poselt, nfront, ibeg_block, nb_blr, blr_loru, current_blr, first_block, last_block, niv, sym, loru, lbandslave, iw, offset_iw, nass)
Definition dfac_lr.F:2437
subroutine, public dmumps_load_mem_update(ssarbr, process_bande_arg, mem_value, new_lu, inc_mem_arg, keep, keep8, lrlus)
double precision, save, private alpha
Definition dmumps_load.F:55
integer, save, private myid
Definition dmumps_load.F:57
subroutine, public dmumps_load_update(check_flops, process_bande, inc_load, keep, keep8)
subroutine regrouping2(cut, npartsass, nass, npartscb, ncb, ibcksz, onlycb, k472)
Definition dlr_core.F:184
subroutine max_cluster(cut, cut_size, maxi_cluster)
Definition dlr_core.F:1304
subroutine, public dmumps_blr_retrieve_nfs4father(iwhandler, nfs4father)
subroutine, public dmumps_blr_retrieve_begs_blr_c(iwhandler, begs_blr_col, nb_panels)
subroutine, public dmumps_blr_retrieve_begs_blr_l(iwhandler, begs_blr_l)
subroutine, public dmumps_blr_save_init(iwhandler, issym, ist2, isslave, nb_panels, begs_blr_l, begs_blr_col, nb_accesses_init, info)
subroutine, public dmumps_blr_save_cb_lrb(iwhandler, cb_lrb)
subroutine, public dmumps_blr_dec_and_tryfree_l(iwhandler, ipanel, keep8, k34)
subroutine, public dmumps_blr_save_m_array(iwhandler, m_array, info)
subroutine, public dmumps_blr_save_panel_loru(iwhandler, loru, ipanel, lrb_panel)
subroutine upd_mry_lu_lrgain(blr_panel, nbblocks)
Definition dlr_stats.F:452
subroutine stats_compute_flop_slave_type2(nrow1, ncol1, nass1, keep50, inode)
Definition dlr_stats.F:479
subroutine upd_flop_frfront_slave(nrow1, ncol1, nass1, keep50, inode)
Definition dlr_stats.F:512
subroutine dealloc_blr_panel(blr_panel, iend, keep8, k34, ibeg_in)
Definition dlr_type.F:56
integer, public strat_try_write
integer, public typef_l
int comp(int a, int b)
integer function mumps_procnode(procinfo_inode, k199)
subroutine mumps_set_ierror(size8, ierror)