OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zsol_distrhs.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_scatter_dist_rhs(
15 & NSLAVES, N,
16 & MYID_NODES, COMM_NODES,
17 & NRHS_COL, NRHS_loc, LRHS_loc,
18 & MAP_RHS_loc,
19 & IRHS_loc, RHS_loc, RHS_loc_size,
20 & RHSCOMP, LD_RHSCOMP,
21 & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP,
22 & LSCAL, scaling_data_dr,
23 & LP, LPOK, KEEP, NB_BYTES_LOC, INFO )
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 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 zmumps_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 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 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 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 DO WHILE ( nbrowstorecv .NE. 0)
169 CALL zmumps_dr_try_recv()
170 CALL zmumps_dr_try_free_send()
171 ENDDO
172 DO WHILE (nb_active_sends .NE. 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 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
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 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
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 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 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 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 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 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
466 END SUBROUTINE zmumps_dr_try_send
467 SUBROUTINE zmumps_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 zmumps_dr_empty_rows
503 END SUBROUTINE zmumps_scatter_dist_rhs
504 SUBROUTINE zmumps_sol_init_irhs_loc(id)
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
608 END SUBROUTINE zmumps_sol_init_irhs_loc
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_test
subroutine mpi_test(ireq, flag, status, ierr)
Definition mpi.f:502
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_reduce
subroutine mpi_reduce(sendbuf, recvbuf, cnt, datatype, op, root, comm, ierr)
Definition mpi.f:120
mpi_get_count
subroutine mpi_get_count(status, datatype, cnt, ierr)
Definition mpi.f:296
mpi_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
zmumps_struc_def
Definition zmumps_struc_def.F:14
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
static
subroutine static(v, vr, a, ar, ms, in, igrnod, weight_md, wfext)
Definition static.F:33
zmumps_sol_init_irhs_loc
subroutine zmumps_sol_init_irhs_loc(id)
Definition zsol_distrhs.F:505
zmumps_dr_try_free_send
subroutine zmumps_dr_try_free_send()
Definition zsol_distrhs.F:375
zmumps_dr_build_nbrowstorecv
subroutine zmumps_dr_build_nbrowstorecv()
Definition zsol_distrhs.F:179
zmumps_dr_try_recv
subroutine zmumps_dr_try_recv()
Definition zsol_distrhs.F:187
zmumps_dr_empty_rows
subroutine zmumps_dr_empty_rows()
Definition zsol_distrhs.F:468
zmumps_dr_try_send
subroutine zmumps_dr_try_send(iproc_arg)
Definition zsol_distrhs.F:396
zmumps_dr_assemble_from_bufrec
subroutine zmumps_dr_assemble_from_bufrec(nbrecords, bufreci_arg, bufrecr_arg)
Definition zsol_distrhs.F:212
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_dr_get_new_buf
subroutine zmumps_dr_get_new_buf(ibuf)
Definition zsol_distrhs.F:361
zmumps_dr_assemble_local
subroutine zmumps_dr_assemble_local()
Definition zsol_distrhs.F:278