15 & COMM_LOAD, ASS_IRECV,
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,
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
46 include
'mumps_headers.h'
47 TYPE (cmumps_root_struc) :: root
48 INTEGER icntl( 60 ), keep( 500 )
51 INTEGER comm_load, ass_irecv
52 INTEGER lbufr, lbufr_bytes
54 INTEGER n, slavef, iwpos, iwposcb, liw
55 INTEGER(8) iptrlu, lrlu, lrlus, la, posfac
57 INTEGER iflag, ierror, nbfin, msgsou
58 INTEGER procnode_steps(keep(28)), ptrist(keep(28)),
60 INTEGER(8) ptrast(keep(28)), ptrfac(keep(28)), pamaster(keep(28))
61 INTEGER perm(n), step(n),
65 INTEGER,
intent(in) :: lrgroups(n)
67 INTEGER frtptr( n+1 ), frtelt( nelt )
69 INTEGER ptlust_s(keep(28)),
70 & itloc(n+keep(253)), fils(n), dad(keep(28)), nd(keep(28))
71 COMPLEX :: 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 COMPLEX dblarr( keep8(26) )
79 INTEGER ipool( lpool )
80 INTEGER istep_to_iniv2(keep(71)),
81 & tab_pos_in_pere(slavef+2,
max(1,keep(56)))
83 INTEGER (8) pospv1,pospv2,offdag,lpos1
85 COMPLEX mult1,mult2, a11, detpiv, a22, a12
86 INTEGER :: nfs4father, nvschur_k253, nslaves_l, irow_l
87 REAL,
ALLOCATABLE,
DIMENSION(:) :: m_array
90 include
'mumps_tags.h'
91 INTEGER :: status(mpi_status_size)
93 INTEGER inode, position, npiv, ierr
95 INTEGER(8) :: posblocfacto
96 INTEGER :: ld_blocfacto
97 INTEGER(8) :: la_blocfacto
100 COMPLEX,
DIMENSION(:),
POINTER :: a_ptr
101 INTEGER ioldps, lcont1, nass1, nrow1, ncol1, npiv1
102 INTEGER nslav1, hs, isw, dest
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 COMPLEX,
DIMENSION(:),
ALLOCATABLE :: uip21k
111 COMPLEX,
DIMENSION(:),
ALLOCATABLE :: dyn_blocfacto
112 INTEGER,
DIMENSION(:),
ALLOCATABLE :: list_slaves_follow
113 INTEGER,
DIMENSION(:),
ALLOCATABLE :: dyn_pivinfo
116 LOGICAL blocking, set_irecv, message_received
118 parameter(one=(1.0e0,0.0e0),
alpha=(-1.0e0,0.0e0))
119 INTEGER liwfac, strat, nextpivdummy
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 COMPLEX,
ALLOCATABLE,
DIMENSION(:) :: work, tau
142 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: jpvt
143 COMPLEX,
ALLOCATABLE,
DIMENSION(:,:) :: blocklr
144 REAL,
ALLOCATABLE,
DIMENSION(:) :: rwork
145 INTEGER :: omp_num, lwork
146 INTEGER :: ii,jj, shift
150 IF (icntl(4) .LE. 0) lp = -1
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 )
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 )
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 )
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 )
183 keep_begs_blr_ls =.false.
184 keep_begs_blr_col =.false.
186 IF ( lr_activated )
THEN
187 la_blocfacto = int(npiv,8) * int(npiv+nelim,8)
188 ld_blocfacto =
max(npiv+nelim,1)
190 la_blocfacto = int(npiv,8) * int(ncol,8)
191 ld_blocfacto =
max(ncol,1)
193 IF (lr_activated)
THEN
194 dynamic_alloc = .true.
196 dynamic_alloc = .false.
198 IF ( .NOT. dynamic_alloc )
THEN
199 IF ( npiv .EQ. 0 )
THEN
204 & npiv, la_blocfacto, .false.,
208 & iwpos, iwposcb, ptrist, ptrast,
209 & step, pimaster, pamaster, lrlus,
210 & keep(ixsz),
comp,dkeep(97),
211 &
myid, slavef, procnode_steps, dad,
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
224 & la-lrlus,0_8,la_blocfacto,keep,keep8,lrlus)
227 ALLOCATE(dyn_pivinfo(
max(1,npiv)),
228 & dyn_blocfacto(
max(1_8,la_blocfacto)),
230 IF (allocok.GT.0)
THEN
231 IF (lp > 0 )
WRITE(lp,*)
myid,
232 &
": ALLOCATION FAILURE FOR DYN_PIVINFO and DYN_BLOCFACTO IN ",
233 &
"CMUMPS_PROCESS_SYM_BLOCFACTO"
242 IF (dynamic_alloc)
THEN
245 & mpi_integer, comm, ierr )
249 & mpi_integer, comm, ierr )
251 IF (dynamic_alloc)
THEN
253 & dyn_blocfacto, int(la_blocfacto),
258 & a(posblocfacto), int(la_blocfacto),
262 IF ( lr_activated )
THEN
264 & nb_blr_lm, 1, mpi_integer,
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 &
"CMUMPS_PROCESS_SYM_BLOCFACTO"
272 ierror =
max(nb_blr_lm,1)
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 &
"CMUMPS_PROCESS_SYM_BLOCFACTO"
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
293 & mpi_integer, comm, ierr )
294 IF (ptrist(step( inode )) .EQ. 0)
THEN
298 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
299 & iwpos, iwposcb, iptrlu,
300 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
302 & ptrast, step, pimaster, pamaster, nstk_s,
comp,
303 & iflag, ierror, comm,
304 & perm, ipool, lpool, leaf, nbfin,
myid, slavef,
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.
313 IF ( iflag .LT. 0 )
GOTO 600
315 IF ( iw( ptrist(step(inode)) + 3 + keep(ixsz)) .EQ. 0 )
THEN
316 DO WHILE ( iw(ptrist(step(inode)) + xxnbpr) .NE. 0)
319 message_received = .false.
321 & ass_irecv, blocking, set_irecv, message_received,
322 & mpi_any_source, contrib_type2,
324 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
325 & iwpos, iwposcb, iptrlu,
326 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
328 & ptrast, step, pimaster, pamaster, nstk_s,
comp,
329 & iflag, ierror, comm,
330 & perm, ipool, lpool, leaf, nbfin,
myid, slavef,
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
336 & istep_to_iniv2, tab_pos_in_pere, .true.
339 IF ( iflag .LT. 0 )
GOTO 600
344 message_received = .true.
346 & blocking, set_irecv, message_received,
347 & mpi_any_source, mpi_any_tag,
349 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
350 & iwpos, iwposcb, iptrlu,
351 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
353 & ptrast, step, pimaster, pamaster, nstk_s,
comp,
354 & iflag, ierror, comm,
355 & perm, ipool, lpool, leaf, nbfin,
myid, slavef,
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.
364 ioldps = ptrist(step(inode))
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.
375 IF ( nass1 < 0 )
THEN
377 iw( ioldps + 1 + keep(ixsz)) = nass1
378 IF (keep(55) .EQ. 0)
THEN
380 & ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
382 & ptrarw, intarr, dblarr, keep8(27), keep8(26), rhs_mumps,
386 & ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
388 & ptrarw, intarr, dblarr, keep8(27), keep8(26),
389 & frtptr, frtelt, rhs_mumps, lrgroups)
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
399 to_update_cpt_end = ( nslaves_tot - nslaves_follow - 1 ) *
403 ict11 = ioldps+hs+nrow1+npiv1 - 1
405 IF (dynamic_alloc)
THEN
406 pivi = abs(dyn_pivinfo(i))
408 pivi = abs(iw(ipiv+i-1))
412 iw(ict11+i) = iw(ict11+pivi)
414 ipos = poselt + int(npiv1 + i - 1,8)
415 kpos = poselt + int(npiv1 + pivi - 1,8)
416 CALL cswap(nrow1, a_ptr(ipos), ncol1, a_ptr(kpos), ncol1)
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 CMUMPS_PROCESS_SYM_BLOCFACTO"
424 ierror = npiv * nrow1
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 CMUMPS_PROCESS_SYM_BLOCFACTO"
437 IF ( nslaves_follow .NE. 0 .and. npiv .NE. 0 )
THEN
438 ALLOCATE( list_slaves_follow( nslaves_follow ),
440 IF ( allocok .GT. 0 )
THEN
441 IF (lp > 0 )
WRITE(lp,*)
myid,
442 &
": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW
443 & IN CMUMPS_PROCESS_SYM_BLOCFACTO"
445 ierror = nslaves_follow
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)
452 IF ((.NOT. lr_activated).OR.keep(475).EQ.0)
THEN
453 IF (dynamic_alloc)
THEN
454 CALL ctrsm(
'L',
'U',
'T',
'U', npiv, nrow1, one
455 & dyn_blocfacto, ld_blocfacto,
456 & a_ptr(poselt+int(npiv1,8)), ncol1)
458 CALL ctrsm(
'L',
'U',
'T',
'U', npiv, nrow1, one,
459 & a( posblocfacto ), ld_blocfacto,
460 & a_ptr(poselt+int(npiv1,8)), ncol1)
463 IF (.NOT.lr_activated)
THEN
464 lpos = poselt + int(npiv1,8)
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)
473 IF ((.NOT. lr_activated).OR.keep(475).EQ.0)
THEN
474 lpos = poselt + int(npiv1,8)
475 IF (dynamic_alloc)
THEN
483 IF (dynamic_alloc)
THEN
484 pivi = dyn_pivinfo(i)
489 IF (dynamic_alloc)
THEN
490 a11 = one/dyn_blocfacto(dpos)
494 CALL cscal( nrow1, a11, a_ptr(lpos), ncol1 )
496 dpos = dpos + int(ld_blocfacto + 1,8)
500 pospv2 = dpos+ int(ld_blocfacto + 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
508 a11 = dyn_blocfacto(pospv2)/detpiv
514 detpiv = a11*a22 - a12**2
516 a11 = a(pospv2)/detpiv
521 mult1 = a11*a_ptr(lpos1)+a12*a_ptr(lpos1+1_8)
522 mult2 = a12*a_ptr(lpos1)+a22*a_ptr(lpos1+1_8)
524 a_ptr(lpos1+1_8) = mult2
525 lpos1 = lpos1 + int(ncol1,8)
528 dpos = pospv2 + int(ld_blocfacto + 1,8)
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))
540 IF (compress_cb.AND.npiv.EQ.0)
THEN
541 compress_cb = .false.
542 iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
548 IF (lr_activated)
THEN
552 keep_begs_blr_ls = .true.
553 nb_blr_ls =
size(begs_blr_ls) - 2
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))
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
568 CALL get_cut(iw(ioldps+hs+nrow1:ioldps+hs+nrow1+ncol1
570 & ncol1-nass1, lrgroups, npartscb_col,
571 & npartsass_col, begs_blr_col)
572 CALL regrouping2(begs_blr_col, npartsass_col, nass1,
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
579 shift = npartsass_col-npartsass_master
580 ALLOCATE(begs_blr_col_tmp(
size(begs_blr_col)-shift),
582 IF ( allocok .GT. 0 )
THEN
583 IF (lp > 0 )
WRITE(lp,*)
myid,
584 &
": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in",
585 &
"CMUMPS_PROCESS_SYM_BLOCFACTO"
587 ierror =
size(begs_blr_col)-shift
590 DO ii= 1,
size(begs_blr_col)-shift
591 begs_blr_col_tmp(ii) = begs_blr_col(ii+shift)
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
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
606 CALL max_cluster(begs_blr_col,nb_blr_col,maxi_cluster_col)
607 maxi_cluster =
max(maxi_cluster,maxi_cluster_col
609 NULLIFY(begs_blr_col)
615 IF (nslaves_prec.GT.0)
THEN
616 nb_accesses_init=nslaves_prec+1
618 IF ( (keep(486).EQ.2)
620 nb_accesses_init = huge(npartsass_master)
624 IF (iflag.LT.0)
GOTO 700
626 & .true., .true., .true., npartsass_col,
627 & begs_blr_ls, begs_blr_col, nb_accesses_init,
631 IF (iflag.LT.0)
GOTO 700
633 lwork = maxi_cluster*maxi_cluster
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),
644 IF (allocok > 0 )
THEN
646 ierror = omp_num*(lwork + maxi_cluster*(maxi_cluster+4))
650 ALLOCATE(blr_ls(nb_blr_ls), stat=allocok)
651 IF (allocok > 0 )
THEN
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),
665 & current_blr,
'V', work, tau, jpvt, lwork, rwork,
666 & blocklr, maxi_cluster, nelim,
669 & 2, keep(483), keep8,
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,
681 & blr_ls, current_blr, current_blr
684 & dyn_pivinfo, offset_iw=1)
687 & ld_blocfacto, -6666,
689 & blr_ls, current_blr, current_blr+1, nb_blr_ls+1,
692 & iw, offset_iw=ipiv)
697 IF (keep(486).NE.2)
THEN
699 & a_ptr(poselt), la_ptr, 1_8,
704 & nb_blr_ls+1, blr_ls(1), current_blr,
'V', 1)
711 IF (iflag.LT.0)
GOTO 700
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.
722 monbloc%LastPiv = npiv1 + npiv
723 monbloc%LastPanelWritten_L = -9999
724 monbloc%LastPanelWritten_U = -9999
725 NULLIFY(monbloc%INDICES)
726 monbloc%Last = lastbl
729 liwfac = iw(ioldps+xxi)
733 & la_ptr, monbloc, nextpivdummy, nextpivdummy,
734 & iw(ioldps), liwfac,
myid, keep8(31), iflag,last_call)
737 IF (lr_activated)
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')
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')
763 IF (dynamic_alloc)
THEN
765 & a_ptr(poselt), la_ptr, 1_8,
766 & iflag, ierror, ncol1, nrow1,
767 & dyn_blocfacto, la_blocfacto,
769 & begs_blr_lm(1),
size(begs_blr_lm), nb_blr_lm+1,
771 & begs_blr_ls(1),
size(begs_blr_ls), nb_blr_ls+1,
773 & current_blr, current_blr,
776 & maxi_cluster, omp_num,
777 & keep(481), dkeep(11), keep(466), keep(477)
781 & a_ptr(poselt), la_ptr, 1_8,
782 & iflag, ierror, ncol1, nrow1,
783 & a(posblocfacto), la_blocfacto,
785 & begs_blr_lm(1),
size(begs_blr_lm), nb_blr_lm+1,
787 & begs_blr_ls(1),
size(begs_blr_ls), nb_blr_ls+1,
789 & current_blr, current_blr,
792 & maxi_cluster, omp_num,
793 & keep(481), dkeep(11), keep(466), keep(477)
796 IF (iflag.LT.0)
GOTO 400
801 IF (iflag.LT.0)
GOTO 700
806 IF (nslaves_prec.GT.0
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
824 CALL cgemm('n
','n
', NCOL-NPIV, NROW1, NPIV,
825 & ALPHA, DYN_BLOCFACTO(UPOS), NCOL,
826 & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1)
828 UPOS = POSBLOCFACTO+int(NPIV,8)
829 CALL cgemm('n
','n
', NCOL-NPIV, NROW1, NPIV,
830 & ALPHA,A(UPOS), NCOL,
831 & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1)
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)
839 CALL cgemmt( 'u
', 't
', 'n
', NROW1, NPIV, ALPHA,
840 & UIP21K( UPOS ), NPIV,
841 & A_PTR( LPOS2 ), NCOL1, ONE,
842 & A_PTR( DPOS ), NCOL1 )
845.GT.
IF ( NROW1 KEEP(7) ) THEN
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
859 CALL cgemv( '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 )
864.ne.
IF ( NROW1-IROW+1-Block 0 )
865 & CALL cgemm( 't
', 'n
', Block, NROW1-IROW+1-Block,
867 & UIP21K( UPOS ), NPIV,
868 & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1,
870 & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 )
873#if defined(GEMMT_AVAILABLE)
877 FLOP1 = dble(NROW1) * dble(NPIV) *
878 & dble( 2 * NCOL - NPIV + NROW1 +1 )
880 CALL CMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 )
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)
892 LRLU = LRLU + LA_BLOCFACTO
893 LRLUS = LRLUS + LA_BLOCFACTO
894 KEEP8(69) = KEEP8(69) - LA_BLOCFACTO
895 POSFAC = POSFAC - LA_BLOCFACTO
897 CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
898 & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
901.NE..and..NE.
IF ( NSLAVES_FOLLOW 0 NPIV 0 ) THEN
903 JPOSK = NCOL1 - NROW1 + 1
906.eq.
DO WHILE ( IERR -1 )
907 IF (DYNAMIC_ALLOC) THEN
908 CALL CMUMPS_BUF_SEND_BLFAC_SLAVE(
909 & INODE, NPIVSENT, FPERE,
913 & LIST_SLAVES_FOLLOW(1),
915 & LR_ACTIVATED, BLR_LS, IPANEL,
916 & DYN_BLOCFACTO, LA_BLOCFACTO,
918 & DYN_PIVINFO, MAXI_CLUSTER,
921 CALL CMUMPS_BUF_SEND_BLFAC_SLAVE(
922 & INODE, NPIVSENT, FPERE,
926 & LIST_SLAVES_FOLLOW(1),
928 & LR_ACTIVATED, BLR_LS, IPANEL,
930 & POSBLOCFACTO, LD_BLOCFACTO,
931 & IW(IPIV), MAXI_CLUSTER,
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
941 COUNTER_WAS_HUGE=.FALSE.
943 TO_UPDATE_CPT_RECUR =
944 & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) *
946 IW(IOLDPS+6+KEEP(IXSZ)) =
947 & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10
950 MESSAGE_RECEIVED = .FALSE.
951 CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV,
952 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
953 & MPI_ANY_SOURCE, MPI_ANY_TAG,
955 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
956 & IWPOS, IWPOSCB, IPTRLU,
957 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
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.
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)))
976.LT.
IF ( IFLAG 0 ) GOTO 600
979.eq.
IF ( IERR -2 ) THEN
980 IF (LP > 0 ) WRITE(LP,*) MYID,
981 &": FAILURE, SEND BUFFER TOO SMALL DURING
982 & CMUMPS_PROCESS_SYM_BLOCFACTO"
983 WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1
985 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35)
988.eq.
IF ( IERR -3 ) THEN
989 IF (LP > 0 ) WRITE(LP,*) MYID,
990 &": FAILURE, RECV BUFFER TOO SMALL DURING
991 & CMUMPS_PROCESS_SYM_BLOCFACTO"
993 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35)
996 DEALLOCATE(LIST_SLAVES_FOLLOW)
998 IF ( LR_ACTIVATED ) THEN
999.GT..AND..GT.
IF (NPIV0 NSLAVES_PREC0
1000.AND..EQ.
& KEEP(486)3
1002 IOLDPS = PTRIST(STEP(INODE))
1003 CALL CMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL,
1006 IF (DYNAMIC_ALLOC) THEN
1007 IF (allocated(DYN_PIVINFO)) DEALLOCATE(DYN_PIVINFO)
1008 IF (allocated(DYN_BLOCFACTO)) THEN
1009 DEALLOCATE(DYN_BLOCFACTO)
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 CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
1018 & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
1021.NE.
IF ( NPIV 0 ) THEN
1022 IF (allocated(UIP21K)) THEN
1023 DEALLOCATE( UIP21K )
1026 IOLDPS = PTRIST(STEP(INODE))
1027 CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA,
1028 & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR),
1029 & A_PTR, POSELT, LA_PTR )
1031.NE.
IF ( KEEP(486) 0) THEN
1032 IF (LR_ACTIVATED) THEN
1033 CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1,
1036 CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1,
1040.EQ.
IF ( IW(IOLDPS+6+KEEP(IXSZ))
1041 & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN
1042 IW(IOLDPS+6+KEEP(IXSZ)) = 1
1044 IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ))
1045 & - TO_UPDATE_CPT_END
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)),
1052 CALL CMUMPS_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.
'
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),
1068 IF (allocok > 0) THEN
1070 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL)
1074 DO JJ=1,NB_BLR_COL-NPARTSASS_COL
1077 NULLIFY(CB_LRB(II,JJ)%Q)
1078 NULLIFY(CB_LRB(II,JJ)%R)
1079 CB_LRB(II,JJ)%ISLR = .FALSE.
1082 CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB)
1084 IF (COMPRESS_CB) THEN
1086.NE..AND..EQ.
IF ( (KEEP(219)0)(KEEP(50)2) ) THEN
1087 CALL CMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF),
1089 NFS4FATHER = max(NFS4FATHER,0) + NELIM
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 & "CMUMPS_PROCESS_SYM_BLOCFACTO"
1097 IERROR = max(1,NFS4FATHER)
1099 BEGS_BLR_COL(1+NPARTSASS_COL) =
1100 & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM
1103.NE..AND..EQ..AND.
IF ( (KEEP(219)0)(KEEP(50)2)
1104.GT.
& NFS4FATHER0 ) THEN
1105 CALL CMUMPS_COMPUTE_NBROWSinF (
1106 & N, INODE, FPERE, KEEP,
1109 & NROW1, NCOL1, NPIV+NPIV1,
1110 & NELIM, NFS4FATHER,
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 +
1117 CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT (
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 +
1127 CALL CMUMPS_GET_SIZE_SCHUR_IN_FRONT (
1132 & PERM, NVSCHUR_K253 )
1135.LT.
IF (IFLAG0) GOTO 700
1139 CALL CMUMPS_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,
1145 & NROW1, NCOL1-NPIV1-NPIV, INODE,
1146 & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR,
1147 & DKEEP(12), KEEP(466), KEEP(484), KEEP(489),
1149 & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR,
1150 & MAXI_CLUSTER, KEEP8, OMP_NUM,
1151 & NFS4FATHER, NPIV1+NPIV, NVSCHUR_K253, KEEP(1),
1153 & , NELIM, NBROWSinF
1158.LT.
IF (IFLAG0) GOTO 650
1159.NE..AND..EQ..AND.
IF ( (KEEP(219)0)(KEEP(50)2)
1160.GT.
& NFS4FATHER0 ) THEN
1162 INFO_TMP(2) = IERROR
1163 CALL CMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF),
1164 & M_ARRAY, INFO_TMP)
1166 IERROR = INFO_TMP(2)
1171.LT.
IF (IFLAG0) GOTO 700
1173 CALL CMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV,
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,
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
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)
1198.NOT.
IF (KEEP_BEGS_BLR_LS) THEN
1199 IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS)
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)
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)
1218 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )