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

Go to the source code of this file.

Functions/Subroutines

subroutine zmumps_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 zmumps_dr_build_nbrowstorecv ()
subroutine zmumps_dr_try_recv ()
subroutine zmumps_dr_assemble_from_bufrec (nbrecords, bufreci_arg, bufrecr_arg)
subroutine zmumps_dr_assemble_local ()
subroutine zmumps_dr_get_new_buf (ibuf)
subroutine zmumps_dr_try_free_send ()
subroutine zmumps_dr_try_send (iproc_arg)
subroutine zmumps_dr_empty_rows ()
subroutine zmumps_sol_init_irhs_loc (id)

Function/Subroutine Documentation

◆ zmumps_dr_assemble_from_bufrec()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_assemble_from_bufrec ( integer, intent(in) nbrecords,
integer, dimension(nbrecords), intent(inout) bufreci_arg,
complex(kind=8), dimension(nbrecords, nrhs_col), intent(in) bufrecr_arg )
private

Definition at line 210 of file zsol_distrhs.F.

212 IMPLICIT NONE
213 INTEGER, INTENT(IN) :: NBRECORDS
214 INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS)
215 COMPLEX(kind=8), 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 ZMUMPS_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

◆ zmumps_dr_assemble_local()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_assemble_local
private

Definition at line 277 of file zsol_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 ZMUMPS_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

◆ zmumps_dr_build_nbrowstorecv()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_build_nbrowstorecv

Definition at line 178 of file zsol_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

◆ zmumps_dr_empty_rows()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_empty_rows
private

Definition at line 467 of file zsol_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

◆ zmumps_dr_get_new_buf()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_get_new_buf ( integer, intent(out) ibuf)
private

Definition at line 360 of file zsol_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

◆ zmumps_dr_try_free_send()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_try_free_send
private

Definition at line 374 of file zsol_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

◆ zmumps_dr_try_recv()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_try_recv
private

Definition at line 186 of file zsol_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_complex,
203 & msgsou, distrhsr,
204 & comm_nodes, mpi_status, ierr_mpi)
205 CALL zmumps_dr_assemble_from_bufrec(nbrecords,
206 & bufreci, bufrecr)
207 ENDIF
208 RETURN
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
zmumps_dr_assemble_from_bufrec
subroutine zmumps_dr_assemble_from_bufrec(nbrecords, bufreci_arg, bufrecr_arg)
Definition zsol_distrhs.F:212

◆ zmumps_dr_try_send()

subroutine zmumps_scatter_dist_rhs::zmumps_dr_try_send ( integer, intent(in) iproc_arg)
private

Definition at line 395 of file zsol_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 ZMUMPS_DR_TRY_SEND"
404 CALL mumps_abort()
405 ENDIF
406 IF (nbrowstosend(iproc_arg+1) .EQ. 0) THEN
407 WRITE(*,*) "Internal error 2 in ZMUMPS_DR_TRY_SEND"
408 CALL mumps_abort()
409 ENDIF
410 CALL zmumps_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_complex,
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
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
zmumps_dr_get_new_buf
subroutine zmumps_dr_get_new_buf(ibuf)
Definition zsol_distrhs.F:361

◆ zmumps_scatter_dist_rhs()

subroutine zmumps_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,
complex(kind=8), dimension(rhs_loc_size), intent(in) rhs_loc,
integer(8), intent(in) rhs_loc_size,
complex(kind=8), 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 zsol_distrhs.F.

24 USE zmumps_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 COMPLEX(kind=8), 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 COMPLEX(kind=8), 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 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUFR
60 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI
61 COMPLEX(kind=8), 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 COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0, 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.GT. IF (allocok 0) RETURN
90 NBROWSTOSEND(1:NSLAVES) = 0
91 DO Iloc = 1, NRHS_loc
92.GE..AND. IF (IRHS_loc(Iloc) 1
93.LE. & IRHS_loc(Iloc) 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.GE..AND. IF (IRHS_loc(Iloc) 1
105.LE. & IRHS_loc(Iloc) 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 ZMUMPS_DR_BUILD_NBROWSTORECV()
113 MAX_ACTIVE_SENDS = min(10, NSLAVES)
114.EQ. IF (KEEP(72) 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.GT. IF (allocok 0) THEN
132.GT. IF (LP 0) WRITE(LP, '(a)')
133 & 'error: allocation problem in zmumps_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.NE. IF (allocok 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.NE. DO WHILE (NBROWSTOSEND(IPROC_MAX+1) 0)
159.EQ. IF (IPROC_MAX MYID_NODES) THEN
160 CALL ZMUMPS_DR_ASSEMBLE_LOCAL()
161 ELSE
162 CALL ZMUMPS_DR_TRY_SEND(IPROC_MAX)
163 ENDIF
164 CALL ZMUMPS_DR_TRY_RECV()
165 CALL ZMUMPS_DR_TRY_FREE_SEND()
166 IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1
167 ENDDO
168.NE. DO WHILE ( NBROWSTORECV 0)
169 CALL ZMUMPS_DR_TRY_RECV()
170 CALL ZMUMPS_DR_TRY_FREE_SEND()
171 ENDDO
172.NE. DO WHILE (NB_ACTIVE_SENDS 0)
173 CALL ZMUMPS_DR_TRY_FREE_SEND()
174 ENDDO
175 CALL ZMUMPS_DR_EMPTY_ROWS()
176 RETURN
177 CONTAINS
178 SUBROUTINE ZMUMPS_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 ZMUMPS_DR_BUILD_NBROWSTORECV
186 SUBROUTINE ZMUMPS_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_COMPLEX,
203 & MSGSOU, DistRhsR,
204 & COMM_NODES, MPI_STATUS, IERR_MPI)
205 CALL ZMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS,
206 & BUFRECI, BUFRECR)
207 ENDIF
208 RETURN
209 END SUBROUTINE ZMUMPS_DR_TRY_RECV
210 SUBROUTINE ZMUMPS_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 COMPLEX(kind=8), 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.LE. IF (BUFRECI(I) 0) THEN
222 WRITE(*,*) "Internal error 1 in ZMUMPS_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.NOT. IF ( TOUCHED(IRHSCOMP) ) THEN
229 IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I)
230 ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I)
231 ENDIF
232 ENDDO
233 OMP_FLAG = .FALSE.
234.GE..AND.!$ OMP_FLAG = ( NRHS_COLKEEP(362)
235.GE.!$ & NRHS_COL*NBRECORDS 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.NOT. IF ( 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.NOT. IF ( 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.NOT. IF ( 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 ZMUMPS_DR_ASSEMBLE_FROM_BUFREC
277 SUBROUTINE ZMUMPS_DR_ASSEMBLE_LOCAL()
278 INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED
279 INTEGER :: Iloc
280 INTEGER :: Iglob
281 INTEGER :: IRHSCOMP
282 INTEGER(8) :: ISHIFT
283.EQ. IF ( NBROWSTOSEND(MYID_NODES+1) 0) THEN
284 WRITE(*,*) "Internal error in ZMUMPS_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.NOT. IF ( TOUCHED(IRHSCOMP)) THEN
293 IFIRSTNOTTOUCHED=I
294 EXIT
295 ENDIF
296 ENDDO
297 IF (LSCAL) THEN
298.GE..AND.!$ OMP_FLAG = (NRHS_COLKEEP(362)
299.GE.!$ & NRHS_COL*NBRECORDS 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.NOT. IF ( 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.GE..AND.!$ OMP_FLAG = (NRHS_COLKEEP(362)
323.GE.!$ & NRHS_COL*NBRECORDS 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.NOT. IF ( 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.NOT. IF ( 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 ZMUMPS_DR_ASSEMBLE_LOCAL
360 SUBROUTINE ZMUMPS_DR_GET_NEW_BUF( IBUF )
361 INTEGER, INTENT(OUT) :: IBUF
362 INTEGER :: I
363 IBUF = -1
364.NE. IF (NB_ACTIVE_SENDS MAX_ACTIVE_SENDS) THEN
365 DO I=1, MAX_ACTIVE_SENDS
366.NOT. IF ( IS_SEND_ACTIVE(I)) THEN
367 IBUF = I
368 EXIT
369 ENDIF
370 ENDDO
371 ENDIF
372 RETURN
373 END SUBROUTINE ZMUMPS_DR_GET_NEW_BUF
374 SUBROUTINE ZMUMPS_DR_TRY_FREE_SEND()
375 INTEGER :: MPI_STATUS(MPI_STATUS_SIZE)
376 INTEGER :: I
377 LOGICAL :: FLAG
378.GT. IF (NB_ACTIVE_SENDS 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.EQ. IF (NB_ACTIVE_SENDS 0) THEN
387 RETURN
388 ENDIF
389 ENDIF
390 ENDIF
391 ENDDO
392 ENDIF
393 RETURN
394 END SUBROUTINE ZMUMPS_DR_TRY_FREE_SEND
395 SUBROUTINE ZMUMPS_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.EQ. IF (IPROC_ARG MYID_NODES) THEN
403 WRITE(*,*) "Internal error 1 in ZMUMPS_DR_TRY_SEND"
404 CALL MUMPS_ABORT()
405 ENDIF
406.EQ. IF (NBROWSTOSEND(IPROC_ARG+1) 0) THEN
407 WRITE(*,*) "Internal error 2 in ZMUMPS_DR_TRY_SEND"
408 CALL MUMPS_ABORT()
409 ENDIF
410 CALL ZMUMPS_DR_GET_NEW_BUF(IBUF)
411.GT. IF (IBUF 0) THEN
412 NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1))
413!$ OMP_FLAG = .FALSE.
414!$ CHUNK = NRHS_COL*NBRECORDS
415.GE.!$ IF (CHUNK 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_COMPLEX,
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 ZMUMPS_DR_TRY_SEND
467 SUBROUTINE ZMUMPS_DR_EMPTY_ROWS()
468 INTEGER :: K, IFS
469.NE. IF ( NB_FS_TOUCHED NB_FS_IN_RHSCOMP ) THEN
470.GE..AND.!$ OMP_FLAG = (NRHS_COL KEEP(362))
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.NOT. IF ( 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.GE.!$ IF (CHUNK8 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 ZMUMPS_DR_EMPTY_ROWS
zmumps_struc_def
Definition zmumps_struc_def.F:14
zmumps_scatter_dist_rhs
subroutine zmumps_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)
Definition zsol_distrhs.F:24

◆ zmumps_sol_init_irhs_loc()

subroutine zmumps_sol_init_irhs_loc ( type (zmumps_struc) id)

Definition at line 504 of file zsol_distrhs.F.

505 USE zmumps_struc_def
506 IMPLICIT NONE
507 TYPE (ZMUMPS_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 ZMUMPS_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