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

Go to the source code of this file.

Functions/Subroutines

subroutine smumps_build_mapping (n, mapping, nnz, irn, jcn, procnode, step, slavef, perm, fils, rg2l, keep, keep8, mblock, nblock, nprow, npcol)
subroutine smumps_redistribution (n, nz_loc8, id, dblarr, ldblarr, intarr, lintarr, ptraiw, ptrarw, keep, keep8, myid, comm, nbrecords a, la, root, procnode_steps, slavef, perm, step, icntl, info, nsend8, nlocal8, istep_to_iniv2, candidates)
subroutine smumps_dist_fill_buffer ()
subroutine smumps_dist_treat_recv_buf (bufi, bufr, nbrecords, n, iw4, keep, keep8, local_m, local_n, root, ptr_root, a, la, end_msg_2_recv, myid, procnode_steps, slavef, ptraiw, ptrarw, perm, step, intarr, lintarr, dblarr, ldblarr)

Function/Subroutine Documentation

◆ smumps_build_mapping()

subroutine smumps_build_mapping ( integer n,
integer, dimension( nnz ) mapping,
integer(8) nnz,
integer, dimension( nnz ) irn,
integer, dimension( nnz ) jcn,
integer, dimension( keep(28) ) procnode,
integer, dimension( n ) step,
integer slavef,
integer, dimension( n ) perm,
integer, dimension( n ) fils,
integer, dimension( n ) rg2l,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer mblock,
integer nblock,
integer nprow,
integer npcol )

Definition at line 14 of file sfac_distrib_distentry.F.

18 USE smumps_struc_def
19 IMPLICIT NONE
20 INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL
21 iNTEGER(8) :: NNZ
22 INTEGER KEEP(500)
23 INTEGER(8) KEEP8(150)
24 INTEGER IRN( NNZ ), JCN( NNZ )
25 INTEGER MAPPING( NNZ ), STEP( N )
26 INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N )
27 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE
28 EXTERNAL mumps_procnode, mumps_typenode
29 INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE
30 INTEGER(8) :: K8
31 INTEGER TYPE_NODE, DEST
32 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID
33 inode = keep(38)
34 k4 = 1
35 DO WHILE ( inode .GT. 0 )
36 rg2l( inode ) = k4
37 inode = fils( inode )
38 k4 = k4 + 1
39 END DO
40 DO k8 = 1_8, nnz
41 iold = irn( k8 )
42 jold = jcn( k8 )
43 IF ( iold .GT. n .OR. iold .LT. 1 .OR.
44 & jold .GT. n .OR. jold .LT. 1 ) THEN
45 mapping( k8 ) = -1
46 cycle
47 END IF
48 IF ( iold .eq. jold ) THEN
49 isend = iold
50 jsend = jold
51 ELSE
52 inew = perm( iold )
53 jnew = perm( jold )
54 IF ( inew .LT. jnew ) THEN
55 isend = iold
56 IF ( keep(50) .ne. 0 ) isend = -iold
57 jsend = jold
58 ELSE
59 isend = -jold
60 jsend = iold
61 END IF
62 END IF
63 iarr = abs( isend )
64 type_node = mumps_typenode( procnode(abs(step(iarr))),
65 & keep(199) )
66 IF ( type_node .eq. 1 .or. type_node .eq. 2 ) THEN
67 IF ( keep(46) .eq. 0 ) THEN
68 dest = mumps_procnode( procnode(abs(step(iarr))),
69 & keep(199) ) + 1
70 ELSE
71 dest = mumps_procnode( procnode(abs(step(iarr))),
72 & keep(199) )
73 END IF
74 ELSE
75 IF ( isend .LT. 0 ) THEN
76 iposroot = rg2l( jsend )
77 jposroot = rg2l( iarr )
78 ELSE
79 iposroot = rg2l( iarr )
80 jposroot = rg2l( jsend )
81 END IF
82 irow_grid = mod( ( iposroot - 1 )/mblock, nprow )
83 jcol_grid = mod( ( jposroot - 1 )/nblock, npcol )
84 IF ( keep( 46 ) .eq. 0 ) THEN
85 dest = irow_grid * npcol + jcol_grid + 1
86 ELSE
87 dest = irow_grid * npcol + jcol_grid
88 END IF
89 END IF
90 mapping( k8 ) = dest
91 END DO
92 RETURN
smumps_struc_def
Definition smumps_struc_def.F:14
mumps_typenode
integer function mumps_typenode(procinfo_inode, k199)
Definition tools_common.F:90
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151

◆ smumps_dist_fill_buffer()

subroutine smumps_redistribution::smumps_dist_fill_buffer

Definition at line 616 of file sfac_distrib_distentry.F.

617 IMPLICIT NONE
618 INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ
619 INTEGER TAILLE_SEND_I, TAILLE_SEND_R
620 LOGICAL SEND_LOCAL
621 IF ( dest_shr .eq. -3 ) THEN
622 ibeg = 1
623 iend = slavef
624 ELSE
625 ibeg = dest_shr + 1
626 iend = dest_shr + 1
627 END IF
628 send_local = .false.
629 DO islave = ibeg, iend
630 nbrec = bufi(1,iact(islave),islave)
631 IF ( dest_shr .eq. -3 ) THEN
632 bufi(1,iact(islave),islave) = - nbrec
633 END IF
634 IF ( dest_shr .eq. -3 .or. nbrec + 1 > nbrecords ) THEN
635 DO WHILE ( send_active( islave ) )
636 CALL mpi_test( ireqr( islave ), flag, status, ierr )
637 IF ( .NOT. flag ) THEN
638 CALL mpi_iprobe( mpi_any_source, arr_int, comm,
639 & flag, status, ierr )
640 IF ( flag ) THEN
641 msgsou = status(mpi_source)
642 CALL mpi_recv( bufreci(1), 2*nbrecords+1,
643 & mpi_integer, msgsou, arr_int, comm,
644 & status, ierr )
645 CALL mpi_recv( bufrecr(1), nbrecords,
646 & mpi_real, msgsou,
647 & arr_real, comm, status, ierr )
648 CALL smumps_dist_treat_recv_buf(
649 & bufreci, bufrecr, nbrecords, n, iw4(1,1),
650 & keep,keep8, local_m, local_n, root, ptr_root,
651 & a, la,
652 & end_msg_2_recv, myid, procnode_steps, slavef,
653 & ptraiw, ptrarw, perm, step,
654 & intarr, lintarr, dblarr, ldblarr
655 & )
656 END IF
657 ELSE
658 CALL mpi_wait( ireqi( islave ), status, ierr )
659 send_active( islave ) = .false.
660 END IF
661 END DO
662 IF ( islave - 1 .ne. myid ) THEN
663 taille_send_i = nbrec * 2 + 1
664 taille_send_r = nbrec
665 CALL mpi_isend( bufi(1, iact(islave), islave ),
666 & taille_send_i,
667 & mpi_integer, islave - 1, arr_int, comm,
668 & ireqi( islave ), ierr )
669 CALL mpi_isend( bufr(1, iact(islave), islave ),
670 & taille_send_r,
671 & mpi_real, islave - 1, arr_real, comm,
672 & ireqr( islave ), ierr )
673 send_active( islave ) = .true.
674 ELSE
675 send_local = .true.
676 END IF
677 iact( islave ) = 3 - iact( islave )
678 bufi( 1, iact( islave ), islave ) = 0
679 END IF
680 IF ( dest_shr .ne. -3 ) THEN
681 ireq = bufi(1,iact(islave),islave) + 1
682 bufi(1,iact(islave),islave) = ireq
683 bufi(ireq*2,iact(islave),islave) = isend_shr
684 bufi(ireq*2+1,iact(islave),islave) = jsend_shr
685 bufr(ireq,iact(islave),islave ) = val_shr
686 END IF
687 END DO
688 IF ( send_local ) THEN
689 islave = myid + 1
690 CALL smumps_dist_treat_recv_buf(
691 & bufi(1,3-iact(islave),islave),
692 & bufr(1,3-iact(islave),islave),
693 & nbrecords, n, iw4(1,1),
694 & keep,keep8, local_m, local_n, root, ptr_root,
695 & a, la,
696 & end_msg_2_recv, myid, procnode_steps, slavef,
697 & ptraiw, ptrarw, perm, step,
698 & intarr, lintarr, dblarr, ldblarr
699 & )
700 END IF
701 RETURN
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
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
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
smumps_dist_treat_recv_buf
subroutine smumps_dist_treat_recv_buf(bufi, bufr, nbrecords, n, iw4, keep, keep8, local_m, local_n, root, ptr_root, a, la, end_msg_2_recv, myid, procnode_steps, slavef, ptraiw, ptrarw, perm, step, intarr, lintarr, dblarr, ldblarr)
Definition sfac_distrib_distentry.F:711

◆ smumps_dist_treat_recv_buf()

subroutine smumps_dist_treat_recv_buf ( integer, dimension( nbrecords * 2 + 1 ) bufi,
real, dimension( nbrecords ) bufr,
integer nbrecords,
integer n,
integer, dimension( n, 2 ) iw4,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer local_m,
integer local_n,
type (smumps_root_struc) root,
integer(8) ptr_root,
real, dimension( la ) a,
integer(8) la,
integer end_msg_2_recv,
integer myid,
integer, dimension( keep(28) ) procnode_steps,
integer slavef,
integer(8), dimension( n ) ptraiw,
integer(8), dimension( n ) ptrarw,
integer, dimension( n ) perm,
integer, dimension( n ) step,
integer, dimension( lintarr ) intarr,
integer(8), intent(in) lintarr,
real, dimension( ldblarr ) dblarr,
integer(8), intent(in) ldblarr )

Definition at line 704 of file sfac_distrib_distentry.F.

711 USE smumps_struc_def, ONLY : smumps_root_struc
712 IMPLICIT NONE
713 TYPE (SMUMPS_ROOT_STRUC) :: root
714 INTEGER NBRECORDS, N, MYID, SLAVEF
715 INTEGER BUFI( NBRECORDS * 2 + 1 )
716 REAL BUFR( NBRECORDS )
717 INTEGER IW4( N, 2 )
718 INTEGER KEEP(500)
719 INTEGER(8) KEEP8(150)
720 INTEGER END_MSG_2_RECV
721 INTEGER(8) :: PTRAIW( N ), PTRARW( N )
722 INTEGER :: PERM( N ), STEP( N )
723 INTEGER PROCNODE_STEPS( KEEP(28) )
724 INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR
725 INTEGER INTARR( LINTARR )
726 INTEGER LOCAL_M, LOCAL_N
727 INTEGER(8) :: PTR_ROOT, LA
728 REAL A( LA ), DBLARR( LDBLARR )
729 INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE
730 EXTERNAL mumps_typenode, mumps_procnode
731 INTEGER IREC, NB_REC, NODE_TYPE, IPROC
732 INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT
733 INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8
734 INTEGER ISHIFT, IARR, JARR
735 INTEGER TAILLE
736 LOGICAL :: EARLYT3ROOTINS
737 REAL VAL
738 earlyt3rootins = keep(200) .EQ.0
739 & .OR. ( keep(200) .LT. 0 .AND. keep(400) .EQ. 0 )
740 nb_rec = bufi( 1 )
741 IF ( nb_rec .LE. 0 ) THEN
742 end_msg_2_recv = end_msg_2_recv - 1
743 nb_rec = - nb_rec
744 END IF
745 IF ( nb_rec .eq. 0 ) GOTO 100
746 DO irec = 1, nb_rec
747 iarr = bufi( irec * 2 )
748 jarr = bufi( irec * 2 + 1 )
749 val = bufr( irec )
750 node_type = mumps_typenode(
751 & procnode_steps(abs(step(abs( iarr )))),
752 & keep(199) )
753 IF ( node_type .eq. 3 .AND. earlyt3rootins ) THEN
754 IF ( iarr .GT. 0 ) THEN
755 iposroot = root%RG2L_ROW( iarr )
756 jposroot = root%RG2L_COL( jarr )
757 ELSE
758 iposroot = root%RG2L_ROW( jarr )
759 jposroot = root%RG2L_COL( -iarr )
760 END IF
761 ilocroot = root%MBLOCK * ( ( iposroot - 1 ) /
762 & ( root%MBLOCK * root%NPROW ) )
763 & + mod( iposroot - 1, root%MBLOCK ) + 1
764 jlocroot = root%NBLOCK * ( ( jposroot - 1 ) /
765 & ( root%NBLOCK * root%NPCOL ) )
766 & + mod( jposroot - 1, root%NBLOCK ) + 1
767 IF (keep(60)==0) THEN
768 a( ptr_root + int(jlocroot-1,8) * int(local_m,8)
769 & + int(ilocroot-1,8)) = a( ptr_root
770 & + int(jlocroot - 1,8) * int(local_m,8)
771 & + int(ilocroot - 1,8) )
772 & + val
773 ELSE
774 root%SCHUR_POINTER( int(jlocroot-1,8)
775 & * int(root%SCHUR_LLD,8)
776 & + int(ilocroot,8) )
777 & = root%SCHUR_POINTER( int(jlocroot - 1,8)
778 & * int(root%SCHUR_LLD,8)
779 & + int(ilocroot,8))
780 & + val
781 ENDIF
782 ELSE IF (iarr.GE.0) THEN
783 IF (iarr.EQ.jarr) THEN
784 ia8 = ptrarw(iarr)
785 dblarr(ia8) = dblarr(ia8) + val
786 ELSE
787 is18 = ptraiw(iarr)
788 ishift = intarr(is18) + iw4(iarr,2)
789 iw4(iarr,2) = iw4(iarr,2) - 1
790 iiw8 = is18 + ishift + 2
791 intarr(iiw8) = jarr
792 is8 = ptrarw(iarr)
793 ias8 = is8 + ishift
794 dblarr(ias8) = val
795 ENDIF
796 ELSE
797 iarr = -iarr
798 is8 = ptraiw(iarr)+iw4(iarr,1)+2
799 intarr(is8) = jarr
800 ias8 = ptrarw(iarr)+iw4(iarr,1)
801 iw4(iarr,1) = iw4(iarr,1) - 1
802 dblarr(ias8) = val
803 IF ( iw4(iarr,1) .EQ. 0
804 & .AND. step(iarr) > 0 ) THEN
805 iproc = mumps_procnode( procnode_steps(step(iarr)),
806 & keep(199) )
807 IF ( iproc .EQ. myid ) THEN
808 taille = intarr( ptraiw(iarr) )
809 CALL smumps_quick_sort_arrowheads( n, perm,
810 & intarr( ptraiw(iarr) + 3 ),
811 & dblarr( ptrarw(iarr) + 1 ),
812 & taille, 1, taille )
813 ENDIF
814 END IF
815 ENDIF
816 ENDDO
817 100 CONTINUE
818 RETURN
smumps_quick_sort_arrowheads
recursive subroutine smumps_quick_sort_arrowheads(n, perm, intlist, dbllist, taille, lo, hi)
Definition sarrowheads.F:686

◆ smumps_redistribution()

subroutine smumps_redistribution ( integer n,
integer(8) nz_loc8,
type (smumps_struc) id,
real, dimension( ldblarr ) dblarr,
integer(8) ldblarr,
integer, dimension( lintarr ) intarr,
integer(8) lintarr,
integer(8), dimension( n ), intent(in) ptraiw,
integer(8), dimension( n ), intent(in) ptrarw,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer myid,
integer comm,
integer nbrecords,
real, dimension( la ) a,
integer(8) la,
type (smumps_root_struc) root,
integer, dimension(keep(28)) procnode_steps,
integer slavef,
integer, dimension( n ) perm,
integer, dimension( n ) step,
integer, dimension(60) icntl,
integer, dimension( 80 ) info,
integer(8), intent(out) nsend8,
integer(8), intent(out) nlocal8,
integer, dimension(keep(71)) istep_to_iniv2,
integer, dimension(slavef+1, max(1,keep(56))) candidates )

Definition at line 94 of file sfac_distrib_distentry.F.

103!$ USE OMP_LIB
104 USE smumps_struc_def
105 IMPLICIT NONE
106 INTEGER N
107 INTEGER(8) :: NZ_loc8
108 TYPE (SMUMPS_STRUC) :: id
109 INTEGER(8) :: LDBLARR, LINTARR
110 REAL DBLARR( LDBLARR )
111 INTEGER INTARR( LINTARR )
112 INTEGER(8), INTENT(IN) :: PTRAIW( N ), PTRARW( N )
113 INTEGER KEEP(500)
114 INTEGER(8) KEEP8(150)
115 INTEGER MYID, COMM, NBRECORDS
116 INTEGER(8) :: LA
117 INTEGER SLAVEF
118 INTEGER ISTEP_TO_INIV2(KEEP(71))
119 INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56)))
120 REAL A( LA )
121 TYPE (SMUMPS_ROOT_STRUC) :: root
122 INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N )
123 INTEGER INFO( 80 ), ICNTL(60)
124 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc,
125 & MUMPS_TYPESPLIT
126 EXTERNAL mumps_procnode, mumps_typenode, numroc,
127 & mumps_typesplit
128 include 'mumps_tags.h'
129 include 'mpif.h'
130 INTEGER :: IERR, MSGSOU
131 INTEGER :: STATUS(MPI_STATUS_SIZE)
132 REAL ZERO
133 parameter( zero = 0.0e0 )
134 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4
135 INTEGER END_MSG_2_RECV
136 INTEGER I
137 INTEGER(8) :: I18, IA8
138 INTEGER(8) :: K8
139 INTEGER TYPE_NODE, DEST, DEST_SHR
140 INTEGER IOLD, JOLD, IARR, ISEND, JSEND
141 INTEGER ISEND_SHR, JSEND_SHR
142 INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND
143 LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS
144 REAL VAL, VAL_SHR
145 INTEGER(8) :: PTR_ROOT
146 INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT
147 INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT,
148 & ILOCROOT, JLOCROOT
149 INTEGER MP,LP
150 INTEGER KPROBE, FREQPROBE
151 INTEGER(8) :: IS18, IIW8, IS8, IAS8
152 INTEGER ISHIFT
153 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI
154 REAL, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR
155 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI
156 REAL, ALLOCATABLE, DIMENSION(:) :: BUFRECR
157 INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR
158 LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE
159 LOGICAL :: FLAG
160 INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8
161 INTEGER MASTER_NODE, ISTEP
162 LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P
163 INTEGER NOMP, NOMP_P, IOMP, P2
164 nsend8 = 0_8
165 nlocal8 = 0_8
166 lp = icntl(1)
167 mp = icntl(2)
168 end_msg_2_recv = slavef
169 ALLOCATE( iact(slavef), stat=allocok)
170 IF ( allocok .GT. 0 ) THEN
171 IF ( lp > 0 ) THEN
172 WRITE(lp,*)
173 & '** Error allocating IACT in matrix distribution'
174 END IF
175 info(1) = -13
176 info(2) = slavef
177 GOTO 20
178 END IF
179 ALLOCATE( ireqi(slavef), stat=allocok)
180 IF ( allocok .GT. 0 ) THEN
181 IF ( lp > 0 ) THEN
182 WRITE(lp,*)
183 & '** Error allocating IREQI in matrix distribution'
184 END IF
185 info(1) = -13
186 info(2) = slavef
187 GOTO 20
188 END IF
189 ALLOCATE( ireqr(slavef), stat=allocok)
190 IF ( allocok .GT. 0 ) THEN
191 IF ( lp > 0 ) THEN
192 WRITE(lp,*)
193 & '** Error allocating IREQR in matrix distribution'
194 END IF
195 info(1) = -13
196 info(2) = slavef
197 GOTO 20
198 END IF
199 ALLOCATE( send_active(slavef), stat=allocok)
200 IF ( allocok .GT. 0 ) THEN
201 IF ( lp > 0 ) THEN
202 WRITE(lp,*)
203 & '** Error allocating SEND_ACTIVE in matrix distribution'
204 END IF
205 info(1) = -13
206 info(2) = slavef
207 GOTO 20
208 END IF
209 ALLOCATE( bufi( nbrecords * 2 + 1, 2, slavef ), stat=allocok)
210 IF ( allocok .GT. 0 ) THEN
211 IF ( lp > 0 ) THEN
212 WRITE(lp,*)
213 & '** Error allocating int buffer for matrix distribution'
214 END IF
215 info(1) = -13
216 info(2) = ( nbrecords * 2 + 1 ) * slavef * 2
217 GOTO 20
218 END IF
219 ALLOCATE( bufr( nbrecords, 2, slavef), stat = allocok)
220 IF ( allocok .GT. 0 ) THEN
221 IF ( lp > 0 ) THEN
222 WRITE(lp,*)
223 & '** Error allocating real buffer for matrix distribution'
224 END IF
225 info(1) = -13
226 info(2) = nbrecords * slavef * 2
227 GOTO 20
228 END IF
229 ALLOCATE( bufreci( nbrecords * 2 + 1 ), stat = allocok )
230 IF ( allocok .GT. 0 ) THEN
231 IF ( lp > 0 ) THEN
232 WRITE(lp,*)
233 & '** Error allocating int recv buffer for matrix distribution'
234 END IF
235 info(1) = -13
236 info(2) = nbrecords * 2 + 1
237 GOTO 20
238 END IF
239 ALLOCATE( bufrecr( nbrecords ), stat = allocok )
240 IF ( allocok .GT. 0 ) THEN
241 IF ( lp > 0 ) THEN
242 WRITE(lp,*)
243 & '** Error allocating int recv buffer for matrix distribution'
244 END IF
245 info(1) = -13
246 info(2) = nbrecords
247 GOTO 20
248 END IF
249 ALLOCATE( iw4( n, 2 ), stat = allocok )
250 IF ( allocok .GT. 0 ) THEN
251 WRITE(lp,*) '** Error allocating IW4 for matrix distribution'
252 info(1) = -13
253 info(2) = n * 2
254 END IF
255 20 CONTINUE
256 CALL mumps_propinfo( icntl, info, comm, myid )
257 IF ( info(1) .LT. 0 ) GOTO 100
258 arrow_root = 0
259 DO i = 1, n
260 i18 = ptraiw( i )
261 ia8 = ptrarw( i )
262 IF ( ia8 .GT. 0_8 ) THEN
263 dblarr( ia8 ) = zero
264 iw4( i, 1 ) = intarr( i18 )
265 iw4( i, 2 ) = -intarr( i18 + 1_8 )
266 intarr( i18 + 2_8 ) = i
267 END IF
268 END DO
269 earlyt3rootins = keep(200) .EQ.0
270 & .OR. ( keep(200) .LT. 0 .AND. keep(400) .EQ. 0 )
271 IF ( keep(38) .NE. 0 .AND. earlyt3rootins ) THEN
272 CALL smumps_get_root_info(root,local_m, local_n, ptr_root, la)
273 CALL smumps_set_root_to_zero(root, keep, a, la)
274 ELSE
275 local_m = -19999; local_n = -29999; ptr_root = -99999_8
276 END IF
277 DO i = 1, slavef
278 bufi( 1, 1, i ) = 0
279 END DO
280 DO i = 1, slavef
281 bufi( 1, 2, i ) = 0
282 END DO
283 DO i = 1, slavef
284 send_active( i ) = .false.
285 iact( i ) = 1
286 END DO
287 kprobe = 0
288 freqprobe = max(1,nbrecords/10)
289 IF (slavef .EQ. 1) freqprobe = huge(freqprobe)
290 nomp = 1
291!$ NOMP=omp_get_max_threads()
292 omp_flag = keep(399).EQ.1 .AND. nomp .GE.2 .AND. slavef.EQ.1
293!$OMP PARALLEL PRIVATE( K8, I, DEST,
294!$OMP& T4MASTER, T4_MASTER_CONCERNED,
295!$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT,
296!$OMP& ILOCROOT, JLOCROOT,
297!$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE,
298!$OMP& IA8, ISHIFT, IIW8, IS18, IS8, IAS8, VAL,
299!$OMP& IARR, ISTEP, ISEND, JSEND,
300!$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P )
301!$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG)
302 iomp=0
303!$ IOMP=omp_get_thread_num()
304 nomp_p=1
305!$ NOMP_P=omp_get_num_threads()
306 omp_flag_p = .false.
307!$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1
308 IF (omp_flag_p) THEN
309 IF ( nomp_p .GE. 16 ) THEN
310 nomp_p=16
311 p2 = 4
312 ELSE IF (nomp_p.GE.8) THEN
313 nomp_p=8
314 p2 = 3
315 ELSE IF (nomp_p.GE.4) THEN
316 nomp_p=4
317 p2 = 2
318 ELSE IF (nomp_p.GE.2) THEN
319 nomp_p=2
320 p2 = 1
321 ENDIF
322 ELSE
323 nomp_p = 1
324 p2 = 0
325 ENDIF
326 IF ( iomp .LT. nomp_p ) THEN
327 DO k8 = 1_8, nz_loc8
328 IF ( slavef .GT. 1 ) THEN
329!$OMP MASTER
330 kprobe = kprobe + 1
331 IF ( kprobe .eq. freqprobe ) THEN
332 kprobe = 0
333 CALL mpi_iprobe( mpi_any_source, arr_int, comm,
334 & flag, status, ierr )
335 IF ( flag ) THEN
336 msgsou = status( mpi_source )
337 CALL mpi_recv( bufreci(1), nbrecords * 2 + 1,
338 & mpi_integer,
339 & msgsou, arr_int, comm, status, ierr )
340 CALL mpi_recv( bufrecr(1), nbrecords,
341 & mpi_real,
342 & msgsou, arr_real, comm, status, ierr )
343 CALL smumps_dist_treat_recv_buf(
344 & bufreci, bufrecr, nbrecords, n, iw4(1,1),
345 & keep,keep8, local_m, local_n, root, ptr_root,
346 & a, la,
347 & end_msg_2_recv, myid, procnode_steps, slavef,
348 & ptraiw, ptrarw, perm, step,
349 & intarr, lintarr, dblarr, ldblarr
350 & )
351 END IF
352 END IF
353!$OMP END MASTER
354 ENDIF
355 iold = id%IRN_loc(k8)
356 jold = id%JCN_loc(k8)
357 IF ( (iold.GT.n).OR.(jold.GT.n).OR.(iold.LT.1)
358 & .OR.(jold.LT.1) ) THEN
359 cycle
360 ENDIF
361 IF (omp_flag_p) THEN
362 IF (iold.EQ.jold) THEN
363 iarr = iold
364 ELSE IF (perm(iold).LT.perm(jold)) THEN
365 iarr = iold
366 ELSE
367 iarr = jold
368 ENDIF
369 doit = ( iomp .EQ. ibits(iarr, p2-1, p2))
370 ELSE
371 doit = .true.
372 ENDIF
373 IF (doit) THEN
374 IF (iold.EQ.jold) THEN
375 isend = iold
376 jsend = iold
377 iarr = iold
378 ELSE IF (perm(iold).LT.perm(jold)) THEN
379 iarr = iold
380 IF ( keep(50) .NE. 0 ) THEN
381 isend = -iold
382 ELSE
383 isend = iold
384 ENDIF
385 jsend = jold
386 ELSE
387 iarr = jold
388 isend = -jold
389 jsend = iold
390 ENDIF
391 istep = abs(step(iarr))
392 CALL mumps_typeandprocnode( type_node, master_node,
393 & procnode_steps(istep), keep(199) )
394 t4_master_concerned = .false.
395 t4master = -9999
396 val = id%A_loc(k8)
397 IF ((keep(52).EQ.7).OR.(keep(52).EQ.8)) THEN
398 val = val * id%ROWSCA(iold)*id%COLSCA(jold)
399 ENDIF
400 IF ( type_node .eq. 1 ) THEN
401 dest = master_node
402 IF (dest.EQ.myid) THEN
403 nlocal8 = nlocal8 + 1_8
404 IF (isend.EQ.jsend) THEN
405 ia8 = ptrarw(isend)
406 dblarr(ia8) = dblarr(ia8) + val
407 ELSE IF (isend.GE.0) THEN
408 is18 = ptraiw(iarr)
409 ishift = intarr(is18) + iw4(iarr,2)
410 intarr(is18+ishift+2) = jsend
411 dblarr(ptrarw(iarr)+ishift) = val
412 iw4(iarr,2) = iw4(iarr,2) - 1
413 ELSE
414 ishift = iw4(iarr,1)
415 intarr(ptraiw(iarr)+ishift+2) = jsend
416 dblarr(ptrarw(iarr)+ishift) = val
417 iw4(iarr,1) = iw4(iarr,1) - 1
418 IF ( iw4(iarr,1) .EQ. 0
419 & .AND. step(iarr) > 0 ) THEN
420 CALL smumps_quick_sort_arrowheads( n, perm,
421 & intarr( ptraiw(iarr) + 3 ),
422 & dblarr( ptrarw(iarr) + 1 ),
423 & intarr( ptraiw(iarr) ), 1,
424 & intarr( ptraiw(iarr) ) )
425 END IF
426 ENDIF
427 cycle
428 ENDIF
429 ELSE IF ( type_node .eq. 2 ) THEN
430 IF ( isend .LT. 0 ) THEN
431 dest = -1
432 ELSE
433 dest = master_node
434 END IF
435 iniv2 = istep_to_iniv2(istep)
436 IF ( keep(79) .GT. 0) THEN
437 typesplit = mumps_typesplit( procnode_steps(istep),
438 & keep(199) )
439 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6)) THEN
440 t4_master_concerned = .true.
441 t4master=candidates(candidates(slavef+1,iniv2)+1,iniv2)
442 ENDIF
443 ENDIF
444 ELSE
445 arrow_root = arrow_root + 1
446 IF (earlyt3rootins) THEN
447 IF ( isend < 0 ) THEN
448 iposroot = root%RG2L_ROW(jsend)
449 jposroot = root%RG2L_ROW(iarr )
450 ELSE
451 iposroot = root%RG2L_ROW(iarr )
452 jposroot = root%RG2L_ROW(jsend)
453 END IF
454 irow_grid = mod( ( iposroot-1 )/root%MBLOCK, root%NPROW )
455 jcol_grid = mod( ( jposroot-1 )/root%NBLOCK, root%NPCOL )
456 dest = irow_grid * root%NPCOL + jcol_grid
457 ELSE
458 dest = -2
459 ENDIF
460 IF ( omp_flag_p ) THEN
461 IF ( earlyt3rootins ) THEN
462 ilocroot = root%MBLOCK * ( ( iposroot - 1 ) /
463 & ( root%MBLOCK * root%NPROW ) )
464 & + mod( iposroot - 1, root%MBLOCK ) + 1
465 jlocroot = root%NBLOCK * ( ( jposroot - 1 ) /
466 & ( root%NBLOCK * root%NPCOL ) )
467 & + mod( jposroot - 1, root%NBLOCK ) + 1
468 IF (keep(60)==0) THEN
469 a( ptr_root + int(jlocroot-1,8) * int(local_m,8)
470 & + int(ilocroot-1,8)) = a( ptr_root
471 & + int(jlocroot - 1,8) * int(local_m,8)
472 & + int(ilocroot - 1,8) )
473 & + val
474 ELSE
475 root%SCHUR_POINTER( int(jlocroot-1,8)
476 & * int(root%SCHUR_LLD,8)
477 & + int(ilocroot,8) )
478 & = root%SCHUR_POINTER( int(jlocroot - 1,8)
479 & * int(root%SCHUR_LLD,8)
480 & + int(ilocroot,8))
481 & + val
482 ENDIF
483 ELSE
484 IF (isend.EQ.jsend) THEN
485 ia8 = ptrarw(isend)
486 dblarr(ia8) = dblarr(ia8) + val
487 ELSE IF (isend.GE.0) THEN
488 is18 = ptraiw(iarr)
489 ishift = intarr(is18) + iw4(iarr,2)
490 iw4(iarr,2) = iw4(iarr,2) - 1
491 iiw8 = is18 + ishift + 2
492 intarr(iiw8) = jsend
493 is8 = ptrarw(iarr)
494 ias8 = is8 + ishift
495 dblarr(ias8) = val
496 ELSE
497 is8 = ptraiw(iarr)+iw4(iarr,1)+2
498 intarr(is8) = jsend
499 ias8 = ptrarw(iarr)+iw4(iarr,1)
500 iw4(iarr,1) = iw4(iarr,1) - 1
501 dblarr(ias8) = val
502 IF ( iw4(iarr,1) .EQ. 0
503 & .AND. step(iarr) > 0 ) THEN
504 CALL smumps_quick_sort_arrowheads( n, perm,
505 & intarr( ptraiw(iarr) + 3 ),
506 & dblarr( ptrarw(iarr) + 1 ),
507 & intarr( ptraiw(iarr) ), 1,
508 & intarr( ptraiw(iarr) ) )
509 END IF
510 ENDIF
511 ENDIF
512 cycle
513 ENDIF
514 END IF
515 IF (dest .eq. -1) THEN
516 nlocal8 = nlocal8 + 1_8
517 nsend8 = nsend8 + int(slavef -1,8)
518 ELSE IF (dest .EQ. -2) THEN
519 nlocal8 = nlocal8 + 1_8
520 nsend8 = nsend8 + int(slavef -1,8)
521 ELSE
522 IF (dest .eq.myid ) THEN
523 nlocal8 = nlocal8 + 1_8
524 ELSE
525 nsend8 = nsend8 + 1_8
526 ENDIF
527 ENDIF
528 IF ( dest.EQ.-1) THEN
529 iniv2 = istep_to_iniv2(istep)
530 ncand = candidates(slavef+1,iniv2)
531 IF (keep(79) .GT. 0) THEN
532 DO i=1, slavef
533 dest=candidates(i,iniv2)
534 IF (dest.LT.0) EXIT
535 IF (i.EQ.ncand+1) cycle
536 dest_shr=dest;isend_shr=isend
537 jsend_shr=jsend;val_shr=val
538 CALL smumps_dist_fill_buffer()
539 ENDDO
540 ELSE
541 DO i=1, ncand
542 dest=candidates(i,iniv2)
543 dest_shr=dest;isend_shr=isend
544 jsend_shr=jsend;val_shr=val
545 CALL smumps_dist_fill_buffer()
546 ENDDO
547 ENDIF
548 dest=master_node
549 dest_shr=dest;isend_shr=isend
550 jsend_shr=jsend;val_shr=val
551 CALL smumps_dist_fill_buffer()
552 IF (t4_master_concerned) THEN
553 dest = t4master
554 dest_shr=dest;isend_shr=isend
555 jsend_shr=jsend;val_shr=val
556 CALL smumps_dist_fill_buffer()
557 ENDIF
558 ELSE IF (dest .GE. 0) THEN
559 dest_shr=dest;isend_shr=isend
560 jsend_shr=jsend;val_shr=val
561 CALL smumps_dist_fill_buffer()
562 IF (t4_master_concerned) THEN
563 dest = t4master
564 dest_shr=dest;isend_shr=isend
565 jsend_shr=jsend;val_shr=val
566 CALL smumps_dist_fill_buffer()
567 ENDIF
568 ELSE IF (dest .EQ. -2) THEN
569 DO i = 0, slavef-1
570 dest=i
571 dest_shr=dest;isend_shr=isend
572 jsend_shr=jsend;val_shr=val
573 CALL smumps_dist_fill_buffer()
574 ENDDO
575 ENDIF
576 ENDIF
577 END DO
578 ENDIF
579!$OMP END PARALLEL
580 dest_shr = -3
581 CALL smumps_dist_fill_buffer()
582 DO WHILE ( end_msg_2_recv .NE. 0 )
583 CALL mpi_recv( bufreci(1), nbrecords * 2 + 1, mpi_integer,
584 & mpi_any_source, arr_int, comm, status, ierr )
585 msgsou = status( mpi_source )
586 CALL mpi_recv( bufrecr(1), nbrecords, mpi_real,
587 & msgsou, arr_real, comm, status, ierr )
588 CALL smumps_dist_treat_recv_buf(
589 & bufreci, bufrecr, nbrecords, n, iw4(1,1),
590 & keep,keep8, local_m, local_n, root, ptr_root,
591 & a, la,
592 & end_msg_2_recv, myid, procnode_steps, slavef,
593 & ptraiw, ptrarw, perm, step,
594 & intarr, lintarr, dblarr, ldblarr
595 & )
596 END DO
597 DO i = 1, slavef
598 IF ( send_active( i ) ) THEN
599 CALL mpi_wait( ireqi( i ), status, ierr )
600 CALL mpi_wait( ireqr( i ), status, ierr )
601 END IF
602 END DO
603 keep(49) = arrow_root
604 100 CONTINUE
605 IF (ALLOCATED(iw4)) DEALLOCATE( iw4 )
606 IF (ALLOCATED(bufi)) DEALLOCATE( bufi )
607 IF (ALLOCATED(bufr)) DEALLOCATE( bufr )
608 IF (ALLOCATED(bufreci)) DEALLOCATE( bufreci )
609 IF (ALLOCATED(bufrecr)) DEALLOCATE( bufrecr )
610 IF (ALLOCATED(iact)) DEALLOCATE( iact )
611 IF (ALLOCATED(ireqi)) DEALLOCATE( ireqi )
612 IF (ALLOCATED(ireqr)) DEALLOCATE( ireqr )
613 IF (ALLOCATED(send_active)) DEALLOCATE( send_active )
614 RETURN
615 CONTAINS
616 SUBROUTINE smumps_dist_fill_buffer()
617 IMPLICIT NONE
618 INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ
619 INTEGER TAILLE_SEND_I, TAILLE_SEND_R
620 LOGICAL SEND_LOCAL
621 IF ( dest_shr .eq. -3 ) THEN
622 ibeg = 1
623 iend = slavef
624 ELSE
625 ibeg = dest_shr + 1
626 iend = dest_shr + 1
627 END IF
628 send_local = .false.
629 DO islave = ibeg, iend
630 nbrec = bufi(1,iact(islave),islave)
631 IF ( dest_shr .eq. -3 ) THEN
632 bufi(1,iact(islave),islave) = - nbrec
633 END IF
634 IF ( dest_shr .eq. -3 .or. nbrec + 1 > nbrecords ) THEN
635 DO WHILE ( send_active( islave ) )
636 CALL mpi_test( ireqr( islave ), flag, status, ierr )
637 IF ( .NOT. flag ) THEN
638 CALL mpi_iprobe( mpi_any_source, arr_int, comm,
639 & flag, status, ierr )
640 IF ( flag ) THEN
641 msgsou = status(mpi_source)
642 CALL mpi_recv( bufreci(1), 2*nbrecords+1,
643 & mpi_integer, msgsou, arr_int, comm,
644 & status, ierr )
645 CALL mpi_recv( bufrecr(1), nbrecords,
646 & mpi_real, msgsou,
647 & arr_real, comm, status, ierr )
648 CALL smumps_dist_treat_recv_buf(
649 & bufreci, bufrecr, nbrecords, n, iw4(1,1),
650 & keep,keep8, local_m, local_n, root, ptr_root,
651 & a, la,
652 & end_msg_2_recv, myid, procnode_steps, slavef,
653 & ptraiw, ptrarw, perm, step,
654 & intarr, lintarr, dblarr, ldblarr
655 & )
656 END IF
657 ELSE
658 CALL mpi_wait( ireqi( islave ), status, ierr )
659 send_active( islave ) = .false.
660 END IF
661 END DO
662 IF ( islave - 1 .ne. myid ) THEN
663 taille_send_i = nbrec * 2 + 1
664 taille_send_r = nbrec
665 CALL mpi_isend( bufi(1, iact(islave), islave ),
666 & taille_send_i,
667 & mpi_integer, islave - 1, arr_int, comm,
668 & ireqi( islave ), ierr )
669 CALL mpi_isend( bufr(1, iact(islave), islave ),
670 & taille_send_r,
671 & mpi_real, islave - 1, arr_real, comm,
672 & ireqr( islave ), ierr )
673 send_active( islave ) = .true.
674 ELSE
675 send_local = .true.
676 END IF
677 iact( islave ) = 3 - iact( islave )
678 bufi( 1, iact( islave ), islave ) = 0
679 END IF
680 IF ( dest_shr .ne. -3 ) THEN
681 ireq = bufi(1,iact(islave),islave) + 1
682 bufi(1,iact(islave),islave) = ireq
683 bufi(ireq*2,iact(islave),islave) = isend_shr
684 bufi(ireq*2+1,iact(islave),islave) = jsend_shr
685 bufr(ireq,iact(islave),islave ) = val_shr
686 END IF
687 END DO
688 IF ( send_local ) THEN
689 islave = myid + 1
690 CALL smumps_dist_treat_recv_buf(
691 & bufi(1,3-iact(islave),islave),
692 & bufr(1,3-iact(islave),islave),
693 & nbrecords, n, iw4(1,1),
694 & keep,keep8, local_m, local_n, root, ptr_root,
695 & a, la,
696 & end_msg_2_recv, myid, procnode_steps, slavef,
697 & ptraiw, ptrarw, perm, step,
698 & intarr, lintarr, dblarr, ldblarr
699 & )
700 END IF
701 RETURN
702 END SUBROUTINE smumps_dist_fill_buffer
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
max
#define max(a, b)
Definition macros.h:21
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition mpi.f:786
id
initmumps id
Definition multiplerhs_example.m:4
smumps_get_root_info
subroutine smumps_get_root_info(root, local_m, local_n, ptr_root, la)
Definition sarrowheads.F:971
smumps_set_root_to_zero
subroutine smumps_set_root_to_zero(root, keep, a, la)
Definition sarrowheads.F:948
smumps_dist_fill_buffer
subroutine smumps_dist_fill_buffer()
Definition sfac_distrib_distentry.F:617
mumps_typesplit
integer function mumps_typesplit(procinfo_inode, k199)
Definition tools_common.F:171
mumps_typeandprocnode
subroutine mumps_typeandprocnode(tpn, mumps_procnode, procinfo_inode, k199)
Definition tools_common.F:114