OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zfac_scalings_simScale_util.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 zmumps_createpartvec(MYID, NUMPROCS, COMM,
15 & IRN_loc, JCN_loc, NZ_loc,
16 & IPARTVEC, ISZ, OSZ,
17 & IWRK, IWSZ)
18C
19 IMPLICIT NONE
20 EXTERNAL zmumps_bureduce
21 INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM
22 INTEGER(8), INTENT(IN) :: NZ_loc
23 INTEGER, INTENT(IN) :: IWSZ
24 INTEGER, INTENT(IN) :: ISZ, OSZ
25 INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc)
26C OUTPUT
27C IPARTVEC(I) = proc number with largest number of entries
28C in row/col I
29 INTEGER, INTENT(OUT) :: IPARTVEC(ISZ)
30C
31C INTERNAL WORKING ARRAY
32C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries
33C on my proc and in row/col I) for I=1,ISZ
34C (2*ISZ+1: 4*ISZ) is then set to
35C the processor with largest number of entries in its row/col
36C and its value (that is copied back into IPARTVEC(I)
37#if defined(WORKAROUNDINTELILP64MPI2INTEGER)
38 INTEGER(4), INTENT(OUT) :: IWRK(IWSZ)
39#else
40 INTEGER, INTENT(OUT) :: IWRK(IWSZ)
41#endif
42 include 'mpif.h'
43C
44C LOCAL VARS
45 INTEGER I
46 INTEGER(8) :: I8
47 INTEGER OP, IERROR
48 INTEGER IR, IC
49C
50 IF(numprocs.NE.1) THEN
51C CHECK done outsize
52C IF(IWSZ < 4*ISZ) THEN
53C CHECK ENDS
54 CALL mpi_op_create(zmumps_bureduce, .true., op, ierror)
55C PERFORM THE REDUCTION
56#if defined(WORKAROUNDINTELILP64MPI2INTEGER)
57 CALL zmumps_ibuinit(iwrk, 4*isz, int(isz,4))
58#else
59 CALL zmumps_ibuinit(iwrk, 4*isz, isz)
60#endif
61C WE FIRST ZERO OUT
62 DO i=1,isz
63 iwrk(2*i-1) = 0
64 iwrk(2*i) = myid
65 ENDDO
66 DO i8=1_8,nz_loc
67 ir = irn_loc(i8)
68 ic = jcn_loc(i8)
69 IF((ir.GE.1).AND.(ir.LE.isz).AND.
70 & (ic.GE.1).AND.(ic.LE.osz)) THEN
71 iwrk(2*ir-1) = iwrk(2*ir-1) + 1
72 ENDIF
73 ENDDO
74 CALL mpi_allreduce(iwrk(1), iwrk(1+2*isz), isz,
75 & mpi_2integer, op, comm, ierror)
76 DO i=1,isz
77 ipartvec(i) = iwrk(2*i+2*isz)
78 ENDDO
79C FREE THE OPERATOR
80 CALL mpi_op_free(op, ierror)
81 ELSE
82 DO i=1,isz
83 ipartvec(i) = 0
84 ENDDO
85 ENDIF
86 RETURN
87 END SUBROUTINE zmumps_createpartvec
88C
89C SEPARATOR: Another function begins
90C
91C
92 SUBROUTINE zmumps_findnummyrowcol(MYID, NUMPROCS, COMM,
93 & IRN_loc, JCN_loc, NZ_loc,
94 & ROWPARTVEC, COLPARTVEC, M, N,
95 & INUMMYR,
96 & INUMMYC,
97 & IWRK, IWSZ)
98 IMPLICIT NONE
99 INTEGER(8), INTENT(IN) :: NZ_loc
100 INTEGER, INTENT(IN) :: MYID, NUMPROCS, M, N, IWSZ
101 INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc)
102C [ROW/COL]PARTVEC(I) holds proc number with largest number of entries
103C in row/col I
104 INTEGER, INTENT(IN) :: ROWPARTVEC(M)
105 INTEGER, INTENT(IN) :: COLPARTVEC(N)
106 INTEGER, INTENT(IN) :: COMM
107C
108C OUTPUT PARAMETERS
109C INUMMYR < M and INUMMYC < N (CPA or <= ??)
110C INUMMYR holds the number of rows allocated to me
111C or non empty on my proc
112C INUMMYC idem with columns
113 INTEGER INUMMYR, INUMMYC
114C
115C INTERNAL working array
116 INTEGER IWRK(IWSZ)
117C
118C Local variables
119 INTEGER I, IR, IC
120 INTEGER(8) :: I8
121C check done outsize
122C IF(IWSZ < M) THEN ERROR
123C IF(IWSZ < N) THEN ERROR
124 inummyr = 0
125 inummyc = 0
126C MARK MY ROWS. FIRST COUNT,
127C IF DYNAMIC MEMORY ALLOCATIOn WILL USED
128C INUMMYR first counts number of rows affected to me
129C (that will be centralized on MYID)
130 DO i=1,m
131 iwrk(i) = 0
132 IF(rowpartvec(i).EQ.myid) THEN
133 iwrk(i)=1
134 inummyr = inummyr + 1
135 ENDIF
136 ENDDO
137 DO i8=1_8,nz_loc
138 ir = irn_loc(i8)
139 ic = jcn_loc(i8)
140 IF((ir.GE.1).AND.(ir.LE.m).AND.
141 & ((ic.GE.1).AND.(ic.LE.n)) ) THEN
142 IF(iwrk(ir) .EQ. 0) THEN
143 iwrk(ir)= 1
144 inummyr = inummyr + 1
145 ENDIF
146 ENDIF
147 ENDDO
148C DO THE SMAME THING FOR COLS
149 DO i=1,n
150 iwrk(i) = 0
151 IF(colpartvec(i).EQ.myid) THEN
152 iwrk(i)= 1
153 inummyc = inummyc + 1
154 ENDIF
155 ENDDO
156 DO i8=1_8,nz_loc
157 ic = jcn_loc(i8)
158 ir = irn_loc(i8)
159 IF((ir.GE.1).AND.(ir.LE.m).AND.
160 & ((ic.GE.1).AND.(ic.LE.n)) ) THEN
161 IF(iwrk(ic) .EQ. 0) THEN
162 iwrk(ic)= 1
163 inummyc = inummyc + 1
164 ENDIF
165 ENDIF
166 ENDDO
167C
168 RETURN
169 END SUBROUTINE zmumps_findnummyrowcol
170 SUBROUTINE zmumps_fillmyrowcolindices(MYID, NUMPROCS,COMM,
171 & IRN_loc, JCN_loc, NZ_loc,
172 & ROWPARTVEC, COLPARTVEC, M, N,
173 & MYROWINDICES, INUMMYR,
174 & MYCOLINDICES, INUMMYC,
175 & IWRK, IWSZ )
176 IMPLICIT NONE
177 INTEGER(8) :: NZ_loc
178 INTEGER MYID, NUMPROCS, M, N
179 INTEGER INUMMYR, INUMMYC, IWSZ
180 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
181 INTEGER ROWPARTVEC(M)
182 INTEGER COLPARTVEC(N)
183 INTEGER MYROWINDICES(INUMMYR)
184 INTEGER MYCOLINDICES(INUMMYC)
185 INTEGER IWRK(IWSZ)
186 INTEGER COMM
187C
188 INTEGER I, IR, IC, ITMP, MAXMN
189 INTEGER(8) :: I8
190C
191 maxmn = m
192 IF(n > maxmn) maxmn = n
193C check done outsize
194C IF(IWSZ < MAXMN) THEN ERROR
195C MARK MY ROWS.
196 DO i=1,m
197 iwrk(i) = 0
198 IF(rowpartvec(i).EQ.myid) iwrk(i)=1
199 ENDDO
200 DO i8=1,nz_loc
201 ir = irn_loc(i8)
202 ic = jcn_loc(i8)
203 IF((ir.GE.1).AND.(ir.LE.m).AND.
204 & ((ic.GE.1).AND.(ic.LE.n)) ) THEN
205 IF(iwrk(ir) .EQ. 0) iwrk(ir)= 1
206 ENDIF
207 ENDDO
208C PUT MY ROWS INTO MYROWINDICES
209 itmp = 1
210 DO i=1,m
211 IF(iwrk(i).EQ.1) THEN
212 myrowindices(itmp) = i
213 itmp = itmp + 1
214 ENDIF
215 ENDDO
216C
217C
218C DO THE SMAME THING FOR COLS
219 DO i=1,n
220 iwrk(i) = 0
221 IF(colpartvec(i).EQ.myid) iwrk(i)= 1
222 ENDDO
223 DO i8=1,nz_loc
224 ir = irn_loc(i8)
225 ic = jcn_loc(i8)
226 IF((ir.GE.1).AND.(ir.LE.m).AND.
227 & ((ic.GE.1).AND.(ic.LE.n)) ) THEN
228 IF(iwrk(ic) .EQ. 0) iwrk(ic)= 1
229 ENDIF
230 ENDDO
231C PUT MY ROWS INTO MYROWINDICES
232 itmp = 1
233 DO i=1,n
234 IF(iwrk(i).EQ.1) THEN
235 mycolindices(itmp) = i
236 itmp = itmp + 1
237 ENDIF
238 ENDDO
239C
240 RETURN
241 END SUBROUTINE zmumps_fillmyrowcolindices
242C
243C SEPARATOR: Another function begins
244C
245C
246 INTEGER FUNCTION zmumps_chk1loc(D, DSZ, INDX, INDXSZ, EPS)
247 IMPLICIT NONE
248 INTEGER dsz, indxsz
249 DOUBLE PRECISION d(dsz)
250 INTEGER indx(indxsz)
251 DOUBLE PRECISION eps
252C LOCAL VARS
253 INTEGER i, iid
254 DOUBLE PRECISION rone
255 PARAMETER(rone=1.0d0)
256 zmumps_chk1loc = 1
257 DO i=1, indxsz
258 iid = indx(i)
259 IF (.NOT.( (d(iid).LE.(rone+eps)).AND.
260 & ((rone-eps).LE.d(iid)) )) THEN
261 zmumps_chk1loc = 0
262 ENDIF
263 ENDDO
264 RETURN
265 END FUNCTION zmumps_chk1loc
266 INTEGER FUNCTION zmumps_chk1conv(D, DSZ, EPS)
267 IMPLICIT NONE
268 INTEGER dsz
269 DOUBLE PRECISION d(dsz)
270 DOUBLE PRECISION eps
271C LOCAL VARS
272 INTEGER i
273 DOUBLE PRECISION rone
274 parameter(rone=1.0d0)
275 zmumps_chk1conv = 1
276 DO i=1, dsz
277 IF (.NOT.( (d(i).LE.(rone+eps)).AND.
278 & ((rone-eps).LE.d(i)) )) THEN
279 zmumps_chk1conv = 0
280 ENDIF
281 ENDDO
282 RETURN
283 END FUNCTION zmumps_chk1conv
284C
285C SEPARATOR: Another function begins
286C
287 INTEGER FUNCTION zmumps_chkconvglo(DR, M, INDXR, INDXRSZ,
288 & DC, N, INDXC, INDXCSZ, EPS, COMM)
289 IMPLICIT NONE
290 include 'mpif.h'
291 INTEGER m, n, indxrsz, indxcsz
292 DOUBLE PRECISION dr(m), dc(n)
293 INTEGER indxr(indxrsz), indxc(indxcsz)
294 DOUBLE PRECISION eps
295 INTEGER comm
296 EXTERNAL zmumps_chk1loc
297 INTEGER zmumps_chk1loc
298 INTEGER glores, myresr, myresc, myres
299 INTEGER ierr
300 myresr = zmumps_chk1loc(dr, m, indxr, indxrsz, eps)
301 myresc = zmumps_chk1loc(dc, n, indxc, indxcsz, eps)
302 myres = myresr + myresc
303 CALL mpi_allreduce(myres, glores, 1, mpi_integer,
304 & mpi_sum, comm, ierr)
305 zmumps_chkconvglo = glores
306 RETURN
307 END FUNCTION zmumps_chkconvglo
308C
309C SEPARATOR: Another function begins
310C
311 DOUBLE PRECISION FUNCTION zmumps_errscaloc(D, TMPD, DSZ,
312 & INDX, INDXSZ)
313C THE VAR D IS NOT USED IN COMPUTATIONS.
314C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F
315 IMPLICIT NONE
316 INTEGER dsz, indxsz
317 DOUBLE PRECISION d(dsz)
318 DOUBLE PRECISION tmpd(dsz)
319 INTEGER INDX(indxsz)
320C LOCAL VARS
321 DOUBLE PRECISION rone
322 parameter(rone=1.0d0)
323 INTEGER i, iind
324 DOUBLE PRECISION errmax
325 INTRINSIC abs
326 errmax = -rone
327 DO i=1,indxsz
328 iind = indx(i)
329 IF(abs(rone-tmpd(iind)).GT.errmax) THEN
330 errmax = abs(rone-tmpd(iind))
331 ENDIF
332 ENDDO
333 zmumps_errscaloc = errmax
334 RETURN
335 END FUNCTION zmumps_errscaloc
336 DOUBLE PRECISION FUNCTION zmumps_errsca1(D, TMPD, DSZ)
337 IMPLICIT NONE
338 INTEGER dsz
339 DOUBLE PRECISION d(dsz)
340 DOUBLE PRECISION tmpd(dsz)
341C LOCAL VARS
342 DOUBLE PRECISION rone
343 parameter(rone=1.0d0)
344 INTEGER i
345 DOUBLE PRECISION errmax1
346 INTRINSIC abs
347 errmax1 = -rone
348 DO i=1,dsz
349 IF(abs(rone-tmpd(i)).GT.errmax1) THEN
350 errmax1 = abs(rone-tmpd(i))
351 ENDIF
352 ENDDO
353 zmumps_errsca1 = errmax1
354 RETURN
355 END FUNCTION zmumps_errsca1
356C
357C SEPARATOR: Another function begins
358C
359 SUBROUTINE zmumps_updatescale(D, TMPD, DSZ,
360 & INDX, INDXSZ)
361 IMPLICIT NONE
362 INTEGER DSZ, INDXSZ
363 DOUBLE PRECISION D(DSZ)
364 DOUBLE PRECISION TMPD(DSZ)
365 INTEGER INDX(INDXSZ)
366 INTRINSIC sqrt
367C LOCAL VARS
368 INTEGER I, IIND
369 DOUBLE PRECISION RZERO
370 parameter(rzero=0.0d0)
371 DO i=1,indxsz
372 iind = indx(i)
373 IF (tmpd(iind).NE.rzero) d(iind) = d(iind)/sqrt(tmpd(iind))
374 ENDDO
375 RETURN
376 END SUBROUTINE zmumps_updatescale
377 SUBROUTINE zmumps_upscale1(D, TMPD, DSZ)
378 IMPLICIT NONE
379 INTEGER DSZ
380 DOUBLE PRECISION D(DSZ)
381 DOUBLE PRECISION TMPD(DSZ)
382 INTRINSIC sqrt
383C LOCAL VARS
384 INTEGER I
385 DOUBLE PRECISION RZERO
386 parameter(rzero=0.0d0)
387 DO i=1,dsz
388 IF (tmpd(i) .NE. rzero) d(i) = d(i)/sqrt(tmpd(i))
389 ENDDO
390 RETURN
391 END SUBROUTINE zmumps_upscale1
392C
393C SEPARATOR: Another function begins
394C
395 SUBROUTINE zmumps_initreallst(D, DSZ, INDX, INDXSZ, VAL)
396 IMPLICIT NONE
397 INTEGER DSZ, INDXSZ
398 DOUBLE PRECISION D(DSZ)
399 INTEGER INDX(INDXSZ)
400 DOUBLE PRECISION VAL
401C LOCAL VARS
402 INTEGER I, IIND
403 DO i=1,indxsz
404 iind = indx(i)
405 d(iind) = val
406 ENDDO
407 RETURN
408 END SUBROUTINE zmumps_initreallst
409C
410C SEPARATOR: Another function begins
411C
412 SUBROUTINE zmumps_invlist(D, DSZ, INDX, INDXSZ)
413 IMPLICIT NONE
414 INTEGER DSZ, INDXSZ
415 DOUBLE PRECISION D(DSZ)
416 INTEGER INDX(INDXSZ)
417C LOCALS
418 INTEGER I, IIND
419 DO i=1,indxsz
420 iind = indx(i)
421 d(iind) = 1.0d0/d(iind)
422 ENDDO
423 RETURN
424 END SUBROUTINE zmumps_invlist
425C
426C SEPARATOR: Another function begins
427C
428 SUBROUTINE zmumps_initreal(D, DSZ, VAL)
429 IMPLICIT NONE
430 INTEGER DSZ
431 DOUBLE PRECISION D(DSZ)
432 DOUBLE PRECISION VAL
433C LOCAL VARS
434 INTEGER I
435 DO i=1,dsz
436 d(i) = val
437 ENDDO
438 RETURN
439 END SUBROUTINE zmumps_initreal
440C
441C SEPARATOR: Another function begins
442C
443 SUBROUTINE zmumps_zeroout(TMPD, TMPSZ, INDX, INDXSZ)
444 IMPLICIT NONE
445 INTEGER TMPSZ,INDXSZ
446 DOUBLE PRECISION TMPD(TMPSZ)
447 INTEGER INDX(INDXSZ)
448C LOCAL VAR
449 INTEGER I
450 DOUBLE PRECISION DZERO
451 parameter(dzero=0.0d0)
452 DO i=1,indxsz
453 tmpd(indx(i)) = dzero
454 ENDDO
455 RETURN
456 END SUBROUTINE zmumps_zeroout
457C
458C SEPARATOR: Another function begins
459C
460 SUBROUTINE zmumps_bureduce(INV, INOUTV, LEN, DTYPE)
461C
462C Like MPI_MINLOC operation (with ties broken sometimes with min
463C and sometimes with max)
464C The objective is find for each entry row/col
465C the processor with largest number of entries in its row/col
466C When 2 procs have the same number of entries in the row/col
467C then
468C if this number of entries is odd we take the proc with largest id
469C if this number of entries is even we take the proc with smallest id
470C
471 IMPLICIT NONE
472#if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE)
473 INTEGER(4) :: LEN
474 INTEGER(4) :: INV(2*LEN)
475 INTEGER(4) :: INOUTV(2*LEN)
476 INTEGER(4) :: DTYPE
477#else
478 INTEGER :: LEN
479 INTEGER :: INV(2*LEN)
480 INTEGER :: INOUTV(2*LEN)
481 INTEGER :: DTYPE
482#endif
483 INTEGER I
484#if defined(WORKAROUNDINTELILP64MPI2INTEGER) || defined(WORKAROUNDILP64MPICUSTOMREDUCE)
485 INTEGER(4) DIN, DINOUT, PIN, PINOUT
486#else
487 INTEGER DIN, DINOUT, PIN, PINOUT
488#endif
489 DO i=1,2*len-1,2
490 din = inv(i) ! nb of entries in row/col
491 pin = inv(i+1) ! proc number
492C DINOUT
493 dinout = inoutv(i)
494 pinout = inoutv(i+1)
495 IF (dinout < din) THEN
496 inoutv(i) = din
497 inoutv(i+1) = pin
498 ELSE IF (dinout == din) THEN
499C --INOUTV(I) = DIN
500C --even number I take smallest Process number (pin)
501 IF ((mod(dinout,2).EQ.0).AND.(pin<pinout)) THEN
502 inoutv(i+1) = pin
503 ELSE IF ((mod(dinout,2).EQ.1).AND.(pin>pinout)) THEN
504C --odd number I take largest Process number (pin)
505 inoutv(i+1) = pin
506 ENDIF
507 ENDIF
508 ENDDO
509 RETURN
510 END SUBROUTINE zmumps_bureduce
511C
512C SEPARATOR: Another function begins
513C
514 SUBROUTINE zmumps_ibuinit(IW, IWSZ, IVAL)
515 IMPLICIT NONE
516 INTEGER IWSZ
517#if defined(WORKAROUNDINTELILP64MPI2INTEGER)
518 INTEGER(4) IW(IWSZ)
519 INTEGER(4) IVAL
520#else
521 INTEGER IW(IWSZ)
522 INTEGER IVAL
523#endif
524 INTEGER I
525 DO i=1,iwsz
526 iw(i)=ival
527 ENDDO
528 RETURN
529 END SUBROUTINE zmumps_ibuinit
530C
531C SEPARATOR: Another function begins
532C
533C
534C SEPARATOR: Another function begins
535C
536 SUBROUTINE zmumps_numvolsndrcv(MYID, NUMPROCS, ISZ, IPARTVEC,
537 & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL,
538 & OSNDRCVNUM,OSNDRCVVOL,
539 & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM)
540 IMPLICIT NONE
541 INTEGER(8), INTENT(IN) :: NZ_loc
542 INTEGER, INTENT(IN) :: IWRKSZ
543 INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ
544 INTEGER, INTENT(IN) :: COMM
545C When INDX holds row indices O(ther)INDX hold col indices
546 INTEGER, INTENT(IN) :: INDX(NZ_loc)
547 INTEGER, INTENT(IN) :: OINDX(NZ_loc)
548C On entry IPARTVEC(I) holds proc number with largest number of entries
549C in row/col I
550 INTEGER, INTENT(IN) :: IPARTVEC(ISZ)
551C
552C OUTPUT PARAMETERS
553C SNDSZ (IPROC+1) is set to the number of rows (or col) that
554C MYID will have to send to IPROC
555C RCVSZ(IPROC+1) is set to the nb of row/cols that
556C MYID will receive from IPROC
557 INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS)
558 INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS)
559C OSNDRCVNUM is set to the total number of procs
560C destination of messages from MYID (< NUMPROCS)
561C ISNDRCVNUM is set to the total number procs
562C that will send messages to MYID (< NUMPROCS)
563C ISNDRCVVOL is set to the total number of row/col that
564C MYID will have to send to other procs
565C (bounded by N)
566C OSNDRCVVOL is set to the total number of row/col that
567C MYID will have to send to other procs
568C (bounded by N)
569C Knowing that for each row the process with the largest
570C number of entries will centralize all indices then
571C ISNDRCVVOL and OSNDRCVVOL are bounded by N
572 INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM
573 INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL
574C
575C INTERNAL WORKING ARRAY
576 INTEGER IWRK(IWRKSZ)
577 include 'mpif.h'
578C LOCAL VARS
579 INTEGER I
580 INTEGER(8) :: I8
581 INTEGER IIND, IIND2, PIND
582 INTEGER IERROR
583C check done outsize
584C IF(ISZ>IWRKSZ) THEN ERROR
585 DO I=1,numprocs
586 sndsz(i) = 0
587 rcvsz(i) = 0
588 ENDDO
589 DO i=1,iwrksz
590 iwrk(i) = 0
591 ENDDO
592C
593C set SNDSZ
594 DO i8=1,nz_loc
595 iind = indx(i8)
596 iind2 = oindx(i8)
597 IF((iind.GE.1).AND.(iind.LE.isz).AND.
598 & (iind2.GE.1).AND.(iind2.LE.osz))THEN
599 pind = ipartvec(iind)
600 IF(pind .NE. myid) THEN
601C MYID will send row/col IIND to proc PIND
602C (PIND has the largest nb of entries in row/con IIND
603 IF(iwrk(iind).EQ.0) THEN
604 iwrk(iind) = 1
605 sndsz(pind+1) = sndsz(pind+1)+1
606 ENDIF
607 ENDIF
608 ENDIF
609 ENDDO
610C
611C use SNDSZ to set RCVSZ
612 CALL mpi_alltoall(sndsz, 1, mpi_integer,
613 & rcvsz, 1, mpi_integer, comm, ierror)
614C
615C compute number of procs destinations of messages from MYID
616C number of row/col sent by MYID.
617 isndrcvnum = 0
618 isndrcvvol = 0
619 osndrcvnum = 0
620 osndrcvvol = 0
621 DO i=1, numprocs
622 IF(sndsz(i) > 0) osndrcvnum = osndrcvnum + 1
623 osndrcvvol = osndrcvvol + sndsz(i)
624 IF(rcvsz(i) > 0) isndrcvnum = isndrcvnum + 1
625 isndrcvvol = isndrcvvol + rcvsz(i)
626 ENDDO
627 RETURN
628 END SUBROUTINE zmumps_numvolsndrcv
629C
630C SEPARATOR: Another function begins
631C
632 SUBROUTINE zmumps_setupcomms(MYID, NUMPROCS, ISZ, IPARTVEC,
633 & NZ_loc, INDX, OSZ, OINDX,
634 & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA,
635 & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA,
636 & SNDSZ, RCVSZ, IWRK,
637 & ISTATUS, REQUESTS,
638 & ITAGCOMM, COMM )
639 IMPLICIT NONE
640 include 'mpif.h'
641 INTEGER(8) :: NZ_loc
642 INTEGER ISNDVOL, OSNDVOL
643 INTEGER MYID, NUMPROCS, ISZ, OSZ
644C ISZ is either M or N
645 INTEGER INDX(NZ_loc)
646 INTEGER OINDX(NZ_loc)
647C INDX is either IRN_loc or JCN_col
648 INTEGER IPARTVEC(ISZ)
649C IPARTVEC is either rowpartvec or colpartvec
650 INTEGER :: ISNDRCVNUM
651 INTEGER INGHBPRCS(ISNDRCVNUM)
652 INTEGER ISNDRCVIA(NUMPROCS+1)
653 INTEGER ISNDRCVJA(ISNDVOL)
654 INTEGER OSNDRCVNUM
655 INTEGER ONGHBPRCS(OSNDRCVNUM)
656 INTEGER OSNDRCVIA(NUMPROCS+1)
657 INTEGER OSNDRCVJA(OSNDVOL)
658 INTEGER SNDSZ(NUMPROCS)
659 INTEGER RCVSZ(NUMPROCS)
660 INTEGER IWRK(ISZ)
661 INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM)
662 INTEGER REQUESTS(ISNDRCVNUM)
663 INTEGER ITAGCOMM, COMM
664C LOCAL VARS
665 INTEGER I, IIND, IIND2, IPID, OFFS
666 INTEGER IWHERETO, POFFS, ITMP, IERROR
667 INTEGER(8) :: I8
668C COMPUATIONs START
669 DO i=1,isz
670 iwrk(i) = 0
671 ENDDO
672C INITIALIZE ONGHBPRCS using SNDSZ
673C INITIALIZE THE OSNDRCVIA using SNDSZ
674 offs = 1
675 poffs = 1
676 DO i=1,numprocs
677 osndrcvia(i) = offs + sndsz(i)
678 IF(sndsz(i) > 0) THEN
679 onghbprcs(poffs)=i
680 poffs = poffs + 1
681 ENDIF
682 offs = offs + sndsz(i)
683 ENDDO
684 osndrcvia(numprocs+1) = offs
685C CHECK STARTS
686C check done outsize
687C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR
688C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL)
689 DO i8=1,nz_loc
690 iind = indx(i8)
691 iind2 = oindx(i8)
692 IF((iind.GE.1).AND.(iind.LE.isz).AND.
693 & (iind2.GE.1).AND.(iind2.LE.osz) ) THEN
694 ipid=ipartvec(iind)
695 IF(ipid.NE.myid) THEN
696 IF(iwrk(iind).EQ.0) THEN
697 iwhereto = osndrcvia(ipid+1)-1
698 osndrcvia(ipid+1) = osndrcvia(ipid+1)-1
699 osndrcvja(iwhereto) = iind
700 iwrk(iind) = 1
701 ENDIF
702 ENDIF
703 ENDIF
704 ENDDO
705C FILLED UP, WHAT I WILL RECEIVE (My requests from others)
706C FILL UP ISNDRCVJA. It will be received to fill up
707 CALL mpi_barrier(comm,ierror)
708 offs = 1
709 poffs = 1
710 isndrcvia(1) = 1
711 DO i=2,numprocs+1
712 isndrcvia(i) = offs + rcvsz(i-1)
713 IF(rcvsz(i-1) > 0) THEN
714 inghbprcs(poffs)=i-1
715 poffs = poffs + 1
716 ENDIF
717 offs = offs + rcvsz(i-1)
718 ENDDO
719 CALL mpi_barrier(comm,ierror)
720 DO i=1, isndrcvnum
721 ipid = inghbprcs(i)
722 offs = isndrcvia(ipid)
723 itmp = isndrcvia(ipid+1) - isndrcvia(ipid)
724 CALL mpi_irecv(isndrcvja(offs), itmp, mpi_integer,ipid-1,
725 & itagcomm, comm, requests(i),ierror)
726 ENDDO
727 DO i=1,osndrcvnum
728 ipid = onghbprcs(i)
729 offs = osndrcvia(ipid)
730 itmp = osndrcvia(ipid+1)-osndrcvia(ipid)
731 CALL mpi_send(osndrcvja(offs), itmp, mpi_integer, ipid-1,
732 & itagcomm, comm,ierror)
733 ENDDO
734 IF(isndrcvnum > 0) THEN
735 CALL mpi_waitall(isndrcvnum, requests(1),istatus(1,1),ierror)
736 ENDIF
737 CALL mpi_barrier(comm,ierror)
738 RETURN
739 END SUBROUTINE zmumps_setupcomms
740C
741C SEPARATOR: Another function begins
742C
743 SUBROUTINE zmumps_docomminf(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM,
744 & ISNDRCVNUM, INGHBPRCS,
745 & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA,
746 & OSNDRCVNUM, ONGHBPRCS,
747 & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA,
748 & ISTATUS, REQUESTS,
749 & COMM)
750 IMPLICIT NONE
751 include 'mpif.h'
752 INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM
753 INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL
754 DOUBLE PRECISION TMPD(IDSZ)
755 INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM)
756 INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL)
757 DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL)
758 INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL)
759 DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL)
760 INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM))
761 INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM))
762 INTEGER COMM, IERROR
763C LOCAL VARS
764 INTEGER I, PID, OFFS, SZ, J, JS, JE, IID
765 DO i=1,isndrcvnum
766 pid = inghbprcs(i)
767 offs = isndrcvia(pid)
768 sz = isndrcvia(pid+1) - isndrcvia(pid)
769 CALL mpi_irecv(isndrcva(offs), sz,
770 & mpi_double_precision, pid-1,
771 & itagcomm,comm,requests(i), ierror)
772 ENDDO
773 DO i=1,osndrcvnum
774 pid = onghbprcs(i)
775 offs = osndrcvia(pid)
776 sz = osndrcvia(pid+1) - osndrcvia(pid)
777 js = osndrcvia(pid)
778 je = osndrcvia(pid+1) - 1
779 DO j=js, je
780 iid = osndrcvja(j)
781 osndrcva(j) = tmpd(iid)
782 ENDDO
783 CALL mpi_send(osndrcva(offs), sz, mpi_double_precision, pid-1,
784 & itagcomm, comm, ierror)
785 ENDDO
786 IF(isndrcvnum > 0) THEN
787 CALL mpi_waitall(isndrcvnum, requests(1),istatus(1,1),ierror)
788 ENDIF
789C FOLD INTO MY D
790 DO i=1,isndrcvnum
791 pid = inghbprcs(i)
792 js = isndrcvia(pid)
793 je = isndrcvia(pid+1)-1
794 DO j=js,je
795 iid = isndrcvja(j)
796 IF(tmpd(iid) < isndrcva(j)) tmpd(iid)= isndrcva(j)
797 ENDDO
798 ENDDO
799C COMMUNICATE THE UPDATED ONES
800 DO i=1,osndrcvnum
801 pid = onghbprcs(i)
802 offs = osndrcvia(pid)
803 sz = osndrcvia(pid+1) - osndrcvia(pid)
804 CALL mpi_irecv(osndrcva(offs), sz,
805 & mpi_double_precision, pid-1,
806 & itagcomm+1,comm,requests(i), ierror)
807 ENDDO
808 DO i=1,isndrcvnum
809 pid = inghbprcs(i)
810 offs = isndrcvia(pid)
811 sz = isndrcvia(pid+1)-isndrcvia(pid)
812 js = isndrcvia(pid)
813 je = isndrcvia(pid+1) -1
814 DO j=js, je
815 iid = isndrcvja(j)
816 isndrcva(j) = tmpd(iid)
817 ENDDO
818 CALL mpi_send(isndrcva(offs), sz, mpi_double_precision, pid-1,
819 & itagcomm+1, comm, ierror)
820 ENDDO
821 IF(osndrcvnum > 0) THEN
822 CALL mpi_waitall(osndrcvnum, requests(1),istatus(1,1),ierror)
823 ENDIF
824 DO i=1,osndrcvnum
825 pid = onghbprcs(i)
826 js = osndrcvia(pid)
827 je = osndrcvia(pid+1) - 1
828 DO j=js,je
829 iid = osndrcvja(j)
830 tmpd(iid)=osndrcva(j)
831 ENDDO
832 ENDDO
833 RETURN
834 END SUBROUTINE zmumps_docomminf
835C
836C SEPARATOR: Another function begins
837C
838 SUBROUTINE zmumps_docomm1n(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM,
839 & ISNDRCVNUM, INGHBPRCS,
840 & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA,
841 & OSNDRCVNUM, ONGHBPRCS,
842 & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA,
843 & ISTATUS, REQUESTS,
844 & COMM)
845 IMPLICIT NONE
846 include 'mpif.h'
847 INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM
848 INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL
849 DOUBLE PRECISION TMPD(IDSZ)
850 INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM)
851 INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL)
852 DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL)
853 INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL)
854 DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL)
855 INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM))
856 INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM))
857 INTEGER COMM, IERROR
858C LOCAL VARS
859 INTEGER I, PID, OFFS, SZ, J, JS, JE, IID
860 DO i=1,isndrcvnum
861 pid = inghbprcs(i)
862 offs = isndrcvia(pid)
863 sz = isndrcvia(pid+1) - isndrcvia(pid)
864 CALL mpi_irecv(isndrcva(offs), sz,
865 & mpi_double_precision, pid-1,
866 & itagcomm,comm,requests(i), ierror)
867 ENDDO
868 DO i=1,osndrcvnum
869 pid = onghbprcs(i)
870 offs = osndrcvia(pid)
871 sz = osndrcvia(pid+1) - osndrcvia(pid)
872 js = osndrcvia(pid)
873 je = osndrcvia(pid+1) - 1
874 DO j=js, je
875 iid = osndrcvja(j)
876 osndrcva(j) = tmpd(iid)
877 ENDDO
878 CALL mpi_send(osndrcva(offs), sz, mpi_double_precision, pid-1,
879 & itagcomm, comm, ierror)
880 ENDDO
881 IF(isndrcvnum > 0) THEN
882 CALL mpi_waitall(isndrcvnum, requests(1),istatus(1,1),ierror)
883 ENDIF
884C FOLD INTO MY D
885 DO i=1,isndrcvnum
886 pid = inghbprcs(i)
887 js = isndrcvia(pid)
888 je = isndrcvia(pid+1)-1
889 DO j=js,je
890 iid = isndrcvja(j)
891 tmpd(iid) = tmpd(iid)+ isndrcva(j)
892 ENDDO
893 ENDDO
894C COMMUNICATE THE UPDATED ONES
895 DO i=1,osndrcvnum
896 pid = onghbprcs(i)
897 offs = osndrcvia(pid)
898 sz = osndrcvia(pid+1) - osndrcvia(pid)
899 CALL mpi_irecv(osndrcva(offs), sz,
900 & mpi_double_precision, pid-1,
901 & itagcomm+1,comm,requests(i), ierror)
902 ENDDO
903 DO i=1,isndrcvnum
904 pid = inghbprcs(i)
905 offs = isndrcvia(pid)
906 sz = isndrcvia(pid+1)-isndrcvia(pid)
907 js = isndrcvia(pid)
908 je = isndrcvia(pid+1) -1
909 DO j=js, je
910 iid = isndrcvja(j)
911 isndrcva(j) = tmpd(iid)
912 ENDDO
913 CALL mpi_send(isndrcva(offs), sz, mpi_double_precision, pid-1,
914 & itagcomm+1, comm, ierror)
915 ENDDO
916 IF(osndrcvnum > 0) THEN
917 CALL mpi_waitall(osndrcvnum, requests(1),istatus(1,1),ierror)
918 ENDIF
919 DO i=1,osndrcvnum
920 pid = onghbprcs(i)
921 js = osndrcvia(pid)
922 je = osndrcvia(pid+1) - 1
923 DO j=js,je
924 iid = osndrcvja(j)
925 tmpd(iid)=osndrcva(j)
926 ENDDO
927 ENDDO
928 RETURN
929 END SUBROUTINE zmumps_docomm1n
930 SUBROUTINE zmumps_createpartvecsym(MYID, NUMPROCS, COMM,
931 & IRN_loc, JCN_loc, NZ_loc,
932 & IPARTVEC, ISZ,
933 & IWRK, IWSZ)
934 IMPLICIT NONE
935 EXTERNAL zmumps_bureduce
936 INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM
937 INTEGER(8) :: NZ_loc
938 INTEGER, INTENT(IN) :: ISZ, IWSZ
939 INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc)
940C
941C OUTPUT
942C IPARTVEC(I) = proc number with largest number of entries
943C in row/col I
944 INTEGER, INTENT(OUT) :: IPARTVEC(ISZ)
945C
946C INTERNAL WORKING ARRAY
947C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries
948C on my proc and in row/col I) for I=1,ISZ
949C (2*ISZ+1: 4*ISZ) is then set to
950C the processor with largest number of entries in its row/col
951C and its value (that is copied back into IPARTVEC(I)
952#if defined(WORKAROUNDINTELILP64MPI2INTEGER)
953 INTEGER(4), INTENT(OUT) :: IWRK(IWSZ)
954#else
955 INTEGER, INTENT(OUT) :: IWRK(IWSZ)
956#endif
957 include 'mpif.h'
958C
959C LOCAL VARS
960 INTEGER I
961 INTEGER(8) :: I8
962 INTEGER OP, IERROR
963 INTEGER IR, IC
964C
965 IF(numprocs.NE.1) THEN
966C CHECK done outsize
967C IF(IWSZ < 2*ISZ) THEN
968C CHECK ENDS
969 CALL mpi_op_create(zmumps_bureduce, .true., op, ierror)
970C PERFORM THE REDUCTION
971#if defined(WORKAROUNDINTELILP64MPI2INTEGER)
972 CALL zmumps_ibuinit(iwrk, 4*isz, int(isz,4))
973#else
974 CALL zmumps_ibuinit(iwrk, 4*isz, isz)
975#endif
976 DO i=1,isz
977 iwrk(2*i-1) = 0
978 iwrk(2*i) = myid
979 ENDDO
980 DO i8=1_8,nz_loc
981 ir = irn_loc(i8)
982 ic = jcn_loc(i8)
983 IF((ir.GE.1).AND.(ir.LE.isz).AND.
984 & (ic.GE.1).AND.(ic.LE.isz)) THEN
985 iwrk(2*ir-1) = iwrk(2*ir-1) + 1
986 iwrk(2*ic-1) = iwrk(2*ic-1) + 1
987 ENDIF
988 ENDDO
989 CALL mpi_allreduce(iwrk(1), iwrk(1+2*isz), isz,
990 & mpi_2integer, op, comm, ierror)
991 DO i=1,isz
992 ipartvec(i) = iwrk(2*i+2*isz)
993 ENDDO
994C FREE THE OPERATOR
995 CALL mpi_op_free(op, ierror)
996 ELSE
997 DO i=1,isz
998 ipartvec(i) = 0
999 ENDDO
1000 ENDIF
1001 RETURN
1002 END SUBROUTINE zmumps_createpartvecsym
1003 SUBROUTINE zmumps_numvolsndrcvsym(MYID, NUMPROCS, ISZ, IPARTVEC,
1004 & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL,
1005 & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM)
1006 IMPLICIT NONE
1007 INTEGER(8), INTENT(IN) :: NZ_loc
1008 INTEGER, INTENT(IN) :: IWRKSZ
1009 INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ
1010 INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc)
1011 INTEGER, INTENT(IN) :: IPARTVEC(ISZ)
1012 INTEGER, INTENT(IN) :: COMM
1013C
1014C OUTPUT PARAMETERS
1015C SNDSZ (IPROC+1) is set to the number of rows (or col) that
1016C MYID will have to send to IPROC
1017C RCVSZ(IPROC+1) is set to the nb of row/cols that
1018C MYID will receive from IPROC
1019 INTEGER :: SNDSZ(NUMPROCS)
1020 INTEGER :: RCVSZ(NUMPROCS)
1021C OSNDRCVNUM is set to the total number of procs
1022C destination of messages from MYID (< NUMPROCS)
1023C ISNDRCVNUM is set to the total number procs
1024C that will send messages to MYID (< NUMPROCS)
1025C ISNDRCVVOL is set to the total number of row/col that
1026C MYID will have to send to other procs
1027C (bounded by N)
1028C OSNDRCVVOL is set to the total number of row/col that
1029C MYID will have to send to other procs
1030C (bounded by N)
1031C Knowing that for each row the process with the largest
1032C number of entries will centralize all indices then
1033C ISNDRCVVOL and OSNDRCVVOL are bounded by N
1034 INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL
1035 INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL
1036C
1037C INTERNAL WORKING ARRAY
1038 INTEGER, INTENT(OUT) :: IWRK(IWRKSZ)
1039 include 'mpif.h'
1040C LOCAL VARS
1041 INTEGER I
1042 INTEGER(8) :: I8
1043 INTEGER IIND, IIND2, PIND
1044 INTEGER IERROR
1045C check done outsize
1046C IF(ISZ>IWRKSZ) THEN ERROR
1047 DO i=1,numprocs
1048 sndsz(i) = 0
1049 rcvsz(i) = 0
1050 ENDDO
1051 DO i=1,iwrksz
1052 iwrk(i) = 0
1053 ENDDO
1054C
1055C set SNDSZ
1056 DO i8=1_8,nz_loc
1057 iind = indx(i8)
1058 iind2 = oindx(i8)
1059 IF((iind.GE.1).AND.(iind.LE.isz).AND.(iind2.GE.1)
1060 & .AND.(iind2.LE.isz)) THEN
1061 pind = ipartvec(iind)
1062 IF(pind .NE. myid) THEN
1063C MYID will send row/col IIND to proc PIND
1064C (PIND has the largest nb of entries in row/con IIND
1065 IF(iwrk(iind).EQ.0) THEN
1066 iwrk(iind) = 1
1067 sndsz(pind+1) = sndsz(pind+1)+1
1068 ENDIF
1069 ENDIF
1070 iind = oindx(i8)
1071 pind = ipartvec(iind)
1072 IF(pind .NE. myid) THEN
1073 IF(iwrk(iind).EQ.0) THEN
1074 iwrk(iind) = 1
1075 sndsz(pind+1) = sndsz(pind+1)+1
1076 ENDIF
1077 ENDIF
1078 ENDIF
1079 ENDDO
1080C
1081C use SNDSZ to set RCVSZ
1082 CALL mpi_alltoall(sndsz, 1, mpi_integer,
1083 & rcvsz, 1, mpi_integer, comm, ierror)
1084C
1085C compute number of procs destinations of messages from MYID
1086C number of row/col sent by MYID.
1087 isndrcvnum = 0
1088 isndrcvvol = 0
1089 osndrcvnum = 0
1090 osndrcvvol = 0
1091 DO i=1, numprocs
1092 IF(sndsz(i) > 0) osndrcvnum = osndrcvnum + 1
1093 osndrcvvol = osndrcvvol + sndsz(i)
1094 IF(rcvsz(i) > 0) isndrcvnum = isndrcvnum + 1
1095 isndrcvvol = isndrcvvol + rcvsz(i)
1096 ENDDO
1097 RETURN
1098 END SUBROUTINE zmumps_numvolsndrcvsym
1099 SUBROUTINE zmumps_findnummyrowcolsym(MYID, NUMPROCS, COMM,
1100 & IRN_loc, JCN_loc, NZ_loc,
1101 & PARTVEC, N,
1102 & INUMMYR,
1103 & IWRK, IWSZ)
1104 IMPLICIT NONE
1105 INTEGER MYID, NUMPROCS, N
1106 INTEGER(8) :: NZ_loc
1107 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
1108 INTEGER PARTVEC(N)
1109 INTEGER INUMMYR
1110 INTEGER IWSZ
1111 INTEGER IWRK(IWSZ)
1112 INTEGER COMM
1113C
1114 INTEGER I, IR, IC
1115 INTEGER(8) :: I8
1116C check done outsize
1117C IF(IWSZ < M) THEN ERROR
1118C IF(IWSZ < N) THEN ERROR
1119 inummyr = 0
1120C MARK MY ROWS. FIRST COUNT,
1121C IF DYNAMIC MEMORY ALLOCATIOn WILL USED
1122 DO i=1,n
1123 iwrk(i) = 0
1124 IF(partvec(i).EQ.myid) THEN
1125 iwrk(i)=1
1126 inummyr = inummyr + 1
1127 ENDIF
1128 ENDDO
1129 DO i8=1_8,nz_loc
1130 ir = irn_loc(i8)
1131 ic = jcn_loc(i8)
1132 IF((ir.GE.1).AND.(ir.LE.n).AND.
1133 & ((ic.GE.1).AND.(ic.LE.n))) THEN
1134 IF(iwrk(ir) .EQ. 0) THEN
1135 iwrk(ir)= 1
1136 inummyr = inummyr + 1
1137 ENDIF
1138 ENDIF
1139 IF((ir.GE.1).AND.(ir.LE.n).AND.
1140 & ((ic.GE.1).AND.(ic.LE.n))) THEN
1141 IF(iwrk(ic).EQ.0) THEN
1142 iwrk(ic)= 1
1143 inummyr = inummyr + 1
1144 ENDIF
1145 ENDIF
1146 ENDDO
1147C THE SMAME THING APPLIES FOR COLS
1148C No need to do anything
1149C
1150 RETURN
1151 END SUBROUTINE zmumps_findnummyrowcolsym
1152 INTEGER FUNCTION zmumps_chkconvglosym(D, N, INDXR, INDXRSZ,
1153 & EPS, COMM)
1154 IMPLICIT NONE
1155 include 'mpif.h'
1156 INTEGER n, indxrsz
1157 DOUBLE PRECISION d(n)
1158 INTEGER INDXR(indxrsz)
1159 DOUBLE PRECISION eps
1160 INTEGER comm
1161 EXTERNAL zmumps_chk1loc
1162 INTEGER zmumps_chk1loc
1163 INTEGER glores, myresr, myres
1164 INTEGER ierr
1165 myresr = zmumps_chk1loc(d, n, indxr, indxrsz, eps)
1166 myres = 2*myresr
1167 CALL mpi_allreduce(myres, glores, 1, mpi_integer,
1168 & mpi_sum, comm, ierr)
1169 zmumps_chkconvglosym = glores
1170 RETURN
1171 END FUNCTION zmumps_chkconvglosym
1172 SUBROUTINE zmumps_fillmyrowcolindicessym(MYID, NUMPROCS,COMM,
1173 & IRN_loc, JCN_loc, NZ_loc,
1174 & PARTVEC, N,
1175 & MYROWINDICES, INUMMYR,
1176 & IWRK, IWSZ )
1177 IMPLICIT NONE
1178 INTEGER MYID, NUMPROCS, N
1179 INTEGER(8) :: NZ_loc
1180 INTEGER INUMMYR, IWSZ
1181 INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc)
1182 INTEGER PARTVEC(N)
1183 INTEGER MYROWINDICES(INUMMYR)
1184 INTEGER IWRK(IWSZ)
1185 INTEGER COMM
1186C
1187 INTEGER I, IR, IC, ITMP, MAXMN
1188 INTEGER(8) :: I8
1189C
1190 maxmn = n
1191C check done outsize
1192C IF(IWSZ < MAXMN) THEN ERROR
1193C MARK MY ROWS.
1194 DO i=1,n
1195 iwrk(i) = 0
1196 IF(partvec(i).EQ.myid) iwrk(i)=1
1197 ENDDO
1198 DO i8=1_8,nz_loc
1199 ir = irn_loc(i8)
1200 ic = jcn_loc(i8)
1201 IF((ir.GE.1).AND.(ir.LE.n).AND.
1202 & ((ic.GE.1).AND.(ic.LE.n))) THEN
1203 IF(iwrk(ir) .EQ. 0) iwrk(ir)= 1
1204 ENDIF
1205 IF((ir.GE.1).AND.(ir.LE.n).AND.
1206 & ((ic.GE.1).AND.(ic.LE.n))) THEN
1207 IF(iwrk(ic) .EQ.0) iwrk(ic)=1
1208 ENDIF
1209 ENDDO
1210C PUT MY ROWS INTO MYROWINDICES
1211 itmp = 1
1212 DO i=1,n
1213 IF(iwrk(i).EQ.1) THEN
1214 myrowindices(itmp) = i
1215 itmp = itmp + 1
1216 ENDIF
1217 ENDDO
1218C
1219C
1220C THE SMAME THING APPLY TO COLS
1221C
1222 RETURN
1223 END SUBROUTINE zmumps_fillmyrowcolindicessym
1224 SUBROUTINE zmumps_setupcommssym(MYID, NUMPROCS, ISZ, IPARTVEC,
1225 & NZ_loc, INDX, OINDX,
1226 & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA,
1227 & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA,
1228 & SNDSZ, RCVSZ, IWRK,
1229 & ISTATUS, REQUESTS,
1230 & ITAGCOMM, COMM )
1231 IMPLICIT NONE
1232 include 'mpif.h'
1233 INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL
1234 INTEGER(8) :: NZ_loc
1235C ISZ is either M or N
1236 INTEGER INDX(NZ_loc), OINDX(NZ_loc)
1237C INDX is either IRN_loc or JCN_col
1238 INTEGER IPARTVEC(ISZ)
1239C IPARTVEC is either rowpartvec or colpartvec
1240 INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM)
1241 INTEGER ISNDRCVIA(NUMPROCS+1)
1242 INTEGER ISNDRCVJA(ISNDVOL)
1243 INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM)
1244 INTEGER OSNDRCVIA(NUMPROCS+1)
1245 INTEGER OSNDRCVJA(OSNDVOL)
1246 INTEGER SNDSZ(NUMPROCS)
1247 INTEGER RCVSZ(NUMPROCS)
1248 INTEGER IWRK(ISZ)
1249 INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM)
1250 INTEGER REQUESTS(ISNDRCVNUM)
1251 INTEGER ITAGCOMM, COMM
1252C LOCAL VARS
1253 INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR
1254 INTEGER(8) :: I8
1255C COMPUATIONs START
1256 DO i=1,isz
1257 iwrk(i) = 0
1258 ENDDO
1259C INITIALIZE ONGHBPRCS using SNDSZ
1260C INITIALIZE THE OSNDRCVIA using SNDSZ
1261 offs = 1
1262 poffs = 1
1263 DO i=1,numprocs
1264 osndrcvia(i) = offs + sndsz(i)
1265 IF(sndsz(i) > 0) THEN
1266 onghbprcs(poffs)=i
1267 poffs = poffs + 1
1268 ENDIF
1269 offs = offs + sndsz(i)
1270 ENDDO
1271 osndrcvia(numprocs+1) = offs
1272C CHECK STARTS
1273C check done outsize
1274C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR
1275C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL)
1276 DO i8=1_8,nz_loc
1277 iind=indx(i8)
1278 iind2 = oindx(i8)
1279 IF((iind.GE.1).AND.(iind.LE.isz).AND.(iind2.GE.1)
1280 & .AND.(iind2.LE.isz)) THEN
1281 ipid=ipartvec(iind)
1282 IF(ipid.NE.myid) THEN
1283 IF(iwrk(iind).EQ.0) THEN
1284 iwhereto = osndrcvia(ipid+1)-1
1285 osndrcvia(ipid+1) = osndrcvia(ipid+1)-1
1286 osndrcvja(iwhereto) = iind
1287 iwrk(iind) = 1
1288 ENDIF
1289 ENDIF
1290 iind = oindx(i8)
1291 ipid=ipartvec(iind)
1292 IF(ipid.NE.myid) THEN
1293 IF(iwrk(iind).EQ.0) THEN
1294 iwhereto = osndrcvia(ipid+1)-1
1295 osndrcvia(ipid+1) = osndrcvia(ipid+1)-1
1296 osndrcvja(iwhereto) = iind
1297 iwrk(iind) = 1
1298 ENDIF
1299 ENDIF
1300 ENDIF
1301 ENDDO
1302C FILLED UP, WHAT I WILL RECEIVE (My requests from others)
1303C FILL UP ISNDRCVJA. It will be received to fill up
1304 CALL mpi_barrier(comm,ierror)
1305 offs = 1
1306 poffs = 1
1307 isndrcvia(1) = 1
1308 DO i=2,numprocs+1
1309 isndrcvia(i) = offs + rcvsz(i-1)
1310 IF(rcvsz(i-1) > 0) THEN
1311 inghbprcs(poffs)=i-1
1312 poffs = poffs + 1
1313 ENDIF
1314 offs = offs + rcvsz(i-1)
1315 ENDDO
1316 CALL mpi_barrier(comm,ierror)
1317 DO i=1, isndrcvnum
1318 ipid = inghbprcs(i)
1319 offs = isndrcvia(ipid)
1320 itmp = isndrcvia(ipid+1) - isndrcvia(ipid)
1321 CALL mpi_irecv(isndrcvja(offs), itmp, mpi_integer,ipid-1,
1322 & itagcomm, comm, requests(i),ierror)
1323 ENDDO
1324 DO i=1,osndrcvnum
1325 ipid = onghbprcs(i)
1326 offs = osndrcvia(ipid)
1327 itmp = osndrcvia(ipid+1)-osndrcvia(ipid)
1328 CALL mpi_send(osndrcvja(offs), itmp, mpi_integer, ipid-1,
1329 & itagcomm, comm,ierror)
1330 ENDDO
1331 IF(isndrcvnum > 0) THEN
1332 CALL mpi_waitall(isndrcvnum, requests(1),istatus(1,1),ierror)
1333 ENDIF
1334 CALL mpi_barrier(comm,ierror)
1335 RETURN
1336 END SUBROUTINE zmumps_setupcommssym
mpi_waitall
subroutine mpi_waitall(cnt, array_of_requests, status, ierr)
Definition mpi.f:536
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_alltoall
subroutine mpi_alltoall(sendbuf, sendcnt, sendtype, recvbuf, recvcnt, recvtype, comm, ierr)
Definition mpi.f:161
mpi_barrier
subroutine mpi_barrier(comm, ierr)
Definition mpi.f:188
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
mpi_op_create
subroutine mpi_op_create(func, commute, op, ierr)
Definition mpi.f:412
mpi_op_free
subroutine mpi_op_free(op, ierr)
Definition mpi.f:421
zmumps_fillmyrowcolindices
subroutine zmumps_fillmyrowcolindices(myid, numprocs, comm, irn_loc, jcn_loc, nz_loc, rowpartvec, colpartvec, m, n, myrowindices, inummyr, mycolindices, inummyc, iwrk, iwsz)
Definition zfac_scalings_simScale_util.F:176
zmumps_chk1conv
integer function zmumps_chk1conv(d, dsz, eps)
Definition zfac_scalings_simScale_util.F:267
zmumps_numvolsndrcv
subroutine zmumps_numvolsndrcv(myid, numprocs, isz, ipartvec, nz_loc, indx, osz, oindx, isndrcvnum, isndrcvvol, osndrcvnum, osndrcvvol, iwrk, iwrksz, sndsz, rcvsz, comm)
Definition zfac_scalings_simScale_util.F:540
zmumps_zeroout
subroutine zmumps_zeroout(tmpd, tmpsz, indx, indxsz)
Definition zfac_scalings_simScale_util.F:444
zmumps_numvolsndrcvsym
subroutine zmumps_numvolsndrcvsym(myid, numprocs, isz, ipartvec, nz_loc, indx, oindx, isndrcvnum, isndrcvvol, osndrcvnum, osndrcvvol, iwrk, iwrksz, sndsz, rcvsz, comm)
Definition zfac_scalings_simScale_util.F:1006
zmumps_fillmyrowcolindicessym
subroutine zmumps_fillmyrowcolindicessym(myid, numprocs, comm, irn_loc, jcn_loc, nz_loc, partvec, n, myrowindices, inummyr, iwrk, iwsz)
Definition zfac_scalings_simScale_util.F:1177
zmumps_setupcommssym
subroutine zmumps_setupcommssym(myid, numprocs, isz, ipartvec, nz_loc, indx, oindx, isndrcvnum, isndvol, inghbprcs, isndrcvia, isndrcvja, osndrcvnum, osndvol, onghbprcs, osndrcvia, osndrcvja, sndsz, rcvsz, iwrk, istatus, requests, itagcomm, comm)
Definition zfac_scalings_simScale_util.F:1231
zmumps_updatescale
subroutine zmumps_updatescale(d, tmpd, dsz, indx, indxsz)
Definition zfac_scalings_simScale_util.F:361
zmumps_createpartvecsym
subroutine zmumps_createpartvecsym(myid, numprocs, comm, irn_loc, jcn_loc, nz_loc, ipartvec, isz, iwrk, iwsz)
Definition zfac_scalings_simScale_util.F:934
zmumps_initreal
subroutine zmumps_initreal(d, dsz, val)
Definition zfac_scalings_simScale_util.F:429
zmumps_invlist
subroutine zmumps_invlist(d, dsz, indx, indxsz)
Definition zfac_scalings_simScale_util.F:413
zmumps_ibuinit
subroutine zmumps_ibuinit(iw, iwsz, ival)
Definition zfac_scalings_simScale_util.F:515
zmumps_errsca1
double precision function zmumps_errsca1(d, tmpd, dsz)
Definition zfac_scalings_simScale_util.F:337
zmumps_findnummyrowcolsym
subroutine zmumps_findnummyrowcolsym(myid, numprocs, comm, irn_loc, jcn_loc, nz_loc, partvec, n, inummyr, iwrk, iwsz)
Definition zfac_scalings_simScale_util.F:1104
zmumps_chkconvglo
integer function zmumps_chkconvglo(dr, m, indxr, indxrsz, dc, n, indxc, indxcsz, eps, comm)
Definition zfac_scalings_simScale_util.F:289
zmumps_upscale1
subroutine zmumps_upscale1(d, tmpd, dsz)
Definition zfac_scalings_simScale_util.F:378
zmumps_docomm1n
subroutine zmumps_docomm1n(myid, numprocs, tmpd, idsz, itagcomm, isndrcvnum, inghbprcs, isndrcvvol, isndrcvia, isndrcvja, isndrcva, osndrcvnum, onghbprcs, osndrcvvol, osndrcvia, osndrcvja, osndrcva, istatus, requests, comm)
Definition zfac_scalings_simScale_util.F:845
zmumps_bureduce
subroutine zmumps_bureduce(inv, inoutv, len, dtype)
Definition zfac_scalings_simScale_util.F:461
zmumps_createpartvec
subroutine zmumps_createpartvec(myid, numprocs, comm, irn_loc, jcn_loc, nz_loc, ipartvec, isz, osz, iwrk, iwsz)
Definition zfac_scalings_simScale_util.F:18
zmumps_chk1loc
integer function zmumps_chk1loc(d, dsz, indx, indxsz, eps)
Definition zfac_scalings_simScale_util.F:247
zmumps_setupcomms
subroutine zmumps_setupcomms(myid, numprocs, isz, ipartvec, nz_loc, indx, osz, oindx, isndrcvnum, isndvol, inghbprcs, isndrcvia, isndrcvja, osndrcvnum, osndvol, onghbprcs, osndrcvia, osndrcvja, sndsz, rcvsz, iwrk, istatus, requests, itagcomm, comm)
Definition zfac_scalings_simScale_util.F:639
zmumps_errscaloc
double precision function zmumps_errscaloc(d, tmpd, dsz, indx, indxsz)
Definition zfac_scalings_simScale_util.F:313
zmumps_initreallst
subroutine zmumps_initreallst(d, dsz, indx, indxsz, val)
Definition zfac_scalings_simScale_util.F:396
zmumps_docomminf
subroutine zmumps_docomminf(myid, numprocs, tmpd, idsz, itagcomm, isndrcvnum, inghbprcs, isndrcvvol, isndrcvia, isndrcvja, isndrcva, osndrcvnum, onghbprcs, osndrcvvol, osndrcvia, osndrcvja, osndrcva, istatus, requests, comm)
Definition zfac_scalings_simScale_util.F:750
zmumps_chkconvglosym
integer function zmumps_chkconvglosym(d, n, indxr, indxrsz, eps, comm)
Definition zfac_scalings_simScale_util.F:1154
zmumps_findnummyrowcol
subroutine zmumps_findnummyrowcol(myid, numprocs, comm, irn_loc, jcn_loc, nz_loc, rowpartvec, colpartvec, m, n, inummyr, inummyc, iwrk, iwsz)
Definition zfac_scalings_simScale_util.F:98