15 & BUFR, LBUFR, LBUFR_BYTES,
17 & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE,
18 & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW,
19 & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU,
22 & PTRIST, PTLUST, PTRFAC,
23 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP,
24 & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF,
25 & NBFIN, ICNTL, KEEP,KEEP8,DKEEP,
26 & root, OPASSW, OPELIW,
28 & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE,
29 & LPTRAR, NELT, FRTPTR, FRTELT,
31 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
39#if ! defined(NO_FDM_MAPROW)
44#if ! defined(NO_FDM_MAPROW)
46 TYPE (dmumps_root_struc ) :: root
47 INTEGER lbufr, lbufr_bytes
48 INTEGER icntl( 60 ), keep(500)
50 DOUBLE PRECISION dkeep(230)
51 INTEGER comm_load, ass_irecv
54 INTEGER(8) :: la, iptrlu, lrlu, lrlus, posfac
55 INTEGER iwpos, iwposcb
58 DOUBLE PRECISION a( la )
59 INTEGER,
intent(in) :: lrgroups(n)
60 INTEGER(8) :: ptrfac(keep(28))
61 INTEGER(8) :: ptrast(keep(28))
62 INTEGER(8) :: pamaster(keep(28))
63 INTEGER ptrist(keep(28)), ptlust(keep(28))
64 INTEGER step(n), pimaster((28))
65 INTEGER procnode_steps( keep(28) )
67 INTEGER nstk( keep(28) )
69 INTEGER iflag, ierror, comm,
myid
71 INTEGER ipool( lpool )
72 INTEGER inode_pere, ison
74 INTEGER nbrows_already_sent
75 INTEGER nslaves_pere, nfront_pere, nass_pere
76 INTEGER list_slaves_pere( * )
79 DOUBLE PRECISION opassw, opeliw
80 DOUBLE PRECISION dblarr(keep8(26))
81 INTEGER intarr(keep8(27))
83 INTEGER frtptr( n+1 ), frtelt( nelt )
84 INTEGER itloc( n+keep(253) ), fils( ), dad( keep(28) )
85 DOUBLE PRECISION :: rhs_mumps(keep(255))
86 INTEGER(8),
INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
87 INTEGER nd( keep(28) ), frere( keep(28) )
88 INTEGER istep_to_iniv2(keep(71)),
89 & tab_pos_in_pere(slavef+2,
max(1,keep(56)))
91 include
'mumps_tags.h'
93 INTEGER :: status(mpi_status_size)
95 INTEGER i_posmyidin_pere
97 INTEGER pdest, pdest_master
98 LOGICAL :: local_assembly_to_be_done
100 INTEGER pdest_master_ison, ipos_in_slave
101 LOGICAL desclu, slave_ison
102 LOGICAL , set_irecv, message_received
103 INTEGER msgsou, msgtag
106 LOGICAL is_error_broadcasted, is_oftype5or6
107 INTEGER itype_son, typesplit
108 INTEGER :: keep253_loc
109 INTEGER :: nvschur, nslaves_l, nrow_l, irow_l, nass_l, nelim_l
111 INTEGER :: iwxxf_handler
112 DOUBLE PRECISION :: adummy(1)
113 DOUBLE PRECISION,
POINTER,
DIMENSION(:) :: son_a
114 INTEGER(8) :: iachk, recsize
115#if ! defined(NO_FDM_MAPROW)
116 INTEGER :: info_tmp(2)
118 include
'mumps_headers.h'
121 INTEGER lmap_loc, allocok
122 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: nbrow
123 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: slaves_pere
124 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: map, perm_loc
125 is_error_broadcasted = .false.
130 is_oftype5or6 = ((typesplit.EQ.5).OR.(typesplit.EQ.6))
132 IF (icntl(4) .LE. 0) lp = -1
133 cb_is_lr = (iw(ptrist(step(ison))+xxlr).EQ.1 .OR.
134 & iw(ptrist(step(ison))+xxlr).EQ.3)
135 iwxxf_handler = iw(ptrist(step(ison))+xxf)
136#if ! defined(NO_FDM_MAPROW)
138 ALLOCATE(slaves_pere(0:
max(1,nslaves_pere)), stat=allocok)
139 if (allocok .GT. 0)
THEN
142 &
' : PB allocation SLAVES_PERE in DMUMPS_MAPLIG'
145 ierror = nslaves_pere+1
148 IF (nslaves_pere.GT.0)
149 &slaves_pere(1:nslaves_pere) = list_slaves_pere(1:nslaves_pere)
150 slaves_pere(0) =
mumps_procnode( procnode_steps(step(inode_pere)),
152 ALLOCATE(nbrow(0:nslaves_pere), stat=allocok)
153 if (allocok .GT. 0)
THEN
156 &
' : PB allocation NBROW in DMUMPS_MAPLIG'
159 ierror = nslaves_pere+1
163 ALLOCATE(map(lmap_loc), stat=allocok)
164 if (allocok .GT. 0)
THEN
166 write(lp,*)
myid,
' : PB allocation LMAP in DMUMPS_MAPLIG'
172 map( 1 : lmap ) = trow( 1 : lmap )
175 slave_ison = pdest_master_ison .NE.
myid
177 IF ( ptrist(step( ison )) .EQ. 0 )
THEN
180 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
181 & iwpos, iwposcb, iptrlu,
182 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
184 & ptrast, step, pimaster, pamaster, nstk,
comp,
185 & iflag, ierror, comm,
187 & ipool, lpool, leaf,
188 & nbfin,
myid, slavef,
190 & root, opassw, opeliw, itloc, rhs_mumps,
191 & fils, dad, ptrarw, ptraiw,
192 & intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere, lptrar,
193 & nelt, frtptr, frtelt,
194 & istep_to_iniv2, tab_pos_in_pere, .true.
197 IF ( iflag .LT. 0 )
THEN
198 is_error_broadcasted = .true.
202#if ! defined(NO_FDM_MAPROW)
204 & ( iw( ptrist(step(ison)) + 1 + keep(ixsz) ) .NE.
205 & iw( ptrist(step(ison)) + 3 + keep(ixsz) ) ) .OR.
206 & ( keep(50) .NE. 0 .AND.
207 & iw( ptrist(step(ison)) + 6 + keep(ixsz) ) .NE. 0 ) )
211 & iw(ptrist(step(ison))+xxa),
212 & inode_pere, ison, nslaves_pere, nfront_pere,
213 & nass_pere, lmap, nfs4father,
214 & slaves_pere(1:nslaves_pere),
217 IF (info_tmp(1) < 0)
THEN
227 & ( iw( ptrist(step(ison)) + 1 + keep(ixsz) ) .NE.
228 & iw( ptrist(step(ison)) + 3 + keep(ixsz) ) ) .OR.
229 & ( keep(50) .NE. 0 .AND.
230 & iw( ptrist(step(ison)) + 6 + keep(ixsz) ) .NE. 0 ) )
231 IF ( keep(50).eq.0)
THEN
232 msgsou = pdest_master_ison
235 IF ( iw( ptrist(step(ison)) + 1 + keep(ixsz) ) .NE.
236 & iw( ptrist(step(ison)) + 3 + keep(ixsz) ) )
THEN
237 msgsou = pdest_master_ison
238 msgtag = bloc_facto_sym
240 msgsou = mpi_any_source
241 msgtag = bloc_facto_sym_slave
246 message_received = .false.
248 & ass_irecv, blocking, set_irecv, message_received,
251 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
252 & iwpos, iwposcb, iptrlu,
253 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
255 & ptrast, step, pimaster, pamaster, nstk,
comp,
256 & iflag, ierror, comm,
257 & perm, ipool, lpool, leaf, nbfin,
myid, slavef,
259 & root, opassw, opeliw, itloc, rhs_mumps,
260 & fils, dad, ptrarw, ptraiw,
261 & intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere, lptrar,
262 & nelt, frtptr, frtelt,
263 & istep_to_iniv2, tab_pos_in_pere, .true.
266 IF ( iflag .LT. 0 )
THEN
267 is_error_broadcasted = .true.
272#if ! defined(NO_FDM_MAPROW)
275 IF ( nslaves_pere .EQ. 0 )
THEN
276 nbrow( 0 ) = lmap_loc
278 DO i = 0, nslaves_pere
282 indice_pere = map( i )
284 & keep,keep8, inode_pere, step, n, slavef,
285 & istep_to_iniv2, tab_pos_in_pere,
288 & nfront_pere - nass_pere,
293 nbrow( nosla ) = nbrow( nosla ) + 1
295 DO i = 1, nslaves_pere
296 nbrow(i)=nbrow(i)+nbrow(i-1)
299 ALLOCATE(perm_loc(lmap_loc), stat=allocok)
300 IF (allocok .GT. 0)
THEN
302 write(lp,*)
myid,
': PB allocation PERM_LOC in DMUMPS_MAPLIG'
309 DO i = lmap_loc, 1, -1
310 indice_pere = map( i )
311 IF (indice_pere > nfront_pere - keep(253))
THEN
312 keep253_loc = keep253_loc + 1
315 & keep,keep8, inode_pere, step, n, slavef,
316 & istep_to_iniv2, tab_pos_in_pere,
319 & nfront_pere - nass_pere,
324 perm_loc( nbrow( nosla ) ) = i
325 nbrow( nosla ) = nbrow( nosla ) - 1
327 DO i = 0, nslaves_pere
330 IF ((keep(114).EQ.1) .AND. (keep(50).EQ.2) .AND.
331 & (keep(116).GT.0) .AND. ((lmap_loc-keep253_loc).GT.0)
333 IF (itype_son.EQ.1)
THEN
334 nelim_l = iw(ptlust(step(ison))+1+keep(ixsz))
336 & iw(ptlust(step(ison))+3+keep(ixsz))
337 irow_l = ptlust(step(ison))+6+keep(ixsz)+nass_l
341 nslaves_l = iw( ptrist(step( ison )) + 5 + keep(ixsz) )
342 irow_l = ptrist(step(ison)) + 6 + nslaves_l + keep(ixsz)
346 & nrow_l-keep253_loc,
353 pdest_master = slaves_pere(0)
354 i_posmyidin_pere = -99999
355 local_assembly_to_be_done = .false.
356 DO i = 0, nslaves_pere
357 IF (slaves_pere(i) .EQ.
myid)
THEN
359 local_assembly_to_be_done = .true.
360#if ! defined(NO_FDM_DESCBAND)
361 IF (ptrist(step(inode_pere)) .EQ. 0
362 & .AND.
myid .NE. pdest_master)
THEN
365 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
366 & iwpos, iwposcb, iptrlu,
367 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
369 & ptrast, step, pimaster, pamaster, nstk,
comp,
370 & iflag, ierror, comm,
371 & perm, ipool, lpool, leaf, nbfin,
myid, slavef,
373 & root, opassw, opeliw, itloc, rhs_mumps,
374 & fils, dad, ptrarw, ptraiw,
375 & intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere, lptrar,
376 & nelt, frtptr, frtelt,
377 & istep_to_iniv2, tab_pos_in_pere, .true.
380 IF ( iflag .LT. 0 )
THEN
381 is_error_broadcasted = .true.
388 IF (keep(120).NE.0 .AND. local_assembly_to_be_done)
THEN
390 & slaves_pere(i_posmyidin_pere),
391 &
myid, pdest_master, ison, inode_pere,
392 & nslaves_pere, nass_pere, nfront_pere, nfs4father,
393 & lmap_loc, map, nbrow, perm_loc,
394 & is_oftype5or6, iflag, ierror,
395 & n, slavef, keep, ipool, lpool, step,
396 & procnode_steps, comm_load, istep_to_iniv2, tab_pos_in_pere,
397 & keep8, iw, liw, a, la, lrlu, lrlus, iptrlu, iwposcb,
398 & ptrist, ptlust, ptrast, pamaster, pimaster, nd,
399 & nelt, frtptr, frtelt,
401 & itloc, rhs_mumps, keep253_loc, nvschur,
402 & fils, dad, lptrar, ptrarw, ptraiw, intarr, dblarr, icntl,
403 & itype_son, lrgroups)
404 local_assembly_to_be_done = .false.
409 DO i = nslaves_pere, 0, -1
410 pdest = slaves_pere( i )
411 IF ( pdest .NE.
myid )
THEN
413 nbrows_already_sent = 0
414 IF (i == nslaves_pere)
THEN
415 nrows_to_send=lmap_loc-nbrow(i)+1
417 nrows_to_send=nbrow(i+1)-nbrow(i)
419 packed_cb=(iw(ptrist(step(ison))+xxs).EQ.s_cb1comp)
421 DO WHILE (ierr .EQ. -1)
422 IF ( iw( ptrist(step(ison) )+keep(ixsz) )
423 & .GT. n + keep(253) )
THEN
424 WRITE(*,*)
myid,
': Internal error in Maplig'
425 WRITE(*,*)
myid,
': PTRIST(STEP(ISON))/N=',
426 & ptrist(step(ison)), n
427 WRITE(*,*)
myid,
': I, NBROW(I)=',i, nbrow(i)
428 WRITE(*,*)
myid,
': NSLAVES_PERE=',nslaves_pere
429 WRITE(*,*)
myid,
': ISON, INODE_PERE=',ison,inode_pere
430 WRITE(*,*)
myid,
': Son header=',
431 & iw(ptrist(step(ison)): ptrist(step(ison))+5+keep(ixsz))
434 IF (nrows_to_send .EQ. 0 .AND. pdest.NE.pdest_master)
THEN
440 & nbrows_already_sent,
441 & desclu, inode_pere,
442 & nfront_pere, nass_pere, nfs4father,
443 & nslaves_pere, ison,
444 & nrows_to_send, lmap_loc, map,
445 & perm_loc(
min(lmap_loc,nbrow(i))),
446 & iw( ptrist(step(ison))),
448 & i, pdest, pdest_master,
450 & keep,keep8, step, n, slavef,
451 & istep_to_iniv2, tab_pos_in_pere, packed_cb,
452 & keep253_loc, nvschur,
454 & npiv_check = iw(ptlust(step(ison))+3+keep(ixsz)))
457 & iw(ptrist(step(ison))+xxs),
459 & ptrast(step(ison)),
460 & iw(ptrist(step(ison))+xxd),
461 & iw(ptrist(step(ison))+xxr),
462 & son_a, iachk, recsize )
464 & desclu, inode_pere,
465 & nfront_pere, nass_pere, nfs4father,
466 & nslaves_pere, ison,
467 & nrows_to_send, lmap_loc, map,
468 & perm_loc(
min(lmap_loc,nbrow(i))),
469 & iw( ptrist(step(ison))),
470 & son_a(iachk:iachk+recsize-1_8),
472 & i, pdest, pdest_master,
474 & keep,keep8, step, n, slavef,
475 & istep_to_iniv2, tab_pos_in_pere, packed_cb,
476 & keep253_loc, nvschur,
479 IF ( ierr .EQ. -2 )
THEN
483 &
"FAILURE: SEND BUFFER TOO SMALL IN DMUMPS_MAPLIG"
485 ierror = (nrows_to_send + 3 )* keep( 34 ) +
486 & nrows_to_send * iw(ptrist(step(ison))+keep(ixsz))
490 IF ( ierr .EQ. -3 )
THEN
493 &
"FAILURE: RECV BUFFER TOO SMALL IN DMUMPS_MAPLIG"
496 ierror = (nrows_to_send + 3 )* keep( 34 ) +
497 & nrows_to_send * iw(ptrist(step(ison))+keep(ixsz))
501 IF (keep(219).NE.0)
THEN
502 IF ( ierr .EQ. -4 )
THEN
507 &
"FAILURE: MAX_ARRAY allocation failed IN DMUMPS_MAPLIG"
512 IF ( ierr .EQ. -1 )
THEN
513 IF (local_assembly_to_be_done)
THEN
515 & slaves_pere(i_posmyidin_pere),
516 &
myid, pdest_master, ison, inode_pere,
517 & nslaves_pere, nass_pere, nfront_pere, nfs4father,
518 & lmap_loc, map, nbrow, perm_loc,
519 & is_oftype5or6, iflag, ierror,
520 & n, slavef, keep, ipool, lpool, step,
521 & procnode_steps, comm_load, istep_to_iniv2,
523 & keep8, iw, liw, a, la, lrlu, lrlus, iptrlu, iwposcb,
524 & ptrist, ptlust, ptrast
525 & nelt, frtptr, frtelt,
527 & itloc, rhs_mumps, keep253_loc, nvschur,
529 & lptrar, ptrarw, ptraiw, intarr, dblarr, icntl,
530 & itype_son, lrgroups)
531 local_assembly_to_be_done = .false.
538 message_received = .false.
540 & ass_irecv, blocking, set_irecv, message_received,
541 & mpi_any_source, mpi_any_tag,
543 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
544 & iwpos, iwposcb, iptrlu,
545 & lrlu, lrlus, n, iw, liw, a, la,
546 & ptrist, ptlust, ptrfac,
547 & ptrast, step, pimaster, pamaster, nstk,
comp,
548 & iflag, ierror, comm,
549 & perm, ipool, lpool, leaf, nbfin,
myid, slavef,
551 & root, opassw, opeliw, itloc, rhs_mumps, fils, dad,
553 & intarr,dblarr,icntl,keep,keep8,dkeep,nd,frere,lptrar,
554 & nelt, frtptr, frtelt,
555 & istep_to_iniv2, tab_pos_in_pere, .true.
558 IF ( iflag .LT. 0 )
THEN
559 is_error_broadcasted=.true.
567 IF (local_assembly_to_be_done)
THEN
569 & slaves_pere(i_posmyidin_pere),
570 &
myid, pdest_master, ison, inode_pere,
571 & nslaves_pere, nass_pere, nfront_pere, nfs4father,
572 & lmap_loc, map, nbrow, perm_loc,
573 & is_oftype5or6, iflag, ierror,
574 & n, slavef, keep, ipool, lpool, step,
575 & procnode_steps, comm_load, istep_to_iniv2, tab_pos_in_pere,
576 & keep8, iw, liw, a, la, lrlu, lrlus, iptrlu, iwposcb,
577 & ptrist, ptlust, ptrast, pamaster, pimaster, nd,
578 & nelt, frtptr, frtelt,
580 & itloc, rhs_mumps, keep253_loc, nvschur,
581 & fils, dad, lptrar, ptrarw, ptraiw, intarr, dblarr, icntl,
582 & itype_son, lrgroups)
583 local_assembly_to_be_done = .false.
590 & .false., keep8, keep(34))
591 IF ((keep(486).EQ.3).OR.keep(486).EQ.0)
THEN
596 IF (keep(214) .EQ. 2)
THEN
598 & ptrist, ptrast, ptlust, ptrfac, iw, liw, a, la,
599 & lrlu, lrlus, iwpos, iwposcb, posfac,
comp,
600 & iptrlu, opeliw, step, pimaster, pamaster,
601 & iflag, ierror, slavef, procnode_steps, dad,
myid,
602 & comm, keep,keep8, dkeep, itype_son )
603 IF (iflag .LT. 0)
THEN
604 is_error_broadcasted = .true.
609 & a, la, lrlu, lrlus, iwposcb, iptrlu,
610 & step,
myid, keep, keep8, itype_son
618 DEALLOCATE(slaves_pere)
620 IF (iflag .LT. 0 .AND. .NOT. is_error_broadcasted)
THEN
626 & BUFR, LBUFR, LBUFR_BYTES,
628 & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE,
629 & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW,
630 & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU,
633 & PTRIST, PTLUST, PTRFAC,
634 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP,
635 & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF,
636 & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root,
637 & OPASSW, OPELIW, ITLOC, RHS_MUMPS,
638 & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR,
639 & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT,
641 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
655 TYPE (DMUMPS_ROOT_STRUC) :: root
656 INTEGER COMM_LOAD, ASS_IRECV
657 INTEGER ICNTL( 60 ), KEEP(500)
658 INTEGER(8) KEEP8(150)
659 DOUBLE PRECISION DKEEP(230)
660 INTEGER LBUFR, LBUFR_BYTES
661 INTEGER SLAVEF, NBFIN
662 INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC
663 INTEGER IWPOS, IWPOSCB
665 DOUBLE PRECISION A( LA )
666 INTEGER,
intent(in) :: LRGROUPS(N)
668 INTEGER IFLAG, IERROR, COMM, MYID
670 INTEGER INODE_PERE, ISON
672 DOUBLE PRECISION,
POINTER,
DIMENSION(:) :: M_ARRAY
673 LOGICAL :: M_ARRAY_RETRIEVED
674 INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE
675 INTEGER LIST_SLAVES_PERE(NSLAVES_PERE)
676 INTEGER NELIM, LMAP, TROW( ), NASS
677 DOUBLE PRECISION OPASSW, OPELIW
678 DOUBLE PRECISION DBLARR(KEEP8(26))
679 INTEGER INTARR(KEEP8(27))
682 INTEGER BUFR( LBUFR )
683 INTEGER IPOOL( LPOOL )
684 INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) )
686 INTEGER(8) :: PTRFAC(KEEP(28))
687 INTEGER(8) :: PTRAST(KEEP(28))
688 INTEGER(8) :: PAMASTER(KEEP(28))
689 INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)),
690 & STEP(N), PIMASTER(KEEP(28))
691 INTEGER PROCNODE_STEPS( KEEP(28) )
692 INTEGER FRTPTR( N+1 ), FRTELT( NELT )
693 INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) )
694 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
695 INTEGER(8),
INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
696 INTEGER ISTEP_TO_INIV2(KEEP(71)),
697 & tab_pos_in_pere(slavef+2,
max(1,keep
700 include
'mumps_tags.h'
702 INTEGER :: STATUS(MPI_STATUS_SIZE)
703 INTEGER NOSLA, I, ISTCHK, ISTCHK_LOC
704 INTEGER NBROWS_ALREADY_SENT
706 INTEGER INDICE_PERE_ARRAY_ARG(1)
707 INTEGER PDEST, PDEST_MASTER, NFRONT
708 LOGICAL SAME_PROC, DESCLU
709 INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE
710 DOUBLE PRECISION,
POINTER,
DIMENSION(:) :: SON_A
711 INTEGER(8) :: DYNSIZE
712 INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND,
713 & npiv, nrows_to_stack, ii, irow_son,
714 & ipos_in_slave, decr, itype_son
716 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
719 INTEGER,
POINTER,
DIMENSION(:) :: BEGS_BLR
720 INTEGER :: NB_BLR_COLS, NB_BLR_ROWS,
721 & nb_blr_shift, panel2decompress,
722 & current_panel_size, panel_beg_offset,
723 & nrows_already_stacked, nrows_to_stack_loc
724 INTEGER :: NVSCHUR, IROW_L
725 INTEGER(8) :: LA_TEMP
726 DOUBLE PRECISION :: ADummy(1)
727 DOUBLE PRECISION,
ALLOCATABLE :: A_TEMP(:)
728 TYPE (LRB_TYPE),
POINTER :: CB_LRB(:,:)
730 include
'mumps_headers.h'
731 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE
732 EXTERNAL mumps_procnode, mumps_typenode
733 INTEGER LMAP_LOC, allocok
734 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: NBROW
735 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: SLAVES_PERE
736 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: MAP, PERM_LOC
738 IF (icntl(4) .LE. 0) lp = -1
739 if (nslaves_pere.le.0)
then
740 write(6,*)
' error 2 in maplig_fils_niv1 ', nslaves_pere
743 ALLOCATE(nbrow(0:nslaves_pere), stat=allocok)
744 IF (allocok .GT. 0)
THEN
747 &
' : PB allocation NBROW in DMUMPS_MAPLIG_FILS_NIV1'
749 ierror = nslaves_pere+1
752 ALLOCATE(slaves_pere(0:nslaves_pere), stat =allocok)
753 IF ( allocok .GT. 0 )
THEN
754 IF (lp > 0)
write(lp,*) myid,
755 &
' : PB allocation SLAVES_PERE in DMUMPS_MAPLIG_FILS_NIV1'
757 ierror = nslaves_pere+1
760 slaves_pere(1:nslaves_pere) = list_slaves_pere(1:nslaves_pere)
761 slaves_pere(0) = mumps_procnode(
762 & procnode_steps(step(inode_pere)),
765 ALLOCATE(map(lmap_loc), stat=allocok)
766 if (allocok .GT. 0)
THEN
767 IF (lp > 0)
write(lp,*) myid,
768 &
' : PB allocation LMAP in DMUMPS_MAPLIG_FILS_NIV1'
773 map( 1 : lmap_loc ) = trow( 1 : lmap_loc )
774 DO i = 0, nslaves_pere
777 IF (nslaves_pere == 0)
THEN
781 indice_pere = map( i )
783 & keep,keep8, inode_pere, step, n, slavef,
784 & istep_to_iniv2, tab_pos_in_pere,
787 & nfront_pere - nass_pere,
792 nbrow( nosla ) = nbrow( nosla ) + 1
794 DO i = 1, nslaves_pere
795 nbrow(i)=nbrow(i)+nbrow(i-1)
798 ALLOCATE(perm_loc(lmap_loc), stat=allocok)
799 if (allocok .GT. 0)
THEN
802 &
': PB allocation PERM_LOC in DMUMPS_MAPLIG_FILS_NIV1'
808 istchk = pimaster(step(ison))
809 nbcols = iw(istchk+keep(ixsz))
810 DO i = lmap_loc, 1, -1
811 indice_pere = map( i )
813 & keep,keep8, inode_pere, step, n, slavef,
814 & istep_to_iniv2, tab_pos_in_pere,
817 & nfront_pere - nass_pere,
822 perm_loc( nbrow( nosla ) ) = i
823 nbrow( nosla ) = nbrow( nosla ) - 1
825 DO i = 0, nslaves_pere
829 IF ( slaves_pere(0) .NE. myid )
THEN
830 WRITE(*,*)
'Error 1 in MAPLIG_FILS_NIV1:',myid, slaves_pere
835 istchk = pimaster(step(ison))
836 nbcols = iw(istchk+keep(ixsz))
837 nelim = iw(istchk+1+keep(ixsz))
838 nrow = iw(istchk+2+keep(ixsz))
839 npiv = iw(istchk+3+keep(ixsz))
842 write(6,*)
' Error 2 in DMUMPS_MAPLIG_FILS_NIV1 ', npiv
845 nslson = iw(istchk+5+keep(ixsz))
846 nfront = npiv + nbcols
847 packed_cb=(iw(ptrist(step(ison))+xxs) .eq. s_cb1comp)
848 IF (i == nslaves_pere)
THEN
849 nrows_to_stack=lmap_loc-nbrow(i)+1
851 nrows_to_stack=nbrow(i+1)-nbrow(i)
853 IF ((keep(114).EQ.1) .AND. (keep(50).EQ.2) .AND.
854 & (keep(116).GT.0) .AND. ((nfront-nass-keep(253)).GT.0)
856 irow_l = pimaster(step(ison)) + 6 + keep(ixsz) + nass
859 & nfront-nass-keep(253),
867 iw(ptlust(step(inode_pere))+xxnbpr) =
868 & iw(ptlust(step(inode_pere))+xxnbpr) - decr
869 iw(ptrist(step(ison))+xxnbpr) =
870 & iw(ptrist(step(ison))+xxnbpr) - decr
871 cb_is_lr = (iw(istchk+xxlr).EQ.1 .OR.
872 & iw(istchk+xxlr).EQ.3)
873 nrows_already_stacked = 0
875 nrows_to_stack_loc = nrows_to_stack
877 IF (cb_is_lr.AND.nrows_to_stack.GT.0)
THEN
879 & iw(istchk+xxf), cb_lrb)
881 & iw(istchk+xxf), begs_blr)
882 nb_blr_rows =
size(begs_blr) - 1
885 panel2decompress = -1
886 DO ii=nb_blr_shift+1,nb_blr_rows
887 IF (begs_blr(ii+1)-1-nass.GT.
888 & nrows_already_stacked+nbrow(i)-1)
THEN
889 panel2decompress = ii
893 IF (panel2decompress.EQ.-1)
THEN
894 write(*,*)
'Internal error: PANEL2DECOMPRESS not found'
897 IF (keep(50).EQ.0)
THEN
898 nb_blr_cols =
size(begs_blr) - 1
900 nb_blr_cols = panel2decompress
902 current_panel_size = begs_blr(panel2decompress+1)
903 & - begs_blr(panel2decompress)
904 panel_beg_offset = nbrow(i) + nrows_already_stacked
905 & - begs_blr(panel2decompress) + nass
907 &
min(nrows_to_stack-nrows_already_stacked,
908 & current_panel_size-panel_beg_offset)
909 la_temp = current_panel_size*nbcols
911 & .false., keep8, iflag, ierror, .true., .true.)
912 allocate(a_temp(la_temp),stat=allocok)
913 IF (allocok.GT.0)
THEN
922 & nbcols, nbcols, .true., 1, 1,
923 & nb_blr_cols-nb_blr_shift,
924 & cb_lrb(panel2decompress-nb_blr_shift,
925 & 1:nb_blr_cols-nb_blr_shift),
927 & cbasm_tofix_in=.true.,
928 & only_nelim_in=current_panel_size-panel_beg_offset)
934 & iw(ptrist(step(ison))+xxs),
936 & pamaster(step(ison)),
937 & iw(ptrist(step(ison))+xxd),
938 & iw(ptrist(step(ison))+xxr),
939 & son_a, iachk, recsize )
940 DO ii = nrows_already_stacked+1,
941 & nrows_already_stacked+nrows_to_stack_loc
942 irow_son=perm_loc(nbrow(i)+ii-1)
943 indice_pere = map(irow_son)
945 & keep,keep8, inode_pere, step, n, slavef,
946 & istep_to_iniv2, tab_pos_in_pere,
949 & nfront_pere - nass_pere,
954 indice_pere = ipos_in_slave
958 & int(irow_son,8)*int(irow_son-1,8)/2_8
961 & int(nelim+irow_son,8)*int(nelim+irow_son-1,8)/2_8
965 & int(nelim+irow_son-1,8)*int(nbcols,8)
967 IF (keep(50).NE.0)
THEN
968 nbcols_eff = nelim + irow_son
972 indice_pere_array_arg(1) = indice_pere
975 & a, la, ison, 1, nbcols_eff,
976 & indice_pere_array_arg,
977 & a_temp(1+(ii+panel_beg_offset
978 & -nrows_already_stacked-1)*nbcols),
980 & step, pimaster, opassw, iwposcb,
981 & myid, keep,keep8,.false.,nbcols)
984 & a, la, ison, 1, nbcols_eff, indice_pere_array_arg,
985 & son_a(posrow), ptlust, ptrast,
986 & step, pimaster, opassw, iwposcb,
987 & myid, keep,keep8,.false.,nbcols_eff)
990 IF (cb_is_lr.AND.nrows_to_stack.GT.0)
THEN
993 & .false., keep8, iflag, ierror, .true., .true.)
994 nrows_already_stacked = nrows_already_stacked
995 & + nrows_to_stack_loc
996 IF (nrows_already_stacked.LT.nrows_to_stack)
THEN
1000 IF (keep(219).NE.0)
THEN
1001 IF(nslaves_pere.GT.0 .AND. keep(50).EQ.2)
THEN
1004 & iw(istchk+xxf), m_array)
1005 m_array_retrieved = .true.
1009 & + int(nelim+nbrow(1),8)*int(nelim+nbrow(1)-1,8)/2_8
1010 asize = int(lmap_loc+nelim,8)*int(nelim+lmap_loc+1,8)/2_8
1011 & - int(nelim+nbrow(1),8)*int(nelim+nbrow(1)-1,8)/2_8
1014 & int(nelim+nbrow(1)-1,8)*int(nbcols,8)
1015 asize = int(lmap_loc-nbrow(1)+1,8) * int(nbcols,8)
1018 IF (ierr .NE.0)
THEN
1019 IF (lp > 0)
WRITE(lp,*) myid,
1020 &
": PB allocation MAX_ARRAY during DMUMPS_MAPLIG_FILS_NIV1"
1025 IF ( lmap_loc-nbrow(1)+1-keep(253)-nvschur.GT. 0 )
THEN
1027 & son_a(posrow),asize,nbcols,
1028 & lmap_loc-nbrow(1)+1-keep(253)-nvschur,
1036 m_array_retrieved = .false.
1039 & a, la, ison, nfs4father,
1040 & m_array(1), ptlust
1041 & step, pimaster, opassw,
1042 & iwposcb,myid, keep,keep8)
1043 IF ( m_array_retrieved )
1047 IF (iw(ptrist(step(ison))+xxnbpr) .EQ. 0
1049 istchk_loc = pimaster
1050 same_proc= istchk_loc .LT. iwposcb
1053 & iwposcb, pimaster, ptlust, iw, liw, step,
1057 IF ( iw(ptlust(step(inode_pere))+xxnbpr) .EQ. 0
1061 & slavef, keep(199), keep(28), keep(76), keep(80),
1062 & keep(47), step, inode_pere+n )
1063 IF (keep(47) .GE. 3)
THEN
1066 & procnode_steps, keep,keep8, slavef, comm_load,
1067 & myid, step, n, nd, fils )
1070 DO i = 0, nslaves_pere
1071 pdest = slaves_pere( i )
1072 IF ( pdest .NE. myid )
THEN
1073 nbrows_already_sent = 0
1075 nfront = iw(pimaster(step(ison))+keep(ixsz))
1076 nelim = iw(pimaster(step(ison))+1+keep(ixsz))
1078 IF (i == nslaves_pere)
THEN
1079 nrows_to_send=lmap_loc-nbrow(i)+1
1081 nrows_to_send=nbrow(i+1)-nbrow(i)
1083 IF ( nrows_to_send .EQ. 0) cycle
1084 itype_son = mumps_typenode( procnode_steps(step(ison)),
1088 & desclu, inode_pere,
1089 & nfront_pere, nass_pere, nfs4father,
1091 & ison, nrows_to_send, lmap_loc,
1092 & map, perm_loc(
min(lmap_loc,nbrow(i))),
1093 & iw(pimaster(step(ison))),
1095 & i, pdest, pdest_master, comm, ierr,
1096 & keep,keep8, step, n, slavef,
1097 & istep_to_iniv2, tab_pos_in_pere,
1098 & packed_cb, keep(253), nvschur,
1100 & npiv_check = iw(ptlust(step(ison))+3+keep(ixsz)))
1103 & iw(ptrist(step(ison))+xxs),
1105 & pamaster(step(ison)),
1106 & iw(ptrist(step(ison))+xxd),
1107 & iw(ptrist(step(ison))+xxr),
1108 & son_a, iachk, recsize )
1110 & desclu, inode_pere,
1111 & nfront_pere, nass_pere, nfs4father,
1113 & ison, nrows_to_send, lmap_loc,
1114 & map, perm_loc(
min(lmap_loc,nbrow(i))),
1115 & iw(pimaster(step(ison))),
1116 & son_a(iachk:iachk+recsize-1_8),
1118 & i, pdest, pdest_master, comm, ierr,
1120 & keep,keep8, step, n, slavef,
1121 & istep_to_iniv2, tab_pos_in_pere,
1122 & packed_cb, keep(253), nvschur,
1125 IF ( ierr .EQ. -2 )
THEN
1126 IF (lp > 0)
WRITE(lp,*) myid,
1127 &
": FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_MAPLIG_FILS_NIV1"
1129 ierror = (nrows_to_send + 3 )* keep( 34 ) +
1130 & nrows_to_send * keep( 35 )
1133 IF ( ierr .EQ. -3 )
THEN
1134 IF (lp > 0)
WRITE(lp,*) myid,
1135 &
": FAILURE, RECV BUFFER TOO SMALL DURING DMUMPS_MAPLIG_FILS_NIV1"
1137 ierror = (nrows_to_send + 3 )* keep( 34 ) +
1138 & nrows_to_send * keep( 35 )
1141 IF (keep(219).NE.0)
THEN
1142 IF ( ierr .EQ. -4 )
THEN
1145 IF (lp > 0)
WRITE(lp,*) myid,
1146 &
": FAILURE, MAX_ARRAY ALLOC FAILED DURING DMUMPS_MAPLIG_FILS_NIV1"
1150 IF ( ierr .EQ. -1 )
THEN
1153 message_received = .false.
1155 & ass_irecv, blocking, set_irecv, message_received,
1156 & mpi_any_source, mpi_any_tag,
1158 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
1159 & iwpos, iwposcb, iptrlu,
1160 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
1162 & ptrast, step, pimaster, pamaster, nstk, comp,
1163 & iflag, ierror, comm,
1164 & perm, ipool, lpool, leaf, nbfin, myid, slavef,
1165 & root, opassw, opeliw, itloc, rhs_mumps,
1166 & fils, dad, ptrarw, ptraiw,
1167 & intarr,dblarr,icntl,keep,keep8,dkeep,nd,frere,
1168 & lptrar, nelt, frtptr, frtelt,
1169 & istep_to_iniv2, tab_pos_in_pere, .true.
1172 IF ( iflag .LT. 0 )
GOTO 600
1177 istchk = ptrist(step(ison))
1178 ptrist(step( ison )) = -77777777
1179 IF ( iw(istchk+keep(ixsz)) .GE. 0 )
THEN
1180 WRITE(*,*)
'error 3 in DMUMPS_MAPLIG_FILS_NIV1'
1184 xxg_status = iw(istchk+xxg)
1186 & iw, liw, lrlu, lrlus, iptrlu,
1187 & iwposcb, la, keep,keep8, .false.
1189 IF (dynsize .GT. 0_8)
THEN
1191 & keep(405).EQ.1, keep8 )
1199 & .false., keep8, keep(34))
1200 IF ((keep(486).EQ.3).OR.keep(486).EQ.0)
THEN
1205 IF (
allocated(nbrow))
DEALLOCATE(nbrow)
1206 IF (
allocated(map))
DEALLOCATE(map)
1207 IF (
allocated(perm_loc))
DEALLOCATE(perm_loc)
1208 IF (
allocated(slaves_pere))
DEALLOCATE(slaves_pere)
1212 & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE,
1213 & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP,
1214 & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR,
1216 & IPOOL, LPOOL, STEP,
1217 & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2,
1219 & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB,
1220 & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND,
1221 & NELT, FRTPTR, FRTELT,
1223 & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR,
1225 & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL,
1226 & SON_NIV, LRGROUPS)
1238 INTEGER,
intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON
1239 INTEGER,
intent(in) :: N, SLAVEF
1240 INTEGER,
intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE
1241 INTEGER,
intent(in) :: NFS4FATHER
1242 INTEGER,
intent(in) :: KEEP(500), STEP(N)
1243 INTEGER,
intent(in) :: LMAP_LOC
1244 INTEGER,
intent(in) :: NBROW(0:NSLAVES_PERE)
1245 INTEGER,
intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC)
1246 INTEGER,
intent(inout) :: IFLAG, IERROR
1247 INTEGER(8),
intent(inout) :: KEEP8(150)
1248 INTEGER,
intent(in) :: LIW, NELT, LPTRAR
1249 INTEGER(8),
intent(in) :: LA
1250 INTEGER(8),
intent(inout) :: IPTRLU, LRLU, LRLUS
1251 INTEGER,
intent(inout) :: IWPOSCB
1252 INTEGER,
intent(inout) :: IW(LIW)
1253 DOUBLE PRECISION,
intent(inout) :: A( LA )
1254 INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28))
1255 INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28))
1256 INTEGER :: PTLUST(KEEP(28))
1257 INTEGER,
intent(inout) :: ITLOC(N)
1258 INTEGER,
intent(in) :: FRTPTR( N+1 ), FRTELT( NELT )
1259 DOUBLE PRECISION,
intent(inout) :: OPASSW, OPELIW
1260 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
1261 INTEGER,
intent(in) :: KEEP253_LOC, NVSCHUR
1262 INTEGER,
intent(in) :: FILS(N), DAD( KEEP(28) )
1263 INTEGER(8),
intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
1264 INTEGER,
intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD
1265 INTEGER ISTEP_TO_INIV2(KEEP(71)),
1266 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
1267 DOUBLE PRECISION DBLARR(KEEP8(26))
1268 INTEGER INTARR(KEEP8(27))
1270 INTEGER IPOOL( LPOOL )
1271 LOGICAL,
intent(in) :: IS_ofType5or6
1272 INTEGER,
intent(in) :: SON_NIV
1273 INTEGER,
intent(in) :: LRGROUPS(N)
1274 INCLUDE
'mumps_headers.h'
1276 INTEGER :: XXG_STATUS
1277 INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS,
1278 & NROW, NPIV, NSLSON,
1279 & nfront, lda_son, nrows_to_stack, ii, indice_pere,
1280 & nosla, collist, ipos_in_slave, irow_son, itmp,
1281 & nbcols_eff, decr, nelim
1282 INTEGER :: NB_POSTPONED
1283 LOGICAL :: PACKED_CB, SAME_PROC
1284 INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON
1287 DOUBLE PRECISION,
DIMENSION(:),
POINTER :: SON_A
1288 DOUBLE PRECISION,
DIMENSION(:),
POINTER :: SON_A_MASTER
1289 INTEGER(8) :: DYN_SIZE
1291 INTEGER INDICE_PERE_ARRAY_ARG(1)
1292 INTEGER :: INBPROCFILS_SON
1294 DOUBLE PRECISION,
POINTER,
DIMENSION(:) :: M_ARRAY
1295 LOGICAL :: M_ARRAY_RETRIEVED
1296 INTEGER(8) :: POSELT
1297 INTEGER :: IOLDPS, PARPIV_T1
1298 LOGICAL :: LR_ACTIVATED
1299 INTEGER,
POINTER,
DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL,
1301 INTEGER :: NB_BLR_COLS, NB_BLR_ROWS,
1302 & nb_col_shift, panel2decompress,
1303 & current_panel_size, panel_beg_offset,
1304 & allocok, nrows_already_stacked, nrows_to_stack_loc,
1305 & nb_row_shift, nass_shift, ncol_shift, nrow_shift
1306 INTEGER(8) :: LA_TEMP
1307 DOUBLE PRECISION,
ALLOCATABLE :: A_TEMP(:)
1308 TYPE (LRB_TYPE),
POINTER :: CB_LRB(:,:)
1310 IF (icntl(4) .LE. 0) lp = -1
1311 IF (i == nslaves_pere)
THEN
1312 nrows_to_stack = lmap_loc - nbrow(i) + 1
1314 nrows_to_stack = nbrow(i+1) - nbrow(i)
1317 IF ( myid .EQ. pdest_master )
THEN
1318 iw(ptlust(step(ifath))+xxnbpr) =
1319 & iw(ptlust(step(ifath))+xxnbpr) - decr
1320 IF ( pdest .EQ. pdest_master .AND. decr .NE. 0)
THEN
1321 iw(pimaster(step(ison))+xxnbpr) =
1322 & iw(pimaster(step(ison))+xxnbpr) - decr
1325 istchk = ptrist(step(ison))
1326 nbcols = iw(istchk+keep(ixsz))
1327 nrow = iw(istchk+2+keep(ixsz))
1328 npiv = iw(istchk+3+keep(ixsz))
1329 nslson = iw(istchk+5+keep(ixsz))
1330 nfront = npiv + nbcols
1331 son_xxs = iw(istchk+xxs)
1332 packed_cb = ( son_xxs .EQ. s_cb1comp )
1336 & ptrast(step(ison)),
1337 & iw(ptrist(step(ison))+xxd),
1338 & iw(ptrist(step(ison))+xxr),
1339 & son_a, iachk, sizfr)
1340 cb_is_lr = (iw(istchk+xxlr).EQ.1 .OR.
1341 & iw(istchk+xxlr).EQ.3)
1343 IF (cb_is_lr.AND.(son_niv.EQ.1).AND.
1344 & keep(50).NE.0)
THEN
1345 istchk_loc = ptlust(step(ison))
1346 nelim = iw(istchk_loc+1+keep(ixsz))
1347 npiv = iw(istchk_loc+3+keep(ixsz))
1348 nfront = iw(istchk_loc+2+keep(ixsz))
1349 nrow = nfront - npiv
1357 IF (son_xxs.EQ.s_nolcbcontig )
THEN
1359 shiftcb_son = int(npiv,8)*int(nrow,8)
1360 ELSE IF (iw(istchk+xxs).EQ.s_nolcleaned)
THEN
1365 shiftcb_son = int(npiv,8)
1368 IF (pdest .NE. pdest_master)
THEN
1369 IF ( keep(55) .eq. 0 )
THEN
1371 & (n, ifath, iw, liw,
1372 & a, la, nrows_to_stack, nbcols,
1373 & opassw, opeliw, step, ptrist, ptrast,
1375 & fils, ptrarw, ptraiw, intarr, dblarr, icntl,
1376 & keep,keep8, myid, lrgroups )
1379 & n, ifath, iw, liw,
1380 & a, la, nrows_to_stack, nbcols,
1381 & opassw, opeliw, step, ptrist, ptrast,
1383 & fils, ptrarw, ptraiw, intarr, dblarr, icntl,
1384 & keep, keep8, myid, lrgroups )
1387 nrows_already_stacked = 0
1389 nrows_to_stack_loc = nrows_to_stack
1390 panel_beg_offset = 0
1391 IF (cb_is_lr.AND.nrows_to_stack.GT.0)
THEN
1393 & iw(istchk+xxf), cb_lrb)
1394 IF (son_niv.EQ.1)
THEN
1396 & iw(istchk+xxf), begs_blr_row)
1398 & iw(istchk+xxf), begs_blr_col)
1399 nb_blr_rows =
size(begs_blr_row) - 1
1402 nb_row_shift = nb_col_shift
1403 nass_shift = begs_blr_row(nb_row_shift+1)-1
1406 & iw(istchk+xxf), begs_blr_sta)
1407 nb_blr_rows =
size(begs_blr_sta) - 2
1408 begs_blr_row => begs_blr_sta(2:nb_blr_rows+2)
1410 & iw(istchk+xxf), begs_blr_col,
1415 panel2decompress = -1
1416 DO ii=nb_row_shift+1,nb_blr_rows
1417 IF (begs_blr_row(ii+1)-1-nass_shift.GT.
1418 & nrows_already_stacked+nbrow(i)-1)
THEN
1419 panel2decompress = ii
1423 IF (panel2decompress.EQ.-1)
THEN
1424 write(*,*)
'Internal error: PANEL2DECOMPRESS not found'
1427 IF (keep(50).EQ.0)
THEN
1428 nb_blr_cols =
size(begs_blr_col) - 1
1429 ELSEIF (son_niv.EQ.1)
THEN
1430 nb_blr_cols = panel2decompress
1434 nrow_shift = nbcols-nrow
1435 DO ii=nb_col_shift+1,
size(begs_blr_col)-1
1436 IF (begs_blr_col(ii+1)-ncol_shift.GT.
1437 & begs_blr_row(panel2decompress+1)-1+nrow_shift)
THEN
1442 IF (nb_blr_cols.EQ.-1)
THEN
1443 write(*,*)
'Internal error: NB_BLR_COLS not found'
1447 current_panel_size = begs_blr_row(panel2decompress+1)
1448 & - begs_blr_row(panel2decompress)
1449 panel_beg_offset = nbrow(i) + nrows_already_stacked
1450 & - begs_blr_row(panel2decompress) + nass_shift
1451 nrows_to_stack_loc =
1452 &
min(nrows_to_stack-nrows_already_stacked,
1453 & current_panel_size-panel_beg_offset)
1454 la_temp = current_panel_size*nbcols
1456 & .false., keep8, iflag, ierror, .true., .true.)
1457 allocate(a_temp(la_temp),stat=allocok)
1458 IF (allocok.GT.0)
THEN
1467 & nbcols, nbcols, .true., 1, 1,
1468 & nb_blr_cols-nb_col_shift,
1469 & cb_lrb(panel2decompress-nb_row_shift,
1470 & 1:nb_blr_cols-nb_col_shift),
1472 & cbasm_tofix_in=.true.,
1473 & only_nelim_in=current_panel_size-panel_beg_offset)
1478 DO ii = nrows_already_stacked+1,
1479 & nrows_already_stacked+nrows_to_stack_loc
1480 irow_son = perm(nbrow(i)+ii-1)
1481 indice_pere=map(irow_son)
1483 & keep,keep8, ifath, step, n, slavef,
1484 & istep_to_iniv2, tab_pos_in_pere,
1487 & nfront_pere - nass_pere,
1492 indice_pere = ipos_in_slave
1493 IF ( packed_cb )
THEN
1494 IF (nbcols - nrow .EQ. 0 )
THEN
1497 & int(itmp,8) * int(itmp-1,8) / 2_8
1499 itmp = irow_son + nbcols - nrow
1501 & + int(itmp,8) * int(itmp-1,8) / 2_8
1502 & - int(nbcols-nrow,8) * int(nbcols-nrow+1,8)/2_8
1505 posrow = iachk + shiftcb_son
1506 & +int(irow_son-1,8)*int(lda_son,8)
1508 IF (pdest == pdest_master)
THEN
1509 IF (keep(50).NE.0)
THEN
1510 nbcols_eff = irow_son + nbcols - nrow
1514 indice_pere_array_arg
1515 IF ((is_oftype5or6).AND.(keep(50).EQ.0))
THEN
1517 write(*,*)
'Compress CB + Type5or6 fronts not',
1522 & a, la, ison, nrows_to_stack, nbcols_eff,
1523 & indice_pere_array_arg,
1524 & son_a(posrow), ptlust, ptrast,
1525 & step, pimaster, opassw,
1526 & iwposcb, myid, keep,keep8,
1527 & is_oftype5or6, lda_son
1530 ELSE IF ( (keep(50).NE.0) .AND.
1531 & (.NOT.packed_cb).AND.(is_oftype5or6) )
THEN
1533 write(*,*)
'Compress CB + Type5or6 fronts not',
1538 & a, la, ison, nrows_to_stack,
1539 & nbcols_eff, indice_pere_array_arg,
1540 & son_a(posrow), ptlust, ptrast,
1541 & step, pimaster, opassw,
1542 & iwposcb, myid, keep,keep8,
1543 & is_oftype5or6, lda_son
1549 & a, la, ison, 1, nbcols_eff,
1550 & indice_pere_array_arg,
1551 & a_temp(1+(ii+panel_beg_offset
1552 & -nrows_already_stacked-1)*nbcols),
1554 & step, pimaster, opassw,
1555 & iwposcb, myid, keep,keep8,
1556 & is_oftype5or6, nbcols )
1559 & a, la, ison, 1, nbcols_eff,
1560 & indice_pere_array_arg,
1561 & son_a(posrow), ptlust, ptrast,
1562 & step, pimaster, opassw,
1563 & iwposcb, myid, keep,keep8,
1564 & is_oftype5or6, lda_son )
1568 istchk = ptrist(step(ison))
1569 collist = istchk + 6 + keep(ixsz)
1570 & + iw( istchk + 5 +keep(ixsz)) + nrow + npiv
1571 IF (cb_is_lr.AND.(son_niv.EQ.1).AND.
1572 & keep(50).NE.0)
THEN
1573 istchk_loc = ptlust(step(ison))
1574 collist = istchk_loc + 6 + keep(ixsz)
1575 & + iw( istchk + 5 +keep(ixsz))
1576 & + iw(istchk_loc+2+keep(ixsz))
1577 & + iw(istchk_loc+3+keep(ixsz))
1579 IF (keep(50).NE.0)
THEN
1580 nbcols_eff = irow_son + nbcols - nrow
1581 IF (cb_is_lr.AND.son_niv.EQ.1)
1582 & nbcols_eff = irow_son + nbcols - (nrow-nelim
1586 indice_pere_array_arg(1) = indice_pere
1587 IF ( (is_oftype5or6) .AND.
1591 & ( (keep(50).NE.0).and. (.NOT.packed_cb) )
1595 write(*,*)
'Compress CB + Type5or6 fronts not',
1601 & a, la, nrows_to_stack, nbcols,
1602 & indice_pere_array_arg,
1603 & iw( collist ), son_a(posrow),
1604 & opassw, opeliw, step, ptrist, ptrast,
1606 & fils, icntl, keep,keep8,
1607 & myid, is_oftype5or6, lda_son)
1608 iw( ptrist(step(ifath))+xxnbpr) =
1609 & iw( ptrist(step(ifath))+xxnbpr) - nrows_to_stack
1615 & a, la, 1, nbcols_eff,
1616 & indice_pere_array_arg,
1618 & a_temp(1+(ii+panel_beg_offset
1619 & -nrows_already_stacked-1)*nbcols),
1620 & opassw, opeliw, step, ptrist, ptrast,
1622 & fils, icntl, keep,keep8,
1623 & myid, is_oftype5or6, nbcols)
1627 & a, la, 1, nbcols_eff, indice_pere_array_arg,
1628 & iw( collist ), son_a(posrow),
1629 & opassw, opeliw, step, ptrist, ptrast,
1631 & fils, icntl, keep,keep8,
1632 & myid, is_oftype5or6, lda_son)
1634 iw( ptrist(step(ifath))+xxnbpr) =
1635 & iw( ptrist(step(ifath))+xxnbpr) - 1
1639 IF (cb_is_lr.AND.nrows_to_stack.GT.0)
THEN
1642 & .false., keep8, iflag, ierror, .true., .true.)
1643 nrows_already_stacked = nrows_already_stacked
1644 & + nrows_to_stack_loc
1645 IF (nrows_already_stacked.LT.nrows_to_stack)
THEN
1649 IF (pdest.EQ.pdest_master)
THEN
1650 IF (keep(219).NE.0)
THEN
1651 IF(nslaves_pere.GT.0 .AND. keep(50).EQ.2)
THEN
1654 & iw(istchk+xxf), m_array)
1655 m_array_retrieved = .true.
1658 WRITE(*,*)
"Error 1 in PARPIV/DMUMPS_MAPLIG"
1662 & int(nbrow(1)-1,8)*int(lda_son,8)
1665 IF (ierr .NE.0)
THEN
1667 WRITE(lp, *)
"MAX_ARRAY allocation failed"
1674 IF (lmap_loc-nbrow(1)+1-keep253_loc-nvschur.NE.0)
1678 & sizfr-shiftcb_son-int(nbrow(1)-1,8)*int(lda_son,8),
1680 & lmap_loc-nbrow(1)+1-keep253_loc-nvschur,
1687 m_array_retrieved = .false.
1690 & a, la, ison, nfs4father,
1691 & m_array(1), ptlust, ptrast,
1693 & opassw,iwposcb,myid, keep,keep8)
1694 IF ( m_array_retrieved )
1698 istchk_loc = pimaster(step(ison))
1699 same_proc= istchk_loc .LT. iwposcb
1700 IF ( same_proc )
THEN
1701 inbprocfils_son = ptrist(step(ison))+xxnbpr
1703 &
"Internal error 0 in DMUMPS_LOCAL_ASSEMBLY_TYPE2",
1704 & inbprocfils_son, pimaster(step(ison))
1707 inbprocfils_son = pimaster(step(ison))+xxnbpr
1709 IF ( iw(inbprocfils_son) .EQ. 0 )
THEN
1712 & iwposcb, pimaster, ptlust, iw, liw, step,
1716 istchk_loc = ptrist(step(ison))
1717 ptrist(step( ison) ) = -99999999
1719 pimaster(step( ison )) = -99999999
1722 xxg_status = iw(istchk_loc+xxg)
1723 IF (dyn_size .GT. 0_8)
THEN
1725 & dyn_size, son_a_master )
1729 & iw, liw, lrlu, lrlus, iptrlu, iwposcb,
1730 & la, keep,keep8, .false.
1732 IF (dyn_size .GT. 0_8)
THEN
1735 & keep(405).EQ.1, keep8 )
1738 IF ( iw(ptlust(step(ifath))+xxnbpr) .EQ. 0
1740 ioldps = ptlust(step(ifath))
1741 IF (nslaves_pere.EQ.0)
THEN
1742 poselt = ptrast(step(ifath))
1744 lr_activated = (iw(ioldps+xxlr).GT.0)
1745 nb_postponed = max(nfront - nd(step(ifath)),0)
1747 & n, ifath, iw, liw, a, la, keep, perm,
1749 & nfront_pere, nass_pere, lr_activated, parpiv_t1,
1754 & slavef, keep(199), keep(28), keep(76), keep(80),
1755 & keep(47), step, ifath+n )
1756 IF (keep(47) .GE. 3)
THEN
1759 & procnode_steps, keep,keep8, slavef, comm_load,
1760 & myid, step, n, nd, fils )
1765 & (n, ifath, iw, liw,
1766 & nbrow(i), step, ptrist, itloc, rhs_mumps,