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