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

Go to the source code of this file.

Functions/Subroutines

subroutine dmumps_scatter_dist_rhs (nslaves, n, myid_nodes, comm_nodes, nrhs_col, nrhs_loc, lrhs_loc, map_rhs_loc, irhs_loc, rhs_loc, rhs_loc_size, rhscomp, ld_rhscomp, posinrhscomp_fwd, nb_fs_in_rhscomp, lscal, scaling_data_dr, lp, lpok, keep, nb_bytes_loc, info)
subroutine dmumps_dr_build_nbrowstorecv ()
subroutine dmumps_dr_try_recv ()
subroutine dmumps_dr_assemble_from_bufrec (nbrecords, bufreci_arg, bufrecr_arg)
subroutine dmumps_dr_assemble_local ()
subroutine dmumps_dr_get_new_buf (ibuf)
subroutine dmumps_dr_try_free_send ()
subroutine dmumps_dr_try_send (iproc_arg)
subroutine dmumps_dr_empty_rows ()
subroutine dmumps_sol_init_irhs_loc (id)

Function/Subroutine Documentation

◆ dmumps_dr_assemble_from_bufrec()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_assemble_from_bufrec ( integer, intent(in) nbrecords,
integer, dimension(nbrecords), intent(inout) bufreci_arg,
double precision, dimension(nbrecords, nrhs_col), intent(in) bufrecr_arg )
private

Definition at line 210 of file dsol_distrhs.F.

212 IMPLICIT NONE
213 INTEGER, INTENT(IN) :: NBRECORDS
214 INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS)
215 DOUBLE PRECISION, INTENT(IN) :: BUFRECR_ARG(NBRECORDS,
216 & NRHS_COL)
217 INTEGER :: I, K, IRHSCOMP, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED
218 ifirstnottouched = nbrecords+1
219 ilastnottouched = 0
220 DO i = 1, nbrecords
221 IF (bufreci(i) .LE. 0) THEN
222 WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_RECV",
223 & i, bufreci(i), bufreci(1)
224 CALL mumps_abort()
225 ENDIF
226 irhscomp=posinrhscomp_fwd(bufreci(i))
227 bufreci_arg(i)=irhscomp
228 IF ( .NOT. touched(irhscomp) ) THEN
229 ifirstnottouched=min(ifirstnottouched,i)
230 ilastnottouched=max(ilastnottouched,i)
231 ENDIF
232 ENDDO
233 omp_flag = .false.
234!$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND.
235!$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2)
236 IF (omp_flag) THEN
237!$OMP PARALLEL DO PRIVATE(I,IRHSCOMP) IF (OMP_FLAG)
238 DO k = 1, nrhs_col
239 DO i = ifirstnottouched, ilastnottouched
240 irhscomp=bufreci_arg(i)
241 IF (.NOT. touched(irhscomp)) THEN
242 rhscomp(irhscomp,k)=zero
243 ENDIF
244 ENDDO
245 DO i = 1, nbrecords
246 irhscomp=bufreci_arg(i)
247 rhscomp(irhscomp,k) = rhscomp(irhscomp,k) +
248 & bufrecr_arg(i,k)
249 ENDDO
250 ENDDO
251!$OMP END PARALLEL DO
252 ELSE
253 DO k = 1, nrhs_col
254 DO i = ifirstnottouched, ilastnottouched
255 irhscomp=bufreci_arg(i)
256 IF (.NOT. touched(irhscomp)) THEN
257 rhscomp(irhscomp,k)=zero
258 ENDIF
259 ENDDO
260 DO i = 1, nbrecords
261 irhscomp=bufreci_arg(i)
262 rhscomp(irhscomp,k) = rhscomp(irhscomp,k) +
263 & bufrecr_arg(i,k)
264 ENDDO
265 ENDDO
266 ENDIF
267 DO i = 1, nbrecords
268 irhscomp = bufreci_arg(i)
269 IF (.NOT. touched(irhscomp)) THEN
270 nb_fs_touched = nb_fs_touched + 1
271 touched(irhscomp) = .true.
272 ENDIF
273 ENDDO
274 nbrowstorecv = nbrowstorecv - nbrecords
275 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ dmumps_dr_assemble_local()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_assemble_local
private

Definition at line 277 of file dsol_distrhs.F.

278 INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED
279 INTEGER :: Iloc
280 INTEGER :: Iglob
281 INTEGER :: IRHSCOMP
282 INTEGER(8) :: ISHIFT
283 IF ( nbrowstosend(myid_nodes+1) .EQ. 0) THEN
284 WRITE(*,*) "Internal error in DMUMPS_DR_ASSEMBLE_LOCAL"
285 CALL mumps_abort()
286 ENDIF
287 nbrecords=min(maxrecords, nbrowstosend(myid_nodes+1))
288 ifirstnottouched=nbrecords+1
289 DO i = 1, nbrecords
290 irhscomp = posinrhscomp_fwd(irhs_loc(
291 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
292 IF (.NOT. touched(irhscomp)) THEN
293 ifirstnottouched=i
294 EXIT
295 ENDIF
296 ENDDO
297 IF (lscal) THEN
298!$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND.
299!$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2)
300!$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob)
301!$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG)
302 DO k = 1, nrhs_col
303 ishift = (k-1) * lrhs_loc
304 DO i = ifirstnottouched, nbrecords
305 irhscomp = posinrhscomp_fwd(irhs_loc(
306 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
307 IF (.NOT. touched(irhscomp)) THEN
308 rhscomp(irhscomp,k)=zero
309 ENDIF
310 ENDDO
311 DO i = 1, nbrecords
312 iloc = irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)
313 iglob = irhs_loc(iloc)
314 irhscomp = posinrhscomp_fwd(iglob)
315 rhscomp(irhscomp,k) = rhscomp(irhscomp,k)+
316 & rhs_loc(iloc+ishift)*
317 & scaling_data_dr%SCALING_LOC(iloc)
318 ENDDO
319 ENDDO
320!$OMP END PARALLEL DO
321 ELSE
322!$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND.
323!$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2)
324!$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob)
325!$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG)
326 DO k = 1, nrhs_col
327 ishift = (k-1) * lrhs_loc
328 DO i = ifirstnottouched, nbrecords
329 irhscomp = posinrhscomp_fwd(irhs_loc(
330 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
331 IF (.NOT. touched(irhscomp)) THEN
332 rhscomp(irhscomp,k)=zero
333 ENDIF
334 ENDDO
335 DO i = 1, nbrecords
336 iloc = irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)
337 iglob = irhs_loc(iloc)
338 irhscomp = posinrhscomp_fwd(iglob)
339 rhscomp(irhscomp,k) = rhscomp(irhscomp,k)+
340 & rhs_loc(iloc+ishift)
341 ENDDO
342 ENDDO
343!$OMP END PARALLEL DO
344 ENDIF
345 DO i = 1, nbrecords
346 irhscomp = posinrhscomp_fwd(irhs_loc(
347 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
348 IF (.NOT. touched(irhscomp)) THEN
349 nb_fs_touched = nb_fs_touched + 1
350 touched(irhscomp) = .true.
351 ENDIF
352 ENDDO
353 nextrowtosend(myid_nodes+1)=nextrowtosend(myid_nodes+1)+
354 & nbrecords
355 nbrowstosend(myid_nodes+1)=nbrowstosend(myid_nodes+1)-
356 & nbrecords
357 nbrowstorecv = nbrowstorecv - nbrecords
358 RETURN

◆ dmumps_dr_build_nbrowstorecv()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_build_nbrowstorecv

Definition at line 178 of file dsol_distrhs.F.

179 INTEGER :: IPROC
180 DO iproc = 0, nslaves-1
181 CALL mpi_reduce( nbrowstosend(iproc+1), nbrowstorecv,
182 & 1, mpi_integer,
183 & mpi_sum, iproc, comm_nodes, ierr_mpi )
184 ENDDO
mpi_reduce
subroutine mpi_reduce(sendbuf, recvbuf, cnt, datatype, op, root, comm, ierr)
Definition mpi.f:120

◆ dmumps_dr_empty_rows()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_empty_rows
private

Definition at line 467 of file dsol_distrhs.F.

468 INTEGER :: K, IFS
469 IF ( nb_fs_touched .NE. nb_fs_in_rhscomp ) THEN
470!$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND.
471!$ & (NRHS_COL*NB_FS_IN_RHSCOMP > KEEP(363)/2)
472!$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSCOMP) IF (OMP_FLAG)
473 DO k = 1, nrhs_col
474 DO ifs = 1, nb_fs_in_rhscomp
475 IF ( .NOT. touched(ifs) ) THEN
476 rhscomp( ifs, k) = zero
477 ENDIF
478 ENDDO
479 DO ifs = nb_fs_in_rhscomp +1, ld_rhscomp
480 rhscomp(ifs, k) = zero
481 ENDDO
482 ENDDO
483!$OMP END PARALLEL DO
484 ELSE
485!$ OMP_FLAG = .FALSE.
486!$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSCOMP-NB_FS_IN_RHSCOMP,8)
487!$ CHUNK8 = max(CHUNK8,1_8)
488!$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN
489!$ OMP_FLAG = .TRUE.
490!$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8))
491!$ ENDIF
492!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8)
493!$OMP& IF (OMP_FLAG)
494 DO k = 1, nrhs_col
495 DO ifs = nb_fs_in_rhscomp +1, ld_rhscomp
496 rhscomp(ifs, k) = zero
497 ENDDO
498 ENDDO
499!$OMP END PARALLEL DO
500 ENDIF
501 RETURN

◆ dmumps_dr_get_new_buf()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_get_new_buf ( integer, intent(out) ibuf)
private

Definition at line 360 of file dsol_distrhs.F.

361 INTEGER, INTENT(OUT) :: IBUF
362 INTEGER :: I
363 ibuf = -1
364 IF (nb_active_sends .NE. max_active_sends) THEN
365 DO i=1, max_active_sends
366 IF (.NOT. is_send_active(i)) THEN
367 ibuf = i
368 EXIT
369 ENDIF
370 ENDDO
371 ENDIF
372 RETURN

◆ dmumps_dr_try_free_send()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_try_free_send
private

Definition at line 374 of file dsol_distrhs.F.

375 INTEGER :: MPI_STATUS(MPI_STATUS_SIZE)
376 INTEGER :: I
377 LOGICAL :: FLAG
378 IF (nb_active_sends .GT. 0) THEN
379 DO i=1, max_active_sends
380 IF (is_send_active(i)) THEN
381 CALL mpi_test( mpi_reqr(i), flag, mpi_status, ierr_mpi )
382 IF (flag) THEN
383 CALL mpi_wait(mpi_reqi(i), mpi_status, ierr_mpi)
384 nb_active_sends = nb_active_sends - 1
385 is_send_active(i)=.false.
386 IF (nb_active_sends .EQ. 0) THEN
387 RETURN
388 ENDIF
389 ENDIF
390 ENDIF
391 ENDDO
392 ENDIF
393 RETURN
mpi_test
subroutine mpi_test(ireq, flag, status, ierr)
Definition mpi.f:502
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525

◆ dmumps_dr_try_recv()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_try_recv
private

Definition at line 186 of file dsol_distrhs.F.

187 IMPLICIT NONE
188 include 'mumps_tags.h'
189 INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU
190 INTEGER :: NBRECORDS
191 LOGICAL :: FLAG
192 CALL mpi_iprobe( mpi_any_source, distrhsi, comm_nodes,
193 & flag, mpi_status, ierr_mpi )
194 IF (flag) THEN
195 msgsou = mpi_status( mpi_source )
196 CALL mpi_get_count(mpi_status, mpi_integer,
197 & nbrecords, ierr_mpi)
198 CALL mpi_recv(bufreci(1), nbrecords, mpi_integer,
199 & msgsou, distrhsi,
200 & comm_nodes, mpi_status, ierr_mpi)
201 CALL mpi_recv(bufrecr(1), nbrecords*nrhs_col,
202 & mpi_double_precision,
203 & msgsou, distrhsr,
204 & comm_nodes, mpi_status, ierr_mpi)
205 CALL dmumps_dr_assemble_from_bufrec(nbrecords,
206 & bufreci, bufrecr)
207 ENDIF
208 RETURN
dmumps_dr_assemble_from_bufrec
subroutine dmumps_dr_assemble_from_bufrec(nbrecords, bufreci_arg, bufrecr_arg)
Definition dsol_distrhs.F:212
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_iprobe
subroutine mpi_iprobe(source, tag, comm, flag, status, ierr)
Definition mpi.f:360
mpi_get_count
subroutine mpi_get_count(status, datatype, cnt, ierr)
Definition mpi.f:296

◆ dmumps_dr_try_send()

subroutine dmumps_scatter_dist_rhs::dmumps_dr_try_send ( integer, intent(in) iproc_arg)
private

Definition at line 395 of file dsol_distrhs.F.

396 IMPLICIT NONE
397 INTEGER, INTENT(IN) :: IPROC_ARG
398 include 'mumps_tags.h'
399 INTEGER :: NBRECORDS, IBUF, I, K
400 INTEGER(8) :: IPOSRHS
401 INTEGER :: IPOSBUF
402 IF (iproc_arg .EQ. myid_nodes) THEN
403 WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_SEND"
404 CALL mumps_abort()
405 ENDIF
406 IF (nbrowstosend(iproc_arg+1) .EQ. 0) THEN
407 WRITE(*,*) "Internal error 2 in DMUMPS_DR_TRY_SEND"
408 CALL mumps_abort()
409 ENDIF
410 CALL dmumps_dr_get_new_buf(ibuf)
411 IF (ibuf .GT. 0) THEN
412 nbrecords = min(maxrecords,nbrowstosend(iproc_arg+1))
413!$ OMP_FLAG = .FALSE.
414!$ CHUNK = NRHS_COL*NBRECORDS
415!$ IF (CHUNK .GE. KEEP(363)) THEN
416!$ OMP_FLAG = .TRUE.
417!$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2)
418!$ ENDIF
419 IF (lscal) THEN
420!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK)
421!$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG)
422 DO k=1, nrhs_col
423 DO i = 1, nbrecords
424 iposbuf = (k-1)*nbrecords
425 iposrhs = int(k-1,8)*int(lrhs_loc,8)
426 iloc = irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
427 bufr( iposbuf + i, ibuf )
428 & = rhs_loc( iposrhs + iloc ) *
429 & scaling_data_dr%SCALING_LOC(iloc)
430 ENDDO
431 ENDDO
432!$OMP END PARALLEL DO
433 ELSE
434!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK)
435!$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG)
436 DO k=1, nrhs_col
437 DO i = 1, nbrecords
438 iposbuf = (k-1)*nbrecords
439 iposrhs = int(k-1,8)*int(lrhs_loc,8)
440 iloc = irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
441 bufr( iposbuf + i, ibuf )
442 & = rhs_loc( iposrhs + iloc )
443 ENDDO
444 ENDDO
445!$OMP END PARALLEL DO
446 ENDIF
447 DO i = 1, nbrecords
448 iloc = irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
449 irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
450 & = irhs_loc(iloc)
451 ENDDO
452 CALL mpi_isend( irhs_loc_sorted(nextrowtosend(iproc_arg+1)),
453 & nbrecords, mpi_integer, iproc_arg, distrhsi,
454 & comm_nodes, mpi_reqi(ibuf), ierr_mpi )
455 CALL mpi_isend( bufr(1,ibuf), nbrecords*nrhs_col,
456 & mpi_double_precision,
457 & iproc_arg, distrhsr,
458 & comm_nodes, mpi_reqr(ibuf), ierr_mpi )
459 nextrowtosend(iproc_arg+1)=nextrowtosend(iproc_arg+1)+
460 & nbrecords
461 nbrowstosend(iproc_arg+1)=nbrowstosend(iproc_arg+1)-nbrecords
462 nb_active_sends = nb_active_sends + 1
463 is_send_active(ibuf)=.true.
464 ENDIF
465 RETURN
dmumps_dr_get_new_buf
subroutine dmumps_dr_get_new_buf(ibuf)
Definition dsol_distrhs.F:361
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382

◆ dmumps_scatter_dist_rhs()

subroutine dmumps_scatter_dist_rhs ( integer, intent(in) nslaves,
integer, intent(in) n,
integer, intent(in) myid_nodes,
integer, intent(in) comm_nodes,
integer, intent(in) nrhs_col,
integer, intent(in) nrhs_loc,
integer, intent(in) lrhs_loc,
integer, dimension(max(1,nrhs_loc)), intent(in) map_rhs_loc,
integer, dimension(nrhs_loc), intent(in) irhs_loc,
double precision, dimension(rhs_loc_size), intent(in) rhs_loc,
integer(8), intent(in) rhs_loc_size,
double precision, dimension(ld_rhscomp, nrhs_col), intent(out) rhscomp,
integer, intent(in) ld_rhscomp,
integer, dimension(n), intent(in) posinrhscomp_fwd,
integer, intent(in) nb_fs_in_rhscomp,
logical, intent(in) lscal,
type(scaling_data_t), intent(in) scaling_data_dr,
integer, intent(in) lp,
logical, intent(in) lpok,
integer, dimension(500) keep,
integer(8), intent(out) nb_bytes_loc,
integer, dimension(2), intent(inout) info )

Definition at line 14 of file dsol_distrhs.F.

24 USE dmumps_struc_def
25!$ USE OMP_LIB
26 IMPLICIT NONE
27 INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES
28 INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc
29 INTEGER, INTENT(IN) :: NRHS_COL
30 INTEGER, INTENT(IN) :: COMM_NODES
31 INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc))
32 INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc)
33 INTEGER(8), INTENT(IN) :: RHS_loc_size
34 DOUBLE PRECISION, INTENT(IN) :: RHS_loc(RHS_loc_size)
35 INTEGER, INTENT(IN) :: NB_FS_IN_RHSCOMP, LD_RHSCOMP
36 INTEGER, INTENT(IN) :: POSINRHSCOMP_FWD(N)
37 DOUBLE PRECISION, INTENT(OUT) :: RHSCOMP(LD_RHSCOMP, NRHS_COL)
38 INTEGER :: KEEP(500)
39 LOGICAL, INTENT(IN) :: LSCAL
40 type scaling_data_t
41 sequence
42 DOUBLE PRECISION, dimension(:), pointer :: SCALING
43 DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC
44 end type scaling_data_t
45 type(scaling_data_t), INTENT(IN) :: scaling_data_dr
46 LOGICAL, INTENT(IN) :: LPOK
47 INTEGER, INTENT(IN) :: LP
48 INTEGER, INTENT(INOUT) :: INFO(2)
49 INTEGER(8), INTENT(OUT):: NB_BYTES_LOC
50 include 'mpif.h'
51 INTEGER :: IERR_MPI
52 LOGICAL :: OMP_FLAG
53!$ INTEGER :: CHUNK, NOMP
54!$ INTEGER(8) :: CHUNK8
55 INTEGER :: allocok
56 INTEGER :: MAXRECORDS
57 INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND
58 INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND
59 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUFR
60 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI
61 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUFRECR
62 LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED
63 INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR
64 INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted
65 INTEGER :: Iloc
66 INTEGER :: Iloc_sorted
67 INTEGER :: IREQ
68 INTEGER :: IMAP, IPROC_MAX
69 INTEGER :: IFS
70 INTEGER :: MAX_ACTIVE_SENDS
71 INTEGER :: NB_ACTIVE_SENDS
72 INTEGER :: NB_FS_TOUCHED
73 INTEGER :: NBROWSTORECV
74 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0d0
75!$ NOMP = OMP_GET_MAX_THREADS()
76 nb_bytes_loc = 0_8
77 ALLOCATE( nbrowstosend(nslaves),
78 & nextrowtosend(nslaves),
79 & irhs_loc_sorted(nrhs_loc),
80 & stat=allocok )
81 IF (allocok > 0) THEN
82 info(1) = -13
83 info(2) = nslaves+nslaves+nrhs_loc
84 ENDIF
85 nb_bytes_loc = int(2*nslaves+nrhs_loc,8)*keep(34)
86 CALL mpi_allreduce( mpi_in_place, allocok, 1,
87 & mpi_integer, mpi_sum,
88 & comm_nodes, ierr_mpi )
89 IF (allocok .GT. 0) RETURN
90 nbrowstosend(1:nslaves) = 0
91 DO iloc = 1, nrhs_loc
92 IF (irhs_loc(iloc) .GE. 1 .AND.
93 & irhs_loc(iloc) .LE. n) THEN
94 imap = map_rhs_loc(iloc)
95 nbrowstosend(imap+1) = nbrowstosend(imap+1)+1
96 ENDIF
97 ENDDO
98 nextrowtosend(1)=1
99 DO imap=1, nslaves-1
100 nextrowtosend(imap+1)=nextrowtosend(imap)+nbrowstosend(imap)
101 ENDDO
102 nbrowstosend=0
103 DO iloc = 1, nrhs_loc
104 IF (irhs_loc(iloc) .GE. 1 .AND.
105 & irhs_loc(iloc) .LE. n) THEN
106 imap = map_rhs_loc(iloc)
107 iloc_sorted = nextrowtosend(imap+1)+nbrowstosend(imap+1)
108 irhs_loc_sorted(iloc_sorted) = iloc
109 nbrowstosend(imap+1)=nbrowstosend(imap+1)+1
110 ENDIF
111 ENDDO
112 CALL dmumps_dr_build_nbrowstorecv()
113 max_active_sends = min(10, nslaves)
114 IF (keep(72) .EQ.1 ) THEN
115 maxrecords = 15
116 ELSE
117 maxrecords = min(200000,2000000/nrhs_col)
118 maxrecords = min(maxrecords,
119 & 50000000 / max_active_sends / nrhs_col)
120 maxrecords = max(maxrecords, 50)
121 ENDIF
122 ALLOCATE(bufr(maxrecords*nrhs_col,
123 & max_active_sends),
124 & mpi_reqi(max_active_sends),
125 & mpi_reqr(max_active_sends),
126 & is_send_active(max_active_sends),
127 & bufreci(maxrecords),
128 & bufrecr(maxrecords*nrhs_col),
129 & touched(nb_fs_in_rhscomp),
130 & stat=allocok)
131 IF (allocok .GT. 0) THEN
132 IF (lp .GT. 0) WRITE(lp, '(A)')
133 & 'Error: Allocation problem in DMUMPS_SCATTER_DIST_RHS'
134 info(1)=-13
135 info(2)=nrhs_col*maxrecords*max_active_sends+
136 & 3*max_active_sends+maxrecords*(1+nrhs_col)
137 & + nb_fs_in_rhscomp
138 ENDIF
139 nb_bytes_loc=nb_bytes_loc +
140 & keep(34) * ( int(2*max_active_sends,8) + int(maxrecords,8) ) +
141 & keep(34) * (int(max_active_sends,8) + int(nb_fs_in_rhscomp,8)) +
142 & keep(35) * (
143 & int( maxrecords,8)*int(nrhs_col,8)*int(max_active_sends,8)
144 & + int(maxrecords,8) * int(nrhs_col,8) )
145 CALL mpi_allreduce( mpi_in_place, allocok, 1,
146 & mpi_integer, mpi_sum,
147 & comm_nodes, ierr_mpi )
148 IF (allocok .NE. 0) RETURN
149 nb_active_sends = 0
150 DO ireq = 1, max_active_sends
151 is_send_active(ireq) = .false.
152 ENDDO
153 nb_fs_touched = 0
154 DO ifs = 1, nb_fs_in_rhscomp
155 touched(ifs) = .false.
156 ENDDO
157 iproc_max=maxloc(nbrowstosend,dim=1)-1
158 DO WHILE (nbrowstosend(iproc_max+1) .NE. 0)
159 IF (iproc_max .EQ. myid_nodes) THEN
160 CALL dmumps_dr_assemble_local()
161 ELSE
162 CALL dmumps_dr_try_send(iproc_max)
163 ENDIF
164 CALL dmumps_dr_try_recv()
165 CALL dmumps_dr_try_free_send()
166 iproc_max=maxloc(nbrowstosend,dim=1)-1
167 ENDDO
168 DO WHILE ( nbrowstorecv .NE. 0)
169 CALL dmumps_dr_try_recv()
170 CALL dmumps_dr_try_free_send()
171 ENDDO
172 DO WHILE (nb_active_sends .NE. 0)
173 CALL dmumps_dr_try_free_send()
174 ENDDO
175 CALL dmumps_dr_empty_rows()
176 RETURN
177 CONTAINS
178 SUBROUTINE dmumps_dr_build_nbrowstorecv()
179 INTEGER :: IPROC
180 DO iproc = 0, nslaves-1
181 CALL mpi_reduce( nbrowstosend(iproc+1), nbrowstorecv,
182 & 1, mpi_integer,
183 & mpi_sum, iproc, comm_nodes, ierr_mpi )
184 ENDDO
185 END SUBROUTINE dmumps_dr_build_nbrowstorecv
186 SUBROUTINE dmumps_dr_try_recv()
187 IMPLICIT NONE
188 include 'mumps_tags.h'
189 INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU
190 INTEGER :: NBRECORDS
191 LOGICAL :: FLAG
192 CALL mpi_iprobe( mpi_any_source, distrhsi, comm_nodes,
193 & flag, mpi_status, ierr_mpi )
194 IF (flag) THEN
195 msgsou = mpi_status( mpi_source )
196 CALL mpi_get_count(mpi_status, mpi_integer,
197 & nbrecords, ierr_mpi)
198 CALL mpi_recv(bufreci(1), nbrecords, mpi_integer,
199 & msgsou, distrhsi,
200 & comm_nodes, mpi_status, ierr_mpi)
201 CALL mpi_recv(bufrecr(1), nbrecords*nrhs_col,
202 & mpi_double_precision,
203 & msgsou, distrhsr,
204 & comm_nodes, mpi_status, ierr_mpi)
205 CALL dmumps_dr_assemble_from_bufrec(nbrecords,
206 & bufreci, bufrecr)
207 ENDIF
208 RETURN
209 END SUBROUTINE dmumps_dr_try_recv
210 SUBROUTINE dmumps_dr_assemble_from_bufrec
211 & (nbrecords, bufreci_arg, bufrecr_arg)
212 IMPLICIT NONE
213 INTEGER, INTENT(IN) :: NBRECORDS
214 INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS)
215 DOUBLE PRECISION, INTENT(IN) :: BUFRECR_ARG(NBRECORDS,
216 & NRHS_COL)
217 INTEGER :: I, K, IRHSCOMP, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED
218 ifirstnottouched = nbrecords+1
219 ilastnottouched = 0
220 DO i = 1, nbrecords
221 IF (bufreci(i) .LE. 0) THEN
222 WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_RECV",
223 & i, bufreci(i), bufreci(1)
224 CALL mumps_abort()
225 ENDIF
226 irhscomp=posinrhscomp_fwd(bufreci(i))
227 bufreci_arg(i)=irhscomp
228 IF ( .NOT. touched(irhscomp) ) THEN
229 ifirstnottouched=min(ifirstnottouched,i)
230 ilastnottouched=max(ilastnottouched,i)
231 ENDIF
232 ENDDO
233 omp_flag = .false.
234!$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND.
235!$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2)
236 IF (omp_flag) THEN
237!$OMP PARALLEL DO PRIVATE(I,IRHSCOMP) IF (OMP_FLAG)
238 DO k = 1, nrhs_col
239 DO i = ifirstnottouched, ilastnottouched
240 irhscomp=bufreci_arg(i)
241 IF (.NOT. touched(irhscomp)) THEN
242 rhscomp(irhscomp,k)=zero
243 ENDIF
244 ENDDO
245 DO i = 1, nbrecords
246 irhscomp=bufreci_arg(i)
247 rhscomp(irhscomp,k) = rhscomp(irhscomp,k) +
248 & bufrecr_arg(i,k)
249 ENDDO
250 ENDDO
251!$OMP END PARALLEL DO
252 ELSE
253 DO k = 1, nrhs_col
254 DO i = ifirstnottouched, ilastnottouched
255 irhscomp=bufreci_arg(i)
256 IF (.NOT. touched(irhscomp)) THEN
257 rhscomp(irhscomp,k)=zero
258 ENDIF
259 ENDDO
260 DO i = 1, nbrecords
261 irhscomp=bufreci_arg(i)
262 rhscomp(irhscomp,k) = rhscomp(irhscomp,k) +
263 & bufrecr_arg(i,k)
264 ENDDO
265 ENDDO
266 ENDIF
267 DO i = 1, nbrecords
268 irhscomp = bufreci_arg(i)
269 IF (.NOT. touched(irhscomp)) THEN
270 nb_fs_touched = nb_fs_touched + 1
271 touched(irhscomp) = .true.
272 ENDIF
273 ENDDO
274 nbrowstorecv = nbrowstorecv - nbrecords
275 RETURN
276 END SUBROUTINE dmumps_dr_assemble_from_bufrec
277 SUBROUTINE dmumps_dr_assemble_local()
278 INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED
279 INTEGER :: Iloc
280 INTEGER :: Iglob
281 INTEGER :: IRHSCOMP
282 INTEGER(8) :: ISHIFT
283 IF ( nbrowstosend(myid_nodes+1) .EQ. 0) THEN
284 WRITE(*,*) "Internal error in DMUMPS_DR_ASSEMBLE_LOCAL"
285 CALL mumps_abort()
286 ENDIF
287 nbrecords=min(maxrecords, nbrowstosend(myid_nodes+1))
288 ifirstnottouched=nbrecords+1
289 DO i = 1, nbrecords
290 irhscomp = posinrhscomp_fwd(irhs_loc(
291 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
292 IF (.NOT. touched(irhscomp)) THEN
293 ifirstnottouched=i
294 EXIT
295 ENDIF
296 ENDDO
297 IF (lscal) THEN
298!$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND.
299!$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2)
300!$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob)
301!$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG)
302 DO k = 1, nrhs_col
303 ishift = (k-1) * lrhs_loc
304 DO i = ifirstnottouched, nbrecords
305 irhscomp = posinrhscomp_fwd(irhs_loc(
306 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
307 IF (.NOT. touched(irhscomp)) THEN
308 rhscomp(irhscomp,k)=zero
309 ENDIF
310 ENDDO
311 DO i = 1, nbrecords
312 iloc = irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)
313 iglob = irhs_loc(iloc)
314 irhscomp = posinrhscomp_fwd(iglob)
315 rhscomp(irhscomp,k) = rhscomp(irhscomp,k)+
316 & rhs_loc(iloc+ishift)*
317 & scaling_data_dr%SCALING_LOC(iloc)
318 ENDDO
319 ENDDO
320!$OMP END PARALLEL DO
321 ELSE
322!$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND.
323!$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2)
324!$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob)
325!$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG)
326 DO k = 1, nrhs_col
327 ishift = (k-1) * lrhs_loc
328 DO i = ifirstnottouched, nbrecords
329 irhscomp = posinrhscomp_fwd(irhs_loc(
330 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
331 IF (.NOT. touched(irhscomp)) THEN
332 rhscomp(irhscomp,k)=zero
333 ENDIF
334 ENDDO
335 DO i = 1, nbrecords
336 iloc = irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)
337 iglob = irhs_loc(iloc)
338 irhscomp = posinrhscomp_fwd(iglob)
339 rhscomp(irhscomp,k) = rhscomp(irhscomp,k)+
340 & rhs_loc(iloc+ishift)
341 ENDDO
342 ENDDO
343!$OMP END PARALLEL DO
344 ENDIF
345 DO i = 1, nbrecords
346 irhscomp = posinrhscomp_fwd(irhs_loc(
347 & irhs_loc_sorted(nextrowtosend(myid_nodes+1)+i-1)))
348 IF (.NOT. touched(irhscomp)) THEN
349 nb_fs_touched = nb_fs_touched + 1
350 touched(irhscomp) = .true.
351 ENDIF
352 ENDDO
353 nextrowtosend(myid_nodes+1)=nextrowtosend(myid_nodes+1)+
354 & nbrecords
355 nbrowstosend(myid_nodes+1)=nbrowstosend(myid_nodes+1)-
356 & nbrecords
357 nbrowstorecv = nbrowstorecv - nbrecords
358 RETURN
359 END SUBROUTINE dmumps_dr_assemble_local
360 SUBROUTINE dmumps_dr_get_new_buf( IBUF )
361 INTEGER, INTENT(OUT) :: IBUF
362 INTEGER :: I
363 ibuf = -1
364 IF (nb_active_sends .NE. max_active_sends) THEN
365 DO i=1, max_active_sends
366 IF (.NOT. is_send_active(i)) THEN
367 ibuf = i
368 EXIT
369 ENDIF
370 ENDDO
371 ENDIF
372 RETURN
373 END SUBROUTINE dmumps_dr_get_new_buf
374 SUBROUTINE dmumps_dr_try_free_send()
375 INTEGER :: MPI_STATUS(MPI_STATUS_SIZE)
376 INTEGER :: I
377 LOGICAL :: FLAG
378 IF (nb_active_sends .GT. 0) THEN
379 DO i=1, max_active_sends
380 IF (is_send_active(i)) THEN
381 CALL mpi_test( mpi_reqr(i), flag, mpi_status, ierr_mpi )
382 IF (flag) THEN
383 CALL mpi_wait(mpi_reqi(i), mpi_status, ierr_mpi)
384 nb_active_sends = nb_active_sends - 1
385 is_send_active(i)=.false.
386 IF (nb_active_sends .EQ. 0) THEN
387 RETURN
388 ENDIF
389 ENDIF
390 ENDIF
391 ENDDO
392 ENDIF
393 RETURN
394 END SUBROUTINE dmumps_dr_try_free_send
395 SUBROUTINE dmumps_dr_try_send(IPROC_ARG)
396 IMPLICIT NONE
397 INTEGER, INTENT(IN) :: IPROC_ARG
398 include 'mumps_tags.h'
399 INTEGER :: NBRECORDS, IBUF, I, K
400 INTEGER(8) :: IPOSRHS
401 INTEGER :: IPOSBUF
402 IF (iproc_arg .EQ. myid_nodes) THEN
403 WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_SEND"
404 CALL mumps_abort()
405 ENDIF
406 IF (nbrowstosend(iproc_arg+1) .EQ. 0) THEN
407 WRITE(*,*) "Internal error 2 in DMUMPS_DR_TRY_SEND"
408 CALL mumps_abort()
409 ENDIF
410 CALL dmumps_dr_get_new_buf(ibuf)
411 IF (ibuf .GT. 0) THEN
412 nbrecords = min(maxrecords,nbrowstosend(iproc_arg+1))
413!$ OMP_FLAG = .FALSE.
414!$ CHUNK = NRHS_COL*NBRECORDS
415!$ IF (CHUNK .GE. KEEP(363)) THEN
416!$ OMP_FLAG = .TRUE.
417!$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2)
418!$ ENDIF
419 IF (lscal) THEN
420!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK)
421!$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG)
422 DO k=1, nrhs_col
423 DO i = 1, nbrecords
424 iposbuf = (k-1)*nbrecords
425 iposrhs = int(k-1,8)*int(lrhs_loc,8)
426 iloc = irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
427 bufr( iposbuf + i, ibuf )
428 & = rhs_loc( iposrhs + iloc ) *
429 & scaling_data_dr%SCALING_LOC(iloc)
430 ENDDO
431 ENDDO
432!$OMP END PARALLEL DO
433 ELSE
434!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK)
435!$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG)
436 DO k=1, nrhs_col
437 DO i = 1, nbrecords
438 iposbuf = (k-1)*nbrecords
439 iposrhs = int(k-1,8)*int(lrhs_loc,8)
440 iloc = irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
441 bufr( iposbuf + i, ibuf )
442 & = rhs_loc( iposrhs + iloc )
443 ENDDO
444 ENDDO
445!$OMP END PARALLEL DO
446 ENDIF
447 DO i = 1, nbrecords
448 iloc = irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
449 irhs_loc_sorted(nextrowtosend(iproc_arg+1)+i-1)
450 & = irhs_loc(iloc)
451 ENDDO
452 CALL mpi_isend( irhs_loc_sorted(nextrowtosend(iproc_arg+1)),
453 & nbrecords, mpi_integer, iproc_arg, distrhsi,
454 & comm_nodes, mpi_reqi(ibuf), ierr_mpi )
455 CALL mpi_isend( bufr(1,ibuf), nbrecords*nrhs_col,
456 & mpi_double_precision,
457 & iproc_arg, distrhsr,
458 & comm_nodes, mpi_reqr(ibuf), ierr_mpi )
459 nextrowtosend(iproc_arg+1)=nextrowtosend(iproc_arg+1)+
460 & nbrecords
461 nbrowstosend(iproc_arg+1)=nbrowstosend(iproc_arg+1)-nbrecords
462 nb_active_sends = nb_active_sends + 1
463 is_send_active(ibuf)=.true.
464 ENDIF
465 RETURN
466 END SUBROUTINE dmumps_dr_try_send
467 SUBROUTINE dmumps_dr_empty_rows()
468 INTEGER :: K, IFS
469 IF ( nb_fs_touched .NE. nb_fs_in_rhscomp ) THEN
470!$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND.
471!$ & (NRHS_COL*NB_FS_IN_RHSCOMP > KEEP(363)/2)
472!$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSCOMP) IF (OMP_FLAG)
473 DO k = 1, nrhs_col
474 DO ifs = 1, nb_fs_in_rhscomp
475 IF ( .NOT. touched(ifs) ) THEN
476 rhscomp( ifs, k) = zero
477 ENDIF
478 ENDDO
479 DO ifs = nb_fs_in_rhscomp +1, ld_rhscomp
480 rhscomp(ifs, k) = zero
481 ENDDO
482 ENDDO
483!$OMP END PARALLEL DO
484 ELSE
485!$ OMP_FLAG = .FALSE.
486!$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSCOMP-NB_FS_IN_RHSCOMP,8)
487!$ CHUNK8 = max(CHUNK8,1_8)
488!$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN
489!$ OMP_FLAG = .TRUE.
490!$ chunk8 = max((chunk8+nomp-1)/nomp,int(keep(363)/2,8))
491!$ ENDIF
492!$omp parallel DO collapse(2) schedule(static,chunk8)
493!$OMP& IF (OMP_FLAG)
494 DO k = 1, nrhs_col
495 DO ifs = nb_fs_in_rhscomp +1, ld_rhscomp
496 rhscomp(ifs, k) = zero
497 ENDDO
498 ENDDO
499!$OMP END PARALLEL DO
500 ENDIF
501 RETURN
502 END SUBROUTINE dmumps_dr_empty_rows
dmumps_dr_empty_rows
subroutine dmumps_dr_empty_rows()
Definition dsol_distrhs.F:468
dmumps_dr_assemble_local
subroutine dmumps_dr_assemble_local()
Definition dsol_distrhs.F:278
dmumps_dr_try_free_send
subroutine dmumps_dr_try_free_send()
Definition dsol_distrhs.F:375
dmumps_dr_try_send
subroutine dmumps_dr_try_send(iproc_arg)
Definition dsol_distrhs.F:396
dmumps_dr_build_nbrowstorecv
subroutine dmumps_dr_build_nbrowstorecv()
Definition dsol_distrhs.F:179
dmumps_dr_try_recv
subroutine dmumps_dr_try_recv()
Definition dsol_distrhs.F:187
mpi_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
dmumps_struc_def
Definition dmumps_struc_def.F:14
static
subroutine static(v, vr, a, ar, ms, in, igrnod, weight_md, wfext)
Definition static.F:33

◆ dmumps_sol_init_irhs_loc()

subroutine dmumps_sol_init_irhs_loc ( type (dmumps_struc) id)

Definition at line 504 of file dsol_distrhs.F.

505 USE dmumps_struc_def
506 IMPLICIT NONE
507 TYPE (DMUMPS_STRUC) :: id
508 INTEGER, PARAMETER :: MASTER = 0
509 INTEGER :: ROW_OR_COL_INDICES
510 INTEGER :: IERR_MPI
511 LOGICAL :: I_AM_SLAVE
512 INTEGER, POINTER :: idIRHS_loc(:)
513 INTEGER, POINTER :: UNS_PERM(:)
514 INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok
515 INTEGER, TARGET :: IDUMMY(1)
516 include 'mpif.h'
517 NULLIFY(uns_perm)
518 IF (id%JOB .NE. 9) THEN
519 WRITE(*,*) "Internal error 1 in DMUMPS_SOL_INIT_IRHS_loc"
520 CALL mumps_abort()
521 ENDIF
522 i_am_slave = ( id%MYID .ne. master .OR.
523 & ( id%MYID .eq. master .AND.
524 & id%KEEP(46) .eq. 1 ) )
525 IF (id%MYID .EQ. master) THEN
526 IF (id%ICNTL(20).EQ.10) THEN
527 row_or_col_indices = 0
528 ELSE IF (id%ICNTL(20).EQ.11) THEN
529 row_or_col_indices = 1
530 ELSE
531 row_or_col_indices = 0
532 ENDIF
533 IF (id%ICNTL(9) .NE. 1) THEN
534 row_or_col_indices = 1 - row_or_col_indices
535 ENDIF
536 IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN
537 uns_perm_to_be_done = 1
538 ELSE
539 uns_perm_to_be_done = 0
540 ENDIF
541 ENDIF
542 CALL mpi_bcast(row_or_col_indices,1,mpi_integer,master,
543 & id%COMM,ierr_mpi)
544 CALL mpi_bcast(uns_perm_to_be_done,1,mpi_integer,master,
545 & id%COMM,ierr_mpi)
546 IF ( i_am_slave ) THEN
547 IF (id%KEEP(89) .GT. 0) THEN
548 IF (.NOT. associated(id%IRHS_loc)) THEN
549 id%INFO(1)=-22
550 id%INFO(2)=17
551 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN
552 id%INFO(1)=-22
553 id%INFO(2)=17
554 ENDIF
555 ENDIF
556 ENDIF
557 CALL mumps_propinfo( id%ICNTL(1),
558 & id%INFO(1),
559 & id%COMM, id%MYID )
560 IF (id%INFO(1).LT.0) goto 500
561 IF (i_am_slave) THEN
562 IF (associated(id%IRHS_loc)) THEN
563 IF (size(id%IRHS_loc) .GT. 0) THEN
564 idirhs_loc => id%IRHS_loc
565 ELSE
566 idirhs_loc => idummy
567 ENDIF
568 ELSE
569 idirhs_loc => idummy
570 ENDIF
571 CALL mumps_build_irhs_loc(id%MYID_NODES, id%NSLAVES, id%N,
572 & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1),
573 & max(1, id%KEEP(32)),
574 & id%STEP(1), id%PROCNODE_STEPS(1), idirhs_loc(1),
575 & row_or_col_indices)
576 ENDIF
577 IF (uns_perm_to_be_done .EQ. 1) THEN
578 IF (id%MYID.NE.master) THEN
579 ALLOCATE(uns_perm(id%N),stat=allocok)
580 IF (allocok > 0) THEN
581 id%INFO(1)=-13
582 id%INFO(2)=id%N
583 GOTO 100
584 ENDIF
585 ENDIF
586 100 CONTINUE
587 CALL mumps_propinfo( id%ICNTL(1),
588 & id%INFO(1),
589 & id%COMM, id%MYID )
590 IF (id%INFO(1) .LT. 0) GOTO 500
591 IF ( id%MYID .EQ. master ) THEN
592 uns_perm => id%UNS_PERM
593 ENDIF
594 CALL mpi_bcast(uns_perm(1),id%N,mpi_integer,master,
595 & id%COMM,ierr_mpi)
596 IF (i_am_slave .AND. id%KEEP(89) .NE.0) THEN
597 DO i=1, id%KEEP(89)
598 id%IRHS_loc(i)=uns_perm(id%IRHS_loc(i))
599 ENDDO
600 ENDIF
601 ENDIF
602 500 CONTINUE
603 IF (id%MYID.NE.master) THEN
604 IF (associated(uns_perm)) DEALLOCATE(uns_perm)
605 ENDIF
606 NULLIFY(uns_perm)
607 RETURN
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
id
initmumps id
Definition multiplerhs_example.m:4
mumps_build_irhs_loc
subroutine mumps_build_irhs_loc(myid_nodes, nslaves, n, ptrist, keep, keep8, iw, liw, step, procnode_steps, irhs_loc, row_or_col_indices)
Definition sol_common.F:55