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

Go to the source code of this file.

Functions/Subroutines

recursive subroutine zmumps_traiter_message_solve (bufr, lbufr, lbufr_bytes, msgtag, msgsou, myid, slavef, comm, n, nrhs, ipool, lpool, leaf, nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac, iwcb, liwcb, wcb, lwcb, poswcb, pleftwcb, posiwcb, ptricb, info, keep, keep8, dkeep, step, procnode_steps, rhscomp, lrhscomp, posinrhscomp_fwd, from_pp)
subroutine zmumps_solve_node_fwd (inode, lastfsl0sta, lastfsl0dyn, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, ipool, lpool, leaf, nbfin, nstk_s, iwcb, liwcb, wcb, lwcb, a, la, iw, liw, nrhs, poswcb, pleftwcb, posiwcb, ptricb, ptrist, ptrfac, procnode_steps, fils, step, frere, dad, info, keep, keep8, dkeep, rhs_root, lrhs_root, mtype, rhscomp, lrhscomp, posinrhscomp_fwd istep_to_iniv2, tab_pos_in_pere, rhs_bounds, lrhs_bounds, do_nbsparse, from_pp, error_was_broadcasted)
recursive subroutine zmumps_solve_recv_and_treat (bloq, flag, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, nrhs, ipool, lpool, leaf, nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac, iwcb, liwcb, wcb, lwcb, poswcb, pleftwcb, posiwcb, ptricb, info, keep, keep8, dkeep, step, procnode_steps, rhscomp, lrhscomp, posinrhscomp_fwd, from_pp)
subroutine zmumps_rhscomp_to_wcb (npiv, ncb, liell, cbinitzero, ldeqliellpanel, rhscomp, lrhscomp, nrhs_b, posinrhscomp_fwd, n, wcb, iw, liw, j1, j3, j2, keep, dkeep)

Function/Subroutine Documentation

◆ zmumps_rhscomp_to_wcb()

subroutine zmumps_rhscomp_to_wcb ( integer, intent(in) npiv,
integer, intent(in) ncb,
integer, intent(in) liell,
logical, intent(in) cbinitzero,
logical, intent(in) ldeqliellpanel,
complex(kind=8), dimension( lrhscomp, nrhs_b ), intent(inout) rhscomp,
integer, intent(in) lrhscomp,
integer, intent(in) nrhs_b,
integer, dimension( n ), intent(in) posinrhscomp_fwd,
integer, intent(in) n,
complex(kind=8), dimension( int(liell,8)* int(nrhs_b,8) ), intent(out) wcb,
integer, dimension( liw ), intent(in) iw,
integer, intent(in) liw,
integer, intent(in) j1,
integer, intent(in) j3,
integer, intent(in) j2,
integer, dimension(500) keep,
double precision, dimension(150) dkeep )

Definition at line 1077 of file zsol_fwd_aux.F.

1083 IMPLICIT NONE
1084 INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N,
1085 & LRHSCOMP, NRHS_B,
1086 & LIW, J1, J2, J3
1087 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL
1088 LOGICAL, INTENT( IN ) :: CBINITZERO
1089 INTEGER, INTENT( IN ) :: POSINRHSCOMP_FWD( N ), IW( LIW )
1090 COMPLEX(kind=8), INTENT( INOUT ) :: RHSCOMP( LRHSCOMP, NRHS_B )
1091 COMPLEX(kind=8), INTENT( OUT ) :: WCB( int(LIELL,8)*
1092 & int(NRHS_B,8) )
1093 INTEGER :: KEEP(500)
1094 DOUBLE PRECISION :: DKEEP(150)
1095 INTEGER, PARAMETER :: ZERO = (0.0d0,0.0d0)
1096 INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8
1097 INTEGER(8) :: PCB_COURANT
1098 INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSCOMP
1099 INTEGER(8) :: IFR8, IFR_ini8
1100 include 'mpif.h'
1101 LOGICAL :: OMP_FLAG
1102 IF ( ldeqliellpanel ) THEN
1103 ld_wcbpiv = liell
1104 ld_wcbcb = liell
1105 pcb_courant = ppiv_courant + npiv
1106 ELSE
1107 ld_wcbpiv = npiv
1108 ld_wcbcb = ncb
1109 pcb_courant = ppiv_courant + npiv * nrhs_b
1110 ENDIF
1111 IF ( ldeqliellpanel ) THEN
1112 DO k=1, nrhs_b
1113 ifr8 = ppiv_courant+int(k-1,8)*int(ld_wcbpiv,8)-1_8
1114 iposinrhscomp = posinrhscomp_fwd(iw(j1))
1115 DO jj = j1, j3
1116 ifr8 = ifr8 + 1_8
1117 wcb(ifr8) = rhscomp(iposinrhscomp,k)
1118 iposinrhscomp = iposinrhscomp + 1
1119 ENDDO
1120 IF (ncb.GT.0 .AND. .NOT. cbinitzero) THEN
1121#if defined(__ve__)
1122!NEC$ IVDEP
1123#endif
1124 DO jj = j3+1, j2
1125 j = iw(jj)
1126 ifr8 = ifr8 + 1_8
1127 iposinrhscomp = abs(posinrhscomp_fwd(j))
1128 wcb(ifr8) = rhscomp(iposinrhscomp,k)
1129 rhscomp(iposinrhscomp,k) = zero
1130 ENDDO
1131 ENDIF
1132 ENDDO
1133 ELSE
1134 pcb_courant = ppiv_courant + ld_wcbpiv*nrhs_b
1135 ifr8 = ppiv_courant - 1_8
1136 ifr_ini8 = ifr8
1137 iposinrhscomp = posinrhscomp_fwd(iw(j1))
1138 omp_flag = .false.
1139!$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND.
1140!$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) )
1141 IF (omp_flag) THEN
1142!$OMP PARALLEL DO PRIVATE(JJ,IFR8)
1143 DO k=1, nrhs_b
1144 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
1145 DO jj = j1, j3
1146 wcb(ifr8+int(jj-j1+1,8)) =
1147 & rhscomp(iposinrhscomp+jj-j1,k)
1148 ENDDO
1149 ENDDO
1150!$OMP END PARALLEL DO
1151 ELSE
1152 DO k=1, nrhs_b
1153 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
1154 DO jj = j1, j3
1155 wcb(ifr8+int(jj-j1+1,8)) =
1156 & rhscomp(iposinrhscomp+jj-j1,k)
1157 ENDDO
1158 ENDDO
1159 ENDIF
1160 ifr8 = pcb_courant - 1_8
1161 IF (ncb.GT.0 .AND. .NOT. cbinitzero) THEN
1162 ifr_ini8 = ifr8
1163 omp_flag = .false.
1164!$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND.
1165!$ & NCB*NRHS_B .GE. KEEP(363) )
1166 IF (omp_flag) THEN
1167!$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP)
1168 DO k=1, nrhs_b
1169 ifr8 = ifr_ini8+(k-1)*ncb
1170#if defined(__ve__)
1171!NEC$ IVDEP
1172#endif
1173 DO jj = j3 + 1, j2
1174 j = iw(jj)
1175 iposinrhscomp = abs(posinrhscomp_fwd(j))
1176 wcb(ifr8+int(jj-j3,8)) = rhscomp(iposinrhscomp,k)
1177 rhscomp(iposinrhscomp,k)=zero
1178 ENDDO
1179 ENDDO
1180!$OMP END PARALLEL DO
1181 ELSE
1182 DO k=1, nrhs_b
1183 ifr8 = ifr_ini8+(k-1)*ncb
1184#if defined(__ve__)
1185!NEC$ IVDEP
1186#endif
1187 DO jj = j3 + 1, j2
1188 j = iw(jj)
1189 iposinrhscomp = abs(posinrhscomp_fwd(j))
1190 wcb(ifr8+int(jj-j3,8)) = rhscomp(iposinrhscomp,k)
1191 rhscomp(iposinrhscomp,k)=zero
1192 ENDDO
1193 ENDDO
1194 ENDIF
1195 ENDIF
1196 ENDIF
1197 IF ( cbinitzero ) THEN
1198 omp_flag = .false.
1199!$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363)
1200 IF (omp_flag) THEN
1201!$OMP PARALLEL DO COLLAPSE(2)
1202 DO k = 1, nrhs_b
1203 DO jj = 1, ncb
1204 wcb(pcb_courant+int(k-1,8)*int(ld_wcbcb,8)+jj-1_8) = zero
1205 ENDDO
1206 ENDDO
1207!$OMP END PARALLEL DO
1208 ELSE
1209 DO k = 1, nrhs_b
1210 DO jj = 1, ncb
1211 wcb(pcb_courant+int(k-1,8)*int(ld_wcbcb,8)+jj-1_8) = zero
1212 ENDDO
1213 ENDDO
1214 ENDIF
1215 ENDIF
1216 RETURN

◆ zmumps_solve_node_fwd()

subroutine zmumps_solve_node_fwd ( integer, intent(in) inode,
integer, intent(in) lastfsl0sta,
integer, intent(in) lastfsl0dyn,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer myid,
integer slavef,
integer comm,
integer n,
integer, dimension( lpool ) ipool,
integer lpool,
integer leaf,
integer nbfin,
integer, dimension(keep(28)) nstk_s,
integer, dimension( liwcb ) iwcb,
integer liwcb,
complex(kind=8), dimension( lwcb ) wcb,
integer(8) lwcb,
complex(kind=8), dimension( la ) a,
integer(8) la,
integer, dimension( liw ) iw,
integer liw,
integer nrhs,
integer(8) poswcb,
integer(8) pleftwcb,
integer posiwcb,
integer, dimension(keep(28)) ptricb,
integer, dimension(keep(28)) ptrist,
integer(8), dimension(keep(28)) ptrfac,
integer, dimension(keep(28)) procnode_steps,
integer, dimension( n ) fils,
integer, dimension( n ) step,
integer, dimension(keep(28)) frere,
integer, dimension(keep(28)) dad,
integer, dimension( 80 ) info,
integer, dimension( 500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230), intent(inout) dkeep,
complex(kind=8), dimension( lrhs_root ) rhs_root,
integer(8) lrhs_root,
integer mtype,
complex(kind=8), dimension(lrhscomp, nrhs) rhscomp,
integer lrhscomp,
integer, dimension(n) posinrhscomp_fwd,
integer, dimension(keep(71)) istep_to_iniv2,
integer, dimension(slavef+2,max(1,keep(56))) tab_pos_in_pere,
integer, dimension(lrhs_bounds), intent(in) rhs_bounds,
integer, intent(in) lrhs_bounds,
logical, intent(in) do_nbsparse,
logical, intent(in) from_pp,
logical, intent(out) error_was_broadcasted )

Definition at line 347 of file zsol_fwd_aux.F.

365 USE zmumps_sol_lr
366!$ USE ZMUMPS_SOL_L0OMP_M, ONLY: LOCK_FOR_SCATTER
367 USE zmumps_sol_l0omp_m, ONLY: nb_lock_max
368 USE zmumps_ooc
369 USE zmumps_buf
370 IMPLICIT NONE
371 INTEGER MTYPE
372 INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN
373 INTEGER LBUFR, LBUFR_BYTES
374 INTEGER MYID, SLAVEF, COMM
375 INTEGER LIWCB, LIW, POSIWCB
376 INTEGER(8) :: POSWCB, PLEFTWCB, LWCB
377 INTEGER(8) :: LA
378 INTEGER N, LPOOL, LEAF, NBFIN
379 INTEGER INFO( 80 ), KEEP( 500)
380 INTEGER(8) KEEP8(150)
381 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
382 INTEGER BUFR( LBUFR )
383 INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28))
384 INTEGER IWCB( LIWCB ), IW( LIW )
385 INTEGER NRHS
386 COMPLEX(kind=8) WCB( LWCB )
387 COMPLEX(kind=8) :: A( LA )
388 INTEGER(8) :: LRHS_ROOT
389 COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT )
390 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28))
391 INTEGER(8) :: PTRFAC(KEEP(28))
392 INTEGER PROCNODE_STEPS(KEEP(28))
393 INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28))
394 INTEGER ISTEP_TO_INIV2(KEEP(71)),
395 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
396 INTEGER POSINRHSCOMP_FWD(N), LRHSCOMP
397 COMPLEX(kind=8) RHSCOMP(LRHSCOMP, NRHS)
398 LOGICAL, intent(in) :: DO_NBSPARSE
399 INTEGER, intent(in) :: LRHS_BOUNDS
400 INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS)
401 LOGICAL, intent(in) :: FROM_PP
402 LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED
403 EXTERNAL zgemv, ztrsv, zgemm, ztrsm, mumps_procnode
404 INTEGER MUMPS_PROCNODE
405 COMPLEX(kind=8) ALPHA,ONE,ZERO
406 parameter(zero=(0.0d0,0.0d0),
407 & one=(1.0d0,0.0d0),
408 & alpha=(-1.0d0,0.0d0))
409 INTEGER :: IWHDLR
410 INTEGER JBDEB, JBFIN, NRHS_B
411 INTEGER LDADIAG
412 INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8
413 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING,
414 & NPIV, NCB, LIELL, JJ, NELIM, IERR
415 INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL
416 INTEGER IPOSINRHSCOMP_TMP
417 INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex
418 LOGICAL FLAG
419 INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSCOMPLASTFSDYN
420 LOGICAL :: OMP_FLAG
421 include 'mumps_headers.h'
422 INTEGER(8) :: APOSDEB
423 INTEGER TempNROW, TempNCOL, PANEL_SIZE,
424 & JFIN, NBJ, NUPDATE_PANEL,
425 & TYPEF
426 INTEGER LD_WCBPIV
427 INTEGER LD_WCBCB
428 LOGICAL :: LDEQLIELLPANEL
429 LOGICAL :: CBINITZERO
430 INTEGER LDAJ, LDAJ_FIRST_PANEL
431 INTEGER LDAtemp
432 LOGICAL COMPRESS_PANEL, LR_ACTIVATED
433 LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR
434 INTEGER TMP_NBPANELS,
435 & I_PIVRPTR, I_PIVR, IPANEL
436 LOGICAL MUST_BE_PERMUTED
437 INTEGER :: SIZEBLOCK, NB, JCourant, NB_LOCK
438 include 'mpif.h'
439 include 'mumps_tags.h'
440 INTEGER DUMMY( 1 )
441 error_was_broadcasted = .false.
442 dummy(1)=1
443 lr_activated = (iw(ptrist(step(inode))+xxlr).GT.0)
444 compress_panel = (iw(ptrist(step(inode))+xxlr).GE.2)
445 oocwrite_compatible_with_blr =
446 & (.NOT.lr_activated.OR.(.NOT.compress_panel).OR.
447 & (keep(485).EQ.0)
448 & )
449 IF (do_nbsparse) THEN
450 jbdeb= rhs_bounds(2*step(inode)-1)
451 jbfin= rhs_bounds(2*step(inode))
452 ELSE
453 jbdeb = 1
454 jbfin = nrhs
455 ENDIF
456 nrhs_b = jbfin-jbdeb+1
457 IF (do_nbsparse) THEN
458 if (jbdeb.GT.jbfin) then
459 write(6,*) " Internal error 1 in nbsparse :",
460 & jbdeb, jbfin
461 CALL mumps_abort()
462 endif
463 IF (jbdeb.LT.1 .OR. jbdeb.GT.nrhs .or.
464 & jbfin.LT.1 .OR. jbfin.GT.nrhs ) THEN
465 write(6,*) " Internal error 2 in nbsparse :",
466 & jbdeb, jbfin
467 CALL mumps_abort()
468 endif
469 ENDIF
470 IF ( inode .eq. keep( 38 ) .OR. inode .eq.keep( 20 ) ) THEN
471 liell = iw( ptrist( step(inode)) + 3 + keep(ixsz))
472 npiv = liell
473 nelim = 0
474 nslaves = 0
475 ipos = ptrist( step(inode)) + 5 + keep(ixsz)
476 ELSE
477 ipos = ptrist(step(inode)) + 2 + keep(ixsz)
478 liell = iw(ipos-2)+iw(ipos+1)
479 nelim = iw(ipos-1)
480 nslaves = iw( ptrist(step(inode)) + 5 + keep(ixsz) )
481 ipos = ipos + 1
482 npiv = iw(ipos)
483 ipos = ipos + 1
484 IF ((keep(201).GT.0).AND.oocwrite_compatible_with_blr) THEN
485 CALL zmumps_solve_get_ooc_node(
486 & inode,ptrfac,keep,a,la,step,
487 & keep8,n,must_be_permuted,ierr)
488 IF(ierr.LT.0)THEN
489 info(1)=ierr
490 info(2)=0
491 error_was_broadcasted = .false.
492 GOTO 270
493 ENDIF
494 IF (keep(201).EQ.1 .AND. keep(50).NE.1) THEN
495 CALL zmumps_ooc_pp_check_perm_freed(
496 & iw(ipos+1+2*liell+1+nslaves),
497 & must_be_permuted )
498 ENDIF
499 ENDIF
500 nslaves = iw( ptrist(step(inode)) + 5 + keep(ixsz))
501 ipos = ipos + 1 + nslaves
502 END IF
503 IF ( mtype .EQ. 1 .OR. keep(50) .NE. 0 ) THEN
504 j1 = ipos + 1
505 j2 = ipos + liell
506 j3 = ipos + npiv
507 ELSE
508 j1 = ipos + liell + 1
509 j2 = ipos + 2 * liell
510 j3 = ipos + liell + npiv
511 END IF
512 ncb = liell-npiv
513 IF (keep(50).NE.0) THEN
514 IF ( keep(459) .GT. 1 ) THEN
515 ldadiag = -99999
516 ELSE
517 ldadiag = npiv
518 ENDIF
519 ELSE
520 ldadiag = liell
521 ENDIF
522 IF ( inode .eq. keep( 38 ) .OR. inode .eq. keep(20) ) THEN
523 ifr8 = 0_8
524 iposinrhscomp_tmp = posinrhscomp_fwd(iw(j1))
525 ifr_ini8 = ifr8
526 omp_flag = .false.
527!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND.
528!$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) )
529 IF (omp_flag) THEN
530!$OMP PARALLEL DO PRIVATE(IFR8,JJ)
531 DO k=jbdeb,jbfin
532 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
533 DO jj = j1, j3
534 rhs_root(ifr8+int(jj-j1+1,8)) =
535 & rhscomp(iposinrhscomp_tmp+jj-j1,k)
536 ENDDO
537 ENDDO
538!$OMP END PARALLEL DO
539 ELSE
540 DO k=jbdeb,jbfin
541 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
542 DO jj = j1, j3
543 rhs_root(ifr8+int(jj-j1+1,8)) =
544 & rhscomp(iposinrhscomp_tmp+jj-j1,k)
545 ENDDO
546 ENDDO
547 ENDIF
548 IF ( npiv .LT. liell ) THEN
549 WRITE(*,*) ' Internal error 1 in ZMUMPS_SOLVE_NODE_FWD',
550 & npiv, liell
551 CALL mumps_abort()
552 END IF
553 GO TO 270
554 END IF
555 apos = ptrfac(step(inode))
556 IF ( (keep(201).EQ.1).AND.oocwrite_compatible_with_blr ) THEN
557 IF (mtype.EQ.1) THEN
558 IF ((mtype.EQ.1).AND.nslaves.NE.0) THEN
559 tempnrow= npiv+nelim
560 tempncol= npiv
561 ldaj_first_panel=tempnrow
562 ELSE
563 tempnrow= liell
564 tempncol= npiv
565 ldaj_first_panel=tempnrow
566 ENDIF
567 typef=typef_l
568 ELSE
569 tempncol= liell
570 tempnrow= npiv
571 ldaj_first_panel=tempncol
572 typef= typef_u
573 ENDIF
574 panel_size = zmumps_ooc_panel_size( ldaj_first_panel )
575 ENDIF
576 ppiv_courant = pleftwcb
577 pleftwcb = pleftwcb + int(liell,8) * int(nrhs_b,8)
578 IF ( poswcb - pleftwcb + 1_8 .LT. 0 ) THEN
579 info(1) = -11
580 CALL mumps_set_ierror(pleftwcb-poswcb-1_8, info(2))
581 error_was_broadcasted = .false.
582 GOTO 270
583 END IF
584 IF (keep(201) .EQ. 1 .AND. oocwrite_compatible_with_blr) THEN
585 ldeqliellpanel = .true.
586 ld_wcbpiv = liell
587 ld_wcbcb = liell
588 pcb_courant = ppiv_courant + npiv
589 ELSE
590 ldeqliellpanel = .false.
591 ld_wcbpiv = npiv
592 ld_wcbcb = ncb
593 pcb_courant = ppiv_courant + int(npiv,8)*int(nrhs_b,8)
594 ENDIF
595 fpere = dad(step(inode))
596 IF ( fpere .NE. 0 ) THEN
597 fpere_mapping = mumps_procnode( procnode_steps(step(fpere)),
598 & keep(199) )
599 ELSE
600 fpere_mapping = -1
601 ENDIF
602 IF ( lastfsl0dyn .LE. n ) THEN
603 cbinitzero = .true.
604 ELSE IF ( fpere_mapping .EQ. myid ) THEN
605 cbinitzero = .true.
606 ELSE
607 cbinitzero = .false.
608 ENDIF
609 CALL zmumps_rhscomp_to_wcb(
610 & npiv, ncb, liell, cbinitzero, ldeqliellpanel,
611 & rhscomp(1, jbdeb), lrhscomp, nrhs_b,
612 & posinrhscomp_fwd, n,
613 & wcb(ppiv_courant),
614 & iw, liw, j1, j3, j2, keep, dkeep)
615 IF ( npiv .NE. 0 ) THEN
616 IF ((keep(201).EQ.1).AND.oocwrite_compatible_with_blr) THEN
617 aposdeb = apos
618 j = 1
619 ipanel = 0
620 10 CONTINUE
621 ipanel = ipanel + 1
622 jfin = min(j+panel_size-1, npiv)
623 IF (iw(ipos+ liell + jfin) < 0) THEN
624 jfin=jfin+1
625 ENDIF
626 nbj = jfin-j+1
627 ldaj = ldaj_first_panel-j+1
628 IF ( (keep(50).NE.1).AND. must_be_permuted ) THEN
629 CALL zmumps_get_ooc_perm_ptr(typef, tmp_nbpanels,
630 & i_pivrptr, i_pivr, ipos+1+2*liell, iw, liw)
631 IF (npiv.EQ.(iw(i_pivrptr+ipanel-1)-1)) THEN
632 must_be_permuted=.false.
633 ELSE
634 CALL zmumps_permute_panel(
635 & iw( i_pivr+ iw(i_pivrptr+ipanel-1)-
636 & iw(i_pivrptr)),
637 & npiv-iw(i_pivrptr+ipanel-1)+1,
638 & iw(i_pivrptr+ipanel-1)-1,
639 & a(aposdeb),
640 & ldaj, nbj, j-1 )
641 ENDIF
642 ENDIF
643 nupdate_panel = ldaj - nbj
644 ppiv_panel = ppiv_courant+int(j-1,8)
645 pcb_panel = ppiv_panel+int(nbj,8)
646 apos1 = aposdeb+int(nbj,8)
647 IF (mtype.EQ.1) THEN
648#if defined(MUMPS_USE_BLAS2)
649 IF ( nrhs_b == 1 ) THEN
650 CALL ztrsv( 'L', 'N', 'U', nbj, a(aposdeb), ldaj,
651 & wcb(ppiv_panel), 1 )
652 IF (nupdate_panel.GT.0) THEN
653 CALL zgemv('N', nupdate_panel,nbj,alpha, a(apos1),
654 & ldaj, wcb(ppiv_panel), 1, one,
655 & wcb(pcb_panel), 1)
656 ENDIF
657 ELSE
658#endif
659 CALL ztrsm( 'L','L','N','U', nbj, nrhs_b, one,
660 & a(aposdeb), ldaj, wcb(ppiv_panel),
661 & liell )
662 IF (nupdate_panel.GT.0) THEN
663 CALL zgemm('N', 'N', nupdate_panel, nrhs_b, nbj,
664 & alpha,
665 & a(apos1), ldaj, wcb(ppiv_panel), liell, one,
666 & wcb(pcb_panel), liell)
667 ENDIF
668#if defined(MUMPS_USE_BLAS2)
669 ENDIF
670#endif
671 ELSE
672#if defined(MUMPS_USE_BLAS2)
673 IF (nrhs_b == 1) THEN
674 CALL ztrsv( 'L', 'N', 'N', nbj, a(aposdeb), ldaj,
675 & wcb(ppiv_panel), 1 )
676 IF (nupdate_panel.GT.0) THEN
677 CALL zgemv('N',nupdate_panel, nbj, alpha, a(apos1),
678 & ldaj, wcb(ppiv_panel), 1,
679 & one, wcb(pcb_panel), 1 )
680 ENDIF
681 ELSE
682#endif
683 CALL ztrsm('L','L','N','N',nbj, nrhs_b, one,
684 & a(aposdeb), ldaj, wcb(ppiv_panel),
685 & liell)
686 IF (nupdate_panel.GT.0) THEN
687 CALL zgemm('N', 'N', nupdate_panel, nrhs_b, nbj,
688 & alpha,
689 & a(apos1), ldaj, wcb(ppiv_panel), liell, one,
690 & wcb(pcb_panel), liell)
691 ENDIF
692#if defined(MUMPS_USE_BLAS2)
693 ENDIF
694#endif
695 ENDIF
696 aposdeb = aposdeb+int(ldaj,8)*int(nbj,8)
697 j=jfin+1
698 IF ( j .LE. npiv ) GOTO 10
699 ELSE
700 IF ( iw(ptrist(step(inode))+xxlr) .GE. 2 .AND.
701 & keep(485) .EQ. 1 ) THEN
702 iwhdlr = iw(ptrist(step(inode))+xxf)
703 CALL zmumps_sol_fwd_lr_su (
704 & inode, n, iwhdlr, npiv, nslaves,
705 & iw, ipos, liw,
706 & liell, wcb, lwcb,
707 & ld_wcbpiv, ld_wcbcb,
708 & ppiv_courant, pcb_courant,
709 & rhscomp, lrhscomp, nrhs,
710 & posinrhscomp_fwd, jbdeb, jbfin,
711 & mtype, keep, keep8, oocwrite_compatible_with_blr,
712 & info(1), info(2) )
713 IF (info(1).LT.0) THEN
714 error_was_broadcasted = .false.
715 GOTO 270
716 ENDIF
717 ELSE IF ( keep(459) .GT. 1 .AND. keep(50) .NE. 0 ) THEN
718 CALL zmumps_solve_fwd_panels(
719 & a, la, apos,
720 & npiv, iw(ipos+liell+1),
721 & nrhs_b, wcb, lwcb, ld_wcbpiv,
722 & ppiv_courant, mtype, keep)
723 ELSE
724 CALL zmumps_solve_fwd_trsolve (
725 & a, la, apos,
726 & npiv, ldadiag,
727 & nrhs_b, wcb, lwcb, ld_wcbpiv,
728 & ppiv_courant, mtype, keep)
729 ENDIF
730 END IF
731 END IF
732 ncb = liell - npiv
733 IF ( mtype .EQ. 1 ) THEN
734 IF ( nslaves .EQ. 0 .OR. npiv .eq. 0 ) THEN
735 nupdate = ncb
736 ELSE
737 nupdate = nelim
738 END IF
739 IF (keep(459) .GT. 1 .AND. keep(50) .NE. 0) THEN
740 CALL mumps_geti8(apos1, iw(ptrist(step(inode))+xxr))
741 apos1 = apos + apos1 - int(npiv,8)*int(nupdate,8)
742 ELSE
743 apos1 = apos + int(npiv,8) * int(ldadiag,8)
744 ENDIF
745 ELSE
746 apos1 = apos + int(npiv,8)
747 nupdate = ncb
748 END IF
749 IF (keep(201).NE.1) THEN
750 IF ( iw(ptrist(step(inode))+xxlr) .LT. 2 .OR.
751 & keep(485).EQ.0) THEN
752 IF (mtype .EQ. 1) THEN
753 ldatemp = npiv
754 ELSE
755 ldatemp = liell
756 ENDIF
757 CALL zmumps_solve_gemm_update
758 & (a, la, apos1,
759 & npiv, ldatemp, nupdate,
760 & nrhs_b, wcb, lwcb, ppiv_courant, ld_wcbpiv,
761 & pcb_courant, ld_wcbcb,
762 & mtype, keep, one)
763 ENDIF
764 END IF
765 IF ( iw(ptrist(step(inode))+xxlr) .LT. 2 .OR.
766 & keep(485).EQ.0) THEN
767 IF (keep(201) .GT. 0 .AND. oocwrite_compatible_with_blr) THEN
768 CALL zmumps_sol_ld_and_reload(
769 & inode, n, npiv, liell, nelim, nslaves,
770 & ppiv_courant,
771 & iw, ipos, liw,
772 & a, la, apos,
773 & wcb, lwcb, ld_wcbpiv,
774 & rhscomp, lrhscomp, nrhs,
775 & posinrhscomp_fwd, jbdeb, jbfin,
776 & mtype, keep, oocwrite_compatible_with_blr,
777 & .false.
778 & )
779 ELSE
780 CALL zmumps_sol_ld_and_reload_panel (
781 & inode, n, npiv, liell, nelim, nslaves,
782 & ppiv_courant,
783 & iw, ipos, liw,
784 & a, la, apos,
785 & wcb, lwcb, ld_wcbpiv,
786 & rhscomp, lrhscomp, nrhs,
787 & posinrhscomp_fwd, jbdeb, jbfin,
788 & mtype, keep, oocwrite_compatible_with_blr,
789 & .false.
790 & )
791 ENDIF
792 ENDIF
793 IF ((keep(201).EQ.1).AND.oocwrite_compatible_with_blr)
794 &THEN
795 CALL zmumps_free_factors_for_solve(inode,ptrfac,keep(28),
796 & a,la,.true.,ierr)
797 IF(ierr.LT.0)THEN
798 info(1)=ierr
799 info(2)=0
800 error_was_broadcasted = .false.
801 GOTO 270
802 ENDIF
803 END IF
804 IF ( fpere .EQ. 0 ) THEN
805 pleftwcb = pleftwcb - int(liell,8) *int(nrhs_b,8)
806 GOTO 270
807 ENDIF
808 IF ( nupdate .NE. 0 .OR. ncb.EQ.0 ) THEN
809 IF (mumps_procnode(procnode_steps(step(fpere)),
810 & keep(199)) .EQ. myid) THEN
811 IF ( ncb .ne. 0 ) THEN
812 ptricb(step(inode)) = ncb + 1
813 nupdate_noncritical = nupdate
814 IF (lastfsl0dyn .LE. n) THEN
815 IF ( lastfsl0dyn .EQ. 0 ) THEN
816 iposinrhscomplastfsdyn = 0
817 ELSE
818 iposinrhscomplastfsdyn =
819 & abs(posinrhscomp_fwd(lastfsl0dyn))
820 ENDIF
821 DO i = 1, nupdate
822 IF ( abs(posinrhscomp_fwd( iw(j3+i) )) .GT.
823 & iposinrhscomplastfsdyn ) THEN
824 IF (abs(step(iw(j3+i))) .GT.
825 & abs(step( lastfsl0sta))
826 & .OR. keep(261) .NE. 1) THEN
827 nupdate_noncritical = i - 1
828 EXIT
829 ENDIF
830 ENDIF
831 ENDDO
832 ENDIF
833 omp_flag = .false.
834!$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND.
835!$ & (NUPDATE*NRHS_B .GE. KEEP(363)) )
836 IF (omp_flag) THEN
837!$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSCOMP_TMP)
838 DO k = jbdeb, jbfin
839 ifr8 = pcb_courant + int(k-jbdeb,8)*int(ld_wcbcb,8)
840#if defined(__ve__)
841!NEC$ IVDEP
842#endif
843 DO i = 1, nupdate_noncritical
844 iposinrhscomp_tmp =
845 & abs(posinrhscomp_fwd(iw(j3 + i)))
846 rhscomp( iposinrhscomp_tmp, k ) =
847 & rhscomp( iposinrhscomp_tmp, k )
848 & + wcb(ifr8 + int(i-1,8))
849 ENDDO
850 ENDDO
851!$OMP END PARALLEL DO
852 ELSE
853 DO k = jbdeb, jbfin
854 ifr8 = pcb_courant + int(k-jbdeb,8)*int(ld_wcbcb,8)
855#if defined(__ve__)
856!NEC$ IVDEP
857#endif
858 DO i = 1, nupdate_noncritical
859 iposinrhscomp_tmp =
860 & abs(posinrhscomp_fwd(iw(j3 + i)))
861 rhscomp( iposinrhscomp_tmp, k ) =
862 & rhscomp( iposinrhscomp_tmp, k )
863 & + wcb(ifr8 + int(i-1,8))
864 ENDDO
865 ENDDO
866 ENDIF
867 IF ( cbinitzero ) THEN
868 IF ( nupdate .NE. nupdate_noncritical) THEN
869 nb_lock = 1
870 IF (.NOT.do_nbsparse.AND.(keep(400).GT.1)) THEN
871 nb_lock = min(keep(400),nb_lock_max)
872 ENDIF
873 sizeblock = (jbfin-jbdeb+1+nb_lock-1) / nb_lock
874 DO nb = 1, nb_lock
875 jcourant = jbdeb+sizeblock*(nb-1)
876!$ CALL OMP_SET_LOCK(LOCK_FOR_SCATTER(NB))
877 DO k = jcourant, min(jbfin,jcourant+sizeblock-1)
878 ifr8 = pcb_courant + int(k-jbdeb,8)*int(ld_wcbcb,8)
879#if defined(__ve__)
880!NEC$ IVDEP
881#endif
882 DO i = nupdate_noncritical+1, nupdate
883 iposinrhscomp_tmp =
884 & abs(posinrhscomp_fwd(iw(j3 + i)))
885 rhscomp( iposinrhscomp_tmp, k ) =
886 & rhscomp( iposinrhscomp_tmp, k )
887 & + wcb(ifr8 + int(i-1,8))
888 ENDDO
889 ENDDO
890!$ CALL OMP_UNSET_LOCK(LOCK_FOR_SCATTER(NB))
891 ENDDO
892 ENDIF
893 ENDIF
894 ptricb(step( inode )) = ptricb(step( inode )) - nupdate
895 ELSE
896 ptricb(step( inode )) = -1
897 ENDIF
898 ELSE
899 210 CONTINUE
900 CALL zmumps_buf_send_vcb( nrhs_b, inode, fpere,
901 & ncb, ld_wcbcb,
902 & nupdate,
903 & iw( j3 + 1 ), wcb( pcb_courant ), jbdeb, jbfin,
904 & rhscomp, 1, 1, -9999, -9999,
905 & keep,
906 & mumps_procnode(procnode_steps(step(fpere)), keep(199)),
907 & contvec,
908 & comm, ierr )
909 IF ( ierr .EQ. -1 ) THEN
910 CALL zmumps_solve_recv_and_treat( .false., flag,
911 & bufr, lbufr, lbufr_bytes,
912 & myid, slavef, comm,
913 & n, nrhs, ipool, lpool, leaf,
914 & nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac,
915 & iwcb, liwcb,
916 & wcb, lwcb, poswcb, pleftwcb, posiwcb,
917 & ptricb, info, keep,keep8, dkeep, step,
918 & procnode_steps,
919 & rhscomp, lrhscomp, posinrhscomp_fwd
920 & , from_pp
921 & )
922 IF ( info( 1 ) .LT. 0 ) THEN
923 error_was_broadcasted = .true.
924 GOTO 270
925 ENDIF
926 GOTO 210
927 ELSE IF ( ierr .EQ. -2 ) THEN
928 info( 1 ) = -17
929 info( 2 ) = nupdate * keep( 35 ) +
930 & ( nupdate + 3 ) * keep( 34 )
931 error_was_broadcasted = .false.
932 GOTO 270
933 ELSE IF ( ierr .EQ. -3 ) THEN
934 info( 1 ) = -20
935 info( 2 ) = nupdate * keep( 35 ) +
936 & ( nupdate + 3 ) * keep( 34 )
937 error_was_broadcasted = .false.
938 GOTO 270
939 END IF
940 ENDIF
941 END IF
942 IF ( nslaves .NE. 0 .AND. mtype .eq. 1
943 & .and. npiv .NE. 0 ) THEN
944 DO islave = 1, nslaves
945 pdest = iw( ptrist(step(inode)) + 5 + islave +keep(ixsz))
946 CALL mumps_bloc2_get_slave_info(
947 & keep,keep8, inode, step, n, slavef,
948 & istep_to_iniv2, tab_pos_in_pere,
949 & islave, ncb - nelim,
950 & nslaves,
951 & effective_cb_size, firstindex )
952 222 CONTINUE
953 CALL zmumps_buf_send_master2slave( nrhs_b,
954 & inode, fpere,
955 & effective_cb_size, ld_wcbcb, ld_wcbpiv, npiv,
956 & jbdeb, jbfin,
957 & wcb( pcb_courant + nelim + firstindex - 1 ),
958 & wcb( ppiv_courant ),
959 & pdest, comm, keep, ierr )
960 IF ( ierr .EQ. -1 ) THEN
961 CALL zmumps_solve_recv_and_treat( .false., flag,
962 & bufr, lbufr, lbufr_bytes,
963 & myid, slavef, comm,
964 & n, nrhs, ipool, lpool, leaf,
965 & nbfin, nstk_s, iw, liw, a, la, ptrist,ptrfac,
966 & iwcb, liwcb,
967 & wcb, lwcb, poswcb, pleftwcb, posiwcb,
968 & ptricb, info, keep,keep8, dkeep, step,
969 & procnode_steps,
970 & rhscomp, lrhscomp, posinrhscomp_fwd
971 & , from_pp
972 & )
973 IF ( info( 1 ) .LT. 0 ) THEN
974 error_was_broadcasted = .true.
975 GOTO 270
976 ENDIF
977 GOTO 222
978 ELSE IF ( ierr .EQ. -2 ) THEN
979 info( 1 ) = -17
980 info( 2 ) = (npiv+effective_cb_size)*nrhs_b*keep(35) +
981 & 6 * keep( 34 )
982 error_was_broadcasted = .false.
983 GOTO 270
984 ELSE IF ( ierr .EQ. -3 ) THEN
985 info( 1 ) = -20
986 info( 2 ) = (npiv+effective_cb_size)*nrhs_b*keep(35) +
987 & 6 * keep( 34 )
988 error_was_broadcasted = .false.
989 GOTO 270
990 END IF
991 END DO
992 END IF
993 pleftwcb = pleftwcb - int(liell,8)*int(nrhs_b,8)
994 270 CONTINUE
995 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
alpha
#define alpha
Definition eval.h:35
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158
ztrsv
subroutine ztrsv(uplo, trans, diag, n, a, lda, x, incx)
ZTRSV
Definition ztrsv.f:149
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
min
#define min(a, b)
Definition macros.h:20
mumps_bloc2_get_slave_info
subroutine mumps_bloc2_get_slave_info(keep, keep8, inode, step, n, slavef, istep_to_iniv2, tab_pos_in_pere islave, ncb, nslaves, size, first_index)
Definition mumps_type2_blocking.F:367
zmumps_buf
Definition zmumps_comm_buffer.F:14
zmumps_buf::zmumps_buf_send_master2slave
subroutine, public zmumps_buf_send_master2slave(nrhs, inode, ifath, eff_cb_size, ld_cb, ld_piv, npiv, jbdeb, jbfin, cb, sol, dest, comm, keep, ierr)
Definition zmumps_comm_buffer.F:427
zmumps_buf::zmumps_buf_send_vcb
subroutine, public zmumps_buf_send_vcb(nrhs_b, node1, node2, ncb, ldw, long, iw, w, jbdeb, jbfin, rhscomp, nrhs, lrhscomp, iposinrhscomp, npiv, keep, dest, tag, comm, ierr)
Definition zmumps_comm_buffer.F:505
zmumps_ooc
Definition zmumps_ooc.F:14
zmumps_ooc::zmumps_free_factors_for_solve
subroutine zmumps_free_factors_for_solve(inode, ptrfac, nsteps, a, la, flag, ierr)
Definition zmumps_ooc.F:1204
zmumps_ooc::zmumps_ooc_panel_size
integer function, public zmumps_ooc_panel_size(nnmax)
Definition zmumps_ooc.F:3404
zmumps_sol_l0omp_m
Definition zsol_omp_m.F:14
zmumps_sol_l0omp_m::nb_lock_max
integer, parameter nb_lock_max
Definition zsol_omp_m.F:16
zmumps_sol_lr
Definition zsol_lr.F:14
zmumps_sol_lr::zmumps_sol_fwd_lr_su
subroutine zmumps_sol_fwd_lr_su(inode, n, iwhdlr, npiv_global, nslaves, iw, ipos_init, liw, liell, wcb, lwcb, ld_wcbpiv, ld_wcbcb, ppiv_init, pcb_init, rhscomp, lrhscomp, nrhs, posinrhscomp_fwd, jbdeb, jbfin, mtype, keep, keep8, oocwrite_compatible_with_blr, iflag, ierror)
Definition zsol_lr.F:31
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865
mumps_geti8
subroutine mumps_geti8(i8, int_array)
Definition tools_common.F:888
zmumps_permute_panel
subroutine zmumps_permute_panel(ipiv, lpiv, ishift, the_panel, nbrow, nbcol, kbeforepanel)
Definition zooc_panel_piv.F:78
zmumps_ooc_pp_check_perm_freed
subroutine zmumps_ooc_pp_check_perm_freed(iw_location, must_be_permuted)
Definition zooc_panel_piv.F:349
zmumps_get_ooc_perm_ptr
subroutine zmumps_get_ooc_perm_ptr(typef, nbpanels, i_pivptr, i_piv, ipos, iw, liw)
Definition zooc_panel_piv.F:133
zmumps_solve_gemm_update
subroutine zmumps_solve_gemm_update(a, la, apos1, nx, lda, ny, nrhs_b, wcb, lwcb, ptrx, ldx, ptry, ldy, mtype, keep, coef_y)
Definition zsol_aux.F:1327
zmumps_solve_fwd_panels
subroutine zmumps_solve_fwd_panels(a, la, apos, npiv, iw, nrhs_b, wcb, lwcb, lda_wcb, ppiv_courant, mtype, keep)
Definition zsol_aux.F:1226
zmumps_solve_get_ooc_node
subroutine zmumps_solve_get_ooc_node(inode, ptrfac, keep, a, la, step, keep8, n, must_be_permuted, ierr)
Definition zsol_aux.F:733
zmumps_sol_ld_and_reload
subroutine zmumps_sol_ld_and_reload(inode, n, npiv, liell, nelim, nslaves, ppiv_courant, iw, ipos, liw, a, la, apos, wcb, lwcb, ld_wcbpiv, rhscomp, lrhscomp, nrhs, posinrhscomp_fwd, jbdeb, jbfin, mtype, keep, oocwrite_compatible_with_blr, ignore_k459)
Definition zsol_aux.F:1511
zmumps_solve_fwd_trsolve
subroutine zmumps_solve_fwd_trsolve(a, la, apos, npiv, ldadiag, nrhs_b, wcb, lwcb, lda_wcb, ppiv_courant, mtype, keep)
Definition zsol_aux.F:1148
zmumps_sol_ld_and_reload_panel
subroutine zmumps_sol_ld_and_reload_panel(inode, n, npiv, liell, nelim, nslaves, ppiv_courant, iw, ipos, liw, a, la, apos, wcb, lwcb, ld_wcbpiv, rhscomp, lrhscomp, nrhs, posinrhscomp_fwd, jbdeb, jbfin, mtype, keep, oocwrite_compatible_with_blr, ignore_k459)
Definition zsol_aux.F:1381
zmumps_rhscomp_to_wcb
subroutine zmumps_rhscomp_to_wcb(npiv, ncb, liell, cbinitzero, ldeqliellpanel, rhscomp, lrhscomp, nrhs_b, posinrhscomp_fwd, n, wcb, iw, liw, j1, j3, j2, keep, dkeep)
Definition zsol_fwd_aux.F:1083
zmumps_solve_recv_and_treat
recursive subroutine zmumps_solve_recv_and_treat(bloq, flag, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, nrhs, ipool, lpool, leaf, nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac, iwcb, liwcb, wcb, lwcb, poswcb, pleftwcb, posiwcb, ptricb, info, keep, keep8, dkeep, step, procnode_steps, rhscomp, lrhscomp, posinrhscomp_fwd, from_pp)
Definition zsol_fwd_aux.F:1009

◆ zmumps_solve_recv_and_treat()

recursive subroutine zmumps_solve_recv_and_treat ( logical bloq,
logical flag,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer myid,
integer slavef,
integer comm,
integer n,
integer nrhs,
integer, dimension(lpool) ipool,
integer lpool,
integer leaf,
integer nbfin,
integer, dimension( keep(28) ) nstk_s,
integer, dimension( liw ) iw,
integer liw,
complex(kind=8), dimension( la ) a,
integer(8), intent(in) la,
integer, dimension(keep(28)) ptrist,
integer(8), dimension(keep(28)) ptrfac,
integer, dimension( liwcb ) iwcb,
integer liwcb,
complex(kind=8), dimension( lwcb ) wcb,
integer(8), intent(in) lwcb,
integer(8) poswcb,
integer(8) pleftwcb,
integer posiwcb,
integer, dimension(keep(28)) ptricb,
integer, dimension( 80 ) info,
integer, dimension( 500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230), intent(inout) dkeep,
integer, dimension(n) step,
integer, dimension(keep(28)) procnode_steps,
complex(kind=8), dimension(lrhscomp,nrhs) rhscomp,
integer lrhscomp,
integer, dimension(n) posinrhscomp_fwd,
logical, intent(in) from_pp )

Definition at line 997 of file zsol_fwd_aux.F.

1009 IMPLICIT NONE
1010 LOGICAL BLOQ
1011 INTEGER LBUFR, LBUFR_BYTES
1012 INTEGER MYID, SLAVEF, COMM
1013 INTEGER N, NRHS, LPOOL, LEAF, NBFIN
1014 INTEGER LIWCB, POSIWCB
1015 INTEGER(8) :: POSWCB, PLEFTWCB
1016 INTEGER LIW
1017 INTEGER(8), INTENT(IN) :: LA, LWCB
1018 INTEGER INFO( 80 ), KEEP( 500)
1019 INTEGER(8) KEEP8(150)
1020 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
1021 INTEGER BUFR( LBUFR ), IPOOL(LPOOL)
1022 INTEGER NSTK_S( KEEP(28) )
1023 INTEGER IWCB( LIWCB )
1024 INTEGER IW( LIW )
1025 COMPLEX(kind=8) WCB( LWCB ), A( LA )
1026 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28))
1027 INTEGER(8) :: PTRFAC(KEEP(28))
1028 INTEGER STEP(N)
1029 INTEGER PROCNODE_STEPS(KEEP(28))
1030 LOGICAL FLAG
1031 INTEGER LRHSCOMP, POSINRHSCOMP_FWD(N)
1032 COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS)
1033 LOGICAL, intent(in) :: FROM_PP
1034 include 'mpif.h'
1035 include 'mumps_tags.h'
1036 INTEGER :: IERR
1037 INTEGER :: STATUS(MPI_STATUS_SIZE)
1038 INTEGER MSGSOU, MSGTAG, MSGLEN
1039 flag = .false.
1040 IF ( bloq ) THEN
1041 flag = .false.
1042 CALL mpi_probe( mpi_any_source, mpi_any_tag,
1043 & comm, status, ierr )
1044 flag = .true.
1045 ELSE
1046 CALL mpi_iprobe( mpi_any_source, mpi_any_tag, comm,
1047 & flag, status, ierr )
1048 END IF
1049 IF ( flag ) THEN
1050 keep(266) = keep(266) -1
1051 msgsou = status( mpi_source )
1052 msgtag = status( mpi_tag )
1053 CALL mpi_get_count( status, mpi_packed, msglen, ierr )
1054 IF ( msglen .GT. lbufr_bytes ) THEN
1055 info(1) = -20
1056 info(2) = msglen
1057 CALL zmumps_bdc_error( myid, slavef, comm, keep )
1058 ELSE
1059 CALL mpi_recv( bufr, lbufr_bytes, mpi_packed,
1060 & msgsou, msgtag, comm, status, ierr )
1061 CALL zmumps_traiter_message_solve( bufr, lbufr, lbufr_bytes,
1062 & msgtag, msgsou, myid, slavef, comm,
1063 & n, nrhs, ipool, lpool, leaf,
1064 & nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac,
1065 & iwcb, liwcb,
1066 & wcb, lwcb, poswcb,
1067 & pleftwcb, posiwcb,
1068 & ptricb, info, keep,keep8, dkeep, step,
1069 & procnode_steps,
1070 & rhscomp, lrhscomp, posinrhscomp_fwd
1071 & , from_pp
1072 & )
1073 END IF
1074 END IF
1075 RETURN
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_iprobe
subroutine mpi_iprobe(source, tag, comm, flag, status, ierr)
Definition mpi.f:360
mpi_get_count
subroutine mpi_get_count(status, datatype, cnt, ierr)
Definition mpi.f:296
mpi_probe
subroutine mpi_probe(source, tag, comm, status, ierr)
Definition mpi.f:449
zmumps_bdc_error
subroutine zmumps_bdc_error(myid, slavef, comm, keep)
Definition zbcast_int.F:38
zmumps_traiter_message_solve
recursive subroutine zmumps_traiter_message_solve(bufr, lbufr, lbufr_bytes, msgtag, msgsou, myid, slavef, comm, n, nrhs, ipool, lpool, leaf, nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac, iwcb, liwcb, wcb, lwcb, poswcb, pleftwcb, posiwcb, ptricb, info, keep, keep8, dkeep, step, procnode_steps, rhscomp, lrhscomp, posinrhscomp_fwd, from_pp)
Definition zsol_fwd_aux.F:27

◆ zmumps_traiter_message_solve()

recursive subroutine zmumps_traiter_message_solve ( integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer msgtag,
integer msgsou,
integer myid,
integer slavef,
integer comm,
integer n,
integer nrhs,
integer, dimension( lpool ) ipool,
integer lpool,
integer leaf,
integer nbfin,
integer, dimension( n ) nstk_s,
integer, dimension( liw ) iw,
integer liw,
complex(kind=8), dimension( la ) a,
integer(8), intent(in) la,
integer, dimension(keep(28)) ptrist,
integer(8), dimension(keep(28)) ptrfac,
integer, dimension( liwcb ) iwcb,
integer liwcb,
complex(kind=8), dimension( lwcb ) wcb,
integer(8), intent(in) lwcb,
integer(8) poswcb,
integer(8) pleftwcb,
integer posiwcb,
integer, dimension(keep(28)) ptricb,
integer, dimension( 80 ) info,
integer, dimension( 500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230), intent(inout) dkeep,
integer, dimension(n) step,
integer, dimension(keep(28)) procnode_steps,
complex(kind=8), dimension( lrhscomp, nrhs ) rhscomp,
integer lrhscomp,
integer, dimension(n), intent(in) posinrhscomp_fwd,
logical, intent(in) from_pp )

Definition at line 14 of file zsol_fwd_aux.F.

27 USE zmumps_ooc
28 USE zmumps_sol_lr, ONLY: zmumps_sol_slave_lr_u
29 USE zmumps_buf
30 IMPLICIT NONE
31 INTEGER LBUFR, LBUFR_BYTES
32 INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM
33 INTEGER LIW
34 INTEGER(8), INTENT(IN) :: LA, LWCB
35 INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSCOMP
36 INTEGER LIWCB, POSIWCB
37 INTEGER(8) :: POSWCB, PLEFTWCB
38 INTEGER INFO( 80 ), KEEP( 500)
39 INTEGER(8) KEEP8(150)
40 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
41 INTEGER BUFR( LBUFR )
42 INTEGER IPOOL( LPOOL ), NSTK_S( N )
43 INTEGER IWCB( LIWCB )
44 INTEGER IW( LIW )
45 INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28))
46 INTEGER(8) :: PTRFAC(KEEP(28))
47 INTEGER STEP(N)
48 INTEGER PROCNODE_STEPS(KEEP(28))
49 COMPLEX(kind=8) WCB( LWCB ), A( LA )
50 COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NRHS )
51 INTEGER, intent(in) :: POSINRHSCOMP_FWD(N)
52 LOGICAL, intent(in) :: FROM_PP
53 include 'mpif.h'
54 include 'mumps_tags.h'
55 INTEGER(8) :: PTRX, PTRY, IFR8
56 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B
57 INTEGER :: IWHDLR, LDA_SLAVE
58 INTEGER :: MTYPE_SLAVE
59 INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV
60 INTEGER PDEST, I, IPOSINRHSCOMP
61 INTEGER J1
62 INTEGER(8) :: APOS
63 LOGICAL DUMMY
64 LOGICAL FLAG
65 LOGICAL :: OMP_FLAG
66 EXTERNAL mumps_procnode
67 INTEGER MUMPS_PROCNODE
68 LOGICAL COMPRESS_PANEL, LR_ACTIVATED
69 LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR
70 COMPLEX(kind=8) ALPHA, ONE
71 parameter(one=(1.0d0,0.0d0), alpha=(-1.0d0,0.0d0))
72 include 'mumps_headers.h'
73 IF ( msgtag .EQ. racine_solve ) THEN
74 nbfin = nbfin - 1
75 IF ( nbfin .eq. 0 ) GOTO 270
76 ELSE IF (msgtag .EQ. contvec ) THEN
77 position = 0
78 CALL mpi_unpack( bufr, lbufr_bytes, position,
79 & finode, 1, mpi_integer, comm, ierr )
80 CALL mpi_unpack( bufr, lbufr_bytes, position,
81 & fpere, 1, mpi_integer, comm, ierr )
82 CALL mpi_unpack( bufr, lbufr_bytes, position,
83 & ncb, 1, mpi_integer, comm, ierr )
84 CALL mpi_unpack( bufr, lbufr_bytes, position,
85 & jbdeb, 1, mpi_integer, comm, ierr )
86 CALL mpi_unpack( bufr, lbufr_bytes, position,
87 & jbfin, 1, mpi_integer, comm, ierr )
88 CALL mpi_unpack( bufr, lbufr_bytes, position,
89 & long, 1, mpi_integer, comm, ierr )
90 nrhs_b = jbfin-jbdeb+1
91 IF ( ncb .eq. 0 ) THEN
92 ptricb(step(finode)) = -1
93 ELSE
94 IF ( ptricb(step(finode)) .EQ. 0 ) THEN
95 ptricb(step(finode)) = ncb + 1
96 END IF
97 IF ( ( posiwcb - long ) .LT. 0 ) THEN
98 info( 1 ) = -14
99 info( 2 ) = long
100 GOTO 260
101 END IF
102 IF ( poswcb - pleftwcb + 1_8 .LT.
103 & int(long,8) * int(nrhs_b,8)) THEN
104 info( 1 ) = -11
105 CALL mumps_set_ierror(pleftwcb-poswcb-1_8+
106 & int(long,8) * int(nrhs_b,8),
107 & info(2))
108 GOTO 260
109 END IF
110 IF (long .GT. 0) THEN
111 CALL mpi_unpack( bufr, lbufr_bytes, position,
112 & iwcb( 1 ),
113 & long, mpi_integer, comm, ierr )
114 DO k = 1, nrhs_b
115 CALL mpi_unpack( bufr, lbufr_bytes, position,
116 & wcb( pleftwcb ),
117 & long, mpi_double_complex, comm, ierr )
118#if defined(__ve__)
119!NEC$ IVDEP
120#endif
121 DO i = 1, long
122 iposinrhscomp= abs(posinrhscomp_fwd(iwcb(i)))
123 rhscomp(iposinrhscomp,jbdeb+k-1) =
124 & rhscomp(iposinrhscomp,jbdeb+k-1) +
125 & wcb(pleftwcb+i-1)
126 ENDDO
127 END DO
128 ptricb(step(finode)) = ptricb(step(finode)) - long
129 ENDIF
130 END IF
131 IF ( ptricb(step(finode)) == 1 .OR.
132 & ptricb(step(finode)) == -1 ) THEN
133 nstk_s(step(fpere)) = nstk_s(step(fpere)) - 1
134 ptricb(step(finode)) = 0
135 END IF
136 IF ( nstk_s(step(fpere)) .EQ. 0 ) THEN
137 ipool( leaf ) = fpere
138 leaf = leaf + 1
139 IF ( leaf > lpool ) THEN
140 WRITE(*,*)
141 & 'Internal error 1 ZMUMPS_TRAITER_MESSAGE_SOLVE',
142 & leaf, lpool
143 CALL mumps_abort()
144 END IF
145 ENDIF
146 ELSEIF ( msgtag .EQ. master2slave ) THEN
147 position = 0
148 CALL mpi_unpack( bufr, lbufr_bytes, position,
149 & finode, 1, mpi_integer, comm, ierr )
150 CALL mpi_unpack( bufr, lbufr_bytes, position,
151 & fpere, 1, mpi_integer, comm, ierr )
152 CALL mpi_unpack( bufr, lbufr_bytes, position,
153 & ncv, 1, mpi_integer, comm, ierr )
154 CALL mpi_unpack( bufr, lbufr_bytes, position,
155 & npiv, 1, mpi_integer, comm, ierr )
156 CALL mpi_unpack( bufr, lbufr_bytes, position,
157 & jbdeb, 1, mpi_integer, comm, ierr )
158 CALL mpi_unpack( bufr, lbufr_bytes, position,
159 & jbfin, 1, mpi_integer, comm, ierr )
160 nrhs_b = jbfin-jbdeb+1
161 ptry = pleftwcb
162 ptrx = pleftwcb + int(ncv,8) * int(nrhs_b,8)
163 pleftwcb = pleftwcb + int(npiv + ncv,8) * int(nrhs_b,8)
164 IF ( poswcb - pleftwcb + 1 .LT. 0 ) THEN
165 info(1) = -11
166 CALL mumps_set_ierror(-poswcb+pleftwcb-1_8,info(2))
167 GO TO 260
168 END IF
169 DO k=1, nrhs_b
170 CALL mpi_unpack( bufr, lbufr_bytes, position,
171 & wcb( ptry + (k-1) * ncv ), ncv,
172 & mpi_double_complex, comm, ierr )
173 ENDDO
174 IF ( npiv .GT. 0 ) THEN
175 DO k=1, nrhs_b
176 CALL mpi_unpack( bufr, lbufr_bytes, position,
177 & wcb( ptrx + (k-1)*npiv ), npiv,
178 & mpi_double_complex, comm, ierr )
179 END DO
180 END IF
181 lr_activated = (iw(ptrist(step(finode))+xxlr).GT.0)
182 compress_panel = (iw(ptrist(step(finode))+xxlr).GE.2)
183 oocwrite_compatible_with_blr =
184 & (.NOT.lr_activated.OR.(.NOT.compress_panel).OR.
185 & (keep(485).EQ.0)
186 & )
187 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr) THEN
188 CALL zmumps_solve_get_ooc_node(
189 & finode,ptrfac,keep,a,la,step,
190 & keep8,n,dummy,ierr)
191 IF(ierr.LT.0)THEN
192 info(1)=ierr
193 info(2)=0
194 GOTO 260
195 ENDIF
196 ENDIF
197 IF ( iw(ptrist(step(finode))+xxlr) .GE. 2 .AND.
198 & keep(485) .EQ. 1 ) THEN
199 iwhdlr = iw(ptrist(step(finode))+xxf)
200 mtype_slave = 1
201 CALL zmumps_sol_slave_lr_u( finode, iwhdlr,
202 & -9999,
203 & wcb, lwcb,
204 & npiv, ncv,
205 & ptrx, ptry,
206 & jbdeb, jbfin,
207 & mtype_slave, keep, keep8,
208 & info(1), info(2) )
209 ELSE
210 apos = ptrfac(step(finode))
211 IF (keep(201) .EQ. 1) THEN
212 mtype_slave = 0
213 lda_slave = ncv
214 ELSE
215 mtype_slave = 1
216 lda_slave = npiv
217 ENDIF
218 CALL zmumps_solve_gemm_update
219 & ( a, la, apos, npiv,
220 & lda_slave,
221 & ncv,
222 & nrhs_b, wcb, lwcb,
223 & ptrx, npiv,
224 & ptry, ncv,
225 & mtype_slave, keep, one )
226 ENDIF
227 IF ((keep(201).GT.0).AND.oocwrite_compatible_with_blr) THEN
228 CALL zmumps_free_factors_for_solve(finode,ptrfac,
229 & keep(28),a,la,.true.,ierr)
230 IF(ierr.LT.0)THEN
231 info(1)=ierr
232 info(2)=0
233 GOTO 260
234 ENDIF
235 ENDIF
236 pleftwcb = pleftwcb - int(npiv,8) * int(nrhs_b,8)
237 pdest = mumps_procnode( procnode_steps(step(fpere)),
238 & keep(199) )
239 IF ( pdest .EQ. myid ) THEN
240 IF ( ptricb(step(finode)) .EQ. 0 ) THEN
241 ncb = iw( ptrist(step(finode)) + 2 + keep(ixsz) )
242 ptricb(step(finode)) = ncb + 1
243 END IF
244 j1 = ptrist(step(finode))+3+keep(ixsz)
245 omp_flag = .false.
246!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND.
247!$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) )
248 IF (omp_flag) THEN
249!$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSCOMP)
250 DO k=1, nrhs_b
251 ifr8 = ptry+int(k-1,8)*int(ncv,8)
252#if defined(__ve__)
253!NEC$ IVDEP
254#endif
255 DO i = 1,ncv
256 jj = iw(j1+i)
257 iposinrhscomp= abs(posinrhscomp_fwd(jj))
258 rhscomp(iposinrhscomp,jbdeb+k-1)=
259 & rhscomp(iposinrhscomp,jbdeb+k-1)
260 & + wcb(ifr8+int(i-1,8))
261 ENDDO
262 ENDDO
263!$OMP END PARALLEL DO
264 ELSE
265 DO k=1, nrhs_b
266 ifr8 = ptry+int(k-1,8)*int(ncv,8)
267#if defined(__ve__)
268!NEC$ IVDEP
269#endif
270 DO i = 1,ncv
271 jj = iw(j1+i)
272 iposinrhscomp= abs(posinrhscomp_fwd(jj))
273 rhscomp(iposinrhscomp,jbdeb+k-1)=
274 & rhscomp(iposinrhscomp,jbdeb+k-1)
275 & + wcb(ifr8+int(i-1,8))
276 ENDDO
277 ENDDO
278 ENDIF
279 ptricb(step(finode)) = ptricb(step(finode)) - ncv
280 IF ( ptricb( step( finode ) ) == 1 ) THEN
281 nstk_s(step(fpere)) = nstk_s(step(fpere)) - 1
282 ptricb(step(finode)) = 0
283 END IF
284 IF ( nstk_s(step(fpere)) .EQ. 0 ) THEN
285 ipool( leaf ) = fpere
286 leaf = leaf + 1
287 IF ( leaf > lpool ) THEN
288 WRITE(*,*)
289 & 'INTERNAL Error in ZMUMPS_TRAITER_MESSAGE_SOLVE',
290 & leaf, lpool
291 CALL mumps_abort()
292 END IF
293 ENDIF
294 ELSE
295 210 CONTINUE
296 CALL zmumps_buf_send_vcb( nrhs_b, finode, fpere,
297 & iw(ptrist(step( finode )) + 2 + keep(ixsz) ), ncv,ncv,
298 & iw(ptrist(step(finode))+4+ keep(ixsz) ),
299 & wcb( ptry ), jbdeb, jbfin,
300 & rhscomp, 1, 1, -9999, -9999,
301 & keep, pdest, contvec, comm, ierr )
302 IF ( ierr .EQ. -1 ) THEN
303 CALL zmumps_solve_recv_and_treat( .false., flag,
304 & bufr, lbufr, lbufr_bytes,
305 & myid, slavef, comm,
306 & n, nrhs, ipool, lpool, leaf,
307 & nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac,
308 & iwcb, liwcb,
309 & wcb, lwcb, poswcb, pleftwcb, posiwcb,
310 & ptricb, info, keep,keep8, dkeep, step,
311 & procnode_steps,
312 & rhscomp, lrhscomp, posinrhscomp_fwd
313 & , from_pp
314 & )
315 IF ( info( 1 ) .LT. 0 ) GOTO 270
316 GOTO 210
317 ELSE IF ( ierr .EQ. -2 ) THEN
318 info( 1 ) = -17
319 info( 2 ) = ( ncv + 4 ) * keep( 34 ) +
320 & ncv * keep( 35 )
321 GOTO 260
322 ELSE IF ( ierr .EQ. -3 ) THEN
323 info( 1 ) = -20
324 info( 2 ) = ( ncv + 4 ) * keep( 34 ) +
325 & ncv * keep( 35 )
326 END IF
327 END IF
328 pleftwcb = pleftwcb - int(ncv,8) * int(nrhs_b,8)
329 ELSEIF ( msgtag .EQ. terreur ) THEN
330 info(1) = -001
331 info(2) = msgsou
332 GOTO 270
333 ELSE IF ( (msgtag.EQ.update_load).OR.
334 & (msgtag.EQ.tag_dummy) ) THEN
335 GO TO 270
336 ELSE
337 info(1)=-100
338 info(2)=msgtag
339 GO TO 260
340 ENDIF
341 GO TO 270
342 260 CONTINUE
343 CALL zmumps_bdc_error( myid, slavef, comm, keep )
344 270 CONTINUE
345 RETURN
mpi_unpack
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
zmumps_sol_lr::zmumps_sol_slave_lr_u
subroutine zmumps_sol_slave_lr_u(inode, iwhdlr, npiv_global, wcb, lwcb, ldx, ldy, ptrx_init, ptry_init, jbdeb, jbfin, mtype, keep, keep8, iflag, ierror)
Definition zsol_lr.F:189