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_SOL_S(N, A, LA, IW, LIW, W, LWC, 14 & NRHS, 15 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, 16 & PTRICB, PTRACB, IWCB, LIWW, W2, 17 & NE_STEPS, NA, LNA, STEP, 18 & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, 19 & MYLEAF, ICNTL, INFO, 20 & PROCNODE_STEPS, 21 & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, 22 & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, 23 & 24 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS 25 & , TO_PROCESS, SIZE_TO_PROCESS 26 & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP 27 & ) 28 USE CMUMPS_OOC 29 USE CMUMPS_BUF 30 IMPLICIT NONE 31 INTEGER MTYPE 32 INTEGER(8) :: LA 33 INTEGER(8), intent(in) :: LWC 34 INTEGER N,LIW,LIWW,LPOOL,LNA 35 INTEGER SLAVEF,MYLEAF,COMM,MYID 36 INTEGER LPANEL_POS 37 INTEGER KEEP( 500 ) 38 INTEGER(8) KEEP8(150) 39 REAL, INTENT(INOUT) :: DKEEP(230) 40 INTEGER PROCNODE_STEPS(KEEP(28)) 41 INTEGER NA(LNA),NE_STEPS(KEEP(28)) 42 INTEGER IPOOL(LPOOL) 43 INTEGER PANEL_POS(LPANEL_POS) 44 INTEGER ICNTL(40), INFO(40) 45 INTEGER PTRIST(KEEP(28)), 46 & PTRICB(KEEP(28)) 47 INTEGER(8) :: PTRACB(KEEP(28)) 48 INTEGER(8) :: PTRFAC(KEEP(28)) 49 INTEGER NRHS 50 COMPLEX A(LA), W(LWC) 51 COMPLEX W2(KEEP(133)) 52 INTEGER IW(LIW),IWCB(LIWW) 53 INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) 54 INTEGER LBUFR, LBUFR_BYTES 55 INTEGER BUFR(LBUFR) 56 INTEGER ISTEP_TO_INIV2(KEEP(71)), 57 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 58 INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) 59#if defined(RHSCOMP_BYROWS) 60 COMPLEX RHSCOMP(NRHS,LRHSCOMP) 61#else 62 COMPLEX RHSCOMP(LRHSCOMP,NRHS) 63#endif 64 INTEGER(8), intent(in) :: LRHS_ROOT 65 COMPLEX RHS_ROOT( LRHS_ROOT ) 66 INTEGER, intent(in) :: SIZE_TO_PROCESS 67 LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) 68 LOGICAL, intent(in) :: DO_NBSPARSE 69 INTEGER, intent(in) :: LRHS_BOUNDS 70 INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) 71 LOGICAL, intent(in) :: FROM_PP 72 INTEGER MUMPS_PROCNODE 73 EXTERNAL MUMPS_PROCNODE 74 INCLUDE 'mpif.h' 75 INCLUDE 'mumps_tags.h' 76 INTEGER IERR 77 LOGICAL FLAG 78 INTEGER POSIWCB,K 79 INTEGER(8) :: APOS, IST 80 INTEGER(8) :: IFR 81 INTEGER NPIV 82 INTEGER IPOS,LIELL,NELIM,JJ,I 83 INTEGER J1,J2,J,NCB,NBFINF 84 INTEGER NBLEAF,INODE,NBROOT,NROOT,NBFILS 85 INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP 86 INTEGER III,IIPOOL,MYLEAFE 87 INTEGER NSLAVES 88 INTEGER JBDEB, JBFIN, NRHS_B 89 COMPLEX ALPHA,ONE,ZERO 90 PARAMETER (ZERO=(0.0E0,0.0E0), 91 & ONE=(1.0E0,0.0E0), 92 & ALPHA=(-1.0E0,0.0E0)) 93 LOGICAL BLOQ,DEBUT 94 INTEGER PROCDEST, DEST 95 INTEGER POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL, 96 & IPOSINRHSCOMP_TMP 97 INTEGER DUMMY(1) 98 INTEGER(8) :: POSWCB, PLEFTW, PTWCB 99 INTEGER Offset, EffectiveSize, ISLAVE, FirstIndex 100 LOGICAL LTLEVEL2, IN_SUBTREE 101 INTEGER TYPENODE 102 INCLUDE 'mumps_headers.h' 103 LOGICAL BLOCK_SEQUENCE 104 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR 105 LOGICAL MUST_BE_PERMUTED 106 LOGICAL NO_CHILDREN 107 LOGICAL Exploit_Sparsity, AM1 108 DOUBLE PRECISION :: TIME_TMP 109 LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND 110 INTEGER :: allocok 111 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS 112 INTEGER(8) :: PTWCB_PANEL 113 INTEGER LDAJ, NBJ, LIWFAC, 114 & NBJLAST, NPIV_LAST, PANEL_SIZE, 115 & NCB_PANEL, TYPEF 116 INTEGER BEG_PANEL 117 LOGICAL TWOBYTWO 118 INTEGER NPANELS, IPANEL 119 LOGICAL MUMPS_IN_OR_ROOT_SSARBR 120 INTEGER MUMPS_TYPENODE 121 EXTERNAL cgemv, ctrsv, ctrsm, cgemm, 122 & MUMPS_TYPENODE, 123 & MUMPS_IN_OR_ROOT_SSARBR 124 DUMMY(1)=0 125 KEEP(266)=0 126 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) 127 if(allocok.ne.0) then 128 WRITE(6,*) ' Allocation error of DEJA_SEND in ' 129 & //'routine CMUMPS_SOL_S ' 130 INFO(1)=-13 131 INFO(2)=SLAVEF 132 endif 133 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) 134 IF ( INFO(1) .LT.0 ) GOTO 340 135 PLEFTW = 1_8 136 POSIWCB = LIWW 137 POSWCB = LWC 138 NROOT = 0 139 NBLEAF = NA(1) 140 NBROOT = NA(2) 141 DO I = NBROOT, 1, -1 142 INODE = NA(NBLEAF+I+2) 143 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), 144 & SLAVEF) .EQ. MYID) THEN 145 NROOT = NROOT + 1 146 IPOOL(NROOT) = INODE 147 ENDIF 148 END DO 149 III = 1 150 IIPOOL = NROOT + 1 151 BLOCK_SEQUENCE = .FALSE. 152 Exploit_Sparsity = .FALSE. 153 AM1 = .FALSE. 154 IF (KEEP(235).NE.0) Exploit_Sparsity = .TRUE. 155 IF (KEEP(237).NE.0) AM1 = .TRUE. 156 NO_CHILDREN = .FALSE. 157 IF (Exploit_Sparsity .OR. AM1) MYLEAF = -1 158 IF (MYLEAF .EQ. -1) THEN 159 MYLEAF = 0 160 DO I=1, NBLEAF 161 INODE=NA(I+2) 162 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), 163 & SLAVEF) .EQ. MYID) THEN 164 MYLEAF = MYLEAF + 1 165 ENDIF 166 ENDDO 167 ENDIF 168 MYLEAFE=MYLEAF 169 NBFINF = SLAVEF 170 IF (MYLEAFE .EQ. 0) THEN 171 CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, FEUILLE, 172 & SLAVEF, KEEP) 173 NBFINF = NBFINF - 1 174 IF (NBFINF .EQ. 0) THEN 175 GOTO 340 176 ENDIF 177 ENDIF 178 50 CONTINUE 179 BLOQ = ( ( III .EQ. IIPOOL ) 180 & ) 181 CALL CMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, 182 & LBUFR_BYTES, MYID, SLAVEF, COMM, 183 & N, IWCB, LIWW, POSIWCB, 184 & W, LWC, POSWCB, 185 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 186 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 187 & STEP, FRERE, FILS, PROCNODE_STEPS, 188 & PLEFTW, KEEP,KEEP8, DKEEP, 189 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 190 & NRHS, MTYPE, 191 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 192 & , TO_PROCESS, SIZE_TO_PROCESS 193 & , FROM_PP ) 194 IF ( INFO(1) .LT. 0 ) GOTO 340 195 IF ( .NOT. FLAG ) THEN 196 IF (III .NE. IIPOOL) THEN 197 INODE = IPOOL(IIPOOL-1) 198 IIPOOL = IIPOOL - 1 199 GO TO 60 200 ENDIF 201 END IF 202 IF ( NBFINF .eq. 0 ) GOTO 340 203 GOTO 50 204 IF (MYID.EQ.0) write(6,*) "BWD: process INODE=", INODE 205 60 CONTINUE 206 IF (DO_NBSPARSE) THEN 207 JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) 208 JBFIN= RHS_BOUNDS(2*STEP(INODE)) 209 NRHS_B = JBFIN-JBDEB+1 210 ELSE 211 JBDEB = 1 212 JBFIN = NRHS 213 NRHS_B = NRHS 214 ENDIF 215 IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN 216 IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) 217 NPIV = IW(IPOS+3) 218 LIELL = IW(IPOS) + NPIV 219 IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) 220 IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN 221 J1 = IPOS + LIELL + 1 222 J2 = IPOS + LIELL + NPIV 223 ELSE 224 J1 = IPOS + 1 225 J2 = IPOS + NPIV 226 END IF 227 IFR = 0_8 228 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 229 IF (KEEP(350).EQ.0) THEN 230 IPOSINRHSCOMP_TMP = IPOSINRHSCOMP 231 DO JJ = J1, J2 232 IFR = IFR + 1_8 233 DO K=JBDEB, JBFIN 234#if defined(RHSCOMP_BYROWS) 235 RHSCOMP(K,IPOSINRHSCOMP_TMP) = RHS_ROOT(IFR+NPIV*(K-1)) 236#else 237 RHSCOMP(IPOSINRHSCOMP_TMP,K) = RHS_ROOT(IFR+NPIV*(K-1)) 238#endif 239 END DO 240 IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 241 END DO 242 ELSE 243 CALL CMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, 244 & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, 245 & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) 246 ENDIF 247 IN = INODE 248 270 IN = FILS(IN) 249 IF (IN .GT. 0) GOTO 270 250 IF (IN .EQ. 0) THEN 251 MYLEAFE = MYLEAFE - 1 252 IF (MYLEAFE .EQ. 0) THEN 253 CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, 254 & FEUILLE, SLAVEF, KEEP ) 255 NBFINF = NBFINF - 1 256 IF (NBFINF .EQ. 0) GOTO 340 257 ENDIF 258 GOTO 50 259 ENDIF 260 IF = -IN 261 LONG = NPIV 262 NBFILS = NE_STEPS(STEP(INODE)) 263 IF ( AM1 ) THEN 264 I = NBFILS 265 NBFILS = 0 266 DO WHILE (I.GT.0) 267 IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 268 IF = FRERE(STEP(IF)) 269 I = I -1 270 ENDDO 271 IF (NBFILS.EQ.0) THEN 272 NO_CHILDREN = .TRUE. 273 ELSE 274 NO_CHILDREN = .FALSE. 275 ENDIF 276 IF = -IN 277 ENDIF 278 DEBUT = .TRUE. 279 DO I = 0, SLAVEF - 1 280 DEJA_SEND( I ) = .FALSE. 281 END DO 282 POOL_FIRST_POS=IIPOOL 283 DO I = 1, NBFILS 284 IF ( AM1 ) THEN 285 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 286 IF = FRERE(STEP(IF)) 287 GOTO 1030 288 ENDIF 289 NO_CHILDREN = .FALSE. 290 ENDIF 291 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),SLAVEF) 292 & .EQ. MYID) THEN 293 IPOOL(IIPOOL) = IF 294 IIPOOL = IIPOOL + 1 295 ELSE 296 PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), 297 & SLAVEF) 298 IF (.NOT. DEJA_SEND( PROCDEST )) THEN 299 600 CONTINUE 300 CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, 301 & LONG, LONG, IW( J1 ), 302 & RHS_ROOT( 1+NPIV*(JBDEB-1) ), 303 & JBDEB, JBFIN, 304 & RHSCOMP(1, 1), NRHS, LRHSCOMP, 305 & IPOSINRHSCOMP, NPIV, 306 & KEEP, PROCDEST, 307 & NOEUD, COMM, IERR ) 308 IF ( IERR .EQ. -1 ) THEN 309 CALL CMUMPS_BACKSLV_RECV_AND_TREAT( 310 & .FALSE., FLAG, 311 & BUFR, LBUFR, LBUFR_BYTES, 312 & MYID, SLAVEF, COMM, 313 & N, IWCB, LIWW, POSIWCB, 314 & W, LWC, POSWCB, 315 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 316 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 317 & STEP, FRERE, FILS, PROCNODE_STEPS, 318 & PLEFTW, KEEP,KEEP8, DKEEP, 319 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 320 & NRHS, MTYPE, 321 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 322 & , TO_PROCESS, SIZE_TO_PROCESS 323 & , FROM_PP ) 324 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 325 GOTO 600 326 ELSE IF ( IERR .EQ. -2 ) THEN 327 INFO( 1 ) = -17 328 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + 329 & ( LONG + 4 ) * KEEP(34) 330 GOTO 330 331 ELSE IF ( IERR .EQ. -3 ) THEN 332 INFO( 1 ) = -20 333 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + 334 & ( LONG + 4 ) * KEEP(34) 335 GOTO 330 336 END IF 337 DEJA_SEND( PROCDEST ) = .TRUE. 338 END IF 339 IF ( IERR .NE. 0 ) CALL MUMPS_ABORT() 340 ENDIF 341 IF = FRERE(STEP(IF)) 342 ENDDO 343 IF (AM1 .AND.NO_CHILDREN) THEN 344 MYLEAFE = MYLEAFE - 1 345 IF (MYLEAFE .EQ. 0) THEN 346 CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, 347 & FEUILLE, SLAVEF, KEEP ) 348 NBFINF = NBFINF - 1 349 IF (NBFINF .EQ. 0) GOTO 340 350 GOTO 50 351 ENDIF 352 ENDIF 353 IF (IIPOOL.NE.POOL_FIRST_POS) THEN 354 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 355 TMP=IPOOL(POOL_FIRST_POS+I-1) 356 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 357 IPOOL(IIPOOL-I)=TMP 358 ENDDO 359 ENDIF 360 GOTO 50 361 END IF 362 IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( 363 & PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 364 TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), 365 & SLAVEF) 366 LTLEVEL2= ( 367 & (TYPENODE .eq.2 ) .AND. 368 & (MTYPE.NE.1) ) 369 NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) 370 IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN 371 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 372 LIELL = IW(IPOS-2)+IW(IPOS+1) 373 NELIM = IW(IPOS-1) 374 IPOS = IPOS + 1 375 NPIV = IW(IPOS) 376 NCB = LIELL - NPIV - NELIM 377 IPOS = IPOS + 2 378 NSLAVES = IW( IPOS ) 379 Offset = 0 380 IPOS = IPOS + NSLAVES 381 IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES 382 IF ( POSIWCB - 2 .LT. 0 .or. 383 & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN 384 CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, 385 & POSWCB, POSIWCB, PTRICB, PTRACB) 386 IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN 387 INFO( 1 ) = -11 388 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, 389 & INFO(2)) 390 GOTO 330 391 END IF 392 IF ( POSIWCB - 2 .LT. 0 ) THEN 393 INFO( 1 ) = -14 394 INFO( 2 ) = 2 - POSIWCB 395 GO TO 330 396 END IF 397 END IF 398 POSIWCB = POSIWCB - 2 399 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) 400 PTRICB(STEP( INODE )) = POSIWCB + 1 401 PTRACB(STEP( INODE )) = POSWCB + 1_8 402 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B 403 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 404 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 405 POSINDICES = IPOS + LIELL + 1 406 ELSE 407 POSINDICES = IPOS + 1 408 END IF 409 IF ( NCB.EQ.0 ) THEN 410 write(6,*) ' Internal Error type 2 node with no CB ' 411 CALL MUMPS_ABORT() 412 ENDIF 413 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 414 J1 = IPOS + LIELL + NPIV + NELIM +1 415 J2 = IPOS + 2 * LIELL 416 ELSE 417 J1 = IPOS + NPIV + NELIM +1 418 J2 = IPOS + LIELL 419 END IF 420 IFR = PTRACB(STEP( INODE )) - 1_8 421 IF (KEEP(350).EQ.0) THEN 422 DO JJ = J1, J2 - KEEP(253) 423 J = IW(JJ) 424 IFR = IFR + 1_8 425 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) 426 DO K=JBDEB, JBFIN 427 W(IFR+int(K-JBDEB,8)*int(NCB,8)) = 428#if defined(RHSCOMP_BYROWS) 429 & RHSCOMP(K,IPOSINRHSCOMP_TMP) 430#else 431 & RHSCOMP(IPOSINRHSCOMP_TMP,K) 432#endif 433 ENDDO 434 ENDDO 435 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 436 CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, 437 & RHSCOMP, NRHS, LRHSCOMP, 438 & W(PTRACB(STEP(INODE))), NCB, 1, 439 & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) 440 IFR = IFR + int(J2-KEEP(253)-J1+1,8) 441 ELSE 442 WRITE(*,*) "Internal error CMUMPS_SOL_S" 443 CALL MUMPS_ABORT() 444 END IF 445 IF (KEEP(252).NE.0) THEN 446 DO JJ = J2-KEEP(253)+1, J2 447 IFR = IFR + 1_8 448 DO K=JBDEB, JBFIN 449 IF (K.EQ.JJ-J2+KEEP(253)) THEN 450 W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ALPHA 451 ELSE 452 W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ZERO 453 ENDIF 454 ENDDO 455 ENDDO 456 ENDIF 457 DO ISLAVE = 1, NSLAVES 458 CALL MUMPS_BLOC2_GET_SLAVE_INFO( 459 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 460 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 461 & ISLAVE, NCB, 462 & NSLAVES, 463 & EffectiveSize, 464 & FirstIndex ) 465 500 CONTINUE 466 DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) 467 CALL CMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, 468 & W(Offset+PTRACB(STEP(INODE))), 469 & EffectiveSize, 470 & NCB, DEST, 471 & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, 472 & KEEP, COMM, IERR ) 473 IF ( IERR .EQ. -1 ) THEN 474 CALL CMUMPS_BACKSLV_RECV_AND_TREAT( 475 & .FALSE., FLAG, 476 & BUFR, LBUFR, LBUFR_BYTES, 477 & MYID, SLAVEF, COMM, 478 & N, IWCB, LIWW, POSIWCB, 479 & W, LWC, POSWCB, 480 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 481 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 482 & STEP, FRERE, FILS, 483 & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, 484 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 485 & NRHS, MTYPE, 486 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 487 & , TO_PROCESS, SIZE_TO_PROCESS 488 & , FROM_PP ) 489 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 490 GOTO 500 491 ELSE IF ( IERR .EQ. -2 ) THEN 492 INFO( 1 ) = -17 493 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + 494 & 2 * KEEP(34) 495 GOTO 330 496 ELSE IF ( IERR .EQ. -3 ) THEN 497 INFO( 1 ) = -20 498 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + 499 & 2 * KEEP(34) 500 GOTO 330 501 END IF 502 Offset = Offset + EffectiveSize 503 END DO 504 IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 505 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, 506 & POSWCB,POSIWCB,PTRICB,PTRACB) 507 GOTO 50 508 ENDIF 509 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 510 LIELL = IW(IPOS-2)+IW(IPOS+1) 511 NELIM = IW(IPOS-1) 512 IPOS = IPOS + 1 513 NPIV = IW(IPOS) 514 NCB = LIELL - NPIV 515 IPOS = IPOS + 1 516 IF (KEEP(201).GT.0) THEN 517 CALL CMUMPS_SOLVE_GET_OOC_NODE( 518 & INODE,PTRFAC,KEEP,A,LA,STEP, 519 & KEEP8,N,MUST_BE_PERMUTED,IERR) 520 IF(IERR.LT.0)THEN 521 INFO(1)=IERR 522 INFO(2)=0 523 GOTO 330 524 ENDIF 525 ENDIF 526 APOS = PTRFAC(IW(IPOS)) 527 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) 528 IPOS = IPOS + 1 + NSLAVES 529 IF (KEEP(201).EQ.1) THEN 530 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 531 IF (MTYPE.NE.1) THEN 532 TYPEF = TYPEF_L 533 ELSE 534 TYPEF = TYPEF_U 535 ENDIF 536 PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE( LIELL ) 537 IF (KEEP(50).NE.1) THEN 538 CALL CMUMPS_OOC_PP_CHECK_PERM_FREED( 539 & IW(IPOS+1+2*LIELL), 540 & MUST_BE_PERMUTED ) 541 ENDIF 542 ENDIF 543 LONG = 0 544 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 545 J1 = IPOS + LIELL + 1 546 J2 = IPOS + NPIV + LIELL 547 ELSE 548 J1 = IPOS + 1 549 J2 = IPOS + NPIV 550 ENDIF 551 IF (IN_SUBTREE) THEN 552 PTWCB = PLEFTW 553 IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN 554 CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, 555 & POSWCB, POSIWCB, PTRICB, PTRACB) 556 IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN 557 INFO(1) = -11 558 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, 559 & INFO(2)) 560 GOTO 330 561 END IF 562 END IF 563 ELSE 564 IF ( POSIWCB - 2 .LT. 0 .or. 565 & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN 566 CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, 567 & POSWCB, POSIWCB, PTRICB, PTRACB) 568 IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN 569 INFO( 1 ) = -11 570 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- 571 & POSWCB-PLEFTW+1_8, 572 & INFO(2) ) 573 GOTO 330 574 END IF 575 IF ( POSIWCB - 2 .LT. 0 ) THEN 576 INFO( 1 ) = -14 577 INFO( 2 ) = 2 - POSIWCB 578 GO TO 330 579 END IF 580 END IF 581 POSIWCB = POSIWCB - 2 582 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) 583 PTRICB(STEP( INODE )) = POSIWCB + 1 584 PTRACB(STEP( INODE )) = POSWCB + 1_8 585 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B 586 IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 587 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN 588 POSINDICES = IPOS + LIELL + 1 589 ELSE 590 POSINDICES = IPOS + 1 591 END IF 592 PTWCB = PTRACB(STEP( INODE )) 593 ENDIF 594 IF (J2.GE.J1) THEN 595 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 596 ELSE 597 IPOSINRHSCOMP = -99999 598 ENDIF 599 IF (J2.GE.J1) THEN 600 DO K=JBDEB, JBFIN 601 IF (KEEP(350).eq.0) THEN 602 IF (KEEP(252).NE.0) THEN 603 DO JJ = J1, J2 604 W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = ZERO 605 ENDDO 606 ELSE 607 DO JJ = J1, J2 608#if defined(RHSCOMP_BYROWS) 609 W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = 610 & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) 611#else 612 W(PTWCB+JJ-J1+(K-JBDEB)*LIELL) = 613 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 614#endif 615 ENDDO 616 ENDIF 617 ELSE IF (KEEP(350).eq.1.OR.KEEP(350).EQ.2) THEN 618 IF (KEEP(252).NE.0) THEN 619 DO JJ = J1, J2 620 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO 621 ENDDO 622 ENDIF 623 ELSE 624 WRITE(*,*) "Internal error CMUMPS_SOL_BWD" 625 CALL MUMPS_ABORT() 626 ENDIF 627 END DO 628 ENDIF 629 IFR = PTWCB + int(NPIV - 1,8) 630 IF ( LIELL .GT. NPIV ) THEN 631 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN 632 J1 = IPOS + LIELL + NPIV + 1 633 J2 = IPOS + 2 * LIELL 634 ELSE 635 J1 = IPOS + NPIV + 1 636 J2 = IPOS + LIELL 637 END IF 638 IF (KEEP(350).EQ.0) THEN 639 DO JJ = J1, J2-KEEP(253) 640 J = IW(JJ) 641 IFR = IFR + 1_8 642 IPOSINRHSCOMP_TMP = abs(POSINRHSCOMP_BWD(J)) 643 DO K=JBDEB, JBFIN 644 W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = 645#if defined(RHSCOMP_BYROWS) 646 & RHSCOMP(K,IPOSINRHSCOMP_TMP) 647#else 648 & RHSCOMP(IPOSINRHSCOMP_TMP,K) 649#endif 650 ENDDO 651 ENDDO 652 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 653 CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, 654 & RHSCOMP, NRHS, LRHSCOMP, 655 & W(PTWCB), LIELL, NPIV+1, 656 & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) 657 IFR = IFR + int(J2-KEEP(253)-J1+1,8) 658 ELSE 659 WRITE(*,*) "Internal error CMUMPS_SOL_S" 660 CALL MUMPS_ABORT() 661 ENDIF 662 IF (KEEP(252).NE.0) THEN 663 DO JJ = J2-KEEP(253)+1, J2 664 IFR = IFR + 1_8 665 DO K=JBDEB, JBFIN 666 IF (K.EQ.JJ-J2+KEEP(253)) THEN 667 W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA 668 ELSE 669 W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ZERO 670 ENDIF 671 ENDDO 672 ENDDO 673 ENDIF 674 NCB = LIELL - NPIV 675 IF (NPIV .EQ. 0) GOTO 160 676 ENDIF 677 IF (KEEP(201).EQ.1) THEN 678 J = NPIV / PANEL_SIZE 679 TWOBYTWO = KEEP(50).EQ.2 .AND. 680 & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. 681 & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) 682 IF (TWOBYTWO) THEN 683 CALL CMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, 684 & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, 685 & NBENTRIES_ALLPANELS) 686 ELSE 687 IF (NPIV.EQ.J*PANEL_SIZE) THEN 688 NPIV_LAST = NPIV 689 NBJLAST = PANEL_SIZE 690 NPANELS = J 691 ELSE 692 NPIV_LAST = (J+1)* PANEL_SIZE 693 NBJLAST = NPIV-J*PANEL_SIZE 694 NPANELS = J+1 695 ENDIF 696 NBENTRIES_ALLPANELS = 697 & int(LIELL,8) * int(NPIV,8) 698 & - int( ( J * ( J - 1 ) ) /2,8 ) 699 & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) 700 & - int(J,8) 701 & * int(mod(NPIV, PANEL_SIZE),8) 702 & * int(PANEL_SIZE,8) 703 JJ=NPIV_LAST 704 ENDIF 705 APOSDEB = APOS + NBENTRIES_ALLPANELS 706 DO IPANEL = NPANELS, 1, -1 707 IF (TWOBYTWO) THEN 708 NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) 709 BEG_PANEL = PANEL_POS(IPANEL) 710 ELSE 711 IF (JJ.EQ.NPIV_LAST) THEN 712 NBJ = NBJLAST 713 ELSE 714 NBJ = PANEL_SIZE 715 ENDIF 716 BEG_PANEL = JJ- PANEL_SIZE+1 717 ENDIF 718 LDAJ = LIELL-BEG_PANEL+1 719 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) 720 PTWCB_PANEL = PTWCB + int(BEG_PANEL - 1,8) 721 IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 722 NCB_PANEL = LDAJ - NBJ 723 IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN 724 CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, 725 & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) 726 IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN 727 MUST_BE_PERMUTED=.FALSE. 728 ELSE 729 CALL CMUMPS_PERMUTE_PANEL( 730 & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), 731 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 732 & IW(I_PIVRPTR+IPANEL-1)-1, 733 & A(APOSDEB), 734 & LDAJ, NBJ, BEG_PANEL-1) 735 ENDIF 736 ENDIF 737#if defined(MUMPS_USE_BLAS2) 738 IF ( NRHS_B == 1 ) THEN 739 IF (NCB_PANEL.NE.0) THEN 740 IF (KEEP(350).EQ.0) THEN 741 CALL cgemv( 'T', NCB_PANEL, NBJ, ALPHA, 742 & A( APOSDEB + int(NBJ,8) ), LDAJ, 743 & W( PTWCB_PANEL+int(NBJ,8) ), 744 & 1, ONE, 745 & W(PTWCB_PANEL), 1 ) 746 ELSE 747 IF (NCB_PANEL - NCB.NE. 0) THEN 748 CALL cgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, 749 & A( APOSDEB + int(NBJ,8) ), LDAJ, 750# if defined(RHSCOMP_BYROWS) 751 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL+NBJ), 752 & 1, ONE, 753 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) 754# else 755 & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), 756 & 1, ONE, 757 & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) 758# endif 759 ENDIF 760 IF (NCB .NE. 0) THEN 761 CALL cgemv( 'T', NCB, NBJ, ALPHA, 762 & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, 763 & W( PTWCB + int(NPIV,8) ), 764 & 1, ONE, 765# if defined(RHSCOMP_BYROWS) 766 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1 ) 767# else 768 & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) 769# endif 770 ENDIF 771 ENDIF 772 ENDIF 773 IF (MTYPE.NE.1) THEN 774 IF (KEEP(350).eq.0) THEN 775 CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 776 & W(PTWCB_PANEL), 1) 777 ELSE 778 CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, 779#if defined(RHSCOMP_BYROWS) 780 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) 781#else 782 & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) 783#endif 784 ENDIF 785 ELSE 786 IF (KEEP(350).eq.0) THEN 787 CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, 788 & W(PTWCB_PANEL), 1) 789 ELSE 790 CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, 791#if defined(RHSCOMP_BYROWS) 792 & RHSCOMP(JBDEB,IPOSINRHSCOMP_PANEL), 1) 793#else 794 & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) 795#endif 796 ENDIF 797 ENDIF 798 ELSE 799#endif 800 IF (NCB_PANEL.NE.0) THEN 801 IF (KEEP(350).eq.0) THEN 802 CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB_PANEL, ALPHA, 803 & A(APOSDEB +int(NBJ,8)), LDAJ, 804 & W(PTWCB_PANEL+int(NBJ,8)),LIELL, 805 & ONE, W(PTWCB_PANEL),LIELL) 806 ELSE 807#if defined(RHSCOMP_BYROWS) 808 WRITE(*,*) "Internal error in CMUMPS_SOL_S" 809 CALL MUMPS_ABORT() 810#else 811 IF (NCB_PANEL - NCB .NE. 0) THEN 812 CALL cgemm( 'T', 'N', NBJ, NRHS_B, 813 & NCB_PANEL-NCB, ALPHA, 814 & A(APOSDEB +int(NBJ,8)), LDAJ, 815 & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, 816 & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) 817 ENDIF 818 IF (NCB .NE. 0) THEN 819 CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, 820 & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, 821 & W( PTWCB+int(NPIV,8) ), LIELL, 822 & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) 823 ENDIF 824#endif 825 ENDIF 826 ENDIF 827 IF (MTYPE.NE.1) THEN 828 IF (KEEP(350).eq.0) THEN 829 CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, 830 & A(APOSDEB), 831 & LDAJ, W(PTWCB_PANEL), LIELL) 832 ELSE 833#if defined(RHSCOMP_BYROWS) 834 WRITE(*,*) "Internal error in CMUMPS_SOL_S" 835 CALL MUMPS_ABORT() 836#else 837 CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, 838 & A(APOSDEB), 839 & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) 840#endif 841 ENDIF 842 ELSE 843 IF (KEEP(350).eq.0) THEN 844 CALL ctrsm('L','L','T','N',NBJ, NRHS_B, ONE, 845 & A(APOSDEB), 846 & LDAJ, W(PTWCB_PANEL), LIELL) 847 ELSE 848#if defined(RHSCOMP_BYROWS) 849 WRITE(*,*) "Internal error in CMUMPS_SOL_S" 850 CALL MUMPS_ABORT() 851#else 852 CALL ctrsm('L','L','T','N',NBJ, NRHS_B, ONE, 853 & A(APOSDEB), 854 & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) 855#endif 856 ENDIF 857 ENDIF 858#if defined(MUMPS_USE_BLAS2) 859 ENDIF 860#endif 861 IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 862 ENDDO 863 ENDIF 864 IF (KEEP(201).EQ.0.OR.KEEP(201).EQ.2)THEN 865 IF ( LIELL .GT. NPIV ) THEN 866 IF ( MTYPE .eq. 1 ) THEN 867 IST = APOS + int(NPIV,8) 868#if defined(MUMPS_USE_BLAS2) 869 IF (NRHS_B == 1) THEN 870 IF (KEEP(350).EQ.0) THEN 871 CALL cgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, 872 & W(PTWCB+int(NPIV,8)), 1, 873 & ONE, 874 & W(PTWCB), 1 ) 875 ELSE 876 CALL cgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, 877 & W(PTWCB+int(NPIV,8)), 1, 878 & ONE, 879#if defined(RHSCOMP_BYROWS) 880 & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) 881#else 882 & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) 883#endif 884 ENDIF 885 ELSE 886#endif 887 IF (KEEP(350).EQ.0) THEN 888 CALL cgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, 889 & A(IST), LIELL, 890 & W(PTWCB+int(NPIV,8)), LIELL, ONE, 891 & W(PTWCB), LIELL) 892 ELSE 893#if defined(RHSCOMP_BYROWS) 894 WRITE(*,*) "Internal error in CMUMPS_SOL_S" 895 CALL MUMPS_ABORT() 896#else 897 CALL cgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, 898 & A(IST), LIELL, 899 & W(PTWCB+int(NPIV,8)), LIELL, ONE, 900 & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) 901#endif 902 ENDIF 903#if defined(MUMPS_USE_BLAS2) 904 ENDIF 905#endif 906 ELSE 907 IF ( KEEP(50) .eq. 0 ) THEN 908 IST = APOS + int(NPIV,8) * int(LIELL,8) 909 ELSE 910 IST = APOS + int(NPIV,8) * int(NPIV,8) 911 END IF 912#if defined(MUMPS_USE_BLAS2) 913 IF ( NRHS_B == 1 ) THEN 914 IF (KEEP(350).EQ.0) THEN 915 CALL cgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, 916 & W( PTWCB+int(NPIV,8) ), 917 & 1, ONE, 918 & W(PTWCB), 1 ) 919 ELSE 920 CALL cgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, 921 & W( PTWCB + int(NPIV,8) ), 922 & 1, ONE, 923#if defined(RHSCOMP_BYROWS) 924 & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1 ) 925#else 926 & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) 927#endif 928 ENDIF 929 ELSE 930#endif 931 IF (KEEP(350).EQ.0) THEN 932 CALL cgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, 933 & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, 934 & ONE, W(PTWCB),LIELL) 935 ELSE 936#if defined(RHSCOMP_BYROWS) 937 WRITE(*,*) "Internal error in CMUMPS_SOL_S" 938 CALL MUMPS_ABORT() 939#else 940 CALL cgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, 941 & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, 942 & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) 943#endif 944 ENDIF 945#if defined(MUMPS_USE_BLAS2) 946 END IF 947#endif 948 END IF 949 ENDIF 950 IF ( MTYPE .eq. 1 ) THEN 951#if defined(MUMPS_USE_BLAS2) 952 IF ( NRHS_B == 1 ) THEN 953 IF (KEEP(350).EQ.0) THEN 954 CALL ctrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, 955 & W(PTWCB), 1) 956 ELSE 957 CALL ctrsv('L', 'T', 'N', NPIV, A(APOS), LIELL, 958#if defined(RHSCOMP_BYROWS) 959 & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) 960#else 961 & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) 962#endif 963 ENDIF 964 ELSE 965#endif 966 IF (KEEP(350).EQ.0) THEN 967 CALL ctrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), 968 & LIELL, W(PTWCB), LIELL) 969 ELSE 970#if defined(RHSCOMP_BYROWS) 971 WRITE(*,*) "Internal error in CMUMPS_SOL_S" 972 CALL MUMPS_ABORT() 973#else 974 CALL ctrsm('L','L','T','N', NPIV, NRHS_B, ONE, A(APOS), 975 & LIELL, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) 976#endif 977 ENDIF 978#if defined(MUMPS_USE_BLAS2) 979 ENDIF 980#endif 981 ELSE 982 IF ( KEEP(50) .EQ. 0 ) THEN 983 LDAJ=LIELL 984 ELSE 985 LDAJ=NPIV 986 ENDIF 987#if defined(MUMPS_USE_BLAS2) 988 IF ( NRHS_B == 1 ) THEN 989 IF (KEEP(350).EQ.0) THEN 990 CALL ctrsv('U','N','U', NPIV, A(APOS), LDAJ, 991 & W(PTWCB), 1) 992 ELSE 993 CALL ctrsv('U','N','U', NPIV, A(APOS), LDAJ, 994#if defined(RHSCOMP_BYROWS) 995 & RHSCOMP(JBDEB,IPOSINRHSCOMP), 1) 996#else 997 & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) 998#endif 999 ENDIF 1000 ELSE 1001#endif 1002 IF (KEEP(350).EQ.0) THEN 1003 CALL ctrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), 1004 & LDAJ,W(PTWCB),LIELL) 1005 ELSE 1006#if defined(RHSCOMP_BYROWS) 1007 WRITE(*,*) "Internal error in CMUMPS_SOL_S" 1008 CALL MUMPS_ABORT() 1009#else 1010 CALL ctrsm('L','U','N','U', NPIV, NRHS_B, ONE, A(APOS), 1011 & LDAJ, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) 1012#endif 1013 ENDIF 1014#if defined(MUMPS_USE_BLAS2) 1015 END IF 1016#endif 1017 END IF 1018 ENDIF 1019 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN 1020 J1 = IPOS + LIELL + 1 1021 ELSE 1022 J1 = IPOS + 1 1023 END IF 1024 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 1025 IF (KEEP(350).EQ.0) THEN 1026 IPOSINRHSCOMP_TMP = IPOSINRHSCOMP 1027 DO 150 I = 1, NPIV 1028 DO K=JBDEB, JBFIN 1029#if defined(RHSCOMP_BYROWS) 1030 RHSCOMP(K,IPOSINRHSCOMP_TMP) = W(PTWCB+I-1+(K-JBDEB)*LIELL) 1031#else 1032 RHSCOMP(IPOSINRHSCOMP_TMP, K) = W(PTWCB+I-1+(K-JBDEB)*LIELL) 1033#endif 1034 ENDDO 1035 IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 1036 150 CONTINUE 1037 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 1038 ELSE 1039 WRITE(*,*)"Internal error in CMUMPS_SOL_S" 1040 CALL MUMPS_ABORT() 1041 ENDIF 1042 160 CONTINUE 1043 IF (KEEP(201).GT.0) THEN 1044 CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), 1045 & A,LA,.TRUE.,IERR) 1046 IF(IERR.LT.0)THEN 1047 INFO(1)=IERR 1048 INFO(2)=0 1049 GOTO 330 1050 ENDIF 1051 ENDIF 1052 IN = INODE 1053 170 IN = FILS(IN) 1054 IF (IN .GT. 0) GOTO 170 1055 IF (IN .EQ. 0) THEN 1056 MYLEAFE = MYLEAFE - 1 1057 IF (MYLEAFE .EQ. 0) THEN 1058 CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, 1059 & FEUILLE, SLAVEF, KEEP ) 1060 NBFINF = NBFINF - 1 1061 IF (NBFINF .EQ. 0) GOTO 340 1062 ENDIF 1063 GOTO 50 1064 ENDIF 1065 IF = -IN 1066 NBFILS = NE_STEPS(STEP(INODE)) 1067 IF (AM1) THEN 1068 I = NBFILS 1069 NBFILS = 0 1070 DO WHILE (I.GT.0) 1071 IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 1072 IF = FRERE(STEP(IF)) 1073 I = I -1 1074 ENDDO 1075 IF (NBFILS.EQ.0) THEN 1076 NO_CHILDREN = .TRUE. 1077 ELSE 1078 NO_CHILDREN = .FALSE. 1079 ENDIF 1080 IF = -IN 1081 ENDIF 1082 IF (IN_SUBTREE) THEN 1083 DO I = 1, NBFILS 1084 IF ( AM1 ) THEN 1085 1010 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 1086 IF = FRERE(STEP(IF)) 1087 GOTO 1010 1088 ENDIF 1089 NO_CHILDREN = .FALSE. 1090 ENDIF 1091 IPOOL((IIPOOL-I+1)+NBFILS-I) = IF 1092 IIPOOL = IIPOOL + 1 1093 IF = FRERE(STEP(IF)) 1094 ENDDO 1095 IF (AM1 .AND. NO_CHILDREN) THEN 1096 MYLEAFE = MYLEAFE - 1 1097 IF (MYLEAFE .EQ. 0) THEN 1098 CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, 1099 & FEUILLE, SLAVEF, KEEP ) 1100 NBFINF = NBFINF - 1 1101 IF (NBFINF .EQ. 0) GOTO 340 1102 GOTO 50 1103 ENDIF 1104 ENDIF 1105 ELSE 1106 DEBUT = .TRUE. 1107 DO I = 0, SLAVEF - 1 1108 DEJA_SEND( I ) = .FALSE. 1109 END DO 1110 POOL_FIRST_POS=IIPOOL 1111 DO 190 I = 1, NBFILS 1112 IF ( AM1 ) THEN 11131020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN 1114 IF = FRERE(STEP(IF)) 1115 GOTO 1020 1116 ENDIF 1117 NO_CHILDREN = .FALSE. 1118 ENDIF 1119 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), 1120 & SLAVEF) .EQ. MYID) THEN 1121 IPOOL(IIPOOL) = IF 1122 IIPOOL = IIPOOL + 1 1123 IF = FRERE(STEP(IF)) 1124 ELSE 1125 PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),SLAVEF) 1126 IF (.not. DEJA_SEND( PROCDEST )) THEN 1127 400 CONTINUE 1128 CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, LIELL, 1129 & LIELL - KEEP(253), 1130 & IW( POSINDICES ), 1131 & W ( PTRACB(STEP( INODE )) ), 1132 & JBDEB, JBFIN, 1133 & RHSCOMP(1, 1), NRHS, LRHSCOMP, 1134 & IPOSINRHSCOMP, NPIV, 1135 & KEEP, PROCDEST, NOEUD, COMM, IERR ) 1136 IF ( IERR .EQ. -1 ) THEN 1137 CALL CMUMPS_BACKSLV_RECV_AND_TREAT( 1138 & .FALSE., FLAG, 1139 & BUFR, LBUFR, LBUFR_BYTES, 1140 & MYID, SLAVEF, COMM, 1141 & N, IWCB, LIWW, POSIWCB, 1142 & W, LWC, POSWCB, 1143 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, 1144 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, 1145 & STEP, FRERE, FILS, PROCNODE_STEPS, 1146 & PLEFTW, KEEP,KEEP8, DKEEP, 1147 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAFE, 1148 & NRHS, MTYPE, 1149 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD 1150 & , TO_PROCESS, SIZE_TO_PROCESS 1151 & , FROM_PP ) 1152 IF ( INFO( 1 ) .LT. 0 ) GOTO 340 1153 GOTO 400 1154 ELSE IF ( IERR .EQ. -2 ) THEN 1155 INFO( 1 ) = -17 1156 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) 1157 GOTO 330 1158 ELSE IF ( IERR .EQ. -3 ) THEN 1159 INFO( 1 ) = -20 1160 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) 1161 GOTO 330 1162 END IF 1163 DEJA_SEND( PROCDEST ) = .TRUE. 1164 END IF 1165 IF = FRERE(STEP(IF)) 1166 ENDIF 1167 190 CONTINUE 1168 IF (AM1 .AND. NO_CHILDREN) THEN 1169 MYLEAFE = MYLEAFE - 1 1170 IF (MYLEAFE .EQ. 0) THEN 1171 CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, 1172 & FEUILLE, SLAVEF, KEEP ) 1173 NBFINF = NBFINF - 1 1174 IF (NBFINF .EQ. 0) GOTO 340 1175 GOTO 50 1176 ENDIF 1177 ENDIF 1178 DO I=1,(IIPOOL-POOL_FIRST_POS)/2 1179 TMP=IPOOL(POOL_FIRST_POS+I-1) 1180 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) 1181 IPOOL(IIPOOL-I)=TMP 1182 ENDDO 1183 IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 1184 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, 1185 & W, LWC, 1186 & POSWCB,POSIWCB,PTRICB,PTRACB) 1187 ENDIF 1188 GOTO 50 1189 330 CONTINUE 1190 CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERREUR, 1191 & SLAVEF, KEEP) 1192 340 CONTINUE 1193 CALL CMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, 1194 & COMM, DUMMY(1), 1195 & SLAVEF, .TRUE., .FALSE.) 1196 IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) 1197 RETURN 1198 END SUBROUTINE CMUMPS_SOL_S 1199