1C 2C This file is part of MUMPS 5.1.2, released 3C on Mon Oct 2 07:37:01 UTC 2017 4C 5C 6C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, 7C 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 http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html 12C 13 MODULE SMUMPS_BUF 14 PRIVATE 15 PUBLIC :: SMUMPS_BUF_TRY_FREE_CB, SMUMPS_BUF_INIT, 16 & SMUMPS_BUF_INI_MYID, 17 & SMUMPS_BUF_ALLOC_CB , SMUMPS_BUF_DEALL_CB , 18 & SMUMPS_BUF_ALLOC_SMALL_BUF, SMUMPS_BUF_DEALL_SMALL_BUF, 19 & SMUMPS_BUF_ALLOC_LOAD_BUFFER,SMUMPS_BUF_DEALL_LOAD_BUFFER, 20 & SMUMPS_BUF_SEND_CB, SMUMPS_BUF_SEND_VCB, 21 & SMUMPS_BUF_SEND_1INT, SMUMPS_BUF_SEND_DESC_BANDE, 22 & SMUMPS_BUF_SEND_MAPLIG, SMUMPS_BUF_SEND_MAITRE2, 23 & SMUMPS_BUF_SEND_CONTRIB_TYPE2, 24 & SMUMPS_BUF_SEND_BLOCFACTO, SMUMPS_BUF_SEND_BLFAC_SLAVE, 25 & SMUMPS_BUF_SEND_MASTER2SLAVE, 26 & SMUMPS_BUF_SEND_CONTRIB_TYPE3, SMUMPS_BUF_SEND_RTNELIND, 27 & SMUMPS_BUF_SEND_ROOT2SLAVE, SMUMPS_BUF_SEND_ROOT2SON, 28 & SMUMPS_BUF_SEND_BACKVEC,SMUMPS_BUF_SEND_UPDATE_LOAD, 29 & SMUMPS_BUF_DIST_IRECV_SIZE, 30 & SMUMPS_BUF_BCAST_ARRAY, SMUMPS_BUF_ALL_EMPTY, 31 & SMUMPS_BUF_BROADCAST, SMUMPS_BUF_SEND_NOT_MSTR, 32 & SMUMPS_BUF_SEND_FILS ,SMUMPS_BUF_DEALL_MAX_ARRAY 33 & ,SMUMPS_BUF_MAX_ARRAY_MINSIZE 34 & ,SMUMPS_BUF_TEST 35 INTEGER NEXT, REQ, CONTENT, OVHSIZE 36 PARAMETER( NEXT = 0, REQ = 1, CONTENT = 2, OVHSIZE = 2 ) 37 INTEGER, SAVE :: SIZEofINT, SIZEofREAL, BUF_MYID 38 TYPE SMUMPS_COMM_BUFFER_TYPE 39 INTEGER LBUF, HEAD, TAIL,LBUF_INT, ILASTMSG 40 INTEGER, DIMENSION(:),POINTER :: CONTENT 41 END TYPE SMUMPS_COMM_BUFFER_TYPE 42 TYPE ( SMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_CB 43 TYPE ( SMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_SMALL 44 TYPE ( SMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_LOAD 45 INTEGER, SAVE :: SIZE_RBUF_BYTES 46 INTEGER, SAVE :: BUF_LMAX_ARRAY 47 REAL, DIMENSION(:), ALLOCATABLE 48 & , SAVE :: BUF_MAX_ARRAY 49 PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY 50 CONTAINS 51 SUBROUTINE SMUMPS_BUF_TRY_FREE_CB() 52 CALL SMUMPS_BUF_TRY_FREE(BUF_CB) 53 RETURN 54 END SUBROUTINE SMUMPS_BUF_TRY_FREE_CB 55 SUBROUTINE SMUMPS_BUF_TRY_FREE(B) 56 IMPLICIT NONE 57 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B 58 INCLUDE 'mpif.h' 59 LOGICAL :: FLAG 60 INTEGER :: IERR 61 INTEGER :: STATUS(MPI_STATUS_SIZE) 62 IF ( B%HEAD .NE. B%TAIL ) THEN 63 10 CONTINUE 64 CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, IERR ) 65 IF ( FLAG ) THEN 66 B%HEAD = B%CONTENT( B%HEAD + NEXT ) 67 IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL 68 IF ( B%HEAD .NE. B%TAIL ) GOTO 10 69 END IF 70 END IF 71 IF ( B%HEAD .EQ. B%TAIL ) THEN 72 B%HEAD = 1 73 B%TAIL = 1 74 B%ILASTMSG = 1 75 END iF 76 RETURN 77 END SUBROUTINE SMUMPS_BUF_TRY_FREE 78 SUBROUTINE SMUMPS_BUF_INI_MYID( MYID ) 79 IMPLICIT NONE 80 INTEGER MYID 81 BUF_MYID = MYID 82 RETURN 83 END SUBROUTINE SMUMPS_BUF_INI_MYID 84 SUBROUTINE SMUMPS_BUF_INIT( IntSize, RealSize ) 85 IMPLICIT NONE 86 INTEGER IntSize, RealSize 87 SIZEofINT = IntSize 88 SIZEofREAL = RealSize 89 NULLIFY(BUF_CB %CONTENT) 90 NULLIFY(BUF_SMALL%CONTENT) 91 NULLIFY(BUF_LOAD%CONTENT) 92 BUF_CB%LBUF = 0 93 BUF_CB%LBUF_INT = 0 94 BUF_CB%HEAD = 1 95 BUF_CB%TAIL = 1 96 BUF_CB%ILASTMSG = 1 97 BUF_SMALL%LBUF = 0 98 BUF_SMALL%LBUF_INT = 0 99 BUF_SMALL%HEAD = 1 100 BUF_SMALL%TAIL = 1 101 BUF_SMALL%ILASTMSG = 1 102 BUF_LOAD%LBUF = 0 103 BUF_LOAD%LBUF_INT = 0 104 BUF_LOAD%HEAD = 1 105 BUF_LOAD%TAIL = 1 106 BUF_LOAD%ILASTMSG = 1 107 RETURN 108 END SUBROUTINE SMUMPS_BUF_INIT 109 SUBROUTINE SMUMPS_BUF_ALLOC_CB( SIZE, IERR ) 110 IMPLICIT NONE 111 INTEGER SIZE, IERR 112 CALL BUF_ALLOC( BUF_CB, SIZE, IERR ) 113 RETURN 114 END SUBROUTINE SMUMPS_BUF_ALLOC_CB 115 SUBROUTINE SMUMPS_BUF_ALLOC_SMALL_BUF( SIZE, IERR ) 116 IMPLICIT NONE 117 INTEGER SIZE, IERR 118 CALL BUF_ALLOC( BUF_SMALL, SIZE, IERR ) 119 RETURN 120 END SUBROUTINE SMUMPS_BUF_ALLOC_SMALL_BUF 121 SUBROUTINE SMUMPS_BUF_ALLOC_LOAD_BUFFER( SIZE, IERR ) 122 IMPLICIT NONE 123 INTEGER SIZE, IERR 124 CALL BUF_ALLOC( BUF_LOAD, SIZE, IERR ) 125 RETURN 126 END SUBROUTINE SMUMPS_BUF_ALLOC_LOAD_BUFFER 127 SUBROUTINE SMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) 128 IMPLICIT NONE 129 INTEGER IERR 130 CALL BUF_DEALL( BUF_LOAD, IERR ) 131 RETURN 132 END SUBROUTINE SMUMPS_BUF_DEALL_LOAD_BUFFER 133 SUBROUTINE SMUMPS_BUF_DEALL_MAX_ARRAY() 134 IMPLICIT NONE 135 IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) 136 RETURN 137 END SUBROUTINE SMUMPS_BUF_DEALL_MAX_ARRAY 138 SUBROUTINE SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) 139 IMPLICIT NONE 140 INTEGER IERR, NFS4FATHER 141 IERR = 0 142 IF (allocated( BUF_MAX_ARRAY)) THEN 143 IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN 144 DEALLOCATE( BUF_MAX_ARRAY ) 145 ENDIF 146 ALLOCATE(BUF_MAX_ARRAY(NFS4FATHER),stat=IERR) 147 BUF_LMAX_ARRAY=NFS4FATHER 148 RETURN 149 END SUBROUTINE SMUMPS_BUF_MAX_ARRAY_MINSIZE 150 SUBROUTINE SMUMPS_BUF_DEALL_CB( IERR ) 151 IMPLICIT NONE 152 INTEGER IERR 153 CALL BUF_DEALL( BUF_CB, IERR ) 154 RETURN 155 END SUBROUTINE SMUMPS_BUF_DEALL_CB 156 SUBROUTINE SMUMPS_BUF_DEALL_SMALL_BUF( IERR ) 157 IMPLICIT NONE 158 INTEGER IERR 159 CALL BUF_DEALL( BUF_SMALL, IERR ) 160 RETURN 161 END SUBROUTINE SMUMPS_BUF_DEALL_SMALL_BUF 162 SUBROUTINE BUF_ALLOC( BUF, SIZE, IERR ) 163 IMPLICIT NONE 164 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF 165 INTEGER SIZE, IERR 166 IERR = 0 167 BUF%LBUF = SIZE 168 BUF%LBUF_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT 169 IF ( associated ( BUF%CONTENT ) ) DEALLOCATE( BUF%CONTENT ) 170 ALLOCATE( BUF%CONTENT( BUF%LBUF_INT ), stat = IERR ) 171 IF (IERR .NE. 0) THEN 172 NULLIFY( BUF%CONTENT ) 173 IERR = -1 174 BUF%LBUF = 0 175 BUF%LBUF_INT = 0 176 END IF 177 BUF%HEAD = 1 178 BUF%TAIL = 1 179 BUF%ILASTMSG = 1 180 RETURN 181 END SUBROUTINE BUF_ALLOC 182 SUBROUTINE BUF_DEALL( BUF, IERR ) 183 IMPLICIT NONE 184 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF 185 INCLUDE 'mpif.h' 186 INTEGER :: IERR 187 INTEGER :: STATUS(MPI_STATUS_SIZE) 188 LOGICAL :: FLAG 189 IF ( .NOT. associated ( BUF%CONTENT ) ) THEN 190 BUF%HEAD = 1 191 BUF%LBUF = 0 192 BUF%LBUF_INT = 0 193 BUF%TAIL = 1 194 BUF%ILASTMSG = 1 195 RETURN 196 END IF 197 DO WHILE ( BUF%HEAD.NE.0 .AND. BUF%HEAD .NE. BUF%TAIL ) 198 CALL MPI_TEST(BUF%CONTENT( BUF%HEAD + REQ ), FLAG, 199 & STATUS, IERR) 200 IF ( .not. FLAG ) THEN 201 WRITE(*,*) '** Warning: trying to cancel a request.' 202 WRITE(*,*) '** This might be problematic' 203 CALL MPI_CANCEL( BUF%CONTENT( BUF%HEAD + REQ ), IERR ) 204 CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), IERR ) 205 END IF 206 BUF%HEAD = BUF%CONTENT( BUF%HEAD + NEXT ) 207 END DO 208 DEALLOCATE( BUF%CONTENT ) 209 NULLIFY( BUF%CONTENT ) 210 BUF%LBUF = 0 211 BUF%LBUF_INT = 0 212 BUF%HEAD = 1 213 BUF%TAIL = 1 214 BUF%ILASTMSG = 1 215 RETURN 216 END SUBROUTINE BUF_DEALL 217 SUBROUTINE SMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, 218 & INODE, FPERE, NFRONT, LCONT, 219 & NASS, NPIV, 220 & IWROW, IWCOL, A, COMPRESSCB, 221 & DEST, TAG, COMM, KEEP, IERR ) 222 IMPLICIT NONE 223 INTEGER DEST, TAG, COMM, IERR 224 INTEGER NBROWS_ALREADY_SENT 225 INTEGER, INTENT(INOUT) :: KEEP(500) 226 INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV 227 INTEGER IWROW( LCONT ), IWCOL( LCONT ) 228 REAL A( * ) 229 LOGICAL COMPRESSCB 230 INCLUDE 'mpif.h' 231 INTEGER NBROWS_PACKET 232 INTEGER POSITION, IREQ, IPOS, I, J1 233 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS 234 INTEGER IZERO, IONE 235 INTEGER SIZECB 236 INTEGER LCONT_SENT 237 INTEGER DEST2(1) 238 PARAMETER( IZERO = 0, IONE = 1 ) 239 LOGICAL RECV_BUF_SMALLER_THAN_SEND 240 DOUBLE PRECISION TMP 241 DEST2(1) = DEST 242 IERR = 0 243 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN 244 CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, 245 & COMM, SIZE1, IERR) 246 ELSE 247 CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR) 248 ENDIF 249 CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) 250 IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN 251 RECV_BUF_SMALLER_THAN_SEND = .FALSE. 252 ELSE 253 SIZE_AV = SIZE_RBUF_BYTES 254 RECV_BUF_SMALLER_THAN_SEND = .TRUE. 255 ENDIF 256 SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL 257 IF (SIZE_AV_REALS < 0 ) THEN 258 NBROWS_PACKET = 0 259 ELSE 260 IF (COMPRESSCB) THEN 261 TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 262 NBROWS_PACKET = int( 263 & ( sqrt( TMP * TMP 264 & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) 265 & / 2.0D0 ) 266 ELSE 267 IF (LCONT.EQ.0) THEN 268 NBROWS_PACKET = 0 269 ELSE 270 NBROWS_PACKET = SIZE_AV_REALS / LCONT 271 ENDIF 272 ENDIF 273 ENDIF 274 10 CONTINUE 275 NBROWS_PACKET = max(0, 276 & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) 277 IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN 278 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 279 IERR = -3 280 GOTO 100 281 ELSE 282 IERR = -1 283 GOTO 100 284 ENDIF 285 ENDIF 286 IF (COMPRESSCB) THEN 287 SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET 288 & *(NBROWS_PACKET+1))/2 289 ELSE 290 SIZECB = NBROWS_PACKET * LCONT 291 ENDIF 292 CALL MPI_PACK_SIZE( SIZECB, MPI_REAL, 293 & COMM, SIZE2, IERR ) 294 SIZE_PACK = SIZE1 + SIZE2 295 IF (SIZE_PACK .GT. SIZE_AV ) THEN 296 NBROWS_PACKET = NBROWS_PACKET - 1 297 IF (NBROWS_PACKET > 0) THEN 298 GOTO 10 299 ELSE 300 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 301 IERR=-3 302 GOTO 100 303 ELSE 304 IERR = -1 305 GOTO 100 306 ENDIF 307 ENDIF 308 ENDIF 309 IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. 310 & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 311 & .AND. 312 & .NOT. RECV_BUF_SMALLER_THAN_SEND) 313 & THEN 314 IERR = -1 315 GOTO 100 316 ENDIF 317 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, 318 & IONE , DEST2 319 & ) 320 IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN 321 NBROWS_PACKET = NBROWS_PACKET - 1 322 IF ( NBROWS_PACKET > 0 ) GOTO 10 323 ENDIF 324 IF ( IERR .LT. 0 ) GOTO 100 325 POSITION = 0 326 CALL MPI_PACK( INODE, 1, MPI_INTEGER, 327 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 328 & POSITION, COMM, IERR ) 329 CALL MPI_PACK( FPERE, 1, MPI_INTEGER, 330 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 331 & POSITION, COMM, IERR ) 332 IF (COMPRESSCB) THEN 333 LCONT_SENT=-LCONT 334 ELSE 335 LCONT_SENT=LCONT 336 ENDIF 337 CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, 338 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 339 & POSITION, COMM, IERR ) 340 CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, 341 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 342 & POSITION, COMM, IERR ) 343 CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, 344 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 345 & POSITION, COMM, IERR ) 346 IF (NBROWS_ALREADY_SENT == 0) THEN 347 CALL MPI_PACK( LCONT, 1, MPI_INTEGER, 348 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 349 & POSITION, COMM, IERR ) 350 CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, 351 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 352 & POSITION, COMM, IERR ) 353 CALL MPI_PACK( LCONT , 1, MPI_INTEGER, 354 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 355 & POSITION, COMM, IERR ) 356 CALL MPI_PACK( IZERO, 1, MPI_INTEGER, 357 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 358 & POSITION, COMM, IERR ) 359 CALL MPI_PACK( IONE, 1, MPI_INTEGER, 360 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 361 & POSITION, COMM, IERR ) 362 CALL MPI_PACK( IZERO, 1, MPI_INTEGER, 363 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 364 & POSITION, COMM, IERR ) 365 CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, 366 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 367 & POSITION, COMM, IERR ) 368 CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, 369 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 370 & POSITION, COMM, IERR ) 371 ENDIF 372 IF ( LCONT .NE. 0 ) THEN 373 J1 = 1 + NBROWS_ALREADY_SENT * NFRONT 374 IF (COMPRESSCB) THEN 375 DO I = NBROWS_ALREADY_SENT+1, 376 & NBROWS_ALREADY_SENT+NBROWS_PACKET 377 CALL MPI_PACK( A( J1 ), I, MPI_REAL, 378 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 379 & POSITION, COMM, IERR ) 380 J1 = J1 + NFRONT 381 END DO 382 ELSE 383 DO I = NBROWS_ALREADY_SENT+1, 384 & NBROWS_ALREADY_SENT+NBROWS_PACKET 385 CALL MPI_PACK( A( J1 ), LCONT, MPI_REAL, 386 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 387 & POSITION, COMM, IERR ) 388 J1 = J1 + NFRONT 389 END DO 390 ENDIF 391 END IF 392 KEEP(266)=KEEP(266)+1 393 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, 394 & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), IERR ) 395 IF ( SIZE_PACK .LT. POSITION ) THEN 396 WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, 397 & POSITION 398 CALL MUMPS_ABORT() 399 END IF 400 IF ( SIZE_PACK .NE. POSITION ) 401 & CALL BUF_ADJUST( BUF_CB, POSITION ) 402 NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET 403 IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN 404 IERR = -1 405 RETURN 406 ENDIF 407 100 CONTINUE 408 RETURN 409 END SUBROUTINE SMUMPS_BUF_SEND_CB 410 SUBROUTINE SMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, 411 & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, 412 & JBDEB, JBFIN, 413 & CB, SOL, 414 & DEST, COMM, KEEP, IERR ) 415 IMPLICIT NONE 416 INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV 417 INTEGER DEST, COMM, IERR, JBDEB, JBFIN 418 REAL CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) 419 REAL SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) 420 INTEGER, INTENT(INOUT) :: KEEP(500) 421 INCLUDE 'mpif.h' 422 INCLUDE 'mumps_tags.h' 423 INTEGER SIZE, SIZE1, SIZE2, K 424 INTEGER POSITION, IREQ, IPOS 425 INTEGER IONE 426 INTEGER DEST2(1) 427 PARAMETER ( IONE=1 ) 428 DEST2(1) = DEST 429 IERR = 0 430 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) 431 CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), 432 & MPI_REAL, COMM, 433 & SIZE2, IERR ) 434 SIZE = SIZE1 + SIZE2 435 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, 436 & IONE , DEST2 437 & ) 438 IF ( IERR .LT. 0 ) THEN 439 RETURN 440 ENDIF 441 POSITION = 0 442 CALL MPI_PACK( INODE, 1, MPI_INTEGER, 443 & BUF_CB%CONTENT( IPOS ), SIZE, 444 & POSITION, COMM, IERR ) 445 CALL MPI_PACK( IFATH, 1, MPI_INTEGER, 446 & BUF_CB%CONTENT( IPOS ), SIZE, 447 & POSITION, COMM, IERR ) 448 CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, 449 & BUF_CB%CONTENT( IPOS ), SIZE, 450 & POSITION, COMM, IERR ) 451 CALL MPI_PACK( NPIV , 1, MPI_INTEGER, 452 & BUF_CB%CONTENT( IPOS ), SIZE, 453 & POSITION, COMM, IERR ) 454 CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, 455 & BUF_CB%CONTENT( IPOS ), SIZE, 456 & POSITION, COMM, IERR ) 457 CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, 458 & BUF_CB%CONTENT( IPOS ), SIZE, 459 & POSITION, COMM, IERR ) 460 DO K = 1, NRHS 461 CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), 462 & EFF_CB_SIZE, MPI_REAL, 463 & BUF_CB%CONTENT( IPOS ), SIZE, 464 & POSITION, COMM, IERR ) 465 END DO 466 IF ( NPIV .GT. 0 ) THEN 467 DO K=1, NRHS 468 CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), 469 & NPIV, MPI_REAL, 470 & BUF_CB%CONTENT( IPOS ), SIZE, 471 & POSITION, COMM, IERR ) 472 ENDDO 473 END IF 474 KEEP(266)=KEEP(266)+1 475 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, 476 & DEST, Master2Slave, COMM, 477 & BUF_CB%CONTENT( IREQ ), IERR ) 478 IF ( SIZE .LT. POSITION ) THEN 479 WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', 480 & SIZE, POSITION 481 CALL MUMPS_ABORT() 482 END IF 483 IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) 484 RETURN 485 END SUBROUTINE SMUMPS_BUF_SEND_MASTER2SLAVE 486 SUBROUTINE SMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, 487 & LONG, 488 & IW, W, JBDEB, JBFIN, 489 & RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, NPIV, 490 & KEEP, 491 & DEST, TAG, COMM, IERR ) 492 IMPLICIT NONE 493 INTEGER LDW, DEST, TAG, COMM, IERR 494 INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN 495 INTEGER IW( max( 1, LONG ) ) 496 INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, IPOSINRHSCOMP, NPIV 497 REAL W( max( 1, LDW * NRHS_B ) ) 498# if defined(RHSCOMP_BYROWS) 499 REAL RHSCOMP(NRHS,LRHSCOMP) 500# else 501 REAL RHSCOMP(LRHSCOMP,NRHS) 502# endif 503 INTEGER, INTENT(INOUT) :: KEEP(500) 504 INCLUDE 'mpif.h' 505 INTEGER POSITION, IREQ, IPOS 506 INTEGER SIZE1, SIZE2, SIZE, K 507 INTEGER IONE 508 INTEGER DEST2(1) 509 PARAMETER ( IONE=1 ) 510 DEST2(1)=DEST 511 IERR = 0 512 IF ( NODE2 .EQ. 0 ) THEN 513 CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) 514 ELSE 515 CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, IERR ) 516 END IF 517 SIZE2 = 0 518 IF ( LONG .GT. 0 ) THEN 519 CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_REAL, 520 & COMM, SIZE2, IERR ) 521 END IF 522 SIZE = SIZE1 + SIZE2 523 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, 524 & IONE , DEST2 525 & ) 526 IF ( IERR .LT. 0 ) THEN 527 RETURN 528 ENDIF 529 POSITION = 0 530 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, 531 & BUF_CB%CONTENT( IPOS ), SIZE, 532 & POSITION, COMM, IERR ) 533 IF ( NODE2 .NE. 0 ) THEN 534 CALL MPI_PACK( NODE2, 1, MPI_INTEGER, 535 & BUF_CB%CONTENT( IPOS ), SIZE, 536 & POSITION, COMM, IERR ) 537 CALL MPI_PACK( NCB, 1, MPI_INTEGER, 538 & BUF_CB%CONTENT( IPOS ), SIZE, 539 & POSITION, COMM, IERR ) 540 ENDIF 541 CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, 542 & BUF_CB%CONTENT( IPOS ), SIZE, 543 & POSITION, COMM, IERR ) 544 CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, 545 & BUF_CB%CONTENT( IPOS ), SIZE, 546 & POSITION, COMM, IERR ) 547 CALL MPI_PACK( LONG, 1, MPI_INTEGER, 548 & BUF_CB%CONTENT( IPOS ), SIZE, 549 & POSITION, COMM, IERR ) 550 IF ( LONG .GT. 0 ) THEN 551 CALL MPI_PACK( IW, LONG, MPI_INTEGER, 552 & BUF_CB%CONTENT( IPOS ), SIZE, 553 & POSITION, COMM, IERR ) 554 IF (NODE2.EQ.0.AND.KEEP(350).NE.0) THEN 555 DO K=1, NRHS_B 556#if defined(RHSCOMP_BYROWS) 557 WRITE(*,*) "Internal error in SMUMPS_BUF_SEND_VCB" 558 CALL MUMPS_ABORT() 559#else 560 IF (NPIV.GT.0) THEN 561 CALL MPI_PACK( RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1), NPIV, 562 & MPI_REAL, 563 & BUF_CB%CONTENT( IPOS ), SIZE, 564 & POSITION, COMM, IERR ) 565 ENDIF 566 IF (LONG-NPIV .NE.0) THEN 567 CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, 568 & MPI_REAL, 569 & BUF_CB%CONTENT( IPOS ), SIZE, 570 & POSITION, COMM, IERR ) 571 ENDIF 572#endif 573 END DO 574 ELSE 575 DO K=1, NRHS_B 576 CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_REAL, 577 & BUF_CB%CONTENT( IPOS ), SIZE, 578 & POSITION, COMM, IERR ) 579 END DO 580 ENDIF 581 END IF 582 KEEP(266)=KEEP(266)+1 583 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, 584 & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), IERR ) 585 IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) 586 RETURN 587 END SUBROUTINE SMUMPS_BUF_SEND_VCB 588 SUBROUTINE SMUMPS_BUF_SEND_1INT( I, DEST, TAG, COMM, 589 & KEEP, IERR ) 590 IMPLICIT NONE 591 INTEGER I 592 INTEGER DEST, TAG, COMM, IERR 593 INTEGER, INTENT(INOUT) :: KEEP(500) 594 INCLUDE 'mpif.h' 595 INTEGER IPOS, IREQ, MSG_SIZE, POSITION 596 INTEGER IONE 597 INTEGER DEST2(1) 598 PARAMETER ( IONE=1 ) 599 DEST2(1)=DEST 600 IERR = 0 601 CALL MPI_PACK_SIZE( 1, MPI_INTEGER, 602 & COMM, MSG_SIZE, IERR ) 603 CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, 604 & IONE , DEST2 605 & ) 606 IF ( IERR .LT. 0 ) THEN 607 write(6,*) ' Internal error in SMUMPS_BUF_SEND_1INT', 608 & ' Buf size (bytes)= ',BUF_SMALL%LBUF 609 RETURN 610 ENDIF 611 POSITION=0 612 CALL MPI_PACK( I, 1, 613 & MPI_INTEGER, BUF_SMALL%CONTENT( IPOS ), 614 & MSG_SIZE, 615 & POSITION, COMM, IERR ) 616 KEEP(266)=KEEP(266)+1 617 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, 618 & MPI_PACKED, DEST, TAG, COMM, 619 & BUF_SMALL%CONTENT( IREQ ), IERR ) 620 RETURN 621 END SUBROUTINE SMUMPS_BUF_SEND_1INT 622 SUBROUTINE SMUMPS_BUF_ALL_EMPTY(CHECK_COMM_NODES, 623 & CHECK_COMM_LOAD,FLAG) 624 LOGICAL, INTENT(IN) :: CHECK_COMM_NODES, CHECK_COMM_LOAD 625 LOGICAL, INTENT(OUT) :: FLAG 626 LOGICAL FLAG1, FLAG2, FLAG3 627 FLAG = .TRUE. 628 IF (CHECK_COMM_NODES) THEN 629 CALL SMUMPS_BUF_EMPTY( BUF_SMALL, FLAG1 ) 630 CALL SMUMPS_BUF_EMPTY( BUF_CB, FLAG2 ) 631 FLAG = FLAG .AND. FLAG1 .AND. FLAG2 632 ENDIF 633 IF ( CHECK_COMM_LOAD ) THEN 634 CALL SMUMPS_BUF_EMPTY( BUF_LOAD, FLAG3 ) 635 FLAG = FLAG .AND. FLAG3 636 ENDIF 637 RETURN 638 END SUBROUTINE SMUMPS_BUF_ALL_EMPTY 639 SUBROUTINE SMUMPS_BUF_EMPTY( B, FLAG ) 640 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B 641 LOGICAL :: FLAG 642 INTEGER SIZE_AVAIL 643 CALL SMUMPS_BUF_SIZE_AVAILABLE(B, SIZE_AVAIL) 644 FLAG = ( B%HEAD == B%TAIL ) 645 RETURN 646 END SUBROUTINE SMUMPS_BUF_EMPTY 647 SUBROUTINE SMUMPS_BUF_SIZE_AVAILABLE( B, SIZE_AV ) 648 IMPLICIT NONE 649 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B 650 INTEGER SIZE_AV 651 INCLUDE 'mpif.h' 652 INTEGER :: IERR 653 INTEGER :: STATUS(MPI_STATUS_SIZE) 654 LOGICAL :: FLAG 655 IF ( B%HEAD .NE. B%TAIL ) THEN 656 10 CONTINUE 657 CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, IERR ) 658 IF ( FLAG ) THEN 659 B%HEAD = B%CONTENT( B%HEAD + NEXT ) 660 IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL 661 IF ( B%HEAD .NE. B%TAIL ) GOTO 10 662 END IF 663 END IF 664 IF ( B%HEAD .EQ. B%TAIL ) THEN 665 B%HEAD = 1 666 B%TAIL = 1 667 B%ILASTMSG = 1 668 END IF 669 IF ( B%HEAD .LE. B%TAIL ) THEN 670 SIZE_AV = max( B%LBUF_INT - B%TAIL, B%HEAD - 2 ) 671 ELSE 672 SIZE_AV = B%HEAD - B%TAIL - 1 673 END IF 674 SIZE_AV = min(SIZE_AV - OVHSIZE, SIZE_AV) 675 SIZE_AV = SIZE_AV * SIZEofINT 676 RETURN 677 END SUBROUTINE SMUMPS_BUF_SIZE_AVAILABLE 678 SUBROUTINE SMUMPS_BUF_TEST() 679 INTEGER :: IPOS, IREQ, IERR 680 INTEGER, PARAMETER :: IONE=1 681 INTEGER :: MSG_SIZE 682 INTEGER :: DEST2(1) 683 DEST2=-10 684 MSG_SIZE=1 685 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, MSG_SIZE, IERR, 686 & IONE , DEST2,.TRUE.) 687 RETURN 688 END SUBROUTINE SMUMPS_BUF_TEST 689 SUBROUTINE BUF_LOOK( B, IPOS, IREQ, MSG_SIZE, IERR, 690 & NDEST , PDEST, TEST_ONLY 691 & ) 692 IMPLICIT NONE 693 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B 694 INTEGER, INTENT(IN) :: MSG_SIZE 695 INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR 696 LOGICAL, INTENT(IN), OPTIONAL :: TEST_ONLY 697 INTEGER NDEST 698 INTEGER, INTENT(IN) :: PDEST(max(1,NDEST)) 699 INCLUDE 'mpif.h' 700 INTEGER :: MSG_SIZE_INT 701 INTEGER :: IBUF 702 LOGICAL :: FLAG 703 INTEGER :: STATUS(MPI_STATUS_SIZE) 704 IERR = 0 705 IF ( B%HEAD .NE. B%TAIL ) THEN 706 10 CONTINUE 707 CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, IERR ) 708 IF ( FLAG ) THEN 709 B%HEAD = B%CONTENT( B%HEAD + NEXT ) 710 IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL 711 IF ( B%HEAD .NE. B%TAIL ) GOTO 10 712 END IF 713 END IF 714 IF ( B%HEAD .EQ. B%TAIL ) THEN 715 B%HEAD = 1 716 B%TAIL = 1 717 B%ILASTMSG = 1 718 END iF 719 MSG_SIZE_INT = ( MSG_SIZE + ( SIZEofINT - 1 ) ) / SIZEofINT 720 MSG_SIZE_INT = MSG_SIZE_INT + OVHSIZE 721 IF (present(TEST_ONLY)) RETURN 722 FLAG = ( ( B%HEAD .LE. B%TAIL ) 723 & .AND. ( 724 & ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL ) 725 & .OR. ( MSG_SIZE_INT .LE. B%HEAD - 2 ) ) ) 726 & .OR. 727 & ( ( B%HEAD .GT. B%TAIL ) 728 & .AND. ( MSG_SIZE_INT .LE. B%HEAD - B%TAIL - 1 ) ) 729 IF ( .NOT. FLAG 730 & ) THEN 731 IERR = -1 732 IF ( MSG_SIZE_INT .GT. B%LBUF_INT - 1 ) THEN 733 IERR = -2 734 ENDIF 735 IPOS = -1 736 IREQ = -1 737 RETURN 738 END IF 739 IF ( B%HEAD .LE. B%TAIL ) THEN 740 IF ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL + 1 ) THEN 741 IBUF = B%TAIL 742 ELSE IF ( MSG_SIZE_INT .LE. B%HEAD - 1 ) THEN 743 IBUF = 1 744 END IF 745 ELSE 746 IBUF = B%TAIL 747 END IF 748 B%CONTENT( B%ILASTMSG + NEXT ) = IBUF 749 B%ILASTMSG = IBUF 750 B%TAIL = IBUF + MSG_SIZE_INT 751 B%CONTENT( IBUF + NEXT ) = 0 752 IPOS = IBUF + CONTENT 753 IREQ = IBUF + REQ 754 RETURN 755 END SUBROUTINE BUF_LOOK 756 SUBROUTINE BUF_ADJUST( BUF, SIZE ) 757 IMPLICIT NONE 758 TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF 759 INTEGER SIZE 760 INTEGER SIZE_INT 761 SIZE_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT 762 SIZE_INT = SIZE_INT + OVHSIZE 763 BUF%TAIL = BUF%ILASTMSG + SIZE_INT 764 RETURN 765 END SUBROUTINE BUF_ADJUST 766 SUBROUTINE SMUMPS_BUF_SEND_DESC_BANDE( 767 & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, 768 & NASS, NSLAVES, LIST_SLAVES, 769 & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR 770 & , LRSTATUS 771 &) 772 IMPLICIT NONE 773 INTEGER COMM, IERR, NFRONT 774 INTEGER INODE 775 INTEGER NLIG, NCOL, NASS, NSLAVES 776 INTEGER NBPROCFILS, DEST 777 INTEGER ILIG( NLIG ) 778 INTEGER ICOL( NCOL ) 779 INTEGER, INTENT(IN) :: IBC_SOURCE 780 INTEGER LIST_SLAVES( NSLAVES ) 781 INTEGER, INTENT(INOUT) :: KEEP(500) 782 INTEGER, INTENT(IN) :: LRSTATUS 783 INCLUDE 'mpif.h' 784 INCLUDE 'mumps_tags.h' 785 INTEGER SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ 786 INTEGER IONE 787 INTEGER DEST2(1) 788 PARAMETER ( IONE=1 ) 789 DEST2(1) = DEST 790 IERR = 0 791 SIZE_INT = ( 7 + NLIG + NCOL + NSLAVES + 1 ) 792 SIZE_INT = SIZE_INT + 1 793 SIZE_BYTES = SIZE_INT * SIZEofINT 794 IF (SIZE_INT.GT.SIZE_RBUF_BYTES ) THEN 795 IERR = -3 796 RETURN 797 END IF 798 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_BYTES, IERR, 799 & IONE , DEST2 800 & ) 801 IF ( IERR .LT. 0 ) THEN 802 RETURN 803 ENDIF 804 POSITION = IPOS 805 BUF_CB%CONTENT( POSITION ) = SIZE_INT 806 POSITION = POSITION + 1 807 BUF_CB%CONTENT( POSITION ) = INODE 808 POSITION = POSITION + 1 809 BUF_CB%CONTENT( POSITION ) = NBPROCFILS 810 POSITION = POSITION + 1 811 BUF_CB%CONTENT( POSITION ) = NLIG 812 POSITION = POSITION + 1 813 BUF_CB%CONTENT( POSITION ) = NCOL 814 POSITION = POSITION + 1 815 BUF_CB%CONTENT( POSITION ) = NASS 816 POSITION = POSITION + 1 817 BUF_CB%CONTENT( POSITION ) = NFRONT 818 POSITION = POSITION + 1 819 BUF_CB%CONTENT( POSITION ) = NSLAVES 820 POSITION = POSITION + 1 821 BUF_CB%CONTENT( POSITION ) = LRSTATUS 822 POSITION = POSITION + 1 823 IF (NSLAVES.GT.0) THEN 824 BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) = 825 & LIST_SLAVES( 1: NSLAVES ) 826 POSITION = POSITION + NSLAVES 827 ENDIF 828 BUF_CB%CONTENT( POSITION:POSITION + NLIG - 1 ) = ILIG 829 POSITION = POSITION + NLIG 830 BUF_CB%CONTENT( POSITION:POSITION + NCOL - 1 ) = ICOL 831 POSITION = POSITION + NCOL 832 POSITION = POSITION - IPOS 833 IF ( POSITION * SIZEofINT .NE. SIZE_BYTES ) THEN 834 WRITE(*,*) 'Error in SMUMPS_BUF_SEND_DESC_BANDE :', 835 & ' wrong estimated size' 836 CALL MUMPS_ABORT() 837 END IF 838 KEEP(266)=KEEP(266)+1 839 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE_BYTES, 840 & MPI_PACKED, 841 & DEST, MAITRE_DESC_BANDE, COMM, 842 & BUF_CB%CONTENT( IREQ ), IERR ) 843 RETURN 844 END SUBROUTINE SMUMPS_BUF_SEND_DESC_BANDE 845 SUBROUTINE SMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, 846 & IPERE, ISON, NROW, 847 & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, 848 & NSLAVES, SLAVES, DEST, COMM, IERR, 849 & 850 & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) 851 IMPLICIT NONE 852 INTEGER NBROWS_ALREADY_SENT 853 INTEGER LDA, NELIM, TYPE_SON 854 INTEGER IPERE, ISON, NROW, NCOL, NSLAVES 855 INTEGER IROW( NROW ) 856 INTEGER ICOL( NCOL ) 857 INTEGER SLAVES( NSLAVES ) 858 REAL VAL(LDA, *) 859 INTEGER IPOS, IREQ, DEST, COMM, IERR 860 INTEGER SLAVEF, KEEP(500), INIV2 861 INTEGER(8) KEEP8(150) 862 INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 863 INCLUDE 'mpif.h' 864 INCLUDE 'mumps_tags.h' 865 INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I 866 INTEGER NBROWS_PACKET, NCOL_SEND 867 INTEGER SIZE_AV 868 LOGICAL RECV_BUF_SMALLER_THAN_SEND 869 INTEGER IONE 870 INTEGER DEST2(1) 871 PARAMETER ( IONE=1 ) 872 DEST2(1) = DEST 873 IERR = 0 874 IF ( NELIM .NE. NROW ) THEN 875 WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW 876 CALL MUMPS_ABORT() 877 END IF 878 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN 879 CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, 880 & COMM, SIZE1, IERR ) 881 IF ( TYPE_SON .eq. 2 ) THEN 882 CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, 883 & COMM, SIZE3, IERR ) 884 ELSE 885 SIZE3 = 0 886 ENDIF 887 SIZE1=SIZE1+SIZE3 888 ELSE 889 CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR) 890 ENDIF 891 IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN 892 NCOL_SEND = NROW 893 ELSE 894 NCOL_SEND = NCOL 895 ENDIF 896 CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) 897 IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN 898 RECV_BUF_SMALLER_THAN_SEND = .FALSE. 899 ELSE 900 RECV_BUF_SMALLER_THAN_SEND = .TRUE. 901 SIZE_AV = SIZE_RBUF_BYTES 902 ENDIF 903 IF (NROW .GT. 0 ) THEN 904 NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL 905 NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) 906 NBROWS_PACKET = max(NBROWS_PACKET, 0) 907 ELSE 908 NBROWS_PACKET =0 909 ENDIF 910 IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN 911 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 912 IERR=-3 913 GOTO 100 914 ELSE 915 IERR=-1 916 GOTO 100 917 ENDIF 918 ENDIF 919 10 CONTINUE 920 CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, 921 & MPI_REAL, 922 & COMM, SIZE2, IERR ) 923 SIZE_PACK = SIZE1 + SIZE2 924 IF (SIZE_PACK .GT. SIZE_AV) THEN 925 NBROWS_PACKET = NBROWS_PACKET - 1 926 IF ( NBROWS_PACKET .GT. 0 ) THEN 927 GOTO 10 928 ELSE 929 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 930 IERR = -3 931 GOTO 100 932 ELSE 933 IERR = -1 934 GOTO 100 935 ENDIF 936 ENDIF 937 ENDIF 938 IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. 939 & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 2 940 & .AND. 941 & .NOT. RECV_BUF_SMALLER_THAN_SEND) 942 & THEN 943 IERR = -1 944 GOTO 100 945 ENDIF 946 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, 947 & IONE , DEST2 948 & ) 949 IF ( IERR .LT. 0 ) THEN 950 GOTO 100 951 ENDIF 952 POSITION = 0 953 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, 954 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 955 & POSITION, COMM, IERR ) 956 CALL MPI_PACK( ISON, 1, MPI_INTEGER, 957 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 958 & POSITION, COMM, IERR ) 959 CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, 960 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 961 & POSITION, COMM, IERR ) 962 CALL MPI_PACK( NROW, 1, MPI_INTEGER, 963 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 964 & POSITION, COMM, IERR ) 965 CALL MPI_PACK( NCOL, 1, MPI_INTEGER, 966 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 967 & POSITION, COMM, IERR ) 968 CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, 969 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 970 & POSITION, COMM, IERR ) 971 CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, 972 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 973 & POSITION, COMM, IERR ) 974 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN 975 IF (NSLAVES.GT.0) THEN 976 CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, 977 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 978 & POSITION, COMM, IERR ) 979 ENDIF 980 CALL MPI_PACK( IROW, NROW, MPI_INTEGER, 981 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 982 & POSITION, COMM, IERR ) 983 CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, 984 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 985 & POSITION, COMM, IERR ) 986 IF ( TYPE_SON .eq. 2 ) THEN 987 CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, 988 & MPI_INTEGER, 989 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 990 & POSITION, COMM, IERR ) 991 ENDIF 992 ENDIF 993 IF (NBROWS_PACKET.GE.1) THEN 994 DO I=NBROWS_ALREADY_SENT+1, 995 & NBROWS_ALREADY_SENT+NBROWS_PACKET 996 CALL MPI_PACK( VAL(1,I), NCOL_SEND, 997 & MPI_REAL, 998 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 999 & POSITION, COMM, IERR ) 1000 ENDDO 1001 ENDIF 1002 KEEP(266)=KEEP(266)+1 1003 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, 1004 & DEST, MAITRE2, COMM, 1005 & BUF_CB%CONTENT( IREQ ), IERR ) 1006 IF ( SIZE_PACK .LT. POSITION ) THEN 1007 write(*,*) 'Try_send_maitre2, SIZE,POSITION=', 1008 & SIZE_PACK,POSITION 1009 CALL MUMPS_ABORT() 1010 END IF 1011 IF ( SIZE_PACK .NE. POSITION ) 1012 & CALL BUF_ADJUST( BUF_CB, POSITION ) 1013 NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET 1014 IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN 1015 IERR = -1 1016 ENDIF 1017 100 CONTINUE 1018 RETURN 1019 END SUBROUTINE SMUMPS_BUF_SEND_MAITRE2 1020 SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, 1021 & DESC_IN_LU, 1022 & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, 1023 & NSLAVES_PERE, 1024 & ISON, NBROW, LMAP, MAPROW, PERM, IW_CBSON, A_CBSON, 1025 & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, 1026 & 1027 & KEEP,KEEP8, STEP, N, SLAVEF, 1028 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 1029 & COMPRESSCB, KEEP253_LOC ) 1030 IMPLICIT NONE 1031 INTEGER NBROWS_ALREADY_SENT 1032 INTEGER, INTENT (in) :: KEEP253_LOC 1033 INTEGER IPERE, ISON, NBROW 1034 INTEGER PDEST, ISLAVE, COMM, IERR 1035 INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, 1036 & NFRONT_PERE, LMAP 1037 INTEGER MAPROW( LMAP ), PERM( max(1, NBROW )) 1038 INTEGER IW_CBSON( * ) 1039 REAL A_CBSON( * ) 1040 LOGICAL DESC_IN_LU, COMPRESSCB 1041 INTEGER KEEP(500), N , SLAVEF 1042 INTEGER(8) KEEP8(150) 1043 INTEGER STEP(N), 1044 & ISTEP_TO_INIV2(KEEP(71)), 1045 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 1046 INCLUDE 'mpif.h' 1047 INCLUDE 'mumps_tags.h' 1048 INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 1049 INTEGER(8) :: ASIZE 1050 LOGICAL COMPUTE_MAX 1051 INTEGER NBROWS_PACKET 1052 INTEGER MAX_ROW_LENGTH 1053 INTEGER LROW, NELIM 1054 INTEGER(8) :: SIZFR, ITMP8 1055 INTEGER NPIV, NFRONT, HS 1056 INTEGER SIZE_PACK, SIZE1, SIZE2, POSITION,I 1057 INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV 1058 INTEGER NBINT, L 1059 INTEGER(8) :: APOS, SHIFTCB_SON, LDA_SON8 1060 INTEGER IPOS_IN_SLAVE 1061 INTEGER STATE_SON 1062 INTEGER INDICE_PERE, NROW, IPOS, IREQ, NOSLA 1063 INTEGER IONE, J, THIS_ROW_LENGTH 1064 INTEGER SIZE_DESC_BANDE, DESC_BANDE_BYTES 1065 LOGICAL RECV_BUF_SMALLER_THAN_SEND 1066 LOGICAL NOT_ENOUGH_SPACE 1067 INTEGER PDEST2(1) 1068 PARAMETER ( IONE=1 ) 1069 INCLUDE 'mumps_headers.h' 1070 REAL ZERO 1071 PARAMETER (ZERO = 0.0E0) 1072 COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. 1073 & (KEEP(50) .EQ. 2) .AND. 1074 & (PDEST.EQ.PDEST_MASTER) 1075 IF (NBROWS_ALREADY_SENT == 0) THEN 1076 IF (COMPUTE_MAX) THEN 1077 CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) 1078 IF (IERR .NE. 0) THEN 1079 IERR = -4 1080 RETURN 1081 ENDIF 1082 ENDIF 1083 ENDIF 1084 PDEST2(1) = PDEST 1085 IERR = 0 1086 LROW = IW_CBSON( 1 + KEEP(IXSZ)) 1087 NELIM = IW_CBSON( 2 + KEEP(IXSZ)) 1088 NPIV = IW_CBSON( 4 + KEEP(IXSZ)) 1089 IF ( NPIV .LT. 0 ) THEN 1090 NPIV = 0 1091 END IF 1092 NROW = IW_CBSON( 3 + KEEP(IXSZ)) 1093 NFRONT = LROW + NPIV 1094 HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) 1095 CALL MUMPS_GETI8( SIZFR, IW_CBSON( 1 + XXR ) ) 1096 STATE_SON = IW_CBSON(1+XXS) 1097 IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN 1098 LDA_SON8 = int(LROW,8) 1099 SHIFTCB_SON = int(NPIV,8)*int(NROW,8) 1100 ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN 1101 LDA_SON8 = int(LROW,8) 1102 SHIFTCB_SON = 0_8 1103 ELSE 1104 LDA_SON8 = int(NFRONT,8) 1105 SHIFTCB_SON = int(NPIV,8) 1106 ENDIF 1107 CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) 1108 IF (PDEST .EQ. PDEST_MASTER) THEN 1109 SIZE_DESC_BANDE=0 1110 ELSE 1111 SIZE_DESC_BANDE=(7+SLAVEF+KEEP(127)*2) 1112 SIZE_DESC_BANDE=SIZE_DESC_BANDE+int(real(KEEP(12))* 1113 & real(SIZE_DESC_BANDE)/100.0E0) 1114 SIZE_DESC_BANDE=max(SIZE_DESC_BANDE, 1115 & 7+NSLAVES_PERE+NFRONT_PERE+NFRONT_PERE-NASS_PERE) 1116 ENDIF 1117 DESC_BANDE_BYTES=SIZE_DESC_BANDE*SIZEofINT 1118 IF ( SIZE_AV .LT. SIZE_RBUF_BYTES-DESC_BANDE_BYTES ) THEN 1119 RECV_BUF_SMALLER_THAN_SEND = .FALSE. 1120 ELSE 1121 RECV_BUF_SMALLER_THAN_SEND = .TRUE. 1122 SIZE_AV = SIZE_RBUF_BYTES-DESC_BANDE_BYTES 1123 ENDIF 1124 SIZE1=0 1125 IF (NBROWS_ALREADY_SENT==0) THEN 1126 IF(COMPUTE_MAX) THEN 1127 CALL MPI_PACK_SIZE(1, MPI_INTEGER, 1128 & COMM, PS1, IERR ) 1129 IF(NFS4FATHER .GT. 0) THEN 1130 CALL MPI_PACK_SIZE( NFS4FATHER, MPI_REAL, 1131 & COMM, SIZE1, IERR ) 1132 ENDIF 1133 SIZE1 = SIZE1+PS1 1134 ENDIF 1135 ENDIF 1136 IF (KEEP(50) .EQ. 0) THEN 1137 ONEorTWO = 1 1138 ELSE 1139 ONEorTWO = 2 1140 ENDIF 1141 IF (PDEST .EQ.PDEST_MASTER) THEN 1142 L = 0 1143 ELSE IF (KEEP(50) .EQ. 0) THEN 1144 L = LROW 1145 ELSE 1146 L = LROW + PERM(1) - LMAP + NBROWS_ALREADY_SENT - 1 1147 ONEorTWO=ONEorTWO+1 1148 ENDIF 1149 NBINT = 6 + L 1150 CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, 1151 & COMM, TMPSIZE, IERR ) 1152 SIZE1 = SIZE1 + TMPSIZE 1153 SIZE_AV = SIZE_AV - SIZE1 1154 NOT_ENOUGH_SPACE=.FALSE. 1155 IF (SIZE_AV .LT.0 ) THEN 1156 NBROWS_PACKET = 0 1157 NOT_ENOUGH_SPACE=.TRUE. 1158 ELSE 1159 IF ( KEEP(50) .EQ. 0 ) THEN 1160 NBROWS_PACKET = 1161 & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) 1162 ELSE 1163 B = 2 * ONEorTWO + 1164 & ( 1 + 2 * LROW + 2 * PERM(1) + 2 * NBROWS_ALREADY_SENT ) 1165 & * SIZEofREAL / SIZEofINT 1166 NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ 1167 & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * 1168 & dble(SIZEofREAL/SIZEofINT)))* 1169 & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) 1170 ENDIF 1171 ENDIF 1172 10 CONTINUE 1173 NBROWS_PACKET = max( 0, 1174 & min( NBROWS_PACKET, NBROW - NBROWS_ALREADY_SENT)) 1175 NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. 1176 & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) 1177 IF (NOT_ENOUGH_SPACE) THEN 1178 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 1179 IERR = -3 1180 GOTO 100 1181 ELSE 1182 IERR = -1 1183 GOTO 100 1184 ENDIF 1185 ENDIF 1186 IF (KEEP(50).EQ.0) THEN 1187 MAX_ROW_LENGTH = -99999 1188 SIZE_REALS = NBROWS_PACKET * LROW 1189 ELSE 1190 SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * 1191 & NBROWS_PACKET + ( NBROWS_PACKET * ( NBROWS_PACKET + 1) ) / 2 1192 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT 1193 & + NBROWS_PACKET-1 1194 ENDIF 1195 SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET 1196 CALL MPI_PACK_SIZE( SIZE_REALS, MPI_REAL, 1197 & COMM, SIZE2, IERR) 1198 CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, 1199 & COMM, SIZE3, IERR) 1200 IF (SIZE2 + SIZE3 .GT. SIZE_AV ) THEN 1201 NBROWS_PACKET = NBROWS_PACKET -1 1202 IF (NBROWS_PACKET .GT. 0 ) THEN 1203 GOTO 10 1204 ELSE 1205 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 1206 IERR = -3 1207 GOTO 100 1208 ELSE 1209 IERR = -1 1210 GOTO 100 1211 ENDIF 1212 ENDIF 1213 ENDIF 1214 SIZE_PACK = SIZE1 + SIZE2 + SIZE3 1215 IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW .AND. 1216 & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 .AND. 1217 & .NOT. RECV_BUF_SMALLER_THAN_SEND) 1218 & THEN 1219 IERR = -1 1220 GOTO 100 1221 ENDIF 1222 IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN 1223 IERR = -3 1224 GOTO 100 1225 ENDIF 1226 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, 1227 & IONE , PDEST2 1228 & ) 1229 IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN 1230 NBROWS_PACKET = NBROWS_PACKET - 1 1231 IF (NBROWS_PACKET > 0 ) GOTO 10 1232 ENDIF 1233 IF ( IERR .LT. 0 ) GOTO 100 1234 POSITION = 0 1235 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, 1236 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1237 & POSITION, COMM, IERR ) 1238 CALL MPI_PACK( ISON, 1, MPI_INTEGER, 1239 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1240 & POSITION, COMM, IERR ) 1241 CALL MPI_PACK( NBROW, 1, MPI_INTEGER, 1242 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1243 & POSITION, COMM, IERR ) 1244 IF (KEEP(50)==0) THEN 1245 CALL MPI_PACK( LROW, 1, MPI_INTEGER, 1246 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1247 & POSITION, COMM, IERR ) 1248 ELSE 1249 CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, 1250 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1251 & POSITION, COMM, IERR ) 1252 ENDIF 1253 CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, 1254 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1255 & POSITION, COMM, IERR ) 1256 CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, 1257 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1258 & POSITION, COMM, IERR ) 1259 IF ( PDEST .NE. PDEST_MASTER ) THEN 1260 IF (KEEP(50)==0) THEN 1261 CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, 1262 & MPI_INTEGER, 1263 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1264 & POSITION, COMM, IERR ) 1265 ELSE 1266 IF (MAX_ROW_LENGTH > 0) THEN 1267 CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), 1268 & MAX_ROW_LENGTH, 1269 & MPI_INTEGER, 1270 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1271 & POSITION, COMM, IERR ) 1272 ENDIF 1273 ENDIF 1274 END IF 1275 DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET 1276 I = PERM(J) 1277 INDICE_PERE=MAPROW(I) 1278 CALL MUMPS_BLOC2_GET_ISLAVE( 1279 & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, 1280 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 1281 & 1282 & NASS_PERE, 1283 & NFRONT_PERE - NASS_PERE, 1284 & NSLAVES_PERE, 1285 & INDICE_PERE, 1286 & NOSLA, 1287 & IPOS_IN_SLAVE ) 1288 INDICE_PERE = IPOS_IN_SLAVE 1289 CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, 1290 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1291 & POSITION, COMM, IERR ) 1292 ENDDO 1293 DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET 1294 I = PERM(J) 1295 INDICE_PERE=MAPROW(I) 1296 CALL MUMPS_BLOC2_GET_ISLAVE( 1297 & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, 1298 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 1299 & 1300 & NASS_PERE, 1301 & NFRONT_PERE - NASS_PERE, 1302 & NSLAVES_PERE, 1303 & INDICE_PERE, 1304 & NOSLA, 1305 & IPOS_IN_SLAVE ) 1306 IF (KEEP(50).ne.0) THEN 1307 THIS_ROW_LENGTH = LROW + I - LMAP 1308 CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, 1309 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1310 & POSITION, COMM, IERR ) 1311 ELSE 1312 THIS_ROW_LENGTH = LROW 1313 ENDIF 1314 IF (DESC_IN_LU) THEN 1315 IF ( COMPRESSCB ) THEN 1316 IF (NELIM.EQ.0) THEN 1317 ITMP8 = int(I,8) 1318 ELSE 1319 ITMP8 = int(NELIM+I,8) 1320 ENDIF 1321 APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 1322 ELSE 1323 APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 1324 ENDIF 1325 ELSE 1326 IF ( COMPRESSCB ) THEN 1327 IF ( LROW .EQ. NROW ) THEN 1328 ITMP8 = int(I,8) 1329 APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 1330 ELSE 1331 ITMP8 = int(I + LROW - NROW,8) 1332 APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - 1333 & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 1334 ENDIF 1335 ELSE 1336 APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 1337 ENDIF 1338 ENDIF 1339 CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, 1340 & MPI_REAL, 1341 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1342 & POSITION, COMM, IERR ) 1343 ENDDO 1344 IF (NBROWS_ALREADY_SENT == 0) THEN 1345 IF (COMPUTE_MAX) THEN 1346 CALL MPI_PACK(NFS4FATHER,1, 1347 & MPI_INTEGER, 1348 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1349 & POSITION, COMM, IERR ) 1350 IF(NFS4FATHER .GT. 0) THEN 1351 BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO 1352 IF(MAPROW(NROW) .GT. NASS_PERE) THEN 1353 DO PS1=1,NROW 1354 IF(MAPROW(PS1).GT.NASS_PERE) EXIT 1355 ENDDO 1356 IF (DESC_IN_LU) THEN 1357 IF (COMPRESSCB) THEN 1358 APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / 1359 & 2_8 + 1_8 1360 NCA = -44444 1361 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - 1362 & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 1363 LROW1 = PS1 + NELIM 1364 ELSE 1365 APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 1366 NCA = LROW 1367 ASIZE = int(NCA,8) * int(NROW-PS1+1,8) 1368 LROW1 = LROW 1369 ENDIF 1370 ELSE 1371 IF (COMPRESSCB) THEN 1372 IF (NPIV.NE.0) THEN 1373 WRITE(*,*) "Error in PARPIV/SMUMPS_BUF_SEND_CONTRIB_TYPE2" 1374 CALL MUMPS_ABORT() 1375 ENDIF 1376 LROW1=LROW-NROW+PS1 1377 ITMP8 = int(PS1 + LROW - NROW,8) 1378 APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - 1379 & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 1380 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - 1381 & ITMP8*(ITMP8-1_8)/2_8 1382 NCA = -555555 1383 ELSE 1384 APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON 1385 NCA = int(LDA_SON8) 1386 ASIZE = SIZFR - (SHIFTCB_SON - 1387 & int(PS1-1,8) * LDA_SON8) 1388 LROW1=-666666 1389 ENDIF 1390 ENDIF 1391 IF ( NROW-PS1+1-KEEP253_LOC .NE. 0 ) THEN 1392 CALL SMUMPS_COMPUTE_MAXPERCOL( 1393 & A_CBSON(APOS),ASIZE,NCA, 1394 & NROW-PS1+1-KEEP253_LOC, 1395 & BUF_MAX_ARRAY,NFS4FATHER,COMPRESSCB,LROW1) 1396 ENDIF 1397 ENDIF 1398 CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, 1399 & MPI_REAL, 1400 & BUF_CB%CONTENT( IPOS ), SIZE_PACK, 1401 & POSITION, COMM, IERR ) 1402 ENDIF 1403 ENDIF 1404 ENDIF 1405 KEEP(266)=KEEP(266)+1 1406 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, 1407 & PDEST, CONTRIB_TYPE2, COMM, 1408 & BUF_CB%CONTENT( IREQ ), IERR ) 1409 IF ( SIZE_PACK.LT. POSITION ) THEN 1410 WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION 1411 WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW 1412 CALL MUMPS_ABORT() 1413 END IF 1414 IF ( SIZE_PACK .NE. POSITION ) 1415 & CALL BUF_ADJUST( BUF_CB, POSITION ) 1416 NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET 1417 IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN 1418 IERR = -1 1419 ENDIF 1420 100 CONTINUE 1421 RETURN 1422 END SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE2 1423 SUBROUTINE SMUMPS_BUF_SEND_MAPLIG( 1424 & INODE, NFRONT, NASS1, NFS4FATHER, 1425 & ISON, MYID, NSLAVES, SLAVES_PERE, 1426 & TROW, NCBSON, 1427 & COMM, IERR, 1428 & DEST, NDEST, SLAVEF, 1429 & 1430 & KEEP,KEEP8, STEP, N, 1431 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 1432 & 1433 & ) 1434 IMPLICIT NONE 1435 INTEGER INODE, NFRONT, NASS1, NCBSON, NSLAVES, 1436 & NDEST 1437 INTEGER SLAVEF, MYID, ISON 1438 INTEGER TROW( NCBSON ) 1439 INTEGER DEST( NDEST ) 1440 INTEGER SLAVES_PERE( NSLAVES ) 1441 INTEGER COMM, IERR 1442 INTEGER KEEP(500), N 1443 INTEGER(8) KEEP8(150) 1444 INTEGER STEP(N), 1445 & ISTEP_TO_INIV2(KEEP(71)), 1446 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 1447 INCLUDE 'mpif.h' 1448 INCLUDE 'mumps_tags.h' 1449 INTEGER SIZE_AV, IDEST, NSEND, SIZE, NFS4FATHER 1450 INTEGER TROW_SIZE, POSITION, INDX, INIV2 1451 INTEGER IPOS, IREQ 1452 INTEGER IONE 1453 PARAMETER ( IONE=1 ) 1454 INTEGER NASS_SON 1455 NASS_SON = -99998 1456 IERR = 0 1457 IF ( NDEST .eq. 1 ) THEN 1458 IF ( DEST(1).EQ.MYID ) GOTO 500 1459 SIZE = SIZEofINT * ( 7 + NSLAVES + NCBSON ) 1460 IF ( NSLAVES.GT.0 ) THEN 1461 SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) 1462 ENDIF 1463 IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN 1464 IERR = -3 1465 RETURN 1466 END IF 1467 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, 1468 & IONE, DEST 1469 & ) 1470 IF (IERR .LT. 0 ) THEN 1471 RETURN 1472 ENDIF 1473 POSITION = IPOS 1474 BUF_CB%CONTENT( POSITION ) = INODE 1475 POSITION = POSITION + 1 1476 BUF_CB%CONTENT( POSITION ) = ISON 1477 POSITION = POSITION + 1 1478 BUF_CB%CONTENT( POSITION ) = NSLAVES 1479 POSITION = POSITION + 1 1480 BUF_CB%CONTENT( POSITION ) = NFRONT 1481 POSITION = POSITION + 1 1482 BUF_CB%CONTENT( POSITION ) = NASS1 1483 POSITION = POSITION + 1 1484 BUF_CB%CONTENT( POSITION ) = NCBSON 1485 POSITION = POSITION + 1 1486 BUF_CB%CONTENT( POSITION ) = NFS4FATHER 1487 POSITION = POSITION + 1 1488 IF ( NSLAVES.GT.0 ) THEN 1489 INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) 1490 BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) 1491 & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) 1492 POSITION = POSITION + NSLAVES + 1 1493 ENDIF 1494 IF ( NSLAVES .NE. 0 ) THEN 1495 BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) 1496 & = SLAVES_PERE( 1: NSLAVES ) 1497 POSITION = POSITION + NSLAVES 1498 END IF 1499 BUF_CB%CONTENT( POSITION:POSITION+NCBSON-1 ) = 1500 & TROW( 1: NCBSON ) 1501 POSITION = POSITION + NCBSON 1502 POSITION = POSITION - IPOS 1503 IF ( POSITION * SIZEofINT .NE. SIZE ) THEN 1504 WRITE(*,*) 'Error in SMUMPS_BUF_SEND_MAPLIG :', 1505 & ' wrong estimated size' 1506 CALL MUMPS_ABORT() 1507 END IF 1508 KEEP(266)=KEEP(266)+1 1509 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, 1510 & MPI_PACKED, 1511 & DEST( NDEST ), MAPLIG, COMM, 1512 & BUF_CB%CONTENT( IREQ ), 1513 & IERR ) 1514 ELSE 1515 NSEND = 0 1516 DO IDEST = 1, NDEST 1517 IF ( DEST( IDEST ) .ne. MYID ) NSEND = NSEND + 1 1518 END DO 1519 SIZE = SIZEofINT * 1520 & ( ( OVHSIZE + 7 + NSLAVES )* NSEND + NCBSON ) 1521 IF ( NSLAVES.GT.0 ) THEN 1522 SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) 1523 ENDIF 1524 CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) 1525 IF ( SIZE_AV .LT. SIZE ) THEN 1526 IERR = -1 1527 RETURN 1528 END IF 1529 DO IDEST= 1, NDEST 1530 CALL MUMPS_BLOC2_GET_SLAVE_INFO( 1531 & KEEP,KEEP8, ISON, STEP, N, SLAVEF, 1532 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 1533 & IDEST, NCBSON, 1534 & NDEST, 1535 & TROW_SIZE, INDX ) 1536 SIZE = SIZEofINT * ( NSLAVES + TROW_SIZE + 7 ) 1537 IF ( NSLAVES.GT.0 ) THEN 1538 SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) 1539 ENDIF 1540 IF ( MYID .NE. DEST( IDEST ) ) THEN 1541 IF (SIZE.GT.SIZE_RBUF_BYTES) THEN 1542 IERR = -3 1543 RETURN 1544 ENDIF 1545 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, 1546 & IONE, DEST(IDEST) ) 1547 IF ( IERR .LT. 0 ) THEN 1548 WRITE(*,*) 'Internal error SMUMPS_BUF_SEND_MAPLIG', 1549 & 'IERR after BUF_LOOK=',IERR 1550 CALL MUMPS_ABORT() 1551 END IF 1552 POSITION = IPOS 1553 BUF_CB%CONTENT( POSITION ) = INODE 1554 POSITION = POSITION + 1 1555 BUF_CB%CONTENT( POSITION ) = ISON 1556 POSITION = POSITION + 1 1557 BUF_CB%CONTENT( POSITION ) = NSLAVES 1558 POSITION = POSITION + 1 1559 BUF_CB%CONTENT( POSITION ) = NFRONT 1560 POSITION = POSITION + 1 1561 BUF_CB%CONTENT( POSITION ) = NASS1 1562 POSITION = POSITION + 1 1563 BUF_CB%CONTENT( POSITION ) = TROW_SIZE 1564 POSITION = POSITION + 1 1565 BUF_CB%CONTENT( POSITION ) = NFS4FATHER 1566 POSITION = POSITION + 1 1567 IF ( NSLAVES.GT.0 ) THEN 1568 INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) 1569 BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) 1570 & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) 1571 POSITION = POSITION + NSLAVES + 1 1572 ENDIF 1573 IF ( NSLAVES .NE. 0 ) THEN 1574 BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) 1575 & = SLAVES_PERE( 1: NSLAVES ) 1576 POSITION = POSITION + NSLAVES 1577 END IF 1578 BUF_CB%CONTENT( POSITION:POSITION+TROW_SIZE-1 ) = 1579 & TROW( INDX: INDX + TROW_SIZE - 1 ) 1580 POSITION = POSITION + TROW_SIZE 1581 POSITION = POSITION - IPOS 1582 IF ( POSITION * SIZEofINT .NE. SIZE ) THEN 1583 WRITE(*,*) ' ERROR 1 in TRY_SEND_MAPLIG:', 1584 & 'Wrong estimated size' 1585 CALL MUMPS_ABORT() 1586 END IF 1587 KEEP(266)=KEEP(266)+1 1588 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, 1589 & MPI_PACKED, 1590 & DEST( IDEST ), MAPLIG, COMM, 1591 & BUF_CB%CONTENT( IREQ ), 1592 & IERR ) 1593 END IF 1594 END DO 1595 END IF 1596 500 CONTINUE 1597 RETURN 1598 END SUBROUTINE SMUMPS_BUF_SEND_MAPLIG 1599 SUBROUTINE SMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, 1600 & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, 1601 & PDEST, NDEST, KEEP, NB_BLOC_FAC, 1602 & NSLAVES_TOT, 1603 & WIDTH, COMM, 1604 & NELIM, NPARTSASS, CURRENT_BLR_PANEL, 1605 & SEND_LR, BLR_LorU, 1606 & 1607 & IERR ) 1608 USE SMUMPS_LR_TYPE 1609 IMPLICIT NONE 1610 INTEGER, intent(in) :: INODE, NCOL, NPIV, 1611 & FPERE, NFRONT, NDEST 1612 INTEGER, intent(in) :: IPIV( NPIV ) 1613 REAL, intent(in) :: VAL( NFRONT, * ) 1614 INTEGER, intent(in) :: PDEST( NDEST ) 1615 INTEGER, intent(inout) :: KEEP(500) 1616 INTEGER, intent(in) :: NB_BLOC_FAC, 1617 & NSLAVES_TOT, COMM, WIDTH 1618 LOGICAL, intent(in) :: LASTBL 1619 LOGICAL, intent(in) :: SEND_LR 1620 INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL 1621 TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU 1622 INTEGER :: SEND_LR_INT 1623 INTEGER, intent(inout) :: IERR 1624 INCLUDE 'mpif.h' 1625 INCLUDE 'mumps_tags.h' 1626 INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE3, SIZET, 1627 & IDEST, IPOSMSG, I 1628 INTEGER NPIVSENT 1629 INTEGER SSS 1630 INTEGER :: NBMSGS 1631 INTEGER, ALLOCATABLE, DIMENSION(:) :: RELAY_INFO 1632 INTEGER :: LRELAY_INFO, DEST_BLOCFACTO, TAG_BLOCFACTO 1633 IERR = 0 1634 LRELAY_INFO = 0 1635 NBMSGS = NDEST 1636 IF ( LASTBL ) THEN 1637 IF ( KEEP(50) .eq. 0 ) THEN 1638 CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + 1639 & 1+LRELAY_INFO, 1640 & MPI_INTEGER, COMM, SIZE1, IERR ) 1641 ELSE 1642 CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + 1643 & 1+LRELAY_INFO, 1644 & MPI_INTEGER, COMM, SIZE1, IERR ) 1645 END IF 1646 ELSE 1647 IF ( KEEP(50) .eq. 0 ) THEN 1648 CALL MPI_PACK_SIZE( 3 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + 1649 & 1+LRELAY_INFO, 1650 & MPI_INTEGER, COMM, SIZE1, IERR ) 1651 ELSE 1652 CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + 1653 & 1+LRELAY_INFO, 1654 & MPI_INTEGER, COMM, SIZE1, IERR ) 1655 END IF 1656 END IF 1657 SIZE2 = 0 1658 CALL MPI_PACK_SIZE(4, MPI_INTEGER, COMM, SIZE3, IERR) 1659 SIZE2=SIZE2+SIZE3 1660 IF ( KEEP(50).NE.0 ) THEN 1661 CALL MPI_PACK_SIZE(1, MPI_INTEGER, COMM, SIZE3, IERR) 1662 SIZE2=SIZE2+SIZE3 1663 ENDIF 1664 IF ((NPIV.GT.0) 1665 & ) THEN 1666 IF (.NOT. SEND_LR) THEN 1667 CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_REAL, 1668 & COMM, SIZE3, IERR ) 1669 SIZE2 = SIZE2+SIZE3 1670 ELSE 1671 CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_REAL, 1672 & COMM, SIZE3, IERR ) 1673 SIZE2 = SIZE2+SIZE3 1674 CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LorU, SIZE3, COMM, IERR ) 1675 SIZE2 = SIZE2+SIZE3 1676 ENDIF 1677 ENDIF 1678 SIZET = SIZE1 + SIZE2 1679 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN 1680 SSS = 0 1681 IF ( LASTBL ) THEN 1682 IF ( KEEP(50) .eq. 0 ) THEN 1683 CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, 1684 & MPI_INTEGER, COMM, SSS, IERR ) 1685 ELSE 1686 CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, 1687 & MPI_INTEGER, COMM, SSS, IERR ) 1688 END IF 1689 ELSE 1690 IF ( KEEP(50) .eq. 0 ) THEN 1691 CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, 1692 & MPI_INTEGER, COMM, SSS, IERR ) 1693 ELSE 1694 CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, 1695 & MPI_INTEGER, COMM, SSS, IERR ) 1696 END IF 1697 END IF 1698 SSS = SSS + SIZE2 1699 IF (SSS.GT.SIZE_RBUF_BYTES) THEN 1700 IERR = -3 1701 RETURN 1702 ENDIF 1703 ENDIF 1704 IF (LRELAY_INFO.GT.0) THEN 1705 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, 1706 & NBMSGS , RELAY_INFO(2) 1707 & ) 1708 ELSE 1709 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, 1710 & NBMSGS , PDEST 1711 & ) 1712 ENDIF 1713 IF ( IERR .LT. 0 ) THEN 1714 RETURN 1715 ENDIF 1716 BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NBMSGS - 1 ) * OVHSIZE 1717 IPOS = IPOS - OVHSIZE 1718 DO IDEST = 1, NBMSGS - 1 1719 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = 1720 & IPOS + IDEST * OVHSIZE 1721 END DO 1722 BUF_CB%CONTENT( IPOS + ( NBMSGS - 1 ) * OVHSIZE ) = 0 1723 IPOSMSG = IPOS + OVHSIZE * NBMSGS 1724 POSITION = 0 1725 CALL MPI_PACK( INODE, 1, MPI_INTEGER, 1726 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1727 & POSITION, COMM, IERR ) 1728 NPIVSENT = NPIV 1729 IF (LASTBL) NPIVSENT = -NPIV 1730 CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, 1731 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1732 & POSITION, COMM, IERR ) 1733 IF ( LASTBL .or. KEEP(50).ne.0 ) THEN 1734 CALL MPI_PACK( FPERE, 1, MPI_INTEGER, 1735 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1736 & POSITION, COMM, IERR ) 1737 END IF 1738 IF ( LASTBL .AND. KEEP(50) .NE. 0 ) THEN 1739 CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, 1740 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1741 & POSITION, COMM, IERR ) 1742 CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, 1743 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1744 & POSITION, COMM, IERR ) 1745 END IF 1746 CALL MPI_PACK( NCOL, 1, MPI_INTEGER, 1747 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1748 & POSITION, COMM, IERR ) 1749 IF (SEND_LR) THEN 1750 SEND_LR_INT=1 1751 ELSE 1752 SEND_LR_INT=0 1753 ENDIF 1754 CALL MPI_PACK( NELIM, 1, MPI_INTEGER, 1755 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1756 & POSITION, COMM, IERR ) 1757 CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, 1758 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1759 & POSITION, COMM, IERR ) 1760 CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, 1761 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1762 & POSITION, COMM, IERR ) 1763 CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, 1764 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1765 & POSITION, COMM, IERR ) 1766 IF ( KEEP(50) .ne. 0 ) THEN 1767 CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, 1768 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1769 & POSITION, COMM, IERR ) 1770 ENDIF 1771 IF ( (NPIV.GT.0) 1772 & ) THEN 1773 IF (NPIV.GT.0) THEN 1774 CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, 1775 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1776 & POSITION, COMM, IERR ) 1777 ENDIF 1778 IF (SEND_LR) THEN 1779 DO I = 1, NPIV 1780 CALL MPI_PACK( VAL(1,I), NPIV+NELIM, 1781 & MPI_REAL, 1782 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1783 & POSITION, COMM, IERR ) 1784 END DO 1785 CALL MUMPS_MPI_PACK_LR( BLR_LorU, 1786 & BUF_CB%CONTENT(IPOSMSG: 1787 & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1), 1788 & SIZET, POSITION, COMM, IERR) 1789 ELSE 1790 DO I = 1, NPIV 1791 CALL MPI_PACK( VAL(1,I), NCOL, 1792 & MPI_REAL, 1793 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1794 & POSITION, COMM, IERR ) 1795 END DO 1796 ENDIF 1797 ENDIF 1798 CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, 1799 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1800 & POSITION, COMM, IERR ) 1801 IF ( LRELAY_INFO.GT.0) 1802 & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, 1803 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1804 & POSITION, COMM, IERR ) 1805 DO IDEST = 1, NBMSGS 1806 IF (LRELAY_INFO .GT. 0) THEN 1807 DEST_BLOCFACTO = RELAY_INFO(IDEST+1) 1808 ELSE 1809 DEST_BLOCFACTO = PDEST(IDEST) 1810 ENDIF 1811 IF ( KEEP(50) .EQ. 0) THEN 1812 TAG_BLOCFACTO = BLOC_FACTO 1813 KEEP(266)=KEEP(266)+1 1814 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, 1815 & MPI_PACKED, 1816 & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, 1817 & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), 1818 & IERR ) 1819 ELSE 1820 KEEP(266)=KEEP(266)+1 1821 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, 1822 & MPI_PACKED, 1823 & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, 1824 & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), 1825 & IERR ) 1826 END IF 1827 END DO 1828 SIZET = SIZET - ( NBMSGS - 1 ) * OVHSIZE * SIZEofINT 1829 IF ( SIZET .LT. POSITION ) THEN 1830 WRITE(*,*) ' Error sending blocfacto : size < position' 1831 WRITE(*,*) ' Size,position=',SIZET,POSITION 1832 CALL MUMPS_ABORT() 1833 END IF 1834 IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) 1835 RETURN 1836 END SUBROUTINE SMUMPS_BUF_SEND_BLOCFACTO 1837 SUBROUTINE SMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, 1838 & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, 1839 & NDEST, PDEST, COMM, KEEP, 1840 & SEND_LR, BLR_LS, IPANEL, 1841 & A , LA, POSBLOCFACTO, LD_BLOCFACTO, 1842 & IPIV, MAXI_CLUSTER, 1843 & IERR ) 1844 USE SMUMPS_LR_TYPE 1845 IMPLICIT NONE 1846 INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE 1847 REAL UIP21K( NPIV, * ) 1848 INTEGER PDEST( NDEST ) 1849 INTEGER COMM, IERR 1850 INTEGER, INTENT(INOUT) :: KEEP(500) 1851 LOGICAL, intent(in) :: SEND_LR 1852 TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS 1853 INTEGER(8), intent(in) :: LA, POSBLOCFACTO 1854 INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), 1855 & MAXI_CLUSTER, IPANEL 1856 REAL, intent(inout) :: A(LA) 1857 INTEGER :: SEND_LR_INT 1858 INCLUDE 'mpif.h' 1859 INCLUDE 'mumps_tags.h' 1860 INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZET, 1861 & IDEST, IPOSMSG, SSS, SSLR 1862 IERR = 0 1863 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, 1864 & MPI_INTEGER, COMM, SIZE1, IERR ) 1865 SIZE2 = 0 1866 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR) 1867 SIZE2=SIZE2+SSLR 1868 IF (.NOT. SEND_LR) THEN 1869 CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_REAL, 1870 & COMM, SSLR, IERR ) 1871 SIZE2=SIZE2+SSLR 1872 ELSE 1873 CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LS, SSLR, COMM, IERR ) 1874 SIZE2=SIZE2+SSLR 1875 ENDIF 1876 SIZET = SIZE1 + SIZE2 1877 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN 1878 CALL MPI_PACK_SIZE( 6 , 1879 & MPI_INTEGER, COMM, SSS, IERR ) 1880 SSS = SSS+SIZE2 1881 IF (SSS.GT.SIZE_RBUF_BYTES) THEN 1882 IERR = -2 1883 RETURN 1884 ENDIF 1885 END IF 1886 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, 1887 & NDEST, PDEST 1888 & ) 1889 IF ( IERR .LT. 0 ) THEN 1890 RETURN 1891 ENDIF 1892 BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE 1893 IPOS = IPOS - OVHSIZE 1894 DO IDEST = 1, NDEST - 1 1895 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = 1896 & IPOS + IDEST * OVHSIZE 1897 END DO 1898 BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 1899 IPOSMSG = IPOS + OVHSIZE * NDEST 1900 POSITION = 0 1901 CALL MPI_PACK( INODE, 1, MPI_INTEGER, 1902 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1903 & POSITION, COMM, IERR ) 1904 CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, 1905 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1906 & POSITION, COMM, IERR ) 1907 CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, 1908 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1909 & POSITION, COMM, IERR ) 1910 CALL MPI_PACK( NPIV, 1, MPI_INTEGER, 1911 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1912 & POSITION, COMM, IERR ) 1913 CALL MPI_PACK( FPERE, 1, MPI_INTEGER, 1914 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1915 & POSITION, COMM, IERR ) 1916 CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, 1917 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1918 & POSITION, COMM, IERR ) 1919 IF (SEND_LR) THEN 1920 SEND_LR_INT=1 1921 ELSE 1922 SEND_LR_INT=0 1923 ENDIF 1924 CALL MPI_PACK( SEND_LR_INT, 1, MPI_INTEGER, 1925 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1926 & POSITION, COMM, IERR ) 1927 CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, 1928 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1929 & POSITION, COMM, IERR ) 1930 IF (SEND_LR) THEN 1931 CALL MUMPS_MPI_PACK_SCALE_LR( BLR_LS, 1932 & BUF_CB%CONTENT( IPOSMSG: 1933 & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1 ), 1934 & SIZET, POSITION, COMM, 1935 & A, LA, POSBLOCFACTO, LD_BLOCFACTO, 1936 & IPIV, NPIV, MAXI_CLUSTER, 1937 & IERR) 1938 ELSE 1939 CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, 1940 & MPI_REAL, 1941 & BUF_CB%CONTENT( IPOSMSG ), SIZET, 1942 & POSITION, COMM, IERR ) 1943 ENDIF 1944 DO IDEST = 1, NDEST 1945 KEEP(266)=KEEP(266)+1 1946 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, 1947 & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, 1948 & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), 1949 & IERR ) 1950 END DO 1951 SIZET = SIZET - ( NDEST - 1 ) * OVHSIZE * SIZEofINT 1952 IF ( SIZET .LT. POSITION ) THEN 1953 WRITE(*,*) ' Error sending blfac slave : size < position' 1954 WRITE(*,*) ' Size,position=',SIZET,POSITION 1955 CALL MUMPS_ABORT() 1956 END IF 1957 IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) 1958 RETURN 1959 END SUBROUTINE SMUMPS_BUF_SEND_BLFAC_SLAVE 1960 SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, 1961 & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, 1962 & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, 1963 & NSUBSET_ROW, NSUBSET_COL, 1964 & NSUPROW, NSUPCOL, 1965 & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, 1966 & NBLOCK, PDEST, COMM, IERR , 1967 & TAB, TABSIZE, TRANSP, SIZE_PACK, 1968 & N_ALREADY_SENT, KEEP, BBPCBP ) 1969 IMPLICIT NONE 1970 INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL 1971 INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON 1972 INTEGER BBPCBP 1973 INTEGER PDEST, TAG, COMM, IERR 1974 INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) 1975 INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) 1976 INTEGER, DIMENSION(:) :: RG2L_ROW 1977 INTEGER, DIMENSION(:) :: RG2L_COL 1978 INTEGER NSUPROW, NSUPCOL 1979 INTEGER(8), INTENT(IN) :: TABSIZE 1980 INTEGER SIZE_PACK 1981 INTEGER KEEP(500) 1982 REAL VAL_SON( LD_SON, * ), TAB(*) 1983 LOGICAL TRANSP 1984 INTEGER N_ALREADY_SENT 1985 INCLUDE 'mpif.h' 1986 INTEGER SIZE1, SIZE2, SIZE_AV, POSITION 1987 INTEGER SIZE_CBP, SIZE_TMP 1988 INTEGER IREQ, IPOS, ITAB 1989 INTEGER ISUB, JSUB, I, J 1990 INTEGER ILOC_ROOT, JLOC_ROOT 1991 INTEGER IPOS_ROOT, JPOS_ROOT 1992 INTEGER IONE 1993 LOGICAL RECV_BUF_SMALLER_THAN_SEND 1994 INTEGER PDEST2(1) 1995 PARAMETER ( IONE=1 ) 1996 INTEGER N_PACKET 1997 INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF 1998 PDEST2(1) = PDEST 1999 IERR = 0 2000 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN 2001 CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) 2002 IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN 2003 RECV_BUF_SMALLER_THAN_SEND = .FALSE. 2004 ELSE 2005 RECV_BUF_SMALLER_THAN_SEND = .TRUE. 2006 SIZE_AV = SIZE_RBUF_BYTES 2007 ENDIF 2008 SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) 2009 CALL MPI_PACK_SIZE(8 + NSUBSET_COL, 2010 & MPI_INTEGER, COMM, SIZE1, IERR ) 2011 SIZE_CBP = 0 2012 IF (N_ALREADY_SENT .EQ. 0 .AND. 2013 & min(NSUPROW,NSUPCOL) .GT.0) THEN 2014 CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, 2015 & SIZE_CBP, IERR) 2016 CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, 2017 & SIZE_TMP, IERR) 2018 SIZE_CBP = SIZE_CBP + SIZE_TMP 2019 CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, 2020 & MPI_REAL, COMM, 2021 & SIZE_TMP, IERR) 2022 SIZE_CBP = SIZE_CBP + SIZE_TMP 2023 SIZE1 = SIZE1 + SIZE_CBP 2024 ENDIF 2025 IF (BBPCBP.EQ.1) THEN 2026 NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL 2027 NSUPCOL_EFF = 0 2028 ELSE 2029 NSUBSET_COL_EFF = NSUBSET_COL 2030 NSUPCOL_EFF = NSUPCOL 2031 ENDIF 2032 NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW 2033 N_PACKET = 2034 & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 2035 10 CONTINUE 2036 N_PACKET = min( N_PACKET, 2037 & NSUBSET_ROW_EFF-N_ALREADY_SENT ) 2038 IF (N_PACKET .LE. 0 .AND. 2039 & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN 2040 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 2041 IERR=-3 2042 GOTO 100 2043 ELSE 2044 IERR = -1 2045 GOTO 100 2046 ENDIF 2047 ENDIF 2048 CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, 2049 & MPI_INTEGER, COMM, SIZE1, IERR ) 2050 SIZE1 = SIZE1 + SIZE_CBP 2051 CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, 2052 & MPI_REAL, 2053 & COMM, SIZE2, IERR ) 2054 SIZE_PACK = SIZE1 + SIZE2 2055 IF (SIZE_PACK .GT. SIZE_AV) THEN 2056 N_PACKET = N_PACKET - 1 2057 IF ( N_PACKET > 0 ) THEN 2058 GOTO 10 2059 ELSE 2060 IF (RECV_BUF_SMALLER_THAN_SEND) THEN 2061 IERR = -3 2062 GOTO 100 2063 ELSE 2064 IERR = -1 2065 GOTO 100 2066 ENDIF 2067 ENDIF 2068 ENDIF 2069#if ! defined(DBG_SMB3) 2070 IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW 2071 & .AND. 2072 & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 2073 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) 2074 & THEN 2075 IERR = -1 2076 GOTO 100 2077 ENDIF 2078#endif 2079 ELSE 2080 N_PACKET = 0 2081 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR ) 2082 END IF 2083 IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN 2084 IERR = -3 2085 GOTO 100 2086 ENDIF 2087 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, 2088 & IONE, PDEST2 2089 & ) 2090 IF ( IERR .LT. 0 ) GOTO 100 2091 POSITION = 0 2092 CALL MPI_PACK( ISON, 1, MPI_INTEGER, 2093 & BUF_CB%CONTENT( IPOS ), 2094 & SIZE_PACK, POSITION, COMM, IERR ) 2095 CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, 2096 & BUF_CB%CONTENT( IPOS ), 2097 & SIZE_PACK, POSITION, COMM, IERR ) 2098 CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, 2099 & BUF_CB%CONTENT( IPOS ), 2100 & SIZE_PACK, POSITION, COMM, IERR ) 2101 CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, 2102 & BUF_CB%CONTENT( IPOS ), 2103 & SIZE_PACK, POSITION, COMM, IERR ) 2104 CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, 2105 & BUF_CB%CONTENT( IPOS ), 2106 & SIZE_PACK, POSITION, COMM, IERR ) 2107 CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, 2108 & BUF_CB%CONTENT( IPOS ), 2109 & SIZE_PACK, POSITION, COMM, IERR ) 2110 CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, 2111 & BUF_CB%CONTENT( IPOS ), 2112 & SIZE_PACK, POSITION, COMM, IERR ) 2113 CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, 2114 & BUF_CB%CONTENT( IPOS ), 2115 & SIZE_PACK, POSITION, COMM, IERR ) 2116 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN 2117 IF (N_ALREADY_SENT .EQ. 0 .AND. 2118 & min(NSUPROW, NSUPCOL) .GT. 0) THEN 2119 DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW 2120 I = SUBSET_ROW( ISUB ) 2121 IPOS_ROOT = RG2L_ROW(INDCOL_SON( I )) 2122 ILOC_ROOT = MBLOCK 2123 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 2124 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 2125 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, 2126 & BUF_CB%CONTENT( IPOS ), 2127 & SIZE_PACK, POSITION, COMM, IERR ) 2128 ENDDO 2129 DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL 2130 J = SUBSET_COL( ISUB ) 2131 JPOS_ROOT = INDROW_SON( J ) - N 2132 JLOC_ROOT = NBLOCK 2133 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 2134 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 2135 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, 2136 & BUF_CB%CONTENT( IPOS ), 2137 & SIZE_PACK, POSITION, COMM, IERR ) 2138 ENDDO 2139 IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN 2140 ITAB = 1 2141 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW 2142 J = SUBSET_ROW(JSUB) 2143 DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL 2144 I = SUBSET_COL(ISUB) 2145 TAB(ITAB) = VAL_SON(J, I) 2146 ITAB = ITAB + 1 2147 ENDDO 2148 ENDDO 2149 CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, 2150 & MPI_REAL, 2151 & BUF_CB%CONTENT( IPOS ), 2152 & SIZE_PACK, POSITION, COMM, IERR ) 2153 ELSE 2154 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW 2155 J = SUBSET_ROW(JSUB) 2156 DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL 2157 I = SUBSET_COL(ISUB) 2158 CALL MPI_PACK(VAL_SON(J,I), 1, 2159 & MPI_REAL, 2160 & BUF_CB%CONTENT( IPOS ), 2161 & SIZE_PACK, POSITION, COMM, IERR ) 2162 ENDDO 2163 ENDDO 2164 ENDIF 2165 ENDIF 2166 IF ( .NOT. TRANSP ) THEN 2167 DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET 2168 I = SUBSET_ROW( ISUB ) 2169 IPOS_ROOT = RG2L_ROW( INDROW_SON( I ) ) 2170 ILOC_ROOT = MBLOCK 2171 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 2172 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 2173 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, 2174 & BUF_CB%CONTENT( IPOS ), 2175 & SIZE_PACK, POSITION, COMM, IERR ) 2176 END DO 2177 DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF 2178 J = SUBSET_COL( JSUB ) 2179 JPOS_ROOT = RG2L_COL( INDCOL_SON( J ) ) 2180 JLOC_ROOT = NBLOCK 2181 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 2182 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 2183 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, 2184 & BUF_CB%CONTENT( IPOS ), 2185 & SIZE_PACK, POSITION, COMM, IERR ) 2186 END DO 2187 DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF 2188 J = SUBSET_COL( JSUB ) 2189 JPOS_ROOT = INDCOL_SON( J ) - N 2190 JLOC_ROOT = NBLOCK 2191 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 2192 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 2193 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, 2194 & BUF_CB%CONTENT( IPOS ), 2195 & SIZE_PACK, POSITION, COMM, IERR ) 2196 ENDDO 2197 ELSE 2198 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET 2199 J = SUBSET_ROW( JSUB ) 2200 IPOS_ROOT = RG2L_ROW( INDCOL_SON( J ) ) 2201 ILOC_ROOT = MBLOCK 2202 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 2203 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 2204 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, 2205 & BUF_CB%CONTENT( IPOS ), 2206 & SIZE_PACK, POSITION, COMM, IERR ) 2207 END DO 2208 DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF 2209 I = SUBSET_COL( ISUB ) 2210 JPOS_ROOT = RG2L_COL( INDROW_SON( I ) ) 2211 JLOC_ROOT = NBLOCK 2212 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 2213 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 2214 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, 2215 & BUF_CB%CONTENT( IPOS ), 2216 & SIZE_PACK, POSITION, COMM, IERR ) 2217 END DO 2218 DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF 2219 I = SUBSET_COL( ISUB ) 2220 JPOS_ROOT = INDROW_SON(I) - N 2221 JLOC_ROOT = NBLOCK 2222 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 2223 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 2224 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, 2225 & BUF_CB%CONTENT( IPOS ), 2226 & SIZE_PACK, POSITION, COMM, IERR ) 2227 ENDDO 2228 END IF 2229 IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN 2230 IF ( .NOT. TRANSP ) THEN 2231 ITAB = 1 2232 DO ISUB = N_ALREADY_SENT+1, 2233 & N_ALREADY_SENT+N_PACKET 2234 I = SUBSET_ROW( ISUB ) 2235 DO JSUB = 1, NSUBSET_COL_EFF 2236 J = SUBSET_COL( JSUB ) 2237 TAB( ITAB ) = VAL_SON(J,I) 2238 ITAB = ITAB + 1 2239 END DO 2240 END DO 2241 CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, 2242 & MPI_REAL, 2243 & BUF_CB%CONTENT( IPOS ), 2244 & SIZE_PACK, POSITION, COMM, IERR ) 2245 ELSE 2246 ITAB = 1 2247 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET 2248 J = SUBSET_ROW( JSUB ) 2249 DO ISUB = 1, NSUBSET_COL_EFF 2250 I = SUBSET_COL( ISUB ) 2251 TAB( ITAB ) = VAL_SON( J, I ) 2252 ITAB = ITAB + 1 2253 END DO 2254 END DO 2255 CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, 2256 & MPI_REAL, 2257 & BUF_CB%CONTENT( IPOS ), 2258 & SIZE_PACK, POSITION, COMM, IERR ) 2259 END IF 2260 ELSE 2261 IF ( .NOT. TRANSP ) THEN 2262 DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET 2263 I = SUBSET_ROW( ISUB ) 2264 DO JSUB = 1, NSUBSET_COL_EFF 2265 J = SUBSET_COL( JSUB ) 2266 CALL MPI_PACK( VAL_SON( J, I ), 1, 2267 & MPI_REAL, 2268 & BUF_CB%CONTENT( IPOS ), 2269 & SIZE_PACK, POSITION, COMM, IERR ) 2270 END DO 2271 END DO 2272 ELSE 2273 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET 2274 J = SUBSET_ROW( JSUB ) 2275 DO ISUB = 1, NSUBSET_COL_EFF 2276 I = SUBSET_COL( ISUB ) 2277 CALL MPI_PACK( VAL_SON( J, I ), 1, 2278 & MPI_REAL, 2279 & BUF_CB%CONTENT( IPOS ), 2280 & SIZE_PACK, POSITION, COMM, IERR ) 2281 END DO 2282 END DO 2283 END IF 2284 ENDIF 2285 END IF 2286 KEEP(266)=KEEP(266)+1 2287 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, 2288 & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), IERR ) 2289 IF ( SIZE_PACK .LT. POSITION ) THEN 2290 WRITE(*,*) ' Error sending contribution to root:Size<positn' 2291 WRITE(*,*) ' Size,position=',SIZE_PACK,POSITION 2292 CALL MUMPS_ABORT() 2293 END IF 2294 IF ( SIZE_PACK .NE. POSITION ) 2295 & CALL BUF_ADJUST( BUF_CB, POSITION ) 2296 N_ALREADY_SENT = N_ALREADY_SENT + N_PACKET 2297 IF (NSUBSET_ROW * NSUBSET_COL .NE. 0) THEN 2298 IF ( N_ALREADY_SENT.NE.NSUBSET_ROW_EFF ) IERR = -1 2299 ENDIF 2300 100 CONTINUE 2301 RETURN 2302 END SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3 2303 SUBROUTINE SMUMPS_BUF_SEND_RTNELIND( ISON, NELIM, 2304 & NELIM_ROW, NELIM_COL, NSLAVES, SLAVES, 2305 & DEST, COMM, KEEP, IERR ) 2306 INTEGER ISON, NELIM 2307 INTEGER NSLAVES, DEST, COMM, IERR 2308 INTEGER NELIM_ROW( NELIM ), NELIM_COL( NELIM ) 2309 INTEGER SLAVES( NSLAVES ) 2310 INTEGER, INTENT(INOUT) :: KEEP(500) 2311 INCLUDE 'mpif.h' 2312 INCLUDE 'mumps_tags.h' 2313 INTEGER SIZE, POSITION, IPOS, IREQ 2314 INTEGER IONE 2315 INTEGER DEST2(1) 2316 PARAMETER ( IONE=1 ) 2317 DEST2(1) = DEST 2318 IERR = 0 2319 SIZE = ( 3 + NSLAVES + 2 * NELIM ) * SIZEofINT 2320 IF (SIZE.GT.SIZE_RBUF_BYTES) THEN 2321 IERR = -3 2322 RETURN 2323 ENDIF 2324 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, 2325 & IONE, DEST2 2326 & ) 2327 IF ( IERR .LT. 0 ) THEN 2328 RETURN 2329 ENDIF 2330 POSITION = IPOS 2331 BUF_CB%CONTENT( POSITION ) = ISON 2332 POSITION = POSITION + 1 2333 BUF_CB%CONTENT( POSITION ) = NELIM 2334 POSITION = POSITION + 1 2335 BUF_CB%CONTENT( POSITION ) = NSLAVES 2336 POSITION = POSITION + 1 2337 BUF_CB%CONTENT( POSITION: POSITION + NELIM - 1 ) = NELIM_ROW 2338 POSITION = POSITION + NELIM 2339 BUF_CB%CONTENT( POSITION: POSITION + NELIM - 1 ) = NELIM_COL 2340 POSITION = POSITION + NELIM 2341 BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) = SLAVES 2342 POSITION = POSITION + NSLAVES 2343 POSITION = POSITION - IPOS 2344 IF ( POSITION * SIZEofINT .NE. SIZE ) THEN 2345 WRITE(*,*) 'Error in SMUMPS_BUF_SEND_ROOT_NELIM_INDICES:', 2346 & 'wrong estimated size' 2347 CALL MUMPS_ABORT() 2348 END IF 2349 KEEP(266)=KEEP(266)+1 2350 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, 2351 & MPI_PACKED, 2352 & DEST, ROOT_NELIM_INDICES, COMM, 2353 & BUF_CB%CONTENT( IREQ ), IERR ) 2354 RETURN 2355 END SUBROUTINE SMUMPS_BUF_SEND_RTNELIND 2356 SUBROUTINE SMUMPS_BUF_SEND_ROOT2SON( ISON, NELIM_ROOT, 2357 & DEST, COMM, KEEP, IERR ) 2358 IMPLICIT NONE 2359 INTEGER ISON, NELIM_ROOT, DEST, COMM, IERR 2360 INTEGER, INTENT(INOUT) :: KEEP(500) 2361 INCLUDE 'mpif.h' 2362 INCLUDE 'mumps_tags.h' 2363 INTEGER IPOS, IREQ, SIZE 2364 INTEGER IONE 2365 INTEGER DEST2(1) 2366 PARAMETER ( IONE=1 ) 2367 DEST2(1)=DEST 2368 IERR = 0 2369 SIZE = 2 * SIZEofINT 2370 CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, SIZE, IERR, 2371 & IONE, DEST2 2372 & ) 2373 IF ( IERR .LT. 0 ) THEN 2374 WRITE(*,*) 'Internal error 1 with small buffers ' 2375 CALL MUMPS_ABORT() 2376 END IF 2377 IF ( IERR .LT. 0 ) THEN 2378 RETURN 2379 ENDIF 2380 BUF_SMALL%CONTENT( IPOS ) = ISON 2381 BUF_SMALL%CONTENT( IPOS + 1 ) = NELIM_ROOT 2382 KEEP(266)=KEEP(266)+1 2383 CALL MPI_ISEND( BUF_SMALL%CONTENT( IPOS ), SIZE, 2384 & MPI_PACKED, 2385 & DEST, ROOT_2SON, COMM, 2386 & BUF_SMALL%CONTENT( IREQ ), IERR ) 2387 RETURN 2388 END SUBROUTINE SMUMPS_BUF_SEND_ROOT2SON 2389 SUBROUTINE SMUMPS_BUF_SEND_ROOT2SLAVE 2390 & ( TOT_ROOT_SIZE, TOT_CONT2RECV, DEST, COMM, KEEP, IERR ) 2391 IMPLICIT NONE 2392 INTEGER TOT_ROOT_SIZE, TOT_CONT2RECV, DEST, COMM, IERR 2393 INTEGER, INTENT(INOUT) :: KEEP(500) 2394 INCLUDE 'mpif.h' 2395 INCLUDE 'mumps_tags.h' 2396 INTEGER SIZE, IPOS, IREQ 2397 INTEGER IONE 2398 INTEGER DEST2(1) 2399 PARAMETER ( IONE=1 ) 2400 IERR = 0 2401 DEST2(1) = DEST 2402 SIZE = 2 * SIZEofINT 2403 CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, SIZE, IERR, 2404 & IONE, DEST2 2405 & ) 2406 IF ( IERR .LT. 0 ) THEN 2407 WRITE(*,*) 'Internal error 2 with small buffers ' 2408 CALL MUMPS_ABORT() 2409 END IF 2410 IF ( IERR .LT. 0 ) THEN 2411 RETURN 2412 ENDIF 2413 BUF_SMALL%CONTENT( IPOS ) = TOT_ROOT_SIZE 2414 BUF_SMALL%CONTENT( IPOS + 1 ) = TOT_CONT2RECV 2415 KEEP(266)=KEEP(266)+1 2416 CALL MPI_ISEND( BUF_SMALL%CONTENT( IPOS ), SIZE, 2417 & MPI_PACKED, 2418 & DEST, ROOT_2SLAVE, COMM, 2419 & BUF_SMALL%CONTENT( IREQ ), IERR ) 2420 RETURN 2421 END SUBROUTINE SMUMPS_BUF_SEND_ROOT2SLAVE 2422 SUBROUTINE SMUMPS_BUF_SEND_BACKVEC 2423 & ( NRHS, INODE, W, LW, LD_W, DEST, MSGTAG, 2424 & JBDEB, JBFIN, KEEP, COMM, IERR ) 2425 IMPLICIT NONE 2426 INTEGER NRHS, INODE,LW,COMM,IERR,DEST,MSGTAG, LD_W 2427 INTEGER, intent(in) :: JBDEB, JBFIN 2428 REAL :: W(LD_W, *) 2429 INTEGER, INTENT(INOUT) :: KEEP(500) 2430 INCLUDE 'mpif.h' 2431 INTEGER SIZE, SIZE1, SIZE2 2432 INTEGER POSITION, IREQ, IPOS 2433 INTEGER IONE, K 2434 INTEGER DEST2(1) 2435 PARAMETER ( IONE=1 ) 2436 IERR = 0 2437 DEST2(1) = DEST 2438 CALL MPI_PACK_SIZE( 4 , MPI_INTEGER, COMM, SIZE1, IERR ) 2439 CALL MPI_PACK_SIZE( LW*NRHS, MPI_REAL, COMM, 2440 & SIZE2, IERR ) 2441 SIZE = SIZE1 + SIZE2 2442 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, 2443 & IONE, DEST2 2444 & ) 2445 IF ( IERR .LT. 0 ) THEN 2446 RETURN 2447 ENDIF 2448 POSITION = 0 2449 CALL MPI_PACK( INODE, 1, MPI_INTEGER, 2450 & BUF_CB%CONTENT( IPOS ), SIZE, 2451 & POSITION, COMM, IERR ) 2452 CALL MPI_PACK( LW , 1, MPI_INTEGER, 2453 & BUF_CB%CONTENT( IPOS ), SIZE, 2454 & POSITION, COMM, IERR ) 2455 CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, 2456 & BUF_CB%CONTENT( IPOS ), SIZE, 2457 & POSITION, COMM, IERR ) 2458 CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, 2459 & BUF_CB%CONTENT( IPOS ), SIZE, 2460 & POSITION, COMM, IERR ) 2461 DO K=1, NRHS 2462 CALL MPI_PACK( W(1,K), LW, MPI_REAL, 2463 & BUF_CB%CONTENT( IPOS ), SIZE, 2464 & POSITION, COMM, IERR ) 2465 END DO 2466 KEEP(266)=KEEP(266)+1 2467 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, 2468 & DEST, MSGTAG, COMM, 2469 & BUF_CB%CONTENT( IREQ ), IERR ) 2470 IF ( SIZE .LT. POSITION ) THEN 2471 WRITE(*,*) 'Try_update: SIZE, POSITION = ', 2472 & SIZE, POSITION 2473 CALL MUMPS_ABORT() 2474 END IF 2475 IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) 2476 RETURN 2477 END SUBROUTINE SMUMPS_BUF_SEND_BACKVEC 2478 SUBROUTINE SMUMPS_BUF_SEND_UPDATE_LOAD 2479 & ( BDC_SBTR,BDC_MEM,BDC_MD, COMM, NPROCS, LOAD, 2480 & MEM,SBTR_CUR, 2481 & LU_USAGE, 2482#if ! defined(OLD_LOAD_MECHANISM) 2483 & FUTURE_NIV2, 2484#endif 2485 & MYID, KEEP, IERR) 2486 IMPLICIT NONE 2487 INTEGER COMM, NPROCS, MYID, IERR 2488 INTEGER, INTENT(INOUT) :: KEEP(500) 2489#if ! defined(OLD_LOAD_MECHANISM) 2490 INTEGER FUTURE_NIV2(NPROCS) 2491#endif 2492 DOUBLE PRECISION LU_USAGE 2493 DOUBLE PRECISION LOAD 2494 DOUBLE PRECISION MEM,SBTR_CUR 2495 LOGICAL BDC_MEM,BDC_SBTR,BDC_MD 2496 INCLUDE 'mpif.h' 2497 INCLUDE 'mumps_tags.h' 2498 INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE 2499 INTEGER I, NDEST, IDEST, IPOSMSG, WHAT, NREALS 2500 INTEGER IZERO 2501 INTEGER MYID2(1) 2502 PARAMETER ( IZERO=0 ) 2503 IERR = 0 2504 MYID2(1) = MYID 2505 NDEST = NPROCS - 1 2506#if ! defined(OLD_LOAD_MECHANISM) 2507 NDEST = 0 2508 DO I = 1, NPROCS 2509 IF ( I .NE. MYID + 1 .AND. FUTURE_NIV2(I).NE.0) THEN 2510 NDEST = NDEST + 1 2511 ENDIF 2512 ENDDO 2513#endif 2514 IF ( NDEST .eq. 0 ) THEN 2515 RETURN 2516 ENDIF 2517 CALL MPI_PACK_SIZE( 1 + (NDEST-1) * OVHSIZE, 2518 & MPI_INTEGER, COMM, 2519 & SIZE1, IERR ) 2520 NREALS = 1 2521 IF (BDC_MEM) THEN 2522 NREALS = 2 2523 ENDIf 2524 IF (BDC_SBTR)THEN 2525 NREALS = 3 2526 ENDIF 2527 IF(BDC_MD)THEN 2528 NREALS=NREALS+1 2529 ENDIF 2530 CALL MPI_PACK_SIZE( NREALS, MPI_DOUBLE_PRECISION, 2531 & COMM, SIZE2, IERR ) 2532 SIZE = SIZE1 + SIZE2 2533 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, 2534 & IZERO, MYID2 2535 & ) 2536 IF ( IERR .LT. 0 ) THEN 2537 RETURN 2538 ENDIF 2539 BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE 2540 IPOS = IPOS - OVHSIZE 2541 DO IDEST = 1, NDEST - 1 2542 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = 2543 & IPOS + IDEST * OVHSIZE 2544 END DO 2545 BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 2546 IPOSMSG = IPOS + OVHSIZE * NDEST 2547 WHAT = 0 2548 POSITION = 0 2549 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, 2550 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2551 & POSITION, COMM, IERR ) 2552 CALL MPI_PACK( LOAD, 1, MPI_DOUBLE_PRECISION, 2553 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2554 & POSITION, COMM, IERR ) 2555 IF (BDC_MEM) THEN 2556 CALL MPI_PACK( MEM, 1, MPI_DOUBLE_PRECISION, 2557 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2558 & POSITION, COMM, IERR ) 2559 END IF 2560 IF (BDC_SBTR) THEN 2561 CALL MPI_PACK( SBTR_CUR, 1, MPI_DOUBLE_PRECISION, 2562 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2563 & POSITION, COMM, IERR ) 2564 END IF 2565 IF(BDC_MD)THEN 2566 CALL MPI_PACK( LU_USAGE, 1, MPI_DOUBLE_PRECISION, 2567 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2568 & POSITION, COMM, IERR ) 2569 ENDIF 2570 IDEST = 0 2571 DO I = 0, NPROCS - 1 2572#if ! defined(OLD_LOAD_MECHANISM) 2573 IF ( I .NE. MYID .AND. FUTURE_NIV2(I+1) .NE. 0) THEN 2574#else 2575 IF ( I .ne. MYID ) THEN 2576#endif 2577 IDEST = IDEST + 1 2578 KEEP(267)=KEEP(267)+1 2579 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), 2580 & POSITION, MPI_PACKED, I, 2581 & UPDATE_LOAD, COMM, 2582 & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), 2583 & IERR ) 2584 END IF 2585 END DO 2586 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT 2587 IF ( SIZE .LT. POSITION ) THEN 2588 WRITE(*,*) ' Error in SMUMPS_BUF_SEND_UPDATE_LOAD' 2589 WRITE(*,*) ' Size,position=',SIZE,POSITION 2590 CALL MUMPS_ABORT() 2591 END IF 2592 IF ( SIZE .NE. POSITION ) 2593 & CALL BUF_ADJUST( BUF_LOAD, POSITION ) 2594 RETURN 2595 END SUBROUTINE SMUMPS_BUF_SEND_UPDATE_LOAD 2596 SUBROUTINE SMUMPS_BUF_BROADCAST 2597 & ( WHAT, COMM, NPROCS, 2598#if ! defined(OLD_LOAD_MECHANISM) 2599 & FUTURE_NIV2, 2600#endif 2601 & LOAD, UPD_LOAD, 2602 & MYID, KEEP, IERR) 2603 IMPLICIT NONE 2604 INTEGER COMM, NPROCS, MYID, IERR, WHAT 2605 DOUBLE PRECISION LOAD,UPD_LOAD 2606 INTEGER, INTENT(INOUT) :: KEEP(500) 2607 INCLUDE 'mpif.h' 2608 INCLUDE 'mumps_tags.h' 2609 INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE 2610 INTEGER I, NDEST, IDEST, IPOSMSG, NREALS 2611 INTEGER IZERO 2612 INTEGER MYID2(1) 2613#if ! defined(OLD_LOAD_MECHANISM) 2614 INTEGER FUTURE_NIV2(NPROCS) 2615#endif 2616 PARAMETER ( IZERO=0 ) 2617 IERR = 0 2618 IF (WHAT .NE. 2 .AND. WHAT .NE. 3 .AND. 2619 & WHAT.NE.6.AND. WHAT.NE.8 .AND.WHAT.NE.9.AND. 2620 & WHAT.NE.17) THEN 2621 WRITE(*,*) 2622 & "Internal error 1 in SMUMPS_BUF_BROADCAST",WHAT 2623 END IF 2624 MYID2(1) = MYID 2625 NDEST = NPROCS - 1 2626#if ! defined(OLD_LOAD_MECHANISM) 2627 NDEST = 0 2628 DO I = 1, NPROCS 2629 IF ( I .NE. MYID + 1 .AND. FUTURE_NIV2(I).NE.0) THEN 2630 NDEST = NDEST + 1 2631 ENDIF 2632 ENDDO 2633#endif 2634 IF ( NDEST .eq. 0 ) THEN 2635 RETURN 2636 ENDIF 2637 CALL MPI_PACK_SIZE( 1 + (NDEST-1) * OVHSIZE, 2638 & MPI_INTEGER, COMM, 2639 & SIZE1, IERR ) 2640 IF((WHAT.NE.17).AND.(WHAT.NE.10))THEN 2641 NREALS = 1 2642 ELSE 2643 NREALS = 2 2644 ENDIF 2645 CALL MPI_PACK_SIZE( NREALS, MPI_DOUBLE_PRECISION, 2646 & COMM, SIZE2, IERR ) 2647 SIZE = SIZE1 + SIZE2 2648 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, 2649 & IZERO, MYID2 2650 & ) 2651 IF ( IERR .LT. 0 ) THEN 2652 RETURN 2653 ENDIF 2654 BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE 2655 IPOS = IPOS - OVHSIZE 2656 DO IDEST = 1, NDEST - 1 2657 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = 2658 & IPOS + IDEST * OVHSIZE 2659 END DO 2660 BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 2661 IPOSMSG = IPOS + OVHSIZE * NDEST 2662 POSITION = 0 2663 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, 2664 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2665 & POSITION, COMM, IERR ) 2666 CALL MPI_PACK( LOAD, 1, MPI_DOUBLE_PRECISION, 2667 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2668 & POSITION, COMM, IERR ) 2669 IF((WHAT.EQ.17).OR.(WHAT.EQ.10))THEN 2670 CALL MPI_PACK( UPD_LOAD, 1, MPI_DOUBLE_PRECISION, 2671 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2672 & POSITION, COMM, IERR ) 2673 ENDIF 2674 IDEST = 0 2675 DO I = 0, NPROCS - 1 2676#if ! defined(OLD_LOAD_MECHANISM) 2677 IF ( I .NE. MYID .AND. FUTURE_NIV2(I+1) .NE. 0) THEN 2678#else 2679 IF ( I .ne. MYID ) THEN 2680#endif 2681 IDEST = IDEST + 1 2682 KEEP(267)=KEEP(267)+1 2683 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), 2684 & POSITION, MPI_PACKED, I, 2685 & UPDATE_LOAD, COMM, 2686 & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), 2687 & IERR ) 2688 END IF 2689 END DO 2690 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT 2691 IF ( SIZE .LT. POSITION ) THEN 2692 WRITE(*,*) ' Error in SMUMPS_BUF_BROADCAST' 2693 WRITE(*,*) ' Size,position=',SIZE,POSITION 2694 CALL MUMPS_ABORT() 2695 END IF 2696 IF ( SIZE .NE. POSITION ) 2697 & CALL BUF_ADJUST( BUF_LOAD, POSITION ) 2698 RETURN 2699 END SUBROUTINE SMUMPS_BUF_BROADCAST 2700 SUBROUTINE SMUMPS_BUF_SEND_FILS 2701 & ( WHAT, COMM, NPROCS, 2702 & FATHER_NODE,INODE,NCB,KEEP, 2703 & MYID,REMOTE, IERR) 2704 IMPLICIT NONE 2705 INTEGER COMM, NPROCS, MYID, IERR, WHAT,REMOTE 2706 INTEGER FATHER_NODE,INODE 2707 INCLUDE 'mpif.h' 2708 INCLUDE 'mumps_tags.h' 2709 INTEGER POSITION, IREQ, IPOS, SIZE 2710 INTEGER NDEST, IDEST, IPOSMSG 2711 INTEGER IZERO,NCB,KEEP(500) 2712 INTEGER MYID2(1) 2713 PARAMETER ( IZERO=0 ) 2714 MYID2(1) = MYID 2715 NDEST = 1 2716 IF ( NDEST .eq. 0 ) THEN 2717 RETURN 2718 ENDIF 2719 IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN 2720 CALL MPI_PACK_SIZE( 4 + OVHSIZE, 2721 & MPI_INTEGER, COMM, 2722 & SIZE, IERR ) 2723 ELSE 2724 CALL MPI_PACK_SIZE( 2 + OVHSIZE, 2725 & MPI_INTEGER, COMM, 2726 & SIZE, IERR ) 2727 ENDIF 2728 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, 2729 & IZERO, MYID2 2730 & ) 2731 IF ( IERR .LT. 0 ) THEN 2732 RETURN 2733 ENDIF 2734 BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE 2735 IPOS = IPOS - OVHSIZE 2736 DO IDEST = 1, NDEST - 1 2737 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = 2738 & IPOS + IDEST * OVHSIZE 2739 END DO 2740 BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 2741 IPOSMSG = IPOS + OVHSIZE * NDEST 2742 POSITION = 0 2743 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, 2744 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2745 & POSITION, COMM, IERR ) 2746 CALL MPI_PACK( FATHER_NODE, 1, MPI_INTEGER, 2747 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2748 & POSITION, COMM, IERR ) 2749 IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN 2750 CALL MPI_PACK( INODE, 1, MPI_INTEGER, 2751 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2752 & POSITION, COMM, IERR ) 2753 CALL MPI_PACK( NCB, 1, MPI_INTEGER, 2754 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2755 & POSITION, COMM, IERR ) 2756 ENDIF 2757 IDEST = 1 2758 KEEP(267)=KEEP(267)+1 2759 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), 2760 & POSITION, MPI_PACKED, REMOTE, 2761 & UPDATE_LOAD, COMM, 2762 & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), 2763 & IERR ) 2764 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT 2765 IF ( SIZE .LT. POSITION ) THEN 2766 WRITE(*,*) ' Error in SMUMPS_BUF_SEND_FILS' 2767 WRITE(*,*) ' Size,position=',SIZE,POSITION 2768 CALL MUMPS_ABORT() 2769 END IF 2770 IF ( SIZE .NE. POSITION ) 2771 & CALL BUF_ADJUST( BUF_LOAD, POSITION ) 2772 RETURN 2773 END SUBROUTINE SMUMPS_BUF_SEND_FILS 2774 SUBROUTINE SMUMPS_BUF_SEND_NOT_MSTR( COMM, MYID, NPROCS, 2775 & MAX_SURF_MASTER,KEEP,IERR) 2776 IMPLICIT NONE 2777 INCLUDE 'mpif.h' 2778 INCLUDE 'mumps_tags.h' 2779 INTEGER IPOS, IREQ, IDEST, IPOSMSG, POSITION, I 2780 INTEGER COMM, MYID, IERR, NPROCS 2781 DOUBLE PRECISION MAX_SURF_MASTER 2782 INTEGER, INTENT(INOUT) :: KEEP(500) 2783 INTEGER IZERO 2784 INTEGER MYID2(1) 2785 PARAMETER ( IZERO=0 ) 2786 INTEGER NDEST, NINTS, NREALS, SIZE, SIZE1, SIZE2 2787 INTEGER WHAT 2788 IERR = 0 2789 MYID2(1) = MYID 2790 NDEST = NPROCS - 1 2791 NINTS = 1 + ( NDEST-1 ) * OVHSIZE 2792 NREALS = 1 2793 CALL MPI_PACK_SIZE( NINTS, 2794 & MPI_INTEGER, COMM, 2795 & SIZE1, IERR ) 2796 CALL MPI_PACK_SIZE( NREALS, 2797 & MPI_DOUBLE_PRECISION, COMM, 2798 & SIZE2, IERR ) 2799 SIZE=SIZE1+SIZE2 2800 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, 2801 & IZERO, MYID2 ) 2802 IF ( IERR .LT. 0 ) THEN 2803 RETURN 2804 ENDIF 2805 BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE 2806 IPOS = IPOS - OVHSIZE 2807 DO IDEST = 1, NDEST - 1 2808 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = 2809 & IPOS + IDEST * OVHSIZE 2810 END DO 2811 BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 2812 IPOSMSG = IPOS + OVHSIZE * NDEST 2813 POSITION = 0 2814 WHAT = 4 2815 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, 2816 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2817 & POSITION, COMM, IERR ) 2818 CALL MPI_PACK( MAX_SURF_MASTER, 1, MPI_DOUBLE_PRECISION, 2819 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2820 & POSITION, COMM, IERR ) 2821 IDEST = 0 2822 DO I = 0, NPROCS - 1 2823 IF ( I .ne. MYID ) THEN 2824 IDEST = IDEST + 1 2825 KEEP(267)=KEEP(267)+1 2826 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), 2827 & POSITION, MPI_PACKED, I, 2828 & UPDATE_LOAD, COMM, 2829 & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), 2830 & IERR ) 2831 END IF 2832 END DO 2833 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT 2834 IF ( SIZE .LT. POSITION ) THEN 2835 WRITE(*,*) ' Error in SMUMPS_BUF_BCAST_ARRAY' 2836 WRITE(*,*) ' Size,position=',SIZE,POSITION 2837 CALL MUMPS_ABORT() 2838 END IF 2839 IF ( SIZE .NE. POSITION ) 2840 & CALL BUF_ADJUST( BUF_LOAD, POSITION ) 2841 RETURN 2842 END SUBROUTINE SMUMPS_BUF_SEND_NOT_MSTR 2843 SUBROUTINE SMUMPS_BUF_BCAST_ARRAY( BDC_MEM, 2844 & COMM, MYID, NPROCS, 2845#if ! defined(OLD_LOAD_MECHANISM) 2846 & FUTURE_NIV2, 2847#endif 2848 & NSLAVES, 2849 & LIST_SLAVES,INODE, 2850 & MEM_INCREMENT, FLOPS_INCREMENT,CB_BAND, WHAT, 2851 & KEEP, 2852 & IERR ) 2853 IMPLICIT NONE 2854 INCLUDE 'mpif.h' 2855 INCLUDE 'mumps_tags.h' 2856 LOGICAL BDC_MEM 2857 INTEGER COMM, MYID, NPROCS, NSLAVES, IERR 2858#if ! defined(OLD_LOAD_MECHANISM) 2859 INTEGER FUTURE_NIV2(NPROCS) 2860#endif 2861 INTEGER LIST_SLAVES(NSLAVES),INODE 2862 DOUBLE PRECISION MEM_INCREMENT(NSLAVES) 2863 DOUBLE PRECISION FLOPS_INCREMENT(NSLAVES) 2864 DOUBLE PRECISION CB_BAND(NSLAVES) 2865 INTEGER, INTENT(INOUT) :: KEEP(500) 2866 INTEGER NDEST, NINTS, NREALS, SIZE1, SIZE2, SIZE 2867 INTEGER IPOS, IPOSMSG, IREQ, POSITION 2868 INTEGER I, IDEST, WHAT 2869 INTEGER IZERO 2870 INTEGER MYID2(1) 2871 PARAMETER ( IZERO=0 ) 2872 MYID2(1)=MYID 2873 IERR = 0 2874#if ! defined(OLD_LOAD_MECHANISM) 2875 NDEST = 0 2876 DO I = 1, NPROCS 2877 IF ( I .NE. MYID + 1 .AND. FUTURE_NIV2(I).NE.0) THEN 2878 NDEST = NDEST + 1 2879 ENDIF 2880 ENDDO 2881#else 2882 NDEST = NPROCS - 1 2883#endif 2884 IF ( NDEST == 0 ) THEN 2885 RETURN 2886 ENDIF 2887 NINTS = 2 + NSLAVES + ( NDEST - 1 ) * OVHSIZE + 1 2888 NREALS = NSLAVES 2889 IF (BDC_MEM) NREALS = NREALS + NSLAVES 2890 IF(WHAT.EQ.19) THEN 2891 NREALS = NREALS + NSLAVES 2892 ENDIF 2893 CALL MPI_PACK_SIZE( NINTS, 2894 & MPI_INTEGER, COMM, 2895 & SIZE1, IERR ) 2896 CALL MPI_PACK_SIZE( NREALS, MPI_DOUBLE_PRECISION, 2897 & COMM, SIZE2, IERR ) 2898 SIZE = SIZE1+SIZE2 2899 CALL BUF_LOOK( BUF_LOAD, IPOS, IREQ, SIZE, IERR, 2900 & IZERO, MYID2 ) 2901 IF ( IERR .LT. 0 ) THEN 2902 RETURN 2903 ENDIF 2904 BUF_LOAD%ILASTMSG = BUF_LOAD%ILASTMSG + ( NDEST - 1 ) * OVHSIZE 2905 IPOS = IPOS - OVHSIZE 2906 DO IDEST = 1, NDEST - 1 2907 BUF_LOAD%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = 2908 & IPOS + IDEST * OVHSIZE 2909 END DO 2910 BUF_LOAD%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 2911 IPOSMSG = IPOS + OVHSIZE * NDEST 2912 POSITION = 0 2913 CALL MPI_PACK( WHAT, 1, MPI_INTEGER, 2914 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2915 & POSITION, COMM, IERR ) 2916 CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, 2917 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2918 & POSITION, COMM, IERR ) 2919 CALL MPI_PACK( INODE, 1, MPI_INTEGER, 2920 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2921 & POSITION, COMM, IERR ) 2922 CALL MPI_PACK( LIST_SLAVES, NSLAVES, MPI_INTEGER, 2923 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2924 & POSITION, COMM, IERR ) 2925 CALL MPI_PACK( FLOPS_INCREMENT, NSLAVES, 2926 & MPI_DOUBLE_PRECISION, 2927 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2928 & POSITION, COMM, IERR ) 2929 IF (BDC_MEM) THEN 2930 CALL MPI_PACK( MEM_INCREMENT, NSLAVES, 2931 & MPI_DOUBLE_PRECISION, 2932 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2933 & POSITION, COMM, IERR ) 2934 END IF 2935 IF(WHAT.EQ.19)THEN 2936 CALL MPI_PACK( CB_BAND, NSLAVES, 2937 & MPI_DOUBLE_PRECISION, 2938 & BUF_LOAD%CONTENT( IPOSMSG ), SIZE, 2939 & POSITION, COMM, IERR ) 2940 ENDIF 2941 IDEST = 0 2942 DO I = 0, NPROCS - 1 2943#if ! defined(OLD_LOAD_MECHANISM) 2944 IF ( I .NE. MYID .AND. FUTURE_NIV2(I+1) .NE. 0) THEN 2945#else 2946 IF ( I .NE. MYID ) THEN 2947#endif 2948 IDEST = IDEST + 1 2949 KEEP(267)=KEEP(267)+1 2950 CALL MPI_ISEND( BUF_LOAD%CONTENT( IPOSMSG ), 2951 & POSITION, MPI_PACKED, I, 2952 & UPDATE_LOAD, COMM, 2953 & BUF_LOAD%CONTENT( IREQ+(IDEST-1)*OVHSIZE ), 2954 & IERR ) 2955 END IF 2956 END DO 2957 SIZE = SIZE - ( NDEST - 1 ) * OVHSIZE * SIZEofINT 2958 IF ( SIZE .LT. POSITION ) THEN 2959 WRITE(*,*) ' Error in SMUMPS_BUF_BCAST_ARRAY' 2960 WRITE(*,*) ' Size,position=',SIZE,POSITION 2961 CALL MUMPS_ABORT() 2962 END IF 2963 IF ( SIZE .NE. POSITION ) 2964 & CALL BUF_ADJUST( BUF_LOAD, POSITION ) 2965 RETURN 2966 END SUBROUTINE SMUMPS_BUF_BCAST_ARRAY 2967 SUBROUTINE SMUMPS_BUF_DIST_IRECV_SIZE 2968 & ( SMUMPS_LBUFR_BYTES) 2969 IMPLICIT NONE 2970 INTEGER SMUMPS_LBUFR_BYTES 2971 SIZE_RBUF_BYTES = SMUMPS_LBUFR_BYTES 2972 RETURN 2973 END SUBROUTINE SMUMPS_BUF_DIST_IRECV_SIZE 2974 SUBROUTINE MUMPS_MPI_PACK_SIZE_LR( BLR_LorU, SIZE_OUT, COMM, IERR) 2975 USE SMUMPS_LR_TYPE 2976 INTEGER, intent(out) :: SIZE_OUT, IERR 2977 INTEGER, intent(in) :: COMM 2978 TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU 2979 INTEGER :: I, SIZE_LOC 2980 INCLUDE 'mpif.h' 2981 IERR = 0 2982 SIZE_OUT = 0 2983 CALL MPI_PACK_SIZE( 1, 2984 & MPI_INTEGER, COMM, SIZE_LOC, IERR ) 2985 SIZE_OUT = SIZE_OUT + SIZE_LOC 2986 DO I = 1, size(BLR_LorU) 2987 CALL MPI_PACK_SIZE( 6, 2988 & MPI_INTEGER, COMM, SIZE_LOC, IERR ) 2989 SIZE_OUT = SIZE_OUT + SIZE_LOC 2990 IF ( BLR_LorU(I)%ISLR ) THEN 2991 IF ( BLR_LorU(I)%LRFORM.NE.1) THEN 2992 CALL MUMPS_ABORT() 2993 ENDIF 2994 IF (BLR_LorU(I)%K .GT. 0) THEN 2995 CALL MPI_PACK_SIZE( BLR_LorU(I)%M * BLR_LorU(I)%K, 2996 & MPI_REAL, COMM, SIZE_LOC, IERR ) 2997 SIZE_OUT = SIZE_OUT + SIZE_LOC 2998 CALL MPI_PACK_SIZE( BLR_LorU(I)%K * BLR_LorU(I)%N, 2999 & MPI_REAL, COMM, SIZE_LOC, IERR ) 3000 SIZE_OUT = SIZE_OUT + SIZE_LOC 3001 ENDIF 3002 ELSE 3003 CALL MPI_PACK_SIZE( BLR_LorU(I)%M * BLR_LorU(I)%N, 3004 & MPI_REAL, COMM, SIZE_LOC, IERR ) 3005 SIZE_OUT = SIZE_OUT + SIZE_LOC 3006 ENDIF 3007 ENDDO 3008 RETURN 3009 END SUBROUTINE MUMPS_MPI_PACK_SIZE_LR 3010 SUBROUTINE MUMPS_MPI_PACK_LR( BLR_LorU, BUF, LBUF, POSITION, 3011 & COMM, IERR) 3012 USE SMUMPS_LR_TYPE 3013 INTEGER, intent(out) :: IERR 3014 INTEGER, intent(in) :: COMM, LBUF 3015 INTEGER, intent(inout) :: POSITION 3016 INTEGER, intent(inout) :: BUF(:) 3017 TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU 3018 INTEGER I, ISLR_INT 3019 INCLUDE 'mpif.h' 3020 IERR = 0 3021 CALL MPI_PACK( size(BLR_LorU), 1, MPI_INTEGER, 3022 & BUF(1), LBUF, POSITION, COMM, IERR ) 3023 DO I = 1, size(BLR_LorU) 3024 IF (BLR_LorU(I)%ISLR) THEN 3025 ISLR_INT = 1 3026 ELSE 3027 ISLR_INT = 0 3028 ENDIF 3029 CALL MPI_PACK( ISLR_INT, 1, MPI_INTEGER, 3030 & BUF(1), LBUF, POSITION, COMM, IERR ) 3031 CALL MPI_PACK( BLR_LorU(I)%LRFORM, 3032 & 1, MPI_INTEGER, 3033 & BUF(1), LBUF, POSITION, COMM, IERR ) 3034 CALL MPI_PACK( BLR_LorU(I)%K, 3035 & 1, MPI_INTEGER, 3036 & BUF(1), LBUF, POSITION, COMM, IERR ) 3037 CALL MPI_PACK( BLR_LorU(I)%M, 3038 & 1, MPI_INTEGER, 3039 & BUF(1), LBUF, POSITION, COMM, IERR ) 3040 CALL MPI_PACK( BLR_LorU(I)%N, 3041 & 1, MPI_INTEGER, 3042 & BUF(1), LBUF, POSITION, COMM, IERR ) 3043 CALL MPI_PACK( BLR_LorU(I)%KSVD, 3044 & 1, MPI_INTEGER, 3045 & BUF(1), LBUF, POSITION, COMM, IERR ) 3046 IF (BLR_LorU(I)%ISLR) THEN 3047 IF (BLR_LorU(I)%K .GT. 0) THEN 3048 CALL MPI_PACK( BLR_LorU(I)%Q(1,1), 3049 & BLR_LorU(I)%M*BLR_LorU(I)%K, 3050 & MPI_REAL, BUF(1), LBUF, POSITION, COMM, IERR ) 3051 CALL MPI_PACK( BLR_LorU(I)%R(1,1), 3052 & BLR_LorU(I)%N*BLR_LorU(I)%K, MPI_REAL, 3053 & BUF(1), LBUF, POSITION, COMM, IERR ) 3054 ENDIF 3055 ELSE 3056 CALL MPI_PACK( BLR_LorU(I)%Q(1,1), BLR_LorU(I)%M*BLR_LorU(I)%N 3057 & ,MPI_REAL, 3058 & BUF(1), LBUF, POSITION, COMM, IERR ) 3059 ENDIF 3060 ENDDO 3061 RETURN 3062 END SUBROUTINE MUMPS_MPI_PACK_LR 3063 SUBROUTINE MUMPS_MPI_PACK_SCALE_LR 3064 & ( BLR, BUF, LBUF, POSITION, 3065 & COMM, 3066 & A , LA, POSELTD, LD_DIAG, 3067 & IPIV, NPIV, MAXI_CLUSTER, 3068 & IERR) 3069 USE SMUMPS_LR_TYPE 3070 INTEGER, intent(out) :: IERR 3071 INTEGER, intent(in) :: COMM, LBUF 3072 INTEGER, intent(inout) :: POSITION 3073 INTEGER, intent(inout) :: BUF(:) 3074 TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR 3075 INTEGER(8), intent(in) :: LA, POSELTD 3076 INTEGER, intent(in) :: LD_DIAG, NPIV 3077 INTEGER, intent(in) :: IPIV(NPIV), MAXI_CLUSTER 3078 REAL, intent(inout) :: A(LA) 3079 INTEGER I, ISLR_INT, J, ALLOCOK 3080 REAL, ALLOCATABLE,DIMENSION(:,:) :: SCALED 3081 REAL, ALLOCATABLE,DIMENSION(:) :: BLOCK 3082 REAL :: PIV1, PIV2, OFFDIAG 3083 INCLUDE 'mpif.h' 3084 IERR = 0 3085 CALL MPI_PACK( size(BLR), 1, MPI_INTEGER, 3086 & BUF(1), LBUF, POSITION, COMM, IERR ) 3087 allocate(BLOCK(MAXI_CLUSTER), STAT=ALLOCOK ) 3088 IF ( ALLOCOK .GT. 0 ) THEN 3089 WRITE(*,*) 'pb allocation in mumps_mpi_pack_scale_lr' 3090 IERR = -1 3091 GOTO 500 3092 END IF 3093 allocate(SCALED(MAXI_CLUSTER,2), STAT=ALLOCOK ) 3094 IF ( ALLOCOK .GT. 0 ) THEN 3095 WRITE(*,*) 'pb allocation in mumps_mpi_pack_scale_lr' 3096 IERR = -1 3097 GOTO 500 3098 END IF 3099 DO I = 1, size(BLR) 3100 IF (BLR(I)%ISLR) THEN 3101 ISLR_INT = 1 3102 ELSE 3103 ISLR_INT = 0 3104 ENDIF 3105 CALL MPI_PACK( ISLR_INT, 1, MPI_INTEGER, 3106 & BUF(1), LBUF, POSITION, COMM, IERR ) 3107 CALL MPI_PACK( BLR(I)%LRFORM, 3108 & 1, MPI_INTEGER, 3109 & BUF(1), LBUF, POSITION, COMM, IERR ) 3110 CALL MPI_PACK( BLR(I)%K, 3111 & 1, MPI_INTEGER, 3112 & BUF(1), LBUF, POSITION, COMM, IERR ) 3113 CALL MPI_PACK( BLR(I)%M, 3114 & 1, MPI_INTEGER, 3115 & BUF(1), LBUF, POSITION, COMM, IERR ) 3116 CALL MPI_PACK( BLR(I)%N, 3117 & 1, MPI_INTEGER, 3118 & BUF(1), LBUF, POSITION, COMM, IERR ) 3119 CALL MPI_PACK( BLR(I)%KSVD, 3120 & 1, MPI_INTEGER, 3121 & BUF(1), LBUF, POSITION, COMM, IERR ) 3122 IF (BLR(I)%ISLR) THEN 3123 IF (BLR(I)%K .GT. 0) THEN 3124 CALL MPI_PACK( BLR(I)%Q(1,1), BLR(I)%M*BLR(I)%K, 3125 & MPI_REAL, 3126 & BUF(1), LBUF, POSITION, COMM, IERR ) 3127 J =1 3128 DO WHILE (J <= BLR(I)%N) 3129 IF (IPIV(J) > 0) THEN 3130 SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) 3131 & * BLR(I)%R(1:BLR(I)%K,J) 3132 J = J+1 3133 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, 3134 & MPI_REAL, 3135 & BUF(1), LBUF, POSITION, COMM, IERR ) 3136 ELSE 3137 PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) 3138 PIV2 = A(POSELTD+LD_DIAG*J+J) 3139 OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) 3140 BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) 3141 SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) 3142 & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) 3143 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, 3144 & MPI_REAL, 3145 & BUF(1), LBUF, POSITION, COMM, IERR ) 3146 SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) 3147 & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) 3148 J =J+2 3149 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, 3150 & MPI_REAL, 3151 & BUF(1), LBUF, POSITION, COMM, IERR ) 3152 ENDIF 3153 END DO 3154 ENDIF 3155 ELSE 3156 J = 1 3157 DO WHILE (J <= BLR(I)%N) 3158 IF (IPIV(J) > 0) THEN 3159 SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) 3160 & * BLR(I)%Q(1:BLR(I)%M,J) 3161 CALL MPI_PACK( SCALED(1,1), BLR(I)%M, 3162 & MPI_REAL, 3163 & BUF(1), LBUF, POSITION, COMM, IERR ) 3164 J = J+1 3165 ELSE 3166 PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) 3167 PIV2 = A(POSELTD+LD_DIAG*J+J) 3168 OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) 3169 BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) 3170 SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) 3171 & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) 3172 CALL MPI_PACK( SCALED(1,1), BLR(I)%M, 3173 & MPI_REAL, 3174 & BUF(1), LBUF, POSITION, COMM, IERR ) 3175 SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) 3176 & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) 3177 CALL MPI_PACK( SCALED(1,2), BLR(I)%M, 3178 & MPI_REAL, 3179 & BUF(1), LBUF, POSITION, COMM, IERR ) 3180 J=J+2 3181 ENDIF 3182 END DO 3183 ENDIF 3184 ENDDO 3185 500 CONTINUE 3186 IF (allocated(BLOCK)) deallocate(BLOCK) 3187 IF (allocated(SCALED)) deallocate(SCALED) 3188 RETURN 3189 END SUBROUTINE MUMPS_MPI_PACK_SCALE_LR 3190 END MODULE SMUMPS_BUF 3191