OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zsol_fwd_aux.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 RECURSIVE SUBROUTINE zmumps_traiter_message_solve
15 & ( bufr, lbufr, lbufr_bytes,
16 & msgtag, msgsou, myid, slavef, comm,
17 & n, nrhs, ipool, lpool, leaf,
18 & nbfin, nstk_s, iw, liw, a, la, ptrist,
19 & ptrfac, iwcb, liwcb,
20 & wcb, lwcb, poswcb,
21 & pleftwcb, posiwcb,
22 & ptricb,
23 & info, keep, keep8, dkeep, step, procnode_steps,
24 & rhscomp, lrhscomp, posinrhscomp_fwd
25 & , from_pp
26 & )
27 USE zmumps_ooc
28 USE zmumps_sol_lr, ONLY: zmumps_sol_slave_lr_u
29 USE zmumps_buf
30 IMPLICIT NONE
31 INTEGER lbufr, lbufr_bytes
32 INTEGER msgtag, msgsou, myid, slavef, comm
33 INTEGER liw
34 INTEGER(8), INTENT(IN) :: la, lwcb
35 INTEGER n, nrhs, lpool, leaf, nbfin, lrhscomp
36 INTEGER liwcb, posiwcb
37 INTEGER(8) :: poswcb, pleftwcb
38 INTEGER info( 80 ), keep( 500)
39 INTEGER(8) keep8(150)
40 DOUBLE PRECISION, INTENT(INOUT) :: dkeep(230)
41 INTEGER bufr( lbufr )
42 INTEGER ipool( lpool ), nstk_s( n )
43 INTEGER iwcb( liwcb )
44 INTEGER iw( liw )
45 INTEGER ptricb(keep(28)),ptrist(keep(28))
46 INTEGER(8) :: ptrfac(keep(28))
47 INTEGER step(n)
48 INTEGER procnode_steps(keep(28))
49 COMPLEX(kind=8) wcb( lwcb ), a( la )
50 COMPLEX(kind=8) rhscomp( lrhscomp, nrhs )
51 INTEGER, intent(in) :: posinrhscomp_fwd(n)
52 LOGICAL, intent(in) :: from_pp
53 include 'mpif.h'
54 include 'mumps_tags.h'
55 INTEGER(8) :: ptrx, ptry, ifr8
56 INTEGER ierr, k, jj, jbdeb, jbfin, nrhs_b
57 INTEGER :: iwhdlr, lda_slave
58 INTEGER :: mtype_slave
59 INTEGER finode, FPERE, long, ncb, position, ncv, npiv
60 INTEGER pdest, i, iposinrhscomp
61 INTEGER j1
62 INTEGER(8) :: apos
63 LOGICAL dummy
64 LOGICAL flag
65 LOGICAL :: omp_flag
66 EXTERNAL mumps_procnode
67 INTEGER mumps_procnode
68 LOGICAL compress_panel, lr_activated
69 LOGICAL oocwrite_compatible_with_blr
70 COMPLEX(kind=8) alpha, one
71 parameter(one=(1.0d0,0.0d0), alpha=(-1.0d0,0.0d0))
72 include 'mumps_headers.h'
73 IF ( msgtag .EQ. racine_solve ) THEN
74 nbfin = nbfin - 1
75 IF ( nbfin .eq. 0 ) GOTO 270
76 ELSE IF (msgtag .EQ. contvec ) THEN
77 position = 0
78 CALL mpi_unpack( bufr, lbufr_bytes, position,
79 & finode, 1, mpi_integer, comm, ierr )
80 CALL mpi_unpack( bufr, lbufr_bytes, position,
81 & fpere, 1, mpi_integer, comm, ierr )
82 CALL mpi_unpack( bufr, lbufr_bytes, position,
83 & ncb, 1, mpi_integer, comm, ierr )
84 CALL mpi_unpack( bufr, lbufr_bytes, position,
85 & jbdeb, 1, mpi_integer, comm, ierr )
86 CALL mpi_unpack( bufr, lbufr_bytes, position,
87 & jbfin, 1, mpi_integer, comm, ierr )
88 CALL mpi_unpack( bufr, lbufr_bytes, position,
89 & long, 1, mpi_integer, comm, ierr )
90 nrhs_b = jbfin-jbdeb+1
91 IF ( ncb .eq. 0 ) THEN
92 ptricb(step(finode)) = -1
93 ELSE
94 IF ( ptricb(step(finode)) .EQ. 0 ) THEN
95 ptricb(step(finode)) = ncb + 1
96 END IF
97 IF ( ( posiwcb - long ) .LT. 0 ) THEN
98 info( 1 ) = -14
99 info( 2 ) = long
100 GOTO 260
101 END IF
102 IF ( poswcb - pleftwcb + 1_8 .LT.
103 & int(long,8) * int(nrhs_b,8)) THEN
104 info( 1 ) = -11
105 CALL mumps_set_ierror(pleftwcb-poswcb-1_8+
106 & int(long,8) * int(nrhs_b,8),
107 & info(2))
108 GOTO 260
109 END IF
110 IF (long .GT. 0) THEN
111 CALL mpi_unpack( bufr, lbufr_bytes, position,
112 & iwcb( 1 ),
113 & long, mpi_integer, comm, ierr )
114 DO k = 1, nrhs_b
115 CALL mpi_unpack( bufr, lbufr_bytes, position,
116 & wcb( pleftwcb ),
117 & long, mpi_double_complex, comm, ierr )
118#if defined(__ve__)
119!NEC$ IVDEP
120#endif
121 DO i = 1, long
122 iposinrhscomp= abs(posinrhscomp_fwd(iwcb(i)))
123 rhscomp(iposinrhscomp,jbdeb+k-1) =
124 & rhscomp(iposinrhscomp,jbdeb+k-1) +
125 & wcb(pleftwcb+i-1)
126 ENDDO
127 END DO
128 ptricb(step(finode)) = ptricb(step(finode)) - long
129 ENDIF
130 END IF
131 IF ( ptricb(step(finode)) == 1 .OR.
132 & ptricb(step(finode)) == -1 ) THEN
133 nstk_s(step(fpere)) = nstk_s(step(fpere)) - 1
134 ptricb(step(finode)) = 0
135 END IF
136 IF ( nstk_s(step(fpere)) .EQ. 0 ) THEN
137 ipool( leaf ) = fpere
138 leaf = leaf + 1
139 IF ( leaf > lpool ) THEN
140 WRITE(*,*)
141 & 'Internal error 1 ZMUMPS_TRAITER_MESSAGE_SOLVE',
142 & leaf, lpool
143 CALL mumps_abort()
144 END IF
145 ENDIF
146 ELSEIF ( msgtag .EQ. master2slave ) THEN
147 position = 0
148 CALL mpi_unpack( bufr, lbufr_bytes, position,
149 & finode, 1, mpi_integer, comm, ierr )
150 CALL mpi_unpack( bufr, lbufr_bytes, position,
151 & fpere, 1, mpi_integer, comm, ierr )
152 CALL mpi_unpack( bufr, lbufr_bytes, position,
153 & ncv, 1, mpi_integer, comm, ierr )
154 CALL mpi_unpack( bufr, lbufr_bytes, position,
155 & npiv, 1, mpi_integer, comm, ierr )
156 CALL mpi_unpack( bufr, lbufr_bytes, position,
157 & jbdeb, 1, mpi_integer, comm, ierr )
158 CALL mpi_unpack( bufr, lbufr_bytes, position,
159 & jbfin, 1, mpi_integer, comm, ierr )
160 nrhs_b = jbfin-jbdeb+1
161 ptry = pleftwcb
162 ptrx = pleftwcb + int(ncv,8) * int(nrhs_b,8)
163 pleftwcb = pleftwcb + int(npiv + ncv,8) * int(nrhs_b,8)
164 IF ( poswcb - pleftwcb + 1 .LT. 0 ) THEN
165 info(1) = -11
166 CALL mumps_set_ierror(-poswcb+pleftwcb-1_8,info(2))
167 GO TO 260
168 END IF
169 DO k=1, nrhs_b
170 CALL mpi_unpack( bufr, lbufr_bytes, position,
171 & wcb( ptry + (k-1) * ncv ), ncv,
172 & mpi_double_complex, comm, ierr )
173 ENDDO
174 IF ( npiv .GT. 0 ) THEN
175 DO k=1, nrhs_b
176 CALL mpi_unpack( bufr, lbufr_bytes, position,
177 & wcb( ptrx + (k-1)*npiv ), npiv,
178 & mpi_double_complex, comm, ierr )
179 END DO
180 END IF
181 lr_activated = (iw(ptrist(step(finode))+xxlr).GT.0)
182 compress_panel = (iw(ptrist(step(finode))+xxlr).GE.2)
183 oocwrite_compatible_with_blr =
184 & (.NOT.lr_activated.OR.(.NOT.compress_panel).OR.
185 & (keep(485).EQ.0)
186 & )
187 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr) THEN
188 CALL zmumps_solve_get_ooc_node(
189 & finode,ptrfac,keep,a,la,step,
190 & keep8,n,dummy,ierr)
191 IF(ierr.LT.0)THEN
192 info(1)=ierr
193 info(2)=0
194 GOTO 260
195 ENDIF
196 ENDIF
197 IF ( iw(ptrist(step(finode))+xxlr) .GE. 2 .AND.
198 & keep(485) .EQ. 1 ) THEN
199 iwhdlr = iw(ptrist(step(finode))+xxf)
200 mtype_slave = 1
201 CALL zmumps_sol_slave_lr_u( finode, iwhdlr,
202 & -9999,
203 & wcb, lwcb,
204 & npiv, ncv,
205 & ptrx, ptry,
206 & jbdeb, jbfin,
207 & mtype_slave, keep, keep8,
208 & info(1), info(2) )
209 ELSE
210 apos = ptrfac(step(finode))
211 IF (keep(201) .EQ. 1) THEN
212 mtype_slave = 0
213 lda_slave = ncv
214 ELSE
215 mtype_slave = 1
216 lda_slave = npiv
217 ENDIF
218 CALL zmumps_solve_gemm_update
219 & ( a, la, apos, npiv,
220 & lda_slave,
221 & ncv,
222 & nrhs_b, wcb, lwcb,
223 & ptrx, npiv,
224 & ptry, ncv,
225 & mtype_slave, keep, one )
226 ENDIF
227 IF ((keep(201).GT.0).AND.oocwrite_compatible_with_blr) THEN
228 CALL zmumps_free_factors_for_solve(finode,ptrfac,
229 & keep(28),a,la,.true.,ierr)
230 IF(ierr.LT.0)THEN
231 info(1)=ierr
232 info(2)=0
233 GOTO 260
234 ENDIF
235 ENDIF
236 pleftwcb = pleftwcb - int(npiv,8) * int(nrhs_b,8)
237 pdest = mumps_procnode( procnode_steps(step(fpere)),
238 & keep(199) )
239 IF ( pdest .EQ. myid ) THEN
240 IF ( ptricb(step(finode)) .EQ. 0 ) THEN
241 ncb = iw( ptrist(step(finode)) + 2 + keep(ixsz) )
242 ptricb(step(finode)) = ncb + 1
243 END IF
244 j1 = ptrist(step(finode))+3+keep(ixsz)
245 omp_flag = .false.
246!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND.
247!$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) )
248 IF (omp_flag) THEN
249!$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSCOMP)
250 DO k=1, nrhs_b
251 ifr8 = ptry+int(k-1,8)*int(ncv,8)
252#if defined(__ve__)
253!NEC$ IVDEP
254#endif
255 DO i = 1,ncv
256 jj = iw(j1+i)
257 iposinrhscomp= abs(posinrhscomp_fwd(jj))
258 rhscomp(iposinrhscomp,jbdeb+k-1)=
259 & rhscomp(iposinrhscomp,jbdeb+k-1)
260 & + wcb(ifr8+int(i-1,8))
261 ENDDO
262 ENDDO
263!$OMP END PARALLEL DO
264 ELSE
265 DO k=1, nrhs_b
266 ifr8 = ptry+int(k-1,8)*int(ncv,8)
267#if defined(__ve__)
268!NEC$ IVDEP
269#endif
270 DO i = 1,ncv
271 jj = iw(j1+i)
272 iposinrhscomp= abs(posinrhscomp_fwd(jj))
273 rhscomp(iposinrhscomp,jbdeb+k-1)=
274 & rhscomp(iposinrhscomp,jbdeb+k-1)
275 & + wcb(ifr8+int(i-1,8))
276 ENDDO
277 ENDDO
278 ENDIF
279 ptricb(step(finode)) = ptricb(step(finode)) - ncv
280 IF ( ptricb( step( finode ) ) == 1 ) THEN
281 nstk_s(step(fpere)) = nstk_s(step(fpere)) - 1
282 ptricb(step(finode)) = 0
283 END IF
284 IF ( nstk_s(step(fpere)) .EQ. 0 ) THEN
285 ipool( leaf ) = fpere
286 leaf = leaf + 1
287 IF ( leaf > lpool ) THEN
288 WRITE(*,*)
289 & 'INTERNAL Error in ZMUMPS_TRAITER_MESSAGE_SOLVE',
290 & leaf, lpool
291 CALL mumps_abort()
292 END IF
293 ENDIF
294 ELSE
295 210 CONTINUE
296 CALL zmumps_buf_send_vcb( nrhs_b, finode, fpere,
297 & iw(ptrist(step( finode )) + 2 + keep(ixsz) ), ncv,ncv,
298 & iw(ptrist(step(finode))+4+ keep(ixsz) ),
299 & wcb( ptry ), jbdeb, jbfin,
300 & rhscomp, 1, 1, -9999, -9999,
301 & keep, pdest, contvec, comm, ierr )
302 IF ( ierr .EQ. -1 ) THEN
303 CALL zmumps_solve_recv_and_treat( .false., flag,
304 & bufr, lbufr, lbufr_bytes,
305 & myid, slavef, comm,
306 & n, nrhs, ipool, lpool, leaf,
307 & nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac,
308 & iwcb, liwcb,
309 & wcb, lwcb, poswcb, pleftwcb, posiwcb,
310 & ptricb, info, keep,keep8, dkeep, step,
311 & procnode_steps,
312 & rhscomp, lrhscomp, posinrhscomp_fwd
313 & , from_pp
314 & )
315 IF ( info( 1 ) .LT. 0 ) GOTO 270
316 GOTO 210
317 ELSE IF ( ierr .EQ. -2 ) THEN
318 info( 1 ) = -17
319 info( 2 ) = ( ncv + 4 ) * keep( 34 ) +
320 & ncv * keep( 35 )
321 GOTO 260
322 ELSE IF ( ierr .EQ. -3 ) THEN
323 info( 1 ) = -20
324 info( 2 ) = ( ncv + 4 ) * keep( 34 ) +
325 & ncv * keep( 35 )
326 END IF
327 END IF
328 pleftwcb = pleftwcb - int(ncv,8) * int(nrhs_b,8)
329 ELSEIF ( msgtag .EQ. terreur ) THEN
330 info(1) = -001
331 info(2) = msgsou
332 GOTO 270
333 ELSE IF ( (msgtag.EQ.update_load).OR.
334 & (msgtag.EQ.tag_dummy) ) THEN
335 GO TO 270
336 ELSE
337 info(1)=-100
338 info(2)=msgtag
339 GO TO 260
340 ENDIF
341 GO TO 270
342 260 CONTINUE
343 CALL zmumps_bdc_error( myid, slavef, comm, keep )
344 270 CONTINUE
345 RETURN
346 END SUBROUTINE zmumps_traiter_message_solve
347 SUBROUTINE zmumps_solve_node_fwd( INODE,
348 & LASTFSL0STA, LASTFSL0DYN,
349 & BUFR, LBUFR, LBUFR_BYTES,
350 & MYID, SLAVEF, COMM,
351 & N, IPOOL, LPOOL, LEAF,
352 & NBFIN, NSTK_S,
353 & IWCB, LIWCB,
354 & WCB, LWCB, A, LA, IW, LIW,
355 & NRHS, POSWCB, PLEFTWCB, POSIWCB,
356 & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS,
357 & FILS, STEP, FRERE, DAD,
358 & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE,
359 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD,
360 &
361 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
362 & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP
363 & , ERROR_WAS_BROADCASTED
364 & )
365 USE zmumps_sol_lr
366!$ USE ZMUMPS_SOL_L0OMP_M, ONLY: LOCK_FOR_SCATTER
367 USE zmumps_sol_l0omp_m, ONLY: nb_lock_max
368 USE zmumps_ooc
369 USE zmumps_buf
370 IMPLICIT NONE
371 INTEGER MTYPE
372 INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN
373 INTEGER LBUFR, LBUFR_BYTES
374 INTEGER MYID, SLAVEF, COMM
375 INTEGER LIWCB, LIW, POSIWCB
376 INTEGER(8) :: POSWCB, PLEFTWCB, LWCB
377 INTEGER(8) :: LA
378 INTEGER N, LPOOL, LEAF, NBFIN
379 INTEGER INFO( 80 ), KEEP( 500)
380 INTEGER(8) KEEP8(150)
381 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
382 INTEGER BUFR( LBUFR )
383 INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28))
384 INTEGER IWCB( LIWCB ), IW( LIW )
385 INTEGER NRHS
386 COMPLEX(kind=8) WCB( LWCB )
387 COMPLEX(kind=8) :: A( LA )
388 INTEGER(8) :: LRHS_ROOT
389 COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT )
390 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28))
391 INTEGER(8) :: PTRFAC(KEEP(28))
392 INTEGER PROCNODE_STEPS(KEEP(28))
393 INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28))
394 INTEGER ISTEP_TO_INIV2(KEEP(71)),
395 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
396 INTEGER POSINRHSCOMP_FWD(N), LRHSCOMP
397 COMPLEX(kind=8) RHSCOMP(LRHSCOMP, NRHS)
398 LOGICAL, intent(in) :: DO_NBSPARSE
399 INTEGER, intent(in) :: LRHS_BOUNDS
400 INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS)
401 LOGICAL, intent(in) :: FROM_PP
402 LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED
403 EXTERNAL zgemv, ztrsv, zgemm, ztrsm, mumps_procnode
404 INTEGER MUMPS_PROCNODE
405 COMPLEX(kind=8) ALPHA,ONE,ZERO
406 parameter(zero=(0.0d0,0.0d0),
407 & one=(1.0d0,0.0d0),
408 & alpha=(-1.0d0,0.0d0))
409 INTEGER :: IWHDLR
410 INTEGER JBDEB, JBFIN, NRHS_B
411 INTEGER LDADIAG
412 INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8
413 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING,
414 & npiv, ncb, liell, jj, nelim, ierr
415 INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL
416 INTEGER IPOSINRHSCOMP_TMP
417 INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex
418 LOGICAL FLAG
419 INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSCOMPLASTFSDYN
420 LOGICAL :: OMP_FLAG
421 include 'mumps_headers.h'
422 INTEGER(8) :: APOSDEB
423 INTEGER TempNROW, TempNCOL, PANEL_SIZE,
424 & JFIN, NBJ, NUPDATE_PANEL,
425 & TYPEF
426 INTEGER LD_WCBPIV
427 INTEGER LD_WCBCB
428 LOGICAL :: LDEQLIELLPANEL
429 LOGICAL :: CBINITZERO
430 INTEGER LDAJ, LDAJ_FIRST_PANEL
431 INTEGER LDAtemp
432 LOGICAL COMPRESS_PANEL, LR_ACTIVATED
433 LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR
434 INTEGER TMP_NBPANELS,
435 & i_pivrptr, i_pivr, ipanel
436 LOGICAL MUST_BE_PERMUTED
437 INTEGER :: SIZEBLOCK, NB, JCourant, NB_LOCK
438 include 'mpif.h'
439 include 'mumps_tags.h'
440 INTEGER DUMMY( 1 )
441 ERROR_WAS_BROADCASTED = .false.
442 dummy(1)=1
443 lr_activated = (iw(ptrist(step(inode))+xxlr).GT.0)
444 compress_panel = (iw(ptrist(step(inode))+xxlr).GE.2)
445 oocwrite_compatible_with_blr =
446 & (.NOT.lr_activated.OR.(.NOT.compress_panel).OR.
447 & (keep(485).EQ.0)
448 & )
449 IF (do_nbsparse) THEN
450 jbdeb= rhs_bounds(2*step(inode)-1)
451 jbfin= rhs_bounds(2*step(inode))
452 ELSE
453 jbdeb = 1
454 jbfin = nrhs
455 ENDIF
456 nrhs_b = jbfin-jbdeb+1
457 IF (do_nbsparse) THEN
458 if (jbdeb.GT.jbfin) then
459 write(6,*) " Internal error 1 in nbsparse :",
460 & jbdeb, jbfin
461 CALL mumps_abort()
462 endif
463 IF (jbdeb.LT.1 .OR. jbdeb.GT.nrhs .or.
464 & jbfin.LT.1 .OR. jbfin.GT.nrhs ) THEN
465 write(6,*) " Internal error 2 in nbsparse :",
466 & jbdeb, jbfin
467 CALL mumps_abort()
468 endif
469 ENDIF
470 IF ( inode .eq. keep( 38 ) .OR. inode .eq.keep( 20 ) ) THEN
471 liell = iw( ptrist( step(inode)) + 3 + keep(ixsz))
472 npiv = liell
473 nelim = 0
474 nslaves = 0
475 ipos = ptrist( step(inode)) + 5 + keep(ixsz)
476 ELSE
477 ipos = ptrist(step(inode)) + 2 + keep(ixsz)
478 liell = iw(ipos-2)+iw(ipos+1)
479 nelim = iw(ipos-1)
480 nslaves = iw( ptrist(step(inode)) + 5 + keep(ixsz) )
481 ipos = ipos + 1
482 npiv = iw(ipos)
483 ipos = ipos + 1
484 IF ((keep(201).GT.0).AND.oocwrite_compatible_with_blr) THEN
485 CALL zmumps_solve_get_ooc_node(
486 & inode,ptrfac,keep,a,la,step,
487 & keep8,n,must_be_permuted,ierr)
488 IF(ierr.LT.0)THEN
489 info(1)=ierr
490 info(2)=0
491 error_was_broadcasted = .false.
492 GOTO 270
493 ENDIF
494 IF (keep(201).EQ.1 .AND. keep(50).NE.1) THEN
495 CALL zmumps_ooc_pp_check_perm_freed(
496 & iw(ipos+1+2*liell+1+nslaves),
497 & must_be_permuted )
498 ENDIF
499 ENDIF
500 nslaves = iw( ptrist(step(inode)) + 5 + keep(ixsz))
501 ipos = ipos + 1 + nslaves
502 END IF
503 IF ( mtype .EQ. 1 .OR. keep(50) .NE. 0 ) THEN
504 j1 = ipos + 1
505 j2 = ipos + liell
506 j3 = ipos + npiv
507 ELSE
508 j1 = ipos + liell + 1
509 j2 = ipos + 2 * liell
510 j3 = ipos + liell + npiv
511 END IF
512 ncb = liell-npiv
513 IF (keep(50).NE.0) THEN
514 IF ( keep(459) .GT. 1 ) THEN
515 ldadiag = -99999
516 ELSE
517 ldadiag = npiv
518 ENDIF
519 ELSE
520 ldadiag = liell
521 ENDIF
522 IF ( inode .eq. keep( 38 ) .OR. inode .eq. keep(20) ) THEN
523 ifr8 = 0_8
524 iposinrhscomp_tmp = posinrhscomp_fwd(iw(j1))
525 ifr_ini8 = ifr8
526 omp_flag = .false.
527!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND.
528!$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) )
529 IF (omp_flag) THEN
530!$OMP PARALLEL DO PRIVATE(IFR8,JJ)
531 DO k=jbdeb,jbfin
532 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
533 DO jj = j1, j3
534 rhs_root(ifr8+int(jj-j1+1,8)) =
535 & rhscomp(iposinrhscomp_tmp+jj-j1,k)
536 ENDDO
537 ENDDO
538!$OMP END PARALLEL DO
539 ELSE
540 DO k=jbdeb,jbfin
541 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
542 DO jj = j1, j3
543 rhs_root(ifr8+int(jj-j1+1,8)) =
544 & rhscomp(iposinrhscomp_tmp+jj-j1,k)
545 ENDDO
546 ENDDO
547 ENDIF
548 IF ( npiv .LT. liell ) THEN
549 WRITE(*,*) ' Internal error 1 in ZMUMPS_SOLVE_NODE_FWD',
550 & npiv, liell
551 CALL mumps_abort()
552 END IF
553 GO TO 270
554 END IF
555 apos = ptrfac(step(inode))
556 IF ( (keep(201).EQ.1).AND.oocwrite_compatible_with_blr ) THEN
557 IF (mtype.EQ.1) THEN
558 IF ((mtype.EQ.1).AND.nslaves.NE.0) THEN
559 tempnrow= npiv+nelim
560 tempncol= npiv
561 ldaj_first_panel=tempnrow
562 ELSE
563 tempnrow= liell
564 tempncol= npiv
565 ldaj_first_panel=tempnrow
566 ENDIF
567 typef=typef_l
568 ELSE
569 tempncol= liell
570 tempnrow= npiv
571 ldaj_first_panel=tempncol
572 typef= typef_u
573 ENDIF
574 panel_size = zmumps_ooc_panel_size( ldaj_first_panel )
575 ENDIF
576 ppiv_courant = pleftwcb
577 pleftwcb = pleftwcb + int(liell,8) * int(nrhs_b,8)
578 IF ( poswcb - pleftwcb + 1_8 .LT. 0 ) THEN
579 info(1) = -11
580 CALL mumps_set_ierror(pleftwcb-poswcb-1_8, info(2))
581 error_was_broadcasted = .false.
582 GOTO 270
583 END IF
584 IF (keep(201) .EQ. 1 .AND. oocwrite_compatible_with_blr) THEN
585 ldeqliellpanel = .true.
586 ld_wcbpiv = liell
587 ld_wcbcb = liell
588 pcb_courant = ppiv_courant + npiv
589 ELSE
590 ldeqliellpanel = .false.
591 ld_wcbpiv = npiv
592 ld_wcbcb = ncb
593 pcb_courant = ppiv_courant + int(npiv,8)*int(nrhs_b,8)
594 ENDIF
595 fpere = dad(step(inode))
596 IF ( fpere .NE. 0 ) THEN
597 fpere_mapping = mumps_procnode( procnode_steps(step(fpere)),
598 & keep(199) )
599 ELSE
600 fpere_mapping = -1
601 ENDIF
602 IF ( lastfsl0dyn .LE. n ) THEN
603 cbinitzero = .true.
604 ELSE IF ( fpere_mapping .EQ. myid ) THEN
605 cbinitzero = .true.
606 ELSE
607 cbinitzero = .false.
608 ENDIF
609 CALL zmumps_rhscomp_to_wcb(
610 & npiv, ncb, liell, cbinitzero, ldeqliellpanel,
611 & rhscomp(1, jbdeb), lrhscomp, nrhs_b,
612 & posinrhscomp_fwd, n,
613 & wcb(ppiv_courant),
614 & iw, liw, j1, j3, j2, keep, dkeep)
615 IF ( npiv .NE. 0 ) THEN
616 IF ((keep(201).EQ.1).AND.oocwrite_compatible_with_blr) THEN
617 aposdeb = apos
618 j = 1
619 ipanel = 0
620 10 CONTINUE
621 ipanel = ipanel + 1
622 jfin = min(j+panel_size-1, npiv)
623 IF (iw(ipos+ liell + jfin) < 0) THEN
624 jfin=jfin+1
625 ENDIF
626 nbj = jfin-j+1
627 ldaj = ldaj_first_panel-j+1
628 IF ( (keep(50).NE.1).AND. must_be_permuted ) THEN
629 CALL zmumps_get_ooc_perm_ptr(typef, tmp_nbpanels,
630 & i_pivrptr, i_pivr, ipos+1+2*liell, iw, liw)
631 IF (npiv.EQ.(iw(i_pivrptr+ipanel-1)-1)) THEN
632 must_be_permuted=.false.
633 ELSE
634 CALL zmumps_permute_panel(
635 & iw( i_pivr+ iw(i_pivrptr+ipanel-1)-
636 & iw(i_pivrptr)),
637 & npiv-iw(i_pivrptr+ipanel-1)+1,
638 & iw(i_pivrptr+ipanel-1)-1,
639 & a(aposdeb),
640 & ldaj, nbj, j-1 )
641 ENDIF
642 ENDIF
643 nupdate_panel = ldaj - nbj
644 ppiv_panel = ppiv_courant+int(j-1,8)
645 pcb_panel = ppiv_panel+int(nbj,8)
646 apos1 = aposdeb+int(nbj,8)
647 IF (mtype.EQ.1) THEN
648#if defined(MUMPS_USE_BLAS2)
649 IF ( nrhs_b == 1 ) THEN
650 CALL ztrsv( 'L', 'N', 'U', nbj, a(aposdeb), ldaj,
651 & wcb(ppiv_panel), 1 )
652 IF (nupdate_panel.GT.0) THEN
653 CALL zgemv('N', nupdate_panel,nbj,alpha, a(apos1),
654 & ldaj, wcb(ppiv_panel), 1, one,
655 & wcb(pcb_panel), 1)
656 ENDIF
657 ELSE
658#endif
659 CALL ztrsm( 'L','L','N','U', nbj, nrhs_b, one,
660 & a(aposdeb), ldaj, wcb(ppiv_panel),
661 & liell )
662 IF (nupdate_panel.GT.0) THEN
663 CALL zgemm('N', 'N', nupdate_panel, nrhs_b, nbj,
664 & alpha,
665 & a(apos1), ldaj, wcb(ppiv_panel), liell, one,
666 & wcb(pcb_panel), liell)
667 ENDIF
668#if defined(mumps_use_blas2)
669 ENDIF
670#endif
671 ELSE
672#if defined(MUMPS_USE_BLAS2)
673 IF (nrhs_b == 1) THEN
674 CALL ztrsv( 'L', 'N', 'N', nbj, a(aposdeb), ldaj,
675 & wcb(ppiv_panel), 1 )
676 IF (nupdate_panel.GT.0) THEN
677 CALL zgemv('N',nupdate_panel, nbj, alpha, a(apos1),
678 & ldaj, wcb(ppiv_panel), 1,
679 & one, wcb(pcb_panel), 1 )
680 ENDIF
681 ELSE
682#endif
683 CALL ztrsm('L','L','N','N',nbj, nrhs_b, one,
684 & a(aposdeb), ldaj, wcb(ppiv_panel),
685 & liell)
686 IF (nupdate_panel.GT.0) THEN
687 CALL zgemm('N', 'N', nupdate_panel, nrhs_b, nbj,
688 & alpha,
689 & a(apos1), ldaj, wcb(ppiv_panel), liell, one,
690 & wcb(pcb_panel), liell)
691 ENDIF
692#if defined(MUMPS_USE_BLAS2)
693 ENDIF
694#endif
695 ENDIF
696 aposdeb = aposdeb+int(ldaj,8)*int(nbj,8)
697 j=jfin+1
698 IF ( j .LE. npiv ) GOTO 10
699 ELSE
700 IF ( iw(ptrist(step(inode))+xxlr) .GE. 2 .AND.
701 & keep(485) .EQ. 1 ) THEN
702 iwhdlr = iw(ptrist(step(inode))+xxf)
703 CALL zmumps_sol_fwd_lr_su (
704 & inode, n, iwhdlr, npiv, nslaves,
705 & iw, ipos, liw,
706 & liell, wcb, lwcb,
707 & ld_wcbpiv, ld_wcbcb,
708 & ppiv_courant, pcb_courant,
709 & rhscomp, lrhscomp, nrhs,
710 & posinrhscomp_fwd, jbdeb, jbfin,
711 & mtype, keep, keep8, oocwrite_compatible_with_blr,
712 & info(1), info(2) )
713 IF (info(1).LT.0) THEN
714 error_was_broadcasted = .false.
715 GOTO 270
716 ENDIF
717 ELSE IF ( keep(459) .GT. 1 .AND. keep(50) .NE. 0 ) THEN
718 CALL zmumps_solve_fwd_panels(
719 & a, la, apos,
720 & npiv, iw(ipos+liell+1),
721 & nrhs_b, wcb, lwcb, ld_wcbpiv,
722 & ppiv_courant, mtype, keep)
723 ELSE
724 CALL zmumps_solve_fwd_trsolve (
725 & a, la, apos,
726 & npiv, ldadiag,
727 & nrhs_b, wcb, lwcb, ld_wcbpiv,
728 & ppiv_courant, mtype, keep)
729 ENDIF
730 END IF
731 END IF
732 ncb = liell - npiv
733 IF ( mtype .EQ. 1 ) THEN
734 IF ( nslaves .EQ. 0 .OR. npiv .eq. 0 ) THEN
735 nupdate = ncb
736 ELSE
737 nupdate = nelim
738 END IF
739 IF (keep(459) .GT. 1 .AND. keep(50) .NE. 0) THEN
740 CALL mumps_geti8(apos1, iw(ptrist(step(inode))+xxr))
741 apos1 = apos + apos1 - int(npiv,8)*int(nupdate,8)
742 ELSE
743 apos1 = apos + int(npiv,8) * int(ldadiag,8)
744 ENDIF
745 ELSE
746 apos1 = apos + int(npiv,8)
747 nupdate = ncb
748 END IF
749 IF (keep(201).NE.1) THEN
750 IF ( iw(ptrist(step(inode))+xxlr) .LT. 2 .OR.
751 & keep(485).EQ.0) THEN
752 IF (mtype .EQ. 1) THEN
753 ldatemp = npiv
754 ELSE
755 ldatemp = liell
756 ENDIF
757 CALL zmumps_solve_gemm_update
758 & (a, la, apos1,
759 & npiv, ldatemp, nupdate,
760 & nrhs_b, wcb, lwcb, ppiv_courant, ld_wcbpiv,
761 & pcb_courant, ld_wcbcb,
762 & mtype, keep, one)
763 ENDIF
764 END IF
765 IF ( iw(ptrist(step(inode))+xxlr) .LT. 2 .OR.
766 & keep(485).EQ.0) THEN
767 IF (keep(201) .GT. 0 .AND. oocwrite_compatible_with_blr) THEN
768 CALL zmumps_sol_ld_and_reload(
769 & inode, n, npiv, liell, nelim, nslaves,
770 & ppiv_courant,
771 & iw, ipos, liw,
772 & a, la, apos,
773 & wcb, lwcb, ld_wcbpiv,
774 & rhscomp, lrhscomp, nrhs,
775 & posinrhscomp_fwd, jbdeb, jbfin,
776 & mtype, keep, oocwrite_compatible_with_blr,
777 & .false.
778 & )
779 ELSE
780 CALL zmumps_sol_ld_and_reload_panel (
781 & inode, n, npiv, liell, nelim, nslaves,
782 & ppiv_courant,
783 & iw, ipos, liw,
784 & a, la, apos,
785 & wcb, lwcb, ld_wcbpiv,
786 & rhscomp, lrhscomp, nrhs,
787 & posinrhscomp_fwd, jbdeb, jbfin,
788 & mtype, keep, oocwrite_compatible_with_blr,
789 & .false.
790 & )
791 ENDIF
792 ENDIF
793 IF ((keep(201).EQ.1).AND.oocwrite_compatible_with_blr)
794 &THEN
795 CALL zmumps_free_factors_for_solve(inode,ptrfac,keep(28),
796 & a,la,.true.,ierr)
797 IF(ierr.LT.0)THEN
798 info(1)=ierr
799 info(2)=0
800 error_was_broadcasted = .false.
801 GOTO 270
802 ENDIF
803 END IF
804 IF ( fpere .EQ. 0 ) THEN
805 pleftwcb = pleftwcb - int(liell,8) *int(nrhs_b,8)
806 GOTO 270
807 ENDIF
808 IF ( nupdate .NE. 0 .OR. ncb.EQ.0 ) THEN
809 IF (mumps_procnode(procnode_steps(step(fpere)),
810 & keep(199)) .EQ. myid) THEN
811 IF ( ncb .ne. 0 ) THEN
812 ptricb(step(inode)) = ncb + 1
813 nupdate_noncritical = nupdate
814 IF (lastfsl0dyn .LE. n) THEN
815 IF ( lastfsl0dyn .EQ. 0 ) THEN
816 iposinrhscomplastfsdyn = 0
817 ELSE
818 iposinrhscomplastfsdyn =
819 & abs(posinrhscomp_fwd(lastfsl0dyn))
820 ENDIF
821 DO i = 1, nupdate
822 IF ( abs(posinrhscomp_fwd( iw(j3+i) )) .GT.
823 & iposinrhscomplastfsdyn ) THEN
824 IF (abs(step(iw(j3+i))) .GT.
825 & abs(step( lastfsl0sta))
826 & .OR. keep(261) .NE. 1) THEN
827 nupdate_noncritical = i - 1
828 EXIT
829 ENDIF
830 ENDIF
831 ENDDO
832 ENDIF
833 omp_flag = .false.
834!$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND.
835!$ & (NUPDATE*NRHS_B .GE. KEEP(363)) )
836 IF (omp_flag) THEN
837!$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSCOMP_TMP)
838 DO k = jbdeb, jbfin
839 ifr8 = pcb_courant + int(k-jbdeb,8)*int(ld_wcbcb,8)
840#if defined(__ve__)
841!NEC$ IVDEP
842#endif
843 DO i = 1, nupdate_noncritical
844 iposinrhscomp_tmp =
845 & abs(posinrhscomp_fwd(iw(j3 + i)))
846 rhscomp( iposinrhscomp_tmp, k ) =
847 & rhscomp( iposinrhscomp_tmp, k )
848 & + wcb(ifr8 + int(i-1,8))
849 ENDDO
850 ENDDO
851!$OMP END PARALLEL DO
852 ELSE
853 DO k = jbdeb, jbfin
854 ifr8 = pcb_courant + int(k-jbdeb,8)*int(ld_wcbcb,8)
855#if defined(__ve__)
856!NEC$ IVDEP
857#endif
858 DO i = 1, nupdate_noncritical
859 iposinrhscomp_tmp =
860 & abs(posinrhscomp_fwd(iw(j3 + i)))
861 rhscomp( iposinrhscomp_tmp, k ) =
862 & rhscomp( iposinrhscomp_tmp, k )
863 & + wcb(ifr8 + int(i-1,8))
864 ENDDO
865 ENDDO
866 ENDIF
867 IF ( cbinitzero ) THEN
868 IF ( nupdate .NE. nupdate_noncritical) THEN
869 nb_lock = 1
870 IF (.NOT.do_nbsparse.AND.(keep(400).GT.1)) THEN
871 nb_lock = min(keep(400),nb_lock_max)
872 ENDIF
873 sizeblock = (jbfin-jbdeb+1+nb_lock-1) / nb_lock
874 DO nb = 1, nb_lock
875 jcourant = jbdeb+sizeblock*(nb-1)
876!$ CALL OMP_SET_LOCK(LOCK_FOR_SCATTER(NB))
877 DO k = jcourant, min(jbfin,jcourant+sizeblock-1)
878 ifr8 = pcb_courant + int(k-jbdeb,8)*int(ld_wcbcb,8)
879#if defined(__ve__)
880!NEC$ IVDEP
881#endif
882 DO i = nupdate_noncritical+1, nupdate
883 iposinrhscomp_tmp =
884 & abs(posinrhscomp_fwd(iw(j3 + i)))
885 rhscomp( iposinrhscomp_tmp, k ) =
886 & rhscomp( iposinrhscomp_tmp, k )
887 & + wcb(ifr8 + int(i-1,8))
888 ENDDO
889 ENDDO
890!$ CALL OMP_UNSET_LOCK(LOCK_FOR_SCATTER(NB))
891 ENDDO
892 ENDIF
893 ENDIF
894 ptricb(step( inode )) = ptricb(step( inode )) - nupdate
895 ELSE
896 ptricb(step( inode )) = -1
897 ENDIF
898 ELSE
899 210 CONTINUE
900 CALL zmumps_buf_send_vcb( nrhs_b, inode, fpere,
901 & ncb, ld_wcbcb,
902 & nupdate,
903 & iw( j3 + 1 ), wcb( pcb_courant ), jbdeb, jbfin,
904 & rhscomp, 1, 1, -9999, -9999,
905 & keep,
906 & mumps_procnode(procnode_steps(step(fpere)), keep(199)),
907 & contvec,
908 & comm, ierr )
909 IF ( ierr .EQ. -1 ) THEN
910 CALL zmumps_solve_recv_and_treat( .false., flag,
911 & bufr, lbufr, lbufr_bytes,
912 & myid, slavef, comm,
913 & n, nrhs, ipool, lpool, leaf,
914 & nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac,
915 & iwcb, liwcb,
916 & wcb, lwcb, poswcb, pleftwcb, posiwcb,
917 & ptricb, info, keep,keep8, dkeep, step,
918 & procnode_steps,
919 & rhscomp, lrhscomp, posinrhscomp_fwd
920 & , from_pp
921 & )
922 IF ( info( 1 ) .LT. 0 ) THEN
923 error_was_broadcasted = .true.
924 GOTO 270
925 ENDIF
926 GOTO 210
927 ELSE IF ( ierr .EQ. -2 ) THEN
928 info( 1 ) = -17
929 info( 2 ) = nupdate * keep( 35 ) +
930 & ( nupdate + 3 ) * keep( 34 )
931 error_was_broadcasted = .false.
932 GOTO 270
933 ELSE IF ( ierr .EQ. -3 ) THEN
934 info( 1 ) = -20
935 info( 2 ) = nupdate * keep( 35 ) +
936 & ( nupdate + 3 ) * keep( 34 )
937 error_was_broadcasted = .false.
938 GOTO 270
939 END IF
940 ENDIF
941 END IF
942 IF ( nslaves .NE. 0 .AND. mtype .eq. 1
943 & .and. npiv .NE. 0 ) THEN
944 DO islave = 1, nslaves
945 pdest = iw( ptrist(step(inode)) + 5 + islave +keep(ixsz))
946 CALL mumps_bloc2_get_slave_info(
947 & keep,keep8, inode, step, n, slavef,
948 & istep_to_iniv2, tab_pos_in_pere,
949 & islave, ncb - nelim,
950 & nslaves,
951 & effective_cb_size, firstindex )
952 222 CONTINUE
953 CALL zmumps_buf_send_master2slave( nrhs_b,
954 & inode, fpere,
955 & effective_cb_size, ld_wcbcb, ld_wcbpiv, npiv,
956 & jbdeb, jbfin,
957 & wcb( pcb_courant + nelim + firstindex - 1 ),
958 & wcb( ppiv_courant ),
959 & pdest, comm, keep, ierr )
960 IF ( ierr .EQ. -1 ) THEN
961 CALL zmumps_solve_recv_and_treat( .false., flag,
962 & bufr, lbufr, lbufr_bytes,
963 & myid, slavef, comm,
964 & n, nrhs, ipool, lpool, leaf,
965 & nbfin, nstk_s, iw, liw, a, la, ptrist,ptrfac,
966 & iwcb, liwcb,
967 & wcb, lwcb, poswcb, pleftwcb, posiwcb,
968 & ptricb, info, keep,keep8, dkeep, step,
969 & procnode_steps,
970 & rhscomp, lrhscomp, posinrhscomp_fwd
971 & , from_pp
972 & )
973 IF ( info( 1 ) .LT. 0 ) THEN
974 error_was_broadcasted = .true.
975 GOTO 270
976 ENDIF
977 GOTO 222
978 ELSE IF ( ierr .EQ. -2 ) THEN
979 info( 1 ) = -17
980 info( 2 ) = (npiv+effective_cb_size)*nrhs_b*keep(35) +
981 & 6 * keep( 34 )
982 error_was_broadcasted = .false.
983 GOTO 270
984 ELSE IF ( ierr .EQ. -3 ) THEN
985 info( 1 ) = -20
986 info( 2 ) = (npiv+effective_cb_size)*nrhs_b*keep(35) +
987 & 6 * keep( 34 )
988 error_was_broadcasted = .false.
989 GOTO 270
990 END IF
991 END DO
992 END IF
993 pleftwcb = pleftwcb - int(liell,8)*int(nrhs_b,8)
994 270 CONTINUE
995 RETURN
996 END SUBROUTINE zmumps_solve_node_fwd
997 RECURSIVE SUBROUTINE zmumps_solve_recv_and_treat( BLOQ, FLAG,
998 & BUFR, LBUFR, LBUFR_BYTES,
999 & MYID, SLAVEF, COMM,
1000 & N, NRHS, IPOOL, LPOOL, LEAF,
1001 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC,
1002 & IWCB, LIWCB,
1003 & WCB, LWCB, POSWCB,
1004 & PLEFTWCB, POSIWCB,
1005 & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS,
1006 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD
1007 & , FROM_PP
1008 & )
1009 IMPLICIT NONE
1010 LOGICAL bloq
1011 INTEGER lbufr, lbufr_bytes
1012 INTEGER myid, slavef, comm
1013 INTEGER n, nrhs, lpool, leaf, nbfin
1014 INTEGER liwcb, posiwcb
1015 INTEGER(8) :: poswcb, pleftwcb
1016 INTEGER liw
1017 INTEGER(8), INTENT(IN) :: la, lwcb
1018 INTEGER info( 80 ), keep( 500)
1019 INTEGER(8) keep8(150)
1020 DOUBLE PRECISION, INTENT(INOUT) :: dkeep(230)
1021 INTEGER bufr( lbufr ), ipool(lpool)
1022 INTEGER nstk_s( keep(28) )
1023 INTEGER iwcb( liwcb )
1024 INTEGER iw( liw )
1025 COMPLEX(kind=8) wcb( lwcb ), a( la )
1026 INTEGER ptricb(keep(28)), ptrist(keep(28))
1027 INTEGER(8) :: ptrfac(keep(28))
1028 INTEGER step(n)
1029 INTEGER procnode_steps(KEEP(28))
1030 LOGICAL flag
1031 INTEGER lrhscomp, posinrhscomp_fwd(n)
1032 COMPLEX(kind=8) rhscomp(lrhscomp,nrhs)
1033 LOGICAL, intent(in) :: from_pp
1034 include 'mpif.h'
1035 include 'mumps_tags.h'
1036 INTEGER :: ierr
1037 INTEGER :: status(mpi_status_size)
1038 INTEGER msgsou, msgtag, msglen
1039 flag = .false.
1040 IF ( bloq ) THEN
1041 flag = .false.
1042 CALL mpi_probe( mpi_any_source, mpi_any_tag,
1043 & comm, status, ierr )
1044 flag = .true.
1045 ELSE
1046 CALL mpi_iprobe( mpi_any_source, mpi_any_tag, comm,
1047 & flag, status, ierr )
1048 END IF
1049 IF ( flag ) THEN
1050 keep(266) = keep(266) -1
1051 msgsou = status( mpi_source )
1052 msgtag = status( mpi_tag )
1053 CALL mpi_get_count( status, mpi_packed, msglen, ierr )
1054 IF ( msglen .GT. lbufr_bytes ) THEN
1055 info(1) = -20
1056 info(2) = msglen
1057 CALL zmumps_bdc_error( myid, slavef, comm, keep )
1058 ELSE
1059 CALL mpi_recv( bufr, lbufr_bytes, mpi_packed,
1060 & msgsou, msgtag, comm, status, ierr )
1061 CALL zmumps_traiter_message_solve( bufr, lbufr, lbufr_bytes,
1062 & msgtag, msgsou, myid, slavef, comm,
1063 & n, nrhs, ipool, lpool, leaf,
1064 & nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac,
1065 & iwcb, liwcb,
1066 & wcb, lwcb, poswcb,
1067 & pleftwcb, posiwcb,
1068 & ptricb, info, keep,keep8, dkeep, step,
1069 & procnode_steps,
1070 & rhscomp, lrhscomp, posinrhscomp_fwd
1071 & , from_pp
1072 & )
1073 END IF
1074 END IF
1075 RETURN
1076 END SUBROUTINE zmumps_solve_recv_and_treat
1077 SUBROUTINE zmumps_rhscomp_to_wcb(
1078 & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL,
1079 & RHSCOMP, LRHSCOMP, NRHS_B,
1080 & POSINRHSCOMP_FWD, N,
1081 & WCB,
1082 & IW, LIW, J1, J3, J2, KEEP, DKEEP)
1083 IMPLICIT NONE
1084 INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N,
1085 & lrhscomp, nrhs_b,
1086 & liw, j1, j2, j3
1087 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL
1088 LOGICAL, INTENT( IN ) :: CBINITZERO
1089 INTEGER, INTENT( IN ) :: POSINRHSCOMP_FWD( N ), IW( LIW )
1090 COMPLEX(kind=8), INTENT( INOUT ) :: RHSCOMP( LRHSCOMP, NRHS_B )
1091 COMPLEX(kind=8), INTENT( OUT ) :: WCB( int(LIELL,8)*
1092 & int(nrhs_b,8) )
1093 INTEGER :: KEEP(500)
1094 DOUBLE PRECISION :: DKEEP(150)
1095 INTEGER, PARAMETER :: ZERO = (0.0d0,0.0d0)
1096 INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8
1097 INTEGER(8) :: PCB_COURANT
1098 INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSCOMP
1099 INTEGER(8) :: IFR8, IFR_ini8
1100 INCLUDE 'mpif.h'
1101 LOGICAL :: OMP_FLAG
1102 IF ( LDEQLIELLPANEL ) THEN
1103 LD_WCBPIV = liell
1104 ld_wcbcb = liell
1105 pcb_courant = ppiv_courant + npiv
1106 ELSE
1107 ld_wcbpiv = npiv
1108 ld_wcbcb = ncb
1109 pcb_courant = ppiv_courant + npiv * nrhs_b
1110 ENDIF
1111 IF ( ldeqliellpanel ) THEN
1112 DO k=1, nrhs_b
1113 ifr8 = ppiv_courant+int(k-1,8)*int(ld_wcbpiv,8)-1_8
1114 iposinrhscomp = posinrhscomp_fwd(iw(j1))
1115 DO jj = j1, j3
1116 ifr8 = ifr8 + 1_8
1117 wcb(ifr8) = rhscomp(iposinrhscomp,k)
1118 iposinrhscomp = iposinrhscomp + 1
1119 ENDDO
1120 IF (ncb.GT.0 .AND. .NOT. cbinitzero) THEN
1121#if defined(__ve__)
1122!NEC$ IVDEP
1123#endif
1124 DO jj = j3+1, j2
1125 j = iw(jj)
1126 ifr8 = ifr8 + 1_8
1127 iposinrhscomp = abs(posinrhscomp_fwd(j))
1128 wcb(ifr8) = rhscomp(iposinrhscomp,k)
1129 rhscomp(iposinrhscomp,k) = zero
1130 ENDDO
1131 ENDIF
1132 ENDDO
1133 ELSE
1134 pcb_courant = ppiv_courant + ld_wcbpiv*nrhs_b
1135 ifr8 = ppiv_courant - 1_8
1136 ifr_ini8 = ifr8
1137 iposinrhscomp = posinrhscomp_fwd(iw(j1))
1138 omp_flag = .false.
1139!$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND.
1140!$ & int(ncb,8)*int(nrhs_b,8) .GE. keep(363) )
1141 IF (omp_flag) THEN
1142!$OMP PARALLEL DO PRIVATE(JJ,IFR8)
1143 DO k=1, nrhs_b
1144 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
1145 DO jj = j1, j3
1146 wcb(ifr8+int(jj-j1+1,8)) =
1147 & rhscomp(iposinrhscomp+jj-j1,k)
1148 ENDDO
1149 ENDDO
1150!$OMP END PARALLEL DO
1151 ELSE
1152 DO k=1, nrhs_b
1153 ifr8 = ifr_ini8 + int(k-1,8)*int(npiv,8)
1154 DO jj = j1, j3
1155 wcb(ifr8+int(jj-j1+1,8)) =
1156 & rhscomp(iposinrhscomp+jj-j1,k)
1157 ENDDO
1158 ENDDO
1159 ENDIF
1160 ifr8 = pcb_courant - 1_8
1161 IF (ncb.GT.0 .AND. .NOT. cbinitzero) THEN
1162 ifr_ini8 = ifr8
1163 omp_flag = .false.
1164!$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND.
1165!$ & NCB*NRHS_B .GE. KEEP(363) )
1166 IF (omp_flag) THEN
1167!$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP)
1168 DO k=1, nrhs_b
1169 ifr8 = ifr_ini8+(k-1)*ncb
1170#if defined(__ve__)
1171!NEC$ IVDEP
1172#endif
1173 DO jj = j3 + 1, j2
1174 j = iw(jj)
1175 iposinrhscomp = abs(posinrhscomp_fwd(j))
1176 wcb(ifr8+int(jj-j3,8)) = rhscomp(iposinrhscomp,k)
1177 rhscomp(iposinrhscomp,k)=zero
1178 ENDDO
1179 ENDDO
1180!$OMP END PARALLEL DO
1181 ELSE
1182 DO k=1, nrhs_b
1183 ifr8 = ifr_ini8+(k-1)*ncb
1184#if defined(__ve__)
1185!nec$ ivdep
1186#endif
1187 DO jj = j3 + 1, j2
1188 j = iw(jj)
1189 iposinrhscomp = abs(posinrhscomp_fwd(j))
1190 wcb(ifr8+int(jj-j3,8)) = rhscomp(iposinrhscomp,k)
1191 rhscomp(iposinrhscomp,k)=zero
1192 ENDDO
1193 ENDDO
1194 ENDIF
1195 ENDIF
1196 ENDIF
1197 IF ( cbinitzero ) THEN
1198 omp_flag = .false.
1199!$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363)
1200 IF (omp_flag) THEN
1201!$OMP PARALLEL DO COLLAPSE(2)
1202 DO k = 1, nrhs_b
1203 DO jj = 1, ncb
1204 wcb(pcb_courant+int(k-1,8)*int(ld_wcbcb,8)+jj-1_8) = zero
1205 ENDDO
1206 ENDDO
1207!$OMP END PARALLEL DO
1208 ELSE
1209 DO k = 1, nrhs_b
1210 DO jj = 1, ncb
1211 wcb(pcb_courant+int(k-1,8)*int(ld_wcbcb,8)+jj-1_8) = zero
1212 ENDDO
1213 ENDDO
1214 ENDIF
1215 ENDIF
1216 RETURN
1217 END SUBROUTINE zmumps_rhscomp_to_wcb
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
alpha
#define alpha
Definition eval.h:35
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158
ztrsv
subroutine ztrsv(uplo, trans, diag, n, a, lda, x, incx)
ZTRSV
Definition ztrsv.f:149
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
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_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
mpi_probe
subroutine mpi_probe(source, tag, comm, status, ierr)
Definition mpi.f:449
mpi_unpack
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
mumps_bloc2_get_slave_info
subroutine mumps_bloc2_get_slave_info(keep, keep8, inode, step, n, slavef, istep_to_iniv2, tab_pos_in_pere islave, ncb, nslaves, size, first_index)
Definition mumps_type2_blocking.F:367
zmumps_buf
Definition zmumps_comm_buffer.F:14
zmumps_buf::zmumps_buf_send_master2slave
subroutine, public zmumps_buf_send_master2slave(nrhs, inode, ifath, eff_cb_size, ld_cb, ld_piv, npiv, jbdeb, jbfin, cb, sol, dest, comm, keep, ierr)
Definition zmumps_comm_buffer.F:427
zmumps_buf::zmumps_buf_send_vcb
subroutine, public zmumps_buf_send_vcb(nrhs_b, node1, node2, ncb, ldw, long, iw, w, jbdeb, jbfin, rhscomp, nrhs, lrhscomp, iposinrhscomp, npiv, keep, dest, tag, comm, ierr)
Definition zmumps_comm_buffer.F:505
zmumps_ooc
Definition zmumps_ooc.F:14
zmumps_ooc::zmumps_free_factors_for_solve
subroutine zmumps_free_factors_for_solve(inode, ptrfac, nsteps, a, la, flag, ierr)
Definition zmumps_ooc.F:1204
zmumps_ooc::zmumps_ooc_panel_size
integer function, public zmumps_ooc_panel_size(nnmax)
Definition zmumps_ooc.F:3404
zmumps_sol_l0omp_m
Definition zsol_omp_m.F:14
zmumps_sol_l0omp_m::nb_lock_max
integer, parameter nb_lock_max
Definition zsol_omp_m.F:16
zmumps_sol_lr
Definition zsol_lr.F:14
zmumps_sol_lr::zmumps_sol_slave_lr_u
subroutine zmumps_sol_slave_lr_u(inode, iwhdlr, npiv_global, wcb, lwcb, ldx, ldy, ptrx_init, ptry_init, jbdeb, jbfin, mtype, keep, keep8, iflag, ierror)
Definition zsol_lr.F:189
zmumps_sol_lr::zmumps_sol_fwd_lr_su
subroutine zmumps_sol_fwd_lr_su(inode, n, iwhdlr, npiv_global, nslaves, iw, ipos_init, liw, liell, wcb, lwcb, ld_wcbpiv, ld_wcbcb, ppiv_init, pcb_init, rhscomp, lrhscomp, nrhs, posinrhscomp_fwd, jbdeb, jbfin, mtype, keep, keep8, oocwrite_compatible_with_blr, iflag, ierror)
Definition zsol_lr.F:31
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865
mumps_geti8
subroutine mumps_geti8(i8, int_array)
Definition tools_common.F:888
zmumps_bdc_error
subroutine zmumps_bdc_error(myid, slavef, comm, keep)
Definition zbcast_int.F:38
zmumps_permute_panel
subroutine zmumps_permute_panel(ipiv, lpiv, ishift, the_panel, nbrow, nbcol, kbeforepanel)
Definition zooc_panel_piv.F:78
zmumps_ooc_pp_check_perm_freed
subroutine zmumps_ooc_pp_check_perm_freed(iw_location, must_be_permuted)
Definition zooc_panel_piv.F:349
zmumps_get_ooc_perm_ptr
subroutine zmumps_get_ooc_perm_ptr(typef, nbpanels, i_pivptr, i_piv, ipos, iw, liw)
Definition zooc_panel_piv.F:133
zmumps_solve_gemm_update
subroutine zmumps_solve_gemm_update(a, la, apos1, nx, lda, ny, nrhs_b, wcb, lwcb, ptrx, ldx, ptry, ldy, mtype, keep, coef_y)
Definition zsol_aux.F:1327
zmumps_solve_fwd_panels
subroutine zmumps_solve_fwd_panels(a, la, apos, npiv, iw, nrhs_b, wcb, lwcb, lda_wcb, ppiv_courant, mtype, keep)
Definition zsol_aux.F:1226
zmumps_solve_get_ooc_node
subroutine zmumps_solve_get_ooc_node(inode, ptrfac, keep, a, la, step, keep8, n, must_be_permuted, ierr)
Definition zsol_aux.F:733
zmumps_sol_ld_and_reload
subroutine zmumps_sol_ld_and_reload(inode, n, npiv, liell, nelim, nslaves, ppiv_courant, iw, ipos, liw, a, la, apos, wcb, lwcb, ld_wcbpiv, rhscomp, lrhscomp, nrhs, posinrhscomp_fwd, jbdeb, jbfin, mtype, keep, oocwrite_compatible_with_blr, ignore_k459)
Definition zsol_aux.F:1511
zmumps_solve_fwd_trsolve
subroutine zmumps_solve_fwd_trsolve(a, la, apos, npiv, ldadiag, nrhs_b, wcb, lwcb, lda_wcb, ppiv_courant, mtype, keep)
Definition zsol_aux.F:1148
zmumps_sol_ld_and_reload_panel
subroutine zmumps_sol_ld_and_reload_panel(inode, n, npiv, liell, nelim, nslaves, ppiv_courant, iw, ipos, liw, a, la, apos, wcb, lwcb, ld_wcbpiv, rhscomp, lrhscomp, nrhs, posinrhscomp_fwd, jbdeb, jbfin, mtype, keep, oocwrite_compatible_with_blr, ignore_k459)
Definition zsol_aux.F:1381
zmumps_rhscomp_to_wcb
subroutine zmumps_rhscomp_to_wcb(npiv, ncb, liell, cbinitzero, ldeqliellpanel, rhscomp, lrhscomp, nrhs_b, posinrhscomp_fwd, n, wcb, iw, liw, j1, j3, j2, keep, dkeep)
Definition zsol_fwd_aux.F:1083
zmumps_traiter_message_solve
recursive subroutine zmumps_traiter_message_solve(bufr, lbufr, lbufr_bytes, msgtag, msgsou, myid, slavef, comm, n, nrhs, ipool, lpool, leaf, nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac, iwcb, liwcb, wcb, lwcb, poswcb, pleftwcb, posiwcb, ptricb, info, keep, keep8, dkeep, step, procnode_steps, rhscomp, lrhscomp, posinrhscomp_fwd, from_pp)
Definition zsol_fwd_aux.F:27
zmumps_solve_recv_and_treat
recursive subroutine zmumps_solve_recv_and_treat(bloq, flag, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, nrhs, ipool, lpool, leaf, nbfin, nstk_s, iw, liw, a, la, ptrist, ptrfac, iwcb, liwcb, wcb, lwcb, poswcb, pleftwcb, posiwcb, ptricb, info, keep, keep8, dkeep, step, procnode_steps, rhscomp, lrhscomp, posinrhscomp_fwd, from_pp)
Definition zsol_fwd_aux.F:1009
zmumps_solve_node_fwd
subroutine zmumps_solve_node_fwd(inode, lastfsl0sta, lastfsl0dyn, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, ipool, lpool, leaf, nbfin, nstk_s, iwcb, liwcb, wcb, lwcb, a, la, iw, liw, nrhs, poswcb, pleftwcb, posiwcb, ptricb, ptrist, ptrfac, procnode_steps, fils, step, frere, dad, info, keep, keep8, dkeep, rhs_root, lrhs_root, mtype, rhscomp, lrhscomp, posinrhscomp_fwd istep_to_iniv2, tab_pos_in_pere, rhs_bounds, lrhs_bounds, do_nbsparse, from_pp, error_was_broadcasted)
Definition zsol_fwd_aux.F:365