1C 2C This file is part of MUMPS 4.10.0, built on Tue May 10 12:56:32 UTC 2011 3C 4C 5C This version of MUMPS is provided to you free of charge. It is public 6C domain, based on public domain software developed during the Esprit IV 7C European project PARASOL (1996-1999). Since this first public domain 8C version in 1999, research and developments have been supported by the 9C following institutions: CERFACS, CNRS, ENS Lyon, INPT(ENSEEIHT)-IRIT, 10C INRIA, and University of Bordeaux. 11C 12C The MUMPS team at the moment of releasing this version includes 13C Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Abdou Guermouche, 14C Guillaume Joslin, Jean-Yves L'Excellent, Francois-Henry Rouet, Bora 15C Ucar and Clement Weisbecker. 16C 17C We are also grateful to Emmanuel Agullo, Caroline Bousquet, Indranil 18C Chowdhury, Philippe Combes, Christophe Daniel, Iain Duff, Vincent Espirat, 19C Aurelia Fevre, Jacko Koster, Stephane Pralet, Chiara Puglisi, Gregoire 20C Richard, Tzvetomila Slavova, Miroslav Tuma and Christophe Voemel who 21C have been contributing to this project. 22C 23C Up-to-date copies of the MUMPS package can be obtained 24C from the Web pages: 25C http://mumps.enseeiht.fr/ or http://graal.ens-lyon.fr/MUMPS 26C 27C 28C THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY 29C EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. 30C 31C 32C User documentation of any code that uses this software can 33C include this complete notice. You can acknowledge (using 34C references [1] and [2]) the contribution of this package 35C in any scientific publication dependent upon the use of the 36C package. You shall use reasonable endeavours to notify 37C the authors of the package of this publication. 38C 39C [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, 40C A fully asynchronous multifrontal solver using distributed dynamic 41C scheduling, SIAM Journal of Matrix Analysis and Applications, 42C Vol 23, No 1, pp 15-41 (2001). 43C 44C [2] P. R. Amestoy and A. Guermouche and J.-Y. L'Excellent and 45C S. Pralet, Hybrid scheduling for the parallel solution of linear 46C systems. Parallel Computing Vol 32 (2), pp 136-156 (2006). 47C 48 SUBROUTINE ZMUMPS_324(A, LDA, NPIV, NBROW, K50 ) 49 IMPLICIT NONE 50 INTEGER LDA, NPIV, NBROW, K50 51 COMPLEX(kind=8) A(int(LDA,8)*int(NBROW+NPIV,8)) 52 INTEGER(8) :: IOLD, INEW, J8 53 INTEGER I , ILAST 54 INTEGER NBROW_L_RECTANGLE_TO_MOVE 55 IF ((NPIV.EQ.0).OR.(LDA.EQ.NPIV)) GOTO 500 56 IF ( K50.NE.0 ) THEN 57 IOLD = int(LDA + 1,8) 58 INEW = int(NPIV + 1,8) 59 IF (IOLD .EQ. INEW ) THEN 60 INEW = INEW + int(NPIV,8) * int(NPIV - 1,8) 61 IOLD = IOLD + int(LDA,8) * int(NPIV - 1,8) 62 ELSE 63 DO I = 1, NPIV - 1 64 IF ( I .LE. NPIV-2 ) THEN 65 ILAST = I+1 66 ELSE 67 ILAST = I 68 ENDIF 69 DO J8 = 0_8, int(ILAST,8) 70 A( INEW + J8 ) = A( IOLD + J8 ) 71 END DO 72 INEW = INEW + int(NPIV,8) 73 IOLD = IOLD + int(LDA,8) 74 END DO 75 ENDIF 76 NBROW_L_RECTANGLE_TO_MOVE = NBROW 77 ELSE 78 INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8) 79 IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8) 80 NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1 81 ENDIF 82 DO I = 1, NBROW_L_RECTANGLE_TO_MOVE 83 DO J8 = 0_8, int(NPIV - 1,8) 84 A( INEW + J8 ) = A( IOLD + J8 ) 85 END DO 86 INEW = INEW + int(NPIV,8) 87 IOLD = IOLD + int(LDA,8) 88 ENDDO 89 500 RETURN 90 END SUBROUTINE ZMUMPS_324 91 SUBROUTINE ZMUMPS_651(A, LDA, NPIV, NCONTIG ) 92 IMPLICIT NONE 93 INTEGER NCONTIG, NPIV, LDA 94 COMPLEX(kind=8) A(NCONTIG*LDA) 95 INTEGER I, J 96 INTEGER(8) :: INEW, IOLD 97 INEW = int(NPIV+1,8) 98 IOLD = int(LDA+1,8) 99 DO I = 2, NCONTIG 100 DO J = 1, NPIV 101 A(INEW)=A(IOLD) 102 INEW = INEW + 1_8 103 IOLD = IOLD + 1_8 104 ENDDO 105 IOLD = IOLD + int(LDA - NPIV,8) 106 ENDDO 107 RETURN 108 END SUBROUTINE ZMUMPS_651 109 SUBROUTINE ZMUMPS_652( A, LA, LDA, POSELT, 110 & IPTRLU, NPIV, 111 & NBCOL_STACK, NBROW_STACK, 112 & NBROW_SEND, SIZECB, KEEP, COMPRESSCB, 113 & LAST_ALLOWED, NBROW_ALREADY_STACKED ) 114 IMPLICIT NONE 115 INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB 116 LOGICAL, intent (in) :: COMPRESSCB 117 COMPLEX(kind=8) A(LA) 118 INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, 119 & NBROW_SEND 120 INTEGER, intent(inout) :: NBROW_ALREADY_STACKED 121 INTEGER(8), intent(in) :: LAST_ALLOWED 122 INTEGER(8) :: APOS, NPOS 123 INTEGER NBROW 124 INTEGER(8) :: J 125 INTEGER I, KEEP(500) 126#if ! defined(ALLOW_NON_INIT) 127 COMPLEX(kind=8) ZERO 128 PARAMETER( ZERO = (0.0D0,0.0D0) ) 129#endif 130 NBROW = NBROW_STACK + NBROW_SEND 131 IF (NBROW_STACK .NE. 0 ) THEN 132 NPOS = IPTRLU + SIZECB 133 APOS = POSELT + int(NPIV+NBROW,8) * int(LDA,8) - 1_8 134 IF ( KEEP(50) .EQ. 0 .OR. .NOT. COMPRESSCB ) THEN 135 APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) 136 NPOS = NPOS 137 & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) 138 ELSE 139 APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) 140 NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * 141 & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 142 ENDIF 143 DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 144 IF (KEEP(50).EQ.0) THEN 145 IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. 146 & LAST_ALLOWED ) THEN 147 EXIT 148 ENDIF 149 DO J= 1_8,int(NBCOL_STACK,8) 150 A(NPOS-J+1_8) = A(APOS-J+1_8) 151 ENDDO 152 NPOS = NPOS - int(NBCOL_STACK,8) 153 ELSE 154 IF (.NOT. COMPRESSCB) THEN 155 IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. 156 & LAST_ALLOWED ) THEN 157 EXIT 158 ENDIF 159#if ! defined(ALLOW_NON_INIT) 160 DO J = 1_8, int(NBCOL_STACK - I,8) 161 A(NPOS - J + 1_8) = ZERO 162 END DO 163#endif 164 NPOS = NPOS + int(- NBCOL_STACK + I,8) 165 ENDIF 166 IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN 167 EXIT 168 ENDIF 169 DO J =1_8, int(I,8) 170 A(NPOS-J+1_8) = A(APOS-J+1_8) 171 ENDDO 172 NPOS = NPOS - int(I,8) 173 ENDIF 174 IF (KEEP(50).EQ.0) THEN 175 APOS = APOS - int(LDA,8) 176 ELSE 177 APOS = APOS - int(LDA + 1,8) 178 ENDIF 179 NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 180 ENDDO 181 END IF 182 RETURN 183 END SUBROUTINE ZMUMPS_652 184 SUBROUTINE ZMUMPS_705( A, LA, LDA, POSELT, 185 & IPTRLU, NPIV, 186 & NBCOL_STACK, NBROW_STACK, 187 & NBROW_SEND, SIZECB, KEEP, COMPRESSCB) 188 IMPLICIT NONE 189 INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB 190 LOGICAL, intent (in) :: COMPRESSCB 191 COMPLEX(kind=8) A(LA) 192 INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, 193 & NBROW_SEND 194 INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini 195 INTEGER I, KEEP(500) 196 INTEGER(8) :: J, LDA8 197#if ! defined(ALLOW_NON_INIT) 198 COMPLEX(kind=8) ZERO 199 PARAMETER( ZERO = (0.0D0,0.0D0) ) 200#endif 201 LDA8 = int(LDA,8) 202 NPOS_ini = IPTRLU + 1_8 203 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) 204 DO I = 1, NBROW_STACK 205 IF (COMPRESSCB) THEN 206 NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + 207 & int(I-1,8) * int(NBROW_SEND,8) 208 ELSE 209 NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) 210 ENDIF 211 APOS = APOS_ini + int(I-1,8) * LDA8 212 IF (KEEP(50).EQ.0) THEN 213 DO J = 1_8, int(NBCOL_STACK,8) 214 A(NPOS+J-1_8) = A(APOS+J-1_8) 215 ENDDO 216 ELSE 217 DO J = 1_8, int(I + NBROW_SEND,8) 218 A(NPOS+J-1_8)=A(APOS+J-1_8) 219 ENDDO 220#if ! defined(ALLOW_NON_INIT) 221 IF (.NOT. COMPRESSCB) THEN 222 A(NPOS+int(I+NBROW_SEND,8): 223 & NPOS+int(NBCOL_STACK-1,8))=ZERO 224 ENDIF 225#endif 226 ENDIF 227 ENDDO 228 RETURN 229 END SUBROUTINE ZMUMPS_705 230 SUBROUTINE ZMUMPS_140( N, INODE, IW, LIW, A, LA, 231 & IOLDPS, POSELT, IFLAG, 232 & UU, NNEG, NPVW, 233 & KEEP,KEEP8, 234 & MYID, SEUIL, AVOID_DELAYED, ETATASS, 235 & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS ) 236 USE ZMUMPS_OOC 237 IMPLICIT NONE 238 INTEGER(8) :: LA, POSELT 239 INTEGER N, INODE, LIW, IFLAG, NNEG, NPVW 240 INTEGER MYID, IOLDPS 241 INTEGER KEEP( 500 ) 242 INTEGER(8) KEEP8(150) 243 DOUBLE PRECISION UU, SEUIL 244 COMPLEX(kind=8) A( LA ) 245 INTEGER, TARGET :: IW( LIW ) 246 LOGICAL AVOID_DELAYED 247 INTEGER ETATASS, IWPOS 248 INTEGER LPN_LIST 249 INTEGER PIVNUL_LIST(LPN_LIST) 250 DOUBLE PRECISION DKEEP(30) 251 INTEGER INOPV, IFINB, NFRONT, NPIV, NBOLKJ, 252 & NBTLKJ,IBEG_BLOCK 253 INTEGER NASS, NEL1, IFLAG_OOC 254 INTEGER :: LDA 255 DOUBLE PRECISION UUTEMP 256 INCLUDE 'mumps_headers.h' 257 EXTERNAL ZMUMPS_222, ZMUMPS_234, 258 & ZMUMPS_230, ZMUMPS_226, 259 & ZMUMPS_237 260 LOGICAL STATICMODE 261 DOUBLE PRECISION SEUIL_LOC 262 INTEGER PIVSIZ,IWPOSP2 263 INTEGER(8) :: LAFAC 264 INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, 265 & IDUMMY 266 LOGICAL POSTPONE_COL_UPDATE, IS_MAXFROMM_AVAIL 267 DOUBLE PRECISION MAXFROMM 268 TYPE(IO_BLOCK) :: MonBloc 269 LOGICAL LAST_CALL 270 INTEGER PP_FIRST2SWAP_L 271 INTEGER PP_LastPIVRPTRFilled 272 IS_MAXFROMM_AVAIL = .FALSE. 273 INOPV = 0 274 SEUIL_LOC = SEUIL 275 IF(KEEP(97) .EQ. 0) THEN 276 STATICMODE = .FALSE. 277 ELSE 278 STATICMODE = .TRUE. 279 ENDIF 280 IF (AVOID_DELAYED) THEN 281 STATICMODE = .TRUE. 282 UUTEMP=UU 283 SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) 284 ELSE 285 UUTEMP=UU 286 ENDIF 287 POSTPONE_COL_UPDATE = (UUTEMP == 0.0D0 .AND. KEEP(201).NE.1) 288 IBEG_BLOCK = 1 289 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 290 LDA = NFRONT 291 NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) 292 IF (NASS .GT. KEEP(3)) THEN 293 NBOLKJ = min( KEEP(6), NASS ) 294 ELSE 295 NBOLKJ = min( KEEP(5), NASS ) 296 ENDIF 297 NBTLKJ = NBOLKJ 298 IF (KEEP(201).EQ.1) THEN 299 IDUMMY = -8765 300 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) 301 LIWFAC = IW(IOLDPS+XXI) 302 TYPEFile = TYPEF_L 303 NextPiv2beWritten = 1 304 PP_FIRST2SWAP_L = NextPiv2beWritten 305 MonBloc%LastPanelWritten_L = 0 306 PP_LastPIVRPTRFilled = 0 307 MonBloc%INODE = INODE 308 MonBloc%MASTER = .TRUE. 309 MonBloc%Typenode = 1 310 MonBloc%NROW = NFRONT 311 MonBloc%NCOL = NFRONT 312 MonBloc%NFS = NASS 313 MonBloc%Last = .FALSE. 314 MonBloc%LastPiv = -77777 315 MonBloc%INDICES => 316 & IW(IOLDPS+6+NFRONT+KEEP(IXSZ): 317 & IOLDPS+5+NFRONT+KEEP(IXSZ)+NFRONT) 318 ENDIF 319 IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) 320 UUTEMP = UU 321 50 CONTINUE 322 CALL ZMUMPS_222(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 323 & INOPV, NNEG, IFLAG,IOLDPS,POSELT,UUTEMP, 324 & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, 325 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, KEEP(IXSZ), 326 & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, 327 & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL) 328 IF (IFLAG.LT.0) GOTO 500 329 IF(KEEP(109).GT. 0) THEN 330 IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN 331 IWPOSP2 = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6+KEEP(IXSZ) 332 & +IW(IOLDPS+5+KEEP(IXSZ)) 333 PIVNUL_LIST(KEEP(109)) = IW(IWPOSP2) 334 ENDIF 335 ENDIF 336 IF (INOPV.EQ.1) THEN 337 IF(STATICMODE) THEN 338 INOPV = -1 339 GOTO 50 340 ENDIF 341 CALL ZMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 342 & LDA, IOLDPS,POSELT, KEEP,KEEP8, POSTPONE_COL_UPDATE, 343 & ETATASS, 344 & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, 345 & LIWFAC, MYID, IFLAG) 346 GOTO 500 347 END IF 348 IF (INOPV.EQ.2) THEN 349 CALL ZMUMPS_234(IBEG_BLOCK, 350 & NFRONT,NASS,N,INODE,IW,LIW,A,LA, 351 & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), 352 & POSTPONE_COL_UPDATE, 353 & KEEP,KEEP8) 354 GOTO 50 355 ENDIF 356 NPVW = NPVW + PIVSIZ 357 IF (NASS.LE.1) THEN 358 CALL ZMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, 359 & IOLDPS,POSELT) 360 IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 361 GO TO 500 362 ENDIF 363 CALL ZMUMPS_226(IBEG_BLOCK, 364 & NFRONT, NASS, N,INODE,IW,LIW,A,LA, 365 & LDA, POSTPONE_COL_UPDATE, IOLDPS, 366 & POSELT,IFINB, 367 & NBTLKJ,PIVSIZ, KEEP(IXSZ),MAXFROMM, 368 & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0D0), 369 & KEEP(253) ) 370 IF(PIVSIZ .EQ. 2) THEN 371 IWPOSP2 = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6 372 IW(IWPOSP2+NFRONT+KEEP(IXSZ)) = -IW(IWPOSP2+NFRONT+KEEP(IXSZ)) 373 ENDIF 374 IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ 375 IF (IFINB.EQ.0) GOTO 50 376 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 377 NEL1 = NASS - NPIV 378 IF (KEEP(201).EQ.1) THEN 379 IF (IFINB.EQ.-1) THEN 380 MonBloc%Last = .TRUE. 381 ELSE 382 MonBloc%Last = .FALSE. 383 ENDIF 384 MonBloc%LastPiv= NPIV 385 LAST_CALL=.FALSE. 386 CALL ZMUMPS_688( 387 & STRAT_TRY_WRITE, 388 & TYPEFile, A(POSELT), 389 & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), 390 & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 391 IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC 392 IF (IFLAG .LT. 0 ) RETURN 393 ENDIF 394 CALL ZMUMPS_234(IBEG_BLOCK, 395 & NFRONT,NASS,N,INODE,IW,LIW,A,LA, 396 & LDA, IOLDPS,POSELT, NBOLKJ, NBTLKJ,KEEP(4), 397 & POSTPONE_COL_UPDATE, 398 & KEEP,KEEP8) 399 IF (IFINB.EQ.-1) THEN 400 CALL ZMUMPS_237(NFRONT,NASS,N,INODE,IW,LIW,A,LA, 401 & LDA, IOLDPS,POSELT, KEEP,KEEP8, 402 & POSTPONE_COL_UPDATE, ETATASS, 403 & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, 404 & LIWFAC, MYID, IFLAG) 405 & 406 GOTO 500 407 ENDIF 408 GO TO 50 409 500 CONTINUE 410 IF (KEEP(201).EQ.1) THEN 411 STRAT = STRAT_WRITE_MAX 412 MonBloc%Last = .TRUE. 413 MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) 414 LAST_CALL=.TRUE. 415 CALL ZMUMPS_688 416 & ( STRAT, TYPEFile, 417 & A(POSELT), LAFAC, MonBloc, 418 & NextPiv2beWritten, IDUMMY, 419 & IW(IOLDPS), LIWFAC, 420 & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 421 IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC 422 IF (IFLAG < 0 ) RETURN 423 CALL ZMUMPS_644 (IWPOS, 424 & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) 425 ENDIF 426 RETURN 427 END SUBROUTINE ZMUMPS_140 428 SUBROUTINE ZMUMPS_222 429 & (NFRONT,NASS,N,INODE,IW,LIW, 430 & A,LA, INOPV, 431 & NNEG, 432 & IFLAG,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, 433 & DKEEP,PIVNUL_LIST,LPN_LIST, XSIZE, 434 & PP_FIRST2SWAP_L, PP_LastPanelonDisk, 435 & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL) 436#if defined (PROFILE_BLAS_ASS_G) 437 USE ZMUMPS_LOAD 438#endif 439 USE MUMPS_OOC_COMMON 440 IMPLICIT NONE 441 INTEGER(8) :: POSELT, LA 442 INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV, 443 & IOLDPS, NNEG 444 INTEGER PIVSIZ,LPIV, XSIZE 445 COMPLEX(kind=8) A(LA) 446 DOUBLE PRECISION UU, UULOC, SEUIL 447 INTEGER IW(LIW) 448 INTEGER KEEP(500) 449 INTEGER(8) KEEP8(150) 450 INTEGER LPN_LIST 451 INTEGER PIVNUL_LIST(LPN_LIST) 452 DOUBLE PRECISION DKEEP(30) 453 INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk 454 INTEGER PP_LastPIVRPTRIndexFilled 455 DOUBLE PRECISION, intent(in) :: MAXFROMM 456 LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL 457 include 'mpif.h' 458 INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ 459 INTEGER JMAX 460 DOUBLE PRECISION RMAX,AMAX,TMAX,TOL 461 DOUBLE PRECISION MAXPIV 462 DOUBLE PRECISION PIVNUL 463 COMPLEX(kind=8) FIXA, CSEUIL 464 COMPLEX(kind=8) PIVOT,DETPIV 465 PARAMETER(TOL = 1.0D-20) 466 INCLUDE 'mumps_headers.h' 467 INTEGER :: J 468 INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini 469 INTEGER :: LDA 470 INTEGER(8) :: LDA8 471 INTEGER NPIV,NASSW,IPIV 472 INTEGER NPIVP1,K 473 INTRINSIC max 474 COMPLEX(kind=8) ZERO, ONE 475 PARAMETER( ZERO = (0.0D0,0.0D0) ) 476 PARAMETER( ONE = (1.0D0,1.0D0) ) 477 DOUBLE PRECISION RZERO,RONE 478 PARAMETER(RZERO=0.0D0, RONE=1.0D0) 479 LOGICAL OMP_FLAG 480 INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 481 PIVNUL = DKEEP(1) 482 FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) 483 CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) 484 LDA = NFRONT 485 LDA8 = int(LDA,8) 486 NFRONT8 = int(NFRONT,8) 487 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 488 CALL ZMUMPS_667(TYPEF_L, NBPANELS_L, 489 & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), 490 & IW, LIW) 491 ENDIF 492 UULOC = UU 493 PIVSIZ = 1 494 NPIV = IW(IOLDPS+1+XSIZE) 495 NPIVP1 = NPIV + 1 496 NASSW = iabs(IW(IOLDPS+3+XSIZE)) 497 IF(INOPV .EQ. -1) THEN 498 APOS = POSELT + (LDA8+1_8) * int(NPIV,8) 499 POSPV1 = APOS 500 IF(abs(A(APOS)).LT.SEUIL) THEN 501 IF(dble(A(APOS)) .GE. RZERO) THEN 502 A(APOS) = CSEUIL 503 ELSE 504 A(APOS) = -CSEUIL 505 ENDIF 506 KEEP(98) = KEEP(98)+1 507 ELSE IF (KEEP(258) .NE. 0) THEN 508 CALL ZMUMPS_762( A(APOS), DKEEP(6), KEEP(259) ) 509 ENDIF 510 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 511 CALL ZMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, 512 & IW(I_PIVR), NASS, NPIVP1, NPIVP1, 513 & PP_LastPanelonDisk, 514 & PP_LastPIVRPTRIndexFilled) 515 ENDIF 516 GO TO 420 517 ENDIF 518 INOPV = 0 519 DO 460 IPIV=NPIVP1,NASSW 520 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) 521 POSPV1 = APOS + int(IPIV - NPIVP1,8) 522 PIVOT = A(POSPV1) 523 IF (UULOC.EQ.RZERO) THEN 524 IF (abs(A(APOS)).EQ.RZERO) GO TO 630 525 IF (KEEP(258) .NE. 0) THEN 526 CALL ZMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) 527 ENDIF 528 GO TO 420 529 ENDIF 530 AMAX = RZERO 531 JMAX = 0 532 IF ( IS_MAXFROMM_AVAIL ) THEN 533 IF ( MAXFROMM > PIVNUL .AND. abs(PIVOT) > TOL) THEN 534 IF ( abs(PIVOT) .GT. max(UULOC*MAXFROMM,SEUIL) ) THEN 535 IF (KEEP(258) .NE. 0) THEN 536 CALL ZMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) 537 ENDIF 538 GOTO 415 539 ENDIF 540 ENDIF 541 IS_MAXFROMM_AVAIL = .FALSE. 542 ENDIF 543 J1 = APOS 544 J2 = POSPV1 - 1_8 545 DO JJ=J1,J2 546 IF(abs(A(JJ)) .GT. AMAX) THEN 547 AMAX = abs(A(JJ)) 548 JMAX = IPIV - int(POSPV1-JJ) 549 ENDIF 550 ENDDO 551 J1 = POSPV1 + LDA8 552 DO J=1, NASSW - IPIV 553 IF(abs(A(J1)) .GT. AMAX) THEN 554 AMAX = abs(A(J1)) 555 JMAX = IPIV + J 556 ENDIF 557 J1 = J1 + LDA8 558 ENDDO 559 RMAX = RZERO 560 J1_ini = J1 561 IF ( (NFRONT - KEEP(253) - NASSW).GE.300 ) THEN 562 OMP_FLAG = .TRUE. 563 ELSE 564 OMP_FLAG = .FALSE. 565 ENDIF 566 DO J=1, NFRONT - KEEP(253) - NASSW 567 J1 = J1_ini + int(J-1,8) * LDA8 568 RMAX = max(abs(A(J1)),RMAX) 569 ENDDO 570 IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN 571 KEEP(109) = KEEP(109)+1 572 PIVNUL_LIST(KEEP(109)) = -1 573 IF(dble(FIXA).GT.RZERO) THEN 574 IF(dble(PIVOT) .GE. RZERO) THEN 575 A(POSPV1) = FIXA 576 ELSE 577 A(POSPV1) = -FIXA 578 ENDIF 579 ELSE 580 J1 = APOS 581 J2 = POSPV1 - 1_8 582 DO JJ=J1,J2 583 A(JJ) = ZERO 584 ENDDO 585 J1 = POSPV1 + LDA8 586 DO J=1, NASSW - IPIV 587 A(J1) = ZERO 588 J1 = J1 + LDA8 589 ENDDO 590 DO J=1,NFRONT - NASSW 591 A(J1) = ZERO 592 J1 = J1 + LDA8 593 ENDDO 594 A(POSPV1) = ONE 595 ENDIF 596 PIVOT = A(POSPV1) 597 GO TO 415 598 ENDIF 599 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN 600 IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN 601 IF(SEUIL .GT. epsilon(SEUIL)) THEN 602 IF(dble(PIVOT) .GE. RZERO) THEN 603 A(POSPV1) = CSEUIL 604 ELSE 605 A(POSPV1) = -CSEUIL 606 ENDIF 607 PIVOT = A(POSPV1) 608 KEEP(98) = KEEP(98)+1 609 GO TO 415 610 ENDIF 611 ENDIF 612 ENDIF 613 IF (max(AMAX,abs(PIVOT)).LE.TOL) GO TO 460 614 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN 615 IF (KEEP(258) .NE.0 ) THEN 616 CALL ZMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) 617 ENDIF 618 GO TO 415 619 END IF 620 IF (AMAX.LE.TOL) GO TO 460 621 IF (RMAX.LT.AMAX) THEN 622 J1 = APOS 623 J2 = POSPV1 - 1_8 624 DO JJ=J1,J2 625 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN 626 RMAX = max(RMAX,abs(A(JJ))) 627 ENDIF 628 ENDDO 629 J1 = POSPV1 + LDA8 630 DO J=1,NASS-IPIV 631 IF(IPIV+J .NE. JMAX) THEN 632 RMAX = max(abs(A(J1)),RMAX) 633 ENDIF 634 J1 = J1 + LDA8 635 ENDDO 636 ENDIF 637 APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) 638 POSPV2 = APOSJ + int(JMAX - NPIVP1,8) 639 IF (IPIV.LT.JMAX) THEN 640 OFFDAG = APOSJ + int(IPIV - NPIVP1,8) 641 ELSE 642 OFFDAG = APOS + int(JMAX - NPIVP1,8) 643 END IF 644 TMAX = RZERO 645 IF(JMAX .LT. IPIV) THEN 646 JJ_ini = POSPV2 647 OMP_FLAG = (NFRONT-JMAX-KEEP(253). GE. 300) 648 DO K = 1, NFRONT - JMAX - KEEP(253) 649 JJ = JJ_ini+ int(K,8)*NFRONT8 650 IF (JMAX+K.NE.IPIV) THEN 651 TMAX=max(TMAX,abs(A(JJ))) 652 ENDIF 653 ENDDO 654 DO KK = APOSJ, POSPV2-1_8 655 TMAX = max(TMAX,abs(A(KK))) 656 ENDDO 657 ELSE 658 JJ_ini = POSPV2 659 OMP_FLAG = (NFRONT-JMAX-KEEP(253). GE. 300) 660 DO K = 1, NFRONT-JMAX-KEEP(253) 661 JJ = JJ_ini + int(K,8)*NFRONT8 662 TMAX=max(TMAX,abs(A(JJ))) 663 ENDDO 664 DO KK = APOSJ, POSPV2 - 1_8 665 IF (KK.NE.OFFDAG) THEN 666 TMAX = max(TMAX,abs(A(KK))) 667 ENDIF 668 ENDDO 669 ENDIF 670 DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 671 IF (SEUIL.GT.RZERO) THEN 672 IF (sqrt(abs(DETPIV)) .LE. SEUIL ) GOTO 460 673 ENDIF 674 MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) 675 IF (MAXPIV.EQ.RZERO) MAXPIV = RONE 676 IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 677 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. 678 & abs(DETPIV)) GO TO 460 679 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. 680 & abs(DETPIV)) GO TO 460 681 IF (KEEP(258) .NE.0 ) THEN 682 CALL ZMUMPS_762(DETPIV, DKEEP(6), KEEP(259)) 683 ENDIF 684 PIVSIZ = 2 685 KEEP(103) = KEEP(103)+1 686 415 CONTINUE 687 DO K=1,PIVSIZ 688 IF (PIVSIZ .EQ. 2) THEN 689 IF (K==1) THEN 690 LPIV = min(IPIV,JMAX) 691 ELSE 692 LPIV = max(IPIV,JMAX) 693 ENDIF 694 ELSE 695 LPIV = IPIV 696 ENDIF 697 IF (LPIV.EQ.NPIVP1) THEN 698 GOTO 416 699 ENDIF 700 CALL ZMUMPS_319( A, LA, IW, LIW, 701 & IOLDPS, NPIVP1, LPIV, POSELT, NASS, 702 & LDA, NFRONT, 1, KEEP(219), KEEP(50), 703 & KEEP(IXSZ)) 704 416 CONTINUE 705 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 706 CALL ZMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, 707 & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, 708 & PP_LastPIVRPTRIndexFilled) 709 ENDIF 710 NPIVP1 = NPIVP1 + 1 711 ENDDO 712 IF(PIVSIZ .EQ. 2) THEN 713 A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV 714 ENDIF 715 GOTO 420 716 460 CONTINUE 717 IF (NASSW.EQ.NASS) THEN 718 INOPV = 1 719 ELSE 720 INOPV = 2 721 ENDIF 722 GO TO 420 723 630 CONTINUE 724 PIVSIZ = 0 725 IFLAG = -10 726 420 CONTINUE 727 IS_MAXFROMM_AVAIL = .FALSE. 728 RETURN 729 END SUBROUTINE ZMUMPS_222 730 SUBROUTINE ZMUMPS_680( PIVRPTR, NBPANELS, PIVR, NASS, 731 & K, P, LastPanelonDisk, 732 & LastPIVRPTRIndexFilled) 733 IMPLICIT NONE 734 INTEGER, intent(in) :: NBPANELS, NASS, K, P 735 INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) 736 INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled 737 INTEGER I 738 IF ( LastPanelonDisk+1 > NBPANELS ) THEN 739 WRITE(*,*) "INTERNAL ERROR IN ZMUMPS_680!" 740 WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) 741 WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk 742 WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled 743 CALL MUMPS_ABORT() 744 ENDIF 745 PIVRPTR(LastPanelonDisk+1) = K + 1 746 IF (LastPanelonDisk.NE.0) THEN 747 PIVR(K - PIVRPTR(1) + 1) = P 748 DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk 749 PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) 750 ENDDO 751 ENDIF 752 LastPIVRPTRIndexFilled = LastPanelonDisk + 1 753 RETURN 754 END SUBROUTINE ZMUMPS_680 755 SUBROUTINE ZMUMPS_226(IBEG_BLOCK, 756 & NFRONT,NASS,N,INODE,IW,LIW, 757 & A,LA,LDA, POSTPONE_COL_UPDATE, 758 & IOLDPS,POSELT,IFINB,LKJIB,PIVSIZ,XSIZE, 759 & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, 760 & KEEP253) 761 IMPLICIT NONE 762 INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB, 763 & NPBEG, IBEG_BLOCK 764 INTEGER LDA 765 INTEGER(8) :: LA 766 INTEGER(8) :: NFRONT8 767 COMPLEX(kind=8) A(LA) 768 LOGICAL POSTPONE_COL_UPDATE 769 INTEGER IW(LIW) 770 COMPLEX(kind=8) VALPIV 771 INTEGER(8) :: POSELT 772 DOUBLE PRECISION, intent(out) :: MAXFROMM 773 LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL 774 LOGICAL, intent(in) :: IS_MAX_USEFUL 775 INTEGER, INTENT(in) :: KEEP253 776 DOUBLE PRECISION :: MAXFROMMTMP 777 INTEGER IOLDPS, NCB1 778 INTEGER(8) :: LDA8 779 INTEGER(8) :: K1POS 780 INTEGER NPIV,JROW2 781 INTEGER NEL2,NEL 782 INTEGER XSIZE 783 COMPLEX(kind=8) ONE, ZERO 784 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 785 INTEGER(8) :: POSPV1, POSPV2 786 INTEGER PIVSIZ,NPIV_NEW,J2,I 787 INTEGER(8) :: OFFDAG, OFFDAG_OLD, IBEG, IEND 788 INTEGER(8) :: JJ, K1, K2, IROW 789 COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2 790 INCLUDE 'mumps_headers.h' 791 PARAMETER(ONE = (1.0D0,0.0D0), 792 & ZERO = (0.0D0,0.0D0)) 793 LDA8 = int(LDA,8) 794 NFRONT8= int(NFRONT,8) 795 NPIV = IW(IOLDPS+1+XSIZE) 796 NPIV_NEW = NPIV + PIVSIZ 797 NEL = NFRONT - NPIV_NEW 798 IFINB = 0 799 IS_MAXFROMM_AVAIL = .FALSE. 800 JROW2 = IW(IOLDPS+3+XSIZE) 801 NPBEG = IBEG_BLOCK 802 NEL2 = JROW2 - NPIV_NEW 803 IF (NEL2.EQ.0) THEN 804 IF (JROW2.EQ.NASS) THEN 805 IFINB = -1 806 ELSE 807 IFINB = 1 808 ENDIF 809 ENDIF 810 IF(PIVSIZ .EQ. 1) THEN 811 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) 812 VALPIV = ONE/A(APOS) 813 A(APOS) = VALPIV 814 LPOS = APOS + LDA8 815 MAXFROMM = 0.0D00 816 IF (NEL2 > 0) THEN 817 IF (.NOT. IS_MAX_USEFUL) THEN 818 DO I=1, NEL2 819 K1POS = LPOS + int(I-1,8)*LDA8 820 A(APOS+int(I,8))=A(K1POS) 821 A(K1POS) = A(K1POS) * VALPIV 822 DO JJ=1_8, int(I,8) 823 A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) 824 ENDDO 825 ENDDO 826 ELSE 827 IS_MAXFROMM_AVAIL = .TRUE. 828 DO I=1, NEL2 829 K1POS = LPOS + int(I-1,8)*LDA8 830 A(APOS+int(I,8))=A(K1POS) 831 A(K1POS) = A(K1POS) * VALPIV 832 A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) 833 MAXFROMM=max( MAXFROMM,abs(A(K1POS+1_8)) ) 834 DO JJ = 2_8, int(I,8) 835 A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) 836 ENDDO 837 ENDDO 838 ENDIF 839 ENDIF 840 IF (POSTPONE_COL_UPDATE) THEN 841 NCB1 = NASS - JROW2 842 ELSE 843 NCB1 = NFRONT - JROW2 844 ENDIF 845 IF (.NOT. IS_MAX_USEFUL) THEN 846 DO I=NEL2+1, NEL2 + NCB1 847 K1POS = LPOS+ int(I-1,8)*LDA8 848 A(APOS+int(I,8))=A(K1POS) 849 A(K1POS) = A(K1POS) * VALPIV 850 DO JJ = 1_8, int(NEL2,8) 851 A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) 852 ENDDO 853 ENDDO 854 ELSE 855 MAXFROMMTMP=0.0D0 856 DO I=NEL2+1, NEL2 + NCB1 - KEEP253 857 K1POS = LPOS+ int(I-1,8)*LDA8 858 A(APOS+int(I,8))=A(K1POS) 859 A(K1POS) = A(K1POS) * VALPIV 860 IF (NEL2 > 0) THEN 861 A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) 862 MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) 863 DO JJ = 2_8, int(NEL2,8) 864 A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) 865 ENDDO 866 ENDIF 867 ENDDO 868 DO I = NEL2 + NCB1 - KEEP253 + 1, NEL2 + NCB1 869 K1POS = LPOS+ int(I-1,8)*LDA8 870 A(APOS+int(I,8))=A(K1POS) 871 A(K1POS) = A(K1POS) * VALPIV 872 DO JJ = 1_8, int(NEL2,8) 873 A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) 874 ENDDO 875 ENDDO 876 MAXFROMM=max(MAXFROMM, MAXFROMMTMP) 877 ENDIF 878 ELSE 879 POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) 880 POSPV2 = POSPV1 + NFRONT8 + 1_8 881 OFFDAG_OLD = POSPV2 - 1_8 882 OFFDAG = POSPV1 + 1_8 883 SWOP = A(POSPV2) 884 DETPIV = A(OFFDAG) 885 A(POSPV2) = A(POSPV1)/DETPIV 886 A(POSPV1) = SWOP/DETPIV 887 A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV 888 A(OFFDAG_OLD) = ZERO 889 LPOS1 = POSPV2 + LDA8 - 1_8 890 LPOS2 = LPOS1 + 1_8 891 CALL zcopy(NFRONT-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) 892 CALL zcopy(NFRONT-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) 893 JJ = POSPV2 + NFRONT8-1_8 894 IBEG = JJ + 2_8 895 IEND = IBEG 896 DO J2 = 1,NEL2 897 K1 = JJ 898 K2 = JJ+1_8 899 MULT1 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) 900 MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*A(K2)) 901 K1 = POSPV1 + 2_8 902 K2 = POSPV2 + 1_8 903 DO IROW = IBEG, IEND 904 A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) 905 K1 = K1 + 1_8 906 K2 = K2 + 1_8 907 ENDDO 908 A( JJ ) = -MULT1 909 A( JJ + 1_8 ) = -MULT2 910 IBEG = IBEG + NFRONT8 911 IEND = IEND + NFRONT8 + 1_8 912 JJ = JJ+NFRONT8 913 ENDDO 914 IEND = IEND-1_8 915 DO J2 = JROW2+1,NFRONT 916 K1 = JJ 917 K2 = JJ+1_8 918 MULT1 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) 919 MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*A(K2)) 920 K1 = POSPV1 + 2_8 921 K2 = POSPV2 + 1_8 922 DO IROW = IBEG, IEND 923 A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) 924 K1 = K1 + 1_8 925 K2 = K2 + 1_8 926 ENDDO 927 A( JJ ) = -MULT1 928 A( JJ + 1_8 ) = -MULT2 929 IBEG = IBEG + NFRONT8 930 IEND = IEND + NFRONT8 931 JJ = JJ + NFRONT8 932 ENDDO 933 ENDIF 934 RETURN 935 END SUBROUTINE ZMUMPS_226 936 SUBROUTINE ZMUMPS_230(NFRONT,N,INODE,IW,LIW,A,LA, 937 & IOLDPS,POSELT) 938 IMPLICIT NONE 939 INTEGER NFRONT,N,INODE,LIW 940 INTEGER(8) :: LA 941 COMPLEX(kind=8) A(LA) 942 INTEGER IW(LIW) 943 COMPLEX(kind=8) VALPIV 944 INTEGER (8) :: APOS, POSELT, LPOS, NFRONT8 945 INTEGER IOLDPS,NEL 946 INTEGER JROW 947 COMPLEX(kind=8), PARAMETER :: ONE = (1.0D0,0.0D0) 948 APOS = POSELT 949 VALPIV = ONE/A(APOS) 950 A(APOS) = VALPIV 951 NEL = NFRONT - 1 952 IF (NEL.EQ.0) GO TO 500 953 NFRONT8 = int(NFRONT,8) 954 LPOS = APOS + NFRONT8 955 CALL ZMUMPS_XSYR('U',NEL, -VALPIV, 956 & A(LPOS), NFRONT, A(LPOS+1_8), NFRONT) 957 DO JROW = 1,NEL 958 A(LPOS) = VALPIV*A(LPOS) 959 LPOS = LPOS + NFRONT8 960 END DO 961 500 CONTINUE 962 RETURN 963 END SUBROUTINE ZMUMPS_230 964 SUBROUTINE ZMUMPS_234(IBEG_BLOCK, 965 & NFRONT,NASS,N,INODE,IW,LIW,A,LA, 966 & LDA, 967 & IOLDPS,POSELT,LKJIB_ORIG,LKJIB,LKJIT, 968 & POSTPONE_COL_UPDATE, 969 & KEEP,KEEP8 ) 970 IMPLICIT NONE 971 INTEGER NFRONT, NASS,N,LIW, IBEG_BLOCK 972 INTEGER(8) :: LA 973 COMPLEX(kind=8) A(LA) 974 INTEGER IW(LIW) 975 INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) 976 INTEGER(8) KEEP8(150) 977 INTEGER(8) :: POSELT 978 INTEGER LDA 979 INTEGER(8) :: LDA8 980 INTEGER IOLDPS, NPIV, JROW2, NPBEG 981 INTEGER NONEL, LKJIW, NEL1, NEL11 982 INTEGER LBP, HF 983 INTEGER(8) :: LPOS,UPOS,APOS 984 INTEGER LKJIT 985 INTEGER LKJIBOLD, IROW 986 INTEGER I, Block 987 INTEGER BLSIZE 988 LOGICAL POSTPONE_COL_UPDATE 989 COMPLEX(kind=8) ONE, ALPHA 990 INCLUDE 'mumps_headers.h' 991 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 992 LDA8 = int(LDA,8) 993 LKJIBOLD = LKJIB 994 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 995 JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) 996 NPBEG = IBEG_BLOCK 997 HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) 998 NEL1 = NASS - JROW2 999 LKJIW = NPIV - NPBEG + 1 1000 NEL11 = NFRONT - NPIV 1001 IF ( LKJIW .NE. LKJIB ) THEN 1002 NONEL = JROW2 - NPIV + 1 1003 IF ((NASS-NPIV).GE.LKJIT) THEN 1004 LKJIB = LKJIB_ORIG + NONEL 1005 IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) 1006 LKJIB = min0(LKJIB, NASS - NPIV) 1007 ELSE 1008 LKJIB = NASS - NPIV 1009 IW(IOLDPS+3+KEEP(IXSZ)) = NASS 1010 ENDIF 1011 IBEG_BLOCK = NPIV + 1 1012 ELSEIF (JROW2.LT.NASS) THEN 1013 IBEG_BLOCK = NPIV + 1 1014 IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) 1015 LKJIB = min0(LKJIB,NASS-NPIV) 1016 ENDIF 1017 IF (LKJIW.EQ.0) GO TO 500 1018 IF (NEL1.NE.0) THEN 1019 IF ( NASS - JROW2 > KEEP(7) ) THEN 1020 BLSIZE = KEEP(8) 1021 ELSE 1022 BLSIZE = NASS - JROW2 1023 END IF 1024 IF ( NASS - JROW2 .GT. 0 ) THEN 1025#if defined(SAK_BYROW) 1026 DO IROW = JROW2+1, NASS, BLSIZE 1027 Block = min( BLSIZE, NASS - IROW + 1 ) 1028 LPOS = POSELT + int(IROW - 1,8) * LDA8 + int(NPBEG - 1,8) 1029 UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int(IROW - 1,8) 1030 APOS = POSELT + int(IROW - 1,8) * LDA8 + int(JROW2,8) 1031 CALL zgemm( 'N','N', IROW + Block - JROW2 - 1, Block, LKJIW, 1032 & ALPHA, A( UPOS ), LDA, 1033 & A( LPOS ), LDA, ONE, A( APOS ), LDA ) 1034 ENDDO 1035#else 1036 DO IROW = JROW2+1, NASS, BLSIZE 1037 Block = min( BLSIZE, NASS - IROW + 1 ) 1038 LPOS = POSELT + int( IROW - 1,8) * LDA8 + int(NPBEG - 1,8) 1039 UPOS = POSELT + int(NPBEG - 1,8) * LDA8 + int( IROW - 1,8) 1040 APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) 1041 CALL zgemm( 'N','N', Block, NASS - IROW + 1, LKJIW, 1042 & ALPHA, A( UPOS ), LDA, 1043 & A( LPOS ), LDA, ONE, A( APOS ), LDA ) 1044 END DO 1045#endif 1046 END IF 1047 LPOS = POSELT + int(NASS,8)*LDA8 + int(NPBEG - 1,8) 1048 UPOS = POSELT + int(NPBEG-1,8) * LDA8 + int(JROW2,8) 1049 APOS = POSELT + int(NASS,8)*LDA8 + int(JROW2,8) 1050 IF ( .NOT. POSTPONE_COL_UPDATE ) THEN 1051 CALL zgemm('N', 'N', NEL1, NFRONT-NASS, LKJIW, ALPHA, 1052 & A(UPOS), LDA, A(LPOS), LDA, ONE, 1053 & A(APOS), LDA) 1054 END IF 1055 ENDIF 1056 500 CONTINUE 1057 RETURN 1058 END SUBROUTINE ZMUMPS_234 1059 SUBROUTINE ZMUMPS_319( A, LA, IW, LIW, 1060 & IOLDPS, NPIVP1, IPIV, POSELT, NASS, 1061 & LDA, NFRONT, LEVEL, K219, K50, XSIZE ) 1062 IMPLICIT NONE 1063 INTEGER(8) :: POSELT, LA 1064 INTEGER LIW, IOLDPS, NPIVP1, IPIV 1065 INTEGER LDA, NFRONT, NASS, LEVEL, K219, K50, XSIZE 1066 COMPLEX(kind=8) A( LA ) 1067 INTEGER IW( LIW ) 1068 INCLUDE 'mumps_headers.h' 1069 INTEGER ISW, ISWPS1, ISWPS2, HF 1070 INTEGER(8) :: IDIAG, APOS 1071 INTEGER(8) :: LDA8 1072 COMPLEX(kind=8) SWOP 1073 LDA8 = int(LDA,8) 1074 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) 1075 IDIAG = APOS + int(IPIV - NPIVP1,8) 1076 HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE 1077 ISWPS1 = IOLDPS + HF + NPIVP1 - 1 1078 ISWPS2 = IOLDPS + HF + IPIV - 1 1079 ISW = IW(ISWPS1) 1080 IW(ISWPS1) = IW(ISWPS2) 1081 IW(ISWPS2) = ISW 1082 ISW = IW(ISWPS1+NFRONT) 1083 IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) 1084 IW(ISWPS2+NFRONT) = ISW 1085 IF ( LEVEL .eq. 2 ) THEN 1086 CALL zswap( NPIVP1 - 1, 1087 & A( POSELT + int(NPIVP1-1,8) ), LDA, 1088 & A( POSELT + int(IPIV-1,8) ), LDA ) 1089 END IF 1090 CALL zswap( NPIVP1-1, 1091 & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, 1092 & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) 1093 CALL zswap( IPIV - NPIVP1 - 1, 1094 & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), 1095 & LDA, A( APOS + 1_8 ), 1 ) 1096 SWOP = A(IDIAG) 1097 A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) 1098 A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP 1099 CALL zswap( NASS - IPIV, A( APOS + LDA8 ), LDA, 1100 & A( IDIAG + LDA8 ), LDA ) 1101 IF ( LEVEL .eq. 1 ) THEN 1102 CALL zswap( NFRONT - NASS, 1103 & A( APOS + int(NASS-IPIV+1,8) * LDA8 ), LDA, 1104 & A( IDIAG + int(NASS-IPIV+1,8) * LDA8 ), LDA ) 1105 END IF 1106 IF (K219.NE.0 .AND.K50.EQ.2) THEN 1107 IF ( LEVEL .eq. 2) THEN 1108 APOS = POSELT+LDA8*LDA8-1_8 1109 SWOP = A(APOS+int(NPIVP1,8)) 1110 A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) 1111 A(APOS+int(IPIV,8)) = SWOP 1112 ENDIF 1113 ENDIF 1114 RETURN 1115 END SUBROUTINE ZMUMPS_319 1116 SUBROUTINE ZMUMPS_237(NFRONT,NASS,N,INODE, 1117 & IW,LIW,A,LA, 1118 & LDA, 1119 & IOLDPS,POSELT,KEEP,KEEP8, 1120 & POSTPONE_COL_UPDATE, ETATASS, 1121 & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, 1122 & LIWFAC, MYID, IFLAG 1123 & ) 1124 USE ZMUMPS_OOC 1125 IMPLICIT NONE 1126 INTEGER NFRONT, NASS,N,INODE,LIW 1127 INTEGER(8) :: LA 1128 COMPLEX(kind=8) A(LA) 1129 INTEGER IW(LIW) 1130 INTEGER KEEP(500) 1131 INTEGER(8) KEEP8(150) 1132 INTEGER(8) :: POSELT 1133 INTEGER LDA 1134 INTEGER IOLDPS, ETATASS 1135 LOGICAL POSTPONE_COL_UPDATE 1136 INTEGER(8) :: LAFAC 1137 INTEGER TYPEFile, NextPiv2beWritten 1138 INTEGER LIWFAC, MYID, IFLAG 1139 TYPE(IO_BLOCK):: MonBloc 1140 INTEGER IDUMMY 1141 LOGICAL LAST_CALL 1142 INCLUDE 'mumps_headers.h' 1143 INTEGER(8) :: UPOS, APOS, LPOS 1144 INTEGER(8) :: LDA8 1145 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, I, IROWEND 1146 INTEGER I2, I2END, Block2 1147 COMPLEX(kind=8) ONE, ALPHA, BETA, ZERO 1148 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 1149 PARAMETER (ZERO=(0.0D0,0.0D0)) 1150 LDA8 = int(LDA,8) 1151 IF (ETATASS.EQ.1) THEN 1152 BETA = ZERO 1153 ELSE 1154 BETA = ONE 1155 ENDIF 1156 IF ( NFRONT - NASS > KEEP(57) ) THEN 1157 BLSIZE = KEEP(58) 1158 ELSE 1159 BLSIZE = NFRONT - NASS 1160 END IF 1161 BLSIZE2 = KEEP(218) 1162 NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) 1163 IF ( NFRONT - NASS .GT. 0 ) THEN 1164 IF ( POSTPONE_COL_UPDATE ) THEN 1165 CALL ztrsm( 'L', 'U', 'T', 'U', 1166 & NPIV, NFRONT-NPIV, ONE, 1167 & A( POSELT ), LDA, 1168 & A( POSELT + LDA8 * int(NPIV,8) ), LDA ) 1169 ENDIF 1170 DO IROWEND = NFRONT - NASS, 1, -BLSIZE 1171 Block = min( BLSIZE, IROWEND ) 1172 IROW = IROWEND - Block + 1 1173 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 1174 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + 1175 & int(NASS + IROW - 1,8) 1176 UPOS = POSELT + int(NASS,8) 1177 IF (.NOT. POSTPONE_COL_UPDATE) THEN 1178 UPOS = POSELT + int(NASS + IROW - 1,8) 1179 ENDIF 1180 IF (POSTPONE_COL_UPDATE) THEN 1181 DO I = 1, NPIV 1182 CALL zcopy( Block, A( LPOS+int(I-1,8) ), LDA, 1183 & A( UPOS+int(I-1,8)*LDA8 ), 1 ) 1184 CALL zscal( Block, A(POSELT+(LDA8+1_8)*int(I-1,8)), 1185 & A( LPOS + int(I - 1,8) ), LDA ) 1186 ENDDO 1187 ENDIF 1188 DO I2END = Block, 1, -BLSIZE2 1189 Block2 = min(BLSIZE2, I2END) 1190 I2 = I2END - Block2+1 1191 CALL zgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, 1192 & A(UPOS+int(I2-1,8)), LDA, 1193 & A(LPOS+int(I2-1,8)*LDA8), LDA, 1194 & BETA, 1195 & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) 1196 IF (KEEP(201).EQ.1) THEN 1197 IF (NextPiv2beWritten.LE.NPIV) THEN 1198 LAST_CALL=.FALSE. 1199 CALL ZMUMPS_688( 1200 & STRAT_TRY_WRITE, TYPEFile, 1201 & A(POSELT), LAFAC, MonBloc, 1202 & NextPiv2beWritten, IDUMMY, 1203 & IW(IOLDPS), LIWFAC, MYID, 1204 & KEEP8(31), 1205 & IFLAG,LAST_CALL ) 1206 IF (IFLAG .LT. 0 ) RETURN 1207 ENDIF 1208 ENDIF 1209 ENDDO 1210 IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN 1211 CALL zgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, 1212 & ALPHA, A( UPOS ), LDA, 1213 & A( LPOS + LDA8 * int(Block,8) ), LDA, 1214 & BETA, 1215 & A( APOS + LDA8 * int(Block,8) ), LDA ) 1216 ENDIF 1217 END DO 1218 END IF 1219 RETURN 1220 END SUBROUTINE ZMUMPS_237 1221 SUBROUTINE ZMUMPS_320( BUF, BLOCK_SIZE, 1222 & MYROW, MYCOL, NPROW, NPCOL, 1223 & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) 1224 IMPLICIT NONE 1225 INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM 1226 INTEGER MYROW, MYCOL, MYID 1227 COMPLEX(kind=8) BUF( BLOCK_SIZE * BLOCK_SIZE ) 1228 COMPLEX(kind=8) A( LOCAL_M, LOCAL_N ) 1229 INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE 1230 INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST 1231 INTEGER IGLOB, JGLOB 1232 INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE 1233 INTEGER IROW_LOC_DEST, JCOL_LOC_DEST 1234 INTEGER PROC_SOURCE, PROC_DEST 1235 NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 1236 DO IBLOCK = 1, NBLOCK 1237 IF ( IBLOCK .NE. NBLOCK 1238 & ) THEN 1239 IBLOCK_SIZE = BLOCK_SIZE 1240 ELSE 1241 IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE 1242 END IF 1243 ROW_SOURCE = mod( IBLOCK - 1, NPROW ) 1244 COL_DEST = mod( IBLOCK - 1, NPCOL ) 1245 IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 1246 IROW_LOC_SOURCE = BLOCK_SIZE * 1247 & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) 1248 & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 1249 JCOL_LOC_DEST = BLOCK_SIZE * 1250 & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) 1251 & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 1252 DO JBLOCK = 1, IBLOCK 1253 IF ( JBLOCK .NE. NBLOCK 1254 & ) THEN 1255 JBLOCK_SIZE = BLOCK_SIZE 1256 ELSE 1257 JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE 1258 END IF 1259 COL_SOURCE = mod( JBLOCK - 1, NPCOL ) 1260 ROW_DEST = mod( JBLOCK - 1, NPROW ) 1261 PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE 1262 PROC_DEST = ROW_DEST * NPCOL + COL_DEST 1263 IF ( PROC_SOURCE .eq. PROC_DEST ) THEN 1264 IF ( MYID .eq. PROC_DEST ) THEN 1265 JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 1266 JCOL_LOC_SOURCE = BLOCK_SIZE * 1267 & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) 1268 & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 1269 IROW_LOC_DEST = BLOCK_SIZE * 1270 & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) 1271 & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 1272 IF ( IBLOCK .eq. JBLOCK ) THEN 1273 IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN 1274 WRITE(*,*) MYID,': Error in calling transdiag:unsym' 1275 CALL MUMPS_ABORT() 1276 END IF 1277 CALL ZMUMPS_327( A( IROW_LOC_SOURCE, 1278 & JCOL_LOC_SOURCE), 1279 & IBLOCK_SIZE, LOCAL_M ) 1280 ELSE 1281 CALL ZMUMPS_326( 1282 & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), 1283 & A( IROW_LOC_DEST, JCOL_LOC_DEST ), 1284 & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) 1285 END IF 1286 END IF 1287 ELSE IF ( MYROW .eq. ROW_SOURCE 1288 & .AND. MYCOL .eq. COL_SOURCE ) THEN 1289 JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 1290 JCOL_LOC_SOURCE = BLOCK_SIZE * 1291 & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) 1292 & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 1293 CALL ZMUMPS_293( BUF, 1294 & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, 1295 & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) 1296 ELSE IF ( MYROW .eq. ROW_DEST 1297 & .AND. MYCOL .eq. COL_DEST ) THEN 1298 JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 1299 IROW_LOC_DEST = BLOCK_SIZE * 1300 & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) 1301 & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 1302 CALL ZMUMPS_281( BUF, 1303 & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, 1304 & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) 1305 END IF 1306 END DO 1307 END DO 1308 RETURN 1309 END SUBROUTINE ZMUMPS_320 1310 SUBROUTINE ZMUMPS_293( BUF, A, LDA, M, N, COMM, DEST ) 1311 IMPLICIT NONE 1312 INTEGER M, N, LDA, DEST, COMM 1313 COMPLEX(kind=8) BUF(*), A(LDA,*) 1314 INTEGER I, IBUF, IERR 1315 INTEGER J 1316 INCLUDE 'mpif.h' 1317 INCLUDE 'mumps_tags.h' 1318 IBUF = 1 1319 DO J = 1, N 1320 BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) 1321 DO I = 1, M 1322 END DO 1323 IBUF = IBUF + M 1324 END DO 1325 CALL MPI_SEND( BUF, M * N, MPI_DOUBLE_COMPLEX, 1326 & DEST, SYMMETRIZE, COMM, IERR ) 1327 RETURN 1328 END SUBROUTINE ZMUMPS_293 1329 SUBROUTINE ZMUMPS_281( BUF, A, LDA, M, N, COMM, SOURCE ) 1330 IMPLICIT NONE 1331 INTEGER LDA, M, N, COMM, SOURCE 1332 COMPLEX(kind=8) BUF(*), A( LDA, *) 1333 INTEGER I, IBUF, IERR 1334 INCLUDE 'mpif.h' 1335 INCLUDE 'mumps_tags.h' 1336 INTEGER STATUS( MPI_STATUS_SIZE ) 1337 CALL MPI_RECV( BUF(1), M * N, MPI_DOUBLE_COMPLEX, SOURCE, 1338 & SYMMETRIZE, COMM, STATUS, IERR ) 1339 IBUF = 1 1340 DO I = 1, M 1341 CALL zcopy( N, BUF(IBUF), 1, A(I,1), LDA ) 1342 IBUF = IBUF + N 1343 END DO 1344 RETURN 1345 END SUBROUTINE ZMUMPS_281 1346 SUBROUTINE ZMUMPS_327( A, N, LDA ) 1347 IMPLICIT NONE 1348 INTEGER N,LDA 1349 COMPLEX(kind=8) A( LDA, * ) 1350 INTEGER I, J 1351 DO I = 2, N 1352 DO J = 1, I - 1 1353 A( J, I ) = A( I, J ) 1354 END DO 1355 END DO 1356 RETURN 1357 END SUBROUTINE ZMUMPS_327 1358 SUBROUTINE ZMUMPS_326( A1, A2, M, N, LD ) 1359 IMPLICIT NONE 1360 INTEGER M,N,LD 1361 COMPLEX(kind=8) A1( LD,* ), A2( LD, * ) 1362 INTEGER I, J 1363 DO J = 1, N 1364 DO I = 1, M 1365 A2( J, I ) = A1( I, J ) 1366 END DO 1367 END DO 1368 RETURN 1369 END SUBROUTINE ZMUMPS_326 1370 RECURSIVE SUBROUTINE ZMUMPS_274( 1371 & COMM_LOAD, ASS_IRECV, 1372 & BUFR, LBUFR, 1373 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, 1374 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, 1375 & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, 1376 & COMP, STEP, PIMASTER, PAMASTER, POSFAC, 1377 & MYID, COMM, IFLAG, IERROR, NBFIN, 1378 & 1379 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, 1380 & ITLOC, RHS_MUMPS, FILS, 1381 & PTRARW, PTRAIW, INTARR, DBLARR, 1382 & ICNTL, KEEP,KEEP8, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, 1383 & LPTRAR, NELT, FRTPTR, FRTELT, 1384 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 1385 USE ZMUMPS_COMM_BUFFER 1386 USE ZMUMPS_LOAD 1387 USE ZMUMPS_OOC 1388 IMPLICIT NONE 1389 INCLUDE 'zmumps_root.h' 1390 INCLUDE 'mumps_headers.h' 1391 TYPE (ZMUMPS_ROOT_STRUC) :: root 1392 INTEGER ICNTL( 40 ), KEEP( 500 ) 1393 INTEGER(8) KEEP8(150) 1394 INTEGER COMM_LOAD, ASS_IRECV 1395 INTEGER LBUFR, LBUFR_BYTES 1396 INTEGER BUFR( LBUFR ) 1397 INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW 1398 INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC 1399 INTEGER COMP 1400 INTEGER IFLAG, IERROR, NBFIN, MSGSOU 1401 INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), 1402 & NSTK_S(KEEP(28)) 1403 INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) 1404 INTEGER NBPROCFILS( KEEP(28) ), STEP(N), 1405 & PIMASTER(KEEP(28)) 1406 INTEGER IW( LIW ) 1407 COMPLEX(kind=8) A( LA ) 1408 INTEGER LPTRAR, NELT 1409 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 1410 INTEGER COMM, MYID 1411 INTEGER PTLUST_S(KEEP(28)), 1412 & ITLOC(N+KEEP(253)), FILS(N), ND(KEEP(28)) 1413 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 1414 INTEGER PTRAIW( LPTRAR ), PTRARW( LPTRAR ) 1415 INTEGER FRERE_STEPS(KEEP(28)) 1416 INTEGER INTARR( max(1,KEEP(14)) ) 1417 DOUBLE PRECISION OPASSW, OPELIW 1418 DOUBLE PRECISION FLOP1 1419 COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 1420 INTEGER LEAF, LPOOL 1421 INTEGER IPOOL( LPOOL ) 1422 INTEGER ISTEP_TO_INIV2(KEEP(71)), 1423 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 1424 INTEGER PIVI 1425 INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 1426 INTEGER J2 1427 COMPLEX(kind=8) MULT1,MULT2 1428 INCLUDE 'mpif.h' 1429 INCLUDE 'mumps_tags.h' 1430 INTEGER STATUS( MPI_STATUS_SIZE ) 1431 INTEGER LP 1432 INTEGER INODE, POSITION, NPIV, IERR 1433 INTEGER NCOL 1434 INTEGER(8) LAELL, POSBLOCFACTO 1435 INTEGER(8) POSELT 1436 INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 1437 INTEGER NSLAV1, HS, ISW, DEST 1438 INTEGER ICT11 1439 INTEGER(8) LPOS, LPOS2, DPOS, UPOS 1440 INTEGER (8) IPOS, KPOS 1441 INTEGER I, IPIV, FPERE, NSLAVES_TOT, 1442 & NSLAVES_FOLLOW, NB_BLOC_FAC 1443 INTEGER IPOSK, JPOSK, NPIVSENT, Block, IROW, BLSIZE 1444 INTEGER allocok, TO_UPDATE_CPT_END 1445 COMPLEX(kind=8), DIMENSION(:),ALLOCATABLE :: UIP21K 1446 INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW 1447 LOGICAL LASTBL 1448 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 1449 COMPLEX(kind=8) ONE,ALPHA 1450 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 1451 INTEGER(8) :: LAFAC 1452 INTEGER LIWFAC, STRAT, NextPivDummy 1453 LOGICAL LAST_CALL 1454 TYPE(IO_BLOCK) :: MonBloc 1455 INTEGER MUMPS_275 1456 EXTERNAL MUMPS_275 1457 LP = ICNTL(1) 1458 IF (ICNTL(4) .LE. 0) LP = -1 1459 FPERE = -1 1460 POSITION = 0 1461 TO_UPDATE_CPT_END = -654321 1462 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, 1463 & MPI_INTEGER, COMM, IERR ) 1464 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, 1465 & MPI_INTEGER, COMM, IERR ) 1466 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, 1467 & MPI_INTEGER, COMM, IERR ) 1468 LASTBL = (NPIV.LE.0) 1469 IF (LASTBL) THEN 1470 NPIV = -NPIV 1471 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, 1472 & MPI_INTEGER, COMM, IERR ) 1473 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, 1474 & MPI_INTEGER, COMM, IERR ) 1475 ENDIF 1476 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, 1477 & MPI_INTEGER, COMM, IERR ) 1478 LAELL = int(NPIV,8) * int(NCOL,8) 1479 IF ( NPIV.GT.0 ) THEN 1480 IF ( LRLU .LT. LAELL .OR. IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN 1481 IF ( LRLUS .LT. LAELL ) THEN 1482 IFLAG = -9 1483 CALL MUMPS_731(LAELL-LRLUS, IERROR) 1484 IF (LP > 0 ) WRITE(LP,*) MYID, 1485 &": FAILURE IN ZMUMPS_274, 1486 & REAL WORKSPACE TOO SMALL" 1487 GOTO 700 1488 END IF 1489 CALL ZMUMPS_94(N, KEEP(28), IW, LIW, A, LA, 1490 & LRLU, IPTRLU, 1491 & IWPOS, IWPOSCB, PTRIST, PTRAST, 1492 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 1493 & KEEP(IXSZ)) 1494 COMP = COMP+1 1495 IF ( LRLU .NE. LRLUS ) THEN 1496 WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' 1497 & ,LRLU,LRLUS 1498 IFLAG = -9 1499 CALL MUMPS_731(LAELL-LRLUS,IERROR) 1500 GOTO 700 1501 END IF 1502 IF ( IWPOS + NPIV - 1 .GT. IWPOSCB ) THEN 1503 IF (LP > 0 ) WRITE(LP,*) MYID, 1504 &": FAILURE IN ZMUMPS_274, 1505 & INTEGER WORKSPACE TOO SMALL" 1506 IFLAG = -8 1507 IERROR = IWPOS + NPIV - 1 - IWPOSCB 1508 GOTO 700 1509 END IF 1510 END IF 1511 LRLU = LRLU - LAELL 1512 LRLUS = LRLUS - LAELL 1513 ENDIF 1514 KEEP8(67) = min(LRLUS, KEEP8(67)) 1515 POSBLOCFACTO = POSFAC 1516 POSFAC = POSFAC + LAELL 1517 CALL ZMUMPS_471(.FALSE.,.FALSE., 1518 & LA-LRLUS,0_8,LAELL,KEEP,KEEP8,LRLU) 1519 IF ( NPIV.GT.0 ) THEN 1520 IPIV = IWPOS 1521 IWPOS = IWPOS + NPIV 1522 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 1523 & IW( IPIV ), NPIV, 1524 & MPI_INTEGER, COMM, IERR ) 1525 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 1526 & A(POSBLOCFACTO), NPIV*NCOL, MPI_DOUBLE_COMPLEX, 1527 & COMM, IERR ) 1528 ENDIF 1529 IF (PTRIST(STEP( INODE )) .EQ. 0) THEN 1530 DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) 1531 BLOCKING = .TRUE. 1532 SET_IRECV= .FALSE. 1533 MESSAGE_RECEIVED = .FALSE. 1534 CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, 1535 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 1536 & MSGSOU, MAITRE_DESC_BANDE, 1537 & STATUS, 1538 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1539 & IWPOS, IWPOSCB, IPTRLU, 1540 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 1541 & PTLUST_S, PTRFAC, 1542 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 1543 & IFLAG, IERROR, COMM, 1544 & NBPROCFILS, 1545 & IPOOL, LPOOL, LEAF, 1546 & NBFIN, MYID, SLAVEF, 1547 & 1548 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1549 & FILS, PTRARW, PTRAIW, 1550 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 1551 & LPTRAR, NELT, FRTPTR, FRTELT, 1552 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 1553 IF ( IFLAG .LT. 0 ) GOTO 600 1554 END DO 1555 ENDIF 1556 DO WHILE ( NBPROCFILS(STEP(INODE)) .NE. 0 ) 1557 BLOCKING = .TRUE. 1558 SET_IRECV=.FALSE. 1559 MESSAGE_RECEIVED = .FALSE. 1560 CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, 1561 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 1562 & MPI_ANY_SOURCE, CONTRIB_TYPE2, 1563 & STATUS, 1564 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1565 & IWPOS, IWPOSCB, IPTRLU, 1566 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 1567 & PTLUST_S, PTRFAC, 1568 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 1569 & IFLAG, IERROR, COMM, 1570 & NBPROCFILS, 1571 & IPOOL, LPOOL, LEAF, 1572 & NBFIN, MYID, SLAVEF, 1573 & 1574 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1575 & FILS, PTRARW, PTRAIW, 1576 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 1577 & LPTRAR, NELT, FRTPTR, FRTELT, 1578 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 1579 IF ( IFLAG .LT. 0 ) GOTO 600 1580 END DO 1581 SET_IRECV = .TRUE. 1582 BLOCKING = .FALSE. 1583 MESSAGE_RECEIVED = .TRUE. 1584 CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, 1585 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 1586 & MPI_ANY_SOURCE, MPI_ANY_TAG, 1587 & STATUS, 1588 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1589 & IWPOS, IWPOSCB, IPTRLU, 1590 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 1591 & PTLUST_S, PTRFAC, 1592 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 1593 & IFLAG, IERROR, COMM, 1594 & NBPROCFILS, 1595 & IPOOL, LPOOL, LEAF, 1596 & NBFIN, MYID, SLAVEF, 1597 & 1598 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1599 & FILS, PTRARW, PTRAIW, 1600 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 1601 & LPTRAR, NELT, FRTPTR, FRTELT, 1602 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 1603 IOLDPS = PTRIST(STEP(INODE)) 1604 POSELT = PTRAST(STEP(INODE)) 1605 LCONT1 = IW( IOLDPS + KEEP(IXSZ)) 1606 NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) 1607 NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) 1608 NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) 1609 NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) 1610 NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM 1611 HS = 6 + NSLAV1 + KEEP(IXSZ) 1612 NCOL1 = LCONT1 + NPIV1 1613 IF ( LASTBL ) THEN 1614 TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * 1615 & NB_BLOC_FAC 1616 END IF 1617 IF (NPIV.GT.0) THEN 1618 IF ( NPIV1 + NCOL .NE. NASS1 ) THEN 1619 WRITE(*,*) 'SymBLFC Error: NPIV1 + NCOL .NE. NASS1 :', 1620 & NPIV1,NCOL,NASS1 1621 CALL MUMPS_ABORT() 1622 END IF 1623 ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 1624 DO I = 1, NPIV 1625 PIVI = abs(IW(IPIV+I-1)) 1626 IF (PIVI.EQ.I) CYCLE 1627 ISW = IW(ICT11+I) 1628 IW(ICT11+I) = IW(ICT11+PIVI) 1629 IW(ICT11+PIVI) = ISW 1630 IPOS = POSELT + int(NPIV1 + I - 1,8) 1631 KPOS = POSELT + int(NPIV1 + PIVI - 1,8) 1632 CALL zswap(NROW1, A(IPOS), NCOL1, A(KPOS), NCOL1) 1633 ENDDO 1634 ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) 1635 IF ( allocok .GT. 0 ) THEN 1636 IF (LP > 0 ) WRITE(LP,*) MYID, 1637 &": ALLOCATION FAILURE FOR UIP21K IN ZMUMPS_274" 1638 IFLAG = -13 1639 IERROR = NPIV * NROW1 1640 GOTO 700 1641 END IF 1642 IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN 1643 ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), 1644 & stat = allocok ) 1645 IF ( allocok .GT. 0 ) THEN 1646 IF (LP > 0 ) WRITE(LP,*) MYID, 1647 &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW 1648 & IN ZMUMPS_274" 1649 IFLAG = -13 1650 IERROR = NSLAVES_FOLLOW 1651 GOTO 700 1652 END IF 1653 LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= 1654 & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): 1655 & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) 1656 END IF 1657 CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, 1658 & A( POSBLOCFACTO ), NCOL, 1659 & A(POSELT+int(NPIV1,8)), NCOL1 ) 1660 LPOS = POSELT + int(NPIV1,8) 1661 UPOS = 1_8 1662 DO I = 1, NROW1 1663 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = 1664 & A(LPOS: LPOS+int(NPIV-1,8)) 1665 LPOS = LPOS + int(NCOL1,8) 1666 UPOS = UPOS + int(NPIV,8) 1667 END DO 1668 LPOS = POSELT + int(NPIV1,8) 1669 DPOS = POSBLOCFACTO 1670 I = 1 1671 DO 1672 IF(I .GT. NPIV) EXIT 1673 IF(IW(IPIV+I-1) .GT. 0) THEN 1674 CALL zscal( NROW1, A(DPOS), A(LPOS), NCOL1 ) 1675 LPOS = LPOS + 1_8 1676 DPOS = DPOS + int(NCOL + 1,8) 1677 I = I+1 1678 ELSE 1679 POSPV1 = DPOS 1680 POSPV2 = DPOS+ int(NCOL + 1,8) 1681 OFFDAG = POSPV1+1_8 1682 LPOS1 = LPOS 1683 DO J2 = 1,NROW1 1684 MULT1 = A(POSPV1)*A(LPOS1)+A(OFFDAG)*A(LPOS1+1_8) 1685 MULT2 = A(OFFDAG)*A(LPOS1)+A(POSPV2)*A(LPOS1+1_8) 1686 A(LPOS1) = MULT1 1687 A(LPOS1+1_8) = MULT2 1688 LPOS1 = LPOS1 + int(NCOL1,8) 1689 ENDDO 1690 LPOS = LPOS + 2_8 1691 DPOS = POSPV2 + int(NCOL + 1,8) 1692 I = I+2 1693 ENDIF 1694 ENDDO 1695 ENDIF 1696 IF (KEEP(201).eq.1) THEN 1697 MonBloc%INODE = INODE 1698 MonBloc%MASTER = .FALSE. 1699 MonBloc%Typenode = 2 1700 MonBloc%NROW = NROW1 1701 MonBloc%NCOL = NCOL1 1702 MonBloc%NFS = NASS1 1703 MonBloc%LastPiv = NPIV1 + NPIV 1704 NULLIFY(MonBloc%INDICES) 1705 MonBloc%Last = LASTBL 1706 STRAT = STRAT_TRY_WRITE 1707 NextPivDummy = -8888 1708 LIWFAC = IW(IOLDPS+XXI) 1709 CALL MUMPS_729(LAFAC, IW(IOLDPS+XXR)) 1710 LAST_CALL=.FALSE. 1711 CALL ZMUMPS_688( STRAT, TYPEF_L, A(POSELT), 1712 & LAFAC, MonBloc, NextPivDummy, NextPivDummy, 1713 & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) 1714 ENDIF 1715 IF (NPIV.GT.0) THEN 1716 LPOS2 = POSELT + int(NPIV1,8) 1717 UPOS = POSBLOCFACTO+int(NPIV,8) 1718 LPOS = LPOS2 + int(NPIV,8) 1719 CALL zgemm('N','N', NCOL-NPIV,NROW1,NPIV,ALPHA,A(UPOS),NCOL, 1720 & A(LPOS2),NCOL1,ONE, A(LPOS),NCOL1) 1721 DPOS = POSELT + int(NCOL1 - NROW1,8) 1722 IF ( NROW1 .GT. KEEP(7) ) THEN 1723 BLSIZE = KEEP(8) 1724 ELSE 1725 BLSIZE = NROW1 1726 ENDIF 1727 IF ( NROW1 .GT. 0 ) THEN 1728 DO IROW = 1, NROW1, BLSIZE 1729 Block = min( BLSIZE, NROW1 - IROW + 1 ) 1730 DPOS = POSELT + int(NCOL1 - NROW1,8) 1731 & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) 1732 LPOS2 = POSELT + int(NPIV1,8) 1733 & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) 1734 UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 1735 DO I = 1, Block 1736 CALL zgemv( 'T', NPIV, Block-I+1, ALPHA, 1737 & A( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, 1738 & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), 1739 & 1, ONE, A(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) 1740 END DO 1741 IF ( NROW1-IROW+1-Block .ne. 0 ) 1742 & CALL zgemm( 'T', 'N', Block, NROW1-IROW+1-Block, NPIV, ALPHA, 1743 & UIP21K( UPOS ), NPIV, 1744 & A( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, ONE, 1745 & A( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) 1746 ENDDO 1747 ENDIF 1748 FLOP1 = dble(NROW1) * dble(NPIV) * 1749 & dble( 2 * NCOL - NPIV + NROW1 +1 ) 1750 FLOP1 = -FLOP1 1751 CALL ZMUMPS_190( 1, .FALSE., FLOP1, KEEP,KEEP8 ) 1752 ENDIF 1753 IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV 1754 IW(IOLDPS + 3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV 1755 IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS + 3+KEEP(IXSZ)) 1756 LRLU = LRLU + LAELL 1757 LRLUS = LRLUS + LAELL 1758 POSFAC = POSFAC - LAELL 1759 IWPOS = IWPOS - NPIV 1760 CALL ZMUMPS_471(.FALSE.,.FALSE., 1761 & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 1762 IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN 1763 IPOSK = NPIV1 + 1 1764 JPOSK = NCOL1 - NROW1 + 1 1765 NPIVSENT = NPIV 1766 IERR = -1 1767 DO WHILE ( IERR .eq. -1 ) 1768 CALL ZMUMPS_64( 1769 & INODE, NPIVSENT, FPERE, 1770 & IPOSK, JPOSK, 1771 & UIP21K, NROW1, 1772 & NSLAVES_FOLLOW, 1773 & LIST_SLAVES_FOLLOW(1), 1774 & COMM, IERR ) 1775 IF (IERR .EQ. -1 ) THEN 1776 BLOCKING = .FALSE. 1777 SET_IRECV= .FALSE. 1778 MESSAGE_RECEIVED = .FALSE. 1779 CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, 1780 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 1781 & MPI_ANY_SOURCE, MPI_ANY_TAG, 1782 & STATUS, 1783 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1784 & IWPOS, IWPOSCB, IPTRLU, 1785 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 1786 & PTLUST_S, PTRFAC, 1787 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 1788 & IFLAG, IERROR, COMM, 1789 & NBPROCFILS, 1790 & IPOOL, LPOOL, LEAF, 1791 & NBFIN, MYID, SLAVEF, 1792 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 1793 & FILS, PTRARW, PTRAIW, 1794 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 1795 & LPTRAR, NELT, FRTPTR, FRTELT, 1796 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 1797 IF ( IFLAG .LT. 0 ) GOTO 600 1798 END IF 1799 END DO 1800 IF ( IERR .eq. -2 ) THEN 1801 IF (LP > 0 ) WRITE(LP,*) MYID, 1802 &": FAILURE, SEND BUFFER TOO SMALL DURING 1803 & ZMUMPS_274" 1804 WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1 1805 IFLAG = -17 1806 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) 1807 GOTO 700 1808 END IF 1809 IF ( IERR .eq. -3 ) THEN 1810 IF (LP > 0 ) WRITE(LP,*) MYID, 1811 &": FAILURE, RECV BUFFER TOO SMALL DURING 1812 & ZMUMPS_274" 1813 IFLAG = -20 1814 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) 1815 GOTO 700 1816 END IF 1817 DEALLOCATE(LIST_SLAVES_FOLLOW) 1818 END IF 1819 IF ( NPIV .NE. 0 ) DEALLOCATE( UIP21K ) 1820 IOLDPS = PTRIST(STEP(INODE)) 1821 IF (LASTBL) THEN 1822 IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) - 1823 & TO_UPDATE_CPT_END 1824 IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 1825 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 1826 & .and. NSLAVES_TOT.NE.1)THEN 1827 DEST = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 1828 CALL ZMUMPS_62( INODE, DEST, END_NIV2_LDLT, 1829 & COMM, IERR ) 1830 IF ( IERR .LT. 0 ) THEN 1831 write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' 1832 IFLAG = -99 1833 GOTO 700 1834 END IF 1835 ENDIF 1836 END IF 1837 IF (LASTBL) THEN 1838 IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN 1839 CALL ZMUMPS_759( COMM_LOAD, ASS_IRECV, 1840 & N, INODE, FPERE, 1841 & root, 1842 & MYID, COMM, 1843 & 1844 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1845 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 1846 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, 1847 & PAMASTER, 1848 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 1849 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 1850 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 1851 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 1852 & LPTRAR, NELT, FRTPTR, FRTELT, 1853 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 1854 ENDIF 1855 ENDIF 1856 600 CONTINUE 1857 RETURN 1858 700 CONTINUE 1859 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 1860 RETURN 1861 END SUBROUTINE ZMUMPS_274 1862 RECURSIVE SUBROUTINE ZMUMPS_759( 1863 & COMM_LOAD, ASS_IRECV, 1864 & N, INODE, FPERE, 1865 & root, 1866 & MYID, COMM, 1867 & 1868 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1869 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 1870 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, 1871 & PAMASTER, 1872 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 1873 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 1874 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 1875 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 1876 & LPTRAR, NELT, FRTPTR, FRTELT, 1877 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 1878 USE ZMUMPS_LOAD 1879 IMPLICIT NONE 1880 INCLUDE 'zmumps_root.h' 1881 INCLUDE 'mumps_headers.h' 1882 INCLUDE 'mpif.h' 1883 INCLUDE 'mumps_tags.h' 1884 INTEGER INODE, FPERE 1885 TYPE (ZMUMPS_ROOT_STRUC) :: root 1886 INTEGER COMM, MYID 1887 INTEGER ICNTL( 40 ), KEEP( 500 ) 1888 INTEGER(8) KEEP8(150) 1889 INTEGER COMM_LOAD, ASS_IRECV 1890 INTEGER N 1891 INTEGER LBUFR, LBUFR_BYTES 1892 INTEGER BUFR( LBUFR ) 1893 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA 1894 INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), 1895 & NSTK_S(KEEP(28)), PTLUST_S(KEEP(28)) 1896 INTEGER IWPOS, IWPOSCB 1897 INTEGER LIW 1898 INTEGER IW( LIW ) 1899 COMPLEX(kind=8) A( LA ) 1900 INTEGER LPTRAR, NELT 1901 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 1902 INTEGER(8) :: PTRAST(KEEP(28)) 1903 INTEGER(8) :: PTRFAC(KEEP(28)) 1904 INTEGER(8) :: PAMASTER(KEEP(28)) 1905 INTEGER STEP(N), PIMASTER(KEEP(28)) 1906 INTEGER COMP, IFLAG, IERROR 1907 INTEGER NBPROCFILS( KEEP(28) ) 1908 INTEGER LPOOL, LEAF 1909 INTEGER IPOOL( LPOOL ) 1910 INTEGER NBFIN, SLAVEF 1911 DOUBLE PRECISION OPASSW, OPELIW 1912 INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 1913 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 1914 INTEGER ND( KEEP(28) ) 1915 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 1916 INTEGER FRERE_STEPS(KEEP(28)) 1917 INTEGER INTARR( max(1,KEEP(14)) ) 1918 COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 1919 INTEGER ISTEP_TO_INIV2(KEEP(71)), 1920 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 1921 INTEGER ITYPE2 1922 INTEGER IHDR_REC 1923 PARAMETER (ITYPE2=2) 1924 INTEGER IOLDPS, NROW, LDA 1925 INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, 1926 & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON 1927 INTEGER(8) :: SHIFT_VAL_SON 1928 INTEGER(8) MEM_GAIN 1929 IF (KEEP(50).EQ.0) THEN 1930 IHDR_REC=6 1931 ELSE 1932 IHDR_REC=8 1933 ENDIF 1934 IOLDPS = PTRIST(STEP(INODE)) 1935 IW(IOLDPS+XXS)=S_ALL 1936 IF (KEEP(214).EQ.1) THEN 1937 CALL ZMUMPS_314( N, INODE, 1938 & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, 1939 & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, 1940 & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, 1941 & IFLAG, IERROR, SLAVEF, MYID, COMM, KEEP,KEEP8, ITYPE2 1942 & ) 1943 IOLDPS = PTRIST(STEP(INODE)) 1944 IF (KEEP(38).NE.FPERE) THEN 1945 IW(IOLDPS+XXS)=S_NOLCBNOCONTIG 1946 IF (KEEP(216).NE.3) THEN 1947 MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* 1948 & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) 1949 LRLUS = LRLUS+MEM_GAIN 1950 CALL ZMUMPS_471(.FALSE.,.FALSE., 1951 & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) 1952 ENDIF 1953 ENDIF 1954 IF (KEEP(216).EQ.2) THEN 1955 IF (FPERE.NE.KEEP(38)) THEN 1956 CALL ZMUMPS_627(A,LA,PTRAST(STEP(INODE)), 1957 & IW( IOLDPS + 2 + KEEP(IXSZ) ), 1958 & IW( IOLDPS + KEEP(IXSZ) ), 1959 & IW( IOLDPS + 3 + KEEP(IXSZ) )+ 1960 & IW( IOLDPS + KEEP(IXSZ) ), 0, 1961 & IW( IOLDPS + XXS ), 0_8 ) 1962 IW(IOLDPS+XXS)=S_NOLCBCONTIG 1963 IW(IOLDPS+XXS)=S_NOLCBCONTIG 1964 ENDIF 1965 ENDIF 1966 ENDIF 1967 IF ( KEEP(38).EQ.FPERE) THEN 1968 LCONT = IW(IOLDPS+KEEP(IXSZ)) 1969 NROW = IW(IOLDPS+2+KEEP(IXSZ)) 1970 NPIV = IW(IOLDPS+3+KEEP(IXSZ)) 1971 NASS = IW(IOLDPS+4+KEEP(IXSZ)) 1972 NELIM = NASS-NPIV 1973 NCOL_TO_SEND = LCONT-NELIM 1974 SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) 1975 SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS 1976 SHIFT_VAL_SON = int(NASS,8) 1977 LDA = LCONT + NPIV 1978 IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN 1979 IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC 1980 ELSE 1981 ENDIF 1982 CALL ZMUMPS_80( COMM_LOAD, ASS_IRECV, 1983 & N, INODE, FPERE, 1984 & PTRIST, PTRAST, 1985 & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, 1986 & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, 1987 & ROOT_CONT_STATIC, MYID, COMM, 1988 & 1989 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 1990 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 1991 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, 1992 & PAMASTER, 1993 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 1994 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 1995 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 1996 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, .FALSE., ND, FRERE_STEPS, 1997 & LPTRAR, NELT, FRTPTR, FRTELT, 1998 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 1999 IF ( IFLAG < 0 ) GOTO 600 2000 IF (NELIM.EQ.0) THEN 2001 IF (KEEP(214).EQ.2) THEN 2002 CALL ZMUMPS_314( N, INODE, 2003 & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, 2004 & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, 2005 & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, 2006 & IFLAG, IERROR, SLAVEF, MYID, COMM, KEEP,KEEP8, ITYPE2 2007 & ) 2008 ENDIF 2009 CALL ZMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, 2010 & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, 2011 & MYID, KEEP 2012 & ) 2013 ELSE 2014 IOLDPS = PTRIST(STEP(INODE)) 2015 IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN 2016 CALL ZMUMPS_626( N, INODE, PTRIST, PTRAST, IW, LIW, 2017 & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, 2018 & MYID, KEEP 2019 & ) 2020 ELSE 2021 IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT 2022 IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN 2023 IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 2024 CALL ZMUMPS_628( IW(IOLDPS), 2025 & LIW-IOLDPS+1, 2026 & MEM_GAIN, KEEP(IXSZ) ) 2027 LRLUS = LRLUS + MEM_GAIN 2028 CALL ZMUMPS_471(.FALSE.,.FALSE., 2029 & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLU) 2030 IF (KEEP(216).EQ.2) THEN 2031 CALL ZMUMPS_627(A,LA,PTRAST(STEP(INODE)), 2032 & IW( IOLDPS + 2 + KEEP(IXSZ) ), 2033 & IW( IOLDPS + KEEP(IXSZ) ), 2034 & IW( IOLDPS + 3 + KEEP(IXSZ) )+ 2035 & IW( IOLDPS + KEEP(IXSZ) ), 2036 & IW( IOLDPS + 4 + KEEP(IXSZ) ) - 2037 & IW( IOLDPS + 3 + KEEP(IXSZ) ), 2038 & IW( IOLDPS + XXS ),0_8) 2039 IW(IOLDPS+XXS)=S_NOLCBCONTIG38 2040 ENDIF 2041 ENDIF 2042 ENDIF 2043 ENDIF 2044 ENDIF 2045 600 CONTINUE 2046 RETURN 2047 END SUBROUTINE ZMUMPS_759 2048 SUBROUTINE ZMUMPS_141( COMM_LOAD, ASS_IRECV, 2049 & N, INODE, FPERE, IW, LIW, A, LA, 2050 & UU, NOFFW, 2051 & NPVW, 2052 & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, 2053 & IFLAG, IERROR, IPOOL,LPOOL, 2054 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 2055 & LRLUS, COMP, 2056 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, 2057 & PIMASTER, PAMASTER, 2058 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 2059 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2060 & FILS, PTRARW, PTRAIW, 2061 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 2062 & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, 2063 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, 2064 & DKEEP,PIVNUL_LIST,LPN_LIST ) 2065 USE ZMUMPS_OOC 2066 IMPLICIT NONE 2067 INCLUDE 'zmumps_root.h' 2068 INTEGER COMM_LOAD, ASS_IRECV 2069 INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 2070 INTEGER(8) :: LA 2071 COMPLEX(kind=8) A( LA ) 2072 DOUBLE PRECISION UU, SEUIL 2073 TYPE (ZMUMPS_ROOT_STRUC) :: root 2074 INTEGER COMM, MYID, LBUFR, LBUFR_BYTES 2075 INTEGER LPTRAR, NELT 2076 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS 2077 INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, SLAVEF, 2078 & IWPOS, IWPOSCB, COMP 2079 INTEGER NB_BLOC_FAC 2080 INTEGER ICNTL(40), KEEP(500) 2081 INTEGER(8) KEEP8(150) 2082 INTEGER, TARGET :: IW( LIW ) 2083 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 2084 INTEGER BUFR( LBUFR ), IPOOL(LPOOL), ITLOC(N+KEEP(253)) 2085 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 2086 INTEGER PTRARW(LPTRAR), PTRAIW(LPTRAR), ND( KEEP(28) ) 2087 INTEGER FRERE(KEEP(28)), FILS(N) 2088 INTEGER INTARR(max(1,KEEP(14))) 2089 INTEGER(8) :: PTRAST(KEEP(28)) 2090 INTEGER(8) :: PTRFAC(KEEP(28)) 2091 INTEGER(8) :: PAMASTER(KEEP(28)) 2092 INTEGER PTRIST(KEEP(28)), 2093 & PTLUST_S(KEEP(28)), 2094 & 2095 & PIMASTER(KEEP(28)), 2096 & NSTK_S(KEEP(28)), NBPROCFILS(KEEP(28)), 2097 & PROCNODE_STEPS(KEEP(28)), STEP(N) 2098 INTEGER ISTEP_TO_INIV2(KEEP(71)), 2099 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 2100 DOUBLE PRECISION OPASSW, OPELIW 2101 COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) 2102 LOGICAL AVOID_DELAYED 2103 INTEGER LPN_LIST 2104 INTEGER PIVNUL_LIST(LPN_LIST) 2105 DOUBLE PRECISION DKEEP(30) 2106 INTEGER(8) :: POSELT 2107 INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, NBTLKJ 2108 INTEGER NASS, IEND, IOLDPS, LDAFS,allocok, IBEG_BLOCK 2109 LOGICAL LASTBL 2110 LOGICAL RESET_TO_ONE, TO_UPDATE 2111 INTEGER K109_ON_ENTRY 2112 INTEGER I,J,JJ,K,IDEB 2113 DOUBLE PRECISION UUTEMP 2114 INCLUDE 'mumps_headers.h' 2115 INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV 2116 INTEGER(8) :: LAFAC 2117 INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, 2118 & IDUMMY 2119 TYPE(IO_BLOCK) :: MonBloc 2120 LOGICAL LAST_CALL 2121 INTEGER PP_FIRST2SWAP_L, IFLAG_OOC 2122 INTEGER PP_LastPIVRPTRFilled 2123 EXTERNAL ZMUMPS_223, ZMUMPS_235, 2124 & ZMUMPS_227, ZMUMPS_294, 2125 & ZMUMPS_44 2126 LOGICAL STATICMODE 2127 DOUBLE PRECISION SEUIL_LOC 2128 INTEGER PIVSIZ,IWPOSPIV 2129 COMPLEX(kind=8) ONE 2130 PARAMETER (ONE=(1.0D0,0.0D0)) 2131 INOPV = 0 2132 IF(KEEP(97) .EQ. 0) THEN 2133 STATICMODE = .FALSE. 2134 ELSE 2135 STATICMODE = .TRUE. 2136 ENDIF 2137 IF (AVOID_DELAYED) THEN 2138 STATICMODE = .TRUE. 2139 UUTEMP=UU 2140 SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) 2141 ELSE 2142 SEUIL_LOC=SEUIL 2143 UUTEMP=UU 2144 ENDIF 2145 RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) 2146 IF (RESET_TO_ONE) THEN 2147 K109_ON_ENTRY = KEEP(109) 2148 ENDIF 2149 IBEG_BLOCK=1 2150 NB_BLOC_FAC = 0 2151 IOLDPS = PTLUST_S(STEP( INODE )) 2152 POSELT = PTRAST( STEP( INODE )) 2153 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 2154 NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) 2155 LDAFS = NASS 2156 IF (NASS .GT. KEEP(3)) THEN 2157 NBOLKJ = min( KEEP(6), NASS ) 2158 ELSE 2159 NBOLKJ = min( KEEP(5), NASS ) 2160 ENDIF 2161 NBTLKJ = NBOLKJ 2162 IW(IOLDPS+3+KEEP(IXSZ)) = min0(NASS,NBTLKJ) 2163 IF (KEEP(201).EQ.1) THEN 2164 IDUMMY = -9876 2165 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) 2166 LIWFAC = IW(IOLDPS+XXI) 2167 TYPEFile = TYPEF_L 2168 NextPiv2beWritten = 1 2169 PP_FIRST2SWAP_L = NextPiv2beWritten 2170 MonBloc%LastPanelWritten_L = 0 2171 MonBloc%INODE = INODE 2172 MonBloc%MASTER = .TRUE. 2173 MonBloc%Typenode = 2 2174 MonBloc%NROW = NASS 2175 MonBloc%NCOL = NASS 2176 MonBloc%NFS = NASS 2177 MonBloc%Last = .FALSE. 2178 MonBloc%LastPiv = -66666 2179 MonBloc%INDICES => 2180 & IW(IOLDPS+6+NFRONT+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ)) 2181 & :IOLDPS+5+2*NFRONT+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))) 2182 ENDIF 2183 ALLOCATE( IPIV( NASS ), stat = allocok ) 2184 IF ( allocok .GT. 0 ) THEN 2185 WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, 2186 & ' integers' 2187 IFLAG=-13 2188 IERROR=NASS 2189 GO TO 490 2190 END IF 2191 50 CONTINUE 2192 IBEGKJI = IBEG_BLOCK 2193 CALL ZMUMPS_223( 2194 & NFRONT,NASS,IBEGKJI, NASS, IPIV, 2195 & N,INODE,IW,LIW,A,LA,NOFFW,INOPV, 2196 & IFLAG,IOLDPS,POSELT,UU, SEUIL_LOC, 2197 & KEEP,KEEP8,PIVSIZ, 2198 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, 2199 & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, 2200 & PP_LastPIVRPTRFilled) 2201 IF (IFLAG.LT.0) GOTO 490 2202 IF(KEEP(109).GT. 0) THEN 2203 IF(PIVNUL_LIST(KEEP(109)).EQ.-1) THEN 2204 IWPOSPIV = IOLDPS+IW(IOLDPS+1+KEEP(IXSZ))+6 2205 & +IW(IOLDPS+5+KEEP(IXSZ)) 2206 PIVNUL_LIST(KEEP(109)) = IW(IWPOSPIV+KEEP(IXSZ)) 2207 ENDIF 2208 ENDIF 2209 IF(INOPV.EQ. 1 .AND. STATICMODE) THEN 2210 INOPV = -1 2211 GOTO 50 2212 ENDIF 2213 IF (INOPV.GE.1) THEN 2214 LASTBL = (INOPV.EQ.1) 2215 IEND = IW(IOLDPS+1+KEEP(IXSZ)) 2216 CALL ZMUMPS_294( COMM_LOAD, ASS_IRECV, 2217 & N, INODE, FPERE, IW, LIW, 2218 & IOLDPS, POSELT, A, LA, LDAFS, 2219 & IBEGKJI, IEND, IPIV, NASS,LASTBL, NB_BLOC_FAC, 2220 & 2221 & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, 2222 & IFLAG, IERROR, IPOOL,LPOOL, 2223 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 2224 & LRLUS, COMP, 2225 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, 2226 & PIMASTER, PAMASTER, 2227 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 2228 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2229 & FILS, PTRARW, PTRAIW, 2230 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 2231 & LPTRAR, NELT, FRTPTR, FRTELT, 2232 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 2233 IF ( IFLAG .LT. 0 ) GOTO 500 2234 ENDIF 2235 IF (INOPV.EQ.1) GO TO 500 2236 IF (INOPV.EQ.2) THEN 2237 CALL ZMUMPS_235(IBEG_BLOCK, 2238 & NASS,N,INODE,IW,LIW,A,LA, 2239 & LDAFS, 2240 & IOLDPS,POSELT,NBOLKJ, NBTLKJ,KEEP(4),KEEP,KEEP8) 2241 GOTO 50 2242 ENDIF 2243 NPVW = NPVW + PIVSIZ 2244 IF (NASS.LE.1) THEN 2245 IFINB = -1 2246 IF (NASS == 1) A(POSELT)=ONE/A(POSELT) 2247 ELSE 2248 CALL ZMUMPS_227(IBEG_BLOCK, 2249 & NASS, N,INODE,IW,LIW,A,LA, 2250 & LDAFS, IOLDPS,POSELT,IFINB, 2251 & NBTLKJ,KEEP(4),PIVSIZ,KEEP(IXSZ)) 2252 IF(PIVSIZ .EQ. 2) THEN 2253 IWPOSPIV = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+1+KEEP(IXSZ))+6+ 2254 & IW(IOLDPS+5+KEEP(IXSZ)) 2255 IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) 2256 ENDIF 2257 ENDIF 2258 IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + PIVSIZ 2259 IF (IFINB.EQ.0) GOTO 50 2260 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN 2261 LASTBL = (IFINB.EQ.-1) 2262 IEND = IW(IOLDPS+1+KEEP(IXSZ)) 2263 CALL ZMUMPS_294(COMM_LOAD, ASS_IRECV, 2264 & N, INODE, FPERE, IW, LIW, 2265 & IOLDPS, POSELT, A, LA, LDAFS, 2266 & IBEGKJI, IEND, IPIV, NASS, LASTBL,NB_BLOC_FAC, 2267 & 2268 & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, 2269 & IFLAG, IERROR, IPOOL,LPOOL, 2270 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 2271 & LRLUS, COMP, 2272 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, 2273 & PIMASTER, PAMASTER, 2274 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 2275 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 2276 & FILS, PTRARW, PTRAIW, 2277 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 2278 & LPTRAR, NELT, FRTPTR, FRTELT, 2279 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 2280 IF ( IFLAG .LT. 0 ) GOTO 500 2281 ENDIF 2282 IF (IFINB.EQ.(-1)) GOTO 500 2283 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 2284 IF (KEEP(201).EQ.1) THEN 2285 IF (.NOT.RESET_TO_ONE.OR.K109_ON_ENTRY.EQ.KEEP(109)) THEN 2286 MonBloc%Last = .FALSE. 2287 MonBloc%LastPiv= NPIV 2288 LAST_CALL=.FALSE. 2289 CALL ZMUMPS_688( 2290 & STRAT_TRY_WRITE, 2291 & TYPEFile, A(POSELT), 2292 & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), 2293 & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 2294 IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC 2295 IF (IFLAG .LT. 0 ) RETURN 2296 ENDIF 2297 ENDIF 2298 CALL ZMUMPS_235(IBEG_BLOCK, 2299 & NASS,N,INODE,IW,LIW,A,LA, 2300 & LDAFS, 2301 & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP,KEEP8) 2302 IF (KEEP(201).EQ.1) THEN 2303 IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN 2304 IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 2305 JJ= IDEB 2306 TO_UPDATE=.FALSE. 2307 DO K = K109_ON_ENTRY+1, KEEP(109) 2308 I = PIVNUL_LIST(K) 2309 DO J=JJ,JJ+NASS 2310 IF (IW(J).EQ.I) THEN 2311 TO_UPDATE=.TRUE. 2312 EXIT 2313 ENDIF 2314 ENDDO 2315 IF (TO_UPDATE) THEN 2316 JJ= J 2317 J = J-IDEB+1 2318 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE 2319 TO_UPDATE=.FALSE. 2320 ELSE 2321 IF (ICNTL(1).GT.0) THEN 2322 write(ICNTL(1),*) ' Internal error related ', 2323 & 'to null pivot row detection' 2324 ENDIF 2325 EXIT 2326 ENDIF 2327 ENDDO 2328 ENDIF 2329 K109_ON_ENTRY = KEEP(109) 2330 MonBloc%Last = .FALSE. 2331 MonBloc%LastPiv= NPIV 2332 LAST_CALL=.FALSE. 2333 CALL ZMUMPS_688( 2334 & STRAT_TRY_WRITE, 2335 & TYPEFile, A(POSELT), 2336 & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), 2337 & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 2338 IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC 2339 IF (IFLAG .LT. 0 ) RETURN 2340 ENDIF 2341 GO TO 50 2342 490 CONTINUE 2343 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 2344 500 CONTINUE 2345 IF (RESET_TO_ONE.AND.K109_ON_ENTRY.LT.KEEP(109)) THEN 2346 IDEB = IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6 2347 JJ= IDEB 2348 TO_UPDATE=.FALSE. 2349 DO K = K109_ON_ENTRY+1, KEEP(109) 2350 I = PIVNUL_LIST(K) 2351 DO J=JJ,JJ+NASS 2352 IF (IW(J).EQ.I) THEN 2353 TO_UPDATE=.TRUE. 2354 EXIT 2355 ENDIF 2356 ENDDO 2357 IF (TO_UPDATE) THEN 2358 JJ= J 2359 J = J-IDEB+1 2360 A(POSELT+int(J-1,8)+int(LDAFS,8)*int(J-1,8))= ONE 2361 TO_UPDATE=.FALSE. 2362 ELSE 2363 IF (ICNTL(1).GT.0) THEN 2364 write(ICNTL(1),*) ' Internal error related ', 2365 & 'to null pivot row detection' 2366 ENDIF 2367 EXIT 2368 ENDIF 2369 ENDDO 2370 ENDIF 2371 IF (KEEP(201).EQ.1) THEN 2372 STRAT = STRAT_WRITE_MAX 2373 MonBloc%Last = .TRUE. 2374 MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) 2375 LAST_CALL = .TRUE. 2376 CALL ZMUMPS_688 2377 & ( STRAT, TYPEFile, 2378 & A(POSELT), LAFAC, MonBloc, 2379 & NextPiv2beWritten, IDUMMY, 2380 & IW(IOLDPS), LIWFAC, 2381 & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) 2382 IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC 2383 IF (IFLAG .LT. 0 ) RETURN 2384 CALL ZMUMPS_644 (IWPOS, 2385 & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) 2386 ENDIF 2387 DEALLOCATE( IPIV ) 2388 RETURN 2389 END SUBROUTINE ZMUMPS_141 2390 SUBROUTINE ZMUMPS_223( NFRONT, NASS, 2391 & IBEGKJI, NASS2, TIPIV, 2392 & N, INODE, IW, LIW, 2393 & A, LA, NNEG, 2394 & INOPV, IFLAG, 2395 & IOLDPS, POSELT, UU, 2396 & SEUIL,KEEP,KEEP8,PIVSIZ, 2397 & DKEEP,PIVNUL_LIST,LPN_LIST, 2398 & PP_FIRST2SWAP_L, PP_LastPanelonDisk, 2399 & PP_LastPIVRPTRIndexFilled) 2400 USE MUMPS_OOC_COMMON 2401 IMPLICIT NONE 2402 INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV 2403 INTEGER NASS2, IBEGKJI, NNEG 2404 INTEGER TIPIV( NASS2 ) 2405 INTEGER PIVSIZ,LPIV 2406 INTEGER(8) :: LA 2407 COMPLEX(kind=8) A(LA) 2408 DOUBLE PRECISION UU, UULOC, SEUIL 2409 COMPLEX(kind=8) CSEUIL 2410 INTEGER IW(LIW) 2411 INTEGER IOLDPS 2412 INTEGER(8) :: POSELT 2413 INTEGER KEEP(500) 2414 INTEGER(8) KEEP8(150) 2415 INTEGER LPN_LIST 2416 INTEGER PIVNUL_LIST(LPN_LIST) 2417 DOUBLE PRECISION DKEEP(30) 2418 INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk 2419 INTEGER PP_LastPIVRPTRIndexFilled 2420 include 'mpif.h' 2421 INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ 2422 INTEGER JMAX 2423 DOUBLE PRECISION RMAX,AMAX,TMAX,TOL 2424 DOUBLE PRECISION MAXPIV 2425 COMPLEX(kind=8) PIVOT,DETPIV 2426 PARAMETER(TOL = 1.0D-20) 2427 INCLUDE 'mumps_headers.h' 2428 INTEGER(8) :: APOSMAX 2429 INTEGER(8) :: APOS 2430 INTEGER(8) :: J1, J2, JJ, KK 2431 INTEGER :: LDAFS 2432 INTEGER(8) :: LDAFS8 2433 DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 2434 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 2435 COMPLEX(kind=8) ZERO, ONE 2436 PARAMETER( ZERO = (0.0D0,0.0D0) ) 2437 PARAMETER( ONE = (1.0D0,0.0D0) ) 2438 DOUBLE PRECISION PIVNUL, VALTMP 2439 COMPLEX(kind=8) FIXA 2440 INTEGER NPIV,NASSW,IPIV 2441 INTEGER NPIVP1,ILOC,K,J 2442 INTRINSIC max 2443 INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L 2444 PIVNUL = DKEEP(1) 2445 FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) 2446 CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) 2447 LDAFS = NASS 2448 LDAFS8 = int(LDAFS,8) 2449 IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN 2450 CALL ZMUMPS_667(TYPEF_L, NBPANELS_L, 2451 & I_PIVRPTR, I_PIVR, 2452 & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) 2453 & +KEEP(IXSZ), 2454 & IW, LIW) 2455 ENDIF 2456 UULOC = UU 2457 PIVSIZ = 1 2458 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 2459 NPIVP1 = NPIV + 1 2460 ILOC = NPIVP1 - IBEGKJI + 1 2461 TIPIV( ILOC ) = ILOC 2462 NASSW = iabs(IW(IOLDPS+3+KEEP(IXSZ))) 2463 APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 2464 IF(INOPV .EQ. -1) THEN 2465 APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) 2466 POSPV1 = APOS 2467 IF(abs(A(APOS)).LT.SEUIL) THEN 2468 IF(dble(A(APOS)) .GE. RZERO) THEN 2469 A(APOS) = CSEUIL 2470 ELSE 2471 A(APOS) = -CSEUIL 2472 ENDIF 2473 ELSE IF (KEEP(258) .NE.0 ) THEN 2474 CALL ZMUMPS_762( A(APOS), DKEEP(6), KEEP(259) ) 2475 ENDIF 2476 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 2477 CALL ZMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, 2478 & IW(I_PIVR), NASS, NPIVP1, NPIVP1, 2479 & PP_LastPanelonDisk, 2480 & PP_LastPIVRPTRIndexFilled) 2481 ENDIF 2482 GO TO 420 2483 ENDIF 2484 INOPV = 0 2485 DO 460 IPIV=NPIVP1,NASSW 2486 APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) 2487 POSPV1 = APOS + int(IPIV - NPIVP1,8) 2488 PIVOT = A(POSPV1) 2489 IF (UULOC.EQ.RZERO) THEN 2490 IF (abs(A(APOS)).EQ.RZERO) GO TO 630 2491 IF (KEEP(258) .NE. 0) THEN 2492 CALL ZMUMPS_762(A(APOS), DKEEP(6), KEEP(259)) 2493 ENDIF 2494 GO TO 420 2495 ENDIF 2496 AMAX = RZERO 2497 JMAX = 0 2498 J1 = APOS 2499 J2 = POSPV1 - 1_8 2500 DO JJ=J1,J2 2501 IF(abs(A(JJ)) .GT. AMAX) THEN 2502 AMAX = abs(A(JJ)) 2503 JMAX = IPIV - int(POSPV1-JJ) 2504 ENDIF 2505 ENDDO 2506 J1 = POSPV1 + LDAFS8 2507 DO J=1, NASSW - IPIV 2508 IF(abs(A(J1)) .GT. AMAX) THEN 2509 AMAX = max(abs(A(J1)),AMAX) 2510 JMAX = IPIV + J 2511 ENDIF 2512 J1 = J1 + LDAFS8 2513 ENDDO 2514 IF (KEEP(219).NE.0) THEN 2515 RMAX = dble(A(APOSMAX+int(IPIV,8))) 2516 ELSE 2517 RMAX = RZERO 2518 ENDIF 2519 DO J=1,NASS - NASSW 2520 RMAX = max(abs(A(J1)),RMAX) 2521 J1 = J1 + LDAFS8 2522 ENDDO 2523 IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN 2524 KEEP(109) = KEEP(109)+1 2525 PIVNUL_LIST(KEEP(109)) = -1 2526 IF (dble(FIXA).GT.RZERO) THEN 2527 IF(dble(PIVOT) .GE. RZERO) THEN 2528 A(POSPV1) = FIXA 2529 ELSE 2530 A(POSPV1) = -FIXA 2531 ENDIF 2532 ELSE 2533 J1 = APOS 2534 J2 = POSPV1 - 1_8 2535 DO JJ=J1,J2 2536 A(JJ) = ZERO 2537 ENDDO 2538 J1 = POSPV1 + LDAFS8 2539 DO J=1, NASSW - IPIV 2540 A(J1) = ZERO 2541 J1 = J1 + LDAFS8 2542 ENDDO 2543 DO J=1,NASS - NASSW 2544 A(J1) = ZERO 2545 J1 = J1 + LDAFS8 2546 ENDDO 2547 VALTMP = max(1.0D10*RMAX, sqrt(huge(RMAX))/1.0D8) 2548 A(POSPV1) = cmplx(VALTMP,kind=kind(A)) 2549 ENDIF 2550 PIVOT = A(POSPV1) 2551 GO TO 415 2552 ENDIF 2553 IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN 2554 IF (max(AMAX,RMAX,abs(PIVOT)).LE.TOL) THEN 2555 IF(SEUIL .GT. epsilon(SEUIL)) THEN 2556 IF(dble(PIVOT) .GE. RZERO) THEN 2557 A(POSPV1) = CSEUIL 2558 ELSE 2559 A(POSPV1) = -CSEUIL 2560 ENDIF 2561 PIVOT = A(POSPV1) 2562 WRITE(*,*) 'WARNING matrix may be singular' 2563 KEEP(98) = KEEP(98)+1 2564 GO TO 415 2565 ENDIF 2566 ENDIF 2567 ENDIF 2568 IF (max(AMAX,abs(PIVOT)) .LE. TOL) GOTO 460 2569 IF (abs(PIVOT).GT.max(UULOC*max(RMAX,AMAX),SEUIL)) THEN 2570 IF (KEEP(258) .NE.0 ) THEN 2571 CALL ZMUMPS_762(PIVOT, DKEEP(6), KEEP(259)) 2572 ENDIF 2573 GO TO 415 2574 END IF 2575 IF (AMAX.LE.TOL) GO TO 460 2576 IF (RMAX.LT.AMAX) THEN 2577 J1 = APOS 2578 J2 = POSPV1 - 1_8 2579 DO JJ=J1,J2 2580 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN 2581 RMAX = max(RMAX,abs(A(JJ))) 2582 ENDIF 2583 ENDDO 2584 J1 = POSPV1 + LDAFS8 2585 DO J=1,NASS-IPIV 2586 IF(IPIV+J .NE. JMAX) THEN 2587 RMAX = max(abs(A(J1)),RMAX) 2588 ENDIF 2589 J1 = J1 + LDAFS8 2590 ENDDO 2591 ENDIF 2592 APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) 2593 POSPV2 = APOSJ + int(JMAX - NPIVP1,8) 2594 IF (IPIV.LT.JMAX) THEN 2595 OFFDAG = APOSJ + int(IPIV - NPIVP1,8) 2596 ELSE 2597 OFFDAG = APOS + int(JMAX - NPIVP1,8) 2598 END IF 2599 IF (KEEP(219).NE.0) THEN 2600 TMAX = max(SEUIL/UULOC,dble(A(APOSMAX+int(JMAX,8)))) 2601 ELSE 2602 TMAX = SEUIL/UULOC 2603 ENDIF 2604 IF(JMAX .LT. IPIV) THEN 2605 JJ = POSPV2 2606 DO K = 1, NASS-JMAX 2607 JJ = JJ+int(NASS,8) 2608 IF (JMAX+K.NE.IPIV) THEN 2609 TMAX=max(TMAX,abs(A(JJ))) 2610 ENDIF 2611 ENDDO 2612 DO KK = APOSJ, POSPV2-1_8 2613 TMAX = max(TMAX,abs(A(KK))) 2614 ENDDO 2615 ELSE 2616 JJ = POSPV2 2617 DO K = 1, NASS-JMAX 2618 JJ = JJ+int(NASS,8) 2619 TMAX=max(TMAX,abs(A(JJ))) 2620 ENDDO 2621 DO KK = APOSJ, POSPV2 - 1_8 2622 IF (KK.NE.OFFDAG) THEN 2623 TMAX = max(TMAX,abs(A(KK))) 2624 ENDIF 2625 ENDDO 2626 ENDIF 2627 DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 2628 IF (SEUIL.GT.RZERO) THEN 2629 IF (sqrt(abs(DETPIV)) .LE. SEUIL ) GOTO 460 2630 ENDIF 2631 MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) 2632 IF (MAXPIV.EQ.RZERO) MAXPIV = RONE 2633 IF (abs(DETPIV)/MAXPIV.LE.TOL) GO TO 460 2634 IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. 2635 & abs(DETPIV)) GO TO 460 2636 IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. 2637 & abs(DETPIV)) GO TO 460 2638 IF (KEEP(258).NE.0) THEN 2639 CALL ZMUMPS_762(DETPIV, DKEEP(6), KEEP(259)) 2640 ENDIF 2641 PIVSIZ = 2 2642 KEEP(105) = KEEP(105)+1 2643 415 CONTINUE 2644 DO K=1,PIVSIZ 2645 IF (PIVSIZ .EQ. 2 ) THEN 2646 IF (K==1) THEN 2647 LPIV = min(IPIV, JMAX) 2648 TIPIV(ILOC) = -(LPIV - IBEGKJI + 1) 2649 ELSE 2650 LPIV = max(IPIV, JMAX) 2651 TIPIV(ILOC+1) = -(LPIV - IBEGKJI + 1) 2652 ENDIF 2653 ELSE 2654 LPIV = IPIV 2655 TIPIV(ILOC) = IPIV - IBEGKJI + 1 2656 ENDIF 2657 IF (LPIV.EQ.NPIVP1) THEN 2658 GOTO 416 2659 ENDIF 2660 CALL ZMUMPS_319( A, LA, IW, LIW, 2661 & IOLDPS, NPIVP1, LPIV, POSELT, NASS, 2662 & LDAFS, NFRONT, 2, KEEP(219), KEEP(50), 2663 & KEEP(IXSZ)) 2664 416 CONTINUE 2665 IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1) THEN 2666 CALL ZMUMPS_680( IW(I_PIVRPTR), NBPANELS_L, 2667 & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, 2668 & PP_LastPIVRPTRIndexFilled) 2669 ENDIF 2670 NPIVP1 = NPIVP1+1 2671 ENDDO 2672 IF(PIVSIZ .EQ. 2) THEN 2673 A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV 2674 ENDIF 2675 GOTO 420 2676 460 CONTINUE 2677 IF (NASSW.EQ.NASS) THEN 2678 INOPV = 1 2679 ELSE 2680 INOPV = 2 2681 ENDIF 2682 GO TO 420 2683 630 CONTINUE 2684 IFLAG = -10 2685 420 CONTINUE 2686 RETURN 2687 END SUBROUTINE ZMUMPS_223 2688 SUBROUTINE ZMUMPS_235( 2689 & IBEG_BLOCK, 2690 & NASS, N, INODE, 2691 & IW, LIW, A, LA, 2692 & LDAFS, 2693 & IOLDPS, POSELT, 2694 & LKJIB_ORIG, LKJIB, LKJIT, KEEP,KEEP8 ) 2695 IMPLICIT NONE 2696 INTEGER NASS,N,LIW 2697 INTEGER(8) :: LA 2698 COMPLEX(kind=8) A(LA) 2699 INTEGER IW(LIW) 2700 INTEGER LKJIB_ORIG, LKJIB, INODE, KEEP(500) 2701 INTEGER(8) KEEP8(150) 2702 INTEGER (8) :: POSELT 2703 INTEGER (8) :: LDAFS8 2704 INTEGER LDAFS, IBEG_BLOCK 2705 INTEGER IOLDPS, NPIV, JROW2, NPBEG 2706 INTEGER NONEL, LKJIW, NEL1 2707 INTEGER HF 2708 INTEGER(8) :: LPOS,UPOS,APOS 2709 INTEGER LKJIT 2710 INTEGER LKJIBOLD, IROW 2711 INTEGER J, Block 2712 INTEGER BLSIZE 2713 COMPLEX(kind=8) ONE, ALPHA 2714 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 2715 INCLUDE 'mumps_headers.h' 2716 LDAFS8 = int(LDAFS,8) 2717 LKJIBOLD = LKJIB 2718 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 2719 JROW2 = iabs(IW(IOLDPS+3+KEEP(IXSZ))) 2720 NPBEG = IBEG_BLOCK 2721 HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) 2722 NEL1 = NASS - JROW2 2723 LKJIW = NPIV - NPBEG + 1 2724 IF ( LKJIW .NE. LKJIB ) THEN 2725 NONEL = JROW2 - NPIV + 1 2726 IF ((NASS-NPIV).GE.LKJIT) THEN 2727 LKJIB = LKJIB_ORIG + NONEL 2728 IW(IOLDPS+3+KEEP(IXSZ))= min0(NPIV+LKJIB,NASS) 2729 LKJIB = min0(LKJIB, NASS - NPIV) 2730 ELSE 2731 LKJIB = NASS - NPIV 2732 IW(IOLDPS+3+KEEP(IXSZ)) = NASS 2733 ENDIF 2734 ELSEIF (JROW2.LT.NASS) THEN 2735 IW(IOLDPS+3+KEEP(IXSZ)) = min0(JROW2+LKJIB,NASS) 2736 ENDIF 2737 IBEG_BLOCK = NPIV + 1 2738 IF (LKJIW.EQ.0) GO TO 500 2739 IF (NEL1.NE.0) THEN 2740 IF ( NASS - JROW2 > KEEP(7) ) THEN 2741 BLSIZE = KEEP(8) 2742 ELSE 2743 BLSIZE = NASS - JROW2 2744 END IF 2745 IF ( NASS - JROW2 .GT. 0 ) THEN 2746 DO IROW = JROW2+1, NASS, BLSIZE 2747 Block = min( BLSIZE, NASS - IROW + 1 ) 2748 LPOS = POSELT + int(IROW - 1,8) * LDAFS8 + int(NPBEG - 1,8) 2749 UPOS = POSELT + int(NPBEG - 1,8) * LDAFS8 + int(IROW - 1,8) 2750 APOS = POSELT + int(IROW-1,8) * LDAFS8 + int(IROW - 1,8) 2751 DO J=1, Block 2752 CALL zgemv( 'T', LKJIW, Block - J + 1, ALPHA, 2753 & A( LPOS ), LDAFS, A( UPOS ), LDAFS, 2754 & ONE, A( APOS ), LDAFS ) 2755 LPOS = LPOS + LDAFS8 2756 APOS = APOS + LDAFS8 + 1_8 2757 UPOS = UPOS + 1_8 2758 END DO 2759 LPOS = POSELT + int(IROW-1+Block,8) * LDAFS8 2760 & + int(NPBEG-1,8) 2761 UPOS = POSELT + int(NPBEG-1,8) * LDAFS8 + int(IROW-1,8) 2762 APOS = POSELT + int( IROW - 1 + Block,8 ) * LDAFS8 2763 & + int(IROW - 1,8) 2764 CALL zgemm( 'N','N', Block, NASS - IROW + 1 - Block, LKJIW, 2765 & ALPHA, A( UPOS ), LDAFS, 2766 & A( LPOS ), LDAFS, ONE, A( APOS ), LDAFS ) 2767 END DO 2768 END IF 2769 END IF 2770 500 CONTINUE 2771 RETURN 2772 END SUBROUTINE ZMUMPS_235 2773 SUBROUTINE ZMUMPS_227 2774 & ( IBEG_BLOCK, NASS, N, INODE, IW, LIW, 2775 & A, LA, LDAFS, 2776 & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,PIVSIZ, 2777 & XSIZE) 2778 IMPLICIT NONE 2779 INTEGER(8) :: LA, POSELT 2780 INTEGER :: LIW 2781 COMPLEX(kind=8) A(LA) 2782 INTEGER IW(LIW) 2783 COMPLEX(kind=8) VALPIV 2784 INTEGER IOLDPS, NCB1 2785 INTEGER LKJIT, IBEG_BLOCK 2786 INTEGER NPIV,JROW2 2787 INTEGER(8) :: APOS 2788 INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS 2789 INTEGER(8) :: JJ, K1, K2 2790 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD 2791 INTEGER(8) :: LDAFS8 2792 INTEGER NASS,N,INODE,IFINB,LKJIB,LDAFS, 2793 & NPBEG 2794 INTEGER NEL2 2795 INTEGER XSIZE 2796 COMPLEX(kind=8) ONE, ALPHA 2797 COMPLEX(kind=8) ZERO 2798 INTEGER PIVSIZ,NPIV_NEW 2799 INTEGER(8) :: IBEG, IEND, IROW 2800 INTEGER :: J2 2801 COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2 2802 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 2803 PARAMETER (ZERO=(0.0D0,0.0D0)) 2804 INCLUDE 'mumps_headers.h' 2805 LDAFS8 = int(LDAFS,8) 2806 NPIV = IW(IOLDPS+1+XSIZE) 2807 NPIV_NEW = NPIV + PIVSIZ 2808 IFINB = 0 2809 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN 2810 IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) 2811 ENDIF 2812 JROW2 = IW(IOLDPS+3+XSIZE) 2813 NPBEG = IBEG_BLOCK 2814 NEL2 = JROW2 - NPIV_NEW 2815 IF (NEL2.EQ.0) THEN 2816 IF (JROW2.EQ.NASS) THEN 2817 IFINB = -1 2818 ELSE 2819 IFINB = 1 2820 ENDIF 2821 ENDIF 2822 IF(PIVSIZ .EQ. 1) THEN 2823 APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) 2824 VALPIV = ONE/A(APOS) 2825 A(APOS) = VALPIV 2826 LPOS = APOS + LDAFS8 2827 CALL zcopy(NASS-NPIV_NEW, A(LPOS), LDAFS, A(APOS+1_8), 1) 2828 CALL ZMUMPS_XSYR('U', NEL2, -VALPIV, A(LPOS), LDAFS, 2829 & A(LPOS+1_8), LDAFS) 2830 CALL zscal(NASS-NPIV_NEW, VALPIV, A(LPOS), LDAFS) 2831 IF (NEL2.GT.0) THEN 2832 K1POS = LPOS + int(NEL2,8)*LDAFS8 2833 NCB1 = NASS - JROW2 2834 CALL zgeru(NEL2, NCB1 , ALPHA, A(APOS+1_8), 1, 2835 & A(K1POS), LDAFS, A(K1POS+1_8), LDAFS) 2836 ENDIF 2837 ELSE 2838 POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) 2839 POSPV2 = POSPV1+LDAFS8+1_8 2840 OFFDAG_OLD = POSPV2 - 1_8 2841 OFFDAG = POSPV1+1_8 2842 SWOP = A(POSPV2) 2843 DETPIV = A(OFFDAG) 2844 A(POSPV2) = A(POSPV1)/DETPIV 2845 A(POSPV1) = SWOP/DETPIV 2846 A(OFFDAG) = -A(OFFDAG_OLD)/DETPIV 2847 A(OFFDAG_OLD) = ZERO 2848 LPOS1 = POSPV2 + LDAFS8 - 1_8 2849 LPOS2 = LPOS1 + 1_8 2850 CALL zcopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) 2851 CALL zcopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) 2852 JJ = POSPV2 + int(NASS-1,8) 2853 IBEG = JJ + 2_8 2854 IEND = IBEG 2855 DO J2 = 1,NEL2 2856 K1 = JJ 2857 K2 = JJ+1_8 2858 MULT1 = - (A(POSPV1)*A(K1)+A(OFFDAG)*A(K2)) 2859 MULT2 = - (A(OFFDAG)*A(K1)+A(POSPV2)*A(K2)) 2860 K1 = POSPV1+2_8 2861 K2 = POSPV2+1_8 2862 DO IROW = IBEG,IEND 2863 A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) 2864 K1 = K1 + 1_8 2865 K2 = K2 + 1_8 2866 ENDDO 2867 A(JJ) = -MULT1 2868 A(JJ+1_8) = -MULT2 2869 IBEG = IBEG + int(NASS,8) 2870 IEND = IEND + int(NASS + 1,8) 2871 JJ = JJ+int(NASS,8) 2872 ENDDO 2873 IEND = IEND-1_8 2874 DO J2 = JROW2+1,NASS 2875 K1 = JJ 2876 K2 = JJ+1_8 2877 MULT1 = - (A(POSPV1)*A(K1)+A(POSPV1+1_8)*A(K2)) 2878 MULT2 = - (A(POSPV1+1_8)*A(K1)+A(POSPV2)*A(K2)) 2879 K1 = POSPV1+2_8 2880 K2 = POSPV2+1_8 2881 DO IROW = IBEG,IEND 2882 A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) 2883 K1 = K1 + 1_8 2884 K2 = K2 + 1_8 2885 ENDDO 2886 A(JJ) = -MULT1 2887 A(JJ+1_8) = -MULT2 2888 IBEG = IBEG + int(NASS,8) 2889 IEND = IEND + int(NASS,8) 2890 JJ = JJ+int(NASS,8) 2891 ENDDO 2892 ENDIF 2893 RETURN 2894 END SUBROUTINE ZMUMPS_227 2895 RECURSIVE SUBROUTINE ZMUMPS_263( 2896 & COMM_LOAD, ASS_IRECV, 2897 & BUFR, LBUFR, 2898 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, 2899 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, 2900 & A, LA, PTRIST, PTRAST, NSTK_S, NBPROCFILS, 2901 & COMP, STEP, PIMASTER, PAMASTER, POSFAC, 2902 & MYID, COMM, IFLAG, IERROR, NBFIN, 2903 & 2904 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, 2905 & ITLOC, RHS_MUMPS, FILS, 2906 & PTRARW, PTRAIW, INTARR, DBLARR, 2907 & ICNTL, KEEP,KEEP8, IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, 2908 & LPTRAR, NELT, FRTPTR, FRTELT, 2909 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 2910 & ) 2911 USE ZMUMPS_COMM_BUFFER 2912 USE ZMUMPS_LOAD 2913 IMPLICIT NONE 2914 INCLUDE 'zmumps_root.h' 2915 TYPE (ZMUMPS_ROOT_STRUC) :: root 2916 INTEGER ICNTL( 40 ), KEEP( 500 ) 2917 INTEGER(8) KEEP8(150) 2918 INTEGER LBUFR, LBUFR_BYTES 2919 INTEGER COMM_LOAD, ASS_IRECV 2920 INTEGER BUFR( LBUFR ) 2921 INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW 2922 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA 2923 INTEGER(8) :: PTRAST(KEEP(28)) 2924 INTEGER(8) :: PAMASTER(KEEP(28)) 2925 INTEGER(8) :: PTRFAC(KEEP(28)) 2926 INTEGER COMP 2927 INTEGER IFLAG, IERROR, NBFIN, MSGSOU 2928 INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), 2929 & NSTK_S(KEEP(28)) 2930 INTEGER NBPROCFILS(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) 2931 INTEGER IW( LIW ) 2932 COMPLEX(kind=8) A( LA ) 2933 INTEGER NELT, LPTRAR 2934 INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) 2935 INTEGER PTRAIW( LPTRAR ), PTRARW( LPTRAR ) 2936 INTEGER ISTEP_TO_INIV2(KEEP(71)), 2937 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 2938 INTEGER COMM, MYID 2939 INTEGER PTLUST_S(KEEP(28)) 2940 INTEGER ITLOC( N + KEEP(253)), FILS( N ) 2941 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 2942 INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) 2943 INTEGER INTARR( max(1,KEEP(14)) ) 2944 DOUBLE PRECISION OPASSW, OPELIW 2945 DOUBLE PRECISION FLOP1 2946 COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 2947 INTEGER LEAF, LPOOL 2948 INTEGER IPOOL( LPOOL ) 2949 INCLUDE 'mumps_headers.h' 2950 INCLUDE 'mpif.h' 2951 INCLUDE 'mumps_tags.h' 2952 INTEGER STATUS( MPI_STATUS_SIZE ) 2953 INTEGER MUMPS_275 2954 EXTERNAL MUMPS_275 2955 INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR 2956 INTEGER(8) POSELT, POSBLOCFACTO 2957 INTEGER(8) LAELL 2958 INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 2959 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW 2960 INTEGER FPERE 2961 INTEGER(8) CPOS, LPOS 2962 LOGICAL DYNAMIC 2963 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED 2964 INTEGER allocok 2965 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: UDYNAMIC 2966 COMPLEX(kind=8) ONE,ALPHA 2967 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) 2968 DYNAMIC = .FALSE. 2969 POSITION = 0 2970 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, 2971 & MPI_INTEGER, COMM, IERR ) 2972 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPOSK, 1, 2973 & MPI_INTEGER, COMM, IERR ) 2974 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JPOSK, 1, 2975 & MPI_INTEGER, COMM, IERR ) 2976 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, 2977 & MPI_INTEGER, COMM, IERR ) 2978 IF ( NPIV .LE. 0 ) THEN 2979 NPIV = - NPIV 2980 WRITE(*,*) MYID,':error, received negative NPIV in BLFAC' 2981 CALL MUMPS_ABORT() 2982 END IF 2983 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, 2984 & MPI_INTEGER, COMM, IERR ) 2985 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOLU, 1, 2986 & MPI_INTEGER, COMM, IERR ) 2987 LAELL = int(NPIV,8) * int(NCOLU,8) 2988 IF ( LRLU .LT. LAELL ) THEN 2989 IF ( LRLUS .LT. LAELL ) THEN 2990 IFLAG = -9 2991 CALL MUMPS_731(LAELL - LRLUS, IERROR) 2992 GOTO 700 2993 END IF 2994 CALL ZMUMPS_94(N, KEEP(28), IW, LIW, A, LA, 2995 & LRLU, IPTRLU, 2996 & IWPOS, IWPOSCB, PTRIST, PTRAST, 2997 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 2998 & KEEP(IXSZ)) 2999 COMP = COMP+1 3000 IF ( LRLU .NE. LRLUS ) THEN 3001 WRITE(*,*) 'PB compress ass..blocfacto: LRLU,LRLUS=' 3002 & ,LRLU,LRLUS 3003 IFLAG = -9 3004 CALL MUMPS_731(LAELL - LRLU, IERROR) 3005 GOTO 700 3006 END IF 3007 END IF 3008 LRLU = LRLU - LAELL 3009 LRLUS = LRLUS - LAELL 3010 KEEP8(67) = min(LRLUS, KEEP8(67)) 3011 POSBLOCFACTO = POSFAC 3012 POSFAC = POSFAC + LAELL 3013 CALL ZMUMPS_471(.FALSE.,.FALSE., 3014 & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLU) 3015 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 3016 & A(POSBLOCFACTO), NPIV*NCOLU, 3017 & MPI_DOUBLE_COMPLEX, 3018 & COMM, IERR ) 3019 IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC = .TRUE. 3020 IF ( (PTRIST(STEP( INODE )).NE.0) .AND. 3021 & (IPOSK + NPIV -1 .GT. 3022 & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN 3023 DYNAMIC = .TRUE. 3024 ENDIF 3025 IF (DYNAMIC) THEN 3026 ALLOCATE(UDYNAMIC(LAELL), stat=allocok) 3027 if (allocok .GT. 0) THEN 3028 write(*,*) MYID, ' : PB allocation U in blfac_slave ' 3029 & , LAELL 3030 IFLAG = -13 3031 CALL MUMPS_731(LAELL,IERROR) 3032 GOTO 700 3033 endif 3034 UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) 3035 LRLU = LRLU + LAELL 3036 LRLUS = LRLUS + LAELL 3037 POSFAC = POSFAC - LAELL 3038 CALL ZMUMPS_471(.FALSE.,.FALSE., 3039 & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 3040 ENDIF 3041 DO WHILE ( PTRIST(STEP(INODE)) .EQ. 0 ) 3042 MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), 3043 & SLAVEF ) 3044 SET_IRECV = .FALSE. 3045 BLOCKING = .TRUE. 3046 MESSAGE_RECEIVED = .FALSE. 3047 CALL ZMUMPS_329( COMM_LOAD, 3048 & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3049 & MSGSOU, MAITRE_DESC_BANDE, 3050 & STATUS, 3051 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3052 & IWPOS, IWPOSCB, IPTRLU, 3053 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 3054 & PTLUST_S, PTRFAC, 3055 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 3056 & IFLAG, IERROR, COMM, 3057 & NBPROCFILS, 3058 & IPOOL, LPOOL, LEAF, 3059 & NBFIN, MYID, SLAVEF, 3060 & 3061 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3062 & FILS, PTRARW, PTRAIW, 3063 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 3064 & LPTRAR, NELT, FRTPTR, FRTELT, 3065 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3066 IF ( IFLAG .LT. 0 ) GOTO 600 3067 ENDDO 3068 DO WHILE ( IPOSK + NPIV -1 .GT. 3069 & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) 3070 MSGSOU = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 3071 SET_IRECV = .FALSE. 3072 BLOCKING = .TRUE. 3073 MESSAGE_RECEIVED = .FALSE. 3074 CALL ZMUMPS_329( COMM_LOAD, 3075 & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3076 & MSGSOU, BLOC_FACTO_SYM, 3077 & STATUS, 3078 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3079 & IWPOS, IWPOSCB, IPTRLU, 3080 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 3081 & PTLUST_S, PTRFAC, 3082 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 3083 & IFLAG, IERROR, COMM, 3084 & NBPROCFILS, 3085 & IPOOL, LPOOL, LEAF, 3086 & NBFIN, MYID, SLAVEF, 3087 & 3088 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3089 & FILS, PTRARW, PTRAIW, 3090 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 3091 & LPTRAR, NELT, FRTPTR, FRTELT, 3092 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3093 IF ( IFLAG .LT. 0 ) GOTO 600 3094 END DO 3095 SET_IRECV = .TRUE. 3096 BLOCKING = .FALSE. 3097 MESSAGE_RECEIVED = .TRUE. 3098 CALL ZMUMPS_329( COMM_LOAD, 3099 & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3100 & MPI_ANY_SOURCE, MPI_ANY_TAG, 3101 & STATUS, 3102 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3103 & IWPOS, IWPOSCB, IPTRLU, 3104 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 3105 & PTLUST_S, PTRFAC, 3106 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 3107 & IFLAG, IERROR, COMM, 3108 & NBPROCFILS, 3109 & IPOOL, LPOOL, LEAF, 3110 & NBFIN, MYID, SLAVEF, 3111 & 3112 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3113 & FILS, PTRARW, PTRAIW, 3114 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 3115 & LPTRAR, NELT, FRTPTR, FRTELT, 3116 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3117 IOLDPS = PTRIST(STEP( INODE )) 3118 POSELT = PTRAST(STEP( INODE )) 3119 LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) 3120 NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) 3121 NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) 3122 NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) 3123 HS = 6 + NSLAVES_TOT + KEEP(IXSZ) 3124 NCOL1 = LCONT1 + NPIV1 3125 CPOS = POSELT + int(JPOSK - 1,8) 3126 LPOS = POSELT + int(IPOSK - 1,8) 3127 IF ( NPIV .GT. 0 ) THEN 3128 IF (DYNAMIC) THEN 3129 CALL zgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, 3130 & UDYNAMIC(1), NPIV, 3131 & A( LPOS ), NCOL1, ONE, 3132 & A( CPOS ), NCOL1 ) 3133 ELSE 3134 CALL zgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, 3135 & A( POSBLOCFACTO ), NPIV, 3136 & A( LPOS ), NCOL1, ONE, 3137 & A( CPOS ), NCOL1 ) 3138 ENDIF 3139 FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) 3140 FLOP1 = -FLOP1 3141 CALL ZMUMPS_190(1, .FALSE., FLOP1, KEEP,KEEP8 ) 3142 ENDIF 3143 IW( IOLDPS + 6 + KEEP(IXSZ) ) = IW( IOLDPS + 6+ KEEP(IXSZ) ) + 1 3144 IF (DYNAMIC) THEN 3145 DEALLOCATE(UDYNAMIC) 3146 ELSE 3147 LRLU = LRLU + LAELL 3148 LRLUS = LRLUS + LAELL 3149 POSFAC = POSFAC - LAELL 3150 CALL ZMUMPS_471(.FALSE.,.FALSE., 3151 & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLU) 3152 ENDIF 3153 NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM 3154 IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. 3155 & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) 3156 & THEN 3157 DEST = MUMPS_275( PROCNODE_STEPS(STEP(INODE)), SLAVEF ) 3158 CALL ZMUMPS_62( INODE, DEST, END_NIV2_LDLT, 3159 & COMM, IERR ) 3160 IF ( IERR .LT. 0 ) THEN 3161 write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' 3162 IFLAG = -99 3163 GOTO 700 3164 END IF 3165 END IF 3166 IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN 3167 CALL ZMUMPS_759( COMM_LOAD, ASS_IRECV, 3168 & N, INODE, FPERE, 3169 & root, 3170 & MYID, COMM, 3171 & 3172 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3173 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 3174 & PTRIST, PTLUST_S, PTRFAC, 3175 & PTRAST, STEP, PIMASTER, PAMASTER, 3176 & NSTK_S, COMP, IFLAG, IERROR, NBPROCFILS, 3177 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 3178 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, PTRARW, PTRAIW, 3179 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE_STEPS, 3180 & LPTRAR, NELT, FRTPTR, FRTELT, 3181 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 3182 ENDIF 3183 600 CONTINUE 3184 RETURN 3185 700 CONTINUE 3186 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 3187 RETURN 3188 END SUBROUTINE ZMUMPS_263 3189 SUBROUTINE ZMUMPS_38( NROW_SON, NCOL_SON, INDROW_SON, 3190 & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, 3191 & LOCAL_M, LOCAL_N, 3192 & RHS_ROOT, NLOC_ROOT, CBP ) 3193 IMPLICIT NONE 3194 INTEGER NCOL_SON, NROW_SON, NSUPCOL 3195 INTEGER, intent(in) :: CBP 3196 INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) 3197 INTEGER LOCAL_M, LOCAL_N 3198 COMPLEX(kind=8) VAL_SON( NCOL_SON, NROW_SON ) 3199 COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N ) 3200 INTEGER NLOC_ROOT 3201 COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC_ROOT ) 3202 INTEGER I, J 3203 IF (CBP .EQ. 0) THEN 3204 DO I = 1, NROW_SON 3205 DO J = 1, NCOL_SON-NSUPCOL 3206 VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) = 3207 & VAL_ROOT( INDROW_SON( I ), INDCOL_SON( J ) ) + VAL_SON(J,I) 3208 END DO 3209 DO J = NCOL_SON-NSUPCOL+1, NCOL_SON 3210 RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = 3211 & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) 3212 ENDDO 3213 END DO 3214 ELSE 3215 DO I=1, NROW_SON 3216 DO J = 1, NCOL_SON 3217 RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = 3218 & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) 3219 ENDDO 3220 ENDDO 3221 ENDIF 3222 RETURN 3223 END SUBROUTINE ZMUMPS_38 3224 RECURSIVE SUBROUTINE ZMUMPS_80 3225 & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, 3226 & PTRI, PTRR, 3227 & root, 3228 & NBROW, NBCOL, SHIFT_LIST_ROW_SON, 3229 & SHIFT_LIST_COL_SON, 3230 & SHIFT_VAL_SON, LDA, TAG, 3231 & MYID, COMM, 3232 & 3233 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 3234 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, 3235 & PTRIST, PTLUST_S, PTRFAC, 3236 & PTRAST, STEP, PIMASTER, PAMASTER, 3237 & NSTK, COMP, IFLAG, IERROR, NBPROCFILS, 3238 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, 3239 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 3240 & FILS, PTRARW, PTRAIW, 3241 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, INVERT, ND, FRERE, 3242 & LPTRAR, NELT, FRTPTR, FRTELT, 3243 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 3244 USE ZMUMPS_OOC 3245 USE ZMUMPS_COMM_BUFFER 3246 USE ZMUMPS_LOAD 3247 IMPLICIT NONE 3248 INCLUDE 'zmumps_root.h' 3249 INTEGER KEEP(500), ICNTL(40) 3250 INTEGER(8) KEEP8(150) 3251 TYPE (ZMUMPS_ROOT_STRUC) :: root 3252 INTEGER COMM_LOAD, ASS_IRECV 3253 INTEGER N, ISON, IROOT, TAG 3254 INTEGER PTRI( KEEP(28) ) 3255 INTEGER(8) :: PTRR( KEEP(28) ) 3256 INTEGER NBROW, NBCOL, LDA 3257 INTEGER(8) :: SHIFT_VAL_SON 3258 INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON 3259 INTEGER MYID, COMM 3260 LOGICAL INVERT 3261 INCLUDE 'mpif.h' 3262 INTEGER LBUFR, LBUFR_BYTES 3263 INTEGER BUFR( LBUFR ) 3264 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA 3265 INTEGER IWPOS, IWPOSCB 3266 INTEGER LIW 3267 INTEGER IW( LIW ) 3268 COMPLEX(kind=8) A( LA ) 3269 INTEGER LPTRAR, NELT 3270 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 3271 INTEGER(8) :: PTRAST(KEEP(28)) 3272 INTEGER(8) :: PTRFAC(KEEP(28)) 3273 INTEGER(8) :: PAMASTER(KEEP(28)) 3274 INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) 3275 INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) 3276 INTEGER COMP, IFLAG, IERROR 3277 INTEGER NBPROCFILS( KEEP(28) ) 3278 INTEGER LPOOL, LEAF 3279 INTEGER IPOOL( LPOOL ) 3280 INTEGER NBFIN, SLAVEF 3281 DOUBLE PRECISION OPASSW, OPELIW 3282 INTEGER PROCNODE_STEPS( KEEP(28) ) 3283 INTEGER ITLOC( N + KEEP(253) ), FILS( N ) 3284 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 3285 INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) 3286 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 3287 INTEGER INTARR( max(1,KEEP(14)) ) 3288 COMPLEX(kind=8) DBLARR( max(1,KEEP(13)) ) 3289 INTEGER ISTEP_TO_INIV2(KEEP(71)), 3290 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 3291 INTEGER allocok 3292 INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL 3293 INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL 3294 INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST 3295 INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST 3296 INTEGER STATUS( MPI_STATUS_SIZE ) 3297 INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB 3298 INTEGER PDEST, IERR 3299 INTEGER LOCAL_M, LOCAL_N 3300 INTEGER(8) :: POSROOT 3301 INTEGER NSUBSET_ROW, NSUBSET_COL 3302 INTEGER NRLOCAL, NCLOCAL 3303 LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED 3304 INTEGER NBROWS_ALREADY_SENT 3305 INTEGER SIZE_MSG 3306 INTEGER LP 3307 INCLUDE 'mumps_headers.h' 3308 LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY 3309 INTEGER BBPCBP 3310 BBPCBP = 0 3311 LP = ICNTL(1) 3312 IF ( ICNTL(4) .LE. 0 ) LP = -1 3313 ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) 3314 if (allocok .GT. 0) THEN 3315 IFLAG =-13 3316 IERROR = root%NPROW + 1 3317 endif 3318 ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) 3319 if (allocok .GT. 0) THEN 3320 IFLAG =-13 3321 IERROR = root%NPCOL + 1 3322 endif 3323 ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) 3324 if (allocok .GT. 0) THEN 3325 IFLAG =-13 3326 IERROR = root%NPROW + 1 3327 endif 3328 ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) 3329 if (allocok .GT. 0) THEN 3330 IFLAG =-13 3331 IERROR = root%NPCOL + 1 3332 endif 3333 IF (IFLAG.LT.0) THEN 3334 IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', 3335 & 'FAILURE in ZMUMPS_80' 3336 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 3337 RETURN 3338 ENDIF 3339 SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) 3340 BCP_SYM_NONEMPTY = .FALSE. 3341 PTRROW = 0 3342 PTRCOL = 0 3343 NSUPROW = 0 3344 NSUPCOL = 0 3345 DO I = 1, NBROW 3346 IGLOB = IW( PTRI(STEP(ISON)) + 3347 & SHIFT_LIST_ROW_SON + I - 1 ) 3348 IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE 3349 IF ( .NOT. INVERT ) THEN 3350 IF (IGLOB.GT.N) THEN 3351 BCP_SYM_NONEMPTY = .TRUE. 3352 POS_IN_ROOT = IGLOB - N 3353 JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) 3354 NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 3355 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 3356 ELSE 3357 POS_IN_ROOT = root%RG2L_ROW( IGLOB ) 3358 IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) 3359 PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 3360 ENDIF 3361 ELSE 3362 IF (IGLOB .GT. N) THEN 3363 POS_IN_ROOT = IGLOB - N 3364 ELSE 3365 POS_IN_ROOT = root%RG2L_COL( IGLOB ) 3366 ENDIF 3367 JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) 3368 IF (IGLOB.GT.N) 3369 & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 3370 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 3371 END IF 3372 END DO 3373 IF ((KEEP(50).NE.0).AND.(.NOT.INVERT).AND.BCP_SYM_NONEMPTY) 3374 & BBPCBP = 1 3375 DO I = 1, NBCOL 3376 JGLOB = IW( PTRI(STEP(ISON)) + 3377 & SHIFT_LIST_COL_SON + I - 1 ) 3378 IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE 3379 IF ( .NOT. INVERT ) THEN 3380 IF (KEEP(50).EQ.0) THEN 3381 IF (JGLOB.LE.N) THEN 3382 POS_IN_ROOT = root%RG2L_COL(JGLOB) 3383 ELSE 3384 POS_IN_ROOT = JGLOB-N 3385 ENDIF 3386 JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) 3387 IF (JGLOB.GT.N) THEN 3388 NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 3389 ENDIF 3390 PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 3391 ELSE 3392 POS_IN_ROOT = root%RG2L_COL(JGLOB) 3393 JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) 3394 PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 3395 IF (BCP_SYM_NONEMPTY) THEN 3396 POS_IN_ROOT = root%RG2L_ROW(JGLOB) 3397 IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) 3398 NSUPROW(IROW+1) = NSUPROW(IROW+1)+1 3399 PTRROW( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 3400 ENDIF 3401 ENDIF 3402 ELSE 3403 IF (JGLOB.LE.N) THEN 3404 POS_IN_ROOT = root%RG2L_ROW( JGLOB ) 3405 ELSE 3406 POS_IN_ROOT = JGLOB-N 3407 ENDIF 3408 IROW = mod( ( POS_IN_ROOT - 1 ) / 3409 & root%MBLOCK, root%NPROW ) 3410 PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 3411 END IF 3412 END DO 3413 PTRROW( 1 ) = 1 3414 DO IROW = 2, root%NPROW + 1 3415 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) 3416 END DO 3417 PTRCOL( 1 ) = 1 3418 DO JCOL = 2, root%NPCOL + 1 3419 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) 3420 END DO 3421 ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), 3422 & stat=allocok) 3423 if (allocok .GT. 0) THEN 3424 IFLAG =-13 3425 IERROR = PTRROW(root%NPROW+1)-1+1 3426 endif 3427 ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), 3428 & stat=allocok) 3429 if (allocok .GT. 0) THEN 3430 IFLAG =-13 3431 IERROR = PTRCOL(root%NPCOL+1)-1+1 3432 endif 3433 DO I = 1, NBROW 3434 IGLOB = IW( PTRI(STEP(ISON)) + 3435 & SHIFT_LIST_ROW_SON + I - 1 ) 3436 IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE 3437 IF ( .NOT. INVERT ) THEN 3438 IF (IGLOB.GT.N) CYCLE 3439 POS_IN_ROOT = root%RG2L_ROW( IGLOB ) 3440 IROW = mod( ( POS_IN_ROOT - 1 ) / root%MBLOCK, 3441 & root%NPROW ) 3442 ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I 3443 PTRROW ( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 3444 ELSE 3445 IF (IGLOB.LE.N) THEN 3446 POS_IN_ROOT = root%RG2L_COL( IGLOB ) 3447 ELSE 3448 POS_IN_ROOT = IGLOB - N 3449 ENDIF 3450 JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, 3451 & root%NPCOL ) 3452 COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I 3453 PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 3454 END IF 3455 END DO 3456 DO I = 1, NBCOL 3457 JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) 3458 IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE 3459 IF ( .NOT. INVERT ) THEN 3460 IF ( JGLOB.LE.N ) THEN 3461 POS_IN_ROOT = root%RG2L_COL( JGLOB ) 3462 ELSE 3463 POS_IN_ROOT = JGLOB - N 3464 ENDIF 3465 JCOL = mod( ( POS_IN_ROOT - 1 ) / 3466 & root%NBLOCK, root%NPCOL ) 3467 COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I 3468 PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 3469 ELSE 3470 IF ( JGLOB.LE.N ) THEN 3471 POS_IN_ROOT = root%RG2L_ROW( JGLOB ) 3472 ELSE 3473 POS_IN_ROOT = JGLOB - N 3474 ENDIF 3475 IROW = mod( ( POS_IN_ROOT - 1 ) / 3476 & root%MBLOCK, root%NPROW ) 3477 ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I 3478 PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 3479 END IF 3480 END DO 3481 IF (BCP_SYM_NONEMPTY) THEN 3482 DO I = 1, NBROW 3483 IGLOB = IW( PTRI(STEP(ISON)) + 3484 & SHIFT_LIST_ROW_SON + I - 1 ) 3485 IF (IGLOB.LE.N) CYCLE 3486 POS_IN_ROOT = IGLOB - N 3487 JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) 3488 COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I 3489 PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 3490 ENDDO 3491 DO I=1, NBCOL 3492 JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) 3493 IF (JGLOB.GT.N) THEN 3494 EXIT 3495 ELSE 3496 POS_IN_ROOT = root%RG2L_ROW(JGLOB) 3497 ENDIF 3498 IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) 3499 ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I 3500 PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 3501 ENDDO 3502 ENDIF 3503 DO IROW = root%NPROW, 2, -1 3504 PTRROW( IROW ) = PTRROW( IROW - 1 ) 3505 END DO 3506 PTRROW( 1 ) = 1 3507 DO JCOL = root%NPCOL, 2, -1 3508 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) 3509 END DO 3510 PTRCOL( 1 ) = 1 3511 JCOL = root%MYCOL 3512 IROW = root%MYROW 3513 IF ( root%yes ) THEN 3514 if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then 3515 write(*,*) ' error in grid position buildandsendcbroot' 3516 CALL MUMPS_ABORT() 3517 end if 3518 IF ( PTRIST(STEP(IROOT)).EQ.0.AND. 3519 & PTLUST_S(STEP(IROOT)).EQ.0) THEN 3520 NBPROCFILS( STEP(IROOT) ) = -1 3521 CALL ZMUMPS_284(root, IROOT, N, IW, LIW, 3522 & A, LA, 3523 & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, 3524 & LRLU, IPTRLU, 3525 & IWPOS, IWPOSCB, PTRIST, PTRAST, 3526 & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, 3527 & COMP, LRLUS, IFLAG, KEEP,KEEP8, IERROR ) 3528 IF (IFLAG.LT.0) THEN 3529 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 3530 RETURN 3531 ENDIF 3532 ELSE 3533 NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT)) - 1 3534 IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN 3535 IF (KEEP(201).EQ.1) THEN 3536 CALL ZMUMPS_681(IERR) 3537 ELSE IF (KEEP(201).EQ.2) THEN 3538 CALL ZMUMPS_580(IERR) 3539 ENDIF 3540 CALL ZMUMPS_507(N, IPOOL, LPOOL, PROCNODE_STEPS, 3541 & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), 3542 & STEP, IROOT+N ) 3543 IF (KEEP(47) .GE. 3) THEN 3544 CALL ZMUMPS_500( 3545 & IPOOL, LPOOL, 3546 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 3547 & MYID, STEP, N, ND, FILS ) 3548 ENDIF 3549 END IF 3550 END IF 3551 IF (KEEP(60) .NE. 0 ) THEN 3552 LOCAL_M = root%SCHUR_LLD 3553 LOCAL_N = root%SCHUR_NLOC 3554 NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) 3555 NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) 3556 CALL ZMUMPS_285( N, 3557 & root%SCHUR_POINTER(1), 3558 & LOCAL_M, LOCAL_N, 3559 & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, 3560 & NBCOL, NBROW, 3561 & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), 3562 & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), 3563 & LDA, A( PTRR( STEP(ISON)) + SHIFT_VAL_SON ), 3564 & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), 3565 & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), 3566 & NRLOCAL, 3567 & NCLOCAL, 3568 & NSUPROW(IROW+1), NSUPCOL(JCOL+1), 3569 & root%RG2L_ROW(1), root%RG2L_COL(1), INVERT, 3570 & KEEP, 3571 & root%RHS_ROOT(1,1), root%RHS_NLOC ) 3572 ELSE 3573 IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN 3574 IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN 3575 LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) 3576 LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) 3577 POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) 3578 ELSE 3579 LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) 3580 LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) 3581 POSROOT = PAMASTER(STEP( IROOT )) 3582 ENDIF 3583 NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) 3584 NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) 3585 CALL ZMUMPS_285( N, A( POSROOT ), 3586 & LOCAL_M, LOCAL_N, 3587 & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, 3588 & NBCOL, NBROW, 3589 & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), 3590 & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), 3591 & LDA, A( PTRR( STEP(ISON)) + SHIFT_VAL_SON ), 3592 & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), 3593 & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), 3594 & NRLOCAL, 3595 & NCLOCAL, 3596 & NSUPROW(IROW+1), NSUPCOL(JCOL+1), 3597 & root%RG2L_ROW(1), root%RG2L_COL(1), INVERT, 3598 & KEEP, 3599 & root%RHS_ROOT(1,1), root%RHS_NLOC ) 3600 END IF 3601 ENDIF 3602 END IF 3603 DO IROW = 0, root%NPROW - 1 3604 DO JCOL = 0, root%NPCOL - 1 3605 PDEST = IROW * root%NPCOL + JCOL 3606 IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. 3607 & MYID.ne.PDEST) THEN 3608 write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL 3609 write(*,*) ' MYID,PDEST=',MYID,PDEST 3610 CALL MUMPS_ABORT() 3611 END IF 3612 IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN 3613 NBROWS_ALREADY_SENT = 0 3614 IERR = -1 3615 DO WHILE ( IERR .EQ. -1 ) 3616 NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) 3617 NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) 3618 IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) 3619 & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) 3620 & THEN 3621 CALL ZMUMPS_94(N, KEEP(28), 3622 & IW, LIW, A, LA, 3623 & LRLU, IPTRLU, 3624 & IWPOS, IWPOSCB, PTRIST, PTRAST, 3625 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 3626 & KEEP(IXSZ)) 3627 COMP = COMP + 1 3628 IF ( LRLU .NE. LRLUS ) THEN 3629 WRITE(*,*) MYID,': Error in b&scbroot: pb compress' 3630 WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS 3631 CALL MUMPS_ABORT() 3632 END IF 3633 END IF 3634 CALL ZMUMPS_648( N, ISON, 3635 & NBCOL, NBROW, 3636 & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), 3637 & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), 3638 & LDA, A( PTRR(STEP(ISON)) + SHIFT_VAL_SON ), 3639 & TAG, 3640 & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), 3641 & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), 3642 & NSUBSET_ROW, NSUBSET_COL, 3643 & NSUPROW(IROW+1), NSUPCOL(JCOL+1), 3644 & root%NPROW, root%NPCOL, root%MBLOCK, 3645 & root%RG2L_ROW, root%RG2L_COL, 3646 & root%NBLOCK, PDEST, 3647 & COMM, IERR, A( POSFAC ), LRLU, INVERT, 3648 & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) 3649 IF ( IERR .EQ. -1 ) THEN 3650 BLOCKING = .FALSE. 3651 SET_IRECV = .TRUE. 3652 MESSAGE_RECEIVED = .FALSE. 3653 CALL ZMUMPS_329( COMM_LOAD, ASS_IRECV, 3654 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, 3655 & MPI_ANY_SOURCE, MPI_ANY_TAG, 3656 & STATUS, BUFR, LBUFR, 3657 & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, 3658 & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, 3659 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, 3660 & PIMASTER, PAMASTER, NSTK, 3661 & COMP, IFLAG, IERROR, COMM, NBPROCFILS, IPOOL, LPOOL, 3662 & LEAF, NBFIN, MYID, SLAVEF, root, 3663 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 3664 & PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, KEEP,KEEP8, 3665 & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, 3666 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. ) 3667 IF ( IFLAG .LT. 0 ) GOTO 500 3668 END IF 3669 END DO 3670 IF ( IERR == -2 ) THEN 3671 IFLAG = -17 3672 IERROR = SIZE_MSG 3673 IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO 3674 & SMALL DURING ZMUMPS_80" 3675 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 3676 GOTO 500 3677 ENDIF 3678 IF ( IERR == -3 ) THEN 3679 IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO 3680 & SMALL DURING ZMUMPS_80" 3681 IFLAG = -20 3682 IERROR = SIZE_MSG 3683 CALL ZMUMPS_44( MYID, SLAVEF, COMM ) 3684 GOTO 500 3685 ENDIF 3686 END IF 3687 END DO 3688 END DO 3689 500 CONTINUE 3690 DEALLOCATE(PTRROW) 3691 DEALLOCATE(PTRCOL) 3692 DEALLOCATE(ROW_INDEX_LIST) 3693 DEALLOCATE(COL_INDEX_LIST) 3694 RETURN 3695 END SUBROUTINE ZMUMPS_80 3696 SUBROUTINE ZMUMPS_285( N, VAL_ROOT, 3697 & LOCAL_M, LOCAL_N, 3698 & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, 3699 & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, 3700 & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, 3701 & RG2L_ROW, RG2L_COL, INVERT, 3702 & KEEP, RHS_ROOT, NLOC ) 3703 IMPLICIT NONE 3704 INCLUDE 'zmumps_root.h' 3705 INTEGER N, LOCAL_M, LOCAL_N 3706 COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N ) 3707 INTEGER NPCOL, NPROW, MBLOCK, NBLOCK 3708 INTEGER NBCOL_SON, NBROW_SON 3709 INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) 3710 INTEGER LD_SON 3711 INTEGER NSUPROW, NSUPCOL 3712 COMPLEX(kind=8) VAL_SON( LD_SON, NBROW_SON ) 3713 INTEGER KEEP(500) 3714 INTEGER NSUBSET_ROW, NSUBSET_COL 3715 INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) 3716 INTEGER RG2L_ROW( N ), RG2L_COL( N ) 3717 LOGICAL INVERT 3718 INTEGER NLOC 3719 COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC) 3720 INTEGER ISUB, JSUB, I, J, IPOS_ROOT, JPOS_ROOT 3721 INTEGER ILOC_ROOT, JLOC_ROOT, IGLOB, JGLOB 3722 IF (KEEP(50).EQ.0) THEN 3723 DO ISUB = 1, NSUBSET_ROW 3724 I = SUBSET_ROW( ISUB ) 3725 IGLOB = INDROW_SON( I ) 3726 IPOS_ROOT = RG2L_ROW( IGLOB ) 3727 ILOC_ROOT = MBLOCK 3728 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 3729 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 3730 DO JSUB = 1, NSUBSET_COL-NSUPCOL 3731 J = SUBSET_COL( JSUB ) 3732 JGLOB = INDCOL_SON( J ) 3733 JPOS_ROOT = RG2L_COL( JGLOB ) 3734 JLOC_ROOT = NBLOCK 3735 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 3736 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 3737 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = 3738 & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) 3739 END DO 3740 DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL 3741 J = SUBSET_COL( JSUB ) 3742 JGLOB = INDCOL_SON( J ) 3743 JPOS_ROOT = JGLOB - N 3744 JLOC_ROOT = NBLOCK 3745 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 3746 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 3747 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = 3748 & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) 3749 ENDDO 3750 END DO 3751 ELSE 3752 IF ( .NOT. INVERT ) THEN 3753 DO ISUB = 1, NSUBSET_ROW - NSUPROW 3754 I = SUBSET_ROW( ISUB ) 3755 IGLOB = INDROW_SON( I ) 3756 IPOS_ROOT = RG2L_ROW( IGLOB ) 3757 ILOC_ROOT = MBLOCK 3758 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 3759 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 3760 DO JSUB = 1, NSUBSET_COL -NSUPCOL 3761 J = SUBSET_COL( JSUB ) 3762 JGLOB = INDCOL_SON( J ) 3763 JPOS_ROOT = RG2L_COL( JGLOB ) 3764 JLOC_ROOT = NBLOCK 3765 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 3766 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 3767 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = 3768 & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) 3769 END DO 3770 END DO 3771 DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL 3772 J = SUBSET_COL( JSUB ) 3773 JGLOB = INDROW_SON( J ) 3774 JPOS_ROOT = JGLOB - N 3775 JLOC_ROOT = NBLOCK 3776 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 3777 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 3778 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW 3779 I = SUBSET_ROW( ISUB ) 3780 IGLOB = INDCOL_SON( I ) 3781 IPOS_ROOT = RG2L_ROW(IGLOB) 3782 ILOC_ROOT = MBLOCK 3783 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 3784 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 3785 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = 3786 & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( I, J ) 3787 END DO 3788 END DO 3789 ELSE 3790 DO ISUB = 1, NSUBSET_COL-NSUPCOL 3791 I = SUBSET_COL( ISUB ) 3792 IGLOB = INDROW_SON( I ) 3793 JPOS_ROOT = RG2L_COL( IGLOB ) 3794 JLOC_ROOT = NBLOCK 3795 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 3796 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 3797 DO JSUB = 1, NSUBSET_ROW 3798 J = SUBSET_ROW( JSUB ) 3799 JGLOB = INDCOL_SON( J ) 3800 IPOS_ROOT = RG2L_ROW( JGLOB ) 3801 ILOC_ROOT = MBLOCK 3802 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 3803 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 3804 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = 3805 & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) 3806 END DO 3807 ENDDO 3808 DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL 3809 I = SUBSET_COL( ISUB ) 3810 IGLOB = INDROW_SON( I ) 3811 JPOS_ROOT = IGLOB - N 3812 JLOC_ROOT = NBLOCK 3813 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) 3814 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 3815 DO JSUB = 1, NSUBSET_ROW 3816 J = SUBSET_ROW( JSUB ) 3817 JGLOB = INDCOL_SON( J ) 3818 IPOS_ROOT = RG2L_ROW( JGLOB ) 3819 ILOC_ROOT = MBLOCK 3820 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) 3821 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 3822 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = 3823 & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) 3824 END DO 3825 ENDDO 3826 END IF 3827 END IF 3828 RETURN 3829 END SUBROUTINE ZMUMPS_285 3830 SUBROUTINE ZMUMPS_164 3831 &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, 3832 & K50, K46, K51 3833 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK 3834 & ) 3835 IMPLICIT NONE 3836 INCLUDE 'zmumps_root.h' 3837 INTEGER MYID, MYID_ROOT 3838 TYPE (ZMUMPS_ROOT_STRUC)::root 3839 INTEGER COMM_ROOT 3840 INTEGER N, IROOT, NPROCS, K50, K46, K51 3841 INTEGER FILS( N ) 3842 INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK 3843 INTEGER INODE, NPROWtemp, NPCOLtemp 3844 LOGICAL SLAVE 3845 root%ROOT_SIZE = 0 3846 root%TOT_ROOT_SIZE = 0 3847 SLAVE = ( MYID .ne. 0 .or. 3848 & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) 3849 INODE = IROOT 3850 DO WHILE ( INODE .GT. 0 ) 3851 INODE = FILS( INODE ) 3852 root%ROOT_SIZE = root%ROOT_SIZE + 1 3853 END DO 3854 IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. 3855 & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 3856 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 3857 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN 3858 root%MBLOCK = K51 3859 root%NBLOCK = K51 3860 CALL ZMUMPS_99( NPROCS, root%NPROW, root%NPCOL, 3861 & root%ROOT_SIZE, K50 ) 3862 IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN 3863 IDNPROW = root%NPROW 3864 IDNPCOL = root%NPCOL 3865 IDMBLOCK = root%MBLOCK 3866 IDNBLOCK = root%NBLOCK 3867 ENDIF 3868 ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN 3869 root%NPROW = IDNPROW 3870 root%NPCOL = IDNPCOL 3871 root%MBLOCK = IDMBLOCK 3872 root%NBLOCK = IDNBLOCK 3873 ENDIF 3874 IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN 3875 IF (SLAVE) THEN 3876 root%LPIV = 0 3877 IF (K46.EQ.0) THEN 3878 MYID_ROOT=MYID-1 3879 ELSE 3880 MYID_ROOT=MYID 3881 ENDIF 3882 IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN 3883 root%MYROW = MYID_ROOT / root%NPCOL 3884 root%MYCOL = mod(MYID_ROOT, root%NPCOL) 3885 root%yes = .true. 3886 ELSE 3887 root%MYROW = -1 3888 root%MYCOL = -1 3889 root%yes = .FALSE. 3890 ENDIF 3891 ELSE 3892 root%yes = .FALSE. 3893 ENDIF 3894 ELSE IF ( SLAVE ) THEN 3895 IF ( root%gridinit_done) THEN 3896 CALL blacs_gridexit( root%CNTXT_BLACS ) 3897 root%gridinit_done = .FALSE. 3898 END IF 3899 root%CNTXT_BLACS = COMM_ROOT 3900 CALL blacs_gridinit( root%CNTXT_BLACS, 'R', 3901 & root%NPROW, root%NPCOL ) 3902 root%gridinit_done = .TRUE. 3903 CALL blacs_gridinfo( root%CNTXT_BLACS, 3904 & NPROWtemp, NPCOLtemp, 3905 & root%MYROW, root%MYCOL ) 3906 IF ( root%MYROW .NE. -1 ) THEN 3907 root%yes = .true. 3908 ELSE 3909 root%yes = .false. 3910 END IF 3911 root%LPIV = 0 3912 ELSE 3913 root%yes = .FALSE. 3914 ENDIF 3915 RETURN 3916 END SUBROUTINE ZMUMPS_164 3917 SUBROUTINE ZMUMPS_165( N, root, FILS, IROOT, 3918 & KEEP, INFO ) 3919 IMPLICIT NONE 3920 INCLUDE 'zmumps_root.h' 3921 TYPE ( ZMUMPS_ROOT_STRUC ):: root 3922 INTEGER N, IROOT, INFO(40), KEEP(500) 3923 INTEGER FILS( N ) 3924 INTEGER INODE, I, allocok 3925 IF ( associated( root%RG2L_ROW ) ) DEALLOCATE( root%RG2L_ROW ) 3926 IF ( associated( root%RG2L_COL ) ) DEALLOCATE( root%RG2L_COL ) 3927 ALLOCATE( root%RG2L_ROW( N ), stat = allocok ) 3928 IF ( allocok .GT. 0 ) THEN 3929 INFO(1)=-13 3930 INFO(2)=N 3931 RETURN 3932 ENDIF 3933 ALLOCATE( root%RG2L_COL( N ), stat = allocok ) 3934 IF ( allocok .GT. 0 ) THEN 3935 INFO(1)=-13 3936 INFO(2)=N 3937 RETURN 3938 ENDIF 3939 INODE = IROOT 3940 I = 1 3941 DO WHILE ( INODE .GT. 0 ) 3942 root%RG2L_ROW( INODE ) = I 3943 root%RG2L_COL( INODE ) = I 3944 I = I + 1 3945 INODE = FILS( INODE ) 3946 END DO 3947 RETURN 3948 END SUBROUTINE ZMUMPS_165 3949 SUBROUTINE ZMUMPS_99( NPROCS, NPROW, NPCOL, SIZE, K50 ) 3950 IMPLICIT NONE 3951 INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 3952 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS 3953 LOGICAL KEEPIT 3954 IF ( K50 .EQ. 1 ) THEN 3955 FLATNESS = 2 3956 ELSE 3957 FLATNESS = 3 3958 ENDIF 3959 NPROW = int(sqrt(dble(NPROCS))) 3960 NPROWtemp = NPROW 3961 NPCOL = int(NPROCS / NPROW) 3962 NPCOLtemp = NPCOL 3963 NPROCSused = NPROWtemp * NPCOLtemp 3964 10 CONTINUE 3965 IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN 3966 NPROWtemp = NPROWtemp - 1 3967 NPCOLtemp = int(NPROCS / NPROWtemp) 3968 KEEPIT=.FALSE. 3969 IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN 3970 IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) 3971 & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) 3972 & KEEPIT=.TRUE. 3973 END IF 3974 IF ( KEEPIT ) THEN 3975 NPROW = NPROWtemp 3976 NPCOL = NPCOLtemp 3977 NPROCSused = NPROW * NPCOL 3978 END IF 3979 GO TO 10 3980 END IF 3981 RETURN 3982 END SUBROUTINE ZMUMPS_99 3983 SUBROUTINE ZMUMPS_290(MYID, M, N, ASEQ, 3984 & LOCAL_M, LOCAL_N, 3985 & MBLOCK, NBLOCK, 3986 & APAR, 3987 & MASTER_ROOT, 3988 & NPROW, NPCOL, 3989 & COMM) 3990 IMPLICIT NONE 3991 INTEGER MYID, MASTER_ROOT, COMM 3992 INTEGER M, N 3993 INTEGER NPROW, NPCOL 3994 INTEGER LOCAL_M, LOCAL_N 3995 INTEGER MBLOCK, NBLOCK 3996 COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N ) 3997 COMPLEX(kind=8) ASEQ( M, N ) 3998 INCLUDE 'mpif.h' 3999 INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL 4000 INTEGER IBLOCK, JBLOCK, II, JJ, KK 4001 INTEGER IAPAR, JAPAR, IERR 4002 INTEGER STATUS(MPI_STATUS_SIZE) 4003 COMPLEX(kind=8) WK( MBLOCK * NBLOCK ) 4004 LOGICAL JUPDATE 4005 IAPAR = 1 4006 JAPAR = 1 4007 DO J = 1, N, NBLOCK 4008 SIZE_JBLOCK = NBLOCK 4009 IF ( J + NBLOCK > N ) THEN 4010 SIZE_JBLOCK = N - J + 1 4011 END IF 4012 JUPDATE = .FALSE. 4013 DO I = 1, M, MBLOCK 4014 SIZE_IBLOCK = MBLOCK 4015 IF ( I + MBLOCK > M ) THEN 4016 SIZE_IBLOCK = M - I + 1 4017 END IF 4018 IBLOCK = I / MBLOCK 4019 JBLOCK = J / NBLOCK 4020 IROW = mod ( IBLOCK, NPROW ) 4021 ICOL = mod ( JBLOCK, NPCOL ) 4022 IDEST = IROW * NPCOL + ICOL 4023 IF ( IDEST .NE. MASTER_ROOT ) THEN 4024 IF ( MYID .EQ. MASTER_ROOT ) THEN 4025 KK=1 4026 DO JJ=J,J+SIZE_JBLOCK-1 4027 DO II=I,I+SIZE_IBLOCK-1 4028 WK(KK)=ASEQ(II,JJ) 4029 KK=KK+1 4030 END DO 4031 END DO 4032 CALL MPI_SSEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, 4033 & MPI_DOUBLE_COMPLEX, 4034 & IDEST, 128, COMM, IERR ) 4035 ELSE IF ( MYID .EQ. IDEST ) THEN 4036 CALL MPI_RECV( WK(1), 4037 & SIZE_IBLOCK*SIZE_JBLOCK, 4038 & MPI_DOUBLE_COMPLEX, 4039 & MASTER_ROOT,128,COMM,STATUS,IERR) 4040 KK=1 4041 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 4042 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 4043 APAR(II,JJ)=WK(KK) 4044 KK=KK+1 4045 END DO 4046 END DO 4047 JUPDATE = .TRUE. 4048 IAPAR = IAPAR + SIZE_IBLOCK 4049 END IF 4050 ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN 4051 APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, 4052 & JAPAR:JAPAR+SIZE_JBLOCK-1 ) 4053 & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) 4054 JUPDATE = .TRUE. 4055 IAPAR = IAPAR + SIZE_IBLOCK 4056 END IF 4057 END DO 4058 IF ( JUPDATE ) THEN 4059 IAPAR = 1 4060 JAPAR = JAPAR + SIZE_JBLOCK 4061 END IF 4062 END DO 4063 RETURN 4064 END SUBROUTINE ZMUMPS_290 4065 SUBROUTINE ZMUMPS_156(MYID, M, N, ASEQ, 4066 & LOCAL_M, LOCAL_N, 4067 & MBLOCK, NBLOCK, 4068 & APAR, 4069 & MASTER_ROOT, 4070 & NPROW, NPCOL, 4071 & COMM) 4072 IMPLICIT NONE 4073 INTEGER MYID, MASTER_ROOT, COMM 4074 INTEGER M, N 4075 INTEGER NPROW, NPCOL 4076 INTEGER LOCAL_M, LOCAL_N 4077 INTEGER MBLOCK, NBLOCK 4078 COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N ) 4079 COMPLEX(kind=8) ASEQ( M, N ) 4080 INCLUDE 'mpif.h' 4081 INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL 4082 INTEGER IBLOCK, JBLOCK, II, JJ, KK 4083 INTEGER IAPAR, JAPAR, IERR 4084 INTEGER STATUS(MPI_STATUS_SIZE) 4085 COMPLEX(kind=8) WK( MBLOCK * NBLOCK ) 4086 LOGICAL JUPDATE 4087 IAPAR = 1 4088 JAPAR = 1 4089 DO J = 1, N, NBLOCK 4090 SIZE_JBLOCK = NBLOCK 4091 IF ( J + NBLOCK > N ) THEN 4092 SIZE_JBLOCK = N - J + 1 4093 END IF 4094 JUPDATE = .FALSE. 4095 DO I = 1, M, MBLOCK 4096 SIZE_IBLOCK = MBLOCK 4097 IF ( I + MBLOCK > M ) THEN 4098 SIZE_IBLOCK = M - I + 1 4099 END IF 4100 IBLOCK = I / MBLOCK 4101 JBLOCK = J / NBLOCK 4102 IROW = mod ( IBLOCK, NPROW ) 4103 ICOL = mod ( JBLOCK, NPCOL ) 4104 ISOUR = IROW * NPCOL + ICOL 4105 IF ( ISOUR .NE. MASTER_ROOT ) THEN 4106 IF ( MYID .EQ. MASTER_ROOT ) THEN 4107 CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, 4108 & MPI_DOUBLE_COMPLEX, 4109 & ISOUR, 128, COMM, STATUS, IERR ) 4110 KK=1 4111 DO JJ=J,J+SIZE_JBLOCK-1 4112 DO II=I,I+SIZE_IBLOCK-1 4113 ASEQ(II,JJ)=WK(KK) 4114 KK=KK+1 4115 END DO 4116 END DO 4117 ELSE IF ( MYID .EQ. ISOUR ) THEN 4118 KK=1 4119 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 4120 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 4121 WK(KK)=APAR(II,JJ) 4122 KK=KK+1 4123 END DO 4124 END DO 4125 CALL MPI_SSEND( WK( 1 ), 4126 & SIZE_IBLOCK*SIZE_JBLOCK, 4127 & MPI_DOUBLE_COMPLEX, 4128 & MASTER_ROOT,128,COMM,IERR) 4129 JUPDATE = .TRUE. 4130 IAPAR = IAPAR + SIZE_IBLOCK 4131 END IF 4132 ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN 4133 ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) 4134 & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, 4135 & JAPAR:JAPAR+SIZE_JBLOCK-1 ) 4136 JUPDATE = .TRUE. 4137 IAPAR = IAPAR + SIZE_IBLOCK 4138 END IF 4139 END DO 4140 IF ( JUPDATE ) THEN 4141 IAPAR = 1 4142 JAPAR = JAPAR + SIZE_JBLOCK 4143 END IF 4144 END DO 4145 RETURN 4146 END SUBROUTINE ZMUMPS_156 4147 SUBROUTINE ZMUMPS_284(root, IROOT, N, 4148 & IW, LIW, A, LA, 4149 & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, 4150 & LRLU, IPTRLU, 4151 & IWPOS, IWPOSCB, PTRIST, PTRAST, 4152 & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, 4153 & COMP, LRLUS, IFLAG, KEEP,KEEP8, IERROR ) 4154 IMPLICIT NONE 4155 INCLUDE 'zmumps_root.h' 4156 INTEGER MYID 4157 INTEGER KEEP(500) 4158 INTEGER(8) KEEP8(150) 4159 TYPE (ZMUMPS_ROOT_STRUC ) :: root 4160 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS 4161 INTEGER IROOT, LIW, N, IWPOS, IWPOSCB 4162 INTEGER IW( LIW ) 4163 COMPLEX(kind=8) A( LA ) 4164 INTEGER PTRIST(KEEP(28)), STEP(N) 4165 INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) 4166 INTEGER PIMASTER(KEEP(28)) 4167 INTEGER ITLOC( N + KEEP(253) ) 4168 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 4169 INTEGER COMP, IFLAG, IERROR 4170 INCLUDE 'mumps_headers.h' 4171 INTEGER FILS( N ), PTRAIW(N), PTRARW( N ) 4172 INTEGER INTARR(max(1,KEEP(14))) 4173 COMPLEX(kind=8) DBLARR(max(1,KEEP(13))) 4174 INTEGER numroc 4175 EXTERNAL numroc 4176 COMPLEX(kind=8) ZERO 4177 PARAMETER( ZERO = (0.0D0,0.0D0) ) 4178 INTEGER(8) :: LREQA_ROOT 4179 INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok 4180 LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, 4181 & root%MYROW, 0, root%NPROW ) 4182 LOCAL_M = max( 1, LOCAL_M ) 4183 LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, 4184 & root%MYCOL, 0, root%NPCOL ) 4185 IF (KEEP(253).GT.0) THEN 4186 root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, 4187 & root%MYCOL, 0, root%NPCOL ) 4188 root%RHS_NLOC = max(1, root%RHS_NLOC) 4189 ELSE 4190 root%RHS_NLOC = 1 4191 ENDIF 4192 IF (associated( root%RHS_ROOT) ) 4193 & DEALLOCATE (root%RHS_ROOT) 4194 ALLOCATE(root%RHS_ROOT(LOCAL_M,root%RHS_NLOC), 4195 & stat=allocok) 4196 IF ( allocok.GT.0) THEN 4197 IFLAG=-13 4198 IERROR = LOCAL_M*root%RHS_NLOC 4199 RETURN 4200 ENDIF 4201 IF (KEEP(253).NE.0) THEN 4202 root%RHS_ROOT = ZERO 4203 CALL ZMUMPS_760 ( N, FILS, 4204 & root, KEEP, RHS_MUMPS, 4205 & IFLAG, IERROR ) 4206 IF ( IFLAG .LT. 0 ) RETURN 4207 ENDIF 4208 IF (KEEP(60) .NE. 0) THEN 4209 PTRIST(STEP(IROOT)) = -6666666 4210 RETURN 4211 ENDIF 4212 LREQI_ROOT = 2 + KEEP(IXSZ) 4213 LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) 4214 IF (LREQA_ROOT.EQ.0_8) THEN 4215 PTRIST(STEP(IROOT)) = -9999999 4216 RETURN 4217 ENDIF 4218 CALL ZMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., 4219 & MYID,N,KEEP,KEEP8,IW,LIW,A,LA, 4220 & LRLU, IPTRLU, 4221 & IWPOS, IWPOSCB, PTRIST, PTRAST, 4222 & STEP, PIMASTER, PAMASTER, LREQI_ROOT, 4223 & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, 4224 & LRLUS, IFLAG, IERROR 4225 & ) 4226 IF ( IFLAG .LT. 0 ) RETURN 4227 PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 4228 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 4229 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N 4230 IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M 4231 RETURN 4232 END SUBROUTINE ZMUMPS_284 4233 SUBROUTINE ZMUMPS_760 4234 & ( N, FILS, root, KEEP, RHS_MUMPS, 4235 & IFLAG, IERROR ) 4236 IMPLICIT NONE 4237 INCLUDE 'zmumps_root.h' 4238 INTEGER N, KEEP(500), IFLAG, IERROR 4239 INTEGER FILS(N) 4240 TYPE (ZMUMPS_ROOT_STRUC ) :: root 4241 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 4242 INTEGER JCOL, IPOS_ROOT, JPOS_ROOT, 4243 & IROW_GRID, JCOL_GRID, ILOCRHS, JLOCRHS, 4244 & INODE 4245 INODE = KEEP(38) 4246 DO WHILE (INODE.GT.0) 4247 IPOS_ROOT = root%RG2L_ROW( INODE ) 4248 IROW_GRID = mod( ( IPOS_ROOT - 1 ) / root%MBLOCK, root%NPROW ) 4249 IF ( IROW_GRID .NE. root%MYROW ) GOTO 100 4250 ILOCRHS = root%MBLOCK * ( ( IPOS_ROOT - 1 ) / 4251 & ( root%MBLOCK * root%NPROW ) ) 4252 & + mod( IPOS_ROOT - 1, root%MBLOCK ) + 1 4253 DO JCOL = 1, KEEP(253) 4254 JPOS_ROOT = JCOL 4255 JCOL_GRID = mod((JPOS_ROOT-1)/root%NBLOCK, root%NPCOL) 4256 IF (JCOL_GRID.NE.root%MYCOL ) CYCLE 4257 JLOCRHS = root%NBLOCK * ( ( JPOS_ROOT - 1 ) / 4258 & ( root%NBLOCK * root%NPCOL ) ) 4259 & + mod( JPOS_ROOT - 1, root%NBLOCK ) + 1 4260 root%RHS_ROOT(ILOCRHS, JLOCRHS) = 4261 & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) 4262 ENDDO 4263 100 CONTINUE 4264 INODE=FILS(INODE) 4265 ENDDO 4266 RETURN 4267 END SUBROUTINE ZMUMPS_760 4268 INTEGER FUNCTION ZMUMPS_IXAMAX(n,x,incx) 4269 COMPLEX(kind=8) x(*) 4270 DOUBLE PRECISION smax 4271 integer i,ix 4272 integer incx,n 4273 ZMUMPS_IXAMAX = 0 4274 if( n.lt.1 ) return 4275 ZMUMPS_IXAMAX = 1 4276 if( n.eq.1 .or. incx.le.0 )return 4277 if(incx.eq.1)go to 20 4278 ix = 1 4279 smax = abs(x(1)) 4280 ix = ix + incx 4281 do 10 i = 2,n 4282 if(abs(x(ix)).le.smax) go to 5 4283 ZMUMPS_IXAMAX = i 4284 smax = abs(x(ix)) 4285 5 ix = ix + incx 4286 10 continue 4287 return 4288 20 smax = abs(x(1)) 4289 do 30 i = 2,n 4290 if(abs(x(i)).le.smax) go to 30 4291 ZMUMPS_IXAMAX = i 4292 smax = abs(x(i)) 4293 30 continue 4294 return 4295 END FUNCTION ZMUMPS_IXAMAX 4296 SUBROUTINE ZMUMPS_XSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) 4297 CHARACTER UPLO 4298 INTEGER INCX, LDA, N 4299 COMPLEX(kind=8) ALPHA 4300 COMPLEX(kind=8) A( LDA, * ), X( * ) 4301 COMPLEX(kind=8) ZERO 4302 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 4303 INTEGER I, INFO, IX, J, JX, KX 4304 COMPLEX(kind=8) TEMP 4305 INTRINSIC max 4306 INFO = 0 4307 IF( UPLO.NE.'U' .AND. UPLO.NE.'L' ) THEN 4308 INFO = 1 4309 ELSE IF( N.LT.0 ) THEN 4310 INFO = 2 4311 ELSE IF( INCX.EQ.0 ) THEN 4312 INFO = 5 4313 ELSE IF( LDA.LT.max( 1, N ) ) THEN 4314 INFO = 7 4315 END IF 4316 IF( INFO.NE.0 ) THEN 4317 WRITE(*,*) "Internal error in ZMUMPS_XSYR" 4318 CALL MUMPS_ABORT() 4319 RETURN 4320 END IF 4321 IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) ) 4322 & RETURN 4323 IF( INCX.LE.0 ) THEN 4324 KX = 1 - ( N-1 )*INCX 4325 ELSE IF( INCX.NE.1 ) THEN 4326 KX = 1 4327 END IF 4328 IF( UPLO.EQ.'U' ) THEN 4329 IF( INCX.EQ.1 ) THEN 4330 DO 20 J = 1, N 4331 IF( X( J ).NE.ZERO ) THEN 4332 TEMP = ALPHA*X( J ) 4333 DO 10 I = 1, J 4334 A( I, J ) = A( I, J ) + X( I )*TEMP 4335 10 CONTINUE 4336 END IF 4337 20 CONTINUE 4338 ELSE 4339 JX = KX 4340 DO 40 J = 1, N 4341 IF( X( JX ).NE.ZERO ) THEN 4342 TEMP = ALPHA*X( JX ) 4343 IX = KX 4344 DO 30 I = 1, J 4345 A( I, J ) = A( I, J ) + X( IX )*TEMP 4346 IX = IX + INCX 4347 30 CONTINUE 4348 END IF 4349 JX = JX + INCX 4350 40 CONTINUE 4351 END IF 4352 ELSE 4353 IF( INCX.EQ.1 ) THEN 4354 DO 60 J = 1, N 4355 IF( X( J ).NE.ZERO ) THEN 4356 TEMP = ALPHA*X( J ) 4357 DO 50 I = J, N 4358 A( I, J ) = A( I, J ) + X( I )*TEMP 4359 50 CONTINUE 4360 END IF 4361 60 CONTINUE 4362 ELSE 4363 JX = KX 4364 DO 80 J = 1, N 4365 IF( X( JX ).NE.ZERO ) THEN 4366 TEMP = ALPHA*X( JX ) 4367 IX = JX 4368 DO 70 I = J, N 4369 A( I, J ) = A( I, J ) + X( IX )*TEMP 4370 IX = IX + INCX 4371 70 CONTINUE 4372 END IF 4373 JX = JX + INCX 4374 80 CONTINUE 4375 END IF 4376 END IF 4377 RETURN 4378 END SUBROUTINE ZMUMPS_XSYR 4379