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

Go to the source code of this file.

Functions/Subroutines

subroutine mumps_ab_free_lmat (lmat)
subroutine mumps_ab_free_gcomp (gcomp)
subroutine mumps_ab_compute_sizeofblock (nblk, ndof, blkptr, blkvar, sizeofblocks, dof2block)
subroutine mumps_ab_coord_to_lmat (myid, nblk, ndof, nnz, irn, jcn, dof2block, iflag, ierror, lp, lpok, lmat)
subroutine mumps_ab_localclean_lmat (myid, nblk, lmat, flag, iflag, ierror, lp, lpok)
subroutine mumps_ab_lmat_to_lumat (lmat, lumat, info, icntl)
subroutine mumps_ab_print_lmatrix (lmat, myid, lp)
subroutine mumps_ab_lmat_to_clean_g (myid, unfold, ready_for_ana_f, lmat, gcomp, info, icntl)
subroutine mumps_ab_col_distribution (option, info, icntl, comm, nblk, myid, nprocs, lmat, mapcol)
subroutine mumps_ab_compute_mapcol (option, info, icntl, myid, nnz, nz_row, size_nzrow, nblk, nprocs, mapcol)
subroutine mumps_ab_build_dclean_lumatrix (mapcolonlumat, mapcol_in_nsteps, info, icntl, keep, comm, myid, nblk, nprocs, lmat, mapcol, sizemapcol, step, sizestep, lumat)
subroutine mumps_inialize_redist_lumat (info, icntl, keep, comm, myid, nblk, lumat, procnode_steps, nsteps, mapcol, lumat_remap, nbrecords, step)
subroutine mumps_ab_dcoord_to_dcompg (myid, nprocs, comm, nblk, ndof, nnz, irn, jcn, dof2block, icntl, info, keep, lumat, gcomp, ready_for_ana_f)
subroutine mumps_ab_dcoord_to_dtree_lumat (myid, nprocs, comm, nblk, ndof, nnz, irn, jcn, procnode_steps, nsteps, step, icntl, info, keep, mapcol, lumat)
subroutine mumps_ab_dist_lmat_to_lumat (unfold, mapcol_in_nsteps, info, icntl, comm, myid, nblk, slavef, lmat, mapcol, sizemapcol, step, sizestep, lumat, nbrecords, nsend8, nlocal8)
subroutine mumps_ab_lmat_treat_recv_buf (myid, bufi, nbrecords, lumat, nblk, ptloc, end_msg_2_recv)
subroutine mumps_ab_lmat_fill_buffer (dest, isend, jsend, nblk, bufi, bufreci, ptloc, nbrecords, slavef, comm, myid, iact, ireqi, send_active, lmat, lumat, end_msg_2_recv)
subroutine mumps_ab_gather_graph (icntl, keep, comm, myid, nprocs, info, gcomp_dist, gcomp)

Function/Subroutine Documentation

◆ mumps_ab_build_dclean_lumatrix()

subroutine mumps_ab_build_dclean_lumatrix ( logical, intent(in) mapcolonlumat,
logical, intent(in) mapcol_in_nsteps,
integer, dimension(80), intent(inout) info,
integer, dimension(60), intent(in) icntl,
integer, dimension(500), intent(in) keep,
integer, intent(in) comm,
integer, intent(in) myid,
integer, intent(in) nblk,
integer, intent(in) nprocs,
type(lmatrix_t), intent(inout) lmat,
integer, dimension(sizemapcol), intent(inout) mapcol,
integer, intent(in) sizemapcol,
integer, dimension(sizestep), intent(in) step,
integer, intent(in) sizestep,
type(lmatrix_t), intent(out) lumat )

Definition at line 630 of file ana_blk.F.

636 USE mumps_ana_blk_m
637 IMPLICIT NONE
638 include 'mpif.h'
639 include 'mumps_tags.h'
640 LOGICAL, INTENT(IN) :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS
641 INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, SIZEMAPCOL
642 INTEGER, INTENT(IN) :: ICNTL(60), COMM, KEEP(500)
643 INTEGER, INTENT(IN) :: SIZESTEP
644 INTEGER, INTENT(IN) :: STEP(SIZESTEP)
645 INTEGER, INTENT(INOUT) :: INFO(80)
646 TYPE(LMATRIX_T), INTENT(INOUT) :: LMAT
647 INTEGER, INTENT(INOUT) :: MAPCOL(SIZEMAPCOL)
648 TYPE(LMATRIX_T), INTENT(OUT) :: LUMAT
649 INTEGER :: NBLKloc, IERR, JB, IB, LP, NB, I,
650 & NBRECORDS
651 INTEGER(8) :: NNZ, NZ_locMAX8, NSEND8, NLOCAL8
652 LOGICAL :: LPOK
653 INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL
654 INTEGER OPTION
655 parameter(option=2)
656 nblkloc = lmat%NBCOL
657 IF (nblkloc.NE.nblk) THEN
658 write(6,*) "Internal error in MUMPS_AB_BUILD_DCLEAN_LUMATRIX ",
659 & "NBLKloc, NBLK=", nblkloc, nblk
660 ENDIF
661 lp = icntl( 1 )
662 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
663 ALLOCATE(wt(nblk), wnbincol(nblk), stat=ierr)
664 IF (ierr.NE.0) THEN
665 info(1) = -7
666 info(2) = 2*nblk
667 IF ( lpok ) THEN
668 WRITE(lp, *) " ERROR allocate of LUMAT%COL; WT"
669 END IF
670 GOTO 500
671 ENDIF
672 CALL mumps_propinfo( icntl(1), info(1),
673 & comm, myid )
674 IF ( info(1) .LT. 0 ) GOTO 500
675 DO jb=1, nblk
676 wt(jb) = lmat%COL(jb)%NBINCOL
677 ENDDO
678 DO jb=1,nblk
679 IF ( lmat%COL(jb)%NBINCOL.EQ.0) cycle
680 DO ib=1, lmat%COL(jb)%NBINCOL
681 i = lmat%COL(jb)%IRN(ib)
682 wt(i)= wt(i)+1
683 ENDDO
684 ENDDO
685 CALL mpi_allreduce(wt(1), wnbincol(1), nblk,
686 & mpi_integer, mpi_sum, comm, ierr)
687 IF (allocated(wt)) DEALLOCATE(wt)
688 IF (mapcolonlumat) THEN
689 nnz = 0_8
690 DO i=1, nblk
691 nnz=nnz+int(wnbincol(i),8)
692 ENDDO
693 CALL mumps_ab_compute_mapcol (option, info, icntl,
694 & myid, nnz, wnbincol(1), nblk,
695 & nblk, nprocs, mapcol(1))
696 CALL mumps_propinfo( icntl(1), info(1),
697 & comm, myid )
698 IF ( info(1) .LT. 0 ) GOTO 500
699 ENDIF
700 lumat%NBCOL = nblk
701 lumat%NZL = 0_8
702 ALLOCATE(lumat%COL(nblk), stat=ierr)
703 IF (ierr.NE.0) THEN
704 info(1) = -7
705 info(2) = nblk
706 IF ( lpok ) THEN
707 WRITE(lp, *) " ERROR allocate of LUMAT%COL; WT"
708 END IF
709 ENDIF
710 IF ( info(1) .GE. 0 ) THEN
711 DO jb=1,nblk
712 nb = wnbincol(jb)
713 IF (mapcol_in_nsteps) THEN
714 IF (mapcol(abs(step(jb))).EQ.myid) THEN
715 lumat%NZL = lumat%NZL + int(nb,8)
716 ELSE
717 nb = 0
718 ENDIF
719 ELSE
720 IF (mapcol(jb).EQ.myid) THEN
721 lumat%NZL = lumat%NZL + int(nb,8)
722 ELSE
723 nb = 0
724 ENDIF
725 ENDIF
726 lumat%COL(jb)%NBINCOL = nb
727 IF (nb.GT.0) THEN
728 ALLOCATE(lumat%COL(jb)%IRN(nb), stat=ierr)
729 IF (ierr.NE.0) THEN
730 info(1) = -7
731 info(2) = nb
732 IF ( lpok ) THEN
733 WRITE(lp, *) " ERROR allocate of LUMAT%COL"
734 END IF
735 EXIT
736 ENDIF
737 ENDIF
738 ENDDO
739 ENDIF
740 CALL mumps_propinfo( icntl(1), info(1),
741 & comm, myid )
742 IF ( info(1) .LT. 0 ) GOTO 500
743 IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
744 CALL mpi_allreduce(lumat%NZL, nz_locmax8, 1, mpi_integer8,
745 & mpi_max, comm, ierr)
746 nbrecords = keep(39)
747 IF (nz_locmax8 .LT. int(nbrecords,8)) THEN
748 nbrecords = int(nz_locmax8)
749 ENDIF
750 CALL mumps_ab_dist_lmat_to_lumat (
751 & .true.,
752 & mapcol_in_nsteps,
753 & info, icntl, comm, myid, nblk, nprocs,
754 & lmat, mapcol, sizemapcol, step, sizestep,
755 & lumat, nbrecords, nsend8, nlocal8
756 & )
757 CALL mumps_ab_free_lmat(lmat)
758 CALL mumps_propinfo( icntl(1), info(1),
759 & comm, myid )
760 IF ( info(1) .LT. 0 ) GOTO 500
761 ALLOCATE(wt(nblk), stat=ierr)
762 IF (ierr.NE.0) THEN
763 info(1) = -7
764 info(2) = 2*nblk
765 IF ( lpok ) THEN
766 WRITE(lp, *) " ERROR allocate of LUMAT%COL; WT"
767 END IF
768 GOTO 500
769 ENDIF
770 CALL mumps_ab_localclean_lmat ( myid,
771 & nblk, lumat, wt(1), info(1), info(2), lp, lpok
772 & )
773 CALL mumps_propinfo( icntl(1), info(1),
774 & comm, myid )
775 IF ( info(1) .LT. 0 ) GOTO 500
776 DEALLOCATE(wt)
777 GOTO 600
778 500 CONTINUE
779 IF (allocated(wt)) DEALLOCATE(wt)
780 IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
781 600 CONTINUE
782 RETURN
mumps_ab_dist_lmat_to_lumat
subroutine mumps_ab_dist_lmat_to_lumat(unfold, mapcol_in_nsteps, info, icntl, comm, myid, nblk, slavef, lmat, mapcol, sizemapcol, step, sizestep, lumat, nbrecords, nsend8, nlocal8)
Definition ana_blk.F:1082
mumps_ab_localclean_lmat
subroutine mumps_ab_localclean_lmat(myid, nblk, lmat, flag, iflag, ierror, lp, lpok)
Definition ana_blk.F:154
mumps_ab_free_lmat
subroutine mumps_ab_free_lmat(lmat)
Definition ana_blk.F:15
mumps_ab_compute_mapcol
subroutine mumps_ab_compute_mapcol(option, info, icntl, myid, nnz, nz_row, size_nzrow, nblk, nprocs, mapcol)
Definition ana_blk.F:560
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
mpi_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
mumps_ana_blk_m
Definition ana_blk_m.F:14

◆ mumps_ab_col_distribution()

subroutine mumps_ab_col_distribution ( integer, intent(in) option,
integer, dimension(80) info,
integer, dimension(60), intent(in) icntl,
integer, intent(in) comm,
integer, intent(in) nblk,
integer, intent(in) myid,
integer, intent(in) nprocs,
type(lmatrix_t) lmat,
integer, dimension(nblk), intent(out) mapcol )

Definition at line 505 of file ana_blk.F.

508 USE mumps_ana_blk_m, ONLY : lmatrix_t
509 IMPLICIT NONE
510 include 'mpif.h'
511 include 'mumps_tags.h'
512 INTEGER IERR
513 INTEGER, INTENT(IN) :: OPTION, NBLK
514 INTEGER, INTENT(IN) :: ICNTL(60), COMM, MYID, NPROCS
515 INTEGER :: INFO(80)
516 TYPE(LMATRIX_T) :: LMAT
517 INTEGER, INTENT(OUT):: MAPCOL(NBLK)
518 INTEGER :: LP, SIZE_NZROW, I
519 LOGICAL :: LPOK
520 INTEGER(8) :: NZL, NNZ
521 INTEGER, DIMENSION(:), ALLOCATABLE :: NZ_ROW
522 lp = icntl( 1 )
523 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
524 IF (option.EQ.1) THEN
525 nnz = -9999
526 size_nzrow = 1
527 ELSE
528 nzl = lmat%NZL
529 size_nzrow = nblk
530 ENDIF
531 ALLOCATE(nz_row(nblk), stat=ierr)
532 IF (ierr.NE.0) THEN
533 info(1) = -7
534 info(2) = size_nzrow
535 IF ( lpok ) THEN
536 WRITE(lp, *)
537 & " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", info(2)
538 END IF
539 ENDIF
540 CALL mumps_propinfo( icntl(1), info(1),
541 & comm, myid )
542 IF (info(1).LT.0) GOTO 500
543 IF (option.NE.1) THEN
544 DO i = 1, nblk
545 mapcol(i) = lmat%COL(i)%NBINCOL
546 ENDDO
547 CALL mpi_allreduce(mapcol(1), nz_row(1), nblk,
548 & mpi_integer, mpi_sum, comm, ierr)
549 CALL mpi_allreduce(nzl, nnz, 1,
550 & mpi_integer8, mpi_sum, comm, ierr)
551 ENDIF
552 CALL mumps_ab_compute_mapcol (option, info, icntl, myid,
553 & nnz, nz_row(1), size_nzrow, nblk, nprocs, mapcol(1))
554 500 CONTINUE
555 IF (allocated(nz_row)) DEALLOCATE(nz_row)
556 RETURN
mumps_ana_blk_m::lmatrix_t
Definition ana_blk_m.F:19

◆ mumps_ab_compute_mapcol()

subroutine mumps_ab_compute_mapcol ( integer, intent(in) option,
integer, dimension(80) info,
integer, dimension(60), intent(in) icntl,
integer, intent(in) myid,
integer(8) nnz,
integer, dimension(size_nzrow), intent(in) nz_row,
integer, intent(in) size_nzrow,
integer, intent(in) nblk,
integer, intent(in) nprocs,
integer, dimension(nblk), intent(out) mapcol )

Definition at line 558 of file ana_blk.F.

560 INTEGER, INTENT(IN) :: OPTION, MYID, SIZE_NZROW, NBLK
561 INTEGER, INTENT(IN) :: ICNTL(60), NPROCS
562 INTEGER :: INFO(80)
563 INTEGER(8) :: NNZ
564 INTEGER, INTENT(IN) :: NZ_ROW(SIZE_NZROW)
565 INTEGER, INTENT(OUT):: MAPCOL(NBLK)
566 INTEGER :: I, J, P, F, LP, IERR
567 LOGICAL :: LPOK
568 INTEGER(8) :: SHARE, T
569 INTEGER, DIMENSION(:), ALLOCATABLE :: FIRST
570 lp = icntl( 1 )
571 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
572 ALLOCATE(first(nprocs+1), stat=ierr)
573 IF (ierr.NE.0) THEN
574 info(1) = -7
575 info(2) = nprocs+1
576 IF ( lpok ) THEN
577 WRITE(lp, *)
578 & " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", info(2)
579 END IF
580 GOTO 500
581 ENDIF
582 DO i=1,nprocs+1
583 first(i) = 0
584 ENDDO
585 IF (option.EQ.1) THEN
586 share = int(nblk/nprocs,8)
587 DO i=1, nprocs
588 first(i) = (i-1)*int(share)+1
589 END DO
590 first(nprocs+1)=nblk+1
591 ELSE
592 share = (nnz-1_8)/int(nprocs,8) + 1_8
593 p = 0
594 t = 0_8
595 f = 1
596 DO i=1, nblk
597 t = t+int(nz_row(i),8)
598 IF (
599 & (t .GE. share) .OR.
600 & ((nblk-i).EQ.(nprocs-p-1)) .OR.
601 & (i.EQ.nblk)
602 & ) THEN
603 p = p+1
604 IF(p.EQ.nprocs) THEN
605 first(p) = f
606 EXIT
607 ELSE
608 first(p) = f
609 f = i+1
610 t = 0_8
611 END IF
612 END IF
613 IF ((i.EQ.nblk).AND.(p.NE.nprocs)) THEN
614 DO j=p,nprocs
615 first(j) = first(p)
616 ENDDO
617 ENDIF
618 END DO
619 first(nprocs+1) = nblk+1
620 ENDIF
621 DO i=1,nprocs
622 DO j=first(i), first(i+1)-1
623 mapcol(j) = i-1
624 ENDDO
625 ENDDO
626 IF (allocated(first)) DEALLOCATE(first)
627 500 CONTINUE
628 RETURN

◆ mumps_ab_compute_sizeofblock()

subroutine mumps_ab_compute_sizeofblock ( integer, intent(in) nblk,
integer, intent(in) ndof,
integer, dimension(nblk+1), intent(in) blkptr,
integer, dimension(ndof), intent(in) blkvar,
integer, dimension(nblk), intent(out) sizeofblocks,
integer, dimension(ndof), intent(out) dof2block )

Definition at line 45 of file ana_blk.F.

48 IMPLICIT NONE
49 INTEGER, INTENT(IN) :: NBLK, NDOF
50 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(NDOF)
51 INTEGER, INTENT(OUT):: SIZEOFBLOCKS(NBLK), DOF2BLOCK(NDOF)
52 INTEGER :: IB, I, IDOF
53 DO ib=1, nblk
54 sizeofblocks(ib)= blkptr(ib+1)-blkptr(ib)
55 DO i=blkptr(ib), blkptr(ib+1)-1
56 idof = blkvar(i)
57 dof2block(idof) = ib
58 ENDDO
59 ENDDO
60 RETURN

◆ mumps_ab_coord_to_lmat()

subroutine mumps_ab_coord_to_lmat ( integer, intent(in) myid,
integer, intent(in) nblk,
integer, intent(in) ndof,
integer(8), intent(in) nnz,
integer, dimension(max(1_8,nnz)), intent(in) irn,
integer, dimension(max(1_8,nnz)), intent(in) jcn,
integer, dimension(ndof), intent(in) dof2block,
integer iflag,
integer ierror,
integer lp,
logical, intent(in) lpok,
type(lmatrix_t) lmat )

Definition at line 62 of file ana_blk.F.

67 USE mumps_ana_blk_m, ONLY : lmatrix_t
68 IMPLICIT NONE
69 INTEGER, INTENT(IN) :: MYID, NBLK, NDOF
70 INTEGER(8), INTENT(IN) :: NNZ
71 INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ))
72 INTEGER, INTENT(IN) :: DOF2BLOCK(NDOF)
73 INTEGER :: LP, IFLAG, IERROR
74 LOGICAL, INTENT(IN) :: LPOK
75 TYPE(LMATRIX_T) :: LMAT
76 INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAG
77 INTEGER :: allocok
78 INTEGER :: I, J, JJB, IIB, IB, JB, NB, PT
79 INTEGER(8) :: I8
80 lmat%NBCOL = nblk
81 lmat%NZL = 0_8
82 ALLOCATE(lmat%COL(nblk),flag(nblk), stat=allocok)
83 IF (allocok.NE.0) THEN
84 iflag = -7
85 ierror = 2*nblk
86 IF ( lpok ) THEN
87 WRITE(lp, *) " ERROR allocate of LMAT%COL"
88 END IF
89 RETURN
90 ENDIF
91 DO ib=1,nblk
92 lmat%COL(ib)%NBINCOL = 0
93 flag(ib) = 0
94 ENDDO
95 ierror = 0
96 DO i8=1, nnz
97 i = irn(i8)
98 j = jcn(i8)
99 IF ( (i.GT.ndof).OR.(j.GT.ndof).OR.(i.LT.1)
100 & .OR.(j.LT.1)) THEN
101 ierror = ierror + 1
102 ELSE
103 ib = dof2block(i)
104 jb = dof2block(j)
105 jjb = min(ib,jb)
106 IF (ib.NE.jb) THEN
107 lmat%NZL = lmat%NZL+1_8
108 lmat%COL(jjb)%NBINCOL = lmat%COL(jjb)%NBINCOL + 1
109 ENDIF
110 ENDIF
111 ENDDO
112 IF (ierror.GE.1) THEN
113 IF (mod(iflag,2) .EQ. 0) iflag = iflag+1
114 ENDIF
115 DO jb=1,nblk
116 nb = lmat%COL(jb)%NBINCOL
117 IF (nb.GT.0) THEN
118 ALLOCATE(lmat%COL(jb)%IRN(nb), stat=allocok)
119 IF (allocok.NE.0) THEN
120 iflag = -7
121 ierror = nblk
122 IF ( lpok ) THEN
123 WRITE(lp, *) " ERROR allocate of LMAT%COL"
124 END IF
125 RETURN
126 ENDIF
127 ENDIF
128 ENDDO
129 DO i8=1, nnz
130 i = irn(i8)
131 j = jcn(i8)
132 IF ( (i.LE.ndof).AND.(j.LE.ndof).AND.(i.GE.1)
133 & .AND.(j.GE.1)) THEN
134 ib = dof2block(i)
135 jb = dof2block(j)
136 jjb = min(ib,jb)
137 iib = max(ib,jb)
138 IF (iib.NE.jjb) THEN
139 pt = flag(jjb)+1
140 flag(jjb) = pt
141 lmat%COL(jjb)%IRN(pt) = iib
142 ENDIF
143 ENDIF
144 ENDDO
145 CALL mumps_ab_localclean_lmat ( myid,
146 & nblk, lmat, flag(1), iflag, ierror, lp, lpok
147 & )
148 DEALLOCATE(flag)
149 RETURN
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ mumps_ab_dcoord_to_dcompg()

subroutine mumps_ab_dcoord_to_dcompg ( integer, intent(in) myid,
integer, intent(in) nprocs,
integer, intent(in) comm,
integer, intent(in) nblk,
integer, intent(in) ndof,
integer(8), intent(in) nnz,
integer, dimension(max(1_8,nnz)), intent(in) irn,
integer, dimension(max(1_8,nnz)), intent(in) jcn,
integer, dimension(ndof), intent(inout) dof2block,
integer, dimension(60), intent(in) icntl,
integer, dimension(80), intent(inout) info,
integer, dimension(500), intent(inout) keep,
type(lmatrix_t) lumat,
type(compact_graph_t) gcomp,
logical, intent(in) ready_for_ana_f )

Definition at line 888 of file ana_blk.F.

894 USE mumps_ana_blk_m, ONLY: lmatrix_t, compact_graph_t
895 IMPLICIT NONE
896 include 'mpif.h'
897 include 'mumps_tags.h'
898 INTEGER IERR, MASTER
899 parameter( master = 0 )
900 INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, NDOF
901 INTEGER(8), INTENT(IN) :: NNZ
902 INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ))
903 LOGICAL, INTENT(IN) :: READY_FOR_ANA_F
904 INTEGER, INTENT(INOUT) :: DOF2BLOCK(NDOF)
905 INTEGER, INTENT(IN) :: ICNTL(60), COMM
906 INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80)
907 TYPE(COMPACT_GRAPH_T) :: GCOMP
908 TYPE(LMATRIX_T) :: LUMAT
909 TYPE(LMATRIX_T) :: LMAT
910 INTEGER :: IDUMMY_ARRAY(1)
911 INTEGER :: allocok, LP, MPG
912 LOGICAL :: LPOK, PROKG
913 INTEGER, DIMENSION(:), ALLOCATABLE :: MAPCOL
914 LOGICAL :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS
915 INTEGER OPTION
916 parameter(option=2)
917 lp = icntl( 1 )
918 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
919 mpg = icntl( 3 )
920 prokg = ( mpg .GT. 0 .and. myid .eq. master )
921 mapcolonlumat = .false.
922 mapcol_in_nsteps = .false.
923 IF (keep(14).EQ.1) THEN
924 CALL mumps_abort()
925 ENDIF
926 IF (keep(14).EQ.0) THEN
927 CALL mpi_bcast( dof2block, ndof, mpi_integer, master,
928 & comm, ierr )
929 ENDIF
930 CALL mumps_ab_coord_to_lmat ( myid,
931 & nblk, ndof, nnz, irn, jcn,
932 & dof2block,
933 & info(1), info(2), lp, lpok,
934 & lmat)
935 CALL mumps_propinfo( icntl(1), info(1),
936 & comm, myid )
937 IF ( info(1) .LT. 0 ) GOTO 500
938 ALLOCATE(mapcol(nblk), stat=allocok)
939 IF (allocok.NE.0) THEN
940 info(1) = -7
941 info(2) = nblk
942 IF ( lpok ) THEN
943 WRITE(lp, *) " ERROR allocate MAPCOL of size",
944 & info(2)
945 END IF
946 ENDIF
947 CALL mumps_propinfo( icntl(1), info(1),
948 & comm, myid )
949 IF ( info(1) .LT. 0 ) GOTO 500
950 IF (.NOT.mapcolonlumat) THEN
951 CALL mumps_ab_col_distribution (option,
952 & info, icntl, comm, nblk, myid, nprocs,
953 & lmat, mapcol)
954 CALL mumps_propinfo( icntl(1), info(1),
955 & comm, myid )
956 IF ( info(1) .LT. 0 ) GOTO 500
957 ENDIF
958 CALL mumps_ab_build_dclean_lumatrix (
959 & mapcolonlumat, mapcol_in_nsteps,
960 & info, icntl, keep, comm, myid, nblk, nprocs,
961 & lmat, mapcol, nblk,
962 & idummy_array, 1,
963 & lumat)
964 CALL mumps_propinfo( icntl(1), info(1),
965 & comm, myid )
966 IF ( info(1) .LT. 0 ) GOTO 500
967 IF (allocated(mapcol)) DEALLOCATE(mapcol)
968 CALL mumps_ab_lmat_to_clean_g ( myid, .false.,
969 & ready_for_ana_f,
970 & lumat, gcomp, info, icntl
971 & )
972 CALL mumps_propinfo( icntl(1), info(1),
973 & comm, myid )
974 IF ( info(1) .LT. 0 ) GOTO 500
975 IF (keep(494).EQ.0) THEN
976 CALL mumps_ab_free_lmat(lumat)
977 ENDIF
978 GOTO 600
979 500 CONTINUE
980 IF (allocated(mapcol)) DEALLOCATE(mapcol)
981 CALL mumps_ab_free_lmat(lmat)
982 CALL mumps_ab_free_lmat(lumat)
983 600 CONTINUE
984 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
mumps_ab_lmat_to_clean_g
subroutine mumps_ab_lmat_to_clean_g(myid, unfold, ready_for_ana_f, lmat, gcomp, info, icntl)
Definition ana_blk.F:291
mumps_ab_col_distribution
subroutine mumps_ab_col_distribution(option, info, icntl, comm, nblk, myid, nprocs, lmat, mapcol)
Definition ana_blk.F:508
mumps_ab_build_dclean_lumatrix
subroutine mumps_ab_build_dclean_lumatrix(mapcolonlumat, mapcol_in_nsteps, info, icntl, keep, comm, myid, nblk, nprocs, lmat, mapcol, sizemapcol, step, sizestep, lumat)
Definition ana_blk.F:636
mumps_ab_coord_to_lmat
subroutine mumps_ab_coord_to_lmat(myid, nblk, ndof, nnz, irn, jcn, dof2block, iflag, ierror, lp, lpok, lmat)
Definition ana_blk.F:67
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
mumps_ana_blk_m::compact_graph_t
Definition ana_blk_m.F:24

◆ mumps_ab_dcoord_to_dtree_lumat()

subroutine mumps_ab_dcoord_to_dtree_lumat ( integer, intent(in) myid,
integer, intent(in) nprocs,
integer, intent(in) comm,
integer, intent(in) nblk,
integer, intent(in) ndof,
integer(8), intent(in) nnz,
integer, dimension(max(1_8,nnz)), intent(in) irn,
integer, dimension(max(1_8,nnz)), intent(in) jcn,
integer, dimension(nsteps), intent(in) procnode_steps,
integer, intent(in) nsteps,
integer, dimension(nblk), intent(in) step,
integer, dimension(60), intent(in) icntl,
integer, dimension(80), intent(inout) info,
integer, dimension(500), intent(inout) keep,
integer, dimension(nsteps), intent(out) mapcol,
type(lmatrix_t) lumat )

Definition at line 986 of file ana_blk.F.

993 USE mumps_ana_blk_m, ONLY: lmatrix_t
994 IMPLICIT NONE
995 include 'mpif.h'
996 include 'mumps_tags.h'
997 INTEGER IERR, MASTER
998 parameter( master = 0 )
999 INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, NDOF, NSTEPS
1000 INTEGER(8), INTENT(IN) :: NNZ
1001 INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ))
1002 INTEGER, INTENT(IN) :: ICNTL(60), COMM
1003 INTEGER, INTENT(IN) :: PROCNODE_STEPS(NSTEPS)
1004 INTEGER, INTENT(IN) :: STEP(NBLK)
1005 INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80)
1006 INTEGER, INTENT(OUT) :: MAPCOL(NSTEPS)
1007 TYPE(LMATRIX_T) :: LUMAT
1008 INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK
1009 TYPE(LMATRIX_T) :: LMAT
1010 INTEGER :: allocok, LP
1011 LOGICAL :: LPOK
1012 INTEGER :: IDOF, ISTEP
1013 LOGICAL :: MAPCOL_IN_NSTEPS, MAPCOLonLUMAT
1014 INTEGER OPTION
1015 parameter(option=2)
1016 INTEGER MUMPS_PROCNODE
1017 lp = icntl( 1 )
1018 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
1019 mapcolonlumat = .false.
1020 mapcol_in_nsteps = .true.
1021 IF (keep(14).EQ.1) THEN
1022 CALL mumps_abort()
1023 ENDIF
1024 allocate(dof2block(ndof), stat=allocok)
1025 IF (allocok.NE.0) THEN
1026 info( 1 ) = -7
1027 info( 2 ) = ndof
1028 IF ( lpok ) WRITE(lp, 150) ' DOF2BLOCK'
1029 ENDIF
1030 CALL mumps_propinfo( icntl(1), info(1),
1031 & comm, myid )
1032 IF ( info(1) .LT. 0 ) GOTO 500
1033 DO idof=1, ndof
1034 dof2block(idof) = idof
1035 ENDDO
1036 CALL mumps_ab_coord_to_lmat ( myid,
1037 & nblk, ndof, nnz, irn, jcn,
1038 & dof2block,
1039 & info(1), info(2), lp, lpok,
1040 & lmat)
1041 CALL mumps_propinfo( icntl(1), info(1),
1042 & comm, myid )
1043 IF ( info(1) .LT. 0 ) GOTO 500
1044 IF (allocated(dof2block)) DEALLOCATE(dof2block)
1045 IF (myid.EQ.master) THEN
1046 DO istep=1, nsteps
1047 mapcol(istep) =
1048 & mumps_procnode(procnode_steps(istep),keep(199))
1049 ENDDO
1050 ENDIF
1051 CALL mpi_bcast( mapcol(1), nsteps, mpi_integer,
1052 & master, comm, ierr )
1053 CALL mpi_bcast( step(1), nblk, mpi_integer,
1054 & master, comm, ierr )
1055 CALL mumps_ab_build_dclean_lumatrix(
1056 & mapcolonlumat, mapcol_in_nsteps,
1057 & info, icntl, keep, comm, myid, nblk, nprocs,
1058 & lmat, mapcol, nsteps,
1059 & step, nblk, lumat)
1060 CALL mumps_propinfo( icntl(1), info(1),
1061 & comm, myid )
1062 IF ( info(1) .LT. 0 ) GOTO 500
1063 GOTO 600
1064 500 CONTINUE
1065 IF (allocated(dof2block)) DEALLOCATE(dof2block)
1066 CALL mumps_ab_free_lmat(lmat)
1067 CALL mumps_ab_free_lmat(lumat)
1068 600 CONTINUE
1069 RETURN
1070 150 FORMAT(
1071 & /' ** FAILURE IN MUMPS_AB_DCOORD_TO_DTREE_LUMAT, ',
1072 & ' DYNAMIC ALLOCATION OF ',
1073 & a30)
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151

◆ mumps_ab_dist_lmat_to_lumat()

subroutine mumps_ab_dist_lmat_to_lumat ( logical, intent(in) unfold,
logical, intent(in) mapcol_in_nsteps,
integer, dimension(80) info,
integer, dimension(60), intent(in) icntl,
integer, intent(in) comm,
integer, intent(in) myid,
integer, intent(in) nblk,
integer, intent(in) slavef,
type(lmatrix_t), intent(in) lmat,
integer, dimension(sizemapcol), intent(in) mapcol,
integer, intent(in) sizemapcol,
integer, dimension(sizestep), intent(in) step,
integer, intent(in) sizestep,
type(lmatrix_t), intent(inout) lumat,
integer, intent(in) nbrecords,
integer(8), intent(out) nsend8,
integer(8), intent(out) nlocal8 )

Definition at line 1075 of file ana_blk.F.

1082 USE mumps_ana_blk_m, ONLY : lmatrix_t
1083 IMPLICIT NONE
1084 include 'mpif.h'
1085 include 'mumps_tags.h'
1086 INTEGER :: IERR, MASTER, MSGSOU
1087 parameter(master=0)
1088 INTEGER :: STATUS(MPI_STATUS_SIZE)
1089 LOGICAL, INTENT(IN) :: UNFOLD, MAPCOL_IN_NSTEPS
1090 INTEGER, INTENT(IN) :: MYID, SLAVEF, NBLK
1091 INTEGER, INTENT(IN) :: SIZEMAPCOL, SIZESTEP
1092 INTEGER, INTENT(IN) :: ICNTL(60), COMM, NBRECORDS
1093 INTEGER :: INFO(80)
1094 TYPE(LMATRIX_T), INTENT(IN) :: LMAT
1095 INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL)
1096 INTEGER, INTENT(IN) :: STEP(SIZESTEP)
1097 TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT
1098 INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8
1099 INTEGER :: LP, MP, allocok
1100 INTEGER :: IB, JB, I, II, ISEND, JSEND, ITOSEND
1101 LOGICAL :: LPOK
1102 INTEGER :: NBTOSEND
1103 INTEGER END_MSG_2_RECV
1104 INTEGER KPROBE, FREQPROBE
1105 INTEGER, ALLOCATABLE, DIMENSION(:) :: PTLOC
1106 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI
1107 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI
1108 INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI
1109 LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE
1110 INTEGER :: DEST
1111 LOGICAL :: FLAG
1112 lp = icntl( 1 )
1113 mp = icntl( 2 )
1114 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
1115 IF (unfold) THEN
1116 nbtosend = 2
1117 ELSE
1118 nbtosend = 1
1119 ENDIF
1120 nsend8 = 0_8
1121 nlocal8 = 0_8
1122 end_msg_2_recv = slavef-1
1123 ALLOCATE( iact(slavef), stat=allocok)
1124 IF ( allocok .GT. 0 ) THEN
1125 IF ( lp > 0 ) THEN
1126 WRITE(lp,*)
1127 & '** Error allocating IACT in matrix distribution'
1128 END IF
1129 info(1) = -7
1130 info(2) = slavef
1131 GOTO 20
1132 END IF
1133 ALLOCATE( ireqi(slavef), stat=allocok)
1134 IF ( allocok .GT. 0 ) THEN
1135 IF ( lp > 0 ) THEN
1136 WRITE(lp,*)
1137 & '** Error allocating IREQI in matrix distribution'
1138 END IF
1139 info(1) = -7
1140 info(2) = slavef
1141 GOTO 20
1142 END IF
1143 ALLOCATE( send_active(slavef), stat=allocok)
1144 IF ( allocok .GT. 0 ) THEN
1145 IF ( lp > 0 ) THEN
1146 WRITE(lp,*)
1147 & '** Error allocating SEND_ACTIVE in matrix distribution'
1148 END IF
1149 info(1) = -7
1150 info(2) = slavef
1151 GOTO 20
1152 END IF
1153 ALLOCATE( bufi( nbrecords * 2 + 1, 2, slavef ), stat=allocok)
1154 IF ( allocok .GT. 0 ) THEN
1155 IF ( lp > 0 ) THEN
1156 WRITE(lp,*)
1157 & '** Error allocating int buffer for matrix distribution'
1158 END IF
1159 info(1) = -7
1160 info(2) = ( nbrecords * 2 + 1 ) * slavef * 2
1161 GOTO 20
1162 END IF
1163 ALLOCATE( bufreci( nbrecords * 2 + 1 ), stat = allocok )
1164 IF ( allocok .GT. 0 ) THEN
1165 IF ( lp > 0 ) THEN
1166 WRITE(lp,*)
1167 & '** Error allocating int recv buffer for matrix distribution'
1168 END IF
1169 info(1) = -7
1170 info(2) = nbrecords * 2 + 1
1171 GOTO 20
1172 END IF
1173 ALLOCATE( ptloc( nblk ), stat = allocok )
1174 IF ( allocok .GT. 0 ) THEN
1175 IF ( lp > 0 ) THEN
1176 WRITE(lp,*)
1177 & '** Error allocating int recv buffer for matrix distribution'
1178 END IF
1179 info(1) = -7
1180 info(2) = nblk
1181 GOTO 20
1182 END IF
1183 20 CONTINUE
1184 CALL mumps_propinfo( icntl, info, comm, myid )
1185 IF ( info(1) .LT. 0 ) GOTO 100
1186 DO i = 1, slavef
1187 bufi( 1, 1, i ) = 0
1188 END DO
1189 DO i = 1, slavef
1190 bufi( 1, 2, i ) = 0
1191 END DO
1192 DO i = 1, slavef
1193 send_active( i ) = .false.
1194 iact( i ) = 1
1195 END DO
1196 DO i = 1, nblk
1197 ptloc(i) = 0
1198 END DO
1199 kprobe = 0
1200 freqprobe = max(1,nbrecords/10)
1201 IF (slavef .EQ. 1) freqprobe = huge(freqprobe)
1202 DO jb=1,nblk
1203 IF ( lmat%COL(jb)%NBINCOL.EQ.0) cycle
1204 DO ii=1, lmat%COL(jb)%NBINCOL
1205 kprobe = kprobe + 1
1206 IF ( kprobe .eq. freqprobe ) THEN
1207 kprobe = 0
1208 CALL mpi_iprobe( mpi_any_source, lmatdist, comm,
1209 & flag, status, ierr )
1210 IF ( flag ) THEN
1211 msgsou = status( mpi_source )
1212 CALL mpi_recv( bufreci(1), nbrecords * 2 + 1,
1213 & mpi_integer,
1214 & msgsou, lmatdist, comm, status, ierr )
1215 CALL mumps_ab_lmat_treat_recv_buf(
1216 & myid, bufreci(1), nbrecords, lumat,
1217 & nblk, ptloc(1), end_msg_2_recv
1218 & )
1219 END IF
1220 END IF
1221 ib = lmat%COL(jb)%IRN(ii)
1222 DO itosend=1,nbtosend
1223 IF (itosend.EQ.1) THEN
1224 IF (mapcol_in_nsteps) THEN
1225 dest = mapcol(abs(step(jb)))
1226 ELSE
1227 dest = mapcol(jb)
1228 ENDIF
1229 isend = ib
1230 jsend = jb
1231 ELSE
1232 IF (mapcol_in_nsteps) THEN
1233 dest = mapcol(abs(step(ib)))
1234 ELSE
1235 dest = mapcol(ib)
1236 ENDIF
1237 isend = jb
1238 jsend = ib
1239 ENDIF
1240 IF (dest.EQ.myid) THEN
1241 lumat%COL(jsend)%IRN(1+ptloc(jsend))= isend
1242 ptloc(jsend) = ptloc(jsend) + 1
1243 nlocal8 = nlocal8 + 1_8
1244 ELSE
1245 nsend8 = nsend8 + 1_8
1246 CALL mumps_ab_lmat_fill_buffer(
1247 & dest, isend, jsend, nblk,
1248 & bufi, bufreci, ptloc,
1249 & nbrecords, slavef, comm, myid, iact, ireqi,
1250 & send_active, lmat, lumat, end_msg_2_recv
1251 & )
1252 ENDIF
1253 ENDDO
1254 ENDDO
1255 ENDDO
1256 dest = -3
1257 CALL mumps_ab_lmat_fill_buffer(dest, isend, jsend,
1258 & nblk, bufi, bufreci, ptloc,
1259 & nbrecords, slavef, comm, myid, iact, ireqi,
1260 & send_active, lmat, lumat, end_msg_2_recv
1261 & )
1262 DO WHILE ( end_msg_2_recv .NE. 0 )
1263 CALL mpi_recv( bufreci(1), nbrecords * 2 + 1, mpi_integer,
1264 & mpi_any_source, lmatdist, comm, status, ierr )
1265 CALL mumps_ab_lmat_treat_recv_buf(
1266 & myid, bufreci(1), nbrecords, lumat,
1267 & nblk, ptloc(1), end_msg_2_recv
1268 & )
1269 END DO
1270 DO i = 1, slavef
1271 IF ( send_active( i ) ) THEN
1272 CALL mpi_wait( ireqi( i ), status, ierr )
1273 END IF
1274 END DO
1275 100 CONTINUE
1276 IF (ALLOCATED(ptloc)) DEALLOCATE( ptloc )
1277 IF (ALLOCATED(bufi)) DEALLOCATE( bufi )
1278 IF (ALLOCATED(bufreci)) DEALLOCATE( bufreci )
1279 IF (ALLOCATED(iact)) DEALLOCATE( iact )
1280 IF (ALLOCATED(ireqi)) DEALLOCATE( ireqi )
1281 IF (ALLOCATED(send_active)) DEALLOCATE( send_active )
1282 RETURN
mumps_ab_lmat_treat_recv_buf
subroutine mumps_ab_lmat_treat_recv_buf(myid, bufi, nbrecords, lumat, nblk, ptloc, end_msg_2_recv)
Definition ana_blk.F:1288
mumps_ab_lmat_fill_buffer
subroutine mumps_ab_lmat_fill_buffer(dest, isend, jsend, nblk, bufi, bufreci, ptloc, nbrecords, slavef, comm, myid, iact, ireqi, send_active, lmat, lumat, end_msg_2_recv)
Definition ana_blk.F:1317
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_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525

◆ mumps_ab_free_gcomp()

subroutine mumps_ab_free_gcomp ( type(compact_graph_t) gcomp)

Definition at line 31 of file ana_blk.F.

32 USE mumps_ana_blk_m, ONLY : compact_graph_t
33 IMPLICIT NONE
34 TYPE(COMPACT_GRAPH_T) :: GCOMP
35 IF (associated(gcomp%IPE)) THEN
36 DEALLOCATE(gcomp%IPE)
37 NULLIFY(gcomp%IPE)
38 ENDIF
39 IF (associated(gcomp%ADJ)) THEN
40 DEALLOCATE(gcomp%ADJ)
41 NULLIFY(gcomp%ADJ)
42 ENDIF
43 RETURN

◆ mumps_ab_free_lmat()

subroutine mumps_ab_free_lmat ( type(lmatrix_t) lmat)

Definition at line 14 of file ana_blk.F.

15 USE mumps_ana_blk_m, ONLY : lmatrix_t
16 IMPLICIT NONE
17 TYPE(LMATRIX_T) :: LMAT
18 INTEGER :: J
19 IF (associated(lmat%COL)) THEN
20 DO j = 1,lmat%NBCOL
21 IF (associated(lmat%COL(j)%IRN)) THEN
22 DEALLOCATE(lmat%COL(j)%IRN)
23 NULLIFY(lmat%COL(j)%IRN)
24 ENDIF
25 ENDDO
26 DEALLOCATE(lmat%COL)
27 NULLIFY(lmat%COL)
28 ENDIF
29 RETURN

◆ mumps_ab_gather_graph()

subroutine mumps_ab_gather_graph ( integer, dimension(60), intent(in) icntl,
integer, dimension(500), intent(in) keep,
integer, intent(in) comm,
integer, intent(in) myid,
integer, intent(in) nprocs,
integer, dimension(80), intent(inout) info,
type(compact_graph_t), intent(in) gcomp_dist,
type(compact_graph_t) gcomp )

Definition at line 1392 of file ana_blk.F.

1395 USE mumps_ana_blk_m, ONLY : compact_graph_t
1396 IMPLICIT NONE
1397 include 'mpif.h'
1398 include 'mumps_tags.h'
1399 INTEGER IERR, MASTER
1400 parameter( master = 0 )
1401 INTEGER :: STATUS(MPI_STATUS_SIZE)
1402 TYPE(COMPACT_GRAPH_T), INTENT(IN) :: GCOMP_DIST
1403 INTEGER, INTENT(IN) :: MYID, NPROCS, ICNTL(60), COMM,
1404 & KEEP(500)
1405 INTEGER, INTENT(INOUT) :: INFO(80)
1406 TYPE(COMPACT_GRAPH_T) :: GCOMP
1407 INTEGER :: NG, allocok, LP, MPG, I, J, K
1408 INTEGER :: INDX, NB_BLOCK_SENT, MAX_NBBLOCK_loc, NRECV,
1409 & BLOCKSIZE, SIZE_SENT, NB_BLOCKS, NBNONEMPTY,
1410 & FIRSTNONEMPTY, LASTNONEMPTY, NBBLOCK_loc
1411 INTEGER(4) :: IOVFLO
1412 INTEGER(8) :: NZG, NZG_CENT, I8, IBEG8, IEND8,
1413 & SIZEGCOMPALLOCATED
1414 LOGICAL :: LPOK, PROKG
1415 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ
1416 INTEGER, ALLOCATABLE :: REQPTR(:)
1417 INTEGER(8), ALLOCATABLE :: GPTR(:), GPTR_cp(:)
1418 lp = icntl( 1 )
1419 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
1420 mpg = icntl( 3 )
1421 prokg = ( mpg .GT. 0 .and. myid .eq. master )
1422 prokg = (prokg.AND.(icntl(4).GE.2))
1423 iovflo = huge(iovflo)
1424 blocksize = int(max(100000_8,int(iovflo,8)/200_8))
1425 nzg = gcomp_dist%NZG
1426 ng = gcomp_dist%NG
1427 CALL mpi_reduce( nzg, nzg_cent, 1, mpi_integer8,
1428 & mpi_sum, master, comm, ierr )
1429 IF (myid.EQ.master) THEN
1430 gcomp%NZG = nzg_cent
1431 gcomp%NG = ng
1432 sizegcompallocated = nzg_cent+int(ng,8)+1_8
1433 gcomp%SIZEADJALLOCATED = sizegcompallocated
1434 ALLOCATE( gcomp%ADJ(sizegcompallocated),
1435 & gcomp%IPE(ng+1),
1436 & gptr( nprocs ),
1437 & gptr_cp( nprocs ),
1438 & reqptr( nprocs-1 ),
1439 & iq(ng+1),stat=allocok)
1440 IF (allocok.NE.0) THEN
1441 info( 1 ) = -7
1442 CALL mumps_set_ierror(
1443 & nzg_cent + 3_8*int(ng,8)+3_8+3_8*int(nprocs,8)-1_8,
1444 & info(2))
1445 IF ( lpok )
1446 & WRITE(lp, *) " ERROR allocating graph in",
1447 & " MUMPS_AB_GATHER_GRAPH"
1448 ENDIF
1449 ELSE
1450 ALLOCATE( iq(ng+1), stat=allocok)
1451 IF (allocok.NE.0) THEN
1452 info( 1 ) = -7
1453 info( 2 ) = ng+1
1454 IF ( lpok )
1455 & WRITE(lp, *) " ERROR allocating pointers",
1456 & " MUMPS_AB_GATHER_GRAPH"
1457 END IF
1458 ENDIF
1459 CALL mumps_propinfo( icntl(1), info(1),
1460 & comm, myid )
1461 IF (info(1).LT.0) GOTO 500
1462 firstnonempty = 0
1463 lastnonempty = -1
1464 DO i=1,ng
1465 iq(i) = int(gcomp_dist%IPE(i+1)-gcomp_dist%IPE(i))
1466 IF (iq(i).NE.0) THEN
1467 IF (firstnonempty.EQ.0) firstnonempty=i
1468 lastnonempty = i
1469 ENDIF
1470 ENDDO
1471 nbnonempty = lastnonempty-firstnonempty+1
1472 IF (myid.EQ.master) THEN
1473 DO j=1, ng
1474 gcomp%IPE(j) = 0
1475 ENDDO
1476 j=firstnonempty
1477 IF (nbnonempty.GT.0) THEN
1478 DO i=firstnonempty, lastnonempty
1479 gcomp%IPE(j) = iq(i)
1480 j = j+1
1481 ENDDO
1482 ENDIF
1483 DO i = 1, nprocs - 1
1484 CALL mpi_recv( nbnonempty, 1,
1485 & mpi_integer, i,
1486 & gatherg_nb, comm, status, ierr )
1487 IF (nbnonempty.GT.0) THEN
1488 CALL mpi_recv( j, 1,
1489 & mpi_integer, i,
1490 & gatherg_first, comm, status, ierr )
1491 CALL mpi_recv( gcomp%IPE(j), nbnonempty,
1492 & mpi_integer8, i,
1493 & gatherg_ipe, comm, status, ierr )
1494 ENDIF
1495 ENDDO
1496 ELSE
1497 CALL mpi_send( nbnonempty, 1, mpi_integer, master,
1498 & gatherg_nb, comm, ierr )
1499 IF (nbnonempty.GT.0) THEN
1500 CALL mpi_send( firstnonempty, 1, mpi_integer, master,
1501 & gatherg_first, comm, ierr )
1502 CALL mpi_send( iq(firstnonempty), nbnonempty,
1503 & mpi_integer8, master,
1504 & gatherg_ipe, comm, ierr )
1505 ENDIF
1506 ENDIF
1507 IF (myid.EQ.master) THEN
1508 iq(1) = 1_8
1509 DO i=1,ng
1510 iq(i+1) = iq(i) + gcomp%IPE(i)
1511 gcomp%IPE(i) = iq(i)
1512 ENDDO
1513 gcomp%IPE(ng+1) = iq(ng+1)
1514 DEALLOCATE(iq)
1515 ELSE
1516 DEALLOCATE(iq)
1517 ENDIF
1518 IF (myid.EQ.master) THEN
1519 nb_block_sent = 0
1520 max_nbblock_loc = 0
1521 DO i = 1, nprocs - 1
1522 CALL mpi_recv( gptr( i+1 ), 1,
1523 & mpi_integer8, i,
1524 & gatherg_nzg, comm, status, ierr )
1525 nbblock_loc = ceiling(dble(gptr(i+1))/dble(blocksize))
1526 max_nbblock_loc = max(max_nbblock_loc, nbblock_loc)
1527 nb_block_sent = nb_block_sent + nbblock_loc
1528 ENDDO
1529 gptr( 1 ) = nzg + 1_8
1530 DO i = 2, nprocs
1531 gptr( i ) = gptr( i ) + gptr( i-1 )
1532 END DO
1533 ELSE
1534 CALL mpi_send( nzg, 1, mpi_integer8, master,
1535 & gatherg_nzg, comm, ierr )
1536 ENDIF
1537 IF (myid.EQ.master) THEN
1538 DO i=1, nprocs
1539 gptr_cp(i) = gptr(i)
1540 ENDDO
1541 IF (nzg.GT.0_8) THEN
1542 DO i8=1, nzg
1543 gcomp%ADJ(i8) = gcomp_dist%ADJ(i8)
1544 ENDDO
1545 ENDIF
1546 nb_blocks = 0
1547 DO k = 1, max_nbblock_loc
1548 nrecv = 0
1549 DO i = 1, nprocs - 1
1550 ibeg8 = gptr_cp( i )
1551 IF ( ibeg8 .LT. gptr(i+1)) THEN
1552 nrecv = nrecv + 1
1553 iend8 = min(ibeg8+int(blocksize,8)-1_8,
1554 & gptr(i+1)-1_8)
1555 gptr_cp( i ) = iend8 + 1_8
1556 size_sent = int(iend8 - ibeg8 + 1_8)
1557 nb_blocks = nb_blocks + 1
1558 CALL mpi_irecv( gcomp%ADJ(ibeg8), size_sent,
1559 & mpi_integer,
1560 & i, gatherg_adj, comm, reqptr(i), ierr )
1561 ELSE
1562 reqptr( i ) = mpi_request_null
1563 ENDIF
1564 END DO
1565 DO i = 1, nrecv
1566 CALL mpi_waitany
1567 & ( nprocs-1, reqptr, indx,
1568 & status, ierr )
1569 ENDDO
1570 END DO
1571 DEALLOCATE( reqptr )
1572 DEALLOCATE( gptr )
1573 DEALLOCATE( gptr_cp )
1574 ELSE
1575 IF (nzg.EQ.0) GOTO 600
1576 DO i8=1_8, nzg, int(blocksize,8)
1577 size_sent = blocksize
1578 IF (nzg-i8+1_8.LT.int(blocksize,8)) THEN
1579 size_sent = int(nzg-i8+1_8)
1580 ENDIF
1581 CALL mpi_send(
1582 & gcomp_dist%ADJ(i8), size_sent,
1583 & mpi_integer, master,
1584 & gatherg_adj, comm, ierr )
1585 ENDDO
1586 ENDIF
1587 GOTO 600
1588 500 CONTINUE
1589 IF (myid.EQ.master) THEN
1590 IF (associated(gcomp%ADJ)) THEN
1591 DEALLOCATE(gcomp%ADJ)
1592 nullify(gcomp%ADJ)
1593 ENDIF
1594 IF (associated(gcomp%IPE)) THEN
1595 DEALLOCATE(gcomp%IPE)
1596 nullify(gcomp%IPE)
1597 ENDIF
1598 ENDIF
1599 600 CONTINUE
1600 IF (allocated(iq)) DEALLOCATE(iq)
1601 RETURN
mpi_reduce
subroutine mpi_reduce(sendbuf, recvbuf, cnt, datatype, op, root, comm, ierr)
Definition mpi.f:120
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
mpi_waitany
subroutine mpi_waitany(cnt, array_of_requests, index, status, ierr)
Definition mpi.f:549
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865

◆ mumps_ab_lmat_fill_buffer()

subroutine mumps_ab_lmat_fill_buffer ( integer, intent(in) dest,
integer, intent(in) isend,
integer, intent(in) jsend,
integer, intent(in) nblk,
integer, dimension( nbrecords * 2 + 1, 2, slavef ), intent(inout) bufi,
integer, dimension( nbrecords * 2 + 1), intent(inout) bufreci,
integer, dimension(nblk), intent(inout) ptloc,
integer, intent(in) nbrecords,
integer, intent(in) slavef,
integer, intent(in) comm,
integer, intent(in) myid,
integer, dimension(slavef), intent(inout) iact,
integer, dimension(slavef), intent(inout) ireqi,
logical, dimension(slavef), intent(inout) send_active,
type(lmatrix_t), intent(in) lmat,
type(lmatrix_t), intent(inout) lumat,
integer, intent(inout) end_msg_2_recv )

Definition at line 1311 of file ana_blk.F.

1317 USE mumps_ana_blk_m, ONLY : lmatrix_t
1318 IMPLICIT NONE
1319 include 'mpif.h'
1320 include 'mumps_tags.h'
1321 INTEGER :: STATUS(MPI_STATUS_SIZE)
1322 INTEGER, INTENT(IN) :: DEST, ISEND, JSEND, SLAVEF, COMM, MYID,
1323 & NBRECORDS, NBLK
1324 INTEGER, INTENT(INOUT) :: END_MSG_2_RECV, PTLOC(NBLK)
1325 TYPE(LMATRIX_T), INTENT(IN) :: LMAT
1326 TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT
1327 LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(SLAVEF)
1328 INTEGER, INTENT(INOUT) :: IREQI(SLAVEF), IACT(SLAVEF)
1329 INTEGER, INTENT(INOUT) :: BUFI( NBRECORDS * 2 + 1, 2, SLAVEF )
1330 INTEGER, INTENT(INOUT) :: BUFRECI( NBRECORDS * 2 + 1)
1331 INTEGER :: IBEG, IEND, ISLAVE, TAILLE_SEND_I, IREQ, MSGSOU,
1332 & NBREC, IERR
1333 LOGICAL :: FLAG
1334 IF ( dest .eq. -3 ) THEN
1335 ibeg = 1
1336 iend = slavef
1337 ELSE
1338 ibeg = dest + 1
1339 iend = dest + 1
1340 END IF
1341 DO islave = ibeg, iend
1342 nbrec = bufi(1,iact(islave),islave)
1343 IF ( dest .eq. -3 ) THEN
1344 bufi(1,iact(islave),islave) = - nbrec
1345 END IF
1346 IF ( dest .eq. -3 .or. nbrec + 1 > nbrecords ) THEN
1347 DO WHILE ( send_active( islave ) )
1348 CALL mpi_test( ireqi( islave ), flag, status, ierr )
1349 IF ( .NOT. flag ) THEN
1350 CALL mpi_iprobe( mpi_any_source, lmatdist, comm,
1351 & flag, status, ierr )
1352 IF ( flag ) THEN
1353 msgsou = status(mpi_source)
1354 CALL mpi_recv( bufreci(1), 2*nbrecords+1,
1355 & mpi_integer, msgsou, lmatdist, comm,
1356 & status, ierr )
1357 CALL mumps_ab_lmat_treat_recv_buf(
1358 & myid, bufreci, nbrecords, lumat,
1359 & nblk, ptloc(1), end_msg_2_recv
1360 & )
1361 END IF
1362 ELSE
1363 send_active( islave ) = .false.
1364 END IF
1365 END DO
1366 IF ( islave - 1 .ne. myid ) THEN
1367 taille_send_i = nbrec * 2 + 1
1368 CALL mpi_isend( bufi(1, iact(islave), islave ),
1369 & taille_send_i,
1370 & mpi_integer, islave - 1, lmatdist, comm,
1371 & ireqi( islave ), ierr )
1372 send_active( islave ) = .true.
1373 ELSE
1374 IF (nbrec.NE.0) THEN
1375 write(*,*) " Internal error in ",
1376 & " MUMPS_AB_LMAT_FILL_BUFFER "
1377 CALL mumps_abort()
1378 ENDIF
1379 END IF
1380 iact( islave ) = 3 - iact( islave )
1381 bufi( 1, iact( islave ), islave ) = 0
1382 END IF
1383 IF ( dest .ne. -3 ) THEN
1384 ireq = bufi(1,iact(islave),islave) + 1
1385 bufi(1,iact(islave),islave) = ireq
1386 bufi(ireq*2,iact(islave),islave) = isend
1387 bufi(ireq*2+1,iact(islave),islave) = jsend
1388 END IF
1389 ENDDO
1390 RETURN
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_test
subroutine mpi_test(ireq, flag, status, ierr)
Definition mpi.f:502

◆ mumps_ab_lmat_to_clean_g()

subroutine mumps_ab_lmat_to_clean_g ( integer, intent(in) myid,
logical, intent(in) unfold,
logical, intent(in) ready_for_ana_f,
type(lmatrix_t) lmat,
type(compact_graph_t) gcomp,
integer, dimension(80), intent(inout) info,
integer, dimension(60), intent(in) icntl )

Definition at line 288 of file ana_blk.F.

291 USE mumps_ana_blk_m, ONLY : lmatrix_t, compact_graph_t
292 IMPLICIT NONE
293 INTEGER, INTENT(IN) :: MYID
294 LOGICAL, INTENT(IN) :: UNFOLD, READY_FOR_ANA_F
295 TYPE(LMATRIX_T) :: LMAT
296 TYPE(COMPACT_GRAPH_T) :: GCOMP
297 INTEGER, INTENT(IN) :: ICNTL(60)
298 INTEGER, INTENT(INOUT) :: INFO(80)
299 INTEGER :: IB, IIB, JJB, allocok, LP, MPG
300 INTEGER(8) :: JPOS, SIZEGCOMPALLOCATED
301 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ
302#if defined(DETERMINISTIC_PARALLEL_GRAPH)
303 INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK
304 INTEGER(8) :: IFIRST, ILAST
305 INTEGER :: L
306#endif
307 LOGICAL LPOK, PROKG
308 lp = icntl( 1 )
309 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
310 mpg = icntl( 3 )
311 prokg = ( mpg .GT. 0 .and. (icntl(4).GE.2) )
312 gcomp%NG = lmat%NBCOL
313 IF (unfold) THEN
314 gcomp%NZG = 2_8*lmat%NZL
315 sizegcompallocated = gcomp%NZG + int(gcomp%NG,8)+1_8
316 ELSE IF (ready_for_ana_f) THEN
317 gcomp%NZG = lmat%NZL
318 sizegcompallocated = gcomp%NZG + int(gcomp%NG,8)+1_8
319 ELSE
320 gcomp%NZG = lmat%NZL
321 sizegcompallocated = gcomp%NZG
322 ENDIF
323 gcomp%SIZEADJALLOCATED= sizegcompallocated
324 ALLOCATE( gcomp%ADJ(sizegcompallocated),
325 & gcomp%IPE(gcomp%NG+1),
326 & iq(gcomp%NG),stat=allocok)
327 IF (allocok.NE.0) THEN
328 info( 1 ) = -7
329 CALL mumps_set_ierror(
330 & gcomp%NZG + 3_8*int(gcomp%NG,8)+1_8, info(2))
331 IF ( lpok ) THEN
332 WRITE(lp, *) " ERROR allocating graph in",
333 & " MUMPS_AB_LMAT_TO_CLEAN_G"
334 END IF
335 RETURN
336 ENDIF
337 DO jjb=1, gcomp%NG
338 iq(jjb)=0_8
339 ENDDO
340 IF (unfold) THEN
341 DO jjb=1, gcomp%NG
342 DO ib=1, lmat%COL(jjb)%NBINCOL
343 iib=lmat%COL(jjb)%IRN(ib)
344 iq(jjb)=iq(jjb)+1
345 iq(iib)=iq(iib)+1
346 ENDDO
347 ENDDO
348 ELSE
349 DO jjb=1, gcomp%NG
350 iq(jjb) = lmat%COL(jjb)%NBINCOL
351 ENDDO
352 ENDIF
353 gcomp%IPE(1) = 1_8
354 DO jjb=1, gcomp%NG
355 gcomp%IPE(jjb+1) = gcomp%IPE(jjb)+iq(jjb)
356 ENDDO
357 IF (unfold) THEN
358 DO jjb=1, gcomp%NG
359 iq(jjb)= gcomp%IPE(jjb)
360 ENDDO
361 DO jjb=1, gcomp%NG
362 DO ib=1, lmat%COL(jjb)%NBINCOL
363 iib=lmat%COL(jjb)%IRN(ib)
364 gcomp%ADJ(iq(iib))= jjb
365 iq(iib) = iq(iib)+1_8
366 gcomp%ADJ(iq(jjb))= iib
367 iq(jjb) = iq(jjb)+1_8
368 ENDDO
369 ENDDO
370 ELSE
371 DO jjb=1, gcomp%NG
372 jpos = gcomp%IPE(jjb)
373 DO ib=1, lmat%COL(jjb)%NBINCOL
374 iib=lmat%COL(jjb)%IRN(ib)
375 gcomp%ADJ(jpos)= iib
376 jpos = jpos+1_8
377 ENDDO
378 ENDDO
379 ENDIF
380 DEALLOCATE(iq)
381#if defined(DETERMINISTIC_PARALLEL_GRAPH)
382 IF (.NOT.ready_for_ana_f) THEN
383 ALLOCATE(work(0:gcomp%NG),stat=allocok)
384 IF (allocok.NE.0) THEN
385 info( 1 ) = -7
386 info( 2 ) = gcomp%NG
387 IF ( lpok ) THEN
388 WRITE(lp, *) " ERROR allocating WORK in",
389 & " MUMPS_AB_LMAT_TO_CLEAN_G"
390 END IF
391 RETURN
392 ENDIF
393 DO jjb=1, gcomp%NG
394 ifirst = gcomp%IPE(jjb)
395 ilast= gcomp%IPE(jjb+1)-1
396 l = int(ilast-ifirst+1)
397 IF ( l .GE. 2 ) THEN
398 IF (l .GE. gcomp%NG ) THEN
399 WRITE(*,*) " Internal error in MUMPS_AB_LMAT_TO_CLEAN_G",
400 & l, gcomp%NG
401 CALL mumps_abort()
402 ENDIF
403 CALL mumps_mergesort( l,
404 & gcomp%ADJ(ifirst:ilast), work(0:l+1) )
405 CALL mumps_mergeswap1( l,
406 & work(0:l+1), gcomp%ADJ(ifirst:ilast) )
407 ENDIF
408 ENDDO
409 DEALLOCATE(work)
410 ENDIF
411#endif
412 RETURN
413#if defined(DETERMINISTIC_PARALLEL_GRAPH)
414 CONTAINS
415 SUBROUTINE mumps_mergesort(N, K, L)
416 INTEGER :: N
417 INTEGER :: K(:), L(0:)
418 INTEGER :: P, Q, S, T
419 CONTINUE
420 l(0) = 1
421 t = n + 1
422 DO p = 1,n - 1
423 IF (k(p) <= k(p+1)) THEN
424 l(p) = p + 1
425 ELSE
426 l(t) = - (p+1)
427 t = p
428 END IF
429 END DO
430 l(t) = 0
431 l(n) = 0
432 IF (l(n+1) == 0) THEN
433 RETURN
434 ELSE
435 l(n+1) = iabs(l(n+1))
436 END IF
437 200 CONTINUE
438 s = 0
439 t = n+1
440 p = l(s)
441 q = l(t)
442 IF(q .EQ. 0) RETURN
443 300 CONTINUE
444 IF(k(p) .GT. k(q)) GOTO 600
445 CONTINUE
446 l(s) = sign(p,l(s))
447 s = p
448 p = l(p)
449 IF (p .GT. 0) GOTO 300
450 CONTINUE
451 l(s) = q
452 s = t
453 DO
454 t = q
455 q = l(q)
456 IF (q .LE. 0) EXIT
457 END DO
458 GOTO 800
459 600 CONTINUE
460 l(s) = sign(q, l(s))
461 s = q
462 q = l(q)
463 IF (q .GT. 0) GOTO 300
464 CONTINUE
465 l(s) = p
466 s = t
467 DO
468 t = p
469 p = l(p)
470 IF (p .LE. 0) EXIT
471 END DO
472 800 CONTINUE
473 p = -p
474 q = -q
475 IF(q.EQ.0) THEN
476 l(s) = sign(p, l(s))
477 l(t) = 0
478 GOTO 200
479 END IF
480 GOTO 300
481 END SUBROUTINE mumps_mergesort
482 SUBROUTINE mumps_mergeswap1(N, L, A)
483 INTEGER :: I, LP, ISWAP, N
484 INTEGER :: L(0:), A(:)
485 lp = l(0)
486 i = 1
487 DO
488 IF ((lp==0).OR.(i>n)) EXIT
489 DO
490 IF (lp >= i) EXIT
491 lp = l(lp)
492 END DO
493 iswap = a(lp)
494 a(lp) = a(i)
495 a(i) = iswap
496 iswap = l(lp)
497 l(lp) = l(i)
498 l(i) = lp
499 lp = iswap
500 i = i + 1
501 ENDDO
502 END SUBROUTINE mumps_mergeswap1
503#endif

◆ mumps_ab_lmat_to_lumat()

subroutine mumps_ab_lmat_to_lumat ( type(lmatrix_t) lmat,
type(lmatrix_t) lumat,
integer, dimension(80), intent(inout) info,
integer, dimension(60), intent(in) icntl )

Definition at line 208 of file ana_blk.F.

210 USE mumps_ana_blk_m, ONLY : lmatrix_t
211 IMPLICIT NONE
212 TYPE(LMATRIX_T) :: LMAT, LUMAT
213 INTEGER, INTENT(IN) :: ICNTL(60)
214 INTEGER, INTENT(INOUT) :: INFO(80)
215 INTEGER :: IB, IIB, JB, allocok, LP, MPG, NB, IERR
216 LOGICAL LPOK, PROKG
217 lp = icntl( 1 )
218 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
219 mpg = icntl( 3 )
220 prokg = ( mpg .GT. 0 .and. (icntl(4).GE.2) )
221 lumat%NBCOL = lmat%NBCOL
222 lumat%NZL = 2_8*lmat%NZL
223 ALLOCATE( lumat%COL(lmat%NBCOL),stat=allocok)
224 IF (allocok.NE.0) THEN
225 info( 1 ) = -7
226 info( 2 ) = lmat%NBCOL
227 IF ( lpok ) THEN
228 WRITE(lp, *) " ERROR allocating LUMAT%COL "
229 END IF
230 RETURN
231 ENDIF
232 DO jb=1, lmat%NBCOL
233 lumat%COL(jb)%NBINCOL = lmat%COL(jb)%NBINCOL
234 ENDDO
235 DO jb=1, lmat%NBCOL
236 DO ib=1, lmat%COL(jb)%NBINCOL
237 iib=lmat%COL(jb)%IRN(ib)
238 lumat%COL(iib)%NBINCOL = lumat%COL(iib)%NBINCOL + 1
239 ENDDO
240 ENDDO
241 DO jb=1, lmat%NBCOL
242 nb = lumat%COL(jb)%NBINCOL
243 ALLOCATE(lumat%COL(jb)%IRN(nb), stat=ierr)
244 IF (ierr.NE.0) THEN
245 info(1) = -7
246 info(2) = nb
247 IF ( lpok ) THEN
248 WRITE(lp, *) " ERROR allocating columns of LUMAT"
249 END IF
250 RETURN
251 ENDIF
252 ENDDO
253 DO jb=1, lmat%NBCOL
254 lumat%COL(jb)%NBINCOL = 0
255 ENDDO
256 DO jb=1, lmat%NBCOL
257 DO ib=1, lmat%COL(jb)%NBINCOL
258 iib=lmat%COL(jb)%IRN(ib)
259 nb = lumat%COL(jb)%NBINCOL+1
260 lumat%COL(jb)%NBINCOL = nb
261 lumat%COL(jb)%IRN(nb)= iib
262 nb = lumat%COL(iib)%NBINCOL+1
263 lumat%COL(iib)%NBINCOL = nb
264 lumat%COL(iib)%IRN(nb)= jb
265 ENDDO
266 ENDDO
267 RETURN

◆ mumps_ab_lmat_treat_recv_buf()

subroutine mumps_ab_lmat_treat_recv_buf ( integer, intent(in) myid,
integer, dimension( nbrecords * 2 + 1 ), intent(in) bufi,
integer, intent(in) nbrecords,
type(lmatrix_t), intent(inout) lumat,
integer, intent(in) nblk,
integer, dimension(nblk), intent(inout) ptloc,
integer, intent(inout) end_msg_2_recv )

Definition at line 1284 of file ana_blk.F.

1288 USE mumps_ana_blk_m, ONLY : lmatrix_t
1289 IMPLICIT NONE
1290 include 'mpif.h'
1291 include 'mumps_tags.h'
1292 INTEGER, INTENT(IN) :: NBLK, MYID, NBRECORDS
1293 INTEGER, INTENT(IN) :: BUFI( NBRECORDS * 2 + 1 )
1294 INTEGER, INTENT(INOUT):: END_MSG_2_RECV, PTLOC(NBLK)
1295 TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT
1296 INTEGER :: IREC, NB_REC, IB, JB
1297 nb_rec = bufi( 1 )
1298 IF ( nb_rec .LE. 0 ) THEN
1299 end_msg_2_recv = end_msg_2_recv - 1
1300 nb_rec = - nb_rec
1301 END IF
1302 IF ( nb_rec .eq. 0 ) RETURN
1303 DO irec = 1, nb_rec
1304 ib = bufi( irec * 2 )
1305 jb = bufi( irec * 2 + 1 )
1306 lumat%COL(jb)%IRN(1+ptloc(jb))= ib
1307 ptloc(jb) = ptloc(jb) + 1
1308 ENDDO
1309 RETURN

◆ mumps_ab_localclean_lmat()

subroutine mumps_ab_localclean_lmat ( integer, intent(in) myid,
integer, intent(in) nblk,
type(lmatrix_t), intent(inout) lmat,
integer, dimension(nblk), intent(out) flag,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) lp,
logical, intent(in) lpok )

Definition at line 151 of file ana_blk.F.

154 USE mumps_ana_blk_m, ONLY : lmatrix_t
155 IMPLICIT NONE
156 INTEGER, INTENT(IN) :: MYID, NBLK, LP
157 LOGICAL, INTENT(IN) :: LPOK
158 INTEGER, INTENT(OUT) :: FLAG(NBLK)
159 INTEGER, INTENT(INOUT) :: IFLAG, IERROR
160 TYPE(LMATRIX_T), INTENT(INOUT) :: LMAT
161 INTEGER, POINTER, DIMENSION(:) :: PTCLEAN
162 INTEGER :: allocok, IB, JB, NB
163 DO jb=1, nblk
164 flag(jb) = 0
165 ENDDO
166 lmat%NZL = 0_8
167 DO jb=1, nblk
168 IF ( lmat%COL(jb)%NBINCOL.EQ.0) cycle
169 nb = 0
170 DO ib=1, lmat%COL(jb)%NBINCOL
171 IF (flag(lmat%COL(jb)%IRN(ib)).EQ.jb) THEN
172 lmat%COL(jb)%IRN(ib)=0
173 ELSE
174 nb = nb+1
175 lmat%NZL = lmat%NZL+1_8
176 flag(lmat%COL(jb)%IRN(ib)) = jb
177 ENDIF
178 ENDDO
179 IF (nb.GT.0) THEN
180 ALLOCATE(ptclean(nb), stat=allocok)
181 IF (allocok.NE.0) THEN
182 iflag = -7
183 ierror = nb
184 IF ( lpok ) THEN
185 WRITE(lp, *) " ERROR allocate PTCLEAN of size",
186 & ierror
187 END IF
188 RETURN
189 ENDIF
190 nb=0
191 DO ib=1, lmat%COL(jb)%NBINCOL
192 IF (lmat%COL(jb)%IRN(ib).NE.0) THEN
193 nb = nb+1
194 ptclean(nb)=lmat%COL(jb)%IRN(ib)
195 ENDIF
196 ENDDO
197 lmat%COL(jb)%NBINCOL = nb
198 deallocate(lmat%COL(jb)%IRN)
199 lmat%COL(jb)%IRN => ptclean
200 NULLIFY(ptclean)
201 ELSE
202 deallocate(lmat%COL(jb)%IRN)
203 NULLIFY(lmat%COL(jb)%IRN)
204 ENDIF
205 ENDDO
206 RETURN

◆ mumps_ab_print_lmatrix()

subroutine mumps_ab_print_lmatrix ( type(lmatrix_t), intent(in) lmat,
integer, intent(in) myid,
integer, intent(in) lp )

Definition at line 269 of file ana_blk.F.

270 USE mumps_ana_blk_m, ONLY : lmatrix_t
271 IMPLICIT NONE
272 TYPE(LMATRIX_T), INTENT(IN) :: LMAT
273 INTEGER, INTENT(IN) :: MYID, LP
274 INTEGER :: JB
275 write(lp,*) myid, " ... LMATRIX %NBCOL, %NZL= ",
276 & lmat%NBCOL, lmat%NZL
277 IF (lmat%NBCOL.GE.0.AND.associated(lmat%COL)) THEN
278 DO jb=1, lmat%NBCOL
279 IF (lmat%COL(jb)%NBINCOL.GT.0) THEN
280 WRITE(lp,*) myid, " ... Column=", jb , " nb entries =",
281 & lmat%COL(jb)%NBINCOL, " List of entries:",
282 & lmat%COL(jb)%IRN(1:lmat%COL(jb)%NBINCOL)
283 ENDIF
284 ENDDO
285 ENDIF
286 RETURN

◆ mumps_inialize_redist_lumat()

subroutine mumps_inialize_redist_lumat ( integer, dimension(80) info,
integer, dimension(60), intent(in) icntl,
integer, dimension(500), intent(in) keep,
integer, intent(in) comm,
integer, intent(in) myid,
integer, intent(in) nblk,
type(lmatrix_t), intent(in) lumat,
integer, dimension(nsteps), intent(in) procnode_steps,
integer, intent(in) nsteps,
integer, dimension(nsteps), intent(out) mapcol,
type(lmatrix_t), intent(inout) lumat_remap,
integer, intent(out) nbrecords,
integer, dimension(nblk), intent(in) step )

Definition at line 784 of file ana_blk.F.

789 USE mumps_ana_blk_m, ONLY : lmatrix_t
790 IMPLICIT NONE
791 include 'mpif.h'
792 include 'mumps_tags.h'
793 INTEGER :: IERR, MASTER
794 parameter(master=0)
795 INTEGER, INTENT(IN) :: MYID, NBLK, NSTEPS, KEEP(500)
796 INTEGER, INTENT(IN) :: ICNTL(60), COMM
797 INTEGER :: INFO(80)
798 INTEGER, INTENT(IN) :: PROCNODE_STEPS(NSTEPS)
799 TYPE(LMATRIX_T), INTENT(IN) :: LUMAT
800 INTEGER, INTENT(IN) :: STEP(NBLK)
801 TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT_REMAP
802 INTEGER, INTENT(OUT) :: NBRECORDS
803 INTEGER, INTENT(OUT) :: MAPCOL(NSTEPS)
804 INTEGER :: LP, MP, ISTEP, JB, NB
805 LOGICAL :: LPOK
806 INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL
807 INTEGER MUMPS_PROCNODE
808 INTEGER(8) :: NZ_locMAX8
809 lp = icntl( 1 )
810 mp = icntl( 2 )
811 lpok = ((lp.GT.0).AND.(icntl(4).GE.1))
812 ALLOCATE(wt(nblk), wnbincol(nblk), stat=ierr)
813 IF (ierr.NE.0) THEN
814 info(1) = -7
815 info(2) = 2*nblk
816 IF ( lpok ) THEN
817 WRITE(lp, *) " ERROR allocate WT"
818 END IF
819 ENDIF
820 CALL mumps_propinfo( icntl(1), info(1),
821 & comm, myid )
822 IF ( info(1) .LT. 0 ) GOTO 500
823 DO jb=1, nblk
824 wt(jb) = lumat%COL(jb)%NBINCOL
825 ENDDO
826 CALL mpi_allreduce(wt(1), wnbincol(1), nblk,
827 & mpi_integer, mpi_sum, comm, ierr)
828 IF (allocated(wt)) DEALLOCATE(wt)
829 IF (myid.EQ.master) THEN
830 DO istep=1, nsteps
831 mapcol(istep) =
832 & mumps_procnode(procnode_steps(istep),keep(199))
833 ENDDO
834 ENDIF
835 CALL mpi_bcast( mapcol(1), nsteps, mpi_integer,
836 & master, comm, ierr )
837 CALL mpi_bcast( step(1), nblk, mpi_integer,
838 & master, comm, ierr )
839 lumat_remap%NBCOL = nblk
840 ALLOCATE(lumat_remap%COL(nblk), stat=ierr)
841 IF (ierr.NE.0) THEN
842 info(1) = -7
843 info(2) = nblk
844 IF ( lpok ) THEN
845 WRITE(lp, *) " ERROR allocate of LUMAT_REMAP%COL"
846 END IF
847 ENDIF
848 IF ( info(1) .GE. 0 ) THEN
849 lumat_remap%NZL = 0_8
850 DO jb=1,nblk
851 nb = wnbincol(jb)
852 IF (mapcol(abs(step(jb))).EQ.myid) THEN
853 lumat_remap%NZL = lumat_remap%NZL + int(nb,8)
854 ELSE
855 nb = 0
856 ENDIF
857 lumat_remap%COL(jb)%NBINCOL = nb
858 IF (nb.GT.0) THEN
859 ALLOCATE(lumat_remap%COL(jb)%IRN(nb), stat=ierr)
860 IF (ierr.NE.0) THEN
861 info(1) = -7
862 info(2) = nb
863 IF ( lpok ) THEN
864 WRITE(lp, *) " ERROR allocate of LUMAT_REMAP%COL"
865 END IF
866 EXIT
867 ENDIF
868 ENDIF
869 ENDDO
870 ENDIF
871 CALL mumps_propinfo( icntl(1), info(1),
872 & comm, myid )
873 IF ( info(1) .LT. 0 ) GOTO 500
874 IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
875 CALL mpi_allreduce(lumat_remap%NZL, nz_locmax8, 1, mpi_integer8,
876 & mpi_max, comm, ierr)
877 nbrecords = keep(39)
878 IF (nz_locmax8 .LT. int(nbrecords,8)) THEN
879 nbrecords = int(nz_locmax8)
880 ENDIF
881 GOTO 600
882 500 CONTINUE
883 IF (allocated(wt)) DEALLOCATE(wt)
884 IF (allocated(wnbincol)) DEALLOCATE(wnbincol)
885 600 CONTINUE
886 RETURN