OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ana_blk.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 mumps_ab_free_lmat ( LMAT )
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
30 END SUBROUTINE mumps_ab_free_lmat
31 SUBROUTINE mumps_ab_free_gcomp ( GCOMP )
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
44 END SUBROUTINE mumps_ab_free_gcomp
45 SUBROUTINE mumps_ab_compute_sizeofblock (
46 & NBLK, NDOF, BLKPTR, BLKVAR,
47 & SIZEOFBLOCKS, DOF2BLOCK )
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
61 END SUBROUTINE mumps_ab_compute_sizeofblock
62 SUBROUTINE mumps_ab_coord_to_lmat ( MYID,
63 & NBLK, NDOF, NNZ, IRN, JCN,
64 & DOF2BLOCK,
65 & IFLAG, IERROR, LP, LPOK,
66 & LMAT)
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
150 END SUBROUTINE mumps_ab_coord_to_lmat
151 SUBROUTINE mumps_ab_localclean_lmat ( MYID,
152 & NBLK, LMAT, FLAG, IFLAG, IERROR, LP, LPOK
153 & )
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
207 END SUBROUTINE mumps_ab_localclean_lmat
208 SUBROUTINE mumps_ab_lmat_to_lumat(
209 & LMAT, LUMAT, INFO, ICNTL )
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
268 END SUBROUTINE mumps_ab_lmat_to_lumat
269 SUBROUTINE mumps_ab_print_lmatrix (LMAT, MYID, LP)
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
287 END SUBROUTINE mumps_ab_print_lmatrix
288 SUBROUTINE mumps_ab_lmat_to_clean_g( MYID, UNFOLD,
289 & READY_FOR_ANA_F,
290 & LMAT, GCOMP, INFO, ICNTL )
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
504 END SUBROUTINE mumps_ab_lmat_to_clean_g
505 SUBROUTINE mumps_ab_col_distribution ( OPTION,
506 & INFO, ICNTL, COMM, NBLK, MYID, NPROCS,
507 & LMAT, MAPCOL )
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
557 END SUBROUTINE mumps_ab_col_distribution
558 SUBROUTINE mumps_ab_compute_mapcol (OPTION, INFO, ICNTL,
559 & MYID, NNZ, NZ_ROW, SIZE_NZROW, NBLK, NPROCS, MAPCOL )
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
629 END SUBROUTINE mumps_ab_compute_mapcol
630 SUBROUTINE mumps_ab_build_dclean_lumatrix (
631 & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS,
632 & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS,
633 & LMAT, MAPCOL, SIZEMAPCOL,
634 & STEP, SIZESTEP,
635 & LUMAT)
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
783 END SUBROUTINE mumps_ab_build_dclean_lumatrix
784 SUBROUTINE mumps_inialize_redist_lumat (
785 & INFO, ICNTL, KEEP, COMM, MYID, NBLK,
786 & LUMAT, PROCNODE_STEPS, NSTEPS, MAPCOL,
787 & LUMAT_REMAP, NBRECORDS, STEP
788 & )
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
887 END SUBROUTINE mumps_inialize_redist_lumat
888 SUBROUTINE mumps_ab_dcoord_to_dcompg (
889 & MYID, NPROCS, COMM,
890 & NBLK, NDOF, NNZ,
891 & IRN, JCN, DOF2BLOCK,
892 & ICNTL, INFO, KEEP,
893 & LUMAT, GCOMP, READY_FOR_ANA_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
985 END SUBROUTINE mumps_ab_dcoord_to_dcompg
986 SUBROUTINE mumps_ab_dcoord_to_dtree_lumat (
987 & MYID, NPROCS, COMM,
988 & NBLK, NDOF, NNZ,
989 & IRN, JCN,
990 & PROCNODE_STEPS, NSTEPS, STEP,
991 & ICNTL, INFO, KEEP,
992 & MAPCOL, LUMAT)
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)
1074 END SUBROUTINE mumps_ab_dcoord_to_dtree_lumat
1075 SUBROUTINE mumps_ab_dist_lmat_to_lumat (
1076 & UNFOLD,
1077 & MAPCOL_IN_NSTEPS,
1078 & INFO, ICNTL, COMM, MYID, NBLK, SLAVEF,
1079 & LMAT, MAPCOL, SIZEMAPCOL, STEP, SIZESTEP,
1080 & LUMAT, NBRECORDS, NSEND8, NLOCAL8
1081 & )
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
1283 END SUBROUTINE mumps_ab_dist_lmat_to_lumat
1284 SUBROUTINE mumps_ab_lmat_treat_recv_buf (
1285 & MYID, BUFI, NBRECORDS, LUMAT,
1286 & NBLK, PTLOC, END_MSG_2_RECV
1287 & )
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
1310 END SUBROUTINE mumps_ab_lmat_treat_recv_buf
1311 SUBROUTINE mumps_ab_lmat_fill_buffer (
1312 & DEST, ISEND, JSEND, NBLK,
1313 & BUFI, BUFRECI, PTLOC,
1314 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI,
1315 & SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV
1316 & )
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
1391 END SUBROUTINE mumps_ab_lmat_fill_buffer
1392 SUBROUTINE mumps_ab_gather_graph (
1393 & ICNTL, KEEP, COMM, MYID, NPROCS, INFO,
1394 & GCOMP_DIST, GCOMP)
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
1602 END SUBROUTINE mumps_ab_gather_graph
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
mumps_ab_dcoord_to_dtree_lumat
subroutine mumps_ab_dcoord_to_dtree_lumat(myid, nprocs, comm, nblk, ndof, nnz, irn, jcn, procnode_steps, nsteps, step, icntl, info, keep, mapcol, lumat)
Definition ana_blk.F:993
mumps_ab_print_lmatrix
subroutine mumps_ab_print_lmatrix(lmat, myid, lp)
Definition ana_blk.F:270
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_compute_sizeofblock
subroutine mumps_ab_compute_sizeofblock(nblk, ndof, blkptr, blkvar, sizeofblocks, dof2block)
Definition ana_blk.F:48
mumps_inialize_redist_lumat
subroutine mumps_inialize_redist_lumat(info, icntl, keep, comm, myid, nblk, lumat, procnode_steps, nsteps, mapcol, lumat_remap, nbrecords, step)
Definition ana_blk.F:789
mumps_ab_lmat_to_lumat
subroutine mumps_ab_lmat_to_lumat(lmat, lumat, info, icntl)
Definition ana_blk.F:210
mumps_ab_gather_graph
subroutine mumps_ab_gather_graph(icntl, keep, comm, myid, nprocs, info, gcomp_dist, gcomp)
Definition ana_blk.F:1395
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_free_gcomp
subroutine mumps_ab_free_gcomp(gcomp)
Definition ana_blk.F:32
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_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
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
mumps_ab_dcoord_to_dcompg
subroutine mumps_ab_dcoord_to_dcompg(myid, nprocs, comm, nblk, ndof, nnz, irn, jcn, dof2block, icntl, info, keep, lumat, gcomp, ready_for_ana_f)
Definition ana_blk.F:894
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
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
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
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_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
mpi_waitany
subroutine mpi_waitany(cnt, array_of_requests, index, status, ierr)
Definition mpi.f:549
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
mumps_ana_blk_m
Definition ana_blk_m.F:14
mumps_ana_blk_m::compact_graph_t
Definition ana_blk_m.F:24
mumps_ana_blk_m::lmatrix_t
Definition ana_blk_m.F:19
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865