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 ZMUMPS_TRAITER_MESSAGE_SOLVE 14 & ( BUFR, LBUFR, LBUFR_BYTES, 15 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, 16 & N, NRHS, IPOOL, LPOOL, III, LEAF, 17 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, 18 & PTRFAC, IWCB, LIWCB, 19 & WCB, LWCB, POSWCB, 20 & PLEFTWCB, POSIWCB, 21 & PTRICB, 22 & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, 23 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD 24 & , FROM_PP ) 25 USE ZMUMPS_OOC 26 USE ZMUMPS_BUF 27 IMPLICIT NONE 28 INTEGER LBUFR, LBUFR_BYTES 29 INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM 30 INTEGER LIW 31 INTEGER(8), INTENT(IN) :: LA, LWCB 32 INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN, LRHSCOMP 33 INTEGER LIWCB, POSIWCB 34 INTEGER(8) :: POSWCB, PLEFTWCB 35 INTEGER INFO( 40 ), KEEP( 500) 36 INTEGER(8) KEEP8(150) 37 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) 38 INTEGER BUFR( LBUFR ) 39 INTEGER IPOOL( LPOOL ), NSTK_S( N ) 40 INTEGER IWCB( LIWCB ) 41 INTEGER IW( LIW ) 42 INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) 43 INTEGER(8) :: PTRFAC(KEEP(28)) 44 INTEGER STEP(N) 45 INTEGER PROCNODE_STEPS(KEEP(28)) 46 COMPLEX(kind=8) WCB( LWCB ), A( LA ) 47#if defined(RHSCOMP_BYROWS) 48 COMPLEX(kind=8) RHSCOMP( NRHS, LRHSCOMP ) 49#else 50 COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NRHS ) 51#endif 52 INTEGER, intent(in) :: POSINRHSCOMP_FWD(N) 53 LOGICAL, intent(in) :: FROM_PP 54 INCLUDE 'mpif.h' 55 INCLUDE 'mumps_tags.h' 56 INTEGER(8) :: PTRX, PTRY, IFR8 57 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B 58 INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV 59 INTEGER PDEST, I, IPOSINRHSCOMP 60 INTEGER J1 61 INTEGER(8) :: APOS 62 LOGICAL DUMMY 63 LOGICAL FLAG 64!$ LOGICAL :: OMP_FLAG 65 EXTERNAL MUMPS_PROCNODE 66 INTEGER MUMPS_PROCNODE 67 DOUBLE PRECISION :: TIME_TMP 68 COMPLEX(kind=8) ALPHA, ONE 69 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 70 INCLUDE 'mumps_headers.h' 71 IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN 72 NBFIN = NBFIN - 1 73 IF ( NBFIN .eq. 0 ) GOTO 270 74 ELSE IF (MSGTAG .EQ. ContVec ) THEN 75 POSITION = 0 76 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 77 & FINODE, 1, MPI_INTEGER, COMM, IERR ) 78 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 79 & FPERE, 1, MPI_INTEGER, COMM, IERR ) 80 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 81 & NCB, 1, MPI_INTEGER, COMM, IERR ) 82 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 83 & JBDEB, 1, MPI_INTEGER, COMM, IERR ) 84 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 85 & JBFIN, 1, MPI_INTEGER, COMM, IERR ) 86 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 87 & LONG, 1, MPI_INTEGER, COMM, IERR ) 88 NRHS_B = JBFIN-JBDEB+1 89 IF ( NCB .eq. 0 ) THEN 90 PTRICB(STEP(FINODE)) = -1 91 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 92 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN 93 IPOOL( LEAF ) = FPERE 94 LEAF = LEAF + 1 95 IF ( LEAF > LPOOL ) THEN 96 WRITE(*,*) 'Internal error 41r2 : Pool is too small.' 97 CALL MUMPS_ABORT() 98 END IF 99 END IF 100 ELSE 101 IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN 102 PTRICB(STEP(FINODE)) = NCB + 1 103 END IF 104 IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN 105 INFO( 1 ) = -14 106 INFO( 2 ) = LONG 107 GOTO 260 108 END IF 109 IF ( POSWCB - PLEFTWCB + 1_8 .LT. 110 & int(LONG,8) * int(NRHS_B,8)) THEN 111 INFO( 1 ) = -11 112 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ 113 & int(LONG,8) * int(NRHS_B,8), 114 & INFO(2)) 115 GOTO 260 116 END IF 117 IF (LONG .GT. 0) THEN 118 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 119 & IWCB( 1 ), 120 & LONG, MPI_INTEGER, COMM, IERR ) 121 DO K = 1, NRHS_B 122 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 123 & WCB( PLEFTWCB ), 124 & LONG, MPI_DOUBLE_COMPLEX, COMM, IERR ) 125 DO I = 1, LONG 126 IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(IWCB(I))) 127#if defined(RHSCOMP_BYROWS) 128 RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) = 129 & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + 130 & WCB(PLEFTWCB+I-1) 131#else 132 RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = 133 & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + 134 & WCB(PLEFTWCB+I-1) 135#endif 136 ENDDO 137 END DO 138 PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG 139 ENDIF 140 IF ( PTRICB(STEP(FINODE)) == 1 ) THEN 141 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 142 END IF 143 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN 144 IPOOL( LEAF ) = FPERE 145 LEAF = LEAF + 1 146 IF ( LEAF > LPOOL ) THEN 147 WRITE(*,*) 'Internal error 41r2 : Pool is too small.' 148 CALL MUMPS_ABORT() 149 END IF 150 ENDIF 151 END IF 152 ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN 153 POSITION = 0 154 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 155 & FINODE, 1, MPI_INTEGER, COMM, IERR ) 156 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 157 & FPERE, 1, MPI_INTEGER, COMM, IERR ) 158 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 159 & NCV, 1, MPI_INTEGER, COMM, IERR ) 160 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 161 & NPIV, 1, MPI_INTEGER, COMM, IERR ) 162 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 163 & JBDEB, 1, MPI_INTEGER, COMM, IERR ) 164 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 165 & JBFIN, 1, MPI_INTEGER, COMM, IERR ) 166 NRHS_B = JBFIN-JBDEB+1 167 PTRY = PLEFTWCB 168 PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) 169 PLEFTWCB = PLEFTWCB + (NPIV + NCV) * NRHS_B 170 IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN 171 INFO(1) = -11 172 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) 173 GO TO 260 174 END IF 175 DO K=1, NRHS_B 176 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 177 & WCB( PTRY + (K-1) * NCV ), NCV, 178 & MPI_DOUBLE_COMPLEX, COMM, IERR ) 179 ENDDO 180 IF ( NPIV .GT. 0 ) THEN 181 DO K=1, NRHS_B 182 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 183 & WCB( PTRX + (K-1)*NPIV ), NPIV, 184 & MPI_DOUBLE_COMPLEX, COMM, IERR ) 185 END DO 186 END IF 187 IF (KEEP(201).GT.0) THEN 188 CALL ZMUMPS_SOLVE_GET_OOC_NODE( 189 & FINODE,PTRFAC,KEEP,A,LA,STEP, 190 & KEEP8,N,DUMMY,IERR) 191 IF(IERR.LT.0)THEN 192 INFO(1)=IERR 193 INFO(2)=0 194 GOTO 260 195 ENDIF 196 ENDIF 197 APOS = PTRFAC(STEP(FINODE)) 198 IF (KEEP(201).EQ.1) THEN 199#if defined(MUMPS_USE_BLAS2) 200 IF ( NRHS_B == 1 ) THEN 201 CALL zgemv( 'N', NCV, NPIV, ALPHA, A(APOS), NCV, 202 & WCB( PTRX ), 1, ONE, 203 & WCB( PTRY ), 1 ) 204 ELSE 205#endif 206 CALL zgemm( 'N', 'N', NCV, NRHS_B, NPIV, ALPHA, 207 & A(APOS), NCV, 208 & WCB( PTRX), NPIV, ONE, 209 & WCB( PTRY), NCV ) 210#if defined(MUMPS_USE_BLAS2) 211 ENDIF 212#endif 213 ELSE 214#if defined(MUMPS_USE_BLAS2) 215 IF ( NRHS_B == 1 ) THEN 216 CALL zgemv( 'T', NPIV, NCV, ALPHA, A(APOS), NPIV, 217 & WCB( PTRX ), 1, ONE, 218 & WCB( PTRY ), 1 ) 219 ELSE 220#endif 221 CALL zgemm( 'T', 'N', NCV, NRHS_B, NPIV, ALPHA, 222 & A(APOS), NPIV, 223 & WCB( PTRX), NPIV, ONE, 224 & WCB( PTRY), NCV ) 225#if defined(MUMPS_USE_BLAS2) 226 ENDIF 227#endif 228 ENDIF 229 IF (KEEP(201).GT.0) THEN 230 CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, 231 & KEEP(28),A,LA,.TRUE.,IERR) 232 IF(IERR.LT.0)THEN 233 INFO(1)=IERR 234 INFO(2)=0 235 GOTO 260 236 ENDIF 237 ENDIF 238 PLEFTWCB = PLEFTWCB - NPIV * NRHS_B 239 PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), 240 & SLAVEF ) 241 IF ( PDEST .EQ. MYID ) THEN 242 IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN 243 NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) 244 PTRICB(STEP(FINODE)) = NCB + 1 245 END IF 246 IF (KEEP(350).EQ.0) THEN 247 DO I = 1, NCV 248 JJ=IW(PTRIST(STEP(FINODE))+3+I+ KEEP(IXSZ) ) 249 IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) 250 DO K=1, NRHS_B 251#if defined(RHSCOMP_BYROWS) 252 RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= 253 & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) + 254 & WCB(PTRY+I-1+(K-1)*NCV) 255#else 256 RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= 257 & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + 258 & WCB(PTRY+I-1+(K-1)*NCV) 259#endif 260 ENDDO 261 END DO 262 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 263 J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) 264!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. 265!$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) 266!$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSCOMP) IF(OMP_FLAG) 267 DO K=1, NRHS_B 268 IFR8 = PTRY+int(K-1,8)*int(NCV,8) 269 DO I = 1,NCV 270 JJ = IW(J1+I) 271 IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) 272#if defined(RHSCOMP_BYROWS) 273 RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP)= 274 & RHSCOMP(JBDEB+K-1,IPOSINRHSCOMP) 275#else 276 RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= 277 & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) 278#endif 279 & + WCB(IFR8+int(I-1,8)) 280 ENDDO 281 ENDDO 282!$OMP END PARALLEL DO 283 ELSE 284 WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" 285 CALL MUMPS_ABORT() 286 ENDIF 287 PTRICB(STEP(FINODE)) = 288 & PTRICB(STEP(FINODE)) - NCV 289 IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN 290 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 291 END IF 292 IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN 293 IPOOL( LEAF ) = FPERE 294 LEAF = LEAF + 1 295 IF ( LEAF > LPOOL ) THEN 296 WRITE(*,*) 'INTERNAL Error 41r: Pool is too small.' 297 CALL MUMPS_ABORT() 298 END IF 299 ENDIF 300 ELSE 301 210 CONTINUE 302 CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, 303 & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, 304 & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), 305 & WCB( PTRY ), JBDEB, JBFIN, 306 & RHSCOMP, 1, 1, -9999, -9999, 307 & KEEP, PDEST, ContVec, COMM, IERR ) 308 IF ( IERR .EQ. -1 ) THEN 309 CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, 310 & BUFR, LBUFR, LBUFR_BYTES, 311 & MYID, SLAVEF, COMM, 312 & N, NRHS, IPOOL, LPOOL, III, LEAF, 313 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 314 & IWCB, LIWCB, 315 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 316 & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, 317 & PROCNODE_STEPS, 318 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD 319 & , FROM_PP ) 320 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 321 GOTO 210 322 ELSE IF ( IERR .EQ. -2 ) THEN 323 INFO( 1 ) = -17 324 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + 325 & NCV * KEEP( 35 ) 326 GOTO 260 327 ELSE IF ( IERR .EQ. -3 ) THEN 328 INFO( 1 ) = -20 329 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + 330 & NCV * KEEP( 35 ) 331 END IF 332 END IF 333 PLEFTWCB = PLEFTWCB - NCV * NRHS_B 334 ELSEIF ( MSGTAG .EQ. TERREUR ) THEN 335 INFO(1) = -001 336 INFO(2) = MSGSOU 337 GOTO 270 338 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. 339 & (MSGTAG.EQ.TAG_DUMMY) ) THEN 340 GO TO 270 341 ELSE 342 INFO(1)=-100 343 INFO(2)=MSGTAG 344 GO TO 260 345 ENDIF 346 GO TO 270 347 260 CONTINUE 348 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 349 270 CONTINUE 350 RETURN 351 END SUBROUTINE ZMUMPS_TRAITER_MESSAGE_SOLVE 352 SUBROUTINE ZMUMPS_SOLVE_NODE( INODE, 353 & BUFR, LBUFR, LBUFR_BYTES, 354 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, 355 & N, IPOOL, LPOOL, III, LEAF, 356 & NBFIN, NSTK_S, 357 & IWCB, LIWCB, 358 & WCB, LWCB, A, LA, IW, LIW, 359 & NRHS, POSWCB, 360 & PLEFTWCB, POSIWCB, 361 & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, 362 & FILS, STEP, FRERE, DAD, 363 & MYROOT, 364 & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE, 365 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, 366 & 367 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 368 & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE 369 & , FROM_PP ) 370 USE ZMUMPS_OOC 371 USE ZMUMPS_BUF 372 IMPLICIT NONE 373 INTEGER MTYPE 374 INTEGER INODE, LBUFR, LBUFR_BYTES 375 INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM 376 INTEGER LIWCB, LIW, POSIWCB 377 INTEGER(8) :: POSWCB, PLEFTWCB, LWCB 378 INTEGER(8) :: LA 379 INTEGER N, LPOOL, III, LEAF, NBFIN 380 INTEGER MYROOT 381 INTEGER INFO( 40 ), KEEP( 500) 382 INTEGER(8) KEEP8(150) 383 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) 384 INTEGER BUFR( LBUFR ) 385 INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) 386 INTEGER IWCB( LIWCB ), IW( LIW ) 387 INTEGER NRHS 388 COMPLEX(kind=8) WCB( LWCB ), A( LA ) 389 COMPLEX(kind=8) RHS_ROOT( * ) 390 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) 391 INTEGER(8) :: PTRFAC(KEEP(28)) 392 INTEGER PROCNODE_STEPS(KEEP(28)) 393 INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) 394 INTEGER ISTEP_TO_INIV2(KEEP(71)), 395 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 396 INTEGER POSINRHSCOMP_FWD(N), LRHSCOMP 397#if defined(RHSCOMP_BYROWS) 398 COMPLEX(kind=8) RHSCOMP(NRHS, LRHSCOMP) 399#else 400 COMPLEX(kind=8) RHSCOMP(LRHSCOMP, NRHS) 401#endif 402 COMPLEX(kind=8) VALPIV, A11, A22, A12, DETPIV 403 LOGICAL, intent(in) :: DO_NBSPARSE 404 INTEGER, intent(in) :: LRHS_BOUNDS 405 INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) 406 LOGICAL, intent(in) :: FROM_PP 407 EXTERNAL zgemv, ztrsv, zgemm, ztrsm, MUMPS_PROCNODE 408 INTEGER MUMPS_PROCNODE 409 COMPLEX(kind=8) ALPHA,ONE,ZERO 410 PARAMETER (ZERO=(0.0D0,0.0D0), 411 & ONE=(1.0D0,0.0D0), 412 & ALPHA=(-1.0D0,0.0D0)) 413 DOUBLE PRECISION TIME_TMP 414 INTEGER JBDEB, JBFIN, NRHS_B 415 INTEGER(8) :: APOS, APOS1, APOS2, APOSOFF, IFR8, IFR_ini8 416 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, NPIV, NCB, 417 & IERR, 418 & LIELL, JJ, 419 & NELIM 420 INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL 421 INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_TMP 422 INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex 423 LOGICAL FLAG 424!$ LOGICAL :: OMP_FLAG 425 INCLUDE 'mumps_headers.h' 426 INTEGER(8) :: POSWCB1, POSWCB2 427 INTEGER(8) :: APOSDEB 428 INTEGER TempNROW, TempNCOL, PANEL_SIZE, LIWFAC, 429 & JFIN, NBJ, NUPDATE_PANEL, 430 & NBK, NBK_ini, TYPEF 431 INTEGER LD_WCBPIV 432 INTEGER LD_WCBCB 433 INTEGER LDAJ, LDAJ_ini, LDAJ_FIRST_PANEL 434 INTEGER TMP_NBPANELS, 435 & I_PIVRPTR, I_PIVR, IPANEL 436 LOGICAL MUST_BE_PERMUTED 437 INCLUDE 'mpif.h' 438 INCLUDE 'mumps_tags.h' 439 INTEGER DUMMY( 1 ) 440 DUMMY(1)=1 441 IF (DO_NBSPARSE) THEN 442 JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) 443 JBFIN= RHS_BOUNDS(2*STEP(INODE)) 444 NRHS_B = JBFIN-JBDEB+1 445 ELSE 446 JBDEB = 1 447 JBFIN = NRHS 448 NRHS_B = NRHS 449 ENDIF 450 IF (DO_NBSPARSE) THEN 451 if (JBDEB.GT.JBFIN) then 452 write(6,*) " Internal error 1 in nbsparse :", 453 & JBDEB, JBFIN 454 CALL MUMPS_ABORT() 455 endif 456 IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. 457 & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN 458 write(6,*) " Internal error 2 in nbsparse :", 459 & JBDEB, JBFIN 460 CALL MUMPS_ABORT() 461 endif 462 ENDIF 463 IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN 464 LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) 465 NPIV = LIELL 466 NELIM = 0 467 NSLAVES = 0 468 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) 469 ELSE 470 IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) 471 LIELL = IW(IPOS-2)+IW(IPOS+1) 472 NELIM = IW(IPOS-1) 473 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) 474 IPOS = IPOS + 1 475 NPIV = IW(IPOS) 476 IPOS = IPOS + 1 477 IF (KEEP(201).GT.0) THEN 478 CALL ZMUMPS_SOLVE_GET_OOC_NODE( 479 & INODE,PTRFAC,KEEP,A,LA,STEP, 480 & KEEP8,N,MUST_BE_PERMUTED,IERR) 481 IF(IERR.LT.0)THEN 482 INFO(1)=IERR 483 INFO(2)=0 484 GOTO 260 485 ENDIF 486 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 487 CALL ZMUMPS_OOC_PP_CHECK_PERM_FREED( 488 & IW(IPOS+1+2*LIELL+1+NSLAVES), 489 & MUST_BE_PERMUTED ) 490 ENDIF 491 ENDIF 492 NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) 493 IPOS = IPOS + 1 + NSLAVES 494 END IF 495 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN 496 J1 = IPOS + 1 497 J2 = IPOS + LIELL 498 J3 = IPOS + NPIV 499 ELSE 500 J1 = IPOS + LIELL + 1 501 J2 = IPOS + 2 * LIELL 502 J3 = IPOS + LIELL + NPIV 503 END IF 504 NCB = LIELL-NPIV 505 IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN 506 IFR8 = 0_8 507 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) 508 IF (KEEP(350).EQ.0) THEN 509 DO JJ = J1, J3 510 IFR8 = IFR8 + 1_8 511 DO K=JBDEB,JBFIN 512 RHS_ROOT(IFR8+int(NPIV,8)*int(K-1,8)) = 513#if defined(RHSCOMP_BYROWS) 514 & RHSCOMP(K,IPOSINRHSCOMP_TMP) 515#else 516 & RHSCOMP(IPOSINRHSCOMP_TMP,K) 517#endif 518 END DO 519 IPOSINRHSCOMP_TMP = IPOSINRHSCOMP_TMP + 1 520 END DO 521 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 522 IFR_ini8 = IFR8 523!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. 524!$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) 525!$OMP PARALLEL DO PRIVATE(IFR8,JJ) IF(OMP_FLAG) 526 DO K=JBDEB,JBFIN 527 IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) 528 DO JJ = J1, J3 529 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = 530#if defined(RHSCOMP_BYROWS) 531 & RHSCOMP(K,IPOSINRHSCOMP_TMP+JJ-J1) 532#else 533 & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) 534#endif 535 ENDDO 536 ENDDO 537!$OMP END PARALLEL DO 538 ELSE 539 WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" 540 CALL MUMPS_ABORT() 541 ENDIF 542 IF ( NPIV .LT. LIELL ) THEN 543 WRITE(*,*) ' Internal error in SOLVE_NODE for Root node' 544 CALL MUMPS_ABORT() 545 END IF 546 MYROOT = MYROOT - 1 547 IF ( MYROOT .EQ. 0 ) THEN 548 NBFIN = NBFIN - 1 549 IF (SLAVEF .GT. 1) THEN 550 CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, 551 & COMM, RACINE_SOLVE, SLAVEF, KEEP) 552 ENDIF 553 END IF 554 GO TO 270 555 END IF 556 APOS = PTRFAC(STEP(INODE)) 557 IF (KEEP(201).EQ.1) THEN 558 IF (MTYPE.EQ.1) THEN 559 IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN 560 TempNROW= NPIV+NELIM 561 TempNCOL= NPIV 562 LDAJ_FIRST_PANEL=TempNROW 563 ELSE 564 TempNROW= LIELL 565 TempNCOL= NPIV 566 LDAJ_FIRST_PANEL=TempNROW 567 ENDIF 568 TYPEF=TYPEF_L 569 ELSE 570 TempNCOL= LIELL 571 TempNROW= NPIV 572 LDAJ_FIRST_PANEL=TempNCOL 573 TYPEF= TYPEF_U 574 ENDIF 575 LIWFAC = IW(PTRIST(STEP(INODE))+XXI) 576 PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) 577 ENDIF 578 PPIV_COURANT = PLEFTWCB 579 PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) 580 IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN 581 INFO(1) = -11 582 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) 583 GO TO 260 584 END IF 585 IF (KEEP(201).EQ.1) THEN 586 LD_WCBPIV = LIELL 587 LD_WCBCB = LIELL 588 PCB_COURANT = PPIV_COURANT + NPIV 589 DO K=JBDEB, JBFIN 590 IFR8 = PPIV_COURANT+int(K-JBDEB,8)*int(LD_WCBPIV,8)-1_8 591 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) 592 DO JJ = J1, J3 593 IFR8 = IFR8 + 1_8 594#if defined(RHSCOMP_BYROWS) 595 WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) 596#else 597 WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) 598#endif 599 IPOSINRHSCOMP = IPOSINRHSCOMP + 1 600 ENDDO 601 IF (NCB.GT.0) THEN 602 DO JJ = J3+1, J2 603 J = IW(JJ) 604 IFR8 = IFR8 + 1_8 605 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) 606#if defined(RHSCOMP_BYROWS) 607 WCB(IFR8) = RHSCOMP(K,IPOSINRHSCOMP) 608 RHSCOMP (K,IPOSINRHSCOMP) = ZERO 609#else 610 WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) 611 RHSCOMP (IPOSINRHSCOMP,K) = ZERO 612#endif 613 ENDDO 614 ENDIF 615 ENDDO 616 ELSE 617 LD_WCBPIV = NPIV 618 LD_WCBCB = NCB 619 PCB_COURANT = PPIV_COURANT + NPIV*NRHS_B 620 IFR8 = PPIV_COURANT - 1_8 621 IFR_ini8 = IFR8 622 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) 623 IF (KEEP(350).EQ.0) THEN 624!$ OMP_FLAG = NRHS_B.GT.4 .AND. .FALSE. 625!$OMP PARALLEL DO PRIVATE(J,IFR8,K) IF(OMP_FLAG) 626 DO 130 JJ = J1, J3 627 J = IW(JJ) 628 IFR8 = IFR_ini8 + int(JJ-J1+1,8) 629 DO K=JBDEB, JBFIN 630#if defined(RHSCOMP_BYROWS) 631 WCB(IFR8+(K-JBDEB)*NPIV) = 632 & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) 633#else 634 WCB(IFR8+(K-JBDEB)*NPIV) = 635 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 636#endif 637 END DO 638 130 CONTINUE 639!$OMP END PARALLEL DO 640 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 641!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. 642!$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) 643!$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) 644 DO K=JBDEB, JBFIN 645 IFR8 = IFR_ini8 + (K-JBDEB)*NPIV 646 DO JJ = J1, J3 647#if defined(RHSCOMP_BYROWS) 648 WCB(IFR8+int(JJ-J1+1,8)) = 649 & RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) 650#else 651 WCB(IFR8+int(JJ-J1+1,8)) = 652 & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) 653#endif 654 ENDDO 655 ENDDO 656!$OMP END PARALLEL DO 657 ELSE 658 WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" 659 CALL MUMPS_ABORT() 660 ENDIF 661 IFR8 = PCB_COURANT - 1_8 662 IF (NPIV .LT. LIELL) THEN 663 IFR_ini8 = IFR8 664 IF (KEEP(350).EQ.0) THEN 665!$OMP PARALLEL DO PRIVATE(J,IFR8,K,IPOSINRHSCOMP) IF(OMP_FLAG) 666 DO 140 JJ = J3 + 1, J2 667 J = IW(JJ) 668 IFR8 = IFR_ini8 + (JJ-J3) 669 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) 670 DO K=JBDEB, JBFIN 671#if defined(RHSCOMP_BYROWS) 672 WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(K,IPOSINRHSCOMP) 673#else 674 WCB(IFR8+(K-JBDEB)*NCB) = RHSCOMP(IPOSINRHSCOMP,K) 675#endif 676#if defined(RHSCOMP_BYROWS) 677 RHSCOMP(K,IPOSINRHSCOMP)=ZERO 678#else 679 RHSCOMP(IPOSINRHSCOMP,K)=ZERO 680#endif 681 ENDDO 682 140 CONTINUE 683!$OMP END PARALLEL DO 684 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 685!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. 686!$ & (J2-J3)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) 687!$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) 688 DO K=JBDEB, JBFIN 689 IFR8 = IFR_ini8+(K-JBDEB)*NCB 690 DO JJ = J3 + 1, J2 691 J = IW(JJ) 692 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) 693#if defined(RHSCOMP_BYROWS) 694 WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(K,IPOSINRHSCOMP) 695#else 696 WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) 697#endif 698#if defined(RHSCOMP_BYROWS) 699 RHSCOMP(K,IPOSINRHSCOMP)=ZERO 700#else 701 RHSCOMP(IPOSINRHSCOMP,K)=ZERO 702#endif 703 ENDDO 704 ENDDO 705!$OMP END PARALLEL DO 706 ELSE 707 WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" 708 CALL MUMPS_ABORT() 709 ENDIF 710 ENDIF 711 ENDIF 712 IF ( NPIV .NE. 0 ) THEN 713 IF (KEEP(201).EQ.1) THEN 714 APOSDEB = APOS 715 J = 1 716 IPANEL = 0 717 10 CONTINUE 718 IPANEL = IPANEL + 1 719 JFIN = min(J+PANEL_SIZE-1, NPIV) 720 IF (IW(IPOS+ LIELL + JFIN) < 0) THEN 721 JFIN=JFIN+1 722 ENDIF 723 NBJ = JFIN-J+1 724 LDAJ = LDAJ_FIRST_PANEL-J+1 725 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN 726 CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, 727 & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) 728 IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN 729 MUST_BE_PERMUTED=.FALSE. 730 ELSE 731 CALL ZMUMPS_PERMUTE_PANEL( 732 & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- 733 & IW(I_PIVRPTR)), 734 & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, 735 & IW(I_PIVRPTR+IPANEL-1)-1, 736 & A(APOSDEB), 737 & LDAJ, NBJ, J-1 ) 738 ENDIF 739 ENDIF 740 NUPDATE_PANEL = LDAJ - NBJ 741 PPIV_PANEL = PPIV_COURANT+int(J-1,8) 742 PCB_PANEL = PPIV_PANEL+int(NBJ,8) 743 APOS1 = APOSDEB+int(NBJ,8) 744 IF (MTYPE.EQ.1) THEN 745#if defined(MUMPS_USE_BLAS2) 746 IF ( NRHS_B == 1 ) THEN 747 CALL ztrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, 748 & WCB(PPIV_PANEL), 1 ) 749 IF (NUPDATE_PANEL.GT.0) THEN 750 CALL zgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), 751 & LDAJ, WCB(PPIV_PANEL), 1, ONE, 752 & WCB(PCB_PANEL), 1) 753 ENDIF 754 ELSE 755#endif 756 CALL ztrsm( 'L','L','N','U', NBJ, NRHS_B, ONE, 757 & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), 758 & LIELL ) 759 IF (NUPDATE_PANEL.GT.0) THEN 760 CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, 761 & ALPHA, 762 & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, 763 & WCB(PCB_PANEL), LIELL) 764 ENDIF 765#if defined(MUMPS_USE_BLAS2) 766 ENDIF 767#endif 768 ELSE 769#if defined(MUMPS_USE_BLAS2) 770 IF (NRHS_B == 1) THEN 771 CALL ztrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, 772 & WCB(PPIV_PANEL), 1 ) 773 IF (NUPDATE_PANEL.GT.0) THEN 774 CALL zgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), 775 & LDAJ, WCB(PPIV_PANEL), 1, 776 & ONE, WCB(PCB_PANEL), 1 ) 777 ENDIF 778 ELSE 779#endif 780 CALL ztrsm('L','L','N','N',NBJ, NRHS_B, ONE, 781 & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), 782 & LIELL) 783 IF (NUPDATE_PANEL.GT.0) THEN 784 CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, 785 & ALPHA, 786 & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, 787 & WCB(PCB_PANEL), LIELL) 788 ENDIF 789#if defined(MUMPS_USE_BLAS2) 790 ENDIF 791#endif 792 ENDIF 793 APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) 794 J=JFIN+1 795 IF ( J .LE. NPIV ) GOTO 10 796 ELSE 797 IF (KEEP(50).NE.0) THEN 798#if defined(MUMPS_USE_BLAS2) 799 IF ( NRHS_B == 1 ) THEN 800 CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), NPIV, 801 & WCB(PPIV_COURANT), 1 ) 802 ELSE 803#endif 804 CALL ztrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, 805 & A(APOS), NPIV, WCB(PPIV_COURANT), 806 & NPIV ) 807#if defined(MUMPS_USE_BLAS2) 808 ENDIF 809#endif 810 ELSE 811 IF ( MTYPE .eq. 1 ) THEN 812#if defined(MUMPS_USE_BLAS2) 813 IF ( NRHS_B == 1) THEN 814 CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), LIELL, 815 & WCB(PPIV_COURANT), 1 ) 816 ELSE 817#endif 818 CALL ztrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, 819 & A(APOS), LIELL, WCB(PPIV_COURANT), 820 & NPIV ) 821#if defined(MUMPS_USE_BLAS2) 822 ENDIF 823#endif 824 ELSE 825#if defined(MUMPS_USE_BLAS2) 826 IF (NRHS_B == 1) THEN 827 CALL ztrsv( 'L', 'N', 'N', NPIV, A(APOS), LIELL, 828 & WCB(PPIV_COURANT), 1 ) 829 ELSE 830#endif 831 CALL ztrsm('L','L','N','N',NPIV, NRHS_B, ONE, 832 & A(APOS), LIELL, WCB(PPIV_COURANT), 833 & NPIV) 834#if defined(MUMPS_USE_BLAS2) 835 ENDIF 836#endif 837 END IF 838 END IF 839 END IF 840 END IF 841 NCB = LIELL - NPIV 842 IF ( MTYPE .EQ. 1 ) THEN 843 IF ( KEEP(50) .eq. 0 ) THEN 844 APOS1 = APOS + int(NPIV,8) * int(LIELL,8) 845 ELSE 846 APOS1 = APOS + int(NPIV,8) * int(NPIV,8) 847 END IF 848 IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN 849 NUPDATE = NCB 850 ELSE 851 NUPDATE = NELIM 852 END IF 853 ELSE 854 APOS1 = APOS + int(NPIV,8) 855 NUPDATE = NCB 856 END IF 857 IF (KEEP(201).NE.1) THEN 858 IF ( NPIV .NE. 0 .AND. NUPDATE.NE.0 ) THEN 859 IF ( MTYPE .eq. 1 ) THEN 860#if defined(MUMPS_USE_BLAS2) 861 IF ( NRHS_B == 1 ) THEN 862 CALL zgemv('T', NPIV, NUPDATE, ALPHA, A(APOS1), 863 & NPIV, WCB(PPIV_COURANT), 1, ONE, 864 & WCB(PCB_COURANT), 1) 865 ELSE 866#endif 867 CALL zgemm('T', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, 868 & A(APOS1), NPIV, WCB(PPIV_COURANT), NPIV, ONE, 869 & WCB(PCB_COURANT), NCB) 870#if defined(MUMPS_USE_BLAS2) 871 END IF 872#endif 873 ELSE 874#if defined(MUMPS_USE_BLAS2) 875 IF ( NRHS_B == 1 ) THEN 876 CALL zgemv('N',NUPDATE, NPIV, ALPHA, A(APOS1), 877 & LIELL, WCB(PPIV_COURANT), 1, 878 & ONE, WCB(PCB_COURANT), 1 ) 879 ELSE 880#endif 881 CALL zgemm('N', 'N', NUPDATE, NRHS_B, NPIV, ALPHA, 882 & A(APOS1), LIELL, WCB(PPIV_COURANT), NPIV, ONE, 883 & WCB(PCB_COURANT), NCB) 884#if defined(MUMPS_USE_BLAS2) 885 END IF 886#endif 887 END IF 888 END IF 889 END IF 890 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) 891 IF ( KEEP(50) .eq. 0 ) THEN 892 IF (KEEP(350).EQ.0) THEN 893 DO K=JBDEB,JBFIN 894 IFR8 = PPIV_COURANT + int(K-JBDEB,8)*int(LD_WCBPIV,8) 895#if defined(RHSCOMP_BYROWS) 896 RHSCOMP(K,IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1) = 897#else 898 RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1,K) = 899#endif 900 & WCB(IFR8:IFR8+int(NPIV-1,8)) 901 ENDDO 902 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 903#if defined(RHSCOMP_BYROWS) 904!$ OMP_FLAG = (NPIV.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) 905!$OMP PARALLEL DO PRIVATE(IFR8,K) IF (OMP_FLAG) 906 DO I=1,NPIV 907 IFR8 = PPIV_COURANT + I-1 908 DO K=JBDEB,JBFIN 909 RHSCOMP(K,IPOSINRHSCOMP+I-1) = 910 & WCB(IFR8+(K-JBDEB)*LD_WCBPIV) 911 ENDDO 912 ENDDO 913!$OMP END PARALLEL DO 914#else 915!$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) 916!$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) 917 DO K=JBDEB,JBFIN 918 IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV 919 RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = 920 & WCB(IFR8:IFR8+int(NPIV-1,8)) 921 ENDDO 922!$OMP END PARALLEL DO 923#endif 924 ELSE 925 WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" 926 CALL MUMPS_ABORT() 927 ENDIF 928 ELSE 929 IFR8 = PPIV_COURANT - 1_8 930 IF (KEEP(201).EQ.1) THEN 931 LDAJ = TempNROW 932 ELSE 933 LDAJ = NPIV 934 ENDIF 935 APOS1 = APOS 936 JJ = J1 937 IF (KEEP(201).EQ.1) THEN 938 NBK = 0 939 ENDIF 940 IF (KEEP(350).EQ.0) THEN 941 DO 942 IF(JJ .GT. J3) EXIT 943 IFR8 = IFR8 + 1_8 944 IF(IW(JJ+LIELL) .GT. 0) THEN 945 VALPIV = ONE/A( APOS1 ) 946 DO K=JBDEB, JBFIN 947#if defined(RHSCOMP_BYROWS) 948 RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = 949 & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV 950#else 951 RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = 952 & WCB( IFR8+(K-JBDEB)*LD_WCBPIV ) * VALPIV 953#endif 954 END DO 955 IF (KEEP(201).EQ.1) THEN 956 NBK = NBK+1 957 IF (NBK.EQ.PANEL_SIZE) THEN 958 NBK = 0 959 LDAJ = LDAJ - PANEL_SIZE 960 ENDIF 961 ENDIF 962 APOS1 = APOS1 + int(LDAJ + 1,8) 963 JJ = JJ+1 964 ELSE 965 IF (KEEP(201).EQ.1) THEN 966 NBK = NBK+1 967 ENDIF 968 APOS2 = APOS1+int(LDAJ+1,8) 969 IF (KEEP(201).EQ.1) THEN 970 APOSOFF = APOS1+int(LDAJ,8) 971 ELSE 972 APOSOFF=APOS1+1_8 973 ENDIF 974 A11 = A(APOS1) 975 A22 = A(APOS2) 976 A12 = A(APOSOFF) 977 DETPIV = A11*A22 - A12**2 978 A22 = A11/DETPIV 979 A11 = A(APOS2)/DETPIV 980 A12 = -A12/DETPIV 981 DO K=JBDEB, JBFIN 982 POSWCB1 = IFR8+int(K-JBDEB,8)*int(LD_WCBPIV,8) 983 POSWCB2 = POSWCB1+1_8 984#if defined(RHSCOMP_BYROWS) 985 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = 986 & WCB(POSWCB1)*A11 987 & + WCB(POSWCB2)*A12 988 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = 989 & WCB(POSWCB1)*A12 990 & + WCB(POSWCB2)*A22 991#else 992 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = 993 & WCB(POSWCB1)*A11 994 & + WCB(POSWCB2)*A12 995 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = 996 & WCB(POSWCB1)*A12 997 & + WCB(POSWCB2)*A22 998#endif 999 END DO 1000 IF (KEEP(201).EQ.1) THEN 1001 NBK = NBK+1 1002 IF (NBK.GE.PANEL_SIZE) THEN 1003 LDAJ = LDAJ - NBK 1004 NBK = 0 1005 ENDIF 1006 ENDIF 1007 APOS1 = APOS2 + int(LDAJ + 1,8) 1008 JJ = JJ+2 1009 IFR8 = IFR8+1_8 1010 ENDIF 1011 ENDDO 1012 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 1013 IFR_ini8 = PPIV_COURANT - 1_8 1014 LDAJ_ini = LDAJ 1015 IF (KEEP(201).EQ.1) NBK_ini = NBK 1016!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. 1017!$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) 1018!$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, 1019!$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) 1020 DO K = JBDEB, JBFIN 1021 IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) 1022 NBK = NBK_ini 1023 APOS1 = APOS 1024 LDAJ = LDAJ_ini 1025 JJ = J1 1026 DO 1027 IF (JJ .GT. J3) EXIT 1028 IFR8 = IFR8 + 1_8 1029 IF (IW(JJ+LIELL) .GT. 0) THEN 1030 VALPIV = ONE/A( APOS1 ) 1031#if defined(RHSCOMP_BYROWS) 1032 RHSCOMP(K, IPOSINRHSCOMP+JJ-J1) = 1033 & WCB( IFR8 ) * VALPIV 1034#else 1035 RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = 1036 & WCB( IFR8 ) * VALPIV 1037#endif 1038 IF (KEEP(201).EQ.1) THEN 1039 NBK = NBK+1 1040 IF (NBK.EQ.PANEL_SIZE) THEN 1041 NBK = 0 1042 LDAJ = LDAJ - PANEL_SIZE 1043 ENDIF 1044 ENDIF 1045 APOS1 = APOS1 + int(LDAJ + 1,8) 1046 JJ = JJ+1 1047 ELSE 1048 IF (KEEP(201).EQ.1) THEN 1049 NBK = NBK+1 1050 ENDIF 1051 APOS2 = APOS1+int(LDAJ+1,8) 1052 IF (KEEP(201).EQ.1) THEN 1053 APOSOFF = APOS1+int(LDAJ,8) 1054 ELSE 1055 APOSOFF=APOS1+1_8 1056 ENDIF 1057 A11 = A(APOS1) 1058 A22 = A(APOS2) 1059 A12 = A(APOSOFF) 1060 DETPIV = A11*A22 - A12**2 1061 A22 = A11/DETPIV 1062 A11 = A(APOS2)/DETPIV 1063 A12 = -A12/DETPIV 1064 POSWCB1 = IFR8 1065 POSWCB2 = POSWCB1+1_8 1066#if defined(RHSCOMP_BYROWS) 1067 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1) = 1068 & WCB(POSWCB1)*A11 1069 & + WCB(POSWCB2)*A12 1070 RHSCOMP(K,IPOSINRHSCOMP+JJ-J1+1) = 1071 & WCB(POSWCB1)*A12 1072 & + WCB(POSWCB2)*A22 1073#else 1074 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = 1075 & WCB(POSWCB1)*A11 1076 & + WCB(POSWCB2)*A12 1077 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = 1078 & WCB(POSWCB1)*A12 1079 & + WCB(POSWCB2)*A22 1080#endif 1081 IF (KEEP(201).EQ.1) THEN 1082 NBK = NBK+1 1083 IF (NBK.GE.PANEL_SIZE) THEN 1084 LDAJ = LDAJ - NBK 1085 NBK = 0 1086 ENDIF 1087 ENDIF 1088 APOS1 = APOS2 + int(LDAJ + 1,8) 1089 JJ = JJ+2 1090 IFR8 = IFR8+1_8 1091 ENDIF 1092 ENDDO 1093 ENDDO 1094!$OMP END PARALLEL DO 1095 ELSE 1096 WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" 1097 CALL MUMPS_ABORT() 1098 ENDIF 1099 END IF 1100 IF (KEEP(201).GT.0) THEN 1101 CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), 1102 & A,LA,.TRUE.,IERR) 1103 IF(IERR.LT.0)THEN 1104 INFO(1)=IERR 1105 INFO(2)=0 1106 GOTO 260 1107 ENDIF 1108 END IF 1109 FPERE = DAD(STEP(INODE)) 1110 IF ( FPERE .EQ. 0 ) THEN 1111 MYROOT = MYROOT - 1 1112 PLEFTWCB = PLEFTWCB - LIELL *NRHS_B 1113 IF ( MYROOT .EQ. 0 ) THEN 1114 NBFIN = NBFIN - 1 1115 IF (SLAVEF .GT. 1) THEN 1116 CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, 1117 & COMM, RACINE_SOLVE, SLAVEF, KEEP) 1118 ENDIF 1119 END IF 1120 GO TO 270 1121 ENDIF 1122 IF ( NUPDATE .NE. 0 .OR. NCB.eq.0 ) THEN 1123 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), 1124 & SLAVEF) .EQ. MYID) THEN 1125 IF ( NCB .ne. 0 ) THEN 1126 PTRICB(STEP(INODE)) = NCB + 1 1127 IF (KEEP(350).EQ.0) THEN 1128!$ OMP_FLAG = .FALSE. 1129!$OMP PARALLEL DO PRIVATE(K,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) 1130 DO 190 I = 1, NUPDATE 1131 IPOSINRHSCOMP_TMP = 1132 & abs(POSINRHSCOMP_FWD(IW(J3 + I))) 1133 DO K=JBDEB, JBFIN 1134#if defined(RHSCOMP_BYROWS) 1135 RHSCOMP( K, IPOSINRHSCOMP_TMP ) = 1136 & RHSCOMP( K, IPOSINRHSCOMP_TMP ) 1137#else 1138 RHSCOMP( IPOSINRHSCOMP_TMP, K ) = 1139 & RHSCOMP( IPOSINRHSCOMP_TMP, K ) 1140#endif 1141 & + WCB(PCB_COURANT + I-1 +(K-JBDEB)*LD_WCBCB) 1142 ENDDO 1143 190 CONTINUE 1144!$OMP END PARALLEL DO 1145 ELSE IF (KEEP(350).EQ.1.OR.KEEP(350).EQ.2) THEN 1146!$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. 1147!$ & (NUPDATE*(JBFIN-JBDEB+1) .GE. KEEP(363)) ) 1148!$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) 1149 DO K = JBDEB, JBFIN 1150 IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) 1151 DO I = 1, NUPDATE 1152 IPOSINRHSCOMP_TMP = 1153 & abs(POSINRHSCOMP_FWD(IW(J3 + I))) 1154#if defined(RHSCOMP_BYROWS) 1155 RHSCOMP( K, IPOSINRHSCOMP_TMP ) = 1156 & RHSCOMP( K, IPOSINRHSCOMP_TMP ) 1157#else 1158 RHSCOMP( IPOSINRHSCOMP_TMP, K ) = 1159 & RHSCOMP( IPOSINRHSCOMP_TMP, K ) 1160#endif 1161 & + WCB(IFR8 + int(I-1,8)) 1162 ENDDO 1163 ENDDO 1164!$OMP END PARALLEL DO 1165 ELSE 1166 WRITE(*,*) "UNKNOWN VERSION OF KEEP(350)" 1167 CALL MUMPS_ABORT() 1168 ENDIF 1169 PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE 1170 IF ( PTRICB(STEP(INODE)) == 1 ) THEN 1171 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 1172 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN 1173 IPOOL( LEAF ) = FPERE 1174 LEAF = LEAF + 1 1175 ENDIF 1176 END IF 1177 ELSE 1178 PTRICB(STEP( INODE )) = -1 1179 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 1180 IF (NSTK_S(STEP(FPERE)) .EQ. 0) THEN 1181 IPOOL( LEAF ) = FPERE 1182 LEAF = LEAF + 1 1183 ENDIF 1184 ENDIF 1185 ELSE 1186 210 CONTINUE 1187 CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, 1188 & NCB, LD_WCBCB, 1189 & NUPDATE, 1190 & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, 1191 & RHSCOMP, 1, 1, -9999, -9999, 1192 & KEEP, 1193 & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), SLAVEF), 1194 & ContVec, 1195 & COMM, IERR ) 1196 IF ( IERR .EQ. -1 ) THEN 1197 CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, 1198 & BUFR, LBUFR, LBUFR_BYTES, 1199 & MYID, SLAVEF, COMM, 1200 & N, NRHS, IPOOL, LPOOL, III, LEAF, 1201 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 1202 & IWCB, LIWCB, 1203 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 1204 & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, 1205 & PROCNODE_STEPS, 1206 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD 1207 & , FROM_PP ) 1208 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 1209 GOTO 210 1210 ELSE IF ( IERR .EQ. -2 ) THEN 1211 INFO( 1 ) = -17 1212 INFO( 2 ) = NUPDATE * KEEP( 35 ) + 1213 & ( NUPDATE + 3 ) * KEEP( 34 ) 1214 GOTO 260 1215 ELSE IF ( IERR .EQ. -3 ) THEN 1216 INFO( 1 ) = -20 1217 INFO( 2 ) = NUPDATE * KEEP( 35 ) + 1218 & ( NUPDATE + 3 ) * KEEP( 34 ) 1219 GOTO 260 1220 END IF 1221 ENDIF 1222 END IF 1223 IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 1224 & .and. NPIV .NE. 0 ) THEN 1225 DO ISLAVE = 1, NSLAVES 1226 PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) 1227 CALL MUMPS_BLOC2_GET_SLAVE_INFO( 1228 & KEEP,KEEP8, INODE, STEP, N, SLAVEF, 1229 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, 1230 & ISLAVE, NCB - NELIM, 1231 & NSLAVES, 1232 & Effective_CB_Size, FirstIndex ) 1233 222 CONTINUE 1234 CALL ZMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, 1235 & INODE, FPERE, 1236 & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, 1237 & JBDEB, JBFIN, 1238 & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), 1239 & WCB( PPIV_COURANT ), 1240 & PDEST, COMM, KEEP, IERR ) 1241 IF ( IERR .EQ. -1 ) THEN 1242 CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, 1243 & BUFR, LBUFR, LBUFR_BYTES, 1244 & MYID, SLAVEF, COMM, 1245 & N, NRHS, IPOOL, LPOOL, III, LEAF, 1246 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, 1247 & IWCB, LIWCB, 1248 & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, 1249 & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, 1250 & PROCNODE_STEPS, 1251 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD 1252 & , FROM_PP ) 1253 IF ( INFO( 1 ) .LT. 0 ) GOTO 270 1254 GOTO 222 1255 ELSE IF ( IERR .EQ. -2 ) THEN 1256 INFO( 1 ) = -17 1257 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + 1258 & 6 * KEEP( 34 ) 1259 GOTO 260 1260 ELSE IF ( IERR .EQ. -3 ) THEN 1261 INFO( 1 ) = -20 1262 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + 1263 & 6 * KEEP( 34 ) 1264 GOTO 260 1265 END IF 1266 END DO 1267 END IF 1268 PLEFTWCB = PLEFTWCB - LIELL*NRHS_B 1269 270 CONTINUE 1270 RETURN 1271 260 CONTINUE 1272 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 1273 RETURN 1274 END SUBROUTINE ZMUMPS_SOLVE_NODE 1275 RECURSIVE SUBROUTINE ZMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, 1276 & BUFR, LBUFR, LBUFR_BYTES, 1277 & MYID, SLAVEF, COMM, 1278 & N, NRHS, IPOOL, LPOOL, III, LEAF, 1279 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, 1280 & IWCB, LIWCB, 1281 & WCB, LWCB, POSWCB, 1282 & PLEFTWCB, POSIWCB, 1283 & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, 1284 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD 1285 & , FROM_PP) 1286 IMPLICIT NONE 1287 LOGICAL BLOQ 1288 INTEGER LBUFR, LBUFR_BYTES 1289 INTEGER MYID, SLAVEF, COMM 1290 INTEGER N, NRHS, LPOOL, III, LEAF, NBFIN 1291 INTEGER LIWCB, POSIWCB 1292 INTEGER(8) :: POSWCB, PLEFTWCB 1293 INTEGER LIW 1294 INTEGER(8), INTENT(IN) :: LA, LWCB 1295 INTEGER INFO( 40 ), KEEP( 500) 1296 INTEGER(8) KEEP8(150) 1297 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) 1298 INTEGER BUFR( LBUFR ), IPOOL(LPOOL) 1299 INTEGER NSTK_S( KEEP(28) ) 1300 INTEGER IWCB( LIWCB ) 1301 INTEGER IW( LIW ) 1302 COMPLEX(kind=8) WCB( LWCB ), A( LA ) 1303 INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) 1304 INTEGER(8) :: PTRFAC(KEEP(28)) 1305 INTEGER STEP(N) 1306 INTEGER PROCNODE_STEPS(KEEP(28)) 1307 LOGICAL FLAG 1308 INTEGER LRHSCOMP, POSINRHSCOMP_FWD(N) 1309#if defined(RHSCOMP_BYROWS) 1310 COMPLEX(kind=8) RHSCOMP(NRHS,LRHSCOMP) 1311#else 1312 COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) 1313#endif 1314 LOGICAL, intent(in) :: FROM_PP 1315 INCLUDE 'mpif.h' 1316 INCLUDE 'mumps_tags.h' 1317 INTEGER :: IERR 1318 INTEGER :: STATUS(MPI_STATUS_SIZE) 1319 INTEGER MSGSOU, MSGTAG, MSGLEN 1320 DOUBLE PRECISION :: TIME_TMP 1321 FLAG = .FALSE. 1322 IF ( BLOQ ) THEN 1323 CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, 1324 & COMM, STATUS, IERR ) 1325 FLAG = .TRUE. 1326 ELSE 1327 CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, 1328 & FLAG, STATUS, IERR ) 1329 END IF 1330 IF ( FLAG ) THEN 1331 KEEP(266) = KEEP(266) -1 1332 MSGSOU = STATUS( MPI_SOURCE ) 1333 MSGTAG = STATUS( MPI_TAG ) 1334 CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) 1335 IF ( MSGLEN .GT. LBUFR_BYTES ) THEN 1336 INFO(1) = -20 1337 INFO(2) = MSGLEN 1338 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 1339 ELSE 1340 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, 1341 & MSGSOU, MSGTAG, COMM, STATUS, IERR ) 1342 CALL ZMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, 1343 & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, 1344 & N, NRHS, IPOOL, LPOOL, III, LEAF, 1345 & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, 1346 & IWCB, LIWCB, 1347 & WCB, LWCB, POSWCB, 1348 & PLEFTWCB, POSIWCB, 1349 & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, 1350 & PROCNODE_STEPS, 1351 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD 1352 & , FROM_PP ) 1353 END IF 1354 END IF 1355 RETURN 1356 END SUBROUTINE ZMUMPS_SOLVE_RECV_AND_TREAT 1357