OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
darrowheads.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, University of Bordeaux.
8C
9C This version of MUMPS is provided to you free of charge. It is
10C released under the CeCILL-C license
11C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 SUBROUTINE dmumps_ana_dist_arrowheads( MYID, SLAVEF, N,
15 & PROCNODE, STEP, PTRAIW, PTRARW, ISTEP_TO_INIV2,
16 & I_AM_CAND,
17 & KEEP, KEEP8, ICNTL, id )
18 USE dmumps_struc_def
19 IMPLICIT NONE
20 TYPE (DMUMPS_STRUC) :: id
21 INTEGER MYID, N, SLAVEF
22 INTEGER KEEP( 500 ), ICNTL( 60 )
23 INTEGER(8) KEEP8(150)
24 INTEGER PROCNODE( KEEP(28) ), STEP( N )
25 INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N )
26 INTEGER ISTEP_TO_INIV2(KEEP(71))
27 LOGICAL I_AM_CAND(max(1,KEEP(56)))
28 LOGICAL I_AM_SLAVE
29 LOGICAL I_AM_CAND_LOC
30 INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT
31 EXTERNAL mumps_typenode, mumps_procnode, mumps_typesplit
32 INTEGER ISTEP, I, NCOL, NROW, allocok
33 INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT
34 LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS
35 INTEGER(8) :: IPTRI, IPTRR
36 earlyt3rootins = keep(200) .EQ. 0
37 & .OR. (keep(200) .LT. 0 .AND. keep(400) .EQ. 0)
38 type_parall = keep(46)
39 i_am_slave = (keep(46).EQ.1 .OR. myid.NE.0)
40 keep8(26) = 0_8
41 keep8(27) = 0_8
42 DO i = 1, n
43 istep=abs(step(i))
44 itype = mumps_typenode( procnode(istep), keep(199) )
45 irank = mumps_procnode( procnode(istep), keep(199) )
46 i_am_cand_loc = .false.
47 typesplit = mumps_typesplit( procnode(istep), keep(199) )
48 t4_master_concerned = .false.
49 IF (itype.EQ.2) THEN
50 iniv2 = istep_to_iniv2(istep)
51 IF (i_am_slave) THEN
52 i_am_cand_loc = i_am_cand(iniv2)
53 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6)) THEN
54 IF ( type_parall .eq. 0 ) THEN
55 t4_master_concerned =
56 & ( id%CANDIDATES (id%CANDIDATES(slavef+1,iniv2)+1,iniv2)
57 & .EQ.myid-1 )
58 ELSE
59 t4_master_concerned =
60 & ( id%CANDIDATES (id%CANDIDATES(slavef+1, iniv2)+1,iniv2 )
61 & .EQ.myid )
62 ENDIF
63 ENDIF
64 ENDIF
65 ENDIF
66 IF ( type_parall .eq. 0 ) THEN
67 irank = irank + 1
68 END IF
69 IF (
70 & ( (itype .EQ. 1.OR.itype.EQ.2) .AND.
71 & irank .EQ. myid )
72 & .OR.
73 & ( t4_master_concerned )
74 & ) THEN
75 keep8(26) = keep8(26) + 1_8 + ptraiw(i)+ptrarw(i)
76 keep8(27) = keep8(27) + 3_8 + ptraiw(i)+ptrarw(i)
77 ELSE IF ( itype .EQ. 3 ) THEN
78 IF (earlyt3rootins) THEN
79 ELSE
80 keep8(26) = keep8(26) + 1_8 + ptraiw(i)+ptrarw(i)
81 keep8(27) = keep8(27) + 3_8 + ptraiw(i)+ptrarw(i)
82 ENDIF
83 ELSE IF ( itype .EQ. 2 .AND. i_am_cand_loc ) THEN
84 ptrarw( i ) = 0_8
85 keep8(26) = keep8(26) + 1_8 + ptraiw(i)+ptrarw(i)
86 keep8(27) = keep8(27) + 3_8 + ptraiw(i)+ptrarw(i)
87 END IF
88 END DO
89 IF ( associated( id%INTARR ) ) THEN
90 DEALLOCATE( id%INTARR )
91 NULLIFY( id%INTARR )
92 END IF
93 IF ( keep8(27) > 0 ) THEN
94 ALLOCATE( id%INTARR( keep8(27) ), stat = allocok )
95 IF ( allocok .GT. 0 ) THEN
96 id%INFO(1) = -7
97 CALL mumps_set_ierror(keep8(27),id%INFO(2))
98 RETURN
99 END IF
100 ELSE
101 ALLOCATE( id%INTARR( 1 ), stat = allocok )
102 IF ( allocok .GT. 0 ) THEN
103 id%INFO(1) = -7
104 id%INFO(2) = 1
105 RETURN
106 END IF
107 END IF
108 iptri = 1_8
109 iptrr = 1_8
110 DO i = 1, n
111 istep = abs(step(i))
112 itype = mumps_typenode( procnode(istep), keep(199) )
113 irank = mumps_procnode( procnode(istep), keep(199) )
114 typesplit = mumps_typesplit( procnode(istep), keep(199) )
115 i_am_cand_loc = .false.
116 t4_master_concerned = .false.
117 IF (itype.EQ.2) THEN
118 iniv2 = istep_to_iniv2(istep)
119 IF (i_am_slave) THEN
120 i_am_cand_loc = i_am_cand(iniv2)
121 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6)) THEN
122 IF ( type_parall .eq. 0 ) THEN
123 t4_master_concerned =
124 & (id%CANDIDATES (id%CANDIDATES(slavef+1,iniv2)+1,iniv2)
125 & .EQ.myid-1 )
126 ELSE
127 t4_master_concerned =
128 & (id%CANDIDATES (id%CANDIDATES(slavef+1,iniv2)+1,iniv2)
129 & .EQ.myid )
130 ENDIF
131 ENDIF
132 ENDIF
133 ENDIF
134 IF ( type_parall .eq. 0 ) THEN
135 irank =irank + 1
136 END IF
137 IF (
138 & ( itype .eq. 2 .and.
139 & irank .eq. myid )
140 & .or.
141 & ( itype .eq. 1 .and.
142 & irank .eq. myid )
143 & .or.
144 & ( t4_master_concerned )
145 & ) THEN
146 ncol = int(ptraiw( i ))
147 nrow = int(ptrarw( i ))
148 id%INTARR( iptri ) = ncol
149 id%INTARR( iptri + 1 ) = -nrow
150 id%INTARR( iptri + 2 ) = i
151 ptraiw( i ) = iptri
152 ptrarw( i ) = iptrr
153 iptri = iptri + int(ncol + nrow + 3,8)
154 iptrr = iptrr + int(ncol + nrow + 1,8)
155 ELSE IF ( itype .eq. 3) THEN
156 IF ( earlyt3rootins ) THEN
157 ptraiw(i)=0
158 ptrarw(i)=0
159 ELSE
160 ncol = int(ptraiw( i ))
161 nrow = int(ptrarw( i ))
162 id%INTARR( iptri ) = ncol
163 id%INTARR( iptri + 1 ) = -nrow
164 id%INTARR( iptri + 2 ) = i
165 ptraiw( i ) = iptri
166 ptrarw( i ) = iptrr
167 iptri = iptri + int(ncol + nrow + 3,8)
168 iptrr = iptrr + int(ncol + nrow + 1,8)
169 ENDIF
170 ELSE IF ( itype .eq. 2 .AND. i_am_cand_loc ) THEN
171 ncol = int(ptraiw( i ))
172 nrow = 0
173 id%INTARR( iptri ) = ncol
174 id%INTARR( iptri + 1 ) = -nrow
175 id%INTARR( iptri + 2 ) = i
176 ptraiw( i ) = iptri
177 ptrarw( i ) = iptrr
178 iptri = iptri + int(ncol + nrow + 3, 8)
179 iptrr = iptrr + int(ncol + nrow + 1, 8)
180 ELSE
181 ptraiw(i) = 0_8
182 ptrarw(i) = 0_8
183 END IF
184 END DO
185 IF ( iptri - 1_8 .NE. keep8(27) ) THEN
186 WRITE(*,*) 'Error 1 in ana_arrowheads',
187 & ' iptri - 1, keep8(27)=', IPTRI - 1, KEEP8(27)
188 CALL MUMPS_ABORT()
189 END IF
190.NE. IF ( IPTRR - 1_8 KEEP8(26) ) THEN
191 WRITE(*,*) 'error 2 in ana_arrowheads'
192 CALL MUMPS_ABORT()
193 END IF
194 RETURN
195 END SUBROUTINE DMUMPS_ANA_DIST_ARROWHEADS
196 SUBROUTINE DMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK,
197 & IRN, ICN, PERM,
198 & LSCAL,COLSCA,ROWSCA,
199 & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS,
200 & LP, COMM, root, KEEP, KEEP8, FILS, RG2L,
201 & INTARR, LINTARR, DBLARR, LDBLARR, PTRAIW, PTRARW, FRERE_STEPS,
202 & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES )
203!$ USE OMP_LIB
204 USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC
205 IMPLICIT NONE
206 INTEGER :: N, COMM, NBRECORDS
207 INTEGER(8), INTENT(IN) :: NZ
208 INTEGER KEEP( 500 )
209 INTEGER(8) KEEP8(150)
210 DOUBLE PRECISION ASPK(NZ)
211 DOUBLE PRECISION COLSCA(*), ROWSCA(*)
212 INTEGER IRN(NZ), ICN(NZ)
213 INTEGER PERM(N), PROCNODE_STEPS(KEEP(28))
214 INTEGER RG2L( N ), FILS( N )
215 INTEGER ISTEP_TO_INIV2(KEEP(71))
216 LOGICAL I_AM_CAND(max(1,KEEP(56)))
217 INTEGER LP, SLAVEF, MYID
218 INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56)))
219 LOGICAL LSCAL
220 TYPE (DMUMPS_ROOT_STRUC) :: root
221 INTEGER(8), INTENT(IN) :: LA
222 INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N )
223 INTEGER :: FRERE_STEPS( KEEP(28) )
224 INTEGER :: STEP(N)
225 INTEGER(8) :: LINTARR, LDBLARR
226 INTEGER :: INTARR( LINTARR )
227 DOUBLE PRECISION :: DBLARR( LDBLARR )
228 DOUBLE PRECISION :: A( LA )
229 INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI
230 DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: BUFR
231 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc,
232 & MUMPS_TYPESPLIT
233 EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc,
234 & MUMPS_TYPESPLIT
235 DOUBLE PRECISION VAL, VAL_SHR
236 INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR
237 INTEGER ISEND_SHR, JSEND_SHR, DEST_SHR
238 INTEGER IPOSROOT, JPOSROOT
239 INTEGER IROW_GRID, JCOL_GRID
240 INTEGER INODE, ISTEP
241 INTEGER NBUFS
242 INTEGER ARROW_ROOT, TAILLE
243 INTEGER LOCAL_M, LOCAL_N
244 INTEGER(8) :: PTR_ROOT
245 INTEGER TYPE_NODE, MASTER_NODE
246 LOGICAL I_AM_CAND_LOC, I_AM_SLAVE
247 INTEGER JARR, ILOCROOT, JLOCROOT
248 INTEGER allocok, INIV2, TYPESPLIT, T4MASTER
249 INTEGER(8) :: I1, IA, IS1, IAS, ISHIFT, K
250 INTEGER NCAND
251 LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS
252 DOUBLE PRECISION ZERO
253 PARAMETER( ZERO = 0.0D0 )
254 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4
255 LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P
256 INTEGER NOMP, NOMP_P, IOMP, P2
257 ARROW_ROOT = 0
258.EQ. EARLYT3ROOTINS = KEEP(200) 0
259.OR..LT..AND..EQ. & (KEEP(200) 0 KEEP(400) 0)
260.NE..OR..EQ. I_AM_SLAVE=(MYID0KEEP(46)1)
261.eq. IF ( KEEP(46) 0 ) THEN
262 NBUFS = SLAVEF
263 ELSE
264 NBUFS = SLAVEF - 1
265 ALLOCATE( IW4( N, 2 ), stat = allocok )
266.GT. IF ( allocok 0 ) THEN
267 WRITE(*,*) 'error allocating iw4'
268 CALL MUMPS_ABORT()
269 END IF
270#if defined(__ve__)
271!NEC$ IVDEP
272#endif
273 DO I = 1, N
274 I1 = PTRAIW( I )
275 IA = PTRARW( I )
276.GT. IF ( IA 0 ) THEN
277 DBLARR( IA ) = ZERO
278 IW4( I, 1 ) = INTARR( I1 )
279 IW4( I, 2 ) = -INTARR( I1 + 1 )
280 INTARR( I1 + 2 ) = I
281 END IF
282 END DO
283.NE..AND. IF ( KEEP(38) 0 EARLYT3ROOTINS ) THEN
284 CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N,
285 & PTR_ROOT, LA)
286 CALL DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA)
287 ELSE
288 LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8
289 END IF
290 END IF
291.GT. IF (NBUFS0) THEN
292 ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok )
293.GT. IF ( allocok 0 ) THEN
294 WRITE(*,*) 'error allocating bufi'
295 CALL MUMPS_ABORT()
296 END IF
297 ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok )
298.GT. IF ( allocok 0 ) THEN
299 WRITE(*,*) 'error allocating bufr'
300 CALL MUMPS_ABORT()
301 END IF
302 DO I = 1, NBUFS
303 BUFI( 1, I ) = 0
304 ENDDO
305 ENDIF
306 INODE = KEEP(38)
307 I = 1
308.GT. DO WHILE ( INODE 0 )
309 RG2L( INODE ) = I
310 INODE = FILS( INODE )
311 I = I + 1
312 END DO
313 NOMP = 1
314!$ NOMP=omp_get_max_threads()
315.EQ..AND..GE..AND..EQ. OMP_FLAG = KEEP(399)1 NOMP2 SLAVEF1
316.AND..EQ. & KEEP(46) 1
317!$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC,
318!$OMP& T4MASTER, T4_MASTER_CONCERNED,
319!$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID,
320!$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT,
321!$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE,
322!$OMP& IA, ISHIFT, IS1, IAS, TAILLE, VAL,
323!$OMP& IARR, JARR, ISTEP, ISEND, JSEND,
324!$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P)
325!$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG)
326 IOMP=0
327!$ IOMP=omp_get_thread_num()
328 NOMP_P=1
329!$ NOMP_P=omp_get_num_threads()
330 OMP_FLAG_P = .FALSE.
331.AND..GT.!$ OMP_FLAG_P = OMP_FLAG NOMP_P 1
332 IF (OMP_FLAG_P) THEN
333.GE. IF ( NOMP_P 16 ) THEN
334 NOMP_P=16
335 P2 = 4
336.GE. ELSE IF (NOMP_P8) THEN
337 NOMP_P=8
338 P2 = 3
339.GE. ELSE IF (NOMP_P4) THEN
340 NOMP_P=4
341 P2 = 2
342.GE. ELSE IF (NOMP_P2) THEN
343 NOMP_P=2
344 P2 = 1
345 ENDIF
346 ELSE
347 NOMP_P = 1
348 P2 = 0
349 ENDIF
350.LT. IF ( IOMP NOMP_P ) THEN
351 DO K=1, NZ
352 IOLD = IRN(K)
353 JOLD = ICN(K)
354.GT..OR..GT..OR..LT. IF ( (IOLDN)(JOLDN)(IOLD1)
355.OR..LT. & (JOLD1) ) THEN
356 CYCLE
357 END IF
358 IF (OMP_FLAG_P) THEN
359.EQ. IF (IOLDJOLD) THEN
360 IARR = IOLD
361.LT. ELSE IF (PERM(IOLD)PERM(JOLD)) THEN
362 IARR = IOLD
363 ELSE
364 IARR = JOLD
365 ENDIF
366.EQ. DOIT = ( IOMP ibits(IARR, P2-1, P2))
367 ELSE
368 DOIT = .TRUE.
369 ENDIF
370 IF (DOIT) THEN
371.EQ. IF (IOLDJOLD) THEN
372 ISEND = IOLD
373 JSEND = JOLD
374 IARR = IOLD
375.LT. ELSE IF (PERM(IOLD)PERM(JOLD)) THEN
376 IARR = IOLD
377.NE. IF ( KEEP(50) 0 ) THEN
378 ISEND = -IOLD
379 ELSE
380 ISEND = IOLD
381 ENDIF
382 JSEND = JOLD
383 ELSE
384 IARR = JOLD
385 ISEND = -JOLD
386 JSEND = IOLD
387 ENDIF
388 ISTEP = abs( STEP(IARR) )
389 CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE,
390 & PROCNODE_STEPS(ISTEP), KEEP(199) )
391 I_AM_CAND_LOC = .FALSE.
392 T4_MASTER_CONCERNED = .FALSE.
393 T4MASTER = -9999
394.EQ. IF ( TYPE_NODE 1 ) THEN
395.eq. IF ( KEEP(46) 0 ) THEN
396 DEST = MASTER_NODE + 1
397 ELSE
398 DEST = MASTER_NODE
399 END IF
400.EQ. ELSE IF ( TYPE_NODE 2 ) THEN
401.LT. IF ( ISEND 0 ) THEN
402 DEST = -1
403 ELSE
404.eq. IF ( KEEP( 46 ) 0 ) THEN
405 DEST = MASTER_NODE + 1
406 ELSE
407 DEST = MASTER_NODE
408 END IF
409 END IF
410 INIV2 = ISTEP_TO_INIV2(ISTEP)
411 IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2)
412.GT. IF ( KEEP(79) 0) THEN
413 TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP),
414 & KEEP(199) )
415.EQ..OR..EQ. IF ( (TYPESPLIT5)(TYPESPLIT6)) THEN
416 T4_MASTER_CONCERNED = .TRUE.
417 T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2)
418.eq. IF ( KEEP(46) 0 ) THEN
419 T4MASTER=T4MASTER+1
420 ENDIF
421 ENDIF
422 ENDIF
423 ELSE
424 ARROW_ROOT = ARROW_ROOT + 1
425 IF (EARLYT3ROOTINS) THEN
426.LT. IF ( ISEND 0 ) THEN
427 IPOSROOT = RG2L(JSEND)
428 JPOSROOT = RG2L(IARR)
429 ELSE
430 IPOSROOT = RG2L( IARR )
431 JPOSROOT = RG2L( JSEND )
432 END IF
433 IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW )
434 JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL )
435.eq. IF ( KEEP( 46 ) 0 ) THEN
436 DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1
437 ELSE
438 DEST = IROW_GRID * root%NPCOL + JCOL_GRID
439 END IF
440 ELSE
441 DEST = -2
442 ENDIF
443 END IF
444 IF (LSCAL) THEN
445 VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD)
446 ELSE
447 VAL = ASPK(K)
448 ENDIF
449.eq. IF ( DEST 0
450.or. &
451.eq..and..eq..AND. & ( DEST -1 KEEP( 46 ) 1
452.OR..EQ. & ( I_AM_CAND_LOC MASTER_NODE 0 ) )
453.or. &
454.EQ. & ( T4MASTER0 )
455.or. &
456.EQ..AND..EQ. & ( DEST -2 KEEP( 46 ) 1 )
457 & ) THEN
458 IARR = ISEND
459 JARR = JSEND
460.eq..AND. IF ( TYPE_NODE 3 EARLYT3ROOTINS ) THEN
461.EQ..AND. IF ( IROW_GRID root%MYROW
462.EQ. & JCOL_GRID root%MYCOL ) THEN
463 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) /
464 & ( root%MBLOCK * root%NPROW ) )
465 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1
466 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) /
467 & ( root%NBLOCK * root%NPCOL ) )
468 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1
469 IF (KEEP(60)==0) THEN
470 A( PTR_ROOT
471 & + int(JLOCROOT - 1,8) * int(LOCAL_M,8)
472 & + int(ILOCROOT - 1,8) )
473 & = A( PTR_ROOT
474 & + int(JLOCROOT - 1,8) * int(LOCAL_M,8)
475 & + int(ILOCROOT - 1,8) )
476 & + VAL
477 ELSE
478 root%SCHUR_POINTER( int(JLOCROOT - 1,8)
479 & * int(root%SCHUR_LLD,8)
480 & + int(ILOCROOT,8) )
481 & = root%SCHUR_POINTER( int(JLOCROOT - 1,8)
482 & * int(root%SCHUR_LLD,8)
483 & + int(ILOCROOT,8))
484 & + VAL
485 ENDIF
486 ELSE
487 WRITE(*,*) MYID,':internal error: root arrowhead '
488 WRITE(*,*) MYID,':is not belonging to me. iarr,jarr='
489 & ,IARR,JARR
490 CALL MUMPS_ABORT()
491 END IF
492.GE. ELSE IF ( IARR 0 ) THEN
493.eq. IF ( IARR JARR ) THEN
494 IA = PTRARW( IARR )
495 DBLARR( IA ) = DBLARR( IA ) + VAL
496 ELSE
497 IS1 = PTRAIW(IARR)
498 ISHIFT = int(INTARR(IS1) + IW4(IARR,2),8)
499 IW4(IARR,2) = IW4(IARR,2) - 1
500 INTARR(IS1 + ISHIFT + 2_8) = JARR
501 DBLARR(PTRARW(IARR)+ISHIFT) = VAL
502 END IF
503 ELSE
504 IARR = -IARR
505 ISHIFT = int(PTRAIW(IARR)+IW4(IARR,1)+2,8)
506 INTARR(ISHIFT) = JARR
507 IAS = PTRARW(IARR)+int(IW4(IARR,1),8)
508 IW4(IARR,1) = IW4(IARR,1) - 1
509 DBLARR(IAS) = VAL
510.EQ..AND. IF ( IW4(IARR,1) 0
511 & STEP( IARR) > 0 ) THEN
512 IF ( MASTER_NODE == MYID) THEN
513 TAILLE = INTARR( PTRAIW(IARR) )
514 CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM,
515 & INTARR( PTRAIW(IARR) + 3 ),
516 & DBLARR( PTRARW(IARR) + 1 ),
517 & TAILLE, 1, TAILLE )
518 END IF
519 END IF
520 END IF
521 END IF
522.EQ. IF ( DEST -1 ) THEN
523 INIV2 = ISTEP_TO_INIV2(ISTEP)
524 NCAND = CANDIDATES(SLAVEF+1,INIV2)
525.GT. IF (KEEP(79)0) THEN
526 DO I=1, SLAVEF
527 DEST=CANDIDATES(I,INIV2)
528.EQ..AND..GE. IF (KEEP(46)0(DEST0)) DEST=DEST+1
529.LT. IF (DEST0) EXIT
530.EQ. IF (INCAND+1) CYCLE
531.NE. IF (DEST0) THEN
532 ISEND_SHR=ISEND; JSEND_SHR=JSEND
533 VAL_SHR=VAL; DEST_SHR=DEST
534 CALL DMUMPS_ARROW_FILL_SEND_BUF()
535 ENDIF
536 ENDDO
537 ELSE
538 DO I=1, NCAND
539 DEST=CANDIDATES(I,INIV2)
540.EQ. IF (KEEP(46)0) DEST=DEST+1
541.NE. IF (DEST0) THEN
542 ISEND_SHR=ISEND; JSEND_SHR=JSEND
543 VAL_SHR=VAL; DEST_SHR=DEST
544 CALL DMUMPS_ARROW_FILL_SEND_BUF()
545 ENDIF
546 ENDDO
547 ENDIF
548 DEST = MASTER_NODE
549.EQ. IF (KEEP(46)0) DEST=DEST+1
550.NE. IF ( DEST 0 ) THEN
551 ISEND_SHR=ISEND; JSEND_SHR=JSEND
552 VAL_SHR=VAL; DEST_SHR=DEST
553 CALL DMUMPS_ARROW_FILL_SEND_BUF()
554 ENDIF
555.AND..GT. IF ((T4_MASTER_CONCERNED)(T4MASTER0)) THEN
556 ISEND_SHR=ISEND; JSEND_SHR=JSEND
557 VAL_SHR=VAL; DEST_SHR=T4MASTER
558 CALL DMUMPS_ARROW_FILL_SEND_BUF()
559 ENDIF
560.GT. ELSE IF ( DEST 0 ) THEN
561 ISEND_SHR=ISEND; JSEND_SHR=JSEND
562 VAL_SHR=VAL; DEST_SHR=DEST
563 CALL DMUMPS_ARROW_FILL_SEND_BUF()
564.GT. IF ( T4MASTER0 ) THEN
565 ISEND_SHR=ISEND; JSEND_SHR=JSEND
566 VAL_SHR=VAL; DEST_SHR=T4MASTER
567 CALL DMUMPS_ARROW_FILL_SEND_BUF()
568 ENDIF
569.GT. ELSE IF ( T4MASTER0 ) THEN
570 ISEND_SHR=ISEND; JSEND_SHR=JSEND
571 VAL_SHR=VAL; DEST_SHR=T4MASTER
572 CALL DMUMPS_ARROW_FILL_SEND_BUF()
573.EQ. ELSE IF ( DEST -2 ) THEN
574 DO I = 0, SLAVEF-1
575 DEST = I
576.EQ. IF (KEEP(46) 0) DEST = DEST + 1
577.NE. IF (DEST 0) THEN
578 ISEND_SHR=ISEND; JSEND_SHR=JSEND
579 VAL_SHR=VAL; DEST_SHR=DEST
580 CALL DMUMPS_ARROW_FILL_SEND_BUF()
581 ENDIF
582 ENDDO
583 ENDIF
584 ENDIF
585 ENDDO
586 ENDIF
587!$OMP END PARALLEL
588 KEEP(49) = ARROW_ROOT
589.GT. IF (NBUFS0) THEN
590 CALL DMUMPS_ARROW_FINISH_SEND_BUF(
591 & BUFI, BUFR, NBRECORDS, NBUFS,
592 & LP, COMM, KEEP( 46 ) )
593 ENDIF
594.NE. IF ( KEEP( 46 ) 0 ) DEALLOCATE( IW4 )
595.GT. IF (NBUFS0) THEN
596 DEALLOCATE( BUFI )
597 DEALLOCATE( BUFR )
598 ENDIF
599 RETURN
600 CONTAINS
601 SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF()
602 IMPLICIT NONE
603 INCLUDE 'mpif.h'
604 INCLUDE 'mumps_tags.h'
605 INTEGER IERR
606 INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ
607.GT. IF (BUFI(1,DEST_SHR)+1NBRECORDS) THEN
608 TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1
609 TAILLE_SENDR = BUFI(1,DEST_SHR)
610 CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI,
611 & MPI_INTEGER,
612 & DEST_SHR, ARROWHEAD, COMM, IERR )
613 CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR,
614 & MPI_DOUBLE_PRECISION, DEST_SHR,
615 & ARROWHEAD, COMM, IERR )
616 BUFI(1,DEST_SHR) = 0
617 ENDIF
618 IREQ = BUFI(1,DEST_SHR) + 1
619 BUFI(1,DEST_SHR) = IREQ
620 BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR
621 BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR
622 BUFR( IREQ, DEST_SHR ) = VAL_SHR
623 RETURN
624 END SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF
625 END SUBROUTINE DMUMPS_FACTO_SEND_ARROWHEADS
626 SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF_ELT(
627 & ISEND_SHR, JSEND_SHR, VAL_SHR,
628 & DEST_SHR, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM )
629 IMPLICIT NONE
630 INTEGER, INTENT(in) :: ISEND_SHR, JSEND_SHR
631 DOUBLE PRECISION, INTENT(in) :: VAL_SHR
632 INTEGER :: DEST_SHR, NBRECORDS, NBUFS, LP, COMM
633 INTEGER :: BUFI( NBRECORDS*2+1, NBUFS )
634 DOUBLE PRECISION :: BUFR( NBRECORDS, NBUFS )
635 INCLUDE 'mpif.h'
636 INCLUDE 'mumps_tags.h'
637 INTEGER IERR
638 INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ
639.GT. IF (BUFI(1,DEST_SHR)+1NBRECORDS) THEN
640 TAILLE_SENDI = BUFI(1,DEST_SHR) * 2 + 1
641 TAILLE_SENDR = BUFI(1,DEST_SHR)
642 CALL MPI_SEND(BUFI(1,DEST_SHR),TAILLE_SENDI,
643 & MPI_INTEGER,
644 & DEST_SHR, ARROWHEAD, COMM, IERR )
645 CALL MPI_SEND( BUFR(1,DEST_SHR), TAILLE_SENDR,
646 & MPI_DOUBLE_PRECISION, DEST_SHR,
647 & ARROWHEAD, COMM, IERR )
648 BUFI(1,DEST_SHR) = 0
649 ENDIF
650 IREQ = BUFI(1,DEST_SHR) + 1
651 BUFI(1,DEST_SHR) = IREQ
652 BUFI( IREQ * 2, DEST_SHR ) = ISEND_SHR
653 BUFI( IREQ * 2 + 1, DEST_SHR ) = JSEND_SHR
654 BUFR( IREQ, DEST_SHR ) = VAL_SHR
655 RETURN
656 END SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF_ELT
657 SUBROUTINE DMUMPS_ARROW_FINISH_SEND_BUF(
658 & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM,
659 & TYPE_PARALL )
660 IMPLICIT NONE
661 INTEGER NBUFS, NBRECORDS, TYPE_PARALL
662 INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS )
663 DOUBLE PRECISION BUFR( NBRECORDS, NBUFS )
664 INTEGER COMM
665 INTEGER LP
666 INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR
667 INCLUDE 'mpif.h'
668 INCLUDE 'mumps_tags.h'
669 DO ISLAVE = 1,NBUFS
670 TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1
671 TAILLE_SENDR = BUFI(1,ISLAVE)
672 BUFI(1,ISLAVE) = - BUFI(1,ISLAVE)
673 CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI,
674 & MPI_INTEGER,
675 & ISLAVE, ARROWHEAD, COMM, IERR )
676.NE. IF ( TAILLE_SENDR 0 ) THEN
677 CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR,
678 & MPI_DOUBLE_PRECISION, ISLAVE,
679 & ARROWHEAD, COMM, IERR )
680 END IF
681 ENDDO
682 RETURN
683 END SUBROUTINE DMUMPS_ARROW_FINISH_SEND_BUF
684 RECURSIVE SUBROUTINE DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM,
685 & INTLIST, DBLLIST, TAILLE, LO, HI )
686 IMPLICIT NONE
687 INTEGER N, TAILLE
688 INTEGER PERM( N )
689 INTEGER INTLIST( TAILLE )
690 DOUBLE PRECISION DBLLIST( TAILLE )
691 INTEGER LO, HI
692 INTEGER I,J
693 INTEGER ISWAP, PIVOT
694 DOUBLE PRECISION dswap
695 I = LO
696 J = HI
697 PIVOT = PERM(INTLIST((I+J)/2))
698 10 IF (PERM(INTLIST(I)) < PIVOT) THEN
699 I=I+1
700 GOTO 10
701 ENDIF
702 20 IF (PERM(INTLIST(J)) > PIVOT) THEN
703 J=J-1
704 GOTO 20
705 ENDIF
706 IF (I < J) THEN
707 ISWAP = INTLIST(I)
708 INTLIST(I) = INTLIST(J)
709 INTLIST(J)=ISWAP
710 dswap = DBLLIST(I)
711 DBLLIST(I) = DBLLIST(J)
712 DBLLIST(J) = dswap
713 ENDIF
714 IF ( I <= J) THEN
715 I = I+1
716 J = J-1
717 ENDIF
718 IF ( I <= J ) GOTO 10
719 IF ( LO < J ) CALL DMUMPS_QUICK_SORT_ARROWHEADS(N, PERM,
720 & INTLIST, DBLLIST, TAILLE, LO, J)
721 IF ( I < HI ) CALL DMUMPS_QUICK_SORT_ARROWHEADS(N, PERM,
722 & INTLIST, DBLLIST, TAILLE, I, HI)
723 RETURN
724 END SUBROUTINE DMUMPS_QUICK_SORT_ARROWHEADS
725 SUBROUTINE DMUMPS_FACTO_RECV_ARROWHD2( N,
726 & DBLARR, LDBLARR, INTARR, LINTARR, PTRAIW, PTRARW,
727 & KEEP, KEEP8, MYID, COMM, NBRECORDS,
728 & A, LA, root,
729 & PROCNODE_STEPS,
730 & SLAVEF, PERM, FRERE_STEPS, STEP, INFO1, INFO2
731 & )
732 USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC
733 IMPLICIT NONE
734 INTEGER N, MYID, COMM
735 INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR
736 INTEGER INTARR(LINTARR)
737 INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW(N)
738 INTEGER KEEP(500)
739 INTEGER(8) KEEP8(150)
740 INTEGER(8), intent(IN) :: LA
741 INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N )
742 INTEGER SLAVEF, NBRECORDS
743 DOUBLE PRECISION A( LA )
744 INTEGER INFO1, INFO2
745 DOUBLE PRECISION DBLARR(LDBLARR)
746 INTEGER FRERE_STEPS( KEEP(28) ), STEP(N)
747 TYPE (DMUMPS_ROOT_STRUC) :: root
748 INTEGER, POINTER, DIMENSION(:) :: BUFI
749 DOUBLE PRECISION, POINTER, DIMENSION(:) :: BUFR
750 INTEGER, POINTER, DIMENSION(:,:) :: IW4
751 LOGICAL :: EARLYT3ROOTINS
752 LOGICAL FINI
753 INTEGER IREC, NB_REC, IARR, JARR, I, allocok
754 INTEGER(8) :: I18, IA8, IS18, IIW8, IS8, IAS8
755 INTEGER ISHIFT
756 INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT,
757 & IPOSROOT, JPOSROOT, TAILLE,
758 & IPROC
759 INTEGER(8) :: PTR_ROOT
760 INTEGER ARROW_ROOT, TYPE_PARALL
761 INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE
762 EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE
763 DOUBLE PRECISION VAL
764 DOUBLE PRECISION ZERO
765 PARAMETER( ZERO = 0.0D0 )
766 INCLUDE 'mpif.h'
767 INCLUDE 'mumps_tags.h'
768 INTEGER MASTER
769 PARAMETER(MASTER=0)
770 INTEGER :: IERR
771 INTEGER :: STATUS(MPI_STATUS_SIZE)
772 INTEGER numroc
773 EXTERNAL numroc
774 TYPE_PARALL = KEEP(46)
775 ARROW_ROOT=0
776.EQ. EARLYT3ROOTINS = KEEP(200) 0
777.OR..LT..AND..EQ. & (KEEP(200) 0 KEEP(400) 0)
778 ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok )
779.GT. IF ( allocok 0 ) THEN
780 INFO1 = -13
781 INFO2 = NBRECORDS * 2 + 1
782 WRITE(*,*) MYID,': could not allocate bufi: goto 500'
783 GOTO 500
784 END IF
785 ALLOCATE( BUFR( NBRECORDS ) , stat = allocok )
786.GT. IF ( allocok 0 ) THEN
787 INFO1 = -13
788 INFO2 = NBRECORDS
789 WRITE(*,*) MYID,': could not allocate bufr: goto 500'
790 GOTO 500
791 END IF
792 ALLOCATE( IW4(N,2), stat = allocok )
793.GT. IF ( allocok 0 ) THEN
794 INFO1 = -13
795 INFO2 = 2 * N
796 WRITE(*,*) MYID,': could not allocate iw4: goto 500'
797 GOTO 500
798 END IF
799.NE..AND. IF ( KEEP(38)0 EARLYT3ROOTINS ) THEN
800 CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA)
801 CALL DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA)
802 ELSE
803 LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8
804 END IF
805 FINI = .FALSE.
806#if defined(__ve__)
807!NEC$ IVDEP
808#endif
809 DO I=1,N
810 I18 = PTRAIW(I)
811 IA8 = PTRARW(I)
812.GT. IF (IA80_8) THEN
813 DBLARR(IA8) = ZERO
814 IW4(I,1) = INTARR(I18)
815 IW4(I,2) = -INTARR(I18+1_8)
816 INTARR(I18+2)=I
817 ENDIF
818 ENDDO
819.NOT. DO WHILE (FINI)
820 CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1,
821 & MPI_INTEGER, MASTER,
822 & ARROWHEAD,
823 & COMM, STATUS, IERR )
824 NB_REC = BUFI(1)
825.LE. IF (NB_REC0) THEN
826 FINI = .TRUE.
827 NB_REC = -NB_REC
828 ENDIF
829.EQ. IF (NB_REC0) EXIT
830 CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_DOUBLE_PRECISION,
831 & MASTER, ARROWHEAD,
832 & COMM, STATUS, IERR )
833 DO IREC=1, NB_REC
834 IARR = BUFI( IREC * 2 )
835 JARR = BUFI( IREC * 2 + 1 )
836 VAL = BUFR( IREC )
837 IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))),
838.eq. & KEEP(199) ) 3
839.AND. & EARLYT3ROOTINS ) THEN
840.GT. IF ( IARR 0 ) THEN
841 IPOSROOT = root%RG2L_ROW( IARR )
842 JPOSROOT = root%RG2L_COL( JARR )
843 ELSE
844 IPOSROOT = root%RG2L_ROW( JARR )
845 JPOSROOT = root%RG2L_COL( -IARR )
846 END IF
847 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) /
848 & ( root%MBLOCK * root%NPROW ) )
849 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1
850 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) /
851 & ( root%NBLOCK * root%NPCOL ) )
852 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1
853 IF (KEEP(60)==0) THEN
854 A( PTR_ROOT + int(JLOCROOT - 1,8) * int(LOCAL_M,8)
855 & + int(ILOCROOT - 1,8) )
856 & = A( PTR_ROOT + int(JLOCROOT - 1,8)
857 & * int(LOCAL_M,8)
858 & + int(ILOCROOT - 1,8))
859 & + VAL
860 ELSE
861 root%SCHUR_POINTER( int(JLOCROOT-1,8)
862 & * int(root%SCHUR_LLD,8)
863 & + int(ILOCROOT,8) )
864 & = root%SCHUR_POINTER( int(JLOCROOT - 1,8)
865 & * int(root%SCHUR_LLD,8)
866 & + int(ILOCROOT,8))
867 & + VAL
868 ENDIF
869.GE. ELSE IF (IARR0) THEN
870.EQ. IF (IARRJARR) THEN
871 IA8 = PTRARW(IARR)
872 DBLARR(IA8) = DBLARR(IA8) + VAL
873 ELSE
874 IS18 = PTRAIW(IARR)
875 ISHIFT = INTARR(IS18) + IW4(IARR,2)
876 IW4(IARR,2) = IW4(IARR,2) - 1
877 IIW8 = IS18 + ISHIFT + 2
878 INTARR(IIW8) = JARR
879 IS8 = PTRARW(IARR)
880 IAS8 = IS8 + ISHIFT
881 DBLARR(IAS8) = VAL
882 ENDIF
883 ELSE
884 IARR = -IARR
885 IS8 = PTRAIW(IARR)+IW4(IARR,1)+2
886 INTARR(IS8) = JARR
887 IAS8 = PTRARW(IARR)+IW4(IARR,1)
888 IW4(IARR,1) = IW4(IARR,1) - 1
889 DBLARR(IAS8) = VAL
890.EQ. IF ( IW4(IARR,1) 0
891.AND. & STEP(IARR) > 0 ) THEN
892 IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)),
893 & KEEP(199) )
894.eq. IF ( TYPE_PARALL 0 ) THEN
895 IPROC = IPROC + 1
896 END IF
897.EQ. IF (IPROC MYID) THEN
898 TAILLE = INTARR( PTRAIW(IARR) )
899 CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM,
900 & INTARR( PTRAIW(IARR) + 3 ),
901 & DBLARR( PTRARW(IARR) + 1 ),
902 & TAILLE, 1, TAILLE )
903 END IF
904 END IF
905 ENDIF
906 ENDDO
907 END DO
908 DEALLOCATE( BUFI )
909 DEALLOCATE( BUFR )
910 DEALLOCATE( IW4 )
911 500 CONTINUE
912 KEEP(49) = ARROW_ROOT
913 RETURN
914 END SUBROUTINE DMUMPS_FACTO_RECV_ARROWHD2
915 SUBROUTINE DMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP)
916!$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS
917 IMPLICIT NONE
918 INTEGER, INTENT(IN) :: LLD, M, N
919 DOUBLE PRECISION :: A(int(LLD,8)*int(N-1,8)+int(M,8))
920 INTEGER :: KEEP(500)
921 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0
922 INTEGER I, J
923!$ INTEGER :: NOMP
924 INTEGER(8) :: I8, LA
925!$ NOMP = OMP_GET_MAX_THREADS()
926.EQ. IF (LLD M) THEN
927 LA=int(LLD,8)*int(N-1,8)+int(M,8)
928!$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361))
929.AND..GT.!$OMP& IF ( LA > int(KEEP(361),8) NOMP 1)
930 DO I8=1, LA
931 A(I8) = ZERO
932 ENDDO
933!$OMP END PARALLEL DO
934 ELSE
935!$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2)
936!$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8)
937.GT..AND..GT.!$OMP& KEEP(361) NOMP 1)
938 DO I = 1, N
939 DO J = 1, M
940 A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO
941 ENDDO
942 ENDDO
943!$OMP END PARALLEL DO
944 ENDIF
945 RETURN
946 END SUBROUTINE DMUMPS_SET_TO_ZERO
947 SUBROUTINE DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA)
948 USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC
949 IMPLICIT NONE
950 INTEGER(8), INTENT(IN) :: LA
951 DOUBLE PRECISION, INTENT(INOUT) :: A(LA)
952 INTEGER :: KEEP(500)
953 TYPE (DMUMPS_ROOT_STRUC) :: root
954 INTEGER :: LOCAL_M, LOCAL_N
955 INTEGER(8) :: PTR_ROOT
956 IF (KEEP(60)==0) THEN
957 CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA)
958.GT. IF (LOCAL_N 0) THEN
959 CALL DMUMPS_SET_TO_ZERO(A(PTR_ROOT),
960 & LOCAL_M, LOCAL_M, LOCAL_N, KEEP)
961 ENDIF
962 ELSE IF (root%yes) THEN
963 CALL DMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1),
964 & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC,
965 & KEEP)
966 ENDIF
967 RETURN
968 END SUBROUTINE DMUMPS_SET_ROOT_TO_ZERO
969 SUBROUTINE DMUMPS_GET_ROOT_INFO(root,
970 & LOCAL_M, LOCAL_N, PTR_ROOT, LA)
971 USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC
972 IMPLICIT NONE
973 TYPE (DMUMPS_ROOT_STRUC), INTENT(IN) :: root
974 INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N
975 INTEGER(8), INTENT(OUT) :: PTR_ROOT
976 INTEGER(8), INTENT(IN) :: LA
977 INTEGER, EXTERNAL :: numroc
978 LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK,
979 & root%MYROW, 0, root%NPROW )
980 LOCAL_M = max( 1, LOCAL_M )
981 LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK,
982 & root%MYCOL, 0, root%NPCOL )
983 PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8
984 RETURN
985 END SUBROUTINE DMUMPS_GET_ROOT_INFO
dmumps_ana_dist_arrowheads
subroutine dmumps_ana_dist_arrowheads(myid, slavef, n, procnode, step, ptraiw, ptrarw, istep_to_iniv2, i_am_cand, keep, keep8, icntl, id)
Definition darrowheads.F:18
dmumps_struc_def
Definition dmumps_struc_def.F:14
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865