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 RECURSIVE SUBROUTINE DMUMPS_BACKSLV_RECV_AND_TREAT( 14 & BLOQ, FLAG, 15 & BUFR, LBUFR, LBUFR_BYTES, 16 & MYID, SLAVEF, COMM, 17 & N, IWCB, LIWW, POSIWCB, 18 & W, LWC, POSWCB, 19 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 20 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 21 & STEP, FRERE, FILS, PROCNODE_STEPS, 22 & PLEFTW, KEEP, KEEP8, DKEEP, 23 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 24 & NRHS, MTYPE, 25 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 26 & , TO_PROCESS, SIZE_TO_PROCESS 27 & , FROM_PP ) 28 IMPLICIT NONE 29 LOGICAL BLOQ, FLAG 30 INTEGER LBUFR, LBUFR_BYTES 31 INTEGER BUFR( LBUFR ) 32 INTEGER MYID, SLAVEF, COMM 33 INTEGER N, LIWW 34 INTEGER IWCB( LIWW ) 35 INTEGER(8), intent(in) :: LWC 36 DOUBLE PRECISION W( LWC ) 37 INTEGER POSIWCB 38 INTEGER IIPOOL, LPOOL 39 INTEGER IPOOL( LPOOL ) 40 INTEGER LPANEL_POS 41 INTEGER PANEL_POS( LPANEL_POS ) 42 INTEGER NBFINF, INFO(40), KEEP(500) 43 INTEGER(8) :: POSWCB, PLEFTW 44 INTEGER(8) KEEP8(150) 45 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) 46 INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) 47 INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) 48 INTEGER(8) :: PTRACB(KEEP(28)) 49 INTEGER LIW 50 INTEGER(8) :: LA 51 INTEGER PTRIST(KEEP(28)), IW( LIW ) 52 INTEGER (8) :: PTRFAC(KEEP(28)) 53 DOUBLE PRECISION A( LA ), W2( KEEP(133) ) 54 INTEGER NRHS 55 INTEGER MYLEAFE, MTYPE 56 INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) 57#if defined(RHSCOMP_BYROWS) 58 DOUBLE PRECISION RHSCOMP(NRHS,LRHSCOMP) 59#else 60 DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) 61#endif 62 INTEGER SIZE_TO_PROCESS 63 LOGICAL TO_PROCESS(SIZE_TO_PROCESS) 64 LOGICAL, intent(in) :: FROM_PP 65 INCLUDE 'mpif.h' 66 INCLUDE 'mumps_tags.h' 67 INTEGER MSGSOU, MSGTAG, MSGLEN 68 INTEGER :: STATUS(MPI_STATUS_SIZE) 69 INTEGER :: IERR 70 DOUBLE PRECISION :: TIME_TMP 71 FLAG = .FALSE. 72 IF ( BLOQ ) THEN 73 CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, 74 & COMM, STATUS, IERR ) 75 FLAG = .TRUE. 76 ELSE 77 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, 78 & FLAG, STATUS, IERR ) 79 END IF 80 IF (FLAG) THEN 81 KEEP(266)=KEEP(266)-1 82 MSGSOU=STATUS(MPI_SOURCE) 83 MSGTAG=STATUS(MPI_TAG) 84 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) 85 IF ( MSGLEN .GT. LBUFR_BYTES ) THEN 86 INFO(1) = -20 87 INFO(2) = MSGLEN 88 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 89 ELSE 90 CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, 91 & MSGTAG, COMM, STATUS, IERR) 92 CALL DMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, 93 & BUFR, LBUFR, LBUFR_BYTES, 94 & MYID, SLAVEF, COMM, 95 & N, IWCB, LIWW, POSIWCB, 96 & W, LWC, POSWCB, 97 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 98 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 99 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, 100 & KEEP, KEEP8, DKEEP, 101 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 102 & NRHS, MTYPE, 103 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 104 & , TO_PROCESS, SIZE_TO_PROCESS 105 & , FROM_PP 106 & ) 107 END IF 108 END IF 109 RETURN 110 END SUBROUTINE DMUMPS_BACKSLV_RECV_AND_TREAT 111 RECURSIVE SUBROUTINE DMUMPS_BACKSLV_TRAITER_MESSAGE( 112 & MSGTAG, MSGSOU, 113 & BUFR, LBUFR, LBUFR_BYTES, 114 & MYID, SLAVEF, COMM, 115 & N, IWCB, LIWW, POSIWCB, 116 & W, LWC, POSWCB, 117 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 118 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 119 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, 120 & KEEP, KEEP8, DKEEP, 121 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 122 & NRHS, MTYPE, 123 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 124 & , TO_PROCESS, SIZE_TO_PROCESS 125 & , FROM_PP 126 & ) 127 USE DMUMPS_OOC 128 USE DMUMPS_BUF 129 IMPLICIT NONE 130 INTEGER MSGTAG, MSGSOU 131 INTEGER LBUFR, LBUFR_BYTES 132 INTEGER BUFR( LBUFR ) 133 INTEGER MYID, SLAVEF, COMM 134 INTEGER N, LIWW 135 INTEGER IWCB( LIWW ) 136 INTEGER(8), intent(in) :: LWC 137 DOUBLE PRECISION W( LWC ) 138 INTEGER POSIWCB 139 INTEGER IIPOOL, LPOOL, LPANEL_POS 140 INTEGER IPOOL( LPOOL ) 141 INTEGER PANEL_POS( LPANEL_POS ) 142 INTEGER NBFINF, INFO(40), KEEP(500) 143 INTEGER(8) :: POSWCB, PLEFTW 144 INTEGER(8) KEEP8(150) 145 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) 146 INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) 147 INTEGER(8) :: PTRACB(KEEP(28)) 148 INTEGER FRERE(KEEP(28)) 149 INTEGER PROCNODE_STEPS(KEEP(28)) 150 INTEGER LIW 151 INTEGER(8) :: LA 152 INTEGER IW( LIW ), PTRIST( KEEP(28) ) 153 INTEGER(8) :: PTRFAC(KEEP(28)) 154 DOUBLE PRECISION A( LA ), W2( KEEP(133) ) 155 INTEGER NRHS 156 INTEGER MYLEAFE, MTYPE 157 INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) 158#if defined(RHSCOMP_BYROWS) 159 DOUBLE PRECISION RHSCOMP(NRHS,LRHSCOMP) 160#else 161 DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) 162#endif 163 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR 164 LOGICAL MUST_BE_PERMUTED 165 INTEGER SIZE_TO_PROCESS 166 LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN 167 LOGICAL, intent(in) :: FROM_PP 168 INCLUDE 'mpif.h' 169 INCLUDE 'mumps_tags.h' 170 INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) 171 INTEGER(8) :: P_UPDATE, P_SOL_MAS 172 INTEGER :: LIELL, K 173 INTEGER(8) :: APOS, IST 174 INTEGER NPIV, NROW_L, IPOS, NROW_RECU 175 INTEGER(8) :: IFR8 176 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA 177 INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, 178 & IPOSINRHSCOMP, IPOSINRHSCOMP_TMP, IPOSINRHSCOMP_PANEL 179 DOUBLE PRECISION :: TIME_TMP 180 INTEGER JBDEB, JBFIN, NRHS_B, allocok 181 LOGICAL FLAG 182 DOUBLE PRECISION ZERO, ALPHA, ONE 183 PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) 184 INCLUDE 'mumps_headers.h' 185 INTEGER POOL_FIRST_POS, TMP 186 LOGICAL,DIMENSION(:),ALLOCATABLE :: DEJA_SEND 187 INTEGER MUMPS_PROCNODE 188 EXTERNAL MUMPS_PROCNODE, dtrsv, dtrsm, dgemv, dgemm 189 INTEGER :: NCB 190 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS 191 INTEGER(8) :: PTWCB, PTWCB_PANEL 192 INTEGER LDAJ, NBJ, LIWFAC, 193 & NBJLAST, NPIV_LAST, PANEL_SIZE, 194 & NCB_PANEL, TYPEF 195 LOGICAL TWOBYTWO 196 INTEGER BEG_PANEL 197 INTEGER IPANEL, NPANELS 198 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) 199 if(allocok.ne.0) then 200 INFO(1)=-13 201 INFO(2)=SLAVEF 202 WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' 203 & //'in bwd solve COMPSO' 204 GOTO 260 205 END IF 206 DUMMY(1)=0 207 IF (MSGTAG .EQ. FEUILLE) THEN 208 NBFINF = NBFINF - 1 209 ELSE IF (MSGTAG .EQ. NOEUD) THEN 210 POSITION = 0 211 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 212 & INODE, 1, MPI_INTEGER, 213 & COMM, IERR) 214 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 215 & JBDEB, 1, MPI_INTEGER, COMM, IERR ) 216 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 217 & JBFIN, 1, MPI_INTEGER, COMM, IERR ) 218 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 219 & LONG, 1, MPI_INTEGER, 220 & COMM, IERR) 221 NRHS_B = JBFIN-JBDEB+1 222 IF ( POSIWCB - LONG .LT. 0 223 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN 224 CALL DMUMPS_COMPSO(N, KEEP(28), IWCB, 225 & LIWW, W, LWC, 226 & POSWCB, POSIWCB, PTRICB, PTRACB) 227 IF (POSIWCB - LONG .LT. 0) THEN 228 INFO(1)=-14 229 INFO(2)=-POSIWCB + LONG 230 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 231 GOTO 260 232 END IF 233 IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN 234 INFO(1) = -11 235 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, 236 & INFO(2)) 237 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 238 GOTO 260 239 END IF 240 ENDIF 241 POSIWCB = POSIWCB - LONG 242 POSWCB = POSWCB - LONG 243 IF (LONG .GT. 0) THEN 244 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 245 & IWCB(POSIWCB + 1), 246 & LONG, MPI_INTEGER, COMM, IERR) 247 DO K=JBDEB,JBFIN 248 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 249 & W(POSWCB + 1), LONG, 250 & MPI_DOUBLE_PRECISION, COMM, IERR) 251 DO JJ=0, LONG-1 252 IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IWCB(POSIWCB+1+JJ))) 253 IF ( (IPOSINRHSCOMP.EQ.0) .OR. 254 & ( IPOSINRHSCOMP.GT.N ) ) CYCLE 255#if defined(RHSCOMP_BYROWS) 256 RHSCOMP(K,IPOSINRHSCOMP) = W(POSWCB+1+JJ) 257#else 258 RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) 259#endif 260 ENDDO 261 ENDDO 262 POSIWCB = POSIWCB + LONG 263 POSWCB = POSWCB + LONG 264 ENDIF 265 POOL_FIRST_POS = IIPOOL 266 IF ( KEEP(237).GT. 0 ) THEN 267 IF (.NOT.TO_PROCESS(STEP(INODE))) 268 & GOTO 1010 269 ENDIF 270 IPOOL( IIPOOL ) = INODE 271 IIPOOL = IIPOOL + 1 272 1010 CONTINUE 273 IF = FRERE( STEP(INODE) ) 274 DO WHILE ( IF .GT. 0 ) 275 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), 276 & SLAVEF) .eq. MYID ) THEN 277 IF ( KEEP(237).GT. 0 ) THEN 278 IF (.NOT.TO_PROCESS(STEP(IF))) THEN 279 IF = FRERE(STEP(IF)) 280 CYCLE 281 ENDIF 282 ENDIF 283 IPOOL( IIPOOL ) = IF 284 IIPOOL = IIPOOL + 1 285 END IF 286 IF = FRERE( STEP( IF ) ) 287 END DO 288 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 289 TMP=IPOOL(POOL_FIRST_POS+I-1) 290 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 291 IPOOL(IIPOOL-I)=TMP 292 ENDDO 293 ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN 294 POSITION = 0 295 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 296 & INODE, 1, MPI_INTEGER, COMM, IERR ) 297 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 298 & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) 299 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 300 & JBDEB, 1, MPI_INTEGER, COMM, IERR ) 301 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 302 & JBFIN, 1, MPI_INTEGER, COMM, IERR ) 303 NRHS_B = JBFIN-JBDEB+1 304 IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) 305 NPIV = - IW( IPOS ) 306 NROW_L = IW( IPOS + 1 ) 307 IF (KEEP(201).GT.0) THEN 308 CALL DMUMPS_SOLVE_GET_OOC_NODE( 309 & INODE,PTRFAC,KEEP,A,LA,STEP, 310 & KEEP8,N,MUST_BE_PERMUTED,IERR) 311 IF(IERR.LT.0)THEN 312 INFO(1)=IERR 313 INFO(2)=0 314 GOTO 260 315 ENDIF 316 ENDIF 317 APOS = PTRFAC(IW( IPOS + 3 )) 318 IF ( NROW_L .NE. NROW_RECU ) THEN 319 WRITE(*,*) 'Error1 in 41S : NROW L/RECU=',NROW_L, NROW_RECU 320 CALL MUMPS_ABORT() 321 END IF 322 LONG = NROW_L + NPIV 323 IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN 324 CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, 325 & LIWW, W, LWC, 326 & POSWCB, POSIWCB, PTRICB, PTRACB) 327 IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN 328 INFO(1) = -11 329 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) 330 WRITE(6,*) MYID,' Internal error in bwd solve COMPSO' 331 GOTO 260 332 END IF 333 END IF 334 P_UPDATE = PLEFTW 335 P_SOL_MAS = PLEFTW + NPIV * NRHS_B 336 PLEFTW = P_SOL_MAS + NROW_L * NRHS_B 337 DO K=JBDEB, JBFIN 338 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 339 & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, 340 & MPI_DOUBLE_PRECISION, 341 & COMM, IERR ) 342 ENDDO 343 IF (KEEP(201).EQ.1) THEN 344#if defined(MUMPS_USE_BLAS2) 345 IF ( NRHS_B == 1 ) THEN 346 CALL dgemv( 'T', NROW_L, NPIV, ALPHA, A( APOS ), NROW_L, 347 & W( P_SOL_MAS ), 1, ZERO, 348 & W( P_UPDATE ), 1 ) 349 ELSE 350#endif 351 CALL dgemm( 'T', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), 352 & NROW_L, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), 353 & NPIV ) 354#if defined(MUMPS_USE_BLAS2) 355 ENDIF 356#endif 357 ELSE 358#if defined(MUMPS_USE_BLAS2) 359 IF ( NRHS_B == 1 ) THEN 360 CALL dgemv( 'N', NPIV, NROW_L, ALPHA, A( APOS ), NPIV, 361 & W( P_SOL_MAS ), 1, ZERO, 362 & W( P_UPDATE ), 1 ) 363 ELSE 364#endif 365 CALL dgemm( 'N', 'N', NPIV, NRHS_B, NROW_L, ALPHA, A(APOS), 366 & NPIV, W( P_SOL_MAS ), NROW_L, ZERO, W( P_UPDATE ), 367 & NPIV ) 368#if defined(MUMPS_USE_BLAS2) 369 END IF 370#endif 371 ENDIF 372 IF (KEEP(201).GT.0) THEN 373 CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), 374 & A,LA,.TRUE.,IERR) 375 IF(IERR.LT.0)THEN 376 INFO(1)=IERR 377 INFO(2)=0 378 GOTO 260 379 ENDIF 380 ENDIF 381 PLEFTW = PLEFTW - NROW_L * NRHS_B 382 100 CONTINUE 383 CALL DMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, 384 & W(P_UPDATE), 385 & NPIV, NPIV, 386 & MSGSOU, 387 & BACKSLV_UPDATERHS, 388 & JBDEB, JBFIN, 389 & KEEP, COMM, IERR ) 390 IF ( IERR .EQ. -1 ) THEN 391 CALL DMUMPS_BACKSLV_RECV_AND_TREAT( 392 & .FALSE., FLAG, 393 & BUFR, LBUFR, LBUFR_BYTES, 394 & MYID, SLAVEF, COMM, 395 & N, IWCB, LIWW, POSIWCB, 396 & W, LWC, POSWCB, 397 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 398 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 399 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, 400 & KEEP, KEEP8, DKEEP, 401 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 402 & NRHS, MTYPE, 403 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 404 & , TO_PROCESS, SIZE_TO_PROCESS 405 & , FROM_PP ) 406 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 407 GOTO 100 408 ELSE IF ( IERR .EQ. -2 ) THEN 409 INFO( 1 ) = -17 410 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) 411 GOTO 260 412 ELSE IF ( IERR .EQ. -3 ) THEN 413 INFO( 1 ) = -20 414 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) 415 GOTO 260 416 END IF 417 PLEFTW = PLEFTW - NPIV * NRHS_B 418 ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN 419 POSITION = 0 420 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 421 & INODE, 1, MPI_INTEGER, COMM, IERR ) 422 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 423 LIELL = IW(IPOS-2)+IW(IPOS+1) 424 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 425 & NPIV, 1, MPI_INTEGER, COMM, IERR ) 426 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 427 & JBDEB, 1, MPI_INTEGER, COMM, IERR ) 428 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 429 & JBFIN, 1, MPI_INTEGER, COMM, IERR ) 430 NRHS_B = JBFIN-JBDEB+1 431 NELIM = IW(IPOS-1) 432 IPOS = IPOS + 1 433 NPIV = IW(IPOS) 434 IPOS = IPOS + 1 435 NSLAVES = IW( IPOS + 1 ) 436 IPOS = IPOS + 1 + NSLAVES 437 INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 438 IF ( KEEP(50) .eq. 0 ) THEN 439 LDA = LIELL 440 ELSE 441 LDA = NPIV 442 ENDIF 443 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 444 J1 = IPOS + LIELL + 1 445 J2 = IPOS + NPIV + LIELL 446 ELSE 447 J1 = IPOS + 1 448 J2 = IPOS + NPIV 449 ENDIF 450 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 451 DO K=JBDEB, JBFIN 452 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 453 & W2, NPIV, MPI_DOUBLE_PRECISION, 454 & COMM, IERR ) 455 I = 1 456 IF ( (KEEP(253).NE.0) .AND. 457 & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) 458 & ) THEN 459 DO JJ = J1,J2 460#if defined(RHSCOMP_BYROWS) 461 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = W2(I) 462#else 463 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) 464#endif 465 I = I+1 466 ENDDO 467 ELSE 468 DO JJ = J1,J2 469#if defined(RHSCOMP_BYROWS) 470 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = 471 & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) + W2(I) 472#else 473 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = 474 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) 475#endif 476 I = I+1 477 ENDDO 478 ENDIF 479 ENDDO 480 IW(PTRIST(STEP(INODE))+XXS) = 481 & IW(PTRIST(STEP(INODE))+XXS) - 1 482 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN 483 IF (KEEP(201).GT.0) THEN 484 CALL DMUMPS_SOLVE_GET_OOC_NODE( 485 & INODE,PTRFAC,KEEP,A,LA,STEP, 486 & KEEP8,N,MUST_BE_PERMUTED,IERR) 487 IF(IERR.LT.0)THEN 488 INFO(1)=IERR 489 INFO(2)=0 490 GOTO 260 491 ENDIF 492 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 493 CALL DMUMPS_OOC_PP_CHECK_PERM_FREED( 494 & IW(IPOS+1+2*LIELL), 495 & MUST_BE_PERMUTED ) 496 ENDIF 497 ENDIF 498 APOS = PTRFAC(IW(INODEPOS)) 499 IF (KEEP(201).EQ.1) THEN 500 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 501 TYPEF = TYPEF_L 502 NROW_L = NPIV+NELIM 503 PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE(NROW_L) 504 IF (PANEL_SIZE.LT.0) THEN 505 WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', 506 & PANEL_SIZE 507 CALL MUMPS_ABORT() 508 ENDIF 509 ENDIF 510 IF ( POSIWCB - 2 .LT. 0 .or. 511 & POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN 512 CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, 513 & LIWW, W, LWC, 514 & POSWCB, POSIWCB, PTRICB, PTRACB) 515 IF ( POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN 516 INFO( 1 ) = -11 517 CALL MUMPS_SET_IERROR( LIELL*NRHS_B - POSWCB-PLEFTW+1_8, 518 & INFO(2) ) 519 GOTO 260 520 END IF 521 IF ( POSIWCB - 2 .LT. 0 ) THEN 522 INFO( 1 ) = -14 523 INFO( 2 ) = 2 - POSIWCB 524 GO TO 260 525 END IF 526 END IF 527 POSIWCB = POSIWCB - 2 528 POSWCB = POSWCB - LIELL*NRHS_B 529 PTRICB(STEP( INODE )) = POSIWCB + 1 530 PTRACB(STEP( INODE )) = POSWCB + 1_8 531 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B 532 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 533 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 5 + NSLAVES 534 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 535 POSINDICES = IPOS + LIELL + 1 536 ELSE 537 POSINDICES = IPOS + 1 538 END IF 539 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 540 IFR8 = PTRACB(STEP( INODE )) 541 IF (KEEP(350).EQ.0) THEN 542 DO K=JBDEB, JBFIN 543 DO JJ = J1, J2 544 W(IFR8+JJ-J1+(K-JBDEB)*LIELL) = 545#if defined(RHSCOMP_BYROWS) 546 & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) 547#else 548 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 549#endif 550 END DO 551 END DO 552 ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN 553 ELSE 554 WRITE(*,*) "Internal error DMUMPS_BACKSLV_TRAITER_MESSAGE" 555 CALL MUMPS_ABORT() 556 ENDIF 557 IFR8 = PTRACB(STEP(INODE))+NPIV-1 558 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 559 J1 = IPOS + LIELL + NPIV + 1 560 J2 = IPOS + 2 * LIELL 561 ELSE 562 J1 = IPOS + NPIV + 1 563 J2 = IPOS + LIELL 564 END IF 565 IF (KEEP(350).EQ.0) THEN 566 DO JJ = J1, J2-KEEP(253) 567 J = IW(JJ) 568 IFR8 = IFR8 + 1 569 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) 570 DO K=JBDEB, JBFIN 571#if defined(RHSCOMP_BYROWS) 572 W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(K,IPOSINRHSCOMP_TMP) 573#else 574 W(IFR8+(K-JBDEB)*LIELL) = RHSCOMP(IPOSINRHSCOMP_TMP,K) 575#endif 576 ENDDO 577 ENDDO 578 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 579 CALL DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, 580 & RHSCOMP, NRHS, LRHSCOMP, 581 & W(PTRACB(STEP(INODE))), LIELL, NPIV+1, 582 & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) 583 IFR8 = IFR8 + J2-KEEP(253)-J1+1 584 ELSE 585 WRITE(*,*) "Internal error DMUMPS_BACKSLV_TRAITER_MESSAGE" 586 CALL MUMPS_ABORT() 587 ENDIF 588 IF ( KEEP(201).EQ.1 .AND. 589 & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN 590 J = NPIV / PANEL_SIZE 591 TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 592 IF (TWOBYTWO) THEN 593 CALL DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, 594 & LPANEL_POS, IW(IPOS+1+LIELL), NPIV, NPANELS, 595 & NROW_L, NBENTRIES_ALLPANELS) 596 ELSE 597 IF (NPIV.EQ.J*PANEL_SIZE) THEN 598 NPIV_LAST = NPIV 599 NBJLAST = PANEL_SIZE 600 NPANELS = J 601 ELSE 602 NPIV_LAST = (J+1)* PANEL_SIZE 603 NBJLAST = NPIV-J*PANEL_SIZE 604 NPANELS = J+1 605 ENDIF 606 NBENTRIES_ALLPANELS = 607 & int(NROW_L,8) * int(NPIV,8) 608 & - int( ( J * ( J - 1 ) ) /2,8 ) 609 & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) 610 & - int(J,8) 611 & * int(mod(NPIV, PANEL_SIZE),8) 612 & * int(PANEL_SIZE,8) 613 JJ=NPIV_LAST 614 ENDIF 615 APOSDEB = APOS + NBENTRIES_ALLPANELS 616 DO IPANEL=NPANELS,1,-1 617 IF (TWOBYTWO) THEN 618 NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) 619 BEG_PANEL = PANEL_POS(IPANEL) 620 ELSE 621 IF (JJ.EQ.NPIV_LAST) THEN 622 NBJ = NBJLAST 623 ELSE 624 NBJ = PANEL_SIZE 625 ENDIF 626 BEG_PANEL = JJ- PANEL_SIZE+1 627 ENDIF 628 LDAJ = NROW_L-BEG_PANEL+1 629 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) 630 PTWCB = PTRACB(STEP(INODE)) 631 PTWCB_PANEL = PTRACB(STEP(INODE)) + int(BEG_PANEL - 1,8) 632 IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 633 NCB_PANEL = LDAJ - NBJ 634 NCB = NROW_L - NPIV 635 IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN 636 CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, 637 & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) 638 CALL DMUMPS_PERMUTE_PANEL( 639 & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), 640 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 641 & IW(I_PIVRPTR+IPANEL-1)-1, 642 & A(APOSDEB), 643 & LDAJ, NBJ, BEG_PANEL-1) 644 ENDIF 645#if defined(MUMPS_USE_BLAS2) 646 IF ( NRHS_B == 1 ) THEN 647 IF (NCB_PANEL.NE.0) THEN 648 IF (KEEP(350).EQ.0) THEN 649 CALL dgemv( 'T', NCB_PANEL, NBJ, ALPHA, 650 & A( APOSDEB + int(NBJ,8) ), LDAJ, 651 & W( PTWCB_PANEL + int(NBJ,8) ), 652 & 1, ONE, 653 & W(PTWCB_PANEL), 1 ) 654 ELSE 655 IF (NCB_PANEL - NCB.NE. 0) THEN 656 CALL dgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, 657 & A( APOSDEB + int(NBJ,8) ), LDAJ, 658# if defined(RHSCOMP_BYROWS) 659 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), 660 & 1, ONE, 661 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) 662# else 663 & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), 664 & 1, ONE, 665 & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) 666# endif 667 ENDIF 668 IF (NCB .NE. 0) THEN 669 CALL dgemv( 'T', NCB, NBJ, ALPHA, 670 & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, 671 & W( PTWCB + NPIV ), 672 & 1, ONE, 673# if defined(RHSCOMP_BYROWS) 674 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) 675# else 676 & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) 677# endif 678 ENDIF 679 ENDIF 680 ENDIF 681 IF (KEEP(350).eq.0) THEN 682 CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 683 & W(PTWCB_PANEL), 1) 684 ELSE 685 CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 686#if defined(RHSCOMP_BYROWS) 687 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) 688#else 689 & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) 690#endif 691 ENDIF 692 ELSE 693#endif 694 IF (NCB_PANEL.NE.0) THEN 695 IF (KEEP(350).eq.0) THEN 696 CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, 697 & A(APOSDEB +int(NBJ,8)), LDAJ, 698 & W(PTWCB_PANEL+int(NBJ,8)),LIELL, 699 & ONE, W(PTWCB_PANEL),LIELL) 700 ELSE 701#if defined(RHSCOMP_BYROWS) 702 WRITE(*,*) 703 & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" 704 CALL MUMPS_ABORT() 705#else 706 IF (NCB_PANEL - NCB .NE. 0) THEN 707 CALL dgemm( 'T', 'N', NBJ, NRHS_B, 708 & NCB_PANEL-NCB, ALPHA, 709 & A(APOSDEB +int(NBJ,8)), LDAJ, 710 & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, 711 & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) 712 ENDIF 713 IF (NCB .NE. 0) THEN 714 CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, 715 & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, 716 & W( PTWCB+NPIV ), LIELL, 717 & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) 718 ENDIF 719#endif 720 ENDIF 721 ENDIF 722 IF (KEEP(350).eq.0) THEN 723 CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, 724 & A(APOSDEB), 725 & LDAJ, W(PTWCB_PANEL), LIELL) 726 ELSE 727#if defined(RHSCOMP_BYROWS) 728 WRITE(*,*) 729 & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" 730 CALL MUMPS_ABORT() 731#else 732 CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, 733 & A(APOSDEB), 734 & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) 735#endif 736 ENDIF 737#if defined(MUMPS_USE_BLAS2) 738 ENDIF 739#endif 740 IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 741 ENDDO 742 GOTO 1234 743 ENDIF 744 IF (NELIM .GT.0) THEN 745 IF ( KEEP(50) .eq. 0 ) THEN 746 IST = APOS + int(NPIV,8) * int(LIELL,8) 747 ELSE 748 IST = APOS + int(NPIV,8) * int(NPIV,8) 749 END IF 750 IF ( NRHS_B == 1 ) THEN 751 IF (KEEP(350).EQ.0) THEN 752 CALL dgemv( 'N', NPIV, NELIM, ALPHA, 753 & A( IST ), NPIV, 754 & W( NPIV + PTRACB(STEP(INODE)) ), 755 & 1, ONE, 756 & W(PTRACB(STEP(INODE))), 1 ) 757 ELSE 758 CALL dgemv( 'N', NPIV, NELIM, ALPHA, 759 & A( IST ), NPIV, 760 & W( NPIV + PTRACB(STEP(INODE)) ), 761 & 1, ONE, 762#if defined(RHSCOMP_BYROWS) 763 & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) 764#else 765 & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) 766#endif 767 ENDIF 768 ELSE 769 IF (KEEP(350).EQ.0) THEN 770 CALL dgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, 771 & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, 772 & ONE, W(PTRACB(STEP(INODE))),LIELL) 773 ELSE 774#if defined(RHSCOMP_BYROWS) 775 WRITE(*,*) 776 & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" 777 CALL MUMPS_ABORT() 778#else 779 CALL dgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, 780 & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, 781 & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) 782#endif 783 ENDIF 784 END IF 785 ENDIF 786#if defined(MUMPS_USE_BLAS2) 787 IF ( NRHS_B == 1 ) THEN 788 IF (KEEP(350).EQ.0) THEN 789 CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, 790 & W(PTRACB(STEP(INODE))),1) 791 ELSE 792 CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, 793#if defined(RHSCOMP_BYROWS) 794 & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) 795#else 796 & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) 797#endif 798 ENDIF 799 ELSE 800#endif 801 IF (KEEP(350).EQ.0) THEN 802 CALL dtrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, 803 & A(APOS), LDA, 804 & W(PTRACB(STEP(INODE))),LIELL) 805 ELSE 806#if defined(RHSCOMP_BYROWS) 807 WRITE(*,*) 808 & "Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" 809 CALL MUMPS_ABORT() 810#else 811 CALL dtrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, 812 & A(APOS), LDA, 813 & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) 814#endif 815 ENDIF 816#if defined(MUMPS_USE_BLAS2) 817 END IF 818#endif 819 1234 CONTINUE 820 IF (KEEP(201).GT.0) THEN 821 CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), 822 & A,LA,.TRUE.,IERR) 823 IF(IERR.LT.0)THEN 824 INFO(1)=IERR 825 INFO(2)=0 826 GOTO 260 827 ENDIF 828 ENDIF 829 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES 830 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(IPOS)) 831 IF (KEEP(350).EQ.0) THEN 832 IPOSINRHSCOMP_TMP = IPOSINRHSCOMP 833 DO I = 1, NPIV 834 DO K=JBDEB,JBFIN 835#if defined(RHSCOMP_BYROWS) 836 RHSCOMP( K, IPOSINRHSCOMP_TMP ) = 837 & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) 838#else 839 RHSCOMP( IPOSINRHSCOMP_TMP , K ) = 840 & W( PTRACB(STEP(INODE))+I-1 + (K-JBDEB)*LIELL ) 841#endif 842 ENDDO 843 IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 844 END DO 845 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 846 ELSE 847 WRITE(*,*)"Internal error in DMUMPS_BACKSLV_TRAITER_MESSAGE" 848 CALL MUMPS_ABORT() 849 ENDIF 850 IN = INODE 851 200 IN = FILS(IN) 852 IF (IN .GT. 0) GOTO 200 853 IF (IN .EQ. 0) THEN 854 MYLEAFE = MYLEAFE - 1 855 IF (MYLEAFE .EQ. 0) THEN 856 CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, 857 & FEUILLE, SLAVEF, KEEP ) 858 NBFINF = NBFINF - 1 859 ENDIF 860 IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 861 CALL DMUMPS_FREETOPSO(N, KEEP(28), 862 & IWCB, LIWW, W, LWC, 863 & POSWCB, POSIWCB, PTRICB, PTRACB) 864 GOTO 270 865 ENDIF 866 DO I = 0, SLAVEF - 1 867 DEJA_SEND( I ) = .FALSE. 868 END DO 869 IN = -IN 870 IF ( KEEP(237).GT.0 ) THEN 871 NO_CHILDREN = .TRUE. 872 ELSE 873 NO_CHILDREN = .FALSE. 874 ENDIF 875 DO WHILE (IN.GT.0) 876 IF ( KEEP(237).GT.0 ) THEN 877 IF (.NOT.TO_PROCESS(STEP(IN))) THEN 878 IN = FRERE(STEP(IN)) 879 CYCLE 880 ELSE 881 NO_CHILDREN = .FALSE. 882 ENDIF 883 ENDIF 884 POOL_FIRST_POS = IIPOOL 885 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), 886 & SLAVEF) .EQ. MYID) THEN 887 IPOOL(IIPOOL ) = IN 888 IIPOOL = IIPOOL + 1 889 ELSE 890 PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), 891 & SLAVEF ) 892 IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 893 110 CONTINUE 894 CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, 895 & LIELL, LIELL-KEEP(253), 896 & IW( POSINDICES ) , 897 & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, 898 & RHSCOMP(1, 1), NRHS, LRHSCOMP, 899 & IPOSINRHSCOMP, NPIV, KEEP, 900 & PROCDEST, NOEUD, COMM, IERR ) 901 IF ( IERR .EQ. -1 ) THEN 902 CALL DMUMPS_BACKSLV_RECV_AND_TREAT( 903 & .FALSE., FLAG, 904 & BUFR, LBUFR, LBUFR_BYTES, 905 & MYID, SLAVEF, COMM, 906 & N, IWCB, LIWW, POSIWCB, 907 & W, LWC, POSWCB, 908 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 909 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, 910 & FRERE, FILS, PROCNODE_STEPS, PLEFTW, 911 & KEEP, KEEP8, DKEEP, 912 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 913 & NRHS, MTYPE, 914 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 915 & , TO_PROCESS, SIZE_TO_PROCESS 916 & , FROM_PP ) 917 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 918 GOTO 110 919 ELSE IF ( IERR .eq. -2 ) THEN 920 INFO(1) = -17 921 INFO(2) = LIELL * NRHS_B * KEEP(35) + 922 & ( LIELL + 4 ) * KEEP(34) 923 GOTO 260 924 ELSE IF ( IERR .eq. -3 ) THEN 925 INFO(1) = -20 926 INFO(2) = LIELL * NRHS_B * KEEP(35) + 927 & ( LIELL + 4 ) * KEEP(34) 928 GOTO 260 929 END IF 930 DEJA_SEND( PROCDEST ) = .TRUE. 931 END IF 932 END IF 933 IN = FRERE( STEP( IN ) ) 934 END DO 935 IF (NO_CHILDREN) THEN 936 MYLEAFE = MYLEAFE - 1 937 IF (MYLEAFE .EQ. 0) THEN 938 CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, 939 & COMM, FEUILLE, SLAVEF, KEEP ) 940 NBFINF = NBFINF - 1 941 ENDIF 942 IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 943 CALL DMUMPS_FREETOPSO( N, KEEP(28), 944 & IWCB, LIWW, W, LWC, 945 & POSWCB, POSIWCB, PTRICB, PTRACB) 946 GOTO 270 947 ENDIF 948 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 949 TMP=IPOOL(POOL_FIRST_POS+I-1) 950 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 951 IPOOL(IIPOOL-I)=TMP 952 ENDDO 953 IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 954 CALL DMUMPS_FREETOPSO( N, KEEP(28), 955 & IWCB, LIWW, W, LWC, 956 & POSWCB, POSIWCB, PTRICB, PTRACB) 957 END IF 958 ELSE IF (MSGTAG.EQ.TERREUR) THEN 959 INFO(1) = -001 960 INFO(2) = MSGSOU 961 GO TO 270 962 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. 963 & (MSGTAG.EQ.TAG_DUMMY) ) THEN 964 GO TO 270 965 ELSE 966 INFO(1) = -100 967 INFO(2) = MSGTAG 968 GOTO 260 969 ENDIF 970 GO TO 270 971 260 CONTINUE 972 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 973 270 CONTINUE 974 DEALLOCATE(DEJA_SEND) 975 RETURN 976 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 977 RETURN 978 END SUBROUTINE DMUMPS_BACKSLV_TRAITER_MESSAGE 979 SUBROUTINE DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, 980 & LEN_PANEL_POS, INDICES, NPIV, 981 & NPANELS, NFRONT_OR_NASS, 982 & NBENTRIES_ALLPANELS) 983 IMPLICIT NONE 984 INTEGER, intent (in) :: PANEL_SIZE, NPIV 985 INTEGER, intent (in) :: INDICES(NPIV) 986 INTEGER, intent (in) :: LEN_PANEL_POS 987 INTEGER, intent (out) :: NPANELS 988 INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) 989 INTEGER, intent (in) :: NFRONT_OR_NASS 990 INTEGER(8), intent(out):: NBENTRIES_ALLPANELS 991 INTEGER NPANELS_MAX, I, NBeff 992 INTEGER(8) :: NBENTRIES_THISPANEL 993 NBENTRIES_ALLPANELS = 0_8 994 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE 995 IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN 996 WRITE(*,*) "Error 1 in DMUMPS_BUILD_PANEL_POS", 997 & LEN_PANEL_POS,NPANELS_MAX 998 CALL MUMPS_ABORT() 999 ENDIF 1000 I = 1 1001 NPANELS = 0 1002 IF (I .GT. NPIV) RETURN 1003 10 CONTINUE 1004 NPANELS = NPANELS + 1 1005 PANEL_POS(NPANELS) = I 1006 NBeff = min(PANEL_SIZE, NPIV-I+1) 1007 IF ( INDICES(I+NBeff-1) < 0) THEN 1008 NBeff=NBeff+1 1009 ENDIF 1010 NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) 1011 NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL 1012 I=I+NBeff 1013 IF ( I .LE. NPIV ) GOTO 10 1014 PANEL_POS(NPANELS+1)=NPIV+1 1015 RETURN 1016 END SUBROUTINE DMUMPS_BUILD_PANEL_POS 1017