OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
smumps_comm_buffer.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 MODULE smumps_buf
15 PRIVATE
16 PUBLIC :: smumps_buf_try_free_cb, smumps_buf_init,
17 & smumps_buf_ini_myid,
18 & smumps_buf_alloc_cb , smumps_buf_deall_cb ,
19 & smumps_buf_alloc_small_buf, smumps_buf_deall_small_buf,
20 & smumps_buf_alloc_load_buffer,smumps_buf_deall_load_buffer,
21 & smumps_buf_send_cb, smumps_buf_send_vcb,
22 & smumps_buf_send_1int, smumps_buf_send_desc_bande,
23 & smumps_buf_send_maplig, smumps_buf_send_maitre2,
24 & smumps_buf_send_contrib_type2,
25 & smumps_buf_send_blocfacto, smumps_buf_send_blfac_slave,
26 & smumps_buf_send_master2slave,
27 & smumps_buf_send_contrib_type3, smumps_buf_send_rtnelind,
28 & smumps_buf_send_root2slave, smumps_buf_send_root2son,
29 & smumps_buf_send_backvec,smumps_buf_send_update_load,
30 & smumps_buf_dist_irecv_size,
31 & smumps_buf_bcast_array, smumps_buf_all_empty,
32 & smumps_buf_broadcast, smumps_buf_send_not_mstr,
33 & smumps_buf_send_fils ,smumps_buf_deall_max_array
34 & ,smumps_buf_max_array_minsize
35 & ,smumps_buf_test
36 PUBLIC :: smumps_blr_pack_cb_lrb
37 & ,smumps_mpi_pack_lrb
38 & ,smumps_mpi_unpack_lrb
39 INTEGER next, req, content, ovhsize
40 parameter( next = 0, req = 1, content = 2, ovhsize = 2 )
41 INTEGER, SAVE :: sizeofint, sizeofreal, buf_myid
42 TYPE smumps_comm_buffer_type
43 INTEGER lbuf, head, tail,lbuf_int, ilastmsg
44 INTEGER, DIMENSION(:),POINTER :: content
45 END TYPE smumps_comm_buffer_type
46 TYPE ( smumps_comm_buffer_type ), SAVE :: buf_cb
47 TYPE ( smumps_comm_buffer_type ), SAVE :: buf_small
48 TYPE ( smumps_comm_buffer_type ), SAVE :: buf_load
49 INTEGER, SAVE :: size_rbuf_bytes
50 INTEGER, SAVE :: buf_lmax_array
51 REAL, DIMENSION(:), allocatable
52 & , SAVE, TARGET :: buf_max_array
53 PUBLIC :: buf_lmax_array, buf_max_array
54 CONTAINS
55 SUBROUTINE smumps_buf_try_free_cb()
56 CALL smumps_buf_try_free(buf_cb)
57 RETURN
58 END SUBROUTINE smumps_buf_try_free_cb
59 SUBROUTINE smumps_buf_try_free(B)
60 IMPLICIT NONE
61 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B
62 include 'mpif.h'
63 LOGICAL :: FLAG
64 INTEGER :: IERR_MPI
65 INTEGER :: STATUS(MPI_STATUS_SIZE)
66 IF ( b%HEAD .NE. b%TAIL ) THEN
67 10 CONTINUE
68 CALL mpi_test( b%CONTENT( b%HEAD + req ), flag,
69 & status, ierr_mpi )
70 IF ( flag ) THEN
71 b%HEAD = b%CONTENT( b%HEAD + next )
72 IF ( b%HEAD .EQ. 0 ) b%HEAD = b%TAIL
73 IF ( b%HEAD .NE. b%TAIL ) GOTO 10
74 END IF
75 END IF
76 IF ( b%HEAD .EQ. b%TAIL ) THEN
77 b%HEAD = 1
78 b%TAIL = 1
79 b%ILASTMSG = 1
80 END iF
81 RETURN
82 END SUBROUTINE smumps_buf_try_free
83 SUBROUTINE smumps_buf_ini_myid( MYID )
84 IMPLICIT NONE
85 INTEGER myid
86 buf_myid = myid
87 RETURN
88 END SUBROUTINE smumps_buf_ini_myid
89 SUBROUTINE smumps_buf_init( IntSize, RealSize )
90 IMPLICIT NONE
91 INTEGER intsize, realsize
92 sizeofint = intsize
93 sizeofreal = realsize
94 NULLIFY(buf_cb %CONTENT)
95 NULLIFY(buf_small%CONTENT)
96 NULLIFY(buf_load%CONTENT)
97 buf_cb%LBUF = 0
98 buf_cb%LBUF_INT = 0
99 buf_cb%HEAD = 1
100 buf_cb%TAIL = 1
101 buf_cb%ILASTMSG = 1
102 buf_small%LBUF = 0
103 buf_small%LBUF_INT = 0
104 buf_small%HEAD = 1
105 buf_small%TAIL = 1
106 buf_small%ILASTMSG = 1
107 buf_load%LBUF = 0
108 buf_load%LBUF_INT = 0
109 buf_load%HEAD = 1
110 buf_load%TAIL = 1
111 buf_load%ILASTMSG = 1
112 RETURN
113 END SUBROUTINE smumps_buf_init
114 SUBROUTINE smumps_buf_alloc_cb( SIZE, IERR )
115 IMPLICIT NONE
116 INTEGER size, ierr
117 CALL buf_alloc( buf_cb, SIZE, ierr )
118 RETURN
119 END SUBROUTINE smumps_buf_alloc_cb
120 SUBROUTINE smumps_buf_alloc_small_buf( SIZE, IERR )
121 IMPLICIT NONE
122 INTEGER size, ierr
123 CALL buf_alloc( buf_small, SIZE, ierr )
124 RETURN
125 END SUBROUTINE smumps_buf_alloc_small_buf
126 SUBROUTINE smumps_buf_alloc_load_buffer( SIZE, IERR )
127 IMPLICIT NONE
128 INTEGER size, ierr
129 CALL buf_alloc( buf_load, SIZE, ierr )
130 RETURN
131 END SUBROUTINE smumps_buf_alloc_load_buffer
132 SUBROUTINE smumps_buf_deall_load_buffer( IERR )
133 IMPLICIT NONE
134 INTEGER ierr
135 CALL buf_deall( buf_load, ierr )
136 RETURN
137 END SUBROUTINE smumps_buf_deall_load_buffer
138 SUBROUTINE smumps_buf_deall_max_array()
139 IMPLICIT NONE
140 IF (allocated( buf_max_array)) DEALLOCATE( buf_max_array )
141 RETURN
142 END SUBROUTINE smumps_buf_deall_max_array
143 SUBROUTINE smumps_buf_max_array_minsize(NFS4FATHER,IERR)
144 IMPLICIT NONE
145 INTEGER ierr, nfs4father
146 ierr = 0
147 IF (allocated( buf_max_array)) THEN
148 IF (buf_lmax_array .GE. nfs4father) RETURN
149 DEALLOCATE( buf_max_array )
150 ENDIF
151 ALLOCATE(buf_max_array(nfs4father),stat=ierr)
152 IF ( ierr .GT. 0 ) THEN
153 ierr = -1
154 RETURN
155 END IF
156 buf_lmax_array=nfs4father
157 RETURN
158 END SUBROUTINE smumps_buf_max_array_minsize
159 SUBROUTINE smumps_buf_deall_cb( IERR )
160 IMPLICIT NONE
161 INTEGER IERR
162 CALL buf_deall( buf_cb, ierr )
163 RETURN
164 END SUBROUTINE smumps_buf_deall_cb
165 SUBROUTINE smumps_buf_deall_small_buf( IERR )
166 IMPLICIT NONE
167 INTEGER ierr
168 CALL buf_deall( buf_small, ierr )
169 RETURN
170 END SUBROUTINE smumps_buf_deall_small_buf
171 SUBROUTINE buf_alloc( BUF, SIZE, IERR )
172 IMPLICIT NONE
173 TYPE ( smumps_comm_buffer_type ) :: buf
174 INTEGER SIZE, IERR
175 ierr = 0
176 buf%LBUF = SIZE
177 buf%LBUF_INT = ( SIZE + sizeofint - 1 ) / sizeofint
178 IF ( associated ( buf%CONTENT ) ) DEALLOCATE( buf%CONTENT )
179 ALLOCATE( buf%CONTENT( buf%LBUF_INT ), stat = ierr )
180 IF (ierr .NE. 0) THEN
181 NULLIFY( buf%CONTENT )
182 ierr = -1
183 buf%LBUF = 0
184 buf%LBUF_INT = 0
185 END IF
186 buf%HEAD = 1
187 buf%TAIL = 1
188 buf%ILASTMSG = 1
189 RETURN
190 END SUBROUTINE buf_alloc
191 SUBROUTINE buf_deall( BUF, IERR )
192 IMPLICIT NONE
193 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF
194 INTEGER :: IERR
195 include 'mpif.h'
196 INTEGER :: IERR_MPI
197 INTEGER :: STATUS(MPI_STATUS_SIZE)
198 LOGICAL :: FLAG
199 IF ( .NOT. associated ( buf%CONTENT ) ) THEN
200 buf%HEAD = 1
201 buf%LBUF = 0
202 buf%LBUF_INT = 0
203 buf%TAIL = 1
204 buf%ILASTMSG = 1
205 RETURN
206 END IF
207 DO WHILE ( buf%HEAD.NE.0 .AND. buf%HEAD .NE. buf%TAIL )
208 CALL mpi_test(buf%CONTENT( buf%HEAD + req ), flag,
209 & status, ierr_mpi)
210 IF ( .not. flag ) THEN
211 WRITE(*,*) '** Warning: trying to cancel a request.'
212 WRITE(*,*) '** This might be problematic'
213 CALL mpi_cancel( buf%CONTENT( buf%HEAD + req ), ierr_mpi )
214 CALL mpi_request_free( buf%CONTENT( buf%HEAD + req ),
215 & ierr_mpi )
216 END IF
217 buf%HEAD = buf%CONTENT( buf%HEAD + next )
218 END DO
219 DEALLOCATE( buf%CONTENT )
220 NULLIFY( buf%CONTENT )
221 buf%LBUF = 0
222 buf%LBUF_INT = 0
223 buf%HEAD = 1
224 buf%TAIL = 1
225 buf%ILASTMSG = 1
226 RETURN
227 END SUBROUTINE buf_deall
228 SUBROUTINE smumps_buf_send_cb( NBROWS_ALREADY_SENT,
229 & INODE, FPERE, NFRONT, LCONT,
230 & NASS, NPIV,
231 & IWROW, IWCOL, A, PACKED_CB,
232 & DEST, TAG, COMM, KEEP, IERR )
233 IMPLICIT NONE
234 INTEGER DEST, tag, comm, ierr
235 INTEGER nbrows_already_sent
236 INTEGER, INTENT(INOUT) :: keep(500)
237 INTEGER INODE, fpere, nfront, lcont, nass, npiv
238 INTEGER iwrow( lcont ), iwcol( lcont )
239 REAL A( * )
240 LOGICAL packed_cb
241 include 'mpif.h'
242 INTEGER :: ierr_mpi
243 INTEGER nbrows_packet
244 INTEGER position, ireq, ipos, i, J1
245 INTEGER size1, size2, size_pack, size_av, size_av_reals
246 INTEGER izero, ione
247 INTEGER sizecb
248 INTEGER lcont_sent
249 INTEGER dest2(1)
250 parameter( izero = 0, ione = 1 )
251 LOGICAL recv_buf_smaller_than_send
252 DOUBLE PRECISION tmp
253 dest2(1) = dest
254 ierr = 0
255 IF (nbrows_already_sent .EQ. 0) THEN
256 CALL mpi_pack_size( 11 + lcont + lcont, mpi_integer,
257 & comm, size1, ierr_mpi)
258 ELSE
259 CALL mpi_pack_size( 5, mpi_integer, comm, size1, ierr_mpi)
260 ENDIF
261 CALL smumps_buf_size_available( buf_cb, size_av )
262 IF ( size_av .LT. size_rbuf_bytes ) THEN
263 recv_buf_smaller_than_send = .false.
264 ELSE
265 size_av = size_rbuf_bytes
266 recv_buf_smaller_than_send = .true.
267 ENDIF
268 size_av_reals = ( size_av - size1 ) / sizeofreal
269 IF (size_av_reals < 0 ) THEN
270 nbrows_packet = 0
271 ELSE
272 IF (packed_cb) THEN
273 tmp=2.0d0*dble(nbrows_already_sent)+1.0d0
274 nbrows_packet = int(
275 & ( sqrt( tmp * tmp
276 & + 8.0d0 * dble(size_av_reals)) - tmp )
277 & / 2.0d0 )
278 ELSE
279 IF (lcont.EQ.0) THEN
280 nbrows_packet = 0
281 ELSE
282 nbrows_packet = size_av_reals / lcont
283 ENDIF
284 ENDIF
285 ENDIF
286 10 CONTINUE
287 nbrows_packet = max(0,
288 & min(nbrows_packet, lcont - nbrows_already_sent))
289 IF (nbrows_packet .EQ. 0 .AND. lcont .NE. 0) THEN
290 IF (recv_buf_smaller_than_send) THEN
291 ierr = -3
292 GOTO 100
293 ELSE
294 ierr = -1
295 GOTO 100
296 ENDIF
297 ENDIF
298 IF (packed_cb) THEN
299 sizecb = (nbrows_already_sent*nbrows_packet)+(nbrows_packet
300 & *(nbrows_packet+1))/2
301 ELSE
302 sizecb = nbrows_packet * lcont
303 ENDIF
304 CALL mpi_pack_size( sizecb, mpi_real,
305 & comm, size2, ierr_mpi )
306 size_pack = size1 + size2
307 IF (size_pack .GT. size_av ) THEN
308 nbrows_packet = nbrows_packet - 1
309 IF (nbrows_packet > 0) THEN
310 GOTO 10
311 ELSE
312 IF (recv_buf_smaller_than_send) THEN
313 ierr=-3
314 GOTO 100
315 ELSE
316 ierr = -1
317 GOTO 100
318 ENDIF
319 ENDIF
320 ENDIF
321 IF (nbrows_packet + nbrows_already_sent.NE.lcont .AND.
322 & size_pack .LT. size_rbuf_bytes / 4
323 & .AND.
324 & .NOT. recv_buf_smaller_than_send)
325 & THEN
326 ierr = -1
327 GOTO 100
328 ENDIF
329 CALL buf_look( buf_cb, ipos, ireq, size_pack, ierr,
330 & ione , dest2)
331 IF (ierr .EQ. -1 .OR. ierr .EQ. -2) THEN
332 nbrows_packet = nbrows_packet - 1
333 IF ( nbrows_packet > 0 ) GOTO 10
334 ENDIF
335 IF ( ierr .LT. 0 ) GOTO 100
336 position = 0
337 CALL mpi_pack( inode, 1, mpi_integer,
338 & buf_cb%CONTENT( ipos ), size_pack,
339 & position, comm, ierr_mpi )
340 CALL mpi_pack( fpere, 1, mpi_integer,
341 & buf_cb%CONTENT( ipos ), size_pack,
342 & position, comm, ierr_mpi )
343 IF (packed_cb) THEN
344 lcont_sent=-lcont
345 ELSE
346 lcont_sent=lcont
347 ENDIF
348 CALL mpi_pack( lcont_sent, 1, mpi_integer,
349 & buf_cb%CONTENT( ipos ), size_pack,
350 & position, comm, ierr_mpi )
351 CALL mpi_pack( nbrows_already_sent, 1, mpi_integer,
352 & buf_cb%CONTENT( ipos ), size_pack,
353 & position, comm, ierr_mpi )
354 CALL mpi_pack( nbrows_packet, 1, mpi_integer,
355 & buf_cb%CONTENT( ipos ), size_pack,
356 & position, comm, ierr_mpi )
357 IF (nbrows_already_sent == 0) THEN
358 CALL mpi_pack( lcont, 1, mpi_integer,
359 & buf_cb%CONTENT( ipos ), size_pack,
360 & position, comm, ierr_mpi )
361 CALL mpi_pack( nass-npiv, 1, mpi_integer,
362 & buf_cb%CONTENT( ipos ), size_pack,
363 & position, comm, ierr_mpi )
364 CALL mpi_pack( lcont , 1, mpi_integer,
365 & buf_cb%CONTENT( ipos ), size_pack,
366 & position, comm, ierr_mpi )
367 CALL mpi_pack( izero, 1, mpi_integer,
368 & buf_cb%CONTENT( ipos ), size_pack,
369 & position, comm, ierr_mpi )
370 CALL mpi_pack( ione, 1, mpi_integer,
371 & buf_cb%CONTENT( ipos ), size_pack,
372 & position, comm, ierr_mpi )
373 CALL mpi_pack( izero, 1, mpi_integer,
374 & buf_cb%CONTENT( ipos ), size_pack,
375 & position, comm, ierr_mpi )
376 CALL mpi_pack( iwrow, lcont, mpi_integer,
377 & buf_cb%CONTENT( ipos ), size_pack,
378 & position, comm, ierr_mpi )
379 CALL mpi_pack( iwcol, lcont, mpi_integer,
380 & buf_cb%CONTENT( ipos ), size_pack,
381 & position, comm, ierr_mpi )
382 ENDIF
383 IF ( lcont .NE. 0 ) THEN
384 j1 = 1 + nbrows_already_sent * nfront
385 IF (packed_cb) THEN
386 DO i = nbrows_already_sent+1,
387 & nbrows_already_sent+nbrows_packet
388 CALL mpi_pack( a( j1 ), i, mpi_real,
389 & buf_cb%CONTENT( ipos ), size_pack,
390 & position, comm, ierr_mpi )
391 j1 = j1 + nfront
392 END DO
393 ELSE
394 DO i = nbrows_already_sent+1,
395 & nbrows_already_sent+nbrows_packet
396 CALL mpi_pack( a( j1 ), lcont, mpi_real,
397 & buf_cb%CONTENT( ipos ), size_pack,
398 & position, comm, ierr_mpi )
399 j1 = j1 + nfront
400 END DO
401 ENDIF
402 END IF
403 keep(266)=keep(266)+1
404 CALL mpi_isend( buf_cb%CONTENT( ipos ), position, mpi_packed,
405 & dest, tag, comm, buf_cb%CONTENT( ireq ),
406 & ierr_mpi )
407 IF ( size_pack .LT. position ) THEN
408 WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',size_pack,
409 & position
410 CALL mumps_abort()
411 END IF
412 IF ( size_pack .NE. position )
413 & CALL buf_adjust( buf_cb, position )
414 nbrows_already_sent = nbrows_already_sent + nbrows_packet
415 IF (nbrows_already_sent .NE. lcont ) THEN
416 ierr = -1
417 RETURN
418 ENDIF
419 100 CONTINUE
420 RETURN
421 END SUBROUTINE smumps_buf_send_cb
422 SUBROUTINE smumps_buf_send_master2slave( NRHS, INODE, IFATH,
423 & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV,
424 & JBDEB, JBFIN,
425 & CB, SOL,
426 & DEST, COMM, KEEP, IERR )
427 IMPLICIT NONE
428 INTEGER nrhs, inode, ifath, eff_cb_size, ld_cb, ld_piv, npiv
429 INTEGER dest, comm, ierr, jbdeb, jbfin
430 REAL cb( ld_cb*(nrhs-1)+eff_cb_size )
431 REAL sol( max(1, ld_piv*(nrhs-1)+NPIV) )
432 INTEGER, INTENT(INOUT) :: keep(500)
433 include 'mpif.h'
434 include 'mumps_tags.h'
435 INTEGER :: ierr_mpi
436 INTEGER size, size1, size2, k
437 INTEGER position, ireq, ipos
438 INTEGER ione
439 INTEGER dest2(1)
440 parameter( ione=1 )
441 dest2(1) = dest
442 ierr = 0
443 CALL mpi_pack_size( 6, mpi_integer, comm, size1, ierr )
444 CALL mpi_pack_size( nrhs * (eff_cb_size + npiv),
445 & mpi_real, comm,
446 & size2, ierr_mpi )
447 SIZE = size1 + size2
448 CALL buf_look( buf_cb, ipos, ireq, SIZE, ierr,
449 & ione , dest2
450 & )
451 IF ( ierr .LT. 0 ) THEN
452 RETURN
453 ENDIF
454 position = 0
455 CALL mpi_pack( inode, 1, mpi_integer,
456 & buf_cb%CONTENT( ipos ), SIZE,
457 & position, comm, ierr_mpi )
458 CALL mpi_pack( ifath, 1, mpi_integer,
459 & buf_cb%CONTENT( ipos ), SIZE,
460 & position, comm, ierr_mpi )
461 CALL mpi_pack( eff_cb_size , 1, mpi_integer,
462 & buf_cb%CONTENT( ipos ), SIZE,
463 & position, comm, ierr_mpi )
464 CALL mpi_pack( npiv , 1, mpi_integer,
465 & buf_cb%CONTENT( ipos ), SIZE,
466 & position, comm, ierr_mpi )
467 CALL mpi_pack( jbdeb , 1, mpi_integer,
468 & buf_cb%CONTENT( ipos ), SIZE,
469 & position, comm, ierr_mpi )
470 CALL mpi_pack( jbfin , 1, mpi_integer,
471 & buf_cb%CONTENT( ipos ), SIZE,
472 & position, comm, ierr_mpi )
473 DO k = 1, nrhs
474 CALL mpi_pack( cb( 1 + ld_cb * (k-1) ),
475 & eff_cb_size, mpi_real,
476 & buf_cb%CONTENT( ipos ), SIZE,
477 & position, comm, ierr_mpi )
478 END DO
479 IF ( npiv .GT. 0 ) THEN
480 DO k=1, nrhs
481 CALL mpi_pack( sol(1+ld_piv*(k-1)),
482 & npiv, mpi_real,
483 & buf_cb%CONTENT( ipos ), SIZE,
484 & position, comm, ierr_mpi )
485 ENDDO
486 END IF
487 keep(266)=keep(266)+1
488 CALL mpi_isend( buf_cb%CONTENT( ipos ), position, mpi_packed,
489 & dest, master2slave, comm,
490 & buf_cb%CONTENT( ireq ), ierr_mpi )
491 IF ( SIZE .LT. position ) THEN
492 WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ',
493 & SIZE, position
494 CALL mumps_abort()
495 END IF
496 IF ( SIZE .NE. position ) CALL buf_adjust( buf_cb, position )
497 RETURN
498 END SUBROUTINE smumps_buf_send_master2slave
499 SUBROUTINE smumps_buf_send_vcb( NRHS_B, NODE1, NODE2, NCB, LDW,
500 & LONG,
501 & IW, W, JBDEB, JBFIN,
502 & RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, NPIV,
503 & KEEP,
504 & DEST, TAG, COMM, IERR )
505 IMPLICIT NONE
506 INTEGER ldw, dest, tag, comm, ierr
507 INTEGER nrhs_b, node1, node2, ncb, long, jbdeb, JBFIN
508 INTEGER iw( max( 1, long ) )
509 INTEGER, INTENT(IN) :: lrhscomp, nrhs, IPOSINRHSCOMP, npiv
510 REAL w( max( 1, ldw * nrhs_b ) )
511 REAL rhscomp(lrhscomp,nrhs)
512 INTEGER, INTENT(INOUT) :: KEEP(500)
513 include 'mpif.h'
514 INTEGER :: ierr_mpi
515 INTEGER position, IREQ, ipos
516 INTEGER size1, size2, SIZE, k
517 INTEGER ione
518 INTEGER dest2(1)
519 parameter( ione=1 )
520 dest2(1)=dest
521 ierr = 0
522 IF ( node2 .EQ. 0 ) THEN
523 CALL mpi_pack_size( 4+long, mpi_integer, comm, size1,
524 & ierr_mpi )
525 ELSE
526 CALL mpi_pack_size( 6+long, mpi_integer, comm, size1,
527 & ierr_mpi )
528 END IF
529 size2 = 0
530 IF ( long .GT. 0 ) THEN
531 CALL mpi_pack_size( nrhs_b*long, mpi_real,
532 & comm, size2, ierr_mpi )
533 END IF
534 SIZE = size1 + size2
535 CALL buf_look( buf_cb, ipos, ireq, SIZE, ierr,
536 & ione , dest2
537 & )
538 IF ( ierr .LT. 0 ) THEN
539 RETURN
540 ENDIF
541 position = 0
542 CALL mpi_pack( node1, 1, mpi_integer,
543 & buf_cb%CONTENT( ipos ), SIZE,
544 & position, comm, ierr_mpi )
545 IF ( node2 .NE. 0 ) THEN
546 CALL mpi_pack( node2, 1, mpi_integer,
547 & buf_cb%CONTENT( ipos ), SIZE,
548 & position, comm, ierr_mpi )
549 CALL mpi_pack( ncb, 1, mpi_integer,
550 & buf_cb%CONTENT( ipos ), SIZE,
551 & position, comm, ierr_mpi )
552 ENDIF
553 CALL mpi_pack( jbdeb, 1, mpi_integer,
554 & buf_cb%CONTENT( ipos ), SIZE,
555 & position, comm, ierr_mpi )
556 CALL mpi_pack( jbfin, 1, mpi_integer,
557 & buf_cb%CONTENT( ipos ), SIZE,
558 & position, comm, ierr_mpi )
559 CALL mpi_pack( long, 1, mpi_integer,
560 & buf_cb%CONTENT( ipos ), SIZE,
561 & position, comm, ierr_mpi )
562 IF ( long .GT. 0 ) THEN
563 CALL mpi_pack( iw, long, mpi_integer,
564 & buf_cb%CONTENT( ipos ), SIZE,
565 & position, comm, ierr_mpi )
566 IF (node2.EQ.0) THEN
567 DO k=1, nrhs_b
568 IF (npiv.GT.0) THEN
569 CALL mpi_pack( rhscomp(iposinrhscomp,jbdeb+k-1), npiv,
570 & mpi_real,
571 & buf_cb%CONTENT( ipos ), SIZE,
572 & position, comm, ierr_mpi )
573 ENDIF
574 IF (long-npiv .NE.0) THEN
575 CALL mpi_pack( w(npiv+1+(k-1)*ldw), long-npiv,
576 & mpi_real,
577 & buf_cb%CONTENT( ipos ), SIZE,
578 & position, comm, ierr_mpi )
579 ENDIF
580 END DO
581 ELSE
582 DO k=1, nrhs_b
583 CALL mpi_pack( w(1+(k-1)*ldw), long, mpi_real,
584 & buf_cb%CONTENT( ipos ), SIZE,
585 & position, comm, ierr_mpi )
586 END DO
587 ENDIF
588 END IF
589 keep(266)=keep(266)+1
590 CALL mpi_isend( buf_cb%CONTENT( ipos ), position, mpi_packed,
591 & dest, tag, comm, buf_cb%CONTENT( ireq ),
592 & ierr_mpi )
593 IF ( SIZE .NE. position ) CALL buf_adjust( buf_cb, position )
594 RETURN
595 END SUBROUTINE smumps_buf_send_vcb
596 SUBROUTINE smumps_buf_send_1int( I, DEST, TAG, COMM,
597 & KEEP, IERR )
598 IMPLICIT NONE
599 INTEGER i
600 INTEGER dest, tag, comm, ierr
601 INTEGER, INTENT(INOUT) :: keep(500)
602 include 'mpif.h'
603 INTEGER :: ierr_mpi
604 INTEGER ipos, ireq, msg_size, position
605 INTEGER ione
606 INTEGER dest2(1)
607 parameter( ione=1 )
608 dest2(1)=dest
609 ierr = 0
610 CALL mpi_pack_size( 1, mpi_integer,
611 & comm, msg_size, ierr_mpi )
612 CALL buf_look( buf_small, ipos, ireq, msg_size, ierr,
613 & ione , dest2
614 & )
615 IF ( ierr .LT. 0 ) THEN
616 write(6,*) ' Internal error in SMUMPS_BUF_SEND_1INT',
617 & ' Buf size (bytes)= ',buf_small%LBUF
618 RETURN
619 ENDIF
620 position=0
621 CALL mpi_pack( i, 1,
622 & mpi_integer, buf_small%CONTENT( ipos ),
623 & msg_size,
624 & position, comm, ierr_mpi )
625 keep(266)=keep(266)+1
626 CALL mpi_isend( buf_small%CONTENT(ipos), msg_size,
627 & mpi_packed, dest, tag, comm,
628 & buf_small%CONTENT( ireq ), ierr_mpi )
629 RETURN
630 END SUBROUTINE smumps_buf_send_1int
631 SUBROUTINE smumps_buf_all_empty(CHECK_COMM_NODES,
632 & CHECK_COMM_LOAD,FLAG)
633 LOGICAL, INTENT(IN) :: check_comm_nodes, check_comm_load
634 LOGICAL, INTENT(OUT) :: flag
635 LOGICAL flag1, flag2, flag3
636 flag = .true.
637 IF (check_comm_nodes) THEN
638 CALL smumps_buf_empty( buf_small, flag1 )
639 CALL smumps_buf_empty( buf_cb, flag2 )
640 flag = flag .AND. flag1 .AND. flag2
641 ENDIF
642 IF ( check_comm_load ) THEN
643 CALL smumps_buf_empty( buf_load, flag3 )
644 flag = flag .AND. flag3
645 ENDIF
646 RETURN
647 END SUBROUTINE smumps_buf_all_empty
648 SUBROUTINE smumps_buf_empty( B, FLAG )
649 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B
650 LOGICAL :: FLAG
651 INTEGER SIZE_AVAIL
652 CALL smumps_buf_size_available(b, size_avail)
653 flag = ( b%HEAD == b%TAIL )
654 RETURN
655 END SUBROUTINE smumps_buf_empty
656 SUBROUTINE smumps_buf_size_available( B, SIZE_AV )
657 IMPLICIT NONE
658 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B
659 INTEGER SIZE_AV
660 include 'mpif.h'
661 INTEGER :: IERR_MPI
662 INTEGER :: STATUS(MPI_STATUS_SIZE)
663 LOGICAL :: FLAG
664 IF ( b%HEAD .NE. b%TAIL ) THEN
665 10 CONTINUE
666 CALL mpi_test( b%CONTENT( b%HEAD + req ), flag, status,
667 & ierr_mpi )
668 IF ( flag ) THEN
669 b%HEAD = b%CONTENT( b%HEAD + next )
670 IF ( b%HEAD .EQ. 0 ) b%HEAD = b%TAIL
671 IF ( b%HEAD .NE. b%TAIL ) GOTO 10
672 END IF
673 END IF
674 IF ( b%HEAD .EQ. b%TAIL ) THEN
675 b%HEAD = 1
676 b%TAIL = 1
677 b%ILASTMSG = 1
678 END IF
679 IF ( b%HEAD .LE. b%TAIL ) THEN
680 size_av = max( b%LBUF_INT - b%TAIL, b%HEAD - 2 )
681 ELSE
682 size_av = b%HEAD - b%TAIL - 1
683 END IF
684 size_av = min(size_av - ovhsize, size_av)
685 size_av = size_av * sizeofint
686 RETURN
687 END SUBROUTINE smumps_buf_size_available
688 SUBROUTINE smumps_buf_test()
689 INTEGER :: ipos, ireq, ierr
690 INTEGER, PARAMETER :: IONE=1
691 INTEGER :: msg_size
692 INTEGER :: dest2(1)
693 dest2=-10
694 msg_size=1
695 CALL buf_look( buf_cb, ipos, ireq, msg_size, ierr,
696 & ione , dest2,.true.)
697 RETURN
698 END SUBROUTINE smumps_buf_test
699 SUBROUTINE buf_look( B, IPOS, IREQ, MSG_SIZE, IERR,
700 & NDEST , PDEST, TEST_ONLY)
701 IMPLICIT NONE
702 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B
703 INTEGER, INTENT(IN) :: MSG_SIZE
704 INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR
705 LOGICAL, INTENT(IN), OPTIONAL :: TEST_ONLY
706 INTEGER NDEST
707 INTEGER, INTENT(IN) :: PDEST(max(1,NDEST))
708 include 'mpif.h'
709 INTEGER :: IERR_MPI
710 INTEGER :: MSG_SIZE_INT
711 INTEGER :: IBUF
712 LOGICAL :: FLAG
713 INTEGER :: STATUS(MPI_STATUS_SIZE)
714 ierr = 0
715 IF ( b%HEAD .NE. b%TAIL ) THEN
716 10 CONTINUE
717 CALL mpi_test( b%CONTENT( b%HEAD + req ), flag, status,
718 & ierr_mpi )
719 IF ( flag ) THEN
720 b%HEAD = b%CONTENT( b%HEAD + next )
721 IF ( b%HEAD .EQ. 0 ) b%HEAD = b%TAIL
722 IF ( b%HEAD .NE. b%TAIL ) GOTO 10
723 END IF
724 END IF
725 IF ( b%HEAD .EQ. b%TAIL ) THEN
726 b%HEAD = 1
727 b%TAIL = 1
728 b%ILASTMSG = 1
729 END iF
730 msg_size_int = ( msg_size + ( sizeofint - 1 ) ) / sizeofint
731 msg_size_int = msg_size_int + ovhsize
732 IF (present(test_only)) RETURN
733 flag = ( ( b%HEAD .LE. b%TAIL )
734 & .AND. (
735 & ( msg_size_int .LE. b%LBUF_INT - b%TAIL )
736 & .OR. ( msg_size_int .LE. b%HEAD - 2 ) ) )
737 & .OR.
738 & ( ( b%HEAD .GT. b%TAIL )
739 & .AND. ( msg_size_int .LE. b%HEAD - b%TAIL - 1 ) )
740 IF ( .NOT. flag
741 & ) THEN
742 ierr = -1
743 IF ( msg_size_int .GT. b%LBUF_INT - 1 ) THEN
744 ierr = -2
745 ENDIF
746 ipos = -1
747 ireq = -1
748 RETURN
749 END IF
750 IF ( b%HEAD .LE. b%TAIL ) THEN
751 IF ( msg_size_int .LE. b%LBUF_INT - b%TAIL + 1 ) THEN
752 ibuf = b%TAIL
753 ELSE IF ( msg_size_int .LE. b%HEAD - 1 ) THEN
754 ibuf = 1
755 END IF
756 ELSE
757 ibuf = b%TAIL
758 END IF
759 b%CONTENT( b%ILASTMSG + next ) = ibuf
760 b%ILASTMSG = ibuf
761 b%TAIL = ibuf + msg_size_int
762 b%CONTENT( ibuf + next ) = 0
763 ipos = ibuf + content
764 ireq = ibuf + req
765 RETURN
766 END SUBROUTINE buf_look
767 SUBROUTINE buf_adjust( BUF, SIZE )
768 IMPLICIT NONE
769 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF
770 INTEGER SIZE
771 INTEGER SIZE_INT
772 size_int = ( SIZE + sizeofint - 1 ) / sizeofint
773 size_int = size_int + ovhsize
774 buf%TAIL = buf%ILASTMSG + size_int
775 RETURN
776 END SUBROUTINE buf_adjust
777 SUBROUTINE smumps_buf_send_desc_bande(
778 & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL,
779 & NASS, NSLAVES_HDR, LIST_SLAVES,
780 & NSLAVES,
781 & ESTIM_NFS4FATHER_ATSON,
782 & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR
783 & , LRSTATUS
784 &)
785 IMPLICIT NONE
786 INTEGER comm, ierr, nfront
787 INTEGER, intent(in) :: inode
788 INTEGER, intent(in) :: nlig, ncol, nass, nslaves_hdr, nslaves
789 INTEGER, intent(in) :: estim_nfs4father_atson
790 INTEGER nbprocfils, dest
791 INTEGER ilig( nlig )
792 INTEGER icol( ncol )
793 INTEGER, INTENT(IN) :: ibc_source
794 INTEGER list_slaves( max(NSLAVES_HDR,1) )
795 INTEGER, INTENT(INOUT) :: keep(500)
796 INTEGER, INTENT(IN) :: lrstatus
797 include 'mpif.h'
798 include 'mumps_tags.h'
799 INTEGER :: ierr_mpi
800 INTEGER size_int, size_bytes, position, ipos, ireq
801 INTEGER ione
802 INTEGER dest2(1)
803 PARAMETER ( ione=1 )
804 dest2(1) = dest
805 ierr = 0
806 size_int = ( 11 + nlig + ncol + nslaves_hdr )
807 size_bytes = size_int * sizeofint
808 IF (size_int.GT.size_rbuf_bytes ) THEN
809 ierr = -3
810 RETURN
811 END IF
812 CALL buf_look( buf_cb, ipos, ireq, size_bytes, ierr,
813 & ione , dest2
814 & )
815 IF ( ierr .LT. 0 ) THEN
816 RETURN
817 ENDIF
818 position = ipos
819 buf_cb%CONTENT( position ) = size_int
820 position = position + 1
821 buf_cb%CONTENT( position ) = inode
822 position = position + 1
823 buf_cb%CONTENT( position ) = nbprocfils
824 position = position + 1
825 buf_cb%CONTENT( position ) = nlig
826 position = position + 1
827 buf_cb%CONTENT( position ) = ncol
828 position = position + 1
829 buf_cb%CONTENT( position ) = nass
830 position = position + 1
831 buf_cb%CONTENT( position ) = nfront
832 position = position + 1
833 buf_cb%CONTENT( position ) = nslaves_hdr
834 position = position + 1
835 buf_cb%CONTENT( position ) = nslaves
836 position = position + 1
837 buf_cb%CONTENT( position ) = lrstatus
838 position = position + 1
839 buf_cb%CONTENT( position ) = estim_nfs4father_atson
840 position = position + 1
841 IF (nslaves_hdr.GT.0) THEN
842 buf_cb%CONTENT( position: position + nslaves_hdr - 1 ) =
843 & list_slaves( 1: nslaves_hdr )
844 position = position + nslaves_hdr
845 ENDIF
846 buf_cb%CONTENT( position:position + nlig - 1 ) = ilig
847 position = position + nlig
848 buf_cb%CONTENT( position:position + ncol - 1 ) = icol
849 position = position + ncol
850 position = position - ipos
851 IF ( position * sizeofint .NE. size_bytes ) THEN
852 WRITE(*,*) 'Error in SMUMPS_BUF_SEND_DESC_BANDE :',
853 & ' wrong estimated size'
854 CALL mumps_abort()
855 END IF
856 keep(266)=keep(266)+1
857 CALL mpi_isend( buf_cb%CONTENT( ipos ), size_bytes,
858 & mpi_packed,
859 & dest, maitre_desc_bande, comm,
860 & buf_cb%CONTENT( ireq ), ierr_mpi )
861 RETURN
862 END SUBROUTINE smumps_buf_send_desc_bande
863 SUBROUTINE smumps_buf_send_maitre2( NBROWS_ALREADY_SENT,
864 & IPERE, ISON, NROW,
865 & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON,
866 & NSLAVES, SLAVES, DEST, COMM, IERR,
867 &
868 & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE )
869 IMPLICIT NONE
870 INTEGER nbrows_already_sent
871 INTEGER lda, nelim, type_son
872 INTEGER ipere, ISON, nrow, ncol, nslaves
873 INTEGER irow( nrow )
874 INTEGER icol( ncol )
875 INTEGER slaves( nslaves )
876 REAL val(lda, *)
877 INTEGER ipos, ireq, DEST, comm, ierr
878 INTEGER slavef, keep(500), iniv2
879 INTEGER(8) keep8(150)
880 INTEGER tab_pos_in_pere(slavef+2,max(1,keep(56)))
881 include 'mpif.h'
882 include 'mumps_tags.h'
883 INTEGER :: ierr_mpi
884 INTEGER size1, size2, size3, size_pack, position, i
885 INTEGER nbrows_packet, ncol_send
886 INTEGER size_av
887 LOGICAL recv_buf_smaller_than_send
888 INTEGER ione
889 INTEGER dest2(1)
890 parameter( ione=1 )
891 dest2(1) = dest
892 ierr = 0
893 IF ( nelim .NE. nrow ) THEN
894 WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',nelim, nrow
895 CALL mumps_abort()
896 END IF
897 IF (nbrows_already_sent .EQ. 0) THEN
898 CALL mpi_pack_size( nrow+ncol+7+nslaves, mpi_integer,
899 & comm, size1, ierr_mpi )
900 IF ( type_son .eq. 2 ) THEN
901 CALL mpi_pack_size( nslaves+1, mpi_integer,
902 & comm, size3, ierr_mpi )
903 ELSE
904 size3 = 0
905 ENDIF
906 size1=size1+size3
907 ELSE
908 CALL mpi_pack_size(7, mpi_integer,comm,size1,ierr_mpi)
909 ENDIF
910 IF ( keep(50).ne.0 .AND. type_son .eq. 2 ) THEN
911 ncol_send = nrow
912 ELSE
913 ncol_send = ncol
914 ENDIF
915 CALL smumps_buf_size_available( buf_cb, size_av )
916 IF (size_av .LT. size_rbuf_bytes) THEN
917 recv_buf_smaller_than_send = .false.
918 ELSE
919 recv_buf_smaller_than_send = .true.
920 size_av = size_rbuf_bytes
921 ENDIF
922 IF (nrow .GT. 0 ) THEN
923 nbrows_packet = (size_av - size1) / ncol_send / sizeofreal
924 nbrows_packet = min(nbrows_packet, nrow - nbrows_already_sent)
925 nbrows_packet = max(nbrows_packet, 0)
926 ELSE
927 nbrows_packet =0
928 ENDIF
929 IF (nbrows_packet .EQ. 0 .AND. nrow .NE. 0) THEN
930 IF (recv_buf_smaller_than_send) THEN
931 ierr=-3
932 GOTO 100
933 ELSE
934 ierr=-1
935 GOTO 100
936 ENDIF
937 ENDIF
938 10 CONTINUE
939 CALL mpi_pack_size( nbrows_packet * ncol_send,
940 & mpi_real,
941 & comm, size2, ierr_mpi )
942 size_pack = size1 + size2
943 IF (size_pack .GT. size_av) THEN
944 nbrows_packet = nbrows_packet - 1
945 IF ( nbrows_packet .GT. 0 ) THEN
946 GOTO 10
947 ELSE
948 IF (recv_buf_smaller_than_send) THEN
949 ierr = -3
950 GOTO 100
951 ELSE
952 ierr = -1
953 GOTO 100
954 ENDIF
955 ENDIF
956 ENDIF
957 IF (nbrows_packet + nbrows_already_sent.NE.nrow .AND.
958 & size_pack - size1 .LT. ( size_rbuf_bytes - size1 ) / 2
959 & .AND.
960 & .NOT. recv_buf_smaller_than_send)
961 & THEN
962 ierr = -1
963 GOTO 100
964 ENDIF
965 CALL buf_look( buf_cb, ipos, ireq, size_pack, ierr,
966 & ione , dest2
967 & )
968 IF ( ierr .LT. 0 ) THEN
969 GOTO 100
970 ENDIF
971 position = 0
972 CALL mpi_pack( ipere, 1, mpi_integer,
973 & buf_cb%CONTENT( ipos ), size_pack,
974 & position, comm, ierr_mpi )
975 CALL mpi_pack( ison, 1, mpi_integer,
976 & buf_cb%CONTENT( ipos ), size_pack,
977 & position, comm, ierr_mpi )
978 CALL mpi_pack( nslaves, 1, mpi_integer,
979 & buf_cb%CONTENT( ipos ), size_pack,
980 & position, comm, ierr_mpi )
981 CALL mpi_pack( nrow, 1, mpi_integer,
982 & buf_cb%CONTENT( ipos ), size_pack,
983 & position, comm, ierr_mpi )
984 CALL mpi_pack( ncol, 1, mpi_integer,
985 & buf_cb%CONTENT( ipos ), size_pack,
986 & position, comm, ierr_mpi )
987 CALL mpi_pack( nbrows_already_sent, 1, mpi_integer,
988 & buf_cb%CONTENT( ipos ), size_pack,
989 & position, comm, ierr_mpi )
990 CALL mpi_pack( nbrows_packet, 1, mpi_integer,
991 & buf_cb%CONTENT( ipos ), size_pack,
992 & position, comm, ierr_mpi )
993 IF (nbrows_already_sent .EQ. 0) THEN
994 IF (nslaves.GT.0) THEN
995 CALL mpi_pack( slaves, nslaves, mpi_integer,
996 & buf_cb%CONTENT( ipos ), size_pack,
997 & position, comm, ierr_mpi )
998 ENDIF
999 CALL mpi_pack( irow, nrow, mpi_integer,
1000 & buf_cb%CONTENT( ipos ), size_pack,
1001 & position, comm, ierr_mpi )
1002 CALL mpi_pack( icol, ncol, mpi_integer,
1003 & buf_cb%CONTENT( ipos ), size_pack,
1004 & position, comm, ierr_mpi )
1005 IF ( type_son .eq. 2 ) THEN
1006 CALL mpi_pack( tab_pos_in_pere(1,iniv2), nslaves+1,
1007 & mpi_integer,
1008 & buf_cb%CONTENT( ipos ), size_pack,
1009 & position, comm, ierr_mpi )
1010 ENDIF
1011 ENDIF
1012 IF (nbrows_packet.GE.1) THEN
1013 DO i=nbrows_already_sent+1,
1014 & nbrows_already_sent+nbrows_packet
1015 CALL mpi_pack( val(1,i), ncol_send,
1016 & mpi_real,
1017 & buf_cb%CONTENT( ipos ), size_pack,
1018 & position, comm, ierr_mpi )
1019 ENDDO
1020 ENDIF
1021 keep(266)=keep(266)+1
1022 CALL mpi_isend( buf_cb%CONTENT( ipos ), position, mpi_packed,
1023 & dest, maitre2, comm,
1024 & buf_cb%CONTENT( ireq ), ierr_mpi )
1025 IF ( size_pack .LT. position ) THEN
1026 write(*,*) 'Try_send_maitre2, SIZE,POSITION=',
1027 & size_pack,position
1028 CALL mumps_abort()
1029 END IF
1030 IF ( size_pack .NE. position )
1031 & CALL buf_adjust( buf_cb, position )
1032 nbrows_already_sent = nbrows_already_sent + nbrows_packet
1033 IF ( nbrows_already_sent .NE. nrow ) THEN
1034 ierr = -1
1035 ENDIF
1036 100 CONTINUE
1037 RETURN
1038 END SUBROUTINE smumps_buf_send_maitre2
1039 SUBROUTINE smumps_buf_send_contrib_type2(NBROWS_ALREADY_SENT,
1040 & DESC_IN_LU,
1041 & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER,
1042 & NSLAVES_PERE,
1043 & ISON, NBROW, LMAP, MAPROW, PERM, IW_CBSON, A_CBSON, LA_CBSON,
1044 & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR,
1045 &
1046 & KEEP,KEEP8, STEP, N, SLAVEF,
1047 & ISTEP_TO_INIV2, TAB_POS_IN_PERE,
1048 & PACKED_CB, KEEP253_LOC, NVSCHUR,
1049 & SON_NIV, MYID, NPIV_CHECK )
1050 USE smumps_lr_type
1051 USE smumps_lr_data_m
1052 IMPLICIT NONE
1053 INTEGER nbrows_already_sent
1054 INTEGER, INTENT (in) :: keep253_loc, nvschur
1055 INTEGER, INTENT (in) :: son_niv
1056 INTEGER, INTENT (in), OPTIONAL :: npiv_check
1057 INTEGER ipere, ison, nbrow, myid
1058 INTEGER pdest, islave, comm, ierr
1059 INTEGER pdest_master, nass_pere, nslaves_pere,
1060 & nfront_pere, lmap
1061 INTEGER maprow( lmap ), perm( max(1, NBROW ))
1062 INTEGER iw_cbson( * )
1063 REAL a_cbson( : )
1064 INTEGER(8) :: LA_CBSON
1065 LOGICAL desc_in_lu, packed_cb
1066 INTEGER keep(500), n , slavef
1067 INTEGER(8) keep8(150)
1068 INTEGER step(n),
1069 & istep_to_iniv2(keep(71)),
1070 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
1071 include 'mpif.h'
1072 include 'mumps_tags.h'
1073 INTEGER :: ierr_mpi
1074 INTEGER nfs4father,size3,ps1,nca,lrow1
1075 INTEGER(8) :: asize
1076 LOGICAL compute_max
1077 REAL, POINTER, DIMENSION(:) :: m_array
1078 INTEGER nbrows_packet
1079 INTEGER max_row_length
1080 INTEGER lrow, nelim
1081 INTEGER(8) :: itmp8
1082 INTEGER npiv, nfront, hs
1083 INTEGER size_pack, size0, size1, size2, position,i
1084 INTEGER SIZE_INTEGERS, b, size_reals, tmpsize, oneortwo, size_av
1085 INTEGER nbint, l
1086 INTEGER(8) :: apos, shiftcb_son, lda_son8
1087 INTEGER ipos_in_slave
1088 INTEGER state_son
1089 INTEGER indice_pere, nrow, ipos, ireq, nosla
1090 INTEGER ione, J, this_row_length
1091 INTEGER size_desc_bande, desc_bande_bytes
1092 LOGICAL recv_buf_smaller_than_send
1093 LOGICAL not_enough_space
1094 INTEGER pdest2(1)
1095 LOGICAL cb_is_lr
1096 TYPE(lrb_type), POINTER :: cb_lrb(:,:)
1097 INTEGER, POINTER, DIMENSION(:) :: begs_blr_row, begs_blr_col,
1098 & begs_blr_sta
1099 INTEGER :: nb_row_shift, nb_col_shift, NASS_SHIFT, panel2send,
1100 & current_panel_size, nb_blr_rows, nb_blr_cols,
1101 & cb_is_lr_int, ncol_shift, nrow_shift,
1102 & nbrows_packet_2pack,
1103 & panel_beg_offset
1104 INTEGER :: npiv_lr
1105 parameter( ione=1 )
1106 include 'mumps_headers.h'
1107 REAL zero
1108 PARAMETER (zero = 0.0e0)
1109 cb_is_lr = (iw_cbson(1+xxlr).EQ.1
1110 & .OR. iw_cbson(1+xxlr).EQ.3)
1111 IF (cb_is_lr) THEN
1112 cb_is_lr_int = 1
1113 ELSE
1114 cb_is_lr_int = 0
1115 ENDIF
1116 compute_max = (keep(219) .NE. 0) .AND.
1117 & (keep(50) .EQ. 2) .AND.
1118 & (pdest.EQ.pdest_master)
1119 IF (nbrows_already_sent == 0) THEN
1120 IF (compute_max) THEN
1121 CALL smumps_buf_max_array_minsize(nfs4father,ierr)
1122 IF (ierr .NE. 0) THEN
1123 ierr = -4
1124 RETURN
1125 ENDIF
1126 ENDIF
1127 ENDIF
1128 pdest2(1) = pdest
1129 ierr = 0
1130 lrow = iw_cbson( 1 + keep(ixsz))
1131 nelim = iw_cbson( 2 + keep(ixsz))
1132 npiv = iw_cbson( 4 + keep(ixsz))
1133 IF ( npiv .LT. 0 ) THEN
1134 npiv = 0
1135 END IF
1136 nrow = iw_cbson( 3 + keep(ixsz))
1137 nfront = lrow + npiv
1138 hs = 6 + iw_cbson( 6 + keep(ixsz)) + keep(ixsz)
1139 IF (cb_is_lr) THEN
1140 CALL smumps_blr_retrieve_cb_lrb(iw_cbson(1+xxf), cb_lrb)
1141 IF (son_niv.EQ.1) THEN
1142 CALL smumps_blr_retrieve_begsblr_sta(iw_cbson(1+xxf),
1143 & begs_blr_row)
1144 CALL smumps_blr_retrieve_begsblr_dyn(iw_cbson(1+xxf),
1145 & begs_blr_col)
1146 nb_blr_rows = size(begs_blr_row) - 1
1147 CALL smumps_blr_retrieve_nb_panels(iw_cbson(1+xxf),
1148 & nb_col_shift)
1149 nb_row_shift = nb_col_shift
1150 nass_shift = begs_blr_row(nb_row_shift+1)-1
1151 npiv_lr = begs_blr_col(nb_col_shift+1)-1
1152 ELSE
1153 npiv_lr=npiv
1154 CALL smumps_blr_retrieve_begsblr_sta(iw_cbson(1+xxf),
1155 & begs_blr_sta)
1156 nb_blr_rows = size(begs_blr_sta) - 2
1157 begs_blr_row => begs_blr_sta(2:nb_blr_rows+2)
1158 CALL smumps_blr_retrieve_begs_blr_c(iw_cbson(1+xxf),
1159 & begs_blr_col, nb_col_shift)
1160 nass_shift = 0
1161 nb_row_shift = 0
1162 ENDIF
1163 panel2send = -1
1164 DO i=nb_row_shift+1,nb_blr_rows
1165 IF (begs_blr_row(i+1)-1-nass_shift
1166 & .GT.nbrows_already_sent+perm(1)-1) THEN
1167 panel2send = i
1168 EXIT
1169 ENDIF
1170 ENDDO
1171 IF (panel2send.EQ.-1) THEN
1172 write(*,*) 'Internal error: PANEL2SEND not found'
1173 CALL mumps_abort()
1174 ENDIF
1175 IF (keep(50).EQ.0) THEN
1176 nb_blr_cols = size(begs_blr_col) - 1
1177 ELSEIF (son_niv.EQ.1) THEN
1178 nb_blr_cols = panel2send
1179 ELSE
1180 nb_blr_cols = -1
1181 ncol_shift = npiv_lr
1182 nrow_shift = lrow - nrow
1183 DO i=nb_col_shift+1,size(begs_blr_col)-1
1184 IF (begs_blr_col(i+1)-ncol_shift.GT.
1185 & begs_blr_row(panel2send+1)-1+nrow_shift) THEN
1186 nb_blr_cols = i
1187 EXIT
1188 ENDIF
1189 ENDDO
1190 IF (nb_blr_cols.EQ.-1) THEN
1191 write(*,*) 'Internal error: NB_BLR_COLS not found'
1192 CALL mumps_abort()
1193 ENDIF
1194 max_row_length = begs_blr_row(panel2send+1)-1+nrow_shift
1195 ENDIF
1196 current_panel_size = begs_blr_row(panel2send+1)
1197 & - begs_blr_row(panel2send)
1198 panel_beg_offset = perm(1) + nbrows_already_sent -
1199 & begs_blr_row(panel2send) + nass_shift
1200 ENDIF
1201 state_son = iw_cbson(1+xxs)
1202 IF (state_son .EQ. s_nolcbcontig) THEN
1203 lda_son8 = int(lrow,8)
1204 shiftcb_son = int(npiv,8)*int(nrow,8)
1205 ELSE IF (state_son .EQ. s_nolcleaned) THEN
1206 lda_son8 = int(lrow,8)
1207 shiftcb_son = 0_8
1208 ELSE
1209 lda_son8 = int(nfront,8)
1210 shiftcb_son = int(npiv,8)
1211 ENDIF
1212 CALL smumps_buf_size_available( buf_cb, size_av )
1213 IF (pdest .EQ. pdest_master) THEN
1214 size_desc_bande=0
1215 ELSE
1216 size_desc_bande=(7+slavef+keep(127)*2)
1217 size_desc_bande=size_desc_bande+int(real(keep(12))*
1218 & real(size_desc_bande)/100.0e0)
1219 size_desc_bande=max(size_desc_bande,
1220 & 7+nslaves_pere+nfront_pere+nfront_pere-nass_pere)
1221 ENDIF
1222 desc_bande_bytes=size_desc_bande*sizeofint
1223 IF ( size_av .LT. size_rbuf_bytes-desc_bande_bytes ) THEN
1224 recv_buf_smaller_than_send = .false.
1225 ELSE
1226 recv_buf_smaller_than_send = .true.
1227 size_av = size_rbuf_bytes-desc_bande_bytes
1228 ENDIF
1229 size1=0
1230 IF (nbrows_already_sent==0) THEN
1231 IF(compute_max) THEN
1232 CALL mpi_pack_size(1, mpi_integer,
1233 & comm, size0, ierr_mpi )
1234 IF(nfs4father .GT. 0) THEN
1235 CALL mpi_pack_size( nfs4father, mpi_real,
1236 & comm, size1, ierr_mpi )
1237 ENDIF
1238 size1 = size1+size0
1239 ENDIF
1240 ENDIF
1241 IF (keep(50) .EQ. 0) THEN
1242 oneortwo = 1
1243 ELSE
1244 oneortwo = 2
1245 ENDIF
1246 IF (pdest .EQ.pdest_master) THEN
1247 l = 0
1248 ELSE IF (keep(50) .EQ. 0) THEN
1249 l = lrow
1250 ELSE
1251 l = lrow + perm(1) - lmap + nbrows_already_sent - 1
1252 oneortwo=oneortwo+1
1253 ENDIF
1254 nbint = 6 + l + 1
1255 IF (cb_is_lr) THEN
1256 nbint = nbint + 4*(nb_blr_cols-nb_col_shift) + 2
1257 ENDIF
1258 CALL mpi_pack_size( nbint, mpi_integer,
1259 & comm, tmpsize, ierr_mpi )
1260 size1 = size1 + tmpsize
1261 size_av = size_av - size1
1262 not_enough_space=.false.
1263 IF (size_av .LT.0 ) THEN
1264 nbrows_packet = 0
1265 not_enough_space=.true.
1266 ELSE
1267 IF ( keep(50) .EQ. 0 ) THEN
1268 nbrows_packet =
1269 & size_av / ( oneortwo*sizeofint+lrow*sizeofreal)
1270 ELSE
1271 b = 2 * oneortwo +
1272 & ( 1 + 2 * lrow + 2 * perm(1) + 2 * nbrows_already_sent )
1273 & * sizeofreal / sizeofint
1274 nbrows_packet=int((dble(-b)+sqrt((dble(b)*dble(b))+
1275 & dble(4)*dble(2)*dble(size_av)/dble(sizeofint) *
1276 & dble(sizeofreal/sizeofint)))*
1277 & dble(sizeofint) / dble(2) / dble(sizeofreal))
1278 ENDIF
1279 ENDIF
1280 10 CONTINUE
1281 nbrows_packet = max( 0, nbrows_packet)
1282 nbrows_packet = min(nbrow-nbrows_already_sent, nbrows_packet)
1283 not_enough_space = not_enough_space .OR.
1284 & (nbrows_packet .EQ.0.AND. nbrow.NE.0)
1285 nbrows_packet_2pack = nbrows_packet
1286 IF (cb_is_lr) THEN
1287 nbrows_packet_2pack = current_panel_size
1288 CALL mumps_blr_get_sizereals_cb_lrb(size_reals, cb_lrb,
1289 & nb_row_shift,
1290 & nb_col_shift, nb_blr_cols, panel2send
1291 & )
1292 not_enough_space = (size_av.LT.size_reals)
1293 IF (.NOT.not_enough_space) THEN
1294 nbrows_packet = min(nbrows_packet,
1295 & current_panel_size-panel_beg_offset)
1296 ENDIF
1297 ENDIF
1298 IF (not_enough_space) THEN
1299 IF (recv_buf_smaller_than_send) THEN
1300 ierr = -3
1301 GOTO 100
1302 ELSE
1303 ierr = -1
1304 GOTO 100
1305 ENDIF
1306 ENDIF
1307 IF (cb_is_lr) THEN
1308 IF (keep(50).EQ.0) THEN
1309 max_row_length = -99999
1310 ELSEIF (son_niv.EQ.1) THEN
1311 max_row_length = lrow+perm(1)-lmap+nbrows_already_sent
1312 & + nbrows_packet_2pack-1
1313 ENDIF
1314 ELSE
1315 IF (keep(50).EQ.0) THEN
1316 max_row_length = -99999
1317 size_reals = nbrows_packet_2pack * lrow
1318 ELSE
1319 size_reals = ( lrow + perm(1) + nbrows_already_sent ) *
1320 & nbrows_packet_2pack + ( nbrows_packet_2pack *
1321 & ( nbrows_packet_2pack + 1) ) / 2
1322 max_row_length = lrow+perm(1)-lmap+nbrows_already_sent
1323 & + nbrows_packet_2pack-1
1324 ENDIF
1325 ENDIF
1326 size_integers = oneortwo* nbrows_packet_2pack
1327 CALL mpi_pack_size( size_reals, mpi_real,
1328 & comm, size2, ierr_mpi )
1329 CALL mpi_pack_size( size_integers, mpi_integer,
1330 & comm, size3, ierr_mpi )
1331 IF (size2 + size3 .GT. size_av ) THEN
1332 nbrows_packet = nbrows_packet -1
1333 IF (nbrows_packet .GT. 0 .AND..NOT.cb_is_lr) THEN
1334 GOTO 10
1335 ELSE
1336 IF (recv_buf_smaller_than_send) THEN
1337 ierr = -3
1338 GOTO 100
1339 ELSE
1340 ierr = -1
1341 GOTO 100
1342 ENDIF
1343 ENDIF
1344 ENDIF
1345 size_pack = size1 + size2 + size3
1346 IF (nbrows_packet + nbrows_already_sent.NE.nbrow .AND.
1347 & size_pack .LT. size_rbuf_bytes / 4 .AND.
1348 & .NOT. recv_buf_smaller_than_send .AND.
1349 & .NOT. cb_is_lr)
1350 & THEN
1351 ierr = -1
1352 GOTO 100
1353 ENDIF
1354 IF (size_pack.GT.size_rbuf_bytes ) THEN
1355 ierr = -3
1356 GOTO 100
1357 ENDIF
1358 CALL buf_look( buf_cb, ipos, ireq, size_pack, ierr,
1359 & ione , pdest2)
1360 IF (ierr .EQ. -1 .OR. ierr.EQ. -2) THEN
1361 nbrows_packet = nbrows_packet - 1
1362 IF (nbrows_packet > 0 ) GOTO 10
1363 ENDIF
1364 IF ( ierr .LT. 0 ) GOTO 100
1365 position = 0
1366 CALL mpi_pack( ipere, 1, mpi_integer,
1367 & buf_cb%CONTENT( ipos ), size_pack,
1368 & position, comm, ierr_mpi )
1369 CALL mpi_pack( ison, 1, mpi_integer,
1370 & buf_cb%CONTENT( ipos ), size_pack,
1371 & position, comm, ierr_mpi )
1372 CALL mpi_pack( nbrow, 1, mpi_integer,
1373 & buf_cb%CONTENT( ipos ), size_pack,
1374 & position, comm, ierr_mpi )
1375 IF (keep(50)==0) THEN
1376 CALL mpi_pack( lrow, 1, mpi_integer,
1377 & buf_cb%CONTENT( ipos ), size_pack,
1378 & position, comm, ierr_mpi )
1379 ELSE
1380 CALL mpi_pack( max_row_length, 1, mpi_integer,
1381 & buf_cb%CONTENT( ipos ), size_pack,
1382 & position, comm, ierr_mpi )
1383 ENDIF
1384 CALL mpi_pack( nbrows_already_sent, 1, mpi_integer,
1385 & buf_cb%CONTENT( ipos ), size_pack,
1386 & position, comm, ierr_mpi )
1387 CALL mpi_pack( nbrows_packet, 1, mpi_integer,
1388 & buf_cb%CONTENT( ipos ), size_pack,
1389 & position, comm, ierr_mpi )
1390 CALL mpi_pack( cb_is_lr_int, 1, mpi_integer,
1391 & buf_cb%CONTENT( ipos ), size_pack,
1392 & position, comm, ierr_mpi )
1393 IF ( pdest .NE. pdest_master ) THEN
1394 IF (keep(50)==0) THEN
1395 CALL mpi_pack( iw_cbson( hs + nrow + npiv + 1 ), lrow,
1396 & mpi_integer,
1397 & buf_cb%CONTENT( ipos ), size_pack,
1398 & position, comm, ierr_mpi )
1399 ELSE
1400 IF (max_row_length > 0) THEN
1401 CALL mpi_pack( iw_cbson( hs + nrow + npiv + 1 ),
1402 & max_row_length,
1403 & mpi_integer,
1404 & buf_cb%CONTENT( ipos ), size_pack,
1405 & position, comm, ierr_mpi )
1406 ENDIF
1407 ENDIF
1408 END IF
1409 DO j=nbrows_already_sent+1,nbrows_already_sent+nbrows_packet
1410 i = perm(j)
1411 indice_pere=maprow(i)
1412 CALL mumps_bloc2_get_islave(
1413 & keep,keep8, ipere, step, n, slavef,
1414 & istep_to_iniv2, tab_pos_in_pere,
1415 &
1416 & nass_pere,
1417 & nfront_pere - nass_pere,
1418 & nslaves_pere,
1419 & indice_pere,
1420 & nosla,
1421 & ipos_in_slave )
1422 indice_pere = ipos_in_slave
1423 CALL mpi_pack( indice_pere, 1, mpi_integer,
1424 & buf_cb%CONTENT( ipos ), size_pack,
1425 & position, comm, ierr_mpi )
1426 ENDDO
1427 IF (cb_is_lr) THEN
1428 CALL smumps_blr_pack_cb_lrb(cb_lrb, nb_row_shift,
1429 & nb_col_shift, nb_blr_cols, panel2send,
1430 & panel_beg_offset,
1431 & buf_cb%CONTENT(ipos:),
1432 & size_pack, position, comm, ierr
1433 & )
1434 IF (keep(50).ne.0) THEN
1435 DO j=nbrows_already_sent+1,nbrows_already_sent+nbrows_packet
1436 i = perm(j)
1437 this_row_length = lrow + i - lmap
1438 CALL mpi_pack( this_row_length, 1, mpi_integer,
1439 & buf_cb%CONTENT( ipos ), size_pack,
1440 & position, comm, ierr_mpi )
1441 ENDDO
1442 ENDIF
1443 GOTO 200
1444 ENDIF
1445 DO j=nbrows_already_sent+1,nbrows_already_sent+nbrows_packet
1446 i = perm(j)
1447 indice_pere=maprow(i)
1448 CALL mumps_bloc2_get_islave(
1449 & keep,keep8, ipere, step, n, slavef,
1450 & istep_to_iniv2, tab_pos_in_pere,
1451 &
1452 & nass_pere,
1453 & nfront_pere - nass_pere,
1454 & nslaves_pere,
1455 & indice_pere,
1456 & nosla,
1457 & ipos_in_slave )
1458 IF (keep(50).ne.0) THEN
1459 this_row_length = lrow + i - lmap
1460 CALL mpi_pack( this_row_length, 1, mpi_integer,
1461 & buf_cb%CONTENT( ipos ), size_pack,
1462 & position, comm, ierr_mpi )
1463 ELSE
1464 this_row_length = lrow
1465 ENDIF
1466 IF (desc_in_lu) THEN
1467 IF ( packed_cb ) THEN
1468 IF (nelim.EQ.0) THEN
1469 itmp8 = int(i,8)
1470 ELSE
1471 itmp8 = int(nelim+i,8)
1472 ENDIF
1473 apos = itmp8 * (itmp8-1_8) / 2_8 + 1_8
1474 ELSE
1475 apos = int(i+nelim-1, 8) * int(lrow,8) + 1_8
1476 ENDIF
1477 ELSE
1478 IF ( packed_cb ) THEN
1479 IF ( lrow .EQ. nrow ) THEN
1480 itmp8 = int(i,8)
1481 apos = itmp8 * (itmp8-1_8)/2_8 + 1_8
1482 ELSE
1483 itmp8 = int(i + lrow - nrow,8)
1484 apos = itmp8 * (itmp8-1_8)/2_8 + 1_8 -
1485 & int(lrow - nrow, 8) * int(lrow-nrow+1,8) / 2_8
1486 ENDIF
1487 ELSE
1488 apos = int( i - 1, 8 ) * lda_son8 + shiftcb_son + 1_8
1489 ENDIF
1490 ENDIF
1491 CALL mpi_pack( a_cbson( apos ), this_row_length,
1492 & mpi_real,
1493 & buf_cb%CONTENT( ipos ), size_pack,
1494 & position, comm, ierr_mpi )
1495 ENDDO
1496 200 CONTINUE
1497 IF (nbrows_already_sent == 0) THEN
1498 IF (compute_max) THEN
1499 CALL mpi_pack(nfs4father,1,
1500 & mpi_integer,
1501 & buf_cb%CONTENT( ipos ), size_pack,
1502 & position, comm, ierr_mpi )
1503 IF (nfs4father .GT. 0) THEN
1504 IF (cb_is_lr) THEN
1505 CALL smumps_blr_retrieve_m_array (
1506 & iw_cbson(1+xxf), m_array)
1507 CALL mpi_pack(m_array(1), nfs4father,
1508 & mpi_real,
1509 & buf_cb%CONTENT( ipos ), size_pack,
1510 & position, comm, ierr_mpi )
1511 CALL smumps_blr_free_m_array ( iw_cbson(1+xxf) )
1512 ELSE
1513 buf_max_array(1:nfs4father) = zero
1514 IF(maprow(nrow) .GT. nass_pere) THEN
1515 DO ps1=1,nrow
1516 IF(maprow(ps1).GT.nass_pere) EXIT
1517 ENDDO
1518 IF (desc_in_lu) THEN
1519 IF (packed_cb) THEN
1520 apos = int(nelim+ps1,8) * int(nelim+ps1-1,8) /
1521 & 2_8 + 1_8
1522 nca = -44444
1523 asize = int(nrow,8) * int(nrow+1,8)/2_8 -
1524 & int(nelim+ps1,8) * int(nelim+ps1-1,8)/2_8
1525 lrow1 = ps1 + nelim
1526 ELSE
1527 apos = int(ps1+nelim-1,8) * int(lrow,8) + 1_8
1528 nca = lrow
1529 asize = int(nca,8) * int(nrow-ps1+1,8)
1530 lrow1 = lrow
1531 ENDIF
1532 ELSE
1533 IF (packed_cb) THEN
1534 IF (npiv.NE.0) THEN
1535 WRITE(*,*) "Error in PARPIV/SMUMPS_BUF_SEND_CONTRIB_TYPE2"
1536 CALL mumps_abort()
1537 ENDIF
1538 lrow1=lrow-nrow+ps1
1539 itmp8 = int(ps1 + lrow - nrow,8)
1540 apos = itmp8 * (itmp8 - 1_8) / 2_8 + 1_8 -
1541 & int(lrow-nrow,8)*int(lrow-nrow+1,8)/2_8
1542 asize = int(lrow,8)*int(lrow+1,8)/2_8 -
1543 & itmp8*(itmp8-1_8)/2_8
1544 nca = -555555
1545 ELSE
1546 apos = int(ps1-1,8) * lda_son8 + 1_8 + shiftcb_son
1547 nca = int(lda_son8)
1548 asize = la_cbson - apos + 1_8
1549 lrow1=-666666
1550 ENDIF
1551 ENDIF
1552 IF ( nrow-ps1+1-keep253_loc-nvschur .GT. 0 ) THEN
1553 CALL smumps_compute_maxpercol(
1554 & a_cbson(apos),asize,nca,
1555 & nrow-ps1+1-keep253_loc-nvschur,
1556 & buf_max_array,nfs4father,packed_cb,lrow1)
1557 ENDIF
1558 ENDIF
1559 CALL mpi_pack(buf_max_array, nfs4father,
1560 & mpi_real,
1561 & buf_cb%CONTENT( ipos ), size_pack,
1562 & position, comm, ierr_mpi )
1563 ENDIF
1564 ENDIF
1565 ENDIF
1566 ENDIF
1567 keep(266)=keep(266)+1
1568 CALL mpi_isend( buf_cb%CONTENT( ipos ), position, mpi_packed,
1569 & pdest, contrib_type2, comm,
1570 & buf_cb%CONTENT( ireq ), ierr_mpi )
1571 IF ( size_pack.LT. position ) THEN
1572 WRITE(*,*) ' contniv2: SIZE, POSITION =',size_pack, position
1573 WRITE(*,*) ' NBROW, LROW = ', nbrow, lrow
1574 CALL mumps_abort()
1575 END IF
1576 IF ( size_pack .NE. position )
1577 & CALL buf_adjust( buf_cb, position )
1578 nbrows_already_sent=nbrows_already_sent + nbrows_packet
1579 IF (nbrows_already_sent .NE. nbrow ) THEN
1580 ierr = -1
1581 ENDIF
1582 100 CONTINUE
1583 RETURN
1584 END SUBROUTINE smumps_buf_send_contrib_type2
1585 SUBROUTINE mumps_blr_get_sizereals_cb_lrb(SIZE_OUT,
1586 & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS,
1587 & PANEL2SEND
1588 & )
1589 USE smumps_lr_type
1590 IMPLICIT NONE
1591 TYPE(lrb_type), POINTER :: cb_lrb(:,:)
1592 INTEGER, INTENT(IN) :: nb_row_shift, nb_col_shift, nb_blr_cols,
1593 & panel2send
1594 INTEGER, intent(out) :: size_out
1595 INTEGER :: j
1596 TYPE(lrb_type), POINTER :: LRB
1597 SIZE_OUT = 0
1598 DO j=1,nb_blr_cols-nb_col_shift
1599 lrb => cb_lrb(panel2send-nb_row_shift,j)
1600 IF (lrb%ISLR) THEN
1601 IF (lrb%K.GT.0) THEN
1602 size_out = size_out + lrb%K*(lrb%M+lrb%N)
1603 ENDIF
1604 ELSE
1605 size_out = size_out + lrb%M*lrb%N
1606 ENDIF
1607 ENDDO
1608 RETURN
1609 END SUBROUTINE mumps_blr_get_sizereals_cb_lrb
1610 SUBROUTINE smumps_blr_pack_cb_lrb(
1611 & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS,
1612 & PANEL2SEND, PANEL_BEG_OFFSET,
1613 & BUF, LBUF, POSITION, COMM, IERR
1614 & )
1615 USE smumps_lr_type
1616 IMPLICIT NONE
1617 TYPE(lrb_type), POINTER :: cb_lrb(:,:)
1618 INTEGER, INTENT(IN) :: nb_row_shift, nb_col_shift, nb_blr_cols,
1619 & panel2send, panel_beg_offset
1620 INTEGER, intent(out) :: ierr
1621 INTEGER, intent(in) :: comm, lbuf
1622 INTEGER, intent(inout) :: position
1623 INTEGER, intent(inout) :: buf(:)
1624 INTEGER :: j, ierr_mpi
1625 include 'mpif.h'
1626 ierr = 0
1627 CALL mpi_pack( nb_blr_cols-nb_col_shift, 1, mpi_integer,
1628 & buf(1), lbuf, position, comm, ierr_mpi )
1629 CALL mpi_pack( panel_beg_offset, 1, mpi_integer,
1630 & buf(1), lbuf, position, comm, ierr_mpi )
1631 DO j=1,nb_blr_cols-nb_col_shift
1632 CALL smumps_mpi_pack_lrb(
1633 & cb_lrb(panel2send-nb_row_shift,j),
1634 & buf, lbuf, position, comm, ierr
1635 & )
1636 ENDDO
1637 END SUBROUTINE smumps_blr_pack_cb_lrb
1638 SUBROUTINE smumps_buf_send_maplig(
1639 & INODE, NFRONT, NASS1, NFS4FATHER,
1640 & ISON, MYID, NSLAVES, SLAVES_PERE,
1641 & TROW, NCBSON,
1642 & COMM, IERR,
1643 & DEST, NDEST, SLAVEF,
1644 &
1645 & KEEP,KEEP8, STEP, N,
1646 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
1647 &
1648 & )
1649 IMPLICIT NONE
1650 INTEGER inode, nfront, nass1, ncbson, nslaves,
1651 & ndest
1652 INTEGER slavef, myid, ison
1653 INTEGER trow( ncbson )
1654 INTEGER dest( ndest )
1655 INTEGER slaves_pere( nslaves )
1656 INTEGER comm, ierr
1657 INTEGER keep(500), n
1658 INTEGER(8) keep8(150)
1659 INTEGER step(n),
1660 & istep_to_iniv2(keep(71)),
1661 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
1662 include 'mpif.h'
1663 include 'mumps_tags.h'
1664 INTEGER :: ierr_mpi
1665 INTEGER size_av, idest, nsend, size, nfs4father
1666 INTEGER trow_size, POSITION, indx, iniv2
1667 INTEGER ipos, ireq
1668 INTEGER ione
1669 PARAMETER ( IONE=1 )
1670 INTEGER nass_son
1671 nass_son = -99998
1672 ierr = 0
1673 IF ( ndest .eq. 1 ) THEN
1674 IF ( dest(1).EQ.myid ) GOTO 500
1675 SIZE = sizeofint * ( 7 + nslaves + ncbson )
1676 IF ( nslaves.GT.0 ) THEN
1677 SIZE = SIZE + sizeofint * ( nslaves + 1 )
1678 ENDIF
1679 IF (size.GT.size_rbuf_bytes ) THEN
1680 ierr = -3
1681 RETURN
1682 END IF
1683 CALL buf_look( buf_cb, ipos, ireq, SIZE, ierr,
1684 & ione, dest
1685 & )
1686 IF (ierr .LT. 0 ) THEN
1687 RETURN
1688 ENDIF
1689 position = ipos
1690 buf_cb%CONTENT( position ) = inode
1691 position = position + 1
1692 buf_cb%CONTENT( position ) = ison
1693 position = position + 1
1694 buf_cb%CONTENT( position ) = nslaves
1695 position = position + 1
1696 buf_cb%CONTENT( position ) = nfront
1697 position = position + 1
1698 buf_cb%CONTENT( position ) = nass1
1699 position = position + 1
1700 buf_cb%CONTENT( position ) = ncbson
1701 position = position + 1
1702 buf_cb%CONTENT( position ) = nfs4father
1703 position = position + 1
1704 IF ( nslaves.GT.0 ) THEN
1705 iniv2 = istep_to_iniv2( step(inode) )
1706 buf_cb%CONTENT( position: position + nslaves )
1707 & = tab_pos_in_pere(1:nslaves+1,iniv2)
1708 position = position + nslaves + 1
1709 ENDIF
1710 IF ( nslaves .NE. 0 ) THEN
1711 buf_cb%CONTENT( position: position + nslaves - 1 )
1712 & = slaves_pere( 1: nslaves )
1713 position = position + nslaves
1714 END IF
1715 buf_cb%CONTENT( position:position+ncbson-1 ) =
1716 & trow( 1: ncbson )
1717 position = position + ncbson
1718 position = position - ipos
1719 IF ( position * sizeofint .NE. SIZE ) THEN
1720 WRITE(*,*) 'Error in SMUMPS_BUF_SEND_MAPLIG :',
1721 & ' wrong estimated size'
1722 CALL mumps_abort()
1723 END IF
1724 keep(266)=keep(266)+1
1725 CALL mpi_isend( buf_cb%CONTENT( ipos ), SIZE,
1726 & mpi_packed,
1727 & dest( ndest ), maplig, comm,
1728 & buf_cb%CONTENT( ireq ),
1729 & ierr_mpi )
1730 ELSE
1731 nsend = 0
1732 DO idest = 1, ndest
1733 IF ( dest( idest ) .ne. myid ) nsend = nsend + 1
1734 END DO
1735 SIZE = sizeofint *
1736 & ( ( ovhsize + 7 + nslaves )* nsend + ncbson )
1737 IF ( nslaves.GT.0 ) THEN
1738 SIZE = SIZE + sizeofint * nsend*( nslaves + 1 )
1739 ENDIF
1740 CALL smumps_buf_size_available( buf_cb, size_av )
1741 IF ( size_av .LT. SIZE ) THEN
1742 ierr = -1
1743 RETURN
1744 END IF
1745 DO idest= 1, ndest
1746 CALL mumps_bloc2_get_slave_info(
1747 & keep,keep8, ison, step, n, slavef,
1748 & istep_to_iniv2, tab_pos_in_pere,
1749 & idest, ncbson,
1750 & ndest,
1751 & trow_size, indx )
1752 SIZE = sizeofint * ( nslaves + trow_size + 7 )
1753 IF ( nslaves.GT.0 ) THEN
1754 SIZE = SIZE + sizeofint * ( nslaves + 1 )
1755 ENDIF
1756 IF ( myid .NE. dest( idest ) ) THEN
1757 IF (size.GT.size_rbuf_bytes) THEN
1758 ierr = -3
1759 RETURN
1760 ENDIF
1761 CALL buf_look( buf_cb, ipos, ireq, SIZE, ierr,
1762 & ione, dest(idest) )
1763 IF ( ierr .LT. 0 ) THEN
1764 WRITE(*,*) 'Internal error SMUMPS_BUF_SEND_MAPLIG',
1765 & 'IERR after BUF_LOOK=',ierr
1766 CALL mumps_abort()
1767 END IF
1768 position = ipos
1769 buf_cb%CONTENT( position ) = inode
1770 position = position + 1
1771 buf_cb%CONTENT( position ) = ison
1772 position = position + 1
1773 buf_cb%CONTENT( position ) = nslaves
1774 position = position + 1
1775 buf_cb%CONTENT( position ) = nfront
1776 position = position + 1
1777 buf_cb%CONTENT( position ) = nass1
1778 position = position + 1
1779 buf_cb%CONTENT( position ) = trow_size
1780 position = position + 1
1781 buf_cb%CONTENT( position ) = nfs4father
1782 position = position + 1
1783 IF ( nslaves.GT.0 ) THEN
1784 iniv2 = istep_to_iniv2( step(inode) )
1785 buf_cb%CONTENT( position: position + nslaves )
1786 & = tab_pos_in_pere(1:nslaves+1,iniv2)
1787 position = position + nslaves + 1
1788 ENDIF
1789 IF ( nslaves .NE. 0 ) THEN
1790 buf_cb%CONTENT( position: position + nslaves - 1 )
1791 & = slaves_pere( 1: nslaves )
1792 position = position + nslaves
1793 END IF
1794 buf_cb%CONTENT( position:position+trow_size-1 ) =
1795 & trow( indx: indx + trow_size - 1 )
1796 position = position + trow_size
1797 position = position - ipos
1798 IF ( position * sizeofint .NE. SIZE ) THEN
1799 WRITE(*,*) ' ERROR 1 in TRY_SEND_MAPLIG:',
1800 & 'Wrong estimated size'
1801 CALL mumps_abort()
1802 END IF
1803 keep(266)=keep(266)+1
1804 CALL mpi_isend( buf_cb%CONTENT( ipos ), SIZE,
1805 & mpi_packed,
1806 & dest( idest ), maplig, comm,
1807 & buf_cb%CONTENT( ireq ),
1808 & ierr_mpi )
1809 END IF
1810 END DO
1811 END IF
1812 500 CONTINUE
1813 RETURN
1814 END SUBROUTINE smumps_buf_send_maplig
1815 SUBROUTINE smumps_buf_send_blocfacto( INODE, NFRONT,
1816 & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL,
1817 & PDEST, NDEST, KEEP, NB_BLOC_FAC,
1818 & NSLAVES_TOT,
1819 & WIDTH, COMM,
1820 & NELIM, NPARTSASS, CURRENT_BLR_PANEL,
1821 & LR_ACTIVATED, BLR_LorU,
1822 &
1823 & IERR )
1824 USE smumps_lr_type
1825 IMPLICIT NONE
1826 INTEGER, intent(in) :: inode, ncol, npiv,
1827 & fpere, nfront, ndest
1828 INTEGER, intent(in) :: ipiv( npiv )
1829 REAL, intent(in) :: val( nfront, * )
1830 INTEGER, intent(in) :: pdest( ndest )
1831 INTEGER, intent(inout) :: keep(500)
1832 INTEGER, intent(in) :: nb_bloc_fac,
1833 & nslaves_tot, comm, width
1834 LOGICAL, intent(in) :: lastbl
1835 LOGICAL, intent(in) :: lr_activated
1836 INTEGER, intent(in) :: nelim, npartsass, current_blr_panel
1837 TYPE (lrb_type), DIMENSION(:), intent(in) :: blr_loru
1838 INTEGER, intent(inout) :: ierr
1839 include 'mpif.h'
1840 include 'mumps_tags.h'
1841 INTEGER :: ierr_mpi
1842 INTEGER position, ireq, ipos, size1, size2, size3, sizet,
1843 & idest, iposmsg, i
1844 INTEGER npivsent
1845 INTEGER sss
1846 INTEGER :: NBMSGS
1847 INTEGER :: lrelay_info, dest_blocfacto, tag_blocfacto
1848 INTEGER :: lr_activated_int
1849 ierr = 0
1850 lrelay_info = 0
1851 nbmsgs = ndest
1852 IF ( lastbl ) THEN
1853 IF ( keep(50) .eq. 0 ) THEN
1854 CALL mpi_pack_size( 4 + npiv + ( nbmsgs - 1 ) * ovhsize +
1855 & 1+lrelay_info,
1856 & mpi_integer, comm, size1, ierr_mpi )
1857 ELSE
1858 CALL mpi_pack_size( 6 + npiv + ( nbmsgs - 1 ) * ovhsize +
1859 & 1+lrelay_info,
1860 & mpi_integer, comm, size1, ierr_mpi )
1861 END IF
1862 ELSE
1863 IF ( keep(50) .eq. 0 ) THEN
1864 CALL mpi_pack_size( 3 + npiv + ( nbmsgs - 1 ) * ovhsize +
1865 & 1+lrelay_info,
1866 & mpi_integer, comm, size1, ierr_mpi )
1867 ELSE
1868 CALL mpi_pack_size( 4 + npiv + ( nbmsgs - 1 ) * ovhsize +
1869 & 1+lrelay_info,
1870 & mpi_integer, comm, size1, ierr_mpi )
1871 END IF
1872 END IF
1873 size2 = 0
1874 CALL mpi_pack_size( 4, mpi_integer, comm, size3, ierr_mpi )
1875 size2=size2+size3
1876 IF ( keep(50).NE.0 ) THEN
1877 CALL mpi_pack_size( 1, mpi_integer, comm, size3, ierr_mpi )
1878 size2=size2+size3
1879 ENDIF
1880 IF ((npiv.GT.0)
1881 & ) THEN
1882 IF (.NOT. lr_activated) THEN
1883 CALL mpi_pack_size( npiv*ncol, mpi_real,
1884 & comm, size3, ierr_mpi )
1885 size2 = size2+size3
1886 ELSE
1887 CALL mpi_pack_size( npiv*(npiv+nelim), mpi_real,
1888 & comm, size3, ierr_mpi )
1889 size2 = size2+size3
1890 CALL mumps_mpi_pack_size_lr( blr_loru, size3, comm, ierr )
1891 size2 = size2+size3
1892 ENDIF
1893 ENDIF
1894 sizet = size1 + size2
1895 IF (sizet.GT.size_rbuf_bytes) THEN
1896 sss = 0
1897 IF ( lastbl ) THEN
1898 IF ( keep(50) .eq. 0 ) THEN
1899 CALL mpi_pack_size( 4 + npiv + 1+lrelay_info,
1900 & mpi_integer, comm, sss, ierr_mpi )
1901 ELSE
1902 CALL mpi_pack_size( 6 + npiv + 1+lrelay_info,
1903 & mpi_integer, comm, sss, ierr_mpi )
1904 END IF
1905 ELSE
1906 IF ( keep(50) .eq. 0 ) THEN
1907 CALL mpi_pack_size( 3 + npiv + 1+lrelay_info,
1908 & mpi_integer, comm, sss, ierr_mpi )
1909 ELSE
1910 CALL mpi_pack_size( 4 + npiv + 1+lrelay_info,
1911 & mpi_integer, comm, sss, ierr_mpi )
1912 END IF
1913 END IF
1914 sss = sss + size2
1915 IF (sss.GT.size_rbuf_bytes) THEN
1916 ierr = -3
1917 RETURN
1918 ENDIF
1919 ENDIF
1920 CALL buf_look( buf_cb, ipos, ireq, sizet, ierr,
1921 & nbmsgs , pdest)
1922 IF ( ierr .LT. 0 ) THEN
1923 RETURN
1924 ENDIF
1925 buf_cb%ILASTMSG = buf_cb%ILASTMSG + ( nbmsgs - 1 ) * ovhsize
1926 ipos = ipos - ovhsize
1927 DO idest = 1, nbmsgs - 1
1928 buf_cb%CONTENT( ipos + ( idest - 1 ) * ovhsize ) =
1929 & ipos + idest * ovhsize
1930 END DO
1931 buf_cb%CONTENT( ipos + ( nbmsgs - 1 ) * ovhsize ) = 0
1932 iposmsg = ipos + ovhsize * nbmsgs
1933 position = 0
1934 CALL mpi_pack( inode, 1, mpi_integer,
1935 & buf_cb%CONTENT( iposmsg ), sizet,
1936 & position, comm, ierr_mpi )
1937 npivsent = npiv
1938 IF (lastbl) npivsent = -npiv
1939 CALL mpi_pack( npivsent, 1, mpi_integer,
1940 & buf_cb%CONTENT( iposmsg ), sizet,
1941 & position, comm, ierr_mpi )
1942 IF ( lastbl .or. keep(50).ne.0 ) THEN
1943 CALL mpi_pack( fpere, 1, mpi_integer,
1944 & buf_cb%CONTENT( iposmsg ), sizet,
1945 & position, comm, ierr_mpi )
1946 END IF
1947 IF ( lastbl .AND. keep(50) .NE. 0 ) THEN
1948 CALL mpi_pack( nslaves_tot, 1, mpi_integer,
1949 & buf_cb%CONTENT( iposmsg ), sizet,
1950 & position, comm, ierr_mpi )
1951 CALL mpi_pack( nb_bloc_fac, 1, mpi_integer,
1952 & buf_cb%CONTENT( iposmsg ), sizet,
1953 & position, comm, ierr_mpi )
1954 END IF
1955 CALL mpi_pack( ncol, 1, mpi_integer,
1956 & buf_cb%CONTENT( iposmsg ), sizet,
1957 & position, comm, ierr_mpi )
1958 CALL mpi_pack( nelim, 1, mpi_integer,
1959 & buf_cb%CONTENT( iposmsg ), sizet,
1960 & position, comm, ierr_mpi )
1961 CALL mpi_pack( npartsass, 1, mpi_integer,
1962 & buf_cb%CONTENT( iposmsg ), sizet,
1963 & position, comm, ierr_mpi )
1964 CALL mpi_pack( current_blr_panel, 1, mpi_integer,
1965 & buf_cb%CONTENT( iposmsg ), sizet,
1966 & position, comm, ierr_mpi )
1967 IF (lr_activated) THEN
1968 lr_activated_int = 1
1969 ELSE
1970 lr_activated_int = 0
1971 ENDIF
1972 CALL mpi_pack( lr_activated_int, 1, mpi_integer,
1973 & buf_cb%CONTENT( iposmsg ), sizet,
1974 & position, comm, ierr_mpi )
1975 IF ( keep(50) .ne. 0 ) THEN
1976 CALL mpi_pack( nslaves_tot, 1, mpi_integer,
1977 & buf_cb%CONTENT( iposmsg ), sizet,
1978 & position, comm, ierr_mpi )
1979 ENDIF
1980 IF ( (npiv.GT.0)
1981 & ) THEN
1982 IF (npiv.GT.0) THEN
1983 CALL mpi_pack( ipiv, npiv, mpi_integer,
1984 & buf_cb%CONTENT( iposmsg ), sizet,
1985 & position, comm, ierr_mpi )
1986 ENDIF
1987 IF (lr_activated) THEN
1988 DO i = 1, npiv
1989 CALL mpi_pack( val(1,i), npiv+nelim,
1990 & mpi_real,
1991 & buf_cb%CONTENT( iposmsg ), sizet,
1992 & position, comm, ierr_mpi )
1993 END DO
1994 CALL smumps_mpi_pack_lr( blr_loru,
1995 & buf_cb%CONTENT(iposmsg:
1996 & iposmsg+(sizet+keep(34)-1)/keep(34)-1),
1997 & sizet, position, comm, ierr)
1998 ELSE
1999 DO i = 1, npiv
2000 CALL mpi_pack( val(1,i), ncol,
2001 & mpi_real,
2002 & buf_cb%CONTENT( iposmsg ), sizet,
2003 & position, comm, ierr_mpi )
2004 END DO
2005 ENDIF
2006 ENDIF
2007 CALL mpi_pack( lrelay_info, 1, mpi_integer,
2008 & buf_cb%CONTENT( iposmsg ), sizet,
2009 & position, comm, ierr_mpi )
2010 DO idest = 1, nbmsgs
2011 dest_blocfacto = pdest(idest)
2012 IF ( keep(50) .EQ. 0) THEN
2013 tag_blocfacto = bloc_facto
2014 keep(266)=keep(266)+1
2015 CALL mpi_isend( buf_cb%CONTENT( iposmsg ), position,
2016 & mpi_packed,
2017 & dest_blocfacto, tag_blocfacto, comm,
2018 & buf_cb%CONTENT( ireq + ( idest-1 ) * ovhsize ),
2019 & ierr_mpi )
2020 ELSE
2021 keep(266)=keep(266)+1
2022 CALL mpi_isend( buf_cb%CONTENT( iposmsg ), position,
2023 & mpi_packed,
2024 & dest_blocfacto, bloc_facto_sym, comm,
2025 & buf_cb%CONTENT( ireq + ( idest-1 ) * ovhsize ),
2026 & ierr_mpi )
2027 END IF
2028 END DO
2029 sizet = sizet - ( nbmsgs - 1 ) * ovhsize * sizeofint
2030 IF ( sizet .LT. position ) THEN
2031 WRITE(*,*) ' Error sending blocfacto : size < position'
2032 WRITE(*,*) ' Size,position=',sizet,position
2033 CALL mumps_abort()
2034 END IF
2035 IF ( sizet .NE. position ) CALL buf_adjust( buf_cb, position )
2036 RETURN
2037 END SUBROUTINE smumps_buf_send_blocfacto
2038 SUBROUTINE smumps_buf_send_blfac_slave( INODE,
2039 & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU,
2040 & NDEST, PDEST, COMM, KEEP,
2041 & LR_ACTIVATED, BLR_LS, IPANEL,
2042 & A , LA, POSBLOCFACTO, LD_BLOCFACTO,
2043 & IPIV, MAXI_CLUSTER, IERR )
2044 USE smumps_lr_type
2045 IMPLICIT NONE
2046 INTEGER inode, ncolu, iposk, JPOSK, npiv, ndest, fpere
2047 REAL uip21k( npiv, * )
2048 INTEGER pdest( ndest )
2049 INTEGER comm, ierr
2050 INTEGER, INTENT(INOUT) :: keep(500)
2051 LOGICAL, intent(in) :: lr_activated
2052 TYPE (lrb_type), DIMENSION(:), POINTER :: blr_ls
2053 INTEGER(8), intent(in) :: la, posblocfacto
2054 INTEGER, intent(in) :: ld_blocfacto, ipiv(npiv),
2055 & maxi_cluster, ipanel
2056 REAL, intent(inout) :: a(la)
2057 include 'mpif.h'
2058 include 'mumps_tags.h'
2059 INTEGER :: ierr_mpi
2060 INTEGER lr_activated_int
2061 INTEGER position, ireq, ipos, size1, size2, sizet,
2062 & idest, iposmsg, sss, sslr
2063 ierr = 0
2064 CALL mpi_pack_size( 6 + ( ndest - 1 ) * ovhsize,
2065 & mpi_integer, comm, size1, ierr_mpi )
2066 size2 = 0
2067 CALL mpi_pack_size(2, mpi_integer, comm, sslr, ierr_mpi )
2068 size2=size2+sslr
2069 IF (.NOT. lr_activated) THEN
2070 CALL mpi_pack_size( abs(npiv)*ncolu, mpi_real,
2071 & comm, sslr, ierr_mpi )
2072 size2=size2+sslr
2073 ELSE
2074 CALL mumps_mpi_pack_size_lr( blr_ls, sslr, comm, ierr )
2075 size2=size2+sslr
2076 ENDIF
2077 sizet = size1 + size2
2078 IF (sizet.GT.size_rbuf_bytes) THEN
2079 CALL mpi_pack_size( 6 ,
2080 & mpi_integer, comm, sss, ierr_mpi )
2081 sss = sss+size2
2082 IF (sss.GT.size_rbuf_bytes) THEN
2083 ierr = -2
2084 RETURN
2085 ENDIF
2086 END IF
2087 CALL buf_look( buf_cb, ipos, ireq, sizet, ierr,
2088 & ndest, pdest)
2089 IF ( ierr .LT. 0 ) THEN
2090 RETURN
2091 ENDIF
2092 buf_cb%ILASTMSG = buf_cb%ILASTMSG + ( ndest - 1 ) * ovhsize
2093 ipos = ipos - ovhsize
2094 DO idest = 1, ndest - 1
2095 buf_cb%CONTENT( ipos + ( idest - 1 ) * ovhsize ) =
2096 & ipos + idest * ovhsize
2097 END DO
2098 buf_cb%CONTENT( ipos + ( ndest - 1 ) * ovhsize ) = 0
2099 iposmsg = ipos + ovhsize * ndest
2100 position = 0
2101 CALL mpi_pack( inode, 1, mpi_integer,
2102 & buf_cb%CONTENT( iposmsg ), sizet,
2103 & position, comm, ierr_mpi )
2104 CALL mpi_pack( iposk, 1, mpi_integer,
2105 & buf_cb%CONTENT( iposmsg ), sizet,
2106 & position, comm, ierr_mpi )
2107 CALL mpi_pack( jposk, 1, mpi_integer,
2108 & buf_cb%CONTENT( iposmsg ), sizet,
2109 & position, comm, ierr_mpi )
2110 CALL mpi_pack( npiv, 1, mpi_integer,
2111 & buf_cb%CONTENT( iposmsg ), sizet,
2112 & position, comm, ierr_mpi )
2113 CALL mpi_pack( fpere, 1, mpi_integer,
2114 & buf_cb%CONTENT( iposmsg ), sizet,
2115 & position, comm, ierr_mpi )
2116 CALL mpi_pack( ncolu, 1, mpi_integer,
2117 & buf_cb%CONTENT( iposmsg ), sizet,
2118 & position, comm, ierr_mpi )
2119 IF (lr_activated) THEN
2120 lr_activated_int = 1
2121 ELSE
2122 lr_activated_int = 0
2123 ENDIF
2124 CALL mpi_pack( lr_activated_int, 1, mpi_integer,
2125 & buf_cb%CONTENT( iposmsg ), sizet,
2126 & position, comm, ierr_mpi )
2127 CALL mpi_pack( ipanel, 1, mpi_integer,
2128 & buf_cb%CONTENT( iposmsg ), sizet,
2129 & position, comm, ierr_mpi )
2130 IF (lr_activated) THEN
2131 CALL mumps_mpi_pack_scale_lr( blr_ls,
2132 & buf_cb%CONTENT( iposmsg:
2133 & iposmsg+(sizet+keep(34)-1)/keep(34)-1 ),
2134 & sizet, position, comm,
2135 & a, la, posblocfacto, ld_blocfacto,
2136 & ipiv, npiv, maxi_cluster, ierr )
2137 ELSE
2138 CALL mpi_pack( uip21k, abs(npiv) * ncolu,
2139 & mpi_real,
2140 & buf_cb%CONTENT( iposmsg ), sizet,
2141 & position, comm, ierr_mpi )
2142 ENDIF
2143 DO idest = 1, ndest
2144 keep(266)=keep(266)+1
2145 CALL mpi_isend( buf_cb%CONTENT( iposmsg ), position, mpi_packed,
2146 & pdest(idest), bloc_facto_sym_slave, comm,
2147 & buf_cb%CONTENT( ireq + ( idest-1 ) * ovhsize ),
2148 & ierr_mpi )
2149 END DO
2150 sizet = sizet - ( ndest - 1 ) * ovhsize * sizeofint
2151 IF ( sizet .LT. position ) THEN
2152 WRITE(*,*) ' Error sending blfac slave : size < position'
2153 WRITE(*,*) ' Size,position=',sizet,position
2154 CALL mumps_abort()
2155 END IF
2156 IF ( sizet .NE. position ) CALL buf_adjust( buf_cb, position )
2157 RETURN
2158 END SUBROUTINE smumps_buf_send_blfac_slave
2159 SUBROUTINE smumps_buf_send_contrib_type3( N, ISON,
2160 & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON,
2161 & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL,
2162 & NSUBSET_ROW, NSUBSET_COL,
2163 & NSUPROW, NSUPCOL,
2164 & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL,
2165 & NBLOCK, PDEST, COMM, IERR ,
2166 & TAB, TABSIZE, TRANSP, SIZE_PACK,
2167 & N_ALREADY_SENT, KEEP, BBPCBP )
2168 IMPLICIT NONE
2169 INTEGER N, ison, nbcol_son, nbrow_son, nsubset_row, nsubset_col
2170 INTEGER nprow, npcol, mblock, nblock, ld_son
2171 INTEGER bbpcbp
2172 INTEGER pdest, tag, comm, ierr
2173 INTEGER indcol_son( nbcol_son ), indrow_son( nbrow_son )
2174 INTEGER subset_row( nsubset_row ), subset_col( nsubset_col )
2175 INTEGER :: rg2l_row(n)
2176 INTEGER :: rg2l_col(n)
2177 INTEGER nsuprow, nsupcol
2178 INTEGER(8), INTENT(IN) :: tabsize
2179 INTEGER size_pack
2180 INTEGER keep(500)
2181 REAL val_son( ld_son, * ), tab(*)
2182 LOGICAL transp
2183 INTEGER n_already_sent
2184 INCLUDE 'mpif.h'
2185 INTEGER :: ierr_mpi
2186 INTEGER size1, size2, size_av, position
2187 INTEGER size_cbp, size_tmp
2188 INTEGER ireq, ipos, itab
2189 INTEGER isub, jsub, i, j
2190 INTEGER iloc_root, jloc_root
2191 INTEGER ipos_root, jpos_root
2192 INTEGER ione
2193 LOGICAL recv_buf_smaller_than_send
2194 INTEGER pdest2(1)
2195 parameter( ione=1 )
2196 INTEGER n_packet
2197 INTEGER nsubset_row_eff, nsubset_col_eff, nsupcol_eff
2198 pdest2(1) = pdest
2199 ierr = 0
2200 IF ( nsubset_row * nsubset_col .NE. 0 ) THEN
2201 CALL smumps_buf_size_available( buf_cb, size_av )
2202 IF (size_av .LT. size_rbuf_bytes) THEN
2203 recv_buf_smaller_than_send = .false.
2204 ELSE
2205 recv_buf_smaller_than_send = .true.
2206 size_av = size_rbuf_bytes
2207 ENDIF
2208 size_av = min(size_av, size_rbuf_bytes)
2209 CALL mpi_pack_size(8 + nsubset_col,
2210 & mpi_integer, comm, size1, ierr_mpi )
2211 size_cbp = 0
2212 IF (n_already_sent .EQ. 0 .AND.
2213 & min(nsuprow,nsupcol) .GT.0) THEN
2214 CALL mpi_pack_size(nsuprow, mpi_integer, comm,
2215 & size_cbp, ierr_mpi )
2216 CALL mpi_pack_size(nsupcol, mpi_integer, comm,
2217 & size_tmp, ierr_mpi )
2218 size_cbp = size_cbp + size_tmp
2219 CALL mpi_pack_size(nsuprow*nsupcol,
2220 & mpi_real, comm,
2221 & size_tmp, ierr_mpi )
2222 size_cbp = size_cbp + size_tmp
2223 size1 = size1 + size_cbp
2224 ENDIF
2225 IF (bbpcbp.EQ.1) THEN
2226 nsubset_col_eff = nsubset_col - nsupcol
2227 nsupcol_eff = 0
2228 ELSE
2229 nsubset_col_eff = nsubset_col
2230 nsupcol_eff = nsupcol
2231 ENDIF
2232 nsubset_row_eff = nsubset_row - nsuprow
2233 n_packet =
2234 & (size_av - size1) / (sizeofint + nsubset_col_eff * sizeofreal)
2235 10 CONTINUE
2236 n_packet = min( n_packet,
2237 & nsubset_row_eff-n_already_sent )
2238 IF (n_packet .LE. 0 .AND.
2239 & nsubset_row_eff-n_already_sent.GT.0) THEN
2240 IF (recv_buf_smaller_than_send) THEN
2241 ierr=-3
2242 GOTO 100
2243 ELSE
2244 ierr = -1
2245 GOTO 100
2246 ENDIF
2247 ENDIF
2248 CALL mpi_pack_size( 8 + nsubset_col_eff + n_packet,
2249 & mpi_integer, comm, size1, ierr_mpi )
2250 size1 = size1 + size_cbp
2251 CALL mpi_pack_size( n_packet * nsubset_col_eff,
2252 & mpi_real,
2253 & comm, size2, ierr_mpi )
2254 size_pack = size1 + size2
2255 IF (size_pack .GT. size_av) THEN
2256 n_packet = n_packet - 1
2257 IF ( n_packet > 0 ) THEN
2258 GOTO 10
2259 ELSE
2260 IF (recv_buf_smaller_than_send) THEN
2261 ierr = -3
2262 GOTO 100
2263 ELSE
2264 ierr = -1
2265 GOTO 100
2266 ENDIF
2267 ENDIF
2268 ENDIF
2269 IF (n_packet + n_already_sent .NE. nsubset_row - nsuprow
2270 & .AND.
2271 & size_pack .LT. size_rbuf_bytes / 4
2272 & .AND. .NOT. recv_buf_smaller_than_send)
2273 & THEN
2274 ierr = -1
2275 GOTO 100
2276 ENDIF
2277 ELSE
2278 n_packet = 0
2279 CALL mpi_pack_size(8,mpi_integer, comm, size_pack, ierr_mpi )
2280 END IF
2281 IF ( size_pack.GT.size_rbuf_bytes ) THEN
2282 ierr = -3
2283 GOTO 100
2284 ENDIF
2285 CALL buf_look( buf_cb, ipos, ireq, size_pack, ierr,
2286 & ione, pdest2
2287 & )
2288 IF ( ierr .LT. 0 ) GOTO 100
2289 position = 0
2290 CALL mpi_pack( ison, 1, mpi_integer,
2291 & buf_cb%CONTENT( ipos ),
2292 & size_pack, position, comm, ierr_mpi )
2293 CALL mpi_pack( nsubset_row, 1, mpi_integer,
2294 & buf_cb%CONTENT( ipos ),
2295 & size_pack, position, comm, ierr_mpi )
2296 CALL mpi_pack( nsuprow, 1, mpi_integer,
2297 & buf_cb%CONTENT( ipos ),
2298 & size_pack, position, comm, ierr_mpi )
2299 CALL mpi_pack( nsubset_col, 1, mpi_integer,
2300 & buf_cb%CONTENT( ipos ),
2301 & size_pack, position, comm, ierr_mpi )
2302 CALL mpi_pack( nsupcol, 1, mpi_integer,
2303 & buf_cb%CONTENT( ipos ),
2304 & size_pack, position, comm, ierr_mpi )
2305 CALL mpi_pack( n_already_sent, 1, mpi_integer,
2306 & buf_cb%CONTENT( ipos ),
2307 & size_pack, position, comm, ierr_mpi )
2308 CALL mpi_pack( n_packet, 1, mpi_integer,
2309 & buf_cb%CONTENT( ipos ),
2310 & size_pack, position, comm, ierr_mpi )
2311 CALL mpi_pack( bbpcbp, 1, mpi_integer,
2312 & buf_cb%CONTENT( ipos ),
2313 & size_pack, position, comm, ierr_mpi )
2314 IF ( nsubset_row * nsubset_col .NE. 0 ) THEN
2315 IF (n_already_sent .EQ. 0 .AND.
2316 & min(nsuprow, nsupcol) .GT. 0) THEN
2317 DO isub = nsubset_row-nsuprow+1, nsubset_row
2318 i = subset_row( isub )
2319 ipos_root = rg2l_row(indcol_son( i ))
2320 iloc_root = mblock
2321 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
2322 & + mod( ipos_root - 1, mblock ) + 1
2323 CALL mpi_pack( iloc_root, 1, mpi_integer,
2324 & buf_cb%CONTENT( ipos ),
2325 & size_pack, position, comm, ierr_mpi )
2326 ENDDO
2327 DO isub = nsubset_col-nsupcol+1, nsubset_col
2328 j = subset_col( isub )
2329 jpos_root = indrow_son( j ) - n
2330 jloc_root = nblock
2331 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
2332 & + mod( jpos_root - 1, nblock ) + 1
2333 CALL mpi_pack( jloc_root, 1, mpi_integer,
2334 & buf_cb%CONTENT( ipos ),
2335 & size_pack, position, comm, ierr_mpi )
2336 ENDDO
2337 IF ( tabsize.GE.int(nsuprow,8)*int(nsupcol,8) ) THEN
2338 itab = 1
2339 DO jsub = nsubset_row - nsuprow+1, nsubset_row
2340 j = subset_row(jsub)
2341 DO isub = nsubset_col - nsupcol+1, nsubset_col
2342 i = subset_col(isub)
2343 tab(itab) = val_son(j, i)
2344 itab = itab + 1
2345 ENDDO
2346 ENDDO
2347 CALL mpi_pack(tab(1), nsuprow*nsupcol,
2348 & mpi_real,
2349 & buf_cb%CONTENT( ipos ),
2350 & size_pack, position, comm, ierr_mpi )
2351 ELSE
2352 DO jsub = nsubset_row - nsuprow+1, nsubset_row
2353 j = subset_row(jsub)
2354 DO isub = nsubset_col - nsupcol+1, nsubset_col
2355 i = subset_col(isub)
2356 CALL mpi_pack(val_son(j,i), 1,
2357 & mpi_real,
2358 & buf_cb%CONTENT( ipos ),
2359 & size_pack, position, comm, ierr_mpi )
2360 ENDDO
2361 ENDDO
2362 ENDIF
2363 ENDIF
2364 IF ( .NOT. transp ) THEN
2365 DO isub = n_already_sent+1, n_already_sent+n_packet
2366 i = subset_row( isub )
2367 ipos_root = rg2l_row( indrow_son( i ) )
2368 iloc_root = mblock
2369 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
2370 & + mod( ipos_root - 1, mblock ) + 1
2371 CALL mpi_pack( iloc_root, 1, mpi_integer,
2372 & buf_cb%CONTENT( ipos ),
2373 & size_pack, position, comm, ierr_mpi )
2374 END DO
2375 DO jsub = 1, nsubset_col_eff - nsupcol_eff
2376 j = subset_col( jsub )
2377 jpos_root = rg2l_col( indcol_son( j ) )
2378 jloc_root = nblock
2379 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
2380 & + mod( jpos_root - 1, nblock ) + 1
2381 CALL mpi_pack( jloc_root, 1, mpi_integer,
2382 & buf_cb%CONTENT( ipos ),
2383 & size_pack, position, comm, ierr_mpi )
2384 END DO
2385 DO jsub = nsubset_col_eff-nsupcol_eff+1, nsubset_col_eff
2386 j = subset_col( jsub )
2387 jpos_root = indcol_son( j ) - n
2388 jloc_root = nblock
2389 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
2390 & + mod( jpos_root - 1, nblock ) + 1
2391 CALL mpi_pack( jloc_root, 1, mpi_integer,
2392 & buf_cb%CONTENT( ipos ),
2393 & size_pack, position, comm, ierr_mpi )
2394 ENDDO
2395 ELSE
2396 DO jsub = n_already_sent+1, n_already_sent+n_packet
2397 j = subset_row( jsub )
2398 ipos_root = rg2l_row( indcol_son( j ) )
2399 iloc_root = mblock
2400 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
2401 & + mod( ipos_root - 1, mblock ) + 1
2402 CALL mpi_pack( iloc_root, 1, mpi_integer,
2403 & buf_cb%CONTENT( ipos ),
2404 & size_pack, position, comm, ierr_mpi )
2405 END DO
2406 DO isub = 1, nsubset_col_eff - nsupcol_eff
2407 i = subset_col( isub )
2408 jpos_root = rg2l_col( indrow_son( i ) )
2409 jloc_root = nblock
2410 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
2411 & + mod( jpos_root - 1, nblock ) + 1
2412 CALL mpi_pack( jloc_root, 1, mpi_integer,
2413 & buf_cb%CONTENT( ipos ),
2414 & size_pack, position, comm, ierr_mpi )
2415 END DO
2416 DO isub = nsubset_col_eff - nsupcol_eff + 1, nsubset_col_eff
2417 i = subset_col( isub )
2418 jpos_root = indrow_son(i) - n
2419 jloc_root = nblock
2420 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
2421 & + mod( jpos_root - 1, nblock ) + 1
2422 CALL mpi_pack( jloc_root, 1, mpi_integer,
2423 & buf_cb%CONTENT( ipos ),
2424 & size_pack, position, comm, ierr_mpi )
2425 ENDDO
2426 END IF
2427 IF ( tabsize.GE.int(n_packet,8)*int(nsubset_col_eff,8) ) THEN
2428 IF ( .NOT. transp ) THEN
2429 itab = 1
2430 DO isub = n_already_sent+1,
2431 & n_already_sent+n_packet
2432 i = subset_row( isub )
2433 DO jsub = 1, nsubset_col_eff
2434 j = subset_col( jsub )
2435 tab( itab ) = val_son(j,i)
2436 itab = itab + 1
2437 END DO
2438 END DO
2439 CALL mpi_pack(tab(1), nsubset_col_eff*n_packet,
2440 & mpi_real,
2441 & buf_cb%CONTENT( ipos ),
2442 & size_pack, position, comm, ierr_mpi )
2443 ELSE
2444 itab = 1
2445 DO jsub = n_already_sent+1, n_already_sent+n_packet
2446 j = subset_row( jsub )
2447 DO isub = 1, nsubset_col_eff
2448 i = subset_col( isub )
2449 tab( itab ) = val_son( j, i )
2450 itab = itab + 1
2451 END DO
2452 END DO
2453 CALL mpi_pack(tab(1), nsubset_col_eff*n_packet,
2454 & mpi_real,
2455 & buf_cb%CONTENT( ipos ),
2456 & size_pack, position, comm, ierr_mpi )
2457 END IF
2458 ELSE
2459 IF ( .NOT. transp ) THEN
2460 DO isub = n_already_sent+1, n_already_sent+n_packet
2461 i = subset_row( isub )
2462 DO jsub = 1, nsubset_col_eff
2463 j = subset_col( jsub )
2464 CALL mpi_pack( val_son( j, i ), 1,
2465 & mpi_real,
2466 & buf_cb%CONTENT( ipos ),
2467 & size_pack, position, comm, ierr_mpi )
2468 END DO
2469 END DO
2470 ELSE
2471 DO jsub = n_already_sent+1, n_already_sent+n_packet
2472 j = subset_row( jsub )
2473 DO isub = 1, nsubset_col_eff
2474 i = subset_col( isub )
2475 CALL mpi_pack( val_son( j, i ), 1,
2476 & mpi_real,
2477 & buf_cb%CONTENT( ipos ),
2478 & size_pack, position, comm, ierr_mpi )
2479 END DO
2480 END DO
2481 END IF
2482 ENDIF
2483 END IF
2484 keep(266)=keep(266)+1
2485 CALL mpi_isend( buf_cb%CONTENT( ipos ), position, mpi_packed,
2486 & pdest, tag, comm, buf_cb%CONTENT( ireq ),
2487 & ierr_mpi )
2488 IF ( size_pack .LT. position ) THEN
2489 WRITE(*,*) ' Error sending contribution to root:Size<positn'
2490 WRITE(*,*) ' Size,position=',size_pack,position
2491 CALL mumps_abort()
2492 END IF
2493 IF ( size_pack .NE. position )
2494 & CALL buf_adjust( buf_cb, position )
2495 n_already_sent = n_already_sent + n_packet
2496 IF (nsubset_row * nsubset_col .NE. 0) THEN
2497 IF ( n_already_sent.NE.nsubset_row_eff ) ierr = -1
2498 ENDIF
2499 100 CONTINUE
2500 RETURN
2501 END SUBROUTINE smumps_buf_send_contrib_type3
2502 SUBROUTINE smumps_buf_send_rtnelind( ISON, NELIM,
2503 & NELIM_ROW, NELIM_COL, NSLAVES, SLAVES,
2504 & DEST, COMM, KEEP, IERR )
2505 INTEGER ison, nelim
2506 INTEGER nslaves, dest, comm, ierr
2507 INTEGER nelim_row( nelim ), nelim_col( nelim )
2508 INTEGER slaves( nslaves )
2509 INTEGER, INTENT(INOUT) :: keep(500)
2510 include 'mpif.h'
2511 include 'mumps_tags.h'
2512 INTEGER :: ierr_mpi
2513 INTEGER size, position, ipos, ireq
2514 INTEGER ione
2515 INTEGER dest2(1)
2516 parameter( ione=1 )
2517 dest2(1) = dest
2518 ierr = 0
2519 SIZE = ( 3 + nslaves + 2 * nelim ) * sizeofint
2520 IF (size.GT.size_rbuf_bytes) THEN
2521 ierr = -3
2522 RETURN
2523 ENDIF
2524 CALL buf_look( buf_cb, ipos, ireq, SIZE, ierr,
2525 & ione, dest2
2526 & )
2527 IF ( ierr .LT. 0 ) THEN
2528 RETURN
2529 ENDIF
2530 position = ipos
2531 buf_cb%CONTENT( position ) = ison
2532 position = position + 1
2533 buf_cb%CONTENT( position ) = nelim
2534 position = position + 1
2535 buf_cb%CONTENT( position ) = nslaves
2536 position = position + 1
2537 buf_cb%CONTENT( position: position + nelim - 1 ) = nelim_row
2538 position = position + nelim
2539 buf_cb%CONTENT( position: position + nelim - 1 ) = nelim_col
2540 position = position + nelim
2541 buf_cb%CONTENT( position: position + nslaves - 1 ) = slaves
2542 position = position + nslaves
2543 position = position - ipos
2544 IF ( position * sizeofint .NE. SIZE ) THEN
2545 WRITE(*,*) 'Error in SMUMPS_BUF_SEND_ROOT_NELIM_INDICES:',
2546 & 'wrong estimated size'
2547 CALL mumps_abort()
2548 END IF
2549 keep(266)=keep(266)+1
2550 CALL mpi_isend( buf_cb%CONTENT( ipos ), SIZE,
2551 & mpi_packed,
2552 & dest, root_nelim_indices, comm,
2553 & buf_cb%CONTENT( ireq ), ierr_mpi )
2554 RETURN
2555 END SUBROUTINE smumps_buf_send_rtnelind
2556 SUBROUTINE smumps_buf_send_root2son( ISON, NELIM_ROOT,
2557 & DEST, COMM, KEEP, IERR )
2558 IMPLICIT NONE
2559 INTEGER ison, nelim_root, dest, comm, ierr
2560 INTEGER, INTENT(INOUT) :: keep(500)
2561 include 'mpif.h'
2562 include 'mumps_tags.h'
2563 INTEGER :: ierr_mpi
2564 INTEGER ipos, ireq, size
2565 INTEGER ione
2566 INTEGER dest2(1)
2567 parameter( ione=1 )
2568 dest2(1)=dest
2569 ierr = 0
2570 SIZE = 2 * sizeofint
2571 CALL buf_look( buf_small, ipos, ireq, SIZE, ierr,
2572 & ione, dest2
2573 & )
2574 IF ( ierr .LT. 0 ) THEN
2575 WRITE(*,*) 'Internal error 1 with small buffers '
2576 CALL mumps_abort()
2577 END IF
2578 IF ( ierr .LT. 0 ) THEN
2579 RETURN
2580 ENDIF
2581 buf_small%CONTENT( ipos ) = ison
2582 buf_small%CONTENT( ipos + 1 ) = nelim_root
2583 keep(266)=keep(266)+1
2584 CALL mpi_isend( buf_small%CONTENT( ipos ), SIZE,
2585 & mpi_packed,
2586 & dest, root_2son, comm,
2587 & buf_small%CONTENT( ireq ), ierr_mpi )
2588 RETURN
2589 END SUBROUTINE smumps_buf_send_root2son
2590 SUBROUTINE smumps_buf_send_root2slave
2591 & ( tot_root_size, tot_cont2recv, dest, comm, keep, ierr )
2592 IMPLICIT NONE
2593 INTEGER tot_root_size, tot_cont2recv, dest, comm, ierr
2594 INTEGER, INTENT(INOUT) :: keep(500)
2595 include 'mpif.h'
2596 include 'mumps_tags.h'
2597 INTEGER :: ierr_mpi
2598 INTEGER SIZE, ipos, ireq
2599 INTEGER ione
2600 INTEGER dest2(1)
2601 parameter( ione=1 )
2602 ierr = 0
2603 dest2(1) = dest
2604 SIZE = 2 * sizeofint
2605 CALL buf_look( buf_small, ipos, ireq, SIZE, ierr,
2606 & ione, dest2
2607 & )
2608 IF ( ierr .LT. 0 ) THEN
2609 WRITE(*,*) 'Internal error 2 with small buffers '
2610 CALL mumps_abort()
2611 END IF
2612 IF ( ierr .LT. 0 ) THEN
2613 RETURN
2614 ENDIF
2615 buf_small%CONTENT( ipos ) = tot_root_size
2616 buf_small%CONTENT( ipos + 1 ) = tot_cont2recv
2617 keep(266)=keep(266)+1
2618 CALL mpi_isend( buf_small%CONTENT( ipos ), SIZE,
2619 & mpi_packed,
2620 & dest, root_2slave, comm,
2621 & buf_small%CONTENT( ireq ), ierr_mpi )
2622 RETURN
2623 END SUBROUTINE smumps_buf_send_root2slave
2624 SUBROUTINE smumps_buf_send_backvec
2625 & ( nrhs, inode, w, lw, ld_w, dest, msgtag,
2626 & jbdeb, jbfin, keep, comm, ierr )
2627 IMPLICIT NONE
2628 INTEGER nrhs, inode,lw,comm,ierr,dest,msgtag, ld_w
2629 INTEGER, intent(in) :: jbdeb, jbfin
2630 REAL :: w(ld_w, *)
2631 INTEGER, INTENT(INOUT) :: keep(500)
2632 include 'mpif.h'
2633 INTEGER :: ierr_mpi
2634 INTEGER size, size1, size2
2635 INTEGER position, ireq, ipos
2636 INTEGER ione, k
2637 INTEGER dest2(1)
2638 parameter( ione=1 )
2639 ierr = 0
2640 dest2(1) = dest
2641 CALL mpi_pack_size( 4 , mpi_integer, comm, size1, ierr_mpi )
2642 CALL mpi_pack_size( lw*nrhs, mpi_real, comm,
2643 & size2, ierr_mpi )
2644 SIZE = size1 + size2
2645 CALL buf_look( buf_cb, ipos, ireq, SIZE, ierr,
2646 & ione, dest2
2647 & )
2648 IF ( ierr .LT. 0 ) THEN
2649 RETURN
2650 ENDIF
2651 position = 0
2652 CALL mpi_pack( inode, 1, mpi_integer,
2653 & buf_cb%CONTENT( ipos ), SIZE,
2654 & position, comm, ierr_mpi )
2655 CALL mpi_pack( lw , 1, mpi_integer,
2656 & buf_cb%CONTENT( ipos ), SIZE,
2657 & position, comm, ierr_mpi )
2658 CALL mpi_pack( jbdeb , 1, mpi_integer,
2659 & buf_cb%CONTENT( ipos ), SIZE,
2660 & position, comm, ierr_mpi )
2661 CALL mpi_pack( jbfin , 1, mpi_integer,
2662 & buf_cb%CONTENT( ipos ), SIZE,
2663 & position, comm, ierr_mpi )
2664 DO k=1, nrhs
2665 CALL mpi_pack( w(1,k), lw, mpi_real,
2666 & buf_cb%CONTENT( ipos ), SIZE,
2667 & position, comm, ierr_mpi )
2668 END DO
2669 keep(266)=keep(266)+1
2670 CALL mpi_isend( buf_cb%CONTENT( ipos ), position, mpi_packed,
2671 & dest, msgtag, comm,
2672 & buf_cb%CONTENT( ireq ), ierr_mpi )
2673 IF ( SIZE .LT. position ) THEN
2674 WRITE(*,*) 'Try_update: SIZE, POSITION = ',
2675 & SIZE, position
2676 CALL mumps_abort()
2677 END IF
2678 IF ( SIZE .NE. position ) CALL buf_adjust( buf_cb, position )
2679 RETURN
2680 END SUBROUTINE smumps_buf_send_backvec
2681 SUBROUTINE smumps_buf_send_update_load
2682 & ( bdc_sbtr,bdc_mem,bdc_md, comm, nprocs, load,
2683 & mem,sbtr_cur,
2684 & lu_usage,
2685 & future_niv2,
2686 & myid, keep, ierr)
2687 IMPLICIT NONE
2688 INTEGER comm, nprocs, myid, ierr
2689 INTEGER, INTENT(INOUT) :: keep(500)
2690 INTEGER future_niv2(nprocs)
2691 DOUBLE PRECISION lu_usage
2692 DOUBLE PRECISION load
2693 DOUBLE PRECISION mem,sbtr_cur
2694 LOGICAL bdc_mem,bdc_sbtr,bdc_md
2695 include 'mpif.h'
2696 include 'mumps_tags.h'
2697 INTEGER :: ierr_mpi
2698 INTEGER position, ireq, ipos, size1, size2, size
2699 INTEGER i, ndest, idest, iposmsg, what, nreals
2700 INTEGER izero
2701 INTEGER myid2(1)
2702 parameter( izero=0 )
2703 ierr = 0
2704 myid2(1) = myid
2705 ndest = nprocs - 1
2706 ndest = 0
2707 DO i = 1, nprocs
2708 IF ( i .NE. myid + 1 .AND. future_niv2(i).NE.0) THEN
2709 ndest = ndest + 1
2710 ENDIF
2711 ENDDO
2712 IF ( ndest .eq. 0 ) THEN
2713 RETURN
2714 ENDIF
2715 CALL mpi_pack_size( 1 + (ndest-1) * ovhsize,
2716 & mpi_integer, comm,
2717 & size1, ierr_mpi )
2718 nreals = 1
2719 IF (bdc_mem) THEN
2720 nreals = 2
2721 ENDIf
2722 IF (bdc_sbtr)THEN
2723 nreals = 3
2724 ENDIF
2725 IF(bdc_md)THEN
2726 nreals=nreals+1
2727 ENDIF
2728 CALL mpi_pack_size( nreals, mpi_double_precision,
2729 & comm, size2, ierr_mpi )
2730 SIZE = size1 + size2
2731 CALL buf_look( buf_load, ipos, ireq, SIZE, ierr,
2732 & izero, myid2
2733 & )
2734 IF ( ierr .LT. 0 ) THEN
2735 RETURN
2736 ENDIF
2737 buf_load%ILASTMSG = buf_load%ILASTMSG + ( ndest - 1 ) * ovhsize
2738 ipos = ipos - ovhsize
2739 DO idest = 1, ndest - 1
2740 buf_load%CONTENT( ipos + ( idest - 1 ) * ovhsize ) =
2741 & ipos + idest * ovhsize
2742 END DO
2743 buf_load%CONTENT( ipos + ( ndest - 1 ) * ovhsize ) = 0
2744 iposmsg = ipos + ovhsize * ndest
2745 what = 0
2746 position = 0
2747 CALL mpi_pack( what, 1, mpi_integer,
2748 & buf_load%CONTENT( iposmsg ), SIZE,
2749 & position, comm, ierr_mpi )
2750 CALL mpi_pack( load, 1, mpi_double_precision,
2751 & buf_load%CONTENT( iposmsg ), SIZE,
2752 & position, comm, ierr_mpi )
2753 IF (bdc_mem) THEN
2754 CALL mpi_pack( mem, 1, mpi_double_precision,
2755 & buf_load%CONTENT( iposmsg ), SIZE,
2756 & position, comm, ierr_mpi )
2757 END IF
2758 IF (bdc_sbtr) THEN
2759 CALL mpi_pack( sbtr_cur, 1, mpi_double_precision,
2760 & buf_load%CONTENT( iposmsg ), SIZE,
2761 & position, comm, ierr_mpi )
2762 END IF
2763 IF(bdc_md)THEN
2764 CALL mpi_pack( lu_usage, 1, mpi_double_precision,
2765 & buf_load%CONTENT( iposmsg ), SIZE,
2766 & position, comm, ierr_mpi )
2767 ENDIF
2768 idest = 0
2769 DO i = 0, nprocs - 1
2770 IF ( i .NE. myid .AND. future_niv2(i+1) .NE. 0) THEN
2771 idest = idest + 1
2772 keep(267)=keep(267)+1
2773 CALL mpi_isend( buf_load%CONTENT( iposmsg ),
2774 & position, mpi_packed, i,
2775 & update_load, comm,
2776 & buf_load%CONTENT( ireq+(idest-1)*ovhsize ),
2777 & ierr_mpi )
2778 END IF
2779 END DO
2780 SIZE = SIZE - ( ndest - 1 ) * ovhsize * sizeofint
2781 IF ( SIZE .LT. position ) THEN
2782 WRITE(*,*) ' Error in SMUMPS_BUF_SEND_UPDATE_LOAD'
2783 WRITE(*,*) ' Size,position=',SIZE,position
2784 CALL mumps_abort()
2785 END IF
2786 IF ( SIZE .NE. position )
2787 & CALL buf_adjust( buf_load, position )
2788 RETURN
2789 END SUBROUTINE smumps_buf_send_update_load
2790 SUBROUTINE smumps_buf_broadcast
2791 & ( what, comm, nprocs,
2792 & future_niv2,
2793 & load, upd_load,
2794 & myid, keep, ierr)
2795 IMPLICIT NONE
2796 INTEGER comm, nprocs, myid, ierr, what
2797 DOUBLE PRECISION load,upd_load
2798 INTEGER, INTENT(INOUT) :: keep(500)
2799 include 'mpif.h'
2800 include 'mumps_tags.h'
2801 INTEGER :: ierr_mpi
2802 INTEGER position, ireq, ipos, size1, size2, size
2803 INTEGER i, ndest, idest, iposmsg, nreals
2804 INTEGER izero
2805 INTEGER myid2(1)
2806 INTEGER future_niv2(nprocs)
2807 parameter( izero=0 )
2808 ierr = 0
2809 IF (what .NE. 2 .AND. what .NE. 3 .AND.
2810 & what.NE.6.AND. what.NE.8 .AND.what.NE.9.AND.
2811 & what.NE.17) THEN
2812 WRITE(*,*)
2813 & "Internal error 1 in SMUMPS_BUF_BROADCAST",what
2814 END IF
2815 myid2(1) = myid
2816 ndest = nprocs - 1
2817 ndest = 0
2818 DO i = 1, nprocs
2819 IF ( i .NE. myid + 1 .AND. future_niv2(i).NE.0) THEN
2820 ndest = ndest + 1
2821 ENDIF
2822 ENDDO
2823 IF ( ndest .eq. 0 ) THEN
2824 RETURN
2825 ENDIF
2826 CALL mpi_pack_size( 1 + (ndest-1) * ovhsize,
2827 & mpi_integer, comm,
2828 & size1, ierr_mpi )
2829 IF((what.NE.17).AND.(what.NE.10))THEN
2830 nreals = 1
2831 ELSE
2832 nreals = 2
2833 ENDIF
2834 CALL mpi_pack_size( nreals, mpi_double_precision,
2835 & comm, size2, ierr_mpi )
2836 SIZE = size1 + size2
2837 CALL buf_look( buf_load, ipos, ireq, SIZE, ierr,
2838 & izero, myid2
2839 & )
2840 IF ( ierr .LT. 0 ) THEN
2841 RETURN
2842 ENDIF
2843 buf_load%ILASTMSG = buf_load%ILASTMSG + ( ndest - 1 ) * ovhsize
2844 ipos = ipos - ovhsize
2845 DO idest = 1, ndest - 1
2846 buf_load%CONTENT( ipos + ( idest - 1 ) * ovhsize ) =
2847 & ipos + idest * ovhsize
2848 END DO
2849 buf_load%CONTENT( ipos + ( ndest - 1 ) * ovhsize ) = 0
2850 iposmsg = ipos + ovhsize * ndest
2851 position = 0
2852 CALL mpi_pack( what, 1, mpi_integer,
2853 & buf_load%CONTENT( iposmsg ), SIZE,
2854 & position, comm, ierr_mpi )
2855 CALL mpi_pack( load, 1, mpi_double_precision,
2856 & buf_load%CONTENT( iposmsg ), SIZE,
2857 & position, comm, ierr_mpi )
2858 IF((what.EQ.17).OR.(what.EQ.10))THEN
2859 CALL mpi_pack( upd_load, 1, mpi_double_precision,
2860 & buf_load%CONTENT( iposmsg ), SIZE,
2861 & position, comm, ierr_mpi )
2862 ENDIF
2863 idest = 0
2864 DO i = 0, nprocs - 1
2865 IF ( i .NE. myid .AND. future_niv2(i+1) .NE. 0) THEN
2866 idest = idest + 1
2867 keep(267)=keep(267)+1
2868 CALL mpi_isend( buf_load%CONTENT( iposmsg ),
2869 & position, mpi_packed, i,
2870 & update_load, comm,
2871 & buf_load%CONTENT( ireq+(idest-1)*ovhsize ),
2872 & ierr_mpi )
2873 END IF
2874 END DO
2875 SIZE = SIZE - ( ndest - 1 ) * ovhsize * sizeofint
2876 IF ( SIZE .LT. position ) THEN
2877 WRITE(*,*) ' Error in SMUMPS_BUF_BROADCAST'
2878 WRITE(*,*) ' Size,position=',SIZE,position
2879 CALL mumps_abort()
2880 END IF
2881 IF ( SIZE .NE. position )
2882 & CALL buf_adjust( buf_load, position )
2883 RETURN
2884 END SUBROUTINE smumps_buf_broadcast
2885 SUBROUTINE smumps_buf_send_fils
2886 & ( what, comm, nprocs,
2887 & father_node,inode,ncb,keep,
2888 & myid,remote, ierr)
2889 IMPLICIT NONE
2890 INTEGER comm, nprocs, myid, ierr, what,remote
2891 INTEGER father_node,inode
2892 include 'mpif.h'
2893 include 'mumps_tags.h'
2894 INTEGER :: ierr_mpi
2895 INTEGER position, ireq, ipos, size
2896 INTEGER ndest, idest, iposmsg
2897 INTEGER izero,ncb,keep(500)
2898 INTEGER myid2(1)
2899 parameter( izero=0 )
2900 myid2(1) = myid
2901 ndest = 1
2902 IF ( ndest .eq. 0 ) THEN
2903 RETURN
2904 ENDIF
2905 IF((keep(81).EQ.2).OR.(keep(81).EQ.3))THEN
2906 CALL mpi_pack_size( 4 + ovhsize,
2907 & mpi_integer, comm,
2908 & SIZE, ierr_mpi )
2909 ELSE
2910 CALL mpi_pack_size( 2 + ovhsize,
2911 & mpi_integer, comm,
2912 & SIZE, ierr_mpi )
2913 ENDIF
2914 CALL buf_look( buf_load, ipos, ireq, SIZE, ierr,
2915 & izero, myid2
2916 & )
2917 IF ( ierr .LT. 0 ) THEN
2918 RETURN
2919 ENDIF
2920 buf_load%ILASTMSG = buf_load%ILASTMSG + ( ndest - 1 ) * ovhsize
2921 ipos = ipos - ovhsize
2922 DO idest = 1, ndest - 1
2923 buf_load%CONTENT( ipos + ( idest - 1 ) * ovhsize ) =
2924 & ipos + idest * ovhsize
2925 END DO
2926 buf_load%CONTENT( ipos + ( ndest - 1 ) * ovhsize ) = 0
2927 iposmsg = ipos + ovhsize * ndest
2928 position = 0
2929 CALL mpi_pack( what, 1, mpi_integer,
2930 & buf_load%CONTENT( iposmsg ), SIZE,
2931 & position, comm, ierr_mpi )
2932 CALL mpi_pack( father_node, 1, mpi_integer,
2933 & buf_load%CONTENT( iposmsg ), SIZE,
2934 & position, comm, ierr_mpi )
2935 IF((keep(81).EQ.2).OR.(keep(81).EQ.3))THEN
2936 CALL mpi_pack( inode, 1, mpi_integer,
2937 & buf_load%CONTENT( iposmsg ), SIZE,
2938 & position, comm, ierr_mpi )
2939 CALL mpi_pack( ncb, 1, mpi_integer,
2940 & buf_load%CONTENT( iposmsg ), SIZE,
2941 & position, comm, ierr_mpi )
2942 ENDIF
2943 idest = 1
2944 keep(267)=keep(267)+1
2945 CALL mpi_isend( buf_load%CONTENT( iposmsg ),
2946 & position, mpi_packed, remote,
2947 & update_load, comm,
2948 & buf_load%CONTENT( ireq+(idest-1)*ovhsize ),
2949 & ierr_mpi )
2950 SIZE = SIZE - ( ndest - 1 ) * ovhsize * sizeofint
2951 IF ( SIZE .LT. position ) THEN
2952 WRITE(*,*) ' Error in SMUMPS_BUF_SEND_FILS'
2953 WRITE(*,*) ' Size,position=',SIZE,position
2954 CALL mumps_abort()
2955 END IF
2956 IF ( SIZE .NE. position )
2957 & CALL buf_adjust( buf_load, position )
2958 RETURN
2959 END SUBROUTINE smumps_buf_send_fils
2960 SUBROUTINE smumps_buf_send_not_mstr( COMM, MYID, NPROCS,
2961 & MAX_SURF_MASTER, KEEP, IERR)
2962 IMPLICIT NONE
2963 include 'mpif.h'
2964 include 'mumps_tags.h'
2965 INTEGER comm, myid, ierr, NPROCS
2966 DOUBLE PRECISION max_surf_master
2967 INTEGER, INTENT(INOUT) :: keep(500)
2968 INTEGER :: ierr_mpi
2969 INTEGER ipos, ireq, idest, iposmsg, position, i
2970 INTEGER izero
2971 INTEGER myid2(1)
2972 parameter( izero=0 )
2973 INTEGER ndest, nints, nreals, SIZE, size1, size2
2974 INTEGER what
2975 ierr = 0
2976 myid2(1) = myid
2977 ndest = nprocs - 1
2978 nints = 1 + ( ndest-1 ) * ovhsize
2979 nreals = 1
2980 CALL mpi_pack_size( nints,
2981 & mpi_integer, comm,
2982 & size1, ierr_mpi )
2983 CALL mpi_pack_size( nreals,
2984 & mpi_double_precision, comm,
2985 & size2, ierr_mpi )
2986 size=size1+size2
2987 CALL buf_look( buf_load, ipos, ireq, SIZE, ierr,
2988 & izero, myid2 )
2989 IF ( ierr .LT. 0 ) THEN
2990 RETURN
2991 ENDIF
2992 buf_load%ILASTMSG = buf_load%ILASTMSG + ( ndest - 1 ) * ovhsize
2993 ipos = ipos - ovhsize
2994 DO idest = 1, ndest - 1
2995 buf_load%CONTENT( ipos + ( idest - 1 ) * ovhsize ) =
2996 & ipos + idest * ovhsize
2997 END DO
2998 buf_load%CONTENT( ipos + ( ndest - 1 ) * ovhsize ) = 0
2999 iposmsg = ipos + ovhsize * ndest
3000 position = 0
3001 what = 4
3002 CALL mpi_pack( what, 1, mpi_integer,
3003 & buf_load%CONTENT( iposmsg ), SIZE,
3004 & position, comm, ierr_mpi )
3005 CALL mpi_pack( max_surf_master, 1, mpi_double_precision,
3006 & buf_load%CONTENT( iposmsg ), SIZE,
3007 & position, comm, ierr_mpi )
3008 idest = 0
3009 DO i = 0, nprocs - 1
3010 IF ( i .ne. myid ) THEN
3011 idest = idest + 1
3012 keep(267)=keep(267)+1
3013 CALL mpi_isend( buf_load%CONTENT( iposmsg ),
3014 & position, mpi_packed, i,
3015 & update_load, comm,
3016 & buf_load%CONTENT( ireq+(idest-1)*ovhsize ),
3017 & ierr_mpi )
3018 END IF
3019 END DO
3020 SIZE = SIZE - ( ndest - 1 ) * ovhsize * sizeofint
3021 IF ( SIZE .LT. position ) THEN
3022 WRITE(*,*) ' Error in SMUMPS_BUF_BCAST_ARRAY'
3023 WRITE(*,*) ' Size,position=',SIZE,position
3024 CALL mumps_abort()
3025 END IF
3026 IF ( SIZE .NE. position )
3027 & CALL buf_adjust( buf_load, position )
3028 RETURN
3029 END SUBROUTINE smumps_buf_send_not_mstr
3030 SUBROUTINE smumps_buf_bcast_array( BDC_MEM,
3031 & COMM, MYID, NPROCS,
3032 & FUTURE_NIV2,
3033 & NSLAVES,
3034 & LIST_SLAVES,INODE,
3035 & MEM_INCREMENT, FLOPS_INCREMENT,CB_BAND, WHAT,
3036 & KEEP,
3037 & IERR )
3038 IMPLICIT NONE
3039 include 'mpif.h'
3040 include 'mumps_tags.h'
3041 LOGICAL bdc_mem
3042 INTEGER comm, myid, NPROCS, nslaves, ierr
3043 INTEGER future_niv2(nprocs)
3044 INTEGER list_slaves(nslaves),inode
3045 DOUBLE PRECISION mem_increment(nslaves)
3046 DOUBLE PRECISION flops_increment(nslaves)
3047 DOUBLE PRECISION cb_band(nslaves)
3048 INTEGER, INTENT(INOUT) :: keep(500)
3049 INTEGER :: ierr_mpi
3050 INTEGER ndest, nints, nreals, size1, size2, size
3051 INTEGER ipos, iposmsg, ireq, position
3052 INTEGER i, idest, what
3053 INTEGER izero
3054 INTEGER myid2(1)
3055 parameter( izero=0 )
3056 myid2(1)=myid
3057 ierr = 0
3058 ndest = 0
3059 DO i = 1, nprocs
3060 IF ( i .NE. myid + 1 .AND. future_niv2(i).NE.0) THEN
3061 ndest = ndest + 1
3062 ENDIF
3063 ENDDO
3064 IF ( ndest == 0 ) THEN
3065 RETURN
3066 ENDIF
3067 nints = 2 + nslaves + ( ndest - 1 ) * ovhsize + 1
3068 nreals = nslaves
3069 IF (bdc_mem) nreals = nreals + nslaves
3070 IF(what.EQ.19) THEN
3071 nreals = nreals + nslaves
3072 ENDIF
3073 CALL mpi_pack_size( nints,
3074 & mpi_integer, comm,
3075 & size1, ierr_mpi )
3076 CALL mpi_pack_size( nreals, mpi_double_precision,
3077 & comm, size2, ierr_mpi )
3078 SIZE = size1+size2
3079 CALL buf_look( buf_load, ipos, ireq, SIZE, ierr,
3080 & izero, myid2 )
3081 IF ( ierr .LT. 0 ) THEN
3082 RETURN
3083 ENDIF
3084 buf_load%ILASTMSG = buf_load%ILASTMSG + ( ndest - 1 ) * ovhsize
3085 ipos = ipos - ovhsize
3086 DO idest = 1, ndest - 1
3087 buf_load%CONTENT( ipos + ( idest - 1 ) * ovhsize ) =
3088 & ipos + idest * ovhsize
3089 END DO
3090 buf_load%CONTENT( ipos + ( ndest - 1 ) * ovhsize ) = 0
3091 iposmsg = ipos + ovhsize * ndest
3092 position = 0
3093 CALL mpi_pack( what, 1, mpi_integer,
3094 & buf_load%CONTENT( iposmsg ), SIZE,
3095 & position, comm, ierr_mpi )
3096 CALL mpi_pack( nslaves, 1, mpi_integer,
3097 & buf_load%CONTENT( iposmsg ), SIZE,
3098 & position, comm, ierr_mpi )
3099 CALL mpi_pack( inode, 1, mpi_integer,
3100 & buf_load%CONTENT( iposmsg ), SIZE,
3101 & position, comm, ierr_mpi )
3102 CALL mpi_pack( list_slaves, nslaves, mpi_integer,
3103 & buf_load%CONTENT( iposmsg ), SIZE,
3104 & position, comm, ierr_mpi )
3105 CALL mpi_pack( flops_increment, nslaves,
3106 & mpi_double_precision,
3107 & buf_load%CONTENT( iposmsg ), SIZE,
3108 & position, comm, ierr_mpi )
3109 IF (bdc_mem) THEN
3110 CALL mpi_pack( mem_increment, nslaves,
3111 & mpi_double_precision,
3112 & buf_load%CONTENT( iposmsg ), SIZE,
3113 & position, comm, ierr_mpi )
3114 END IF
3115 IF(what.EQ.19)THEN
3116 CALL mpi_pack( cb_band, nslaves,
3117 & mpi_double_precision,
3118 & buf_load%CONTENT( iposmsg ), SIZE,
3119 & position, comm, ierr_mpi )
3120 ENDIF
3121 idest = 0
3122 DO i = 0, nprocs - 1
3123 IF ( i .NE. myid .AND. future_niv2(i+1) .NE. 0) THEN
3124 idest = idest + 1
3125 keep(267)=keep(267)+1
3126 CALL mpi_isend( buf_load%CONTENT( iposmsg ),
3127 & position, mpi_packed, i,
3128 & update_load, comm,
3129 & buf_load%CONTENT( ireq+(idest-1)*ovhsize ),
3130 & ierr_mpi )
3131 END IF
3132 END DO
3133 SIZE = SIZE - ( ndest - 1 ) * ovhsize * sizeofint
3134 IF ( SIZE .LT. position ) THEN
3135 WRITE(*,*) ' Error in SMUMPS_BUF_BCAST_ARRAY'
3136 WRITE(*,*) ' Size,position=',SIZE,position
3137 CALL mumps_abort()
3138 END IF
3139 IF ( SIZE .NE. position )
3140 & CALL buf_adjust( buf_load, position )
3141 RETURN
3142 END SUBROUTINE smumps_buf_bcast_array
3143 SUBROUTINE smumps_buf_dist_irecv_size
3144 & ( smumps_lbufr_bytes)
3145 IMPLICIT NONE
3146 INTEGER smumps_lbufr_bytes
3147 size_rbuf_bytes = smumps_lbufr_bytes
3148 RETURN
3149 END SUBROUTINE smumps_buf_dist_irecv_size
3150 SUBROUTINE mumps_mpi_pack_size_lr( BLR_LorU, SIZE_OUT, COMM,
3151 & IERR )
3152 USE smumps_lr_type
3153 INTEGER, intent(out) :: SIZE_OUT, IERR
3154 INTEGER, intent(in) :: COMM
3155 TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU
3156 INTEGER :: I, SIZE_LOC, IERR_MPI
3157 include 'mpif.h'
3158 ierr = 0
3159 size_out = 0
3160 CALL mpi_pack_size( 1, mpi_integer, comm, size_loc, ierr_mpi )
3161 size_out = size_out + size_loc
3162 DO i = 1, size(blr_loru)
3163 CALL mumps_mpi_pack_size_lrb(blr_loru(i), size_loc, comm,
3164 & ierr )
3165 size_out = size_out + size_loc
3166 ENDDO
3167 RETURN
3168 END SUBROUTINE mumps_mpi_pack_size_lr
3169 SUBROUTINE mumps_mpi_pack_size_lrb(LRB, SIZE_OUT, COMM, IERR )
3170 USE smumps_lr_type
3171 INTEGER, intent(out) :: SIZE_OUT, IERR
3172 INTEGER, intent(in) :: COMM
3173 TYPE (LRB_TYPE), intent(in) :: LRB
3174 INTEGER :: SIZE_LOC, IERR_MPI
3175 include 'mpif.h'
3176 ierr = 0
3177 size_out = 0
3178 CALL mpi_pack_size( 4,
3179 & mpi_integer, comm, size_loc, ierr_mpi )
3180 size_out = size_out + size_loc
3181 IF ( lrb%ISLR ) THEN
3182 IF (lrb%K .GT. 0) THEN
3183 CALL mpi_pack_size( lrb%M * lrb%K,
3184 & mpi_real, comm, size_loc, ierr_mpi )
3185 size_out = size_out + size_loc
3186 CALL mpi_pack_size( lrb%K * lrb%N,
3187 & mpi_real, comm, size_loc, ierr_mpi )
3188 size_out = size_out + size_loc
3189 ENDIF
3190 ELSE
3191 CALL mpi_pack_size( lrb%M * lrb%N,
3192 & mpi_real, comm, size_loc, ierr_mpi )
3193 size_out = size_out + size_loc
3194 ENDIF
3195 RETURN
3196 END SUBROUTINE mumps_mpi_pack_size_lrb
3197 SUBROUTINE smumps_mpi_pack_lr( BLR_LorU, BUF, LBUF, POSITION,
3198 & COMM, IERR )
3199 USE smumps_lr_type
3200 INTEGER, intent(out) :: IERR
3201 INTEGER, intent(in) :: COMM, LBUF
3202 INTEGER, intent(inout) :: POSITION
3203 INTEGER, intent(inout) :: BUF(:)
3204 TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU
3205 INTEGER I
3206 INTEGER :: IERR_MPI
3207 INCLUDE 'mpif.h'
3208 IERR = 0
3209 CALL mpi_pack( size(blr_loru), 1, mpi_integer,
3210 & buf(1), lbuf, position, comm, ierr_mpi )
3211 DO i = 1, size(blr_loru)
3212 CALL smumps_mpi_pack_lrb(blr_loru(i), buf, lbuf, position,
3213 & comm, ierr
3214 & )
3215 ENDDO
3216 RETURN
3217 END SUBROUTINE smumps_mpi_pack_lr
3218 SUBROUTINE smumps_mpi_pack_lrb( LRB, BUF, LBUF, POSITION,
3219 & COMM, IERR
3220 & )
3221 USE smumps_lr_type
3222 INTEGER, intent(out) :: ierr
3223 INTEGER, intent(in) :: comm, lbuf
3224 INTEGER, intent(inout) :: position
3225 INTEGER, intent(inout) :: buf(:)
3226 TYPE (lrb_type), intent(in) :: lrb
3227 INTEGER islr_int
3228 INTEGER :: ierr_mpi
3229 include 'mpif.h'
3230 ierr = 0
3231 IF (lrb%ISLR) THEN
3232 islr_int = 1
3233 ELSE
3234 islr_int = 0
3235 ENDIF
3236 CALL mpi_pack( islr_int, 1, mpi_integer,
3237 & buf(1), lbuf, position, comm, ierr_mpi )
3238 CALL mpi_pack( lrb%K,
3239 & 1, mpi_integer,
3240 & buf(1), lbuf, position, comm, ierr_mpi )
3241 CALL mpi_pack( lrb%M,
3242 & 1, mpi_integer,
3243 & buf(1), lbuf, position, comm, ierr_mpi )
3244 CALL mpi_pack( lrb%N,
3245 & 1, mpi_integer,
3246 & buf(1), lbuf, position, comm, ierr_mpi )
3247 IF (lrb%ISLR) THEN
3248 IF (lrb%K .GT. 0) THEN
3249 CALL mpi_pack( lrb%Q(1,1),
3250 & lrb%M*lrb%K, mpi_real,
3251 & buf(1), lbuf, position, comm, ierr_mpi )
3252 CALL mpi_pack( lrb%R(1,1),
3253 & lrb%N*lrb%K, mpi_real,
3254 & buf(1), lbuf, position, comm, ierr_mpi )
3255 ENDIF
3256 ELSE
3257 CALL mpi_pack( lrb%Q(1,1), lrb%M*lrb%N
3258 & ,mpi_real,
3259 & buf(1), lbuf, position, comm, ierr_mpi )
3260 ENDIF
3261 RETURN
3262 END SUBROUTINE smumps_mpi_pack_lrb
3263 SUBROUTINE smumps_mpi_unpack_lrb(
3264 & BUFR, LBUFR, LBUFR_BYTES, POSITION,
3265 & LRB, KEEP8,
3266 & COMM, IFLAG, IERROR
3267 & )
3268 USE smumps_lr_core, ONLY : alloc_lrb
3269 USE smumps_lr_type
3270 IMPLICIT NONE
3271 INTEGER, INTENT(IN) :: lbufr
3272 INTEGER, INTENT(IN) :: lbufr_bytes
3273 INTEGER, INTENT(IN) :: bufr(lbufr)
3274 INTEGER, INTENT(INOUT) :: position
3275 INTEGER, INTENT(IN) :: comm
3276 INTEGER, INTENT(INOUT) :: iflag, ierror
3277 TYPE (lrb_type), INTENT(OUT) :: lrb
3278 INTEGER(8) :: keep8(150)
3279 LOGICAL :: islr
3280 INTEGER :: islr_int
3281 INTEGER :: k, m, n
3282 INTEGER :: ierr_mpi
3283 include 'mpif.h'
3284 include 'mumps_tags.h'
3285 CALL mpi_unpack( bufr, lbufr_bytes, position,
3286 & islr_int, 1, mpi_integer, comm, ierr_mpi )
3287 CALL mpi_unpack( bufr, lbufr_bytes, position,
3288 & k, 1,
3289 & mpi_integer, comm, ierr_mpi )
3290 CALL mpi_unpack( bufr, lbufr_bytes, position,
3291 & m, 1,
3292 & mpi_integer, comm, ierr_mpi )
3293 CALL mpi_unpack( bufr, lbufr_bytes, position,
3294 & n, 1,
3295 & mpi_integer, comm, ierr_mpi )
3296 IF (islr_int .eq. 1) THEN
3297 islr = .true.
3298 ELSE
3299 islr = .false.
3300 ENDIF
3301 CALL alloc_lrb( lrb, k, m, n, islr,
3302 & iflag, ierror, keep8 )
3303 IF (iflag.LT.0) RETURN
3304 IF (islr) THEN
3305 IF (k .GT. 0) THEN
3306 CALL mpi_unpack( bufr, lbufr_bytes, position,
3307 & lrb%Q(1,1), m*k, mpi_real,
3308 & comm, ierr_mpi )
3309 CALL mpi_unpack( bufr, lbufr_bytes, position,
3310 & lrb%R(1,1), n*k, mpi_real,
3311 & comm, ierr_mpi )
3312 ENDIF
3313 ELSE
3314 CALL mpi_unpack( bufr, lbufr_bytes, position,
3315 & lrb%Q(1,1), m*n, mpi_real,
3316 & comm, ierr_mpi )
3317 ENDIF
3318 RETURN
3319 END SUBROUTINE smumps_mpi_unpack_lrb
3320 SUBROUTINE mumps_mpi_pack_scale_lr
3321 & ( blr, buf, lbuf, position,
3322 & comm,
3323 & a , la, poseltd, ld_diag,
3324 & ipiv, npiv, maxi_cluster,
3325 & ierr )
3326 USE smumps_lr_type
3327 INTEGER, intent(out) :: IERR
3328 INTEGER, intent(in) :: COMM, LBUF
3329 INTEGER, intent(inout) :: POSITION
3330 INTEGER, intent(inout) :: BUF(:)
3331 TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR
3332 INTEGER(8), intent(in) :: LA, POSELTD
3333 INTEGER, intent(in) :: LD_DIAG, NPIV
3334 INTEGER, intent(in) :: IPIV(NPIV), MAXI_CLUSTER
3335 REAL, intent(inout) :: A(LA)
3336 INTEGER :: IERR_MPI
3337 INTEGER I, ISLR_INT, J, ALLOCOK
3338 REAL, ALLOCATABLE,DIMENSION(:,:) :: SCALED
3339 REAL, ALLOCATABLE,DIMENSION(:) :: BLOCK
3340 REAL :: PIV1, PIV2, OFFDIAG
3341 INCLUDE 'mpif.h'
3342 ierr = 0
3343 CALL mpi_pack( size(blr), 1, mpi_integer,
3344 & buf(1), lbuf, position, comm, ierr_mpi )
3345 allocate(block(maxi_cluster), stat=allocok )
3346 IF ( allocok .GT. 0 ) THEN
3347 WRITE(*,*) 'pb allocation in mumps_mpi_pack_scale_lr'
3348 ierr = -1
3349 GOTO 500
3350 END IF
3351 allocate(scaled(maxi_cluster,2), stat=allocok )
3352 IF ( allocok .GT. 0 ) THEN
3353 WRITE(*,*) 'pb allocation in mumps_mpi_pack_scale_lr'
3354 ierr = -1
3355 GOTO 500
3356 END IF
3357 DO i = 1, size(blr)
3358 IF (blr(i)%ISLR) THEN
3359 islr_int = 1
3360 ELSE
3361 islr_int = 0
3362 ENDIF
3363 CALL mpi_pack( islr_int, 1, mpi_integer,
3364 & buf(1), lbuf, position, comm, ierr_mpi )
3365 CALL mpi_pack( blr(i)%K,
3366 & 1, mpi_integer,
3367 & buf(1), lbuf, position, comm, ierr_mpi )
3368 CALL mpi_pack( blr(i)%M,
3369 & 1, mpi_integer,
3370 & buf(1), lbuf, position, comm, ierr_mpi )
3371 CALL mpi_pack( blr(i)%N,
3372 & 1, mpi_integer,
3373 & buf(1), lbuf, position, comm, ierr_mpi )
3374 IF (blr(i)%ISLR) THEN
3375 IF (blr(i)%K .GT. 0) THEN
3376 CALL mpi_pack( blr(i)%Q(1,1), blr(i)%M*blr(i)%K,
3377 & mpi_real,
3378 & buf(1), lbuf, position, comm, ierr_mpi )
3379 j =1
3380 DO WHILE (j <= blr(i)%N)
3381 IF (ipiv(j) > 0) THEN
3382 scaled(1:blr(i)%K,1) = a(poseltd+ld_diag*(j-1)+j-1)
3383 & * blr(i)%R(1:blr(i)%K,j)
3384 j = j+1
3385 CALL mpi_pack( scaled(1,1), blr(i)%K,
3386 & mpi_real,
3387 & buf(1), lbuf, position, comm, ierr_mpi )
3388 ELSE
3389 piv1 = a(poseltd+ld_diag*(j-1)+j-1)
3390 piv2 = a(poseltd+ld_diag*j+j)
3391 offdiag = a(poseltd+ld_diag*(j-1)+j)
3392 block(1:blr(i)%K) = blr(i)%R(1:blr(i)%K,j)
3393 scaled(1:blr(i)%K,1) = piv1 * blr(i)%R(1:blr(i)%K,j)
3394 & + offdiag * blr(i)%R(1:blr(i)%K,j+1)
3395 CALL mpi_pack( scaled(1,1), blr(i)%K,
3396 & mpi_real,
3397 & buf(1), lbuf, position, comm, ierr_mpi )
3398 scaled(1:blr(i)%K,2) = offdiag * block(1:blr(i)%K)
3399 & + piv2 * blr(i)%R(1:blr(i)%K,j+1)
3400 j =j+2
3401 CALL mpi_pack( scaled(1,2), blr(i)%K,
3402 & mpi_real,
3403 & buf(1), lbuf, position, comm, ierr_mpi )
3404 ENDIF
3405 END DO
3406 ENDIF
3407 ELSE
3408 j = 1
3409 DO WHILE (j <= blr(i)%N)
3410 IF (ipiv(j) > 0) THEN
3411 scaled(1:blr(i)%M,1) = a(poseltd+ld_diag*(j-1)+j-1)
3412 & * blr(i)%Q(1:blr(i)%M,j)
3413 CALL mpi_pack( scaled(1,1), blr(i)%M,
3414 & mpi_real,
3415 & buf(1), lbuf, position, comm, ierr_mpi )
3416 j = j+1
3417 ELSE
3418 piv1 = a(poseltd+ld_diag*(j-1)+j-1)
3419 piv2 = a(poseltd+ld_diag*j+j)
3420 offdiag = a(poseltd+ld_diag*(j-1)+j)
3421 block(1:blr(i)%M) = blr(i)%Q(1:blr(i)%M,j)
3422 scaled(1:blr(i)%M,1) = piv1 * blr(i)%Q(1:blr(i)%M,j)
3423 & + offdiag * blr(i)%Q(1:blr(i)%M,j+1)
3424 CALL mpi_pack( scaled(1,1), blr(i)%M,
3425 & mpi_real,
3426 & buf(1), lbuf, position, comm, ierr_mpi )
3427 scaled(1:blr(i)%M,2) = offdiag * block(1:blr(i)%M)
3428 & + piv2 * blr(i)%Q(1:blr(i)%M,j+1)
3429 CALL mpi_pack( scaled(1,2), blr(i)%M,
3430 & mpi_real,
3431 & buf(1), lbuf, position, comm, ierr_mpi )
3432 j=j+2
3433 ENDIF
3434 END DO
3435 ENDIF
3436 ENDDO
3437 500 CONTINUE
3438 IF (allocated(block)) deallocate(block)
3439 IF (allocated(scaled)) deallocate(scaled)
3440 RETURN
3441 END SUBROUTINE mumps_mpi_pack_scale_lr
3442 END MODULE smumps_buf
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
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_pack
subroutine mpi_pack(inbuf, incnt, datatype, outbuf, outcnt, position, comm, ierr)
Definition mpi.f:428
mpi_request_free
subroutine mpi_request_free(ireq, ierr)
Definition mpi.f:472
mpi_pack_size
subroutine mpi_pack_size(incnt, datatype, comm, size, ierr)
Definition mpi.f:439
mpi_cancel
subroutine mpi_cancel(ireq, ierr)
Definition mpi.f:214
mpi_unpack
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
mumps_bloc2_get_islave
subroutine mumps_bloc2_get_islave(keep, keep8, inode, step, n, slavef, istep_to_iniv2, tab_pos_in_pere nass, ncb, nslaves, position, islave, iposslave)
Definition mumps_type2_blocking.F:479
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
smumps_buf
Definition smumps_comm_buffer.F:14
smumps_buf::smumps_buf_send_fils
subroutine, public smumps_buf_send_fils(what, comm, nprocs, father_node, inode, ncb, keep, myid, remote, ierr)
Definition smumps_comm_buffer.F:2889
smumps_buf::smumps_buf_init
subroutine, public smumps_buf_init(intsize, realsize)
Definition smumps_comm_buffer.F:90
smumps_buf::smumps_buf_send_update_load
subroutine, public smumps_buf_send_update_load(bdc_sbtr, bdc_mem, bdc_md, comm, nprocs, load, mem, sbtr_cur, lu_usage, future_niv2, myid, keep, ierr)
Definition smumps_comm_buffer.F:2687
smumps_buf::mumps_mpi_pack_scale_lr
subroutine mumps_mpi_pack_scale_lr(blr, buf, lbuf, position, comm, a, la, poseltd, ld_diag, ipiv, npiv, maxi_cluster, ierr)
Definition smumps_comm_buffer.F:3326
smumps_buf::smumps_buf_send_1int
subroutine, public smumps_buf_send_1int(i, dest, tag, comm, keep, ierr)
Definition smumps_comm_buffer.F:598
smumps_buf::smumps_buf_deall_small_buf
subroutine, public smumps_buf_deall_small_buf(ierr)
Definition smumps_comm_buffer.F:166
smumps_buf::smumps_buf_send_contrib_type3
subroutine, public smumps_buf_send_contrib_type3(n, ison, nbcol_son, nbrow_son, indcol_son, indrow_son, ld_son, val_son, tag, subset_row, subset_col, nsubset_row, nsubset_col, nsuprow, nsupcol, nprow, npcol, mblock, rg2l_row, rg2l_col, nblock, pdest, comm, ierr, tab, tabsize, transp, size_pack, n_already_sent, keep, bbpcbp)
Definition smumps_comm_buffer.F:2168
smumps_buf::smumps_mpi_unpack_lrb
subroutine, public smumps_mpi_unpack_lrb(bufr, lbufr, lbufr_bytes, position, lrb, keep8, comm, iflag, ierror)
Definition smumps_comm_buffer.F:3268
smumps_buf::smumps_buf_send_blocfacto
subroutine, public smumps_buf_send_blocfacto(inode, nfront, ncol, npiv, fpere, lastbl, ipiv, val, pdest, ndest, keep, nb_bloc_fac, nslaves_tot, width, comm, nelim, npartsass, current_blr_panel, lr_activated, blr_loru ierr)
Definition smumps_comm_buffer.F:1824
smumps_buf::buf_deall
subroutine buf_deall(buf, ierr)
Definition smumps_comm_buffer.F:192
smumps_buf::smumps_buf_empty
subroutine smumps_buf_empty(b, flag)
Definition smumps_comm_buffer.F:649
smumps_buf::smumps_blr_pack_cb_lrb
subroutine, public smumps_blr_pack_cb_lrb(cb_lrb, nb_row_shift, nb_col_shift, nb_blr_cols, panel2send, panel_beg_offset, buf, lbuf, position, comm, ierr)
Definition smumps_comm_buffer.F:1615
smumps_buf::smumps_buf_dist_irecv_size
subroutine, public smumps_buf_dist_irecv_size(smumps_lbufr_bytes)
Definition smumps_comm_buffer.F:3145
smumps_buf::buf_myid
integer, save buf_myid
Definition smumps_comm_buffer.F:41
smumps_buf::smumps_buf_send_root2slave
subroutine, public smumps_buf_send_root2slave(tot_root_size, tot_cont2recv, dest, comm, keep, ierr)
Definition smumps_comm_buffer.F:2592
smumps_buf::sizeofint
integer, save sizeofint
Definition smumps_comm_buffer.F:41
smumps_buf::smumps_buf_all_empty
subroutine, public smumps_buf_all_empty(check_comm_nodes, check_comm_load, flag)
Definition smumps_comm_buffer.F:633
smumps_buf::smumps_buf_broadcast
subroutine, public smumps_buf_broadcast(what, comm, nprocs, future_niv2, load, upd_load, myid, keep, ierr)
Definition smumps_comm_buffer.F:2795
smumps_buf::smumps_buf_send_not_mstr
subroutine, public smumps_buf_send_not_mstr(comm, myid, nprocs, max_surf_master, keep, ierr)
Definition smumps_comm_buffer.F:2962
smumps_buf::smumps_buf_send_blfac_slave
subroutine, public smumps_buf_send_blfac_slave(inode, npiv, fpere, iposk, jposk, uip21k, ncolu, ndest, pdest, comm, keep, lr_activated, blr_ls, ipanel, a, la, posblocfacto, ld_blocfacto, ipiv, maxi_cluster, ierr)
Definition smumps_comm_buffer.F:2044
smumps_buf::smumps_buf_test
subroutine, public smumps_buf_test()
Definition smumps_comm_buffer.F:689
smumps_buf::smumps_buf_alloc_load_buffer
subroutine, public smumps_buf_alloc_load_buffer(size, ierr)
Definition smumps_comm_buffer.F:127
smumps_buf::smumps_buf_send_backvec
subroutine, public smumps_buf_send_backvec(nrhs, inode, w, lw, ld_w, dest, msgtag, jbdeb, jbfin, keep, comm, ierr)
Definition smumps_comm_buffer.F:2627
smumps_buf::mumps_mpi_pack_size_lr
subroutine mumps_mpi_pack_size_lr(blr_loru, size_out, comm, ierr)
Definition smumps_comm_buffer.F:3152
smumps_buf::smumps_buf_send_contrib_type2
subroutine, public smumps_buf_send_contrib_type2(nbrows_already_sent, desc_in_lu, ipere, nfront_pere, nass_pere, nfs4father, nslaves_pere, ison, nbrow, lmap, maprow, perm, iw_cbson, a_cbson, la_cbson, islave, pdest, pdest_master, comm, ierr, keep, keep8, step, n, slavef, istep_to_iniv2, tab_pos_in_pere, packed_cb, keep253_loc, nvschur, son_niv, myid, npiv_check)
Definition smumps_comm_buffer.F:1050
smumps_buf::sizeofreal
integer, save sizeofreal
Definition smumps_comm_buffer.F:41
smumps_buf::ovhsize
integer ovhsize
Definition smumps_comm_buffer.F:39
smumps_buf::smumps_buf_send_root2son
subroutine, public smumps_buf_send_root2son(ison, nelim_root, dest, comm, keep, ierr)
Definition smumps_comm_buffer.F:2558
smumps_buf::smumps_buf_send_maitre2
subroutine, public smumps_buf_send_maitre2(nbrows_already_sent, ipere, ison, nrow, irow, ncol, icol, val, lda, nelim, type_son, nslaves, slaves, dest, comm, ierr, slavef, keep, keep8, iniv2, tab_pos_in_pere)
Definition smumps_comm_buffer.F:869
smumps_buf::smumps_buf_deall_cb
subroutine, public smumps_buf_deall_cb(ierr)
Definition smumps_comm_buffer.F:160
smumps_buf::smumps_buf_ini_myid
subroutine, public smumps_buf_ini_myid(myid)
Definition smumps_comm_buffer.F:84
smumps_buf::smumps_buf_size_available
subroutine smumps_buf_size_available(b, size_av)
Definition smumps_comm_buffer.F:657
smumps_buf::buf_small
type(smumps_comm_buffer_type), save buf_small
Definition smumps_comm_buffer.F:47
smumps_buf::smumps_mpi_pack_lr
subroutine smumps_mpi_pack_lr(blr_loru, buf, lbuf, position, comm, ierr)
Definition smumps_comm_buffer.F:3199
smumps_buf::buf_max_array
real, dimension(:), allocatable, target, save, public buf_max_array
Definition smumps_comm_buffer.F:51
smumps_buf::smumps_mpi_pack_lrb
subroutine, public smumps_mpi_pack_lrb(lrb, buf, lbuf, position, comm, ierr)
Definition smumps_comm_buffer.F:3221
smumps_buf::mumps_blr_get_sizereals_cb_lrb
subroutine mumps_blr_get_sizereals_cb_lrb(size_out, cb_lrb, nb_row_shift, nb_col_shift, nb_blr_cols, panel2send)
Definition smumps_comm_buffer.F:1589
smumps_buf::req
integer req
Definition smumps_comm_buffer.F:39
smumps_buf::smumps_buf_send_master2slave
subroutine, public smumps_buf_send_master2slave(nrhs, inode, ifath, eff_cb_size, ld_cb, ld_piv, npiv, jbdeb, jbfin, cb, sol, dest, comm, keep, ierr)
Definition smumps_comm_buffer.F:427
smumps_buf::mumps_mpi_pack_size_lrb
subroutine mumps_mpi_pack_size_lrb(lrb, size_out, comm, ierr)
Definition smumps_comm_buffer.F:3170
smumps_buf::smumps_buf_send_desc_bande
subroutine, public smumps_buf_send_desc_bande(inode, nbprocfils, nlig, ilig, ncol, icol, nass, nslaves_hdr, list_slaves, nslaves, estim_nfs4father_atson, dest, ibc_source, nfront, comm, keep, ierr, lrstatus)
Definition smumps_comm_buffer.F:785
smumps_buf::buf_load
type(smumps_comm_buffer_type), save buf_load
Definition smumps_comm_buffer.F:48
smumps_buf::smumps_buf_send_cb
subroutine, public smumps_buf_send_cb(nbrows_already_sent, inode, fpere, nfront, lcont, nass, npiv, iwrow, iwcol, a, packed_cb, dest, tag, comm, keep, ierr)
Definition smumps_comm_buffer.F:233
smumps_buf::smumps_buf_try_free_cb
subroutine, public smumps_buf_try_free_cb()
Definition smumps_comm_buffer.F:56
smumps_buf::buf_lmax_array
integer, save, public buf_lmax_array
Definition smumps_comm_buffer.F:50
smumps_buf::smumps_buf_bcast_array
subroutine, public smumps_buf_bcast_array(bdc_mem, comm, myid, nprocs, future_niv2, nslaves, list_slaves, inode, mem_increment, flops_increment, cb_band, what, keep, ierr)
Definition smumps_comm_buffer.F:3038
smumps_buf::size_rbuf_bytes
integer, save size_rbuf_bytes
Definition smumps_comm_buffer.F:49
smumps_buf::buf_cb
type(smumps_comm_buffer_type), save buf_cb
Definition smumps_comm_buffer.F:46
smumps_buf::buf_adjust
subroutine buf_adjust(buf, size)
Definition smumps_comm_buffer.F:768
smumps_buf::smumps_buf_send_vcb
subroutine, public smumps_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 smumps_comm_buffer.F:505
smumps_buf::smumps_buf_max_array_minsize
subroutine, public smumps_buf_max_array_minsize(nfs4father, ierr)
Definition smumps_comm_buffer.F:144
smumps_buf::smumps_buf_try_free
subroutine smumps_buf_try_free(b)
Definition smumps_comm_buffer.F:60
smumps_buf::smumps_buf_alloc_small_buf
subroutine, public smumps_buf_alloc_small_buf(size, ierr)
Definition smumps_comm_buffer.F:121
smumps_buf::smumps_buf_send_maplig
subroutine, public smumps_buf_send_maplig(inode, nfront, nass1, nfs4father, ison, myid, nslaves, slaves_pere, trow, ncbson, comm, ierr, dest, ndest, slavef, keep, keep8, step, n, istep_to_iniv2, tab_pos_in_per)
Definition smumps_comm_buffer.F:1649
smumps_buf::buf_look
subroutine buf_look(b, ipos, ireq, msg_size, ierr, ndest, pdest, test_only)
Definition smumps_comm_buffer.F:701
smumps_buf::smumps_buf_deall_load_buffer
subroutine, public smumps_buf_deall_load_buffer(ierr)
Definition smumps_comm_buffer.F:133
smumps_buf::smumps_buf_alloc_cb
subroutine, public smumps_buf_alloc_cb(size, ierr)
Definition smumps_comm_buffer.F:115
smumps_buf::buf_alloc
subroutine buf_alloc(buf, size, ierr)
Definition smumps_comm_buffer.F:172
smumps_buf::next
integer next
Definition smumps_comm_buffer.F:39
smumps_buf::smumps_buf_deall_max_array
subroutine, public smumps_buf_deall_max_array()
Definition smumps_comm_buffer.F:139
smumps_buf::smumps_buf_send_rtnelind
subroutine, public smumps_buf_send_rtnelind(ison, nelim, nelim_row, nelim_col, nslaves, slaves, dest, comm, keep, ierr)
Definition smumps_comm_buffer.F:2505
smumps_buf::content
integer content
Definition smumps_comm_buffer.F:39
smumps_lr_core
Definition slr_core.F:18
smumps_lr_core::alloc_lrb
subroutine alloc_lrb(lrb_out, k, m, n, islr, iflag, ierror, keep8)
Definition slr_core.F:111
smumps_lr_data_m
Definition smumps_lr_data_m.F:14
smumps_lr_data_m::smumps_blr_retrieve_cb_lrb
subroutine, public smumps_blr_retrieve_cb_lrb(iwhandler, thecb)
Definition smumps_lr_data_m.F:837
smumps_lr_data_m::smumps_blr_retrieve_begsblr_dyn
subroutine, public smumps_blr_retrieve_begsblr_dyn(iwhandler, begs_blr_dynamic)
Definition smumps_lr_data_m.F:638
smumps_lr_data_m::smumps_blr_retrieve_m_array
subroutine, public smumps_blr_retrieve_m_array(iwhandler, m_array)
Definition smumps_lr_data_m.F:902
smumps_lr_data_m::smumps_blr_retrieve_begs_blr_c
subroutine, public smumps_blr_retrieve_begs_blr_c(iwhandler, begs_blr_col, nb_panels)
Definition smumps_lr_data_m.F:654
smumps_lr_data_m::smumps_blr_retrieve_nb_panels
subroutine, public smumps_blr_retrieve_nb_panels(iwhandler, nb_panels)
Definition smumps_lr_data_m.F:672
smumps_lr_data_m::smumps_blr_free_m_array
subroutine, public smumps_blr_free_m_array(iwhandler)
Definition smumps_lr_data_m.F:917
smumps_lr_data_m::smumps_blr_retrieve_begsblr_sta
subroutine, public smumps_blr_retrieve_begsblr_sta(iwhandler, begs_blr_static)
Definition smumps_lr_data_m.F:622
smumps_lr_type
Definition slr_type.F:14
smumps_compute_maxpercol
subroutine smumps_compute_maxpercol(a, asize, ncol, nrow, m_array, nmax, packed_cb, lrow1)
Definition stools.F:1643
smumps_buf::smumps_comm_buffer_type
Definition smumps_comm_buffer.F:42
smumps_lr_type::lrb_type
Definition slr_type.F:16