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 SUBROUTINE CMUMPS_BUILD_MAPPING 14 & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, 15 & SLAVEF, PERM, FILS, 16 & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) 17 USE CMUMPS_STRUC_DEF 18 IMPLICIT NONE 19 INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL 20 iNTEGER(8) :: NNZ 21 INTEGER KEEP(500) 22 INTEGER(8) KEEP8(150) 23 INTEGER IRN( NNZ ), JCN( NNZ ) 24 INTEGER MAPPING( NNZ ), STEP( N ) 25 INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) 26 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE 27 EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE 28 INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE 29 INTEGER(8) :: K8 30 INTEGER TYPE_NODE, DEST 31 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID 32 INODE = KEEP(38) 33 K4 = 1 34 DO WHILE ( INODE .GT. 0 ) 35 RG2L( INODE ) = K4 36 INODE = FILS( INODE ) 37 K4 = K4 + 1 38 END DO 39 DO K8 = 1_8, NNZ 40 IOLD = IRN( K8 ) 41 JOLD = JCN( K8 ) 42 IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. 43 & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN 44 MAPPING( K8 ) = -1 45 CYCLE 46 END IF 47 IF ( IOLD .eq. JOLD ) THEN 48 ISEND = IOLD 49 JSEND = JOLD 50 ELSE 51 INEW = PERM( IOLD ) 52 JNEW = PERM( JOLD ) 53 IF ( INEW .LT. JNEW ) THEN 54 ISEND = IOLD 55 IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD 56 JSEND = JOLD 57 ELSE 58 ISEND = -JOLD 59 JSEND = IOLD 60 END IF 61 END IF 62 IARR = abs( ISEND ) 63 TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), 64 & SLAVEF ) 65 IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN 66 IF ( KEEP(46) .eq. 0 ) THEN 67 DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), 68 & SLAVEF ) + 1 69 ELSE 70 DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), 71 & SLAVEF ) 72 END IF 73 ELSE 74 IF ( ISEND .LT. 0 ) THEN 75 IPOSROOT = RG2L( JSEND ) 76 JPOSROOT = RG2L( IARR ) 77 ELSE 78 IPOSROOT = RG2L( IARR ) 79 JPOSROOT = RG2L( JSEND ) 80 END IF 81 IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) 82 JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) 83 IF ( KEEP( 46 ) .eq. 0 ) THEN 84 DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 85 ELSE 86 DEST = IROW_GRID * NPCOL + JCOL_GRID 87 END IF 88 END IF 89 MAPPING( K8 ) = DEST 90 END DO 91 RETURN 92 END SUBROUTINE CMUMPS_BUILD_MAPPING 93 SUBROUTINE CMUMPS_REDISTRIBUTION( 94 & N, NZ_loc8, id, 95 & DBLARR, LDBLARR, INTARR, LINTARR, 96 & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, 97 & 98 & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, 99 & ICNTL, INFO, NSEND8, NLOCAL8, 100 & ISTEP_TO_INIV2, CANDIDATES 101 & ) 102 USE CMUMPS_STRUC_DEF 103 IMPLICIT NONE 104 INTEGER N 105 INTEGER(8) :: NZ_loc8 106 TYPE (CMUMPS_STRUC) :: id 107 INTEGER(8) :: LDBLARR, LINTARR 108 COMPLEX DBLARR( LDBLARR ) 109 INTEGER INTARR( LINTARR ) 110 INTEGER(8), INTENT(IN) :: PTRAIW( N ), PTRARW( N ) 111 INTEGER KEEP(500) 112 INTEGER(8) KEEP8(150) 113 INTEGER MYID, COMM, NBRECORDS 114 INTEGER(8) :: LA 115 INTEGER SLAVEF 116 INTEGER ISTEP_TO_INIV2(KEEP(71)) 117 INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) 118 COMPLEX A( LA ) 119 TYPE (CMUMPS_ROOT_STRUC) :: root 120 INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) 121 INTEGER INFO( 40 ), ICNTL(40) 122 INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, 123 & MUMPS_TYPESPLIT 124 EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, 125 & MUMPS_TYPESPLIT 126 INCLUDE 'mumps_tags.h' 127 INCLUDE 'mpif.h' 128 INTEGER :: IERR, MSGSOU 129 INTEGER :: STATUS(MPI_STATUS_SIZE) 130 COMPLEX ZERO 131 PARAMETER( ZERO = (0.0E0,0.0E0) ) 132 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 133 INTEGER END_MSG_2_RECV 134 INTEGER I 135 INTEGER(8) :: I18, IA8 136 INTEGER(8) :: K8 137 INTEGER TYPE_NODE, DEST 138 INTEGER IOLD, JOLD, IARR, ISEND, JSEND, INEW, JNEW 139 INTEGER allocok, TYPESPLIT, T4MASTER, INIV2 140 LOGICAL T4_MASTER_CONCERNED 141 COMPLEX VAL 142 INTEGER(8) :: PTR_ROOT 143 INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT 144 INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT 145 INTEGER MP,LP 146 INTEGER KPROBE, FREQPROBE 147 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI 148 COMPLEX, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR 149 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI 150 COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFRECR 151 INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR 152 LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE 153 LOGICAL FLAG 154 INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 155 INTEGER MASTER_NODE, ISTEP 156 NSEND8 = 0_8 157 NLOCAL8 = 0_8 158 LP = ICNTL(1) 159 MP = ICNTL(2) 160 END_MSG_2_RECV = SLAVEF 161 ALLOCATE( IACT(SLAVEF), stat=allocok) 162 IF ( allocok .GT. 0 ) THEN 163 IF ( LP > 0 ) THEN 164 WRITE(LP,*) 165 & '** Error allocating IACT in matrix distribution' 166 END IF 167 INFO(1) = -13 168 INFO(2) = SLAVEF 169 GOTO 20 170 END IF 171 ALLOCATE( IREQI(SLAVEF), stat=allocok) 172 IF ( allocok .GT. 0 ) THEN 173 IF ( LP > 0 ) THEN 174 WRITE(LP,*) 175 & '** Error allocating IREQI in matrix distribution' 176 END IF 177 INFO(1) = -13 178 INFO(2) = SLAVEF 179 GOTO 20 180 END IF 181 ALLOCATE( IREQR(SLAVEF), stat=allocok) 182 IF ( allocok .GT. 0 ) THEN 183 IF ( LP > 0 ) THEN 184 WRITE(LP,*) 185 & '** Error allocating IREQR in matrix distribution' 186 END IF 187 INFO(1) = -13 188 INFO(2) = SLAVEF 189 GOTO 20 190 END IF 191 ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) 192 IF ( allocok .GT. 0 ) THEN 193 IF ( LP > 0 ) THEN 194 WRITE(LP,*) 195 & '** Error allocating SEND_ACTIVE in matrix distribution' 196 END IF 197 INFO(1) = -13 198 INFO(2) = SLAVEF 199 GOTO 20 200 END IF 201 ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) 202 IF ( allocok .GT. 0 ) THEN 203 IF ( LP > 0 ) THEN 204 WRITE(LP,*) 205 & '** Error allocating int buffer for matrix distribution' 206 END IF 207 INFO(1) = -13 208 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 209 GOTO 20 210 END IF 211 ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) 212 IF ( allocok .GT. 0 ) THEN 213 IF ( LP > 0 ) THEN 214 WRITE(LP,*) 215 & '** Error allocating real buffer for matrix distribution' 216 END IF 217 INFO(1) = -13 218 INFO(2) = NBRECORDS * SLAVEF * 2 219 GOTO 20 220 END IF 221 ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) 222 IF ( allocok .GT. 0 ) THEN 223 IF ( LP > 0 ) THEN 224 WRITE(LP,*) 225 & '** Error allocating int recv buffer for matrix distribution' 226 END IF 227 INFO(1) = -13 228 INFO(2) = NBRECORDS * 2 + 1 229 GOTO 20 230 END IF 231 ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) 232 IF ( allocok .GT. 0 ) THEN 233 IF ( LP > 0 ) THEN 234 WRITE(LP,*) 235 & '** Error allocating int recv buffer for matrix distribution' 236 END IF 237 INFO(1) = -13 238 INFO(2) = NBRECORDS 239 GOTO 20 240 END IF 241 ALLOCATE( IW4( N, 2 ), stat = allocok ) 242 IF ( allocok .GT. 0 ) THEN 243 WRITE(LP,*) '** Error allocating IW4 for matrix distribution' 244 INFO(1) = -13 245 INFO(2) = N * 2 246 END IF 247 20 CONTINUE 248 CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) 249 IF ( INFO(1) .LT. 0 ) GOTO 100 250 ARROW_ROOT = 0 251 DO I = 1, N 252 I18 = PTRAIW( I ) 253 IA8 = PTRARW( I ) 254 IF ( IA8 .GT. 0_8 ) THEN 255 DBLARR( IA8 ) = ZERO 256 IW4( I, 1 ) = INTARR( I18 ) 257 IW4( I, 2 ) = -INTARR( I18 + 1_8 ) 258 INTARR( I18 + 2_8 ) = I 259 END IF 260 END DO 261 IF ( KEEP(38) .NE. 0 ) THEN 262 IF (KEEP(60)==0) THEN 263 LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, 264 & root%MYROW, 0, root%NPROW ) 265 LOCAL_M = max( 1, LOCAL_M ) 266 LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, 267 & root%MYCOL, 0, root%NPCOL ) 268 PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 269 IF ( PTR_ROOT .LE. LA ) THEN 270 A( PTR_ROOT:LA ) = ZERO 271 END IF 272 ELSE 273 DO I = 1, root%SCHUR_NLOC 274 root%SCHUR_POINTER((I-1)*root%SCHUR_LLD+1: 275 & (I-1)*root%SCHUR_LLD+root%SCHUR_MLOC) = ZERO 276 ENDDO 277 ENDIF 278 END IF 279 DO I = 1, SLAVEF 280 BUFI( 1, 1, I ) = 0 281 END DO 282 DO I = 1, SLAVEF 283 BUFI( 1, 2, I ) = 0 284 END DO 285 DO I = 1, SLAVEF 286 SEND_ACTIVE( I ) = .FALSE. 287 IACT( I ) = 1 288 END DO 289 KPROBE = 0 290 FREQPROBE = max(1,NBRECORDS/10) 291 DO K8 = 1_8, NZ_loc8 292 KPROBE = KPROBE + 1 293 IF ( KPROBE .eq. FREQPROBE ) THEN 294 KPROBE = 0 295 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, 296 & FLAG, STATUS, IERR ) 297 IF ( FLAG ) THEN 298 MSGSOU = STATUS( MPI_SOURCE ) 299 CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, 300 & MPI_INTEGER, 301 & MSGSOU, ARR_INT, COMM, STATUS, IERR ) 302 CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_COMPLEX, 303 & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) 304 CALL CMUMPS_DIST_TREAT_RECV_BUF( 305 & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), 306 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 307 & A, LA, 308 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 309 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 310 & INTARR, LINTARR, DBLARR, LDBLARR 311 & ) 312 END IF 313 END IF 314 IOLD = id%IRN_loc(K8) 315 JOLD = id%JCN_loc(K8) 316 IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) 317 & .OR.(JOLD.LT.1) ) CYCLE 318 VAL = id%A_loc(K8) 319 IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN 320 VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) 321 ENDIF 322 IF (IOLD.EQ.JOLD) THEN 323 ISEND = IOLD 324 JSEND = JOLD 325 ELSE 326 INEW = PERM(IOLD) 327 JNEW = PERM(JOLD) 328 IF (INEW.LT.JNEW) THEN 329 ISEND = IOLD 330 IF ( KEEP(50) .NE. 0 ) ISEND = -IOLD 331 JSEND = JOLD 332 ELSE 333 ISEND = -JOLD 334 JSEND = IOLD 335 ENDIF 336 ENDIF 337 IARR = abs( ISEND ) 338 ISTEP = abs(STEP(IARR)) 339 TYPE_NODE = MUMPS_TYPENODE( PROCNODE_STEPS(ISTEP), 340 & SLAVEF ) 341 MASTER_NODE= MUMPS_PROCNODE( PROCNODE_STEPS(ISTEP), 342 & SLAVEF ) 343 TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), 344 & SLAVEF ) 345 T4_MASTER_CONCERNED = .FALSE. 346 T4MASTER = -9999 347 IF (TYPE_NODE.EQ.2) THEN 348 INIV2 = ISTEP_TO_INIV2(ISTEP) 349 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN 350 T4_MASTER_CONCERNED = .TRUE. 351 T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) 352 ENDIF 353 ENDIF 354 IF ( TYPE_NODE .eq. 1 ) THEN 355 DEST = MASTER_NODE 356 ELSE IF ( TYPE_NODE .eq. 2 ) THEN 357 IF ( ISEND .LT. 0 ) THEN 358 DEST = -1 359 ELSE 360 DEST = MASTER_NODE 361 END IF 362 ELSE 363 IF ( ISEND < 0 ) THEN 364 IPOSROOT = root%RG2L_ROW(JSEND) 365 JPOSROOT = root%RG2L_ROW(IARR ) 366 ELSE 367 IPOSROOT = root%RG2L_ROW(IARR ) 368 JPOSROOT = root%RG2L_ROW(JSEND) 369 END IF 370 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) 371 JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) 372 DEST = IROW_GRID * root%NPCOL + JCOL_GRID 373 END IF 374 if (DEST .eq. -1) then 375 NLOCAL8 = NLOCAL8 + 1_8 376 NSEND8 = NSEND8 + int(SLAVEF -1,8) 377 else 378 if (DEST .eq.MYID ) then 379 NLOCAL8 = NLOCAL8 + 1_8 380 else 381 NSEND8 = NSEND8 + 1_8 382 endif 383 end if 384 IF ( DEST.EQ.-1) THEN 385 DO I=1, CANDIDATES(SLAVEF+1,ISTEP_TO_INIV2(ISTEP)) 386 DEST=CANDIDATES(I,ISTEP_TO_INIV2(ISTEP)) 387 CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, 388 & BUFI, BUFR, BUFRECI, BUFRECR, 389 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 390 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 391 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 392 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 393 & root, KEEP,KEEP8 ) 394 ENDDO 395 DEST=MASTER_NODE 396 CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, 397 & BUFI, BUFR, BUFRECI, BUFRECR, 398 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 399 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 400 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 401 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 402 & root, KEEP,KEEP8 ) 403 IF (T4_MASTER_CONCERNED) THEN 404 DEST = T4MASTER 405 CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, 406 & BUFI, BUFR, BUFRECI, BUFRECR, 407 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 408 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 409 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 410 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 411 & root, KEEP,KEEP8 ) 412 ENDIF 413 ELSE 414 CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, 415 & BUFI, BUFR, BUFRECI, BUFRECR, 416 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 417 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 418 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 419 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 420 & root, KEEP,KEEP8 ) 421 IF (T4_MASTER_CONCERNED) THEN 422 DEST = T4MASTER 423 CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, 424 & BUFI, BUFR, BUFRECI, BUFRECR, 425 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 426 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 427 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 428 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4(1,1), 429 & root, KEEP,KEEP8 ) 430 ENDIF 431 ENDIF 432 END DO 433 DEST = -2 434 CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, 435 & BUFI, BUFR, BUFRECI, BUFRECR, 436 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 437 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, 438 & N, PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 439 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, 440 & IW4(1,1), root, KEEP,KEEP8 ) 441 DO WHILE ( END_MSG_2_RECV .NE. 0 ) 442 CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, 443 & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) 444 MSGSOU = STATUS( MPI_SOURCE ) 445 CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_COMPLEX, 446 & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) 447 CALL CMUMPS_DIST_TREAT_RECV_BUF( 448 & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), 449 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 450 & A, LA, 451 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 452 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 453 & INTARR, LINTARR, DBLARR, LDBLARR 454 & ) 455 END DO 456 DO I = 1, SLAVEF 457 IF ( SEND_ACTIVE( I ) ) THEN 458 CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) 459 CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) 460 END IF 461 END DO 462 KEEP(49) = ARROW_ROOT 463 100 CONTINUE 464 IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) 465 IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) 466 IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) 467 IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) 468 IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) 469 IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) 470 IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) 471 IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) 472 IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) 473 RETURN 474 END SUBROUTINE CMUMPS_REDISTRIBUTION 475 SUBROUTINE CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, 476 & BUFI, BUFR, BUFRECI, BUFRECR, 477 & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, 478 & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, N, 479 & PTRAIW, PTRARW, PERM, STEP, ARROW_ROOT, END_MSG_2_RECV, 480 & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, 481 & KEEP,KEEP8 ) 482 IMPLICIT NONE 483 INCLUDE 'cmumps_root.h' 484 TYPE (CMUMPS_ROOT_STRUC) :: root 485 INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N 486 INTEGER KEEP(500) 487 INTEGER(8) KEEP8(150) 488 INTEGER ARROW_ROOT, END_MSG_2_RECV, LOCAL_M, LOCAL_N 489 INTEGER(8) :: LINTARR, LDBLARR 490 INTEGER(8) :: LA, PTR_ROOT 491 INTEGER BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) 492 INTEGER BUFRECI( NBRECORDS * 2 + 1 ) 493 INTEGER IREQI(SLAVEF), IREQR(SLAVEF), IACT(SLAVEF) 494 INTEGER IW4( N, 2 ) 495 INTEGER(8) PTRAIW( N ), PTRARW( N ) 496 INTEGER PERM( N ), STEP( N ) 497 INTEGER PROCNODE_STEPS( KEEP(28) ) 498 INTEGER INTARR( LINTARR ) 499 COMPLEX DBLARR( LDBLARR ), A( LA ) 500 LOGICAL SEND_ACTIVE(SLAVEF) 501 COMPLEX BUFR( NBRECORDS, 2, SLAVEF ) 502 COMPLEX BUFRECR( NBRECORDS ) 503 COMPLEX VAL 504 INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ 505 INTEGER TAILLE_SEND_I, TAILLE_SEND_R, MSGSOU 506 LOGICAL FLAG, SEND_LOCAL 507 INCLUDE 'mpif.h' 508 INCLUDE 'mumps_tags.h' 509 INTEGER :: IERR 510 INTEGER :: STATUS(MPI_STATUS_SIZE) 511 IF ( DEST .eq. -2 ) THEN 512 IBEG = 1 513 IEND = SLAVEF 514 ELSE 515 IBEG = DEST + 1 516 IEND = DEST + 1 517 END IF 518 SEND_LOCAL = .FALSE. 519 DO ISLAVE = IBEG, IEND 520 NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) 521 IF ( DEST .eq. -2 ) THEN 522 BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC 523 END IF 524 IF ( DEST .eq. -2 .or. NBREC + 1 > NBRECORDS ) THEN 525 DO WHILE ( SEND_ACTIVE( ISLAVE ) ) 526 CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) 527 IF ( .NOT. FLAG ) THEN 528 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, 529 & FLAG, STATUS, IERR ) 530 IF ( FLAG ) THEN 531 MSGSOU = STATUS(MPI_SOURCE) 532 CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, 533 & MPI_INTEGER, MSGSOU, ARR_INT, COMM, 534 & STATUS, IERR ) 535 CALL MPI_RECV( BUFRECR(1), NBRECORDS, 536 & MPI_COMPLEX, MSGSOU, 537 & ARR_REAL, COMM, STATUS, IERR ) 538 CALL CMUMPS_DIST_TREAT_RECV_BUF( 539 & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), 540 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 541 & A, LA, 542 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 543 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 544 & INTARR, LINTARR, DBLARR, LDBLARR 545 & ) 546 END IF 547 ELSE 548 CALL MPI_WAIT( IREQI( ISLAVE ), STATUS, IERR ) 549 SEND_ACTIVE( ISLAVE ) = .FALSE. 550 END IF 551 END DO 552 IF ( ISLAVE - 1 .ne. MYID ) THEN 553 TAILLE_SEND_I = NBREC * 2 + 1 554 TAILLE_SEND_R = NBREC 555 CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), 556 & TAILLE_SEND_I, 557 & MPI_INTEGER, ISLAVE - 1, ARR_INT, COMM, 558 & IREQI( ISLAVE ), IERR ) 559 CALL MPI_ISEND( BUFR(1, IACT(ISLAVE), ISLAVE ), 560 & TAILLE_SEND_R, 561 & MPI_COMPLEX, ISLAVE - 1, ARR_REAL, COMM, 562 & IREQR( ISLAVE ), IERR ) 563 SEND_ACTIVE( ISLAVE ) = .TRUE. 564 ELSE 565 SEND_LOCAL = .TRUE. 566 END IF 567 IACT( ISLAVE ) = 3 - IACT( ISLAVE ) 568 BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 569 END IF 570 IF ( DEST .ne. -2 ) THEN 571 IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 572 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ 573 BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND 574 BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND 575 BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL 576 END IF 577 END DO 578 IF ( SEND_LOCAL ) THEN 579 ISLAVE = MYID + 1 580 CALL CMUMPS_DIST_TREAT_RECV_BUF( 581 & BUFI(1,3-IACT(ISLAVE),ISLAVE), 582 & BUFR(1,3-IACT(ISLAVE),ISLAVE), 583 & NBRECORDS, N, IW4(1,1), 584 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, 585 & A, LA, 586 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, 587 & ARROW_ROOT, PTRAIW, PTRARW, PERM, STEP, 588 & INTARR, LINTARR, DBLARR, LDBLARR 589 & ) 590 END IF 591 RETURN 592 END SUBROUTINE CMUMPS_DIST_FILL_BUFFER 593 SUBROUTINE CMUMPS_DIST_TREAT_RECV_BUF 594 & ( BUFI, BUFR, NBRECORDS, N, IW4, 595 & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, A, LA, 596 & END_MSG_2_RECV, MYID, PROCNODE_STEPS, 597 & SLAVEF, ARROW_ROOT, 598 & PTRAIW, PTRARW, PERM, STEP, 599 & INTARR, LINTARR, DBLARR, LDBLARR ) 600 IMPLICIT NONE 601 INCLUDE 'cmumps_root.h' 602 TYPE (CMUMPS_ROOT_STRUC) :: root 603 INTEGER NBRECORDS, N, ARROW_ROOT, MYID, SLAVEF 604 INTEGER BUFI( NBRECORDS * 2 + 1 ) 605 COMPLEX BUFR( NBRECORDS ) 606 INTEGER IW4( N, 2 ) 607 INTEGER KEEP(500) 608 INTEGER(8) KEEP8(150) 609 INTEGER END_MSG_2_RECV 610 INTEGER(8) :: PTRAIW( N ), PTRARW( N ) 611 INTEGER :: PERM( N ), STEP( N ) 612 INTEGER PROCNODE_STEPS( KEEP(28) ) 613 INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR 614 INTEGER INTARR( LINTARR ) 615 INTEGER LOCAL_M, LOCAL_N 616 INTEGER(8) :: PTR_ROOT, LA 617 COMPLEX A( LA ), DBLARR( LDBLARR ) 618 INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE 619 EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE 620 INTEGER IREC, NB_REC, NODE_TYPE, IPROC 621 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID, 622 & ILOCROOT, JLOCROOT 623 INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 624 INTEGER ISHIFT, IARR, JARR 625 INTEGER TAILLE 626 COMPLEX VAL 627 NB_REC = BUFI( 1 ) 628 IF ( NB_REC .LE. 0 ) THEN 629 END_MSG_2_RECV = END_MSG_2_RECV - 1 630 NB_REC = - NB_REC 631 END IF 632 IF ( NB_REC .eq. 0 ) GOTO 100 633 DO IREC = 1, NB_REC 634 IARR = BUFI( IREC * 2 ) 635 JARR = BUFI( IREC * 2 + 1 ) 636 VAL = BUFR( IREC ) 637 NODE_TYPE = MUMPS_TYPENODE( 638 & PROCNODE_STEPS(abs(STEP(abs( IARR )))), 639 & SLAVEF ) 640 IF ( NODE_TYPE .eq. 3 ) THEN 641 ARROW_ROOT = ARROW_ROOT + 1 642 IF ( IARR .GT. 0 ) THEN 643 IPOSROOT = root%RG2L_ROW( IARR ) 644 JPOSROOT = root%RG2L_COL( JARR ) 645 ELSE 646 IPOSROOT = root%RG2L_ROW( JARR ) 647 JPOSROOT = root%RG2L_COL( -IARR ) 648 END IF 649 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW ) 650 JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL ) 651 IF ( IROW_GRID .NE. root%MYROW .OR. 652 & JCOL_GRID .NE. root%MYCOL ) THEN 653 WRITE(*,*) MYID,':INTERNAL Error: recvd root arrowhead ' 654 WRITE(*,*) MYID,':not belonging to me. IARR,JARR=',IARR,JARR 655 WRITE(*,*) MYID,':IROW_GRID,JCOL_GRID=',IROW_GRID,JCOL_GRID 656 WRITE(*,*) MYID,':MYROW, MYCOL=', root%MYROW, root%MYCOL 657 WRITE(*,*) MYID,':IPOSROOT,JPOSROOT=', IPOSROOT, JPOSROOT 658 CALL MUMPS_ABORT() 659 END IF 660 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / 661 & ( root%MBLOCK * root%NPROW ) ) 662 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 663 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / 664 & ( root%NBLOCK * root%NPCOL ) ) 665 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 666 IF (KEEP(60)==0) THEN 667 A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) 668 & + int(ILOCROOT-1,8)) = A( PTR_ROOT 669 & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) 670 & + int(ILOCROOT - 1,8) ) 671 & + VAL 672 ELSE 673 root%SCHUR_POINTER( int(JLOCROOT-1,8) 674 & * int(root%SCHUR_LLD,8) 675 & + int(ILOCROOT,8) ) 676 & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) 677 & * int(root%SCHUR_LLD,8) 678 & + int(ILOCROOT,8)) 679 & + VAL 680 ENDIF 681 ELSE IF (IARR.GE.0) THEN 682 IF (IARR.EQ.JARR) THEN 683 IA8 = PTRARW(IARR) 684 DBLARR(IA8) = DBLARR(IA8) + VAL 685 ELSE 686 IS18 = PTRAIW(IARR) 687 ISHIFT = INTARR(IS18) + IW4(IARR,2) 688 IW4(IARR,2) = IW4(IARR,2) - 1 689 IIW8 = IS18 + ISHIFT + 2 690 INTARR(IIW8) = JARR 691 IS8 = PTRARW(IARR) 692 IAS8 = IS8 + ISHIFT 693 DBLARR(IAS8) = VAL 694 ENDIF 695 ELSE 696 IARR = -IARR 697 IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 698 INTARR(IS8) = JARR 699 IAS8 = PTRARW(IARR)+IW4(IARR,1) 700 IW4(IARR,1) = IW4(IARR,1) - 1 701 DBLARR(IAS8) = VAL 702 IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(abs(STEP(IARR))), 703 & SLAVEF ) 704 IF ( (KEEP(50) .NE. 0 .OR. KEEP(234).NE.0) 705 & .AND. 706 & IW4(IARR,1) .EQ. 0 .AND. 707 & IPROC .EQ. MYID 708 & .AND. STEP(IARR) > 0 ) THEN 709 TAILLE = INTARR( PTRAIW(IARR) ) 710 CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, 711 & INTARR( PTRAIW(IARR) + 3 ), 712 & DBLARR( PTRARW(IARR) + 1 ), 713 & TAILLE, 1, TAILLE ) 714 END IF 715 ENDIF 716 ENDDO 717 100 CONTINUE 718 RETURN 719 END SUBROUTINE CMUMPS_DIST_TREAT_RECV_BUF 720