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 DMUMPS_152(SSARBR, MYID, N, IPOSBLOCK, 49 & RPOSBLOCK, 50 & IW, LIW, 51 & LRLU, LRLUS, IPTRLU, 52 & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS 53 & ) 54 USE DMUMPS_LOAD 55 IMPLICIT NONE 56 INTEGER(8) :: RPOSBLOCK 57 INTEGER IPOSBLOCK, 58 & LIW, IWPOSCB, N 59 INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU 60 LOGICAL IN_PLACE_STATS 61 INTEGER IW( LIW ), KEEP(500) 62 INTEGER(8) KEEP8(150) 63 INTEGER MYID 64 LOGICAL SSARBR 65 INTEGER SIZFI_BLOCK, SIZFI 66 INTEGER IPOSSHIFT 67 INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, 68 & SIZEHOLE, MEM_INC 69 INCLUDE 'mumps_headers.h' 70 IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) 71 SIZFI_BLOCK=IW(IPOSBLOCK+XXI) 72 CALL MUMPS_729( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) ) 73 IF (KEEP(216).eq.3) THEN 74 SIZFR_BLOCK_EFF=SIZFR_BLOCK 75 ELSE 76 CALL DMUMPS_628( IW(IPOSBLOCK), 77 & LIW-IPOSBLOCK+1, 78 & SIZEHOLE, KEEP(IXSZ)) 79 SIZFR_BLOCK_EFF=SIZFR_BLOCK-SIZEHOLE 80 ENDIF 81 IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN 82 IPTRLU = IPTRLU + SIZFR_BLOCK 83 IWPOSCB = IWPOSCB + SIZFI_BLOCK 84 LRLU = LRLU + SIZFR_BLOCK 85 IF (.NOT. IN_PLACE_STATS) THEN 86 LRLUS = LRLUS + SIZFR_BLOCK_EFF 87 ENDIF 88 MEM_INC = -SIZFR_BLOCK_EFF 89 IF (IN_PLACE_STATS) THEN 90 MEM_INC= 0_8 91 ENDIF 92 CALL DMUMPS_471(SSARBR,.FALSE., 93 & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLU) 94 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 95 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) 96 SIZFI = IW( IWPOSCB+1+XXI ) 97 CALL MUMPS_729( SIZFR,IW(IWPOSCB+1+XXR) ) 98 IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN 99 IPTRLU = IPTRLU + SIZFR 100 LRLU = LRLU + SIZFR 101 IWPOSCB = IWPOSCB + SIZFI 102 GO TO 90 103 ENDIF 104 100 CONTINUE 105 IW( IWPOSCB+1+XXP)=TOP_OF_STACK 106 ELSE 107 IW( IPOSBLOCK +XXS)=S_FREE 108 IF (.NOT. IN_PLACE_STATS) LRLUS = LRLUS + SIZFR_BLOCK_EFF 109 CALL DMUMPS_471(SSARBR,.FALSE., 110 & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLU) 111 END IF 112 RETURN 113 END SUBROUTINE DMUMPS_152 114 SUBROUTINE DMUMPS_144( COMM_LOAD, ASS_IRECV, 115 & N, INODE, FPERE, IW, LIW, A, LA, 116 & UU, NOFFW, 117 & NPVW, 118 & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, 119 & IFLAG, IERROR, IPOOL,LPOOL, 120 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 121 & LRLUS, COMP, 122 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, PIMASTER, 123 & PAMASTER, 124 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 125 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 126 & FILS, PTRARW, PTRAIW, 127 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 128 & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, 129 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, 130 & DKEEP,PIVNUL_LIST,LPN_LIST) 131 USE DMUMPS_OOC 132 IMPLICIT NONE 133 INCLUDE 'dmumps_root.h' 134 INTEGER COMM_LOAD, ASS_IRECV 135 INTEGER N, INODE, FPERE, LIW, NOFFW, NPVW 136 INTEGER(8) :: LA 137 INTEGER IW( LIW ) 138 DOUBLE PRECISION A( LA ) 139 DOUBLE PRECISION UU, SEUIL 140 TYPE (DMUMPS_ROOT_STRUC) :: root 141 INTEGER COMM, MYID, LBUFR, LBUFR_BYTES 142 INTEGER LPTRAR, NELT 143 INTEGER ICNTL(40), KEEP(500) 144 INTEGER(8) KEEP8(150) 145 INTEGER NBFIN, SLAVEF, 146 & IFLAG, IERROR, LEAF, LPOOL 147 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS 148 INTEGER IWPOS, IWPOSCB, COMP 149 INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) 150 INTEGER BUFR( LBUFR ), IPOOL(LPOOL), 151 & ITLOC(N+KEEP(253)), FILS(N), 152 & PTRARW(LPTRAR), PTRAIW(LPTRAR), 153 & ND( KEEP(28) ), FRERE( KEEP(28) ) 154 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 155 INTEGER INTARR(max(1,KEEP(14))) 156 INTEGER(8) :: PTRAST(KEEP(28)) 157 INTEGER(8) :: PTRFAC(KEEP(28)) 158 INTEGER(8) :: PAMASTER(KEEP(28)) 159 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), 160 & STEP(N), PIMASTER(KEEP(28)), 161 & NSTK_S(KEEP(28)), NBPROCFILS(KEEP(28)), 162 & PROCNODE_STEPS(KEEP(28)) 163 INTEGER ISTEP_TO_INIV2(KEEP(71)), 164 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 165 DOUBLE PRECISION OPASSW, OPELIW 166 DOUBLE PRECISION DBLARR(max(1,KEEP(13))) 167 LOGICAL AVOID_DELAYED 168 INTEGER LPN_LIST 169 INTEGER PIVNUL_LIST(LPN_LIST) 170 DOUBLE PRECISION DKEEP(30) 171 INTEGER INOPV, IFINB, NFRONT, NPIV, IBEGKJI, NBOLKJ, 172 & NBTLKJ, IBEG_BLOCK 173 INTEGER(8) :: POSELT 174 INTEGER NASS, NEL1, IEND, IOLDPS, dummy, allocok 175 LOGICAL LASTBL 176 DOUBLE PRECISION UUTEMP 177 INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV 178 INTEGER(8) :: LAFAC 179 INTEGER LIWFAC, STRAT, TYPEFile, LNextPiv2beWritten, 180 & UNextPiv2beWritten, IFLAG_OOC, 181 & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, 182 & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U 183 TYPE(IO_BLOCK) :: MonBloc 184 LOGICAL LAST_CALL 185 INCLUDE 'mumps_headers.h' 186 EXTERNAL DMUMPS_224, DMUMPS_233, 187 & DMUMPS_225, DMUMPS_232, 188 & DMUMPS_294, 189 & DMUMPS_44 190 LOGICAL STATICMODE 191 DOUBLE PRECISION SEUIL_LOC 192 INOPV = 0 193 SEUIL_LOC = SEUIL 194 IF(KEEP(97) .EQ. 0) THEN 195 STATICMODE = .FALSE. 196 ELSE 197 STATICMODE = .TRUE. 198 ENDIF 199 IF (AVOID_DELAYED) THEN 200 STATICMODE = .TRUE. 201 UUTEMP=UU 202 SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) 203 ELSE 204 UUTEMP=UU 205 ENDIF 206 IBEG_BLOCK=1 207 dummy = 0 208 IOLDPS = PTLUST_S(STEP( INODE )) 209 POSELT = PTRAST(STEP( INODE )) 210 NFRONT = IW(IOLDPS+KEEP(IXSZ)) 211 NASS = iabs(IW(IOLDPS+2+KEEP(IXSZ))) 212 IF (NASS .GT. KEEP(3)) THEN 213 NBOLKJ = min( KEEP(6), NASS ) 214 ELSE 215 NBOLKJ = min( KEEP(5),NASS ) 216 ENDIF 217 NBTLKJ = NBOLKJ 218 ALLOCATE( IPIV( NASS ), stat = allocok ) 219 IF ( allocok .GT. 0 ) THEN 220 WRITE(*,*) MYID,' : FACTO_NIV2 :failed to allocate ',NASS, 221 & ' integers' 222 IFLAG = -13 223 IERROR =NASS 224 GO TO 490 225 END IF 226 IF (KEEP(201).EQ.1) THEN 227 CALL MUMPS_729(LAFAC,IW(IOLDPS+XXR)) 228 LIWFAC = IW(IOLDPS+XXI) 229 TYPEFile = TYPEF_U 230 LNextPiv2beWritten = 1 231 UNextPiv2beWritten = 1 232 PP_FIRST2SWAP_L = LNextPiv2beWritten 233 PP_FIRST2SWAP_U = UNextPiv2beWritten 234 MonBloc%LastPanelWritten_L = 0 235 MonBloc%LastPanelWritten_U = 0 236 MonBloc%INODE = INODE 237 MonBloc%MASTER = .TRUE. 238 MonBloc%Typenode = 2 239 MonBloc%NROW = NASS 240 MonBloc%NCOL = NFRONT 241 MonBloc%NFS = NASS 242 MonBloc%Last = .FALSE. 243 MonBloc%LastPiv = -68877 244 NULLIFY(MonBloc%INDICES) 245 ENDIF 246 50 CONTINUE 247 IBEGKJI = IBEG_BLOCK 248 CALL DMUMPS_224(NFRONT,NASS,IBEGKJI, NASS, IPIV, 249 & N,INODE,IW,LIW,A,LA,INOPV,NOFFW, 250 & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, 251 & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, 252 & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, 253 & PP_LastPIVRPTRFilled_L, 254 & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, 255 & PP_LastPIVRPTRFilled_U) 256 IF (IFLAG.LT.0) GOTO 490 257 IF (INOPV.EQ.1) THEN 258 IF(STATICMODE) THEN 259 INOPV = -1 260 GOTO 50 261 ENDIF 262 ENDIF 263 IF (INOPV.GE.1) THEN 264 LASTBL = (INOPV.EQ.1) 265 IEND = IW(IOLDPS+1+KEEP(IXSZ)) 266 CALL DMUMPS_294( COMM_LOAD, ASS_IRECV, 267 & N, INODE, FPERE, IW, LIW, 268 & IOLDPS, POSELT, A, LA, NFRONT, 269 & IBEGKJI, IEND, IPIV, NASS,LASTBL, dummy, 270 & 271 & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, 272 & IFLAG, IERROR, IPOOL,LPOOL, 273 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 274 & LRLUS, COMP, 275 & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, 276 & PIMASTER, PAMASTER, 277 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 278 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 279 & FILS, PTRARW, PTRAIW, 280 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 281 & LPTRAR, NELT, FRTPTR, FRTELT, 282 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 283 IF ( IFLAG .LT. 0 ) GOTO 500 284 ENDIF 285 IF (INOPV.EQ.1) GO TO 500 286 IF (INOPV.EQ.2) THEN 287 CALL DMUMPS_233(IBEG_BLOCK,NFRONT,NASS,N,INODE,IW,LIW,A,LA, 288 & IOLDPS,POSELT,NBOLKJ,NBTLKJ,KEEP(4),KEEP(IXSZ)) 289 GOTO 50 290 ENDIF 291 NPVW = NPVW + 1 292 IF (NASS.LE.1) THEN 293 IFINB = -1 294 ELSE 295 CALL DMUMPS_225(IBEG_BLOCK, 296 & NFRONT, NASS, N,INODE,IW,LIW,A,LA, 297 & IOLDPS,POSELT,IFINB, 298 & NBTLKJ,KEEP(4),KEEP(IXSZ)) 299 ENDIF 300 IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS+1+KEEP(IXSZ)) + 1 301 IF (IFINB.EQ.0) GOTO 50 302 IF ((IFINB.EQ.1).OR.(IFINB.EQ.-1)) THEN 303 LASTBL = (IFINB.EQ.-1) 304 IEND = IW(IOLDPS+1+KEEP(IXSZ)) 305 CALL DMUMPS_294(COMM_LOAD, ASS_IRECV, 306 & N, INODE, FPERE, IW, LIW, 307 & IOLDPS, POSELT, A, LA, NFRONT, 308 & IBEGKJI, IEND, IPIV, NASS, LASTBL, dummy, 309 & 310 & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, 311 & IFLAG, IERROR, IPOOL,LPOOL, 312 & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, 313 & LRLUS, COMP, 314 & PTRIST, PTRAST, PTLUST_S, PTRFAC, 315 & STEP, PIMASTER, PAMASTER, 316 & NSTK_S,NBPROCFILS,PROCNODE_STEPS, root, 317 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 318 & FILS, PTRARW, PTRAIW, 319 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 320 & LPTRAR, NELT, FRTPTR, FRTELT, 321 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 322 IF ( IFLAG .LT. 0 ) GOTO 500 323 ENDIF 324 IF (IFINB.EQ.(-1)) GOTO 500 325 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) 326 NEL1 = NASS - NPIV 327 CALL DMUMPS_232(A,LA, 328 & NFRONT,NPIV,NASS,POSELT,NBTLKJ) 329 IF (KEEP(201).EQ.1) THEN 330 STRAT = STRAT_TRY_WRITE 331 MonBloc%LastPiv = NPIV 332 TYPEFile = TYPEF_BOTH_LU 333 LAST_CALL= .FALSE. 334 CALL DMUMPS_688 335 & ( STRAT, TYPEFile, 336 & A(POSELT), LAFAC, MonBloc, 337 & LNextPiv2beWritten, UNextPiv2beWritten, 338 & IW(IOLDPS), LIWFAC, 339 & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 340 IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC 341 IF (IFLAG<0) RETURN 342 ENDIF 343 GO TO 50 344 490 CONTINUE 345 CALL DMUMPS_44( MYID, SLAVEF, COMM ) 346 500 CONTINUE 347 DEALLOCATE( IPIV ) 348 IF (KEEP(201).EQ.1) THEN 349 STRAT = STRAT_WRITE_MAX 350 MonBloc%Last = .TRUE. 351 MonBloc%LastPiv = IW(IOLDPS+1+KEEP(IXSZ)) 352 TYPEFile = TYPEF_BOTH_LU 353 LAST_CALL = .TRUE. 354 CALL DMUMPS_688 355 & ( STRAT, TYPEFile, 356 & A(POSELT), LAFAC, MonBloc, 357 & LNextPiv2beWritten, UNextPiv2beWritten, 358 & IW(IOLDPS), LIWFAC, 359 & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) 360 IF (IFLAG_OOC < 0 ) IFLAG=IFLAG_OOC 361 IF (IFLAG<0) RETURN 362 CALL DMUMPS_644 (IWPOS, 363 & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) 364 ENDIF 365 RETURN 366 END SUBROUTINE DMUMPS_144 367 SUBROUTINE DMUMPS_176( COMM_LOAD, ASS_IRECV, 368 & root, FRERE, IROOT, 369 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 370 & IWPOS, IWPOSCB, IPTRLU, 371 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 372 & PTLUST_S, PTRFAC, 373 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 374 & IFLAG, IERROR, COMM, 375 & NBPROCFILS, 376 & IPOOL, LPOOL, LEAF, 377 & NBFIN, MYID, SLAVEF, 378 & 379 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 380 & FILS, PTRARW, PTRAIW, 381 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, 382 & LPTRAR, NELT, FRTPTR, FRTELT, 383 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 384 USE DMUMPS_COMM_BUFFER 385 IMPLICIT NONE 386 INCLUDE 'dmumps_root.h' 387 TYPE (DMUMPS_ROOT_STRUC) :: root 388 INTEGER IROOT 389 INTEGER ICNTL( 40 ), KEEP( 500 ) 390 INTEGER(8) KEEP8(150) 391 INTEGER COMM_LOAD, ASS_IRECV 392 INTEGER LBUFR, LBUFR_BYTES 393 INTEGER BUFR( LBUFR ) 394 INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS 395 INTEGER IWPOS, IWPOSCB 396 INTEGER(8) :: LA 397 INTEGER N, LIW 398 INTEGER IW( LIW ) 399 DOUBLE PRECISION A( LA ) 400 INTEGER(8) :: PTRAST(KEEP(28)) 401 INTEGER(8) :: PTRFAC(KEEP(28)) 402 INTEGER(8) :: PAMASTER(KEEP(28)) 403 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) 404 INTEGER STEP(N), PIMASTER(KEEP(28)) 405 INTEGER COMP 406 INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) 407 INTEGER NBPROCFILS( KEEP(28) ) 408 INTEGER IFLAG, IERROR, COMM 409 INTEGER LPTRAR, NELT 410 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 411 INTEGER LPOOL, LEAF 412 INTEGER IPOOL( LPOOL ) 413 INTEGER MYID, SLAVEF, NBFIN 414 INTEGER ISTEP_TO_INIV2(KEEP(71)), 415 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 416 DOUBLE PRECISION OPASSW, OPELIW 417 INTEGER ITLOC( N+KEEP(253) ), FILS( N ) 418 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 419 INTEGER PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 420 INTEGER ND(KEEP(28)), FRERE(KEEP(28)) 421 INTEGER INTARR( max(1,KEEP(14)) ) 422 DOUBLE PRECISION DBLARR( max(1,KEEP(13)) ) 423 INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, 424 & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, 425 & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, 426 & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, 427 & IROW_SON, ICOL_SON, ISLAVE, IERR, 428 & NELIM_SENT, IPOS_STATREC 429 INTEGER MUMPS_275 430 EXTERNAL MUMPS_275 431 INCLUDE 'mumps_headers.h' 432 INCLUDE 'mumps_tags.h' 433 NB_CONTRI_GLOBAL = KEEP(41) 434 NUMORG = root%ROOT_SIZE 435 NELIM = KEEP(42) 436 NFRONT = NUMORG + KEEP(42) 437 DO IROW = 0, root%NPROW - 1 438 DO JCOL = 0, root%NPCOL - 1 439 PDEST = IROW * root%NPCOL + JCOL 440 IF ( PDEST .NE. MYID ) THEN 441 CALL DMUMPS_73(NFRONT, 442 & NB_CONTRI_GLOBAL, PDEST, COMM, IERR) 443 if (IERR.lt.0) then 444 write(6,*) ' error detected by ', 445 & 'DMUMPS_73' 446 CALL MUMPS_ABORT() 447 endif 448 ENDIF 449 END DO 450 END DO 451 CALL DMUMPS_270( NFRONT, 452 & NB_CONTRI_GLOBAL, root, 453 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 454 & IWPOS, IWPOSCB, IPTRLU, 455 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 456 & PTLUST_S, PTRFAC, 457 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 458 & IFLAG, IERROR, COMM, COMM_LOAD, 459 & NBPROCFILS, 460 & IPOOL, LPOOL, LEAF, 461 & NBFIN, MYID, SLAVEF, 462 & 463 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 464 & FILS, PTRARW, PTRAIW, 465 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND ) 466 IF (IFLAG < 0 ) RETURN 467 HF = 6 + KEEP(IXSZ) 468 IOLDPS = PTLUST_S(STEP(IROOT)) 469 IN = IROOT 470 DEB_ROW = IOLDPS + HF 471 ILOC_ROW = DEB_ROW 472 DO WHILE (IN.GT.0) 473 IW(ILOC_ROW) = IN 474 IW(ILOC_ROW+NFRONT) = IN 475 ILOC_ROW = ILOC_ROW + 1 476 IN = FILS(IN) 477 END DO 478 IFSON = -IN 479 ILOC_ROW = IOLDPS + HF + NUMORG 480 ILOC_COL = ILOC_ROW + NFRONT 481 IF ( NELIM.GT.0 ) THEN 482 IN = IFSON 483 DO WHILE (IN.GT.0) 484 IPOS_SON = PIMASTER(STEP(IN)) 485 IF (IPOS_SON .EQ. 0) GOTO 100 486 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) 487 if (NELIM_SON.eq.0) then 488 write(6,*) ' error 1 in process_last_rtnelind' 489 CALL MUMPS_ABORT() 490 endif 491 NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) 492 HS = 6 + NSLAVES_SON + KEEP(IXSZ) 493 IROW_SON = IPOS_SON + HS 494 ICOL_SON = IROW_SON + NELIM_SON 495 DO I = 1, NELIM_SON 496 IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) 497 ENDDO 498 DO I = 1, NELIM_SON 499 IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) 500 ENDDO 501 NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 502 DO ISLAVE = 0,NSLAVES_SON 503 IF (ISLAVE.EQ.0) THEN 504 PDEST= MUMPS_275(PROCNODE_STEPS(STEP(IN)),SLAVEF) 505 ELSE 506 PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) 507 ENDIF 508 IF (PDEST.NE.MYID) THEN 509 CALL DMUMPS_74(IN, NELIM_SENT, 510 & PDEST, COMM, IERR ) 511 if (IERR.lt.0) then 512 write(6,*) ' error detected by ', 513 & 'DMUMPS_73' 514 CALL MUMPS_ABORT() 515 endif 516 ELSE 517 CALL DMUMPS_271( COMM_LOAD, ASS_IRECV, 518 & IN, NELIM_SENT, root, 519 & 520 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 521 & IWPOS, IWPOSCB, IPTRLU, 522 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 523 & PTLUST_S, PTRFAC, 524 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 525 & IFLAG, IERROR, COMM, 526 & NBPROCFILS, 527 & IPOOL, LPOOL, LEAF, 528 & NBFIN, MYID, SLAVEF, 529 & 530 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 531 & FILS, PTRARW, PTRAIW, 532 & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, 533 & LPTRAR, NELT, FRTPTR, FRTELT, 534 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 535 IF ( ISLAVE .NE. 0 ) THEN 536 IF (KEEP(50) .EQ. 0) THEN 537 IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) 538 ELSE 539 IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) 540 ENDIF 541 IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN 542 IW(IPOS_STATREC) = S_ROOT2SON_CALLED 543 ELSE 544 CALL DMUMPS_626( N, IN, PTRIST, PTRAST, 545 & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, 546 & IPTRLU, STEP, MYID, KEEP 547 & ) 548 ENDIF 549 ENDIF 550 IPOS_SON = PIMASTER(STEP(IN)) 551 ENDIF 552 END DO 553 CALL DMUMPS_152( .FALSE.,MYID,N, IPOS_SON, 554 & PTRAST(STEP(IN)), 555 & IW, LIW, 556 & LRLU, LRLUS, IPTRLU, 557 & IWPOSCB, LA, KEEP,KEEP8, .FALSE. 558 & ) 559 ILOC_ROW = ILOC_ROW + NELIM_SON 560 ILOC_COL = ILOC_COL + NELIM_SON 561 100 CONTINUE 562 IN = FRERE(STEP(IN)) 563 ENDDO 564 ENDIF 565 RETURN 566 END SUBROUTINE DMUMPS_176 567 SUBROUTINE DMUMPS_268(MYID,BUFR, LBUFR, 568 & LBUFR_BYTES, 569 & PROCNODE_STEPS, SLAVEF, 570 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, 571 & N, IW, LIW, A, LA, 572 & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, 573 & COMP, 574 & IFLAG, IERROR, COMM, COMM_LOAD, NBPROCFILS, 575 & IPOOL, LPOOL, LEAF, KEEP,KEEP8, ND, FILS, FRERE, 576 & ITLOC, RHS_MUMPS, 577 & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) 578 USE DMUMPS_LOAD 579 IMPLICIT NONE 580 INCLUDE 'mpif.h' 581 INTEGER IERR 582 INTEGER MYID 583 INTEGER KEEP(500) 584 INTEGER(8) KEEP8(150) 585 INTEGER LBUFR, LBUFR_BYTES 586 INTEGER BUFR( LBUFR ) 587 INTEGER SLAVEF 588 INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA 589 INTEGER IWPOS, IWPOSCB 590 INTEGER N, LIW 591 INTEGER IW( LIW ) 592 DOUBLE PRECISION A( LA ) 593 INTEGER(8) :: PTRAST(KEEP(28)) 594 INTEGER(8) :: PAMASTER(KEEP(28)) 595 INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) 596 INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) 597 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 598 INTEGER COMP 599 INTEGER NSTK_S( KEEP(28) ) 600 INTEGER NBPROCFILS( KEEP(28) ) 601 INTEGER IFLAG, IERROR, COMM, COMM_LOAD 602 INTEGER LPOOL, LEAF 603 INTEGER IPOOL( LPOOL ) 604 INTEGER ND(KEEP(28)), FILS( N ), FRERE( KEEP(28) ) 605 INTEGER ISTEP_TO_INIV2(KEEP(71)), 606 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 607 INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, 608 & NSLAVES 609 INTEGER(8) :: NOREAL 610 INTEGER NOINT, INIV2, NCOL_EFF 611 DOUBLE PRECISION FLOP1 612 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET 613 INTEGER NOREAL_PACKET 614 LOGICAL PERETYPE2 615 INCLUDE 'mumps_headers.h' 616 INTEGER MUMPS_330 617 EXTERNAL MUMPS_330 618 POSITION = 0 619 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 620 & IFATH, 1, MPI_INTEGER 621 & , COMM, IERR) 622 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 623 & ISON , 1, MPI_INTEGER, 624 & COMM, IERR) 625 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 626 & NSLAVES, 1, 627 & MPI_INTEGER, COMM, IERR ) 628 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 629 & NROW , 1, MPI_INTEGER 630 & , COMM, IERR) 631 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 632 & NCOL , 1, MPI_INTEGER 633 & , COMM, IERR) 634 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 635 & NBROWS_ALREADY_SENT, 1, 636 & MPI_INTEGER, COMM, IERR) 637 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 638 & NBROWS_PACKET, 1, 639 & MPI_INTEGER, COMM, IERR) 640 IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN 641 NCOL_EFF = NROW 642 ELSE 643 NCOL_EFF = NCOL 644 ENDIF 645 NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF 646 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN 647 NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) 648 NOREAL= int(NROW,8) * int(NCOL_EFF,8) 649 CALL DMUMPS_22(.FALSE.,0_8,.FALSE.,.FALSE., 650 & MYID,N,KEEP,KEEP8,IW,LIW,A,LA, 651 & LRLU, IPTRLU,IWPOS,IWPOSCB, 652 & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, 653 & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., 654 & COMP, LRLUS, IFLAG, IERROR 655 & ) 656 IF ( IFLAG .LT. 0 ) THEN 657 RETURN 658 ENDIF 659 PIMASTER(STEP( ISON )) = IWPOSCB + 1 660 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 661 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL 662 NELIM = NROW 663 IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM 664 IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW 665 IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN 666 IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL 667 IF ( NROW - NCOL .GE. 0 ) THEN 668 WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL 669 CALL MUMPS_ABORT() 670 END IF 671 ELSE 672 IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 673 END IF 674 IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 675 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES 676 IF (NSLAVES.GT.0) THEN 677 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 678 & IW( IWPOSCB + 7 + KEEP(IXSZ) ), 679 & NSLAVES, MPI_INTEGER, COMM, IERR ) 680 ENDIF 681 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 682 & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), 683 & NROW, MPI_INTEGER, COMM, IERR) 684 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 685 & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), 686 & NCOL, MPI_INTEGER, COMM, IERR) 687 IF ( ( KEEP(48).NE. 0 ).AND.(NSLAVES .GT. 0 )) THEN 688 INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) 689 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 690 & TAB_POS_IN_PERE(1,INIV2), 691 & NSLAVES+1, MPI_INTEGER, COMM, IERR) 692 TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES 693 ENDIF 694 ENDIF 695 IF (NOREAL_PACKET.GT.0) THEN 696 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 697 & A(PAMASTER(STEP(ISON)) + 698 & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8)), 699 & NOREAL_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR) 700 ENDIF 701 IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN 702 PERETYPE2 = ( MUMPS_330(PROCNODE_STEPS(STEP(IFATH)), 703 & SLAVEF) .EQ. 2 ) 704 NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 705 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN 706 CALL DMUMPS_507(N, IPOOL, LPOOL, PROCNODE_STEPS, 707 & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), 708 & STEP, IFATH ) 709 IF (KEEP(47) .GE. 3) THEN 710 CALL DMUMPS_500( 711 & IPOOL, LPOOL, 712 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 713 & MYID, STEP, N, ND, FILS ) 714 ENDIF 715 CALL MUMPS_137( IFATH, N, PROCNODE_STEPS, 716 & SLAVEF, ND, 717 & FILS,FRERE, STEP, PIMASTER, 718 & KEEP(28), KEEP(50), KEEP(253), 719 & FLOP1,IW, LIW, KEEP(IXSZ) ) 720 IF (IFATH.NE.KEEP(20)) 721 & CALL DMUMPS_190(1, .FALSE., FLOP1, KEEP,KEEP8) 722 END IF 723 ENDIF 724 RETURN 725 END SUBROUTINE DMUMPS_268 726 SUBROUTINE DMUMPS_242(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, 727 &SLAVEF) 728 USE DMUMPS_COMM_BUFFER 729 IMPLICIT NONE 730 INCLUDE 'mpif.h' 731 INTEGER IERR 732 INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF 733 INTEGER DEST 734 INTEGER DATA(LDATA) 735 DO 10 DEST = 0, SLAVEF - 1 736 IF (DEST .NE. ROOT) THEN 737 IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN 738 CALL DMUMPS_62( DATA(1), DEST, TAG, 739 & COMMW, IERR ) 740 ELSE 741 WRITE(*,*) 'Error : bad argument to DMUMPS_242' 742 CALL MUMPS_ABORT() 743 END IF 744 ENDIF 745 10 CONTINUE 746 RETURN 747 END SUBROUTINE DMUMPS_242 748 SUBROUTINE DMUMPS_44( MYID, SLAVEF, COMM ) 749 INTEGER MYID, SLAVEF, COMM 750 INCLUDE 'mpif.h' 751 INCLUDE 'mumps_tags.h' 752 INTEGER DUMMY (1) 753 CALL DMUMPS_242( DUMMY, 1, MPI_INTEGER, MYID, 754 & COMM, TERREUR, SLAVEF ) 755 RETURN 756 END SUBROUTINE DMUMPS_44 757 SUBROUTINE DMUMPS_464( K34, K35, K16, K10 ) 758 IMPLICIT NONE 759 INTEGER, INTENT(OUT) :: K34, K35, K10, K16 760 INTEGER SIZE_INT, SIZE_REAL_OR_DOUBLE 761 INTEGER I(2) 762 DOUBLE PRECISION R(2) 763 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) 764 CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) 765 K34 = int(SIZE_INT) 766 K10 = 8 / K34 767 K16 = int(SIZE_REAL_OR_DOUBLE) 768 K35 = K16 769 RETURN 770 END SUBROUTINE DMUMPS_464 771 SUBROUTINE DMUMPS_20( NSLAVES, LWK_USER, CNTL, ICNTL, 772 & KEEP,KEEP8, 773 & INFO, INFOG, RINFO, RINFOG, SYM, PAR, 774 & DKEEP) 775 IMPLICIT NONE 776 DOUBLE PRECISION DKEEP(30) 777 DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40) 778 INTEGER ICNTL(40), KEEP(500), SYM, PAR, NSLAVES 779 INTEGER INFO(40), INFOG(40) 780 INTEGER(8) KEEP8(150) 781 INTEGER LWK_USER 782C Let $A_{preproc}$ be the preprocessed matrix to be factored (see 783 LWK_USER = 0 784 KEEP(1:500) = 0 785 KEEP8(1:150)= 0_8 786 INFO(1:40) = 0 787 INFOG(1:40) = 0 788 ICNTL(1:40) = 0 789 RINFO(1:40) = 0.0D0 790 RINFOG(1:40)= 0.0D0 791 CNTL(1:15) = 0.0D0 792 DKEEP(1:30) = 0.0D0 793 KEEP( 50 ) = SYM 794 IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 795 IF ( KEEP(50) .NE. 1 ) THEN 796 CNTL(1) = 0.01D0 797 ELSE 798 CNTL(1) = 0.0D0 799 END IF 800 CNTL(2) = sqrt(epsilon(0.0D0)) 801 CNTL(3) = 0.0D0 802 CNTL(4) = -1.0D0 803 CNTL(5) = 0.0D0 804 CNTL(6) = -1.0D0 805 KEEP(46) = PAR 806 IF ( KEEP(46) .NE. 0 .AND. 807 & KEEP(46) .NE. 1 ) THEN 808 KEEP(46) = 1 809 END IF 810 ICNTL(1) = 6 811 ICNTL(2) = 0 812 ICNTL(3) = 6 813 ICNTL(4) = 2 814 ICNTL(5) = 0 815 IF (SYM.NE.1) THEN 816 ICNTL(6) = 7 817 ELSE 818 ICNTL(6) = 0 819 ENDIF 820 ICNTL(7) = 7 821 ICNTL(8) = 77 822 ICNTL(9) = 1 823 ICNTL(10) = 0 824 ICNTL(11) = 0 825 IF(SYM .EQ. 2) THEN 826 ICNTL(12) = 0 827 ELSE 828 ICNTL(12) = 1 829 ENDIF 830 ICNTL(13) = 0 831 IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN 832 ICNTL(14) = 5 833 ELSE IF (NSLAVES .GT. 4) THEN 834 ICNTL(14) = 30 835 ELSE 836 ICNTL(14) = 20 837 END IF 838 ICNTL(15) = 0 839 ICNTL(16) = 0 840 ICNTL(17) = 0 841 ICNTL(18) = 0 842 ICNTL(19) = 0 843 ICNTL(20) = 0 844 ICNTL(21) = 0 845 ICNTL(22) = 0 846 ICNTL(23) = 0 847 ICNTL(24) = 0 848 ICNTL(27) = -8 849 ICNTL(28) = 1 850 ICNTL(29) = 0 851 ICNTL(39) = 1 852 ICNTL(40) = 0 853 KEEP(12) = 0 854 KEEP(11) = 2147483646 855 KEEP(24) = 18 856 KEEP(68) = 0 857 KEEP(36) = 1 858 KEEP(1) = 8 859 KEEP(7) = 150 860 KEEP(8) = 120 861 KEEP(57) = 500 862 KEEP(58) = 250 863 IF ( SYM .eq. 0 ) THEN 864 KEEP(4) = 32 865 KEEP(3) = 96 866 KEEP(5) = 16 867 KEEP(6) = 32 868 KEEP(9) = 700 869 KEEP(85) = 300 870 KEEP(62) = 50 871 IF (NSLAVES.GE.128) KEEP(62)=200 872 IF (NSLAVES.GE.128) KEEP(9)=800 873 IF (NSLAVES.GE.256) KEEP(9)=900 874 ELSE 875 KEEP(4) = 24 876 KEEP(3) = 96 877 KEEP(5) = 16 878 KEEP(6) = 48 879 KEEP(9) = 400 880 KEEP(85) = 100 881 KEEP(62) = 100 882 IF (NSLAVES.GE.128) KEEP(62)=150 883 IF (NSLAVES.GE.64) KEEP(9)=800 884 IF (NSLAVES.GE.128) KEEP(9)=900 885 END IF 886 KEEP(63) = 60 887 KEEP(48) = 5 888 KEEP(17) = 0 889 CALL DMUMPS_464( KEEP(34), KEEP(35), 890 & KEEP(16), KEEP(10) ) 891#if defined(SP_) 892 KEEP( 51 ) = 70 893#else 894 KEEP( 51 ) = 48 895#endif 896 KEEP(37) = max(800, int(sqrt(dble(NSLAVES+1))*dble(KEEP(51)))) 897 IF ( NSLAVES > 256 ) THEN 898 KEEP(39) = 10000 899 ELSEIF ( NSLAVES > 128 ) THEN 900 KEEP(39) = 20000 901 ELSEIF ( NSLAVES > 64 ) THEN 902 KEEP(39) = 40000 903 ELSEIF ( NSLAVES > 16 ) THEN 904 KEEP(39) = 80000 905 ELSE 906 KEEP(39) = 160000 907 END IF 908 KEEP(40) = -1 - 456789 909 KEEP(45) = 0 910 KEEP(47) = 2 911 KEEP(64) = 10 912 KEEP(69) = 4 913 KEEP(75) = 1 914 KEEP(76) = 2 915 KEEP(77) = 30 916 KEEP(79) = 0 917 IF (NSLAVES.GT.4) THEN 918 KEEP(78)=max( 919 & int(log(dble(NSLAVES))/log(dble(2))) - 2 920 & , 0 ) 921 ENDIF 922 KEEP(210) = 2 923 KEEP8(79) = -10_8 924 KEEP(80) = 1 925 KEEP(81) = 0 926 KEEP(82) = 5 927 KEEP(83) = min(8,NSLAVES/4) 928 KEEP(83) = max(min(4,NSLAVES),max(KEEP(83),1)) 929 KEEP(86)=1 930 KEEP(87)=0 931 KEEP(88)=0 932 KEEP(90)=1 933 KEEP(91)=min(8, NSLAVES) 934 KEEP(91) = max(min(4,NSLAVES),min(KEEP(83),KEEP(91))) 935 IF(NSLAVES.LT.48)THEN 936 KEEP(102)=150 937 ELSEIF(NSLAVES.LT.128)THEN 938 KEEP(102)=150 939 ELSEIF(NSLAVES.LT.256)THEN 940 KEEP(102)=200 941 ELSEIF(NSLAVES.LT.512)THEN 942 KEEP(102)=300 943 ELSEIF(NSLAVES.GE.512)THEN 944 KEEP(102)=400 945 ENDIF 946#if defined(OLD_OOC_NOPANEL) 947 KEEP(99)=0 948#else 949 KEEP(99)=4 950#endif 951 KEEP(100)=0 952 KEEP(204)=0 953 KEEP(205)=0 954 KEEP(209)=-1 955 KEEP(104) = 16 956 KEEP(107)=0 957 KEEP(211)=2 958 IF (NSLAVES .EQ. 2) THEN 959 KEEP(213) = 101 960 ELSE 961 KEEP(213) = 201 962 ENDIF 963 KEEP(217)=0 964 KEEP(215)=0 965 KEEP(216)=1 966 KEEP(218)=50 967 KEEP(219)=1 968 IF (KEEP(50).EQ.2) THEN 969 KEEP(227)= max(2,32) 970 ELSE 971 KEEP(227)= max(1,32) 972 ENDIF 973 KEEP(231) = 1 974 KEEP(232) = 3 975 KEEP(233) = 0 976 KEEP(239) = 1 977 KEEP(240) = 10 978 DKEEP(4) = -1.0D0 979 DKEEP(5) = -1.0D0 980 IF(NSLAVES.LE.8)THEN 981 KEEP(238)=12 982 ELSE 983 KEEP(238)=7 984 ENDIF 985 KEEP(234)= 1 986 DKEEP(3)=-5.0D0 987 KEEP(242) = 1 988 KEEP(250) = 1 989 RETURN 990 END SUBROUTINE DMUMPS_20 991 SUBROUTINE DMUMPS_786(id, LP) 992 USE DMUMPS_STRUC_DEF 993 IMPLICIT NONE 994 TYPE (DMUMPS_STRUC) :: id 995 INTEGER LP 996 IF (id%KEEP(72)==1) THEN 997 IF (LP.GT.0) 998 & write(LP,*) 'Warning KEEP(72) = 1 !!!!!!!!!! ' 999 id%KEEP(37) = 2*id%NSLAVES 1000 id%KEEP(3)=3 1001 id%KEEP(4)=2 1002 id%KEEP(5)=1 1003 id%KEEP(6)=2 1004 id%KEEP(9)=3 1005 id%KEEP(39)=300 1006 id%CNTL(1)=0.1D0 1007 id%KEEP(213) = 101 1008 id%KEEP(85)=2 1009 id%KEEP(85)=-4 1010 id%KEEP(62) = 2 1011 id%KEEP(1) = 1 1012 id%KEEP(51) = 2 1013 ELSE IF (id%KEEP(72)==2) THEN 1014 IF (LP.GT.0) 1015 & write(LP,*)' OOC setting to reduce stack memory', 1016 & ' KEEP(72)=', id%KEEP(72) 1017 id%KEEP(85)=2 1018 id%KEEP(85)=-10000 1019 id%KEEP(62) = 10 1020 id%KEEP(210) = 1 1021 id%KEEP8(79) = 160000_8 1022 id%KEEP(1) = 2 1023 id%KEEP(102) = 110 1024 id%KEEP(213) = 121 1025 END IF 1026 RETURN 1027 END SUBROUTINE DMUMPS_786 1028 SUBROUTINE DMUMPS_195(N, NZ, IRN, ICN, LIW, IKEEP, PTRAR, 1029 & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, 1030 & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id) 1031 USE DMUMPS_STRUC_DEF 1032 IMPLICIT NONE 1033 INTEGER N,NZ,LIW,IORD,SIZE_SCHUR, NSLAVES 1034 INTEGER PTRAR(N,4), NFSIZ(N), FILS(N), FRERE(N) 1035 INTEGER IKEEP(N,3) 1036 INTEGER LISTVAR_SCHUR(SIZE_SCHUR) 1037 INTEGER INFO(40), ICNTL(40), KEEP(500) 1038 INTEGER(8) KEEP8(150) 1039 TYPE (DMUMPS_STRUC) :: id 1040 INTEGER IRN(NZ), ICN(NZ) 1041 INTEGER, DIMENSION(:), ALLOCATABLE :: IW 1042 INTEGER IERR 1043 INTEGER K,I,L1,L2,IWFR,NCMPA,LLIW, IN, IFSON 1044 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry 1045 INTEGER MedDens, NBQD, AvgDens 1046 LOGICAL PROK, COMPRESS_SCHUR 1047 INTEGER NBBUCK 1048 INTEGER, DIMENSION(:), ALLOCATABLE :: HEAD 1049 INTEGER NUMFLAG 1050 INTEGER OPT_METIS_SIZE 1051 INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS 1052 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP 1053 INTEGER THRESH, IVersion 1054 LOGICAL AGG6 1055 INTEGER MINSYM 1056 PARAMETER (MINSYM=50) 1057 INTEGER(8) :: K79REF 1058 PARAMETER(K79REF=12000000_8) 1059 INTEGER PIV(N) 1060 INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST 1061 INTEGER TOTEL 1062 LOGICAL IDENT,SPLITROOT 1063 EXTERNAL MUMPS_197, DMUMPS_198, 1064 & DMUMPS_199, DMUMPS_351, 1065 & DMUMPS_557, DMUMPS_201 1066#if defined(OLDDFS) 1067 EXTERNAL DMUMPS_200 1068#endif 1069 EXTERNAL DMUMPS_623 1070 EXTERNAL DMUMPS_547, DMUMPS_550, 1071 & DMUMPS_556 1072 ALLOCATE( IW ( LIW ), stat = IERR ) 1073 IF ( IERR .GT. 0 ) THEN 1074 INFO( 1 ) = -7 1075 INFO( 2 ) = LIW 1076 RETURN 1077 ENDIF 1078 LLIW = LIW - 2*N - 1 1079 L1 = LLIW + 1 1080 L2 = L1 + N 1081 LP = ICNTL(1) 1082 MP = ICNTL(3) 1083 PROK = (MP.GT.0) 1084 LDIAG = ICNTL(4) 1085 COMPRESS_SCHUR = .FALSE. 1086 IF (KEEP(1).LT.0) KEEP(1) = 0 1087 NEMIN = KEEP(1) 1088 IF (LDIAG.GT.2 .AND. MP.GT.0) THEN 1089 WRITE (MP,99999) N, NZ, LIW, INFO(1) 1090 K = min0(10,NZ) 1091 IF (LDIAG.EQ.4) K = NZ 1092 IF (K.GT.0) WRITE (MP,99998) (IRN(I),ICN(I),I=1,K) 1093 K = min0(10,N) 1094 IF (LDIAG.EQ.4) K = N 1095 IF (IORD.EQ.1 .AND. K.GT.0) THEN 1096 WRITE (MP,99997) (IKEEP(I,1),I=1,K) 1097 ENDIF 1098 ENDIF 1099 NCMP = N 1100 IF (KEEP(60).NE.0) THEN 1101 IF ((SIZE_SCHUR.LE.0 ).OR. 1102 & (SIZE_SCHUR.GE.N) ) GOTO 90 1103 ENDIF 1104#if defined(metis) || defined(parmetis) 1105 IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) 1106 & .AND. 1107 & ((IORD.EQ.7).OR.(IORD.EQ.5)) 1108 & )THEN 1109 COMPRESS_SCHUR=.TRUE. 1110 NCMP = N-SIZE_SCHUR 1111 CALL DMUMPS_623(N,NCMP,NZ,IRN, ICN, IW(1), LLIW, 1112 & IW(L2), PTRAR(1,2), 1113 & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), 1114 & INFO(1), INFO(2), ICNTL, symmetry, 1115 & KEEP(50), MedDens, NBQD, AvgDens, 1116 & LISTVAR_SCHUR, SIZE_SCHUR, 1117 & FRERE,FILS) 1118 IORD = 5 1119 KEEP(95) = 1 1120 NBQD = 0 1121 ELSE 1122#endif 1123 CALL DMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, 1124 & IW(L2), PTRAR(1,2), 1125 & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), 1126 & INFO(1), INFO(2), ICNTL, symmetry, 1127 & KEEP(50), MedDens, NBQD, AvgDens) 1128#if defined(metis) || defined(parmetis) 1129 ENDIF 1130#endif 1131 INFO(8) = symmetry 1132 IF(NBQD .GT. 0) THEN 1133 IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .LE. 1 ) THEN 1134 IF(KEEP(95) .NE. 1) THEN 1135 IF ( PROK ) 1136 & WRITE( MP,*) 1137 & 'Compressed/constrained ordering set OFF' 1138 KEEP(95) = 1 1139 ENDIF 1140 ENDIF 1141 ENDIF 1142 IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. 1143 & .NOT. COMPRESS_SCHUR ) THEN 1144 IORD = 0 1145 ENDIF 1146 IF ( (KEEP(50).EQ.2) 1147 & .AND. (KEEP(95) .EQ. 3) 1148 & .AND. (IORD .EQ. 7) ) THEN 1149 IORD = 0 1150 ENDIF 1151 CALL DMUMPS_701( N, KEEP(50), NSLAVES, IORD, 1152 & symmetry, MedDens, NBQD, AvgDens, 1153 & PROK, MP ) 1154 IF(KEEP(50) .EQ. 2) THEN 1155 IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN 1156 IF (PROK) WRITE(MP,*) 1157 & 'WARNING: DMUMPS_195 constrained ordering not '// 1158 & ' available with selected ordering. Move to' // 1159 & ' compressed ordering.' 1160 KEEP(95) = 2 1161 ENDIF 1162 IF(KEEP(95) .EQ. 2 .AND. IORD .EQ. 0) THEN 1163 IF (PROK) WRITE(MP,*) 1164 & 'WARNING: DMUMPS_195 AMD not available with ', 1165#if defined(metis) || defined(parmetis) 1166 & 'compressed ordering -> move to METIS' 1167 IORD = 5 1168#else 1169 & 'compressed ordering -> move to AMF' 1170 IORD = 2 1171#endif 1172 ENDIF 1173 ELSE 1174 KEEP(95) = 1 1175 ENDIF 1176 MTRANS = KEEP(23) 1177 COMPRESS = KEEP(95) - 1 1178 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN 1179 IF(id%CNTL(4) .GE. 0.0D0) THEN 1180 IF (KEEP(1).LE.8) THEN 1181 NEMIN = 16 1182 ELSE 1183 NEMIN = 2*KEEP(1) 1184 ENDIF 1185 IF (PROK) 1186 & WRITE(MP,*) 'Setting static pivoting ON, COMPRESS =', 1187 & COMPRESS 1188 ENDIF 1189 ENDIF 1190 IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN 1191 KEEP(23) = 0 1192 ENDIF 1193 IF(COMPRESS .EQ. 2) THEN 1194 IF (IORD.NE.2) THEN 1195 WRITE(*,*) "IORD not compatible with COMPRESS:", 1196 & IORD, COMPRESS 1197 CALL MUMPS_ABORT() 1198 ENDIF 1199 CALL DMUMPS_556( 1200 & N,PIV,FRERE,FILS,NFSIZ,IKEEP, 1201 & NCST,KEEP,KEEP8,id) 1202 ENDIF 1203 IF ( IORD .NE. 1 ) THEN 1204 IF(COMPRESS .GE. 1) THEN 1205 CALL DMUMPS_547( 1206 & N,NZ, IRN, ICN, PIV, 1207 & NCMP, IW(1), LLIW, IW(L2),PTRAR(1,2),PTRAR, 1208 & IW(L1), FILS, IWFR, 1209 & IERROR, KEEP,KEEP8, ICNTL) 1210 symmetry = 100 1211 ENDIF 1212 IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN 1213 IF(KEEP(23) .EQ. 7 ) THEN 1214 KEEP(23) = -5 1215 DEALLOCATE (IW) 1216 RETURN 1217 ELSE IF(KEEP(23) .EQ. -9876543) THEN 1218 IDENT = .TRUE. 1219 KEEP(23) = 5 1220 IF (PROK) WRITE(MP,'(A)') 1221 & ' ... Apply column permutation (already computed)' 1222 DO J=1,N 1223 JPERM = PIV(J) 1224 FILS(JPERM) = J 1225 IF (JPERM.NE.J) IDENT = .FALSE. 1226 ENDDO 1227 IF (.NOT.IDENT) THEN 1228 DO K=1,NZ 1229 J = ICN(K) 1230 IF ((J.LE.0).OR.(J.GT.N)) CYCLE 1231 ICN(K) = FILS(J) 1232 ENDDO 1233 ALLOCATE(COLSCA_TEMP(N), stat=IERR) 1234 IF ( IERR > 0 ) THEN 1235 INFO( 1 ) = -7 1236 INFO( 2 ) = N 1237 RETURN 1238 ENDIF 1239 DO J = 1, N 1240 COLSCA_TEMP(J)=id%COLSCA(J) 1241 ENDDO 1242 DO J=1, N 1243 id%COLSCA(FILS(J))=COLSCA_TEMP(J) 1244 ENDDO 1245 DEALLOCATE(COLSCA_TEMP) 1246 IF (MP.GT.0 .AND. ICNTL(4).GE.2) 1247 & WRITE(MP,'(/A)') 1248 & ' WARNING input matrix data modified' 1249 CALL DMUMPS_351 1250 & (N,NZ,IRN, ICN, IW(1), LLIW, IW(L2), PTRAR(1,2), 1251 & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), 1252 & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), 1253 & MedDens, NBQD, AvgDens) 1254 INFO(8) = symmetry 1255 NCMP = N 1256 ELSE 1257 KEEP(23) = 0 1258 ENDIF 1259 ENDIF 1260 ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN 1261 IF (PROK) WRITE(MP,'(A)') 1262 & ' ... No column permutation' 1263 KEEP(23) = 0 1264 ENDIF 1265 ENDIF 1266 IF (IORD.NE.1 .AND. IORD.NE.5) THEN 1267 IF (PROK) THEN 1268 IF (IORD.EQ.2) THEN 1269 WRITE(MP,'(A)') ' Ordering based on AMF ' 1270#if defined(scotch) || defined(ptscotch) 1271 ELSE IF (IORD.EQ.3) THEN 1272 WRITE(MP,'(A)') ' Ordering based on SCOTCH ' 1273#endif 1274#if defined(pord) 1275 ELSE IF (IORD.EQ.4) THEN 1276 WRITE(MP,'(A)') ' Ordering based on PORD ' 1277#endif 1278 ELSE IF (IORD.EQ.6) THEN 1279 WRITE(MP,'(A)') ' Ordering based on QAMD ' 1280 ELSE 1281 WRITE(MP,'(A)') ' Ordering based on AMD ' 1282 ENDIF 1283 ENDIF 1284 IF ( KEEP(60) .NE. 0 ) THEN 1285 CALL MUMPS_162(N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), 1286 & IW(L1), IKEEP, 1287 & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), 1288 & LISTVAR_SCHUR, SIZE_SCHUR) 1289 IF (KEEP(60)==1) THEN 1290 KEEP(20) = LISTVAR_SCHUR(1) 1291 ELSE 1292 KEEP(38) = LISTVAR_SCHUR(1) 1293 ENDIF 1294 ELSE 1295 IF ( .FALSE. ) THEN 1296#if defined(pord) 1297 ELSEIF (IORD .EQ. 4) THEN 1298 IF(COMPRESS .EQ. 1) THEN 1299 DO I=L1,L1-1+KEEP(93)/2 1300 IW(I) = 2 1301 ENDDO 1302 DO I=L1+KEEP(93)/2,L1+NCMP-1 1303 IW(I) = 1 1304 ENDDO 1305 CALL MUMPS_PORDF_WND(NCMP, IWFR-1, IW(L2), IW, 1306 & IW(L1), NCMPA, N) 1307 CALL DMUMPS_548(NCMP,IW(L2),IW(L1),FILS) 1308 CALL DMUMPS_549(NCMP,IW(L2),IKEEP(1,1), 1309 & FRERE,PTRAR(1,1)) 1310 DO I=1,NCMP 1311 IKEEP(IKEEP(I,1),2)=I 1312 ENDDO 1313 ELSE 1314 CALL MUMPS_PORDF(NCMP, IWFR-1, IW(L2), IW(1), 1315 & IW(L1), NCMPA) 1316 ENDIF 1317 IF ( NCMPA .NE. 0 ) THEN 1318 write(6,*) ' Out PORD, NCMPA=', NCMPA 1319 INFO( 1 ) = -9999 1320 INFO( 2 ) = 4 1321 RETURN 1322 ENDIF 1323#endif 1324#if defined(scotch) || defined(ptscotch) 1325 ELSEIF (IORD .EQ. 3) THEN 1326 CALL MUMPS_SCOTCH(NCMP, LLIW, IW(L2), IWFR, 1327 & PTRAR(1,2), IW(1), IW(L1), IKEEP, 1328 & IKEEP(1,2), NCMPA) 1329 IF ( NCMPA .NE. 0 ) THEN 1330 write(6,*) ' Out SCTOCH, NCMPA=', NCMPA 1331 INFO( 1 ) = -9999 1332 INFO( 2 ) = 3 1333 RETURN 1334 ENDIF 1335 IF (COMPRESS .EQ. 1) THEN 1336 CALL DMUMPS_548(NCMP,IW(L2),IW(L1),FILS) 1337 CALL DMUMPS_549(NCMP,IW(L2),IKEEP(1,1), 1338 & FRERE,PTRAR(1,1)) 1339 DO I=1,NCMP 1340 IKEEP(IKEEP(I,1),2)=I 1341 ENDDO 1342 ENDIF 1343#endif 1344 ELSEIF (IORD .EQ. 2) THEN 1345 NBBUCK = 2*N 1346 ALLOCATE( HEAD ( 0: NBBUCK + 1), stat = IERR ) 1347 IF ( IERR .GT. 0 ) THEN 1348 INFO( 1 ) = -7 1349 INFO( 2 ) = NBBUCK+2 1350 RETURN 1351 ENDIF 1352 IF(COMPRESS .GE. 1) THEN 1353 DO I=L1,L1-1+KEEP(93)/2 1354 IW(I) = 2 1355 ENDDO 1356 DO I=L1+KEEP(93)/2,L1+NCMP-1 1357 IW(I) = 1 1358 ENDDO 1359 ELSE 1360 IW(L1) = -1 1361 ENDIF 1362 IF(COMPRESS .LE. 1) THEN 1363 CALL MUMPS_337(NCMP, NBBUCK, LLIW, IW(L2), 1364 & IWFR, PTRAR(1,2), 1365 & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, 1366 & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD) 1367 ELSE 1368 IF(PROK) WRITE(MP,'(A)') 1369 & ' Constrained Ordering based on AMF' 1370 CALL MUMPS_560(NCMP, NBBUCK, LLIW, IW(L2), 1371 & IWFR, PTRAR(1,2), 1372 & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, 1373 & IKEEP(1,3), PTRAR, PTRAR(1,3), HEAD, 1374 & NFSIZ, FRERE) 1375 ENDIF 1376 DEALLOCATE(HEAD) 1377 ELSEIF (IORD .EQ. 6) THEN 1378 ALLOCATE( HEAD ( N ), stat = IERR ) 1379 IF ( IERR .GT. 0 ) THEN 1380 INFO( 1 ) = -7 1381 INFO( 2 ) = N 1382 RETURN 1383 ENDIF 1384 THRESH = 1 1385 IVersion = 2 1386 IF(COMPRESS .EQ. 1) THEN 1387 DO I=L1,L1-1+KEEP(93)/2 1388 IW(I) = 2 1389 ENDDO 1390 DO I=L1+KEEP(93)/2,L1+NCMP-1 1391 IW(I) = 1 1392 ENDDO 1393 TOTEL = KEEP(93)+KEEP(94) 1394 ELSE 1395 IW(L1) = -1 1396 TOTEL = N 1397 ENDIF 1398 CALL MUMPS_421(TOTEL,IVersion, THRESH, HEAD, 1399 & NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), IW(1), 1400 & IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, 1401 & IKEEP(1,3), PTRAR, PTRAR(1,3)) 1402 DEALLOCATE(HEAD) 1403 ELSE 1404 CALL MUMPS_197(NCMP, LLIW, IW(L2), IWFR, PTRAR(1,2), 1405 & IW(1), IW(L1), IKEEP, IKEEP(1,2), NCMPA, FILS, 1406 & IKEEP(1,3), PTRAR, PTRAR(1,3)) 1407 ENDIF 1408 ENDIF 1409 IF(COMPRESS .GE. 1) THEN 1410 CALL DMUMPS_550(N,NCMP,KEEP(94),KEEP(93), 1411 & PIV,IKEEP(1,1),IKEEP(1,2)) 1412 COMPRESS = -1 1413 ENDIF 1414 ENDIF 1415#if defined(metis) || defined(parmetis) 1416 IF (IORD.EQ.5) THEN 1417 IF (PROK) THEN 1418 WRITE(MP,'(A)') ' Ordering based on METIS ' 1419 ENDIF 1420 NUMFLAG = 1 1421 OPT_METIS_SIZE = 8 1422 ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR ) 1423 IF ( IERR .GT. 0 ) THEN 1424 INFO( 1 ) = -7 1425 INFO( 2 ) = OPT_METIS_SIZE 1426 RETURN 1427 ENDIF 1428 OPTIONS_METIS(1) = 0 1429 IF (COMPRESS .EQ. 1) THEN 1430 DO I=1,KEEP(93)/2 1431 FILS(I) = 2 1432 ENDDO 1433 DO I=KEEP(93)/2+1,NCMP 1434 FILS(I) = 1 1435 ENDDO 1436 CALL METIS_NODEWND(NCMP, IW(L2), IW(1),FILS, 1437 & NUMFLAG, OPTIONS_METIS, 1438 & IKEEP(1,2), IKEEP(1,1) ) 1439 ELSE 1440 CALL METIS_NODEND(NCMP, IW(L2), IW(1), NUMFLAG, 1441 & OPTIONS_METIS, 1442 & IKEEP(1,2), IKEEP(1,1) ) 1443 ENDIF 1444 DEALLOCATE (OPTIONS_METIS) 1445 IF ( COMPRESS_SCHUR ) THEN 1446 CALL DMUMPS_622( 1447 & N, NCMP, IKEEP(1,1),IKEEP(1,2), 1448 & LISTVAR_SCHUR, SIZE_SCHUR, FILS) 1449 COMPRESS = -1 1450 ENDIF 1451 IF (COMPRESS .EQ. 1) THEN 1452 CALL DMUMPS_550(N,NCMP,KEEP(94), 1453 & KEEP(93),PIV,IKEEP(1,1),IKEEP(1,2)) 1454 COMPRESS = -1 1455 ENDIF 1456 ENDIF 1457#endif 1458 IF (PROK) THEN 1459 IF (IORD.EQ.1) THEN 1460 WRITE(MP,'(A)') ' Ordering given is used' 1461 ENDIF 1462 ENDIF 1463 IF ((IORD.EQ.1) 1464 & ) THEN 1465 DO K=1,N 1466 PTRAR(K,1) = 0 1467 ENDDO 1468 DO K=1,N 1469 IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) 1470 & GO TO 40 1471 IF (PTRAR(IKEEP(K,1),1).EQ.1) THEN 1472 GOTO 40 1473 ELSE 1474 PTRAR(IKEEP(K,1),1) = 1 1475 ENDIF 1476 ENDDO 1477 ENDIF 1478 IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1) THEN 1479 IF (KEEP(106)==1) THEN 1480 IF ( COMPRESS .EQ. -1 ) THEN 1481 CALL DMUMPS_351(N,NZ,IRN, ICN, IW(1), LLIW, 1482 & IW(L2), PTRAR(1,2), 1483 & PTRAR, IW(L1), IWFR, KEEP(113), KEEP(114), 1484 & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), 1485 & MedDens, NBQD, AvgDens) 1486 INFO(8) = symmetry 1487 ENDIF 1488 COMPRESS = 0 1489 ALLOCATE( HEAD ( 2*N ), stat = IERR ) 1490 IF ( IERR .GT. 0 ) THEN 1491 INFO( 1 ) = -7 1492 INFO( 2 ) = 2*N 1493 RETURN 1494 ENDIF 1495 THRESH = -1 1496 IF (KEEP(60) == 0) THEN 1497 ITEMP = 0 1498 ELSE 1499 ITEMP = SIZE_SCHUR 1500 IF (KEEP(60)==1) THEN 1501 KEEP(20) = LISTVAR_SCHUR(1) 1502 ELSE 1503 KEEP(38) = LISTVAR_SCHUR(1) 1504 ENDIF 1505 ENDIF 1506 AGG6 =.TRUE. 1507 CALL MUMPS_422(THRESH, HEAD, 1508 & N, LLIW, IW(L2), IWFR, PTRAR(1,2), IW, 1509 & IW(L1), HEAD(N+1), 1510 & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3), 1511 & IKEEP(1,1), LISTVAR_SCHUR, ITEMP, AGG6) 1512 DEALLOCATE(HEAD) 1513 ELSE 1514 CALL DMUMPS_198(N, NZ, IRN, ICN, IKEEP, IW(1), 1515 & LLIW, IW(L2), 1516 & PTRAR(1,2), IW(L1), IWFR, 1517 & INFO(1),INFO(2), KEEP(11), MP) 1518 IF (KEEP(60) .EQ. 0) THEN 1519 ITEMP = 0 1520 CALL DMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, 1521 & IKEEP(1,2), IW(L1), 1522 & PTRAR, NCMPA, ITEMP) 1523 ELSE 1524 CALL DMUMPS_199(N, IW(L2), IW, LLIW, IWFR, IKEEP, 1525 & IKEEP(1,2), IW(L1), 1526 & PTRAR, NCMPA, SIZE_SCHUR) 1527 IF (KEEP(60) .EQ. 1) THEN 1528 KEEP(20) = LISTVAR_SCHUR(1) 1529 ELSE 1530 KEEP(38) = LISTVAR_SCHUR(1) 1531 ENDIF 1532 ENDIF 1533 ENDIF 1534 ENDIF 1535#if defined(OLDDFS) 1536 CALL DMUMPS_200 1537 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), 1538 & NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60)) 1539#else 1540 CALL DMUMPS_557 1541 & (N, IW(L2), IW(L1), IKEEP(1,1), IKEEP(1,2), IKEEP(1,3), 1542 & NFSIZ, PTRAR, INFO(6), FILS, FRERE, 1543 & PTRAR(1,3), NEMIN, PTRAR(1,4), KEEP(60), 1544 & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), 1545 & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1) 1546#endif 1547 IF (KEEP(60).NE.0) THEN 1548 IF (KEEP(60)==1) THEN 1549 IN = KEEP(20) 1550 ELSE 1551 IN = KEEP(38) 1552 ENDIF 1553 DO WHILE (IN.GT.0) 1554 IN = FILS (IN) 1555 END DO 1556 IFSON = -IN 1557 IF (KEEP(60)==1) THEN 1558 IN = KEEP(20) 1559 ELSE 1560 IN = KEEP(38) 1561 ENDIF 1562 DO I=2,SIZE_SCHUR 1563 FILS(IN) = LISTVAR_SCHUR (I) 1564 IN = FILS(IN) 1565 FRERE (IN) = N+1 1566 ENDDO 1567 FILS(IN) = -IFSON 1568 ENDIF 1569 CALL DMUMPS_201(IKEEP(1,2), 1570 & PTRAR(1,3), INFO(6), 1571 & INFO(5), KEEP(2), KEEP(50), 1572 & KEEP(101),KEEP(108),KEEP(5), 1573 & KEEP(6), KEEP(226), KEEP(253)) 1574 IF ( KEEP(53) .NE. 0 ) THEN 1575 CALL MUMPS_209( N, FRERE, FILS, NFSIZ, KEEP(20) ) 1576 END IF 1577 IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) 1578 & .OR. 1579 & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) 1580 & .OR. 1581 & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN 1582 CALL DMUMPS_510(KEEP8(21), KEEP(2), 1583 & KEEP(48), KEEP(50), NSLAVES) 1584 END IF 1585 IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) KEEP(210)=0 1586 IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) KEEP(210)=1 1587 IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) KEEP(210)=2 1588 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) 1589 IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN 1590 IF ( huge(KEEP8(79)) / K79REF + 1_8 .GE. int(NSLAVES,8) ) THEN 1591 KEEP8(79)=huge(KEEP8(79)) 1592 ELSE 1593 KEEP8(79)=K79REF * int(NSLAVES,8) 1594 ENDIF 1595 ENDIF 1596 IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. 1597 & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. 1598 & (KEEP(79).EQ.6) 1599 & ) THEN 1600 IF (KEEP(210).EQ.1) THEN 1601 SPLITROOT = .FALSE. 1602 IF ( KEEP(62).GE.1) THEN 1603 CALL DMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), 1604 & NSLAVES, KEEP,KEEP8, SPLITROOT, 1605 & MP, LDIAG,INFO(1),INFO(2)) 1606 IF (INFO(1).LT.0) RETURN 1607 ENDIF 1608 ENDIF 1609 ENDIF 1610 SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. 1611 & ICNTL(13).EQ.-1 ) 1612 & .AND. (KEEP(60).EQ.0) 1613 IF (SPLITROOT) THEN 1614 CALL DMUMPS_97(N, FRERE, FILS, NFSIZ,INFO(6), 1615 & NSLAVES, KEEP,KEEP8, SPLITROOT, 1616 & MP, LDIAG,INFO(1),INFO(2)) 1617 IF (INFO(1).LT.0) RETURN 1618 ENDIF 1619 IF (LDIAG.GT.2 .AND. MP.GT.0) THEN 1620 K = min0(10,N) 1621 IF (LDIAG.EQ.4) K = N 1622 IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) 1623 IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) 1624 IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) 1625 IF (K.GT.0) WRITE (MP,99986) (PTRAR(I,1),I=1,K) 1626 IF (K.GT.0) WRITE (MP,99985) (PTRAR(I,2),I=1,K) 1627 IF (K.GT.0) WRITE (MP,99984) (PTRAR(I,3),I=1,K) 1628 IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) 1629 IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) 1630 IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) 1631 ENDIF 1632 GO TO 90 1633 40 INFO(1) = -4 1634 INFO(2) = K 1635 IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) 1636 IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) 1637 GOTO 90 1638 90 CONTINUE 1639 DEALLOCATE(IW) 1640 RETURN 164199999 FORMAT (/'Entering analysis phase with ...'/ 1642 & ' N NZ LIW INFO(1)'/, 1643 & 9X, I8, I11, I12, I14) 164499998 FORMAT ('Matrix entries: IRN() ICN()'/ 1645 & (I12, I7, I12, I7, I12, I7)) 164699997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 164799996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 164899991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 164999990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 165099989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 165199988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 165299987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 165399986 FORMAT ('PTRAR(.,1)=', 10I6/(12X, 10I6)) 165499985 FORMAT ('PTRAR(.,2)=', 10I6/(12X, 10I6)) 165599984 FORMAT ('PTRAR(.,3)=', 10I6/(12X, 10I6)) 165699982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) 1657 END SUBROUTINE DMUMPS_195 1658 SUBROUTINE DMUMPS_199(N,IPE,IW, LW, IWFR, IPS, IPV, NV, FLAG, 1659 & NCMPA, SIZE_SCHUR) 1660 INTEGER N,LW,IWFR,NCMPA,SIZE_SCHUR 1661 INTEGER FLAG(N) 1662 INTEGER IPS(N), IPV(N) 1663 INTEGER IW(LW), NV(N), IPE(N) 1664 INTEGER I,J,ML,MS,ME,IP,MINJS,IE,KDUMMY,JP 1665 INTEGER LN,JP1,JS,LWFR,JP2,JE 1666 DO 10 I=1,N 1667 FLAG(I) = 0 1668 NV(I) = 0 1669 J = IPS(I) 1670 IPV(J) = I 1671 10 CONTINUE 1672 NCMPA = 0 1673 DO 100 ML=1,N-SIZE_SCHUR 1674 MS = IPV(ML) 1675 ME = MS 1676 FLAG(MS) = ME 1677 IP = IWFR 1678 MINJS = N 1679 IE = ME 1680 DO 70 KDUMMY=1,N 1681 JP = IPE(IE) 1682 LN = 0 1683 IF (JP.LE.0) GO TO 60 1684 LN = IW(JP) 1685 DO 50 JP1=1,LN 1686 JP = JP + 1 1687 JS = IW(JP) 1688 IF (FLAG(JS).EQ.ME) GO TO 50 1689 FLAG(JS) = ME 1690 IF (IWFR.LT.LW) GO TO 40 1691 IPE(IE) = JP 1692 IW(JP) = LN - JP1 1693 CALL DMUMPS_194(N, IPE, IW, IP-1, LWFR,NCMPA) 1694 JP2 = IWFR - 1 1695 IWFR = LWFR 1696 IF (IP.GT.JP2) GO TO 30 1697 DO 20 JP=IP,JP2 1698 IW(IWFR) = IW(JP) 1699 IWFR = IWFR + 1 1700 20 CONTINUE 1701 30 IP = LWFR 1702 JP = IPE(IE) 1703 40 IW(IWFR) = JS 1704 MINJS = min0(MINJS,IPS(JS)+0) 1705 IWFR = IWFR + 1 1706 50 CONTINUE 1707 60 IPE(IE) = -ME 1708 JE = NV(IE) 1709 NV(IE) = LN + 1 1710 IE = JE 1711 IF (IE.EQ.0) GO TO 80 1712 70 CONTINUE 1713 80 IF (IWFR.GT.IP) GO TO 90 1714 IPE(ME) = 0 1715 NV(ME) = 1 1716 GO TO 100 1717 90 MINJS = IPV(MINJS) 1718 NV(ME) = NV(MINJS) 1719 NV(MINJS) = ME 1720 IW(IWFR) = IW(IP) 1721 IW(IP) = IWFR - IP 1722 IPE(ME) = IP 1723 IWFR = IWFR + 1 1724 100 CONTINUE 1725 IF (SIZE_SCHUR == 0) RETURN 1726 DO ML = N-SIZE_SCHUR+1,N 1727 ME = IPV(ML) 1728 IE = ME 1729 DO KDUMMY=1,N 1730 JP = IPE(IE) 1731 LN = 0 1732 IF (JP.LE.0) GO TO 160 1733 LN = IW(JP) 1734 160 IPE(IE) = -IPV(N-SIZE_SCHUR+1) 1735 JE = NV(IE) 1736 NV(IE) = LN + 1 1737 IE = JE 1738 IF (IE.EQ.0) GO TO 190 1739 ENDDO 1740 190 NV(ME) = 0 1741 IPE(ME) = -IPV(N-SIZE_SCHUR+1) 1742 ENDDO 1743 ME = IPV(N-SIZE_SCHUR+1) 1744 IPE(ME) = 0 1745 NV(ME) = SIZE_SCHUR 1746 RETURN 1747 END SUBROUTINE DMUMPS_199 1748 SUBROUTINE DMUMPS_198(N, NZ, IRN, ICN, PERM, 1749 & IW, LW, IPE, IQ, FLAG, 1750 & IWFR, IFLAG, IERROR, IOVFLO, MP) 1751 INTEGER N,NZ,LW,IWFR,IFLAG,IERROR 1752 INTEGER PERM(N) 1753 INTEGER IQ(N) 1754 INTEGER IRN(NZ), ICN(NZ) 1755 INTEGER IPE(N), IW(LW), FLAG(N) 1756 INTEGER MP 1757 INTEGER IOVFLO 1758 INTEGER I,J,K,LBIG,L,ID,IN,LEN,JDUMMY,K1,K2 1759 IERROR = 0 1760 DO 10 I=1,N 1761 IQ(I) = 0 1762 10 CONTINUE 1763 DO 80 K=1,NZ 1764 I = IRN(K) 1765 J = ICN(K) 1766 IW(K) = -I 1767 IF (I.EQ.J) GOTO 40 1768 IF (I.GT.J) GOTO 30 1769 IF (I.GE.1 .AND. J.LE.N) GO TO 60 1770 GO TO 50 1771 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 1772 GO TO 50 1773 40 IW(K) = 0 1774 IF (I.GE.1 .AND. I.LE.N) GO TO 80 1775 50 IERROR = IERROR + 1 1776 IW(K) = 0 1777 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) 1778 IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J 1779 GO TO 80 1780 60 IF (PERM(J).GT.PERM(I)) GO TO 70 1781 IQ(J) = IQ(J) + 1 1782 GO TO 80 1783 70 IQ(I) = IQ(I) + 1 1784 80 CONTINUE 1785 IF (IERROR.GE.1) THEN 1786 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 1787 ENDIF 1788 IWFR = 1 1789 LBIG = 0 1790 DO 100 I=1,N 1791 L = IQ(I) 1792 LBIG = max0(L,LBIG) 1793 IWFR = IWFR + L 1794 IPE(I) = IWFR - 1 1795 100 CONTINUE 1796 DO 140 K=1,NZ 1797 I = -IW(K) 1798 IF (I.LE.0) GO TO 140 1799 L = K 1800 IW(K) = 0 1801 DO 130 ID=1,NZ 1802 J = ICN(L) 1803 IF (PERM(I).LT.PERM(J)) GO TO 110 1804 L = IPE(J) 1805 IPE(J) = L - 1 1806 IN = IW(L) 1807 IW(L) = I 1808 GO TO 120 1809 110 L = IPE(I) 1810 IPE(I) = L - 1 1811 IN = IW(L) 1812 IW(L) = J 1813 120 I = -IN 1814 IF (I.LE.0) GO TO 140 1815 130 CONTINUE 1816 140 CONTINUE 1817 K = IWFR - 1 1818 L = K + N 1819 IWFR = L + 1 1820 DO 170 I=1,N 1821 FLAG(I) = 0 1822 J = N + 1 - I 1823 LEN = IQ(J) 1824 IF (LEN.LE.0) GO TO 160 1825 DO 150 JDUMMY=1,LEN 1826 IW(L) = IW(K) 1827 K = K - 1 1828 L = L - 1 1829 150 CONTINUE 1830 160 IPE(J) = L 1831 L = L - 1 1832 170 CONTINUE 1833 IF (LBIG.GE.IOVFLO) GO TO 190 1834 DO 180 I=1,N 1835 K = IPE(I) 1836 IW(K) = IQ(I) 1837 IF (IQ(I).EQ.0) IPE(I) = 0 1838 180 CONTINUE 1839 GO TO 230 1840 190 IWFR = 1 1841 DO 220 I=1,N 1842 K1 = IPE(I) + 1 1843 K2 = IPE(I) + IQ(I) 1844 IF (K1.LE.K2) GO TO 200 1845 IPE(I) = 0 1846 GO TO 220 1847 200 IPE(I) = IWFR 1848 IWFR = IWFR + 1 1849 DO 210 K=K1,K2 1850 J = IW(K) 1851 IF (FLAG(J).EQ.I) GO TO 210 1852 IW(IWFR) = J 1853 IWFR = IWFR + 1 1854 FLAG(J) = I 1855 210 CONTINUE 1856 K = IPE(I) 1857 IW(K) = IWFR - K - 1 1858 220 CONTINUE 1859 230 RETURN 186099999 FORMAT (' *** WARNING MESSAGE FROM DMUMPS_198 ***' ) 186199998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, 1862 & ') IGNORED') 1863 END SUBROUTINE DMUMPS_198 1864 SUBROUTINE DMUMPS_194(N, IPE, IW, LW, IWFR,NCMPA) 1865 INTEGER N,LW,IWFR,NCMPA 1866 INTEGER IPE(N) 1867 INTEGER IW(LW) 1868 INTEGER I,K1,LWFR,IR,K,K2 1869 NCMPA = NCMPA + 1 1870 DO 10 I=1,N 1871 K1 = IPE(I) 1872 IF (K1.LE.0) GO TO 10 1873 IPE(I) = IW(K1) 1874 IW(K1) = -I 1875 10 CONTINUE 1876 IWFR = 1 1877 LWFR = IWFR 1878 DO 60 IR=1,N 1879 IF (LWFR.GT.LW) GO TO 70 1880 DO 20 K=LWFR,LW 1881 IF (IW(K).LT.0) GO TO 30 1882 20 CONTINUE 1883 GO TO 70 1884 30 I = -IW(K) 1885 IW(IWFR) = IPE(I) 1886 IPE(I) = IWFR 1887 K1 = K + 1 1888 K2 = K + IW(IWFR) 1889 IWFR = IWFR + 1 1890 IF (K1.GT.K2) GO TO 50 1891 DO 40 K=K1,K2 1892 IW(IWFR) = IW(K) 1893 IWFR = IWFR + 1 1894 40 CONTINUE 1895 50 LWFR = K2 + 1 1896 60 CONTINUE 1897 70 RETURN 1898 END SUBROUTINE DMUMPS_194 1899#if defined(OLDDFS) 1900 SUBROUTINE DMUMPS_200(N, IPE, NV, IPS, NE, NA, NFSIZ, 1901 & NSTEPS, 1902 & FILS, FRERE,NDD,NEMIN, KEEP60) 1903 INTEGER N,NSTEPS 1904 INTEGER NDD(N) 1905 INTEGER FILS(N), FRERE(N) 1906 INTEGER IPS(N), NE(N), NA(N), NFSIZ(N) 1907 INTEGER IPE(N), NV(N) 1908 INTEGER NEMIN, KEEP60 1909 INTEGER I,IF,IS,NR,NR1,INS,INL,INB,INF,INFS,INSW 1910 INTEGER K,L,ISON,IN,INP,IFSON,INC,INO 1911 INTEGER INOS,IB,IL 1912 DO 10 I=1,N 1913 IPS(I) = 0 1914 NE(I) = 0 1915 10 CONTINUE 1916 DO 20 I=1,N 1917 IF (NV(I).GT.0) GO TO 20 1918 IF = -IPE(I) 1919 IS = -IPS(IF) 1920 IF (IS.GT.0) IPE(I) = IS 1921 IPS(IF) = -I 1922 20 CONTINUE 1923 NR = N + 1 1924 DO 50 I=1,N 1925 IF (NV(I).LE.0) GO TO 50 1926 IF = -IPE(I) 1927 IF (IF.NE.0) THEN 1928 IS = -IPS(IF) 1929 IF (IS.GT.0) IPE(I) = IS 1930 IPS(IF) = -I 1931 ELSE 1932 NR = NR - 1 1933 NE(NR) = I 1934 ENDIF 1935 50 CONTINUE 1936 DO 999 I=1,N 1937 FILS(I) = IPS(I) 1938 999 CONTINUE 1939 NR1 = NR 1940 INS = 0 1941 1000 IF (NR1.GT.N) GO TO 1151 1942 INS = NE(NR1) 1943 NR1 = NR1 + 1 1944 1070 INL = FILS(INS) 1945 IF (INL.LT.0) THEN 1946 INS = -INL 1947 GO TO 1070 1948 ENDIF 1949 1080 IF (IPE(INS).LT.0) THEN 1950 INS = -IPE(INS) 1951 FILS(INS) = 0 1952 GO TO 1080 1953 ENDIF 1954 IF (IPE(INS).EQ.0) THEN 1955 INS = 0 1956 GO TO 1000 1957 ENDIF 1958 INB = IPE(INS) 1959 IF (NV(INB).EQ.0) THEN 1960 INS = INB 1961 GO TO 1070 1962 ENDIF 1963 IF (NV(INB).GE.NV(INS)) THEN 1964 INS = INB 1965 GO TO 1070 1966 ENDIF 1967 INF = INB 1968 1090 INF = IPE(INF) 1969 IF (INF.GT.0) GO TO 1090 1970 INF = -INF 1971 INFS = -FILS(INF) 1972 IF (INFS.EQ.INS) THEN 1973 FILS(INF) = -INB 1974 IPS(INF) = -INB 1975 IPE(INS) = IPE(INB) 1976 IPE(INB) = INS 1977 INS = INB 1978 GO TO 1070 1979 ENDIF 1980 INSW = INFS 1981 1100 INFS = IPE(INSW) 1982 IF (INFS.NE.INS) THEN 1983 INSW = INFS 1984 GO TO 1100 1985 ENDIF 1986 IPE(INS) = IPE(INB) 1987 IPE(INB) = INS 1988 IPE(INSW)= INB 1989 INS =INB 1990 GO TO 1070 1991 1151 CONTINUE 1992 DO 51 I=1,N 1993 FRERE(I) = IPE(I) 1994 FILS(I) = IPS(I) 1995 51 CONTINUE 1996 IS = 1 1997 I = 0 1998 IL = 0 1999 DO 160 K=1,N 2000 IF (I.GT.0) GO TO 60 2001 I = NE(NR) 2002 NE(NR) = 0 2003 NR = NR + 1 2004 IL = N 2005 NA(N) = 0 2006 60 DO 70 L=1,N 2007 IF (IPS(I).GE.0) GO TO 80 2008 ISON = -IPS(I) 2009 IPS(I) = 0 2010 I = ISON 2011 IL = IL - 1 2012 NA(IL) = 0 2013 70 CONTINUE 2014 80 IPS(I) = K 2015 NE(IS) = NE(IS) + 1 2016 IF (NV(I).GT.0) GO TO 89 2017 IN = I 2018 81 IN = FRERE(IN) 2019 IF (IN.GT.0) GO TO 81 2020 IF = -IN 2021 IN = IF 2022 82 INL = IN 2023 IN = FILS(IN) 2024 IF (IN.GT.0) GO TO 82 2025 IFSON = -IN 2026 FILS(INL) = I 2027 IN = I 2028 83 INP = IN 2029 IN = FILS(IN) 2030 IF (IN.GT.0) GO TO 83 2031 IF (IFSON .EQ. I) GO TO 86 2032 FILS(INP) = -IFSON 2033 IN = IFSON 2034 84 INC =IN 2035 IN = FRERE(IN) 2036 IF (IN.NE.I) GO TO 84 2037 FRERE(INC) = FRERE(I) 2038 GO TO 120 2039 86 IF (FRERE(I).LT.0) FILS(INP) = 0 2040 IF (FRERE(I).GT.0) FILS(INP) = -FRERE(I) 2041 GO TO 120 2042 89 IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 2043 NA(IS) = NA(IL) 2044 NDD(IS) = NV(I) 2045 NFSIZ(I) = NV(I) 2046 IF (NA(IS).LT.1) GO TO 110 2047 IF ( (KEEP60.NE.0).AND. 2048 & (NE(IS).EQ.NDD(IS)) ) GOTO 110 2049 IF (NDD(IS-1)-NE(IS-1).EQ.NDD(IS)) GO TO 100 2050 IF ((NE(IS-1).GE.NEMIN).AND. 2051 & (NE(IS).GE.NEMIN) ) GO TO 110 2052 IF (2*NE(IS-1)*(NDD(IS)-NDD(IS-1)+NE(IS-1)).GE. 2053 & ((NDD(IS)+NE(IS-1))* 2054 & (NDD(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 2055 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 2056 NDD(IS-1) = NDD(IS) + NE(IS-1) 2057 NE(IS-1) = NE(IS) + NE(IS-1) 2058 NE(IS) = 0 2059 IN=I 2060 101 INL = IN 2061 IN = FILS(IN) 2062 IF (IN.GT.0) GO TO 101 2063 IFSON = -IN 2064 IN = IFSON 2065 102 INO = IN 2066 IN = FRERE(IN) 2067 IF (IN.GT.0) GO TO 102 2068 FILS(INL) = INO 2069 NFSIZ(I) = NDD(IS-1) 2070 IN = INO 2071 103 INP = IN 2072 IN = FILS(IN) 2073 IF (IN.GT.0) GO TO 103 2074 INOS = -IN 2075 IF (IFSON.EQ.INO) GO TO 107 2076 IN = IFSON 2077 FILS(INP) = -IFSON 2078 105 INS = IN 2079 IN = FRERE(IN) 2080 IF (IN.NE.INO) GO TO 105 2081 IF (INOS.EQ.0) FRERE(INS) = -I 2082 IF (INOS.NE.0) FRERE(INS) = INOS 2083 IF (INOS.EQ.0) GO TO 109 2084 107 IN = INOS 2085 IF (IN.EQ.0) GO TO 109 2086 108 INT = IN 2087 IN = FRERE(IN) 2088 IF (IN.GT.0) GO TO 108 2089 FRERE(INT) = -I 2090 109 CONTINUE 2091 GO TO 120 2092 110 IS = IS + 1 2093 120 IB = IPE(I) 2094 IF (IB.LT.0) GOTO 150 2095 IF (IB.EQ.0) GOTO 140 2096 NA(IL) = 0 2097 140 I = IB 2098 GO TO 160 2099 150 I = -IB 2100 IL = IL + 1 2101 160 CONTINUE 2102 NSTEPS = IS - 1 2103 DO 170 I=1,N 2104 K = FILS(I) 2105 IF (K.GT.0) THEN 2106 FRERE(K) = N + 1 2107 NFSIZ(K) = 0 2108 ENDIF 2109 170 CONTINUE 2110 RETURN 2111 END SUBROUTINE DMUMPS_200 2112#else 2113 SUBROUTINE DMUMPS_557(N, IPE, NV, IPS, NE, NA, NFSIZ, 2114 & NODE, NSTEPS, 2115 & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, 2116 & KEEP20, KEEP38, NAMALG,NAMALGMAX, 2117 & CUMUL,KEEP50, ICNTL13, KEEP37, NSLAVES, 2118 & ALLOW_AMALG_TINY_NODES) 2119 IMPLICIT NONE 2120 INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 2121 INTEGER ND(N), NFSIZ(N) 2122 INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) 2123 INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) 2124 INTEGER NEMIN,AMALG_COUNT 2125 INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) 2126 DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, 2127 & FLOPS_AVANT, FLOPS_APRES 2128 INTEGER ICNTL13, KEEP37, NSLAVES 2129 LOGICAL ALLOW_AMALG_TINY_NODES 2130#if defined(NOAMALGTOFATHER) 2131#else 2132#endif 2133 INTEGER I,IF,IS,NR,INS 2134 INTEGER K,L,ISON,IN,IFSON,INO 2135 INTEGER INOS,IB,IL 2136 INTEGER IPERM 2137#if defined(NOAMALGTOFATHER) 2138 INTEGER INB,INF,INFS,INL,INSW,INT,NR1 2139#else 2140 INTEGER DADI 2141 LOGICAL AMALG_TO_father_OK 2142#endif 2143 AMALG_COUNT = 0 2144 DO 10 I=1,N 2145 CUMUL(I)= 0 2146 IPS(I) = 0 2147 NE(I) = 0 2148 NODE(I) = 1 2149 SUBORD(I) = 0 2150 NAMALG(I) = 0 2151 10 CONTINUE 2152 FRERE(1:N) = IPE(1:N) 2153 NR = N + 1 2154 DO 50 I=1,N 2155 IF = -FRERE(I) 2156 IF (NV(I).EQ.0) THEN 2157 IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) 2158 SUBORD(IF) = I 2159 NODE(IF) = NODE(IF)+1 2160 ELSE 2161 IF (IF.NE.0) THEN 2162 IS = -IPS(IF) 2163 IF (IS.GT.0) FRERE(I) = IS 2164 IPS(IF) = -I 2165 ELSE 2166 NR = NR - 1 2167 NE(NR) = I 2168 ENDIF 2169 ENDIF 2170 50 CONTINUE 2171#if defined(NOAMALGTOFATHER) 2172 DO 999 I=1,N 2173 FILS(I) = IPS(I) 2174 999 CONTINUE 2175 NR1 = NR 2176 INS = 0 2177 1000 IF (NR1.GT.N) GO TO 1151 2178 INS = NE(NR1) 2179 NR1 = NR1 + 1 2180 1070 INL = FILS(INS) 2181 IF (INL.LT.0) THEN 2182 INS = -INL 2183 GO TO 1070 2184 ENDIF 2185 1080 IF (FRERE(INS).LT.0) THEN 2186 INS = -FRERE(INS) 2187 FILS(INS) = 0 2188 GO TO 1080 2189 ENDIF 2190 IF (FRERE(INS).EQ.0) THEN 2191 INS = 0 2192 GO TO 1000 2193 ENDIF 2194 INB = FRERE(INS) 2195 IF (NV(INB).GE.NV(INS)) THEN 2196 INS = INB 2197 GO TO 1070 2198 ENDIF 2199 INF = INB 2200 1090 INF = FRERE(INF) 2201 IF (INF.GT.0) GO TO 1090 2202 INF = -INF 2203 INFS = -FILS(INF) 2204 IF (INFS.EQ.INS) THEN 2205 FILS(INF) = -INB 2206 IPS(INF) = -INB 2207 FRERE(INS) = FRERE(INB) 2208 FRERE(INB) = INS 2209 ELSE 2210 INSW = INFS 2211 1100 INFS = FRERE(INSW) 2212 IF (INFS.NE.INS) THEN 2213 INSW = INFS 2214 GO TO 1100 2215 ENDIF 2216 FRERE(INS) = FRERE(INB) 2217 FRERE(INB) = INS 2218 FRERE(INSW)= INB 2219 ENDIF 2220 INS = INB 2221 GO TO 1070 2222#endif 2223 DO 51 I=1,N 2224 FILS(I) = IPS(I) 2225 51 CONTINUE 2226 IS = 1 2227 I = 0 2228 IPERM = 1 2229 DO 160 K=1,N 2230 AMALG_TO_father_OK=.FALSE. 2231 IF (I.LE.0) THEN 2232 IF (NR.GT.N) EXIT 2233 I = NE(NR) 2234 NE(NR) = 0 2235 NR = NR + 1 2236 IL = N 2237 NA(N) = 0 2238 ENDIF 2239 DO 70 L=1,N 2240 IF (IPS(I).GE.0) EXIT 2241 ISON = -IPS(I) 2242 IPS(I) = 0 2243 I = ISON 2244 IL = IL - 1 2245 NA(IL) = 0 2246 70 CONTINUE 2247#if ! defined(NOAMALGTOFATHER) 2248 DADI = -IPE(I) 2249 IF ( (DADI.NE.0) .AND. 2250 & ( 2251 & (KEEP60.EQ.0).OR. 2252 & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) 2253 & ) 2254 & ) THEN 2255 ACCU = 2256 & ( dble(20000)* 2257 & dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) 2258 & ) 2259 & / 2260 & ( dble(NV(DADI)+NODE(I))* 2261 & dble(NV(DADI)+NODE(I)) ) 2262 ACCU = ACCU + dble(CUMUL(I) ) 2263 AMALG_TO_father_OK = ( (NODE(I).LE.NEMIN).OR. 2264 & (NODE(DADI).LE.NEMIN) ) 2265 AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. 2266 & ( 2267 & ( dble(2*(NODE(I)))* 2268 & dble((NV(DADI)-NV(I)+NODE(I))) 2269 & ) .LT. 2270 & ( dble(NV(DADI)+NODE(I))* 2271 & dble(NV(DADI)+NODE(I))*dble(NEMIN)/dble(100) 2272 & ) 2273 & ) ) 2274 AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. 2275 & ( ACCU .LE. dble(NEMIN)*dble(100) ) 2276 & ) 2277 IF (AMALG_TO_father_OK) THEN 2278 CALL MUMPS_511(NV(I),NODE(I),NODE(I), 2279 & KEEP50,1,FLOPS_SON) 2280 CALL MUMPS_511(NV(DADI),NODE(DADI), 2281 & NODE(DADI), 2282 & KEEP50,1,FLOPS_FATHER) 2283 FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON 2284 & + max(dble(200.0) * dble(NV(I)-NODE(I)) 2285 & * dble(NV(I)-NODE(I)), 2286 & dble(10000.0)) 2287 CALL MUMPS_511(NV(DADI)+NODE(I), 2288 & NODE(DADI)+NODE(I), 2289 & NODE(DADI)+NODE(I), 2290 & KEEP50,1,FLOPS_APRES) 2291 IF(FLOPS_APRES .GT. FLOPS_AVANT) THEN 2292 AMALG_TO_father_OK = .FALSE. 2293 ENDIF 2294 ENDIF 2295 IF ( (NV(I).GT. 50*NV(DADI)).AND. (NSLAVES.GT.1) 2296 & .AND. (ICNTL13.LE.0) 2297 & .AND. (NV(I).GT. KEEP37) ) THEN 2298 AMALG_TO_father_OK = .TRUE. 2299 ENDIF 2300 IF ( ALLOW_AMALG_TINY_NODES .AND. 2301 & NODE(I) * 900 .LE. NV(DADI) - NAMALG(DADI)) THEN 2302 IF ( NAMALG(DADI) < (NV(DADI)-NAMALG(DADI))/50 ) THEN 2303 AMALG_TO_father_OK = .TRUE. 2304 NAMALG(DADI) = NAMALG(DADI) + NODE(I) 2305 ENDIF 2306 ENDIF 2307 AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. 2308 & ( NV(I)-NODE(I).EQ.NV(DADI)) ) 2309 IF (AMALG_TO_father_OK) THEN 2310 CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) 2311 NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) 2312 AMALG_COUNT = AMALG_COUNT+1 2313 IN = DADI 2314 75 IF (SUBORD(IN).EQ.0) GOTO 76 2315 IN = SUBORD(IN) 2316 GOTO 75 2317 76 CONTINUE 2318 SUBORD(IN) = I 2319 NV(I) = 0 2320 IFSON = -FILS(DADI) 2321 IF (IFSON.EQ.I) THEN 2322 IF (FILS(I).LT.0) THEN 2323 FILS(DADI) = FILS(I) 2324 GOTO 78 2325 ELSE 2326 IF (FRERE(I).GT.0) THEN 2327 FILS(DADI) = -FRERE(I) 2328 ELSE 2329 FILS(DADI) = 0 2330 ENDIF 2331 GOTO 90 2332 ENDIF 2333 ENDIF 2334 IN = IFSON 2335 77 INS = IN 2336 IN = FRERE(IN) 2337 IF (IN.NE.I) GOTO 77 2338 IF (FILS(I) .LT.0) THEN 2339 FRERE(INS) = -FILS(I) 2340 ELSE 2341 FRERE(INS) = FRERE(I) 2342 GOTO 90 2343 ENDIF 2344 78 CONTINUE 2345 IN = -FILS(I) 2346 79 INO = IN 2347 IN = FRERE(IN) 2348 IF (IN.GT.0) GOTO 79 2349 FRERE(INO) = FRERE(I) 2350 90 CONTINUE 2351 NODE(DADI) = NODE(DADI)+ NODE(I) 2352 NV(DADI) = NV(DADI) + NODE(I) 2353 NA(IL+1) = NA(IL+1) + NA(IL) 2354 GOTO 120 2355 ENDIF 2356 ENDIF 2357#endif 2358 NE(IS) = NE(IS) + NODE(I) 2359 IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 2360 NA(IS) = NA(IL) 2361 ND(IS) = NV(I) 2362 NODE(I) = IS 2363 IPS(I) = IPERM 2364 IPERM = IPERM + 1 2365 IN = I 2366 777 IF (SUBORD(IN).EQ.0) GO TO 778 2367 IN = SUBORD(IN) 2368 NODE(IN) = IS 2369 IPS(IN) = IPERM 2370 IPERM = IPERM + 1 2371 GO TO 777 2372 778 IF (NA(IS).LE.0) GO TO 110 2373#if defined(NOAMALGTOFATHER) 2374 IF ( (KEEP60.NE.0).AND. 2375 & (NE(IS).EQ.ND(IS)) ) GOTO 110 2376 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN 2377 GO TO 100 2378 ENDIF 2379 IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN 2380 GOTO 110 2381 ENDIF 2382 IF ((NE(IS-1).GE.NEMIN).AND. 2383 & (NE(IS).GE.NEMIN) ) GO TO 110 2384 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. 2385 & ((ND(IS)+NE(IS-1))* 2386 & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 2387 NAMALG(IS-1) = NAMALG(IS-1)+1 2388 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 2389 ND(IS-1) = ND(IS) + NE(IS-1) 2390 NE(IS-1) = NE(IS) + NE(IS-1) 2391 NE(IS) = 0 2392 NODE(I) = IS-1 2393 IFSON = -FILS(I) 2394 IN = IFSON 2395 102 INO = IN 2396 IN = FRERE(IN) 2397 IF (IN.GT.0) GO TO 102 2398 NV(INO) = 0 2399 IN = I 2400 888 IF (SUBORD(IN).EQ.0) GO TO 889 2401 IN = SUBORD(IN) 2402 GO TO 888 2403 889 SUBORD(IN) = INO 2404 INOS = -FILS(INO) 2405 IF (IFSON.EQ.INO) THEN 2406 FILS(I) = -INOS 2407 GO TO 107 2408 ENDIF 2409 IN = IFSON 2410 105 INS = IN 2411 IN = FRERE(IN) 2412 IF (IN.NE.INO) GO TO 105 2413 IF (INOS.EQ.0) THEN 2414 FRERE(INS) = -I 2415 GO TO 120 2416 ELSE 2417 FRERE(INS) = INOS 2418 ENDIF 2419 107 IN = INOS 2420 IF (IN.EQ.0) GO TO 120 2421 108 INT = IN 2422 IN = FRERE(IN) 2423 IF (IN.GT.0) GO TO 108 2424 FRERE(INT) = -I 2425 GO TO 120 2426#endif 2427 110 IS = IS + 1 2428 120 IB = FRERE(I) 2429 IF (IB.GE.0) THEN 2430 IF (IB.GT.0) NA(IL) = 0 2431 I = IB 2432 ELSE 2433 I = -IB 2434 IL = IL + 1 2435 ENDIF 2436 160 CONTINUE 2437 NSTEPS = IS - 1 2438 DO I=1, N 2439 IF (NV(I).EQ.0) THEN 2440 FRERE(I) = N+1 2441 NFSIZ(I) = 0 2442 ELSE 2443 NFSIZ(I) = ND(NODE(I)) 2444 IF (SUBORD(I) .NE.0) THEN 2445 INOS = -FILS(I) 2446 INO = I 2447 DO WHILE (SUBORD(INO).NE.0) 2448 IS = SUBORD(INO) 2449 FILS(INO) = IS 2450 INO = IS 2451 END DO 2452 FILS(INO) = -INOS 2453 ENDIF 2454 ENDIF 2455 ENDDO 2456 RETURN 2457 END SUBROUTINE DMUMPS_557 2458#endif 2459 SUBROUTINE DMUMPS_201(NE, ND, NSTEPS, 2460 & MAXFR, MAXELIM, K50, MAXFAC, MAXNPIV, 2461 & K5,K6,PANEL_SIZE,K253) 2462 IMPLICIT NONE 2463 INTEGER NSTEPS,MAXNPIV 2464 INTEGER MAXFR, MAXELIM, K50, MAXFAC 2465 INTEGER K5,K6,PANEL_SIZE,K253 2466 INTEGER NE(NSTEPS), ND(NSTEPS) 2467 INTEGER ITREE, NFR, NELIM 2468 INTEGER LKJIB 2469 LKJIB = max(K5,K6) 2470 MAXFR = 0 2471 MAXFAC = 0 2472 MAXELIM = 0 2473 MAXNPIV = 0 2474 PANEL_SIZE = 0 2475 DO ITREE=1,NSTEPS 2476 NELIM = NE(ITREE) 2477 NFR = ND(ITREE) + K253 2478 IF (NFR.GT.MAXFR) MAXFR = NFR 2479 IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM 2480 IF (NELIM .GT. MAXNPIV) THEN 2481 IF(NFR .NE. NELIM) MAXNPIV = NELIM 2482 ENDIF 2483 IF (K50.EQ.0) THEN 2484 MAXFAC = max(MAXFAC, (2*NFR - NELIM)*NELIM ) 2485 PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) 2486 ELSE 2487 MAXFAC = max(MAXFAC, NFR * NELIM) 2488 PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) 2489 PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) 2490 ENDIF 2491 END DO 2492 RETURN 2493 END SUBROUTINE DMUMPS_201 2494 SUBROUTINE DMUMPS_348( N, FILS, FRERE, 2495 & NSTK, NA ) 2496 IMPLICIT NONE 2497 INTEGER, INTENT(IN) :: N 2498 INTEGER, INTENT(IN) :: FILS(N), FRERE(N) 2499 INTEGER, INTENT(INOUT) :: NSTK(N), NA(N) 2500 INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON 2501 NA = 0 2502 NSTK = 0 2503 NBROOT = 0 2504 ILEAF = 1 2505 DO 11 I=1,N 2506 IF (FRERE(I).EQ. N+1) CYCLE 2507 IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 2508 IN = I 2509 12 IN = FILS(IN) 2510 IF (IN.GT.0) GO TO 12 2511 IF (IN.EQ.0) THEN 2512 NA(ILEAF) = I 2513 ILEAF = ILEAF + 1 2514 CYCLE 2515 ENDIF 2516 ISON = -IN 2517 13 NSTK(I) = NSTK(I) + 1 2518 ISON = FRERE(ISON) 2519 IF (ISON.GT.0) GO TO 13 2520 11 CONTINUE 2521 NBLEAF = ILEAF-1 2522 IF (N.GT.1) THEN 2523 IF (NBLEAF.GT.N-2) THEN 2524 IF (NBLEAF.EQ.N-1) THEN 2525 NA(N-1) = -NA(N-1)-1 2526 NA(N) = NBROOT 2527 ELSE 2528 NA(N) = -NA(N)-1 2529 ENDIF 2530 ELSE 2531 NA(N-1) = NBLEAF 2532 NA(N) = NBROOT 2533 ENDIF 2534 ENDIF 2535 RETURN 2536 END SUBROUTINE DMUMPS_348 2537 SUBROUTINE DMUMPS_203( N, NZ, MTRANS, PERM, 2538 & id, ICNTL, INFO) 2539 USE DMUMPS_STRUC_DEF 2540 IMPLICIT NONE 2541 TYPE (DMUMPS_STRUC) :: id 2542 INTEGER N, NZ, LIWG 2543 INTEGER PERM(N) 2544 INTEGER MTRANS 2545 INTEGER ICNTL(40), INFO(40) 2546 INTEGER allocok 2547 INTEGER, ALLOCATABLE, DIMENSION(:) :: IW 2548 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2 2549 TARGET :: S2 2550 INTEGER LS2,LSC 2551 INTEGER ICNTL64(10), INFO64(10) 2552 INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) 2553 DOUBLE PRECISION CNTL64(10) 2554 INTEGER LDW, LDWMIN 2555 INTEGER MPRINT,LP, MP, IPIW, LIW, LIWMIN 2556 INTEGER JPERM 2557 INTEGER NUMNZ, I, J, JPOS, K, NZREAL 2558 INTEGER PLENR, IP, IRNW,RSPOS,CSPOS 2559 LOGICAL PROK, IDENT, DUPPLI 2560 INTEGER NZTOT, K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG 2561 LOGICAL SCALINGLOC 2562 INTEGER,POINTER,DIMENSION(:) :: ZERODIAG 2563 INTEGER,POINTER,DIMENSION(:) :: STR_KER 2564 INTEGER,POINTER,DIMENSION(:) :: MARKED 2565 INTEGER,POINTER,DIMENSION(:) :: FLAG 2566 INTEGER,POINTER,DIMENSION(:) :: PIV_OUT 2567 DOUBLE PRECISION THEMIN, THEMAX, COLNORM,MAXDBL 2568 DOUBLE PRECISION ZERO,TWO,ONE 2569 PARAMETER(ZERO = 0.0D0,TWO = 2.0D0,ONE = 1.0D0) 2570 MPRINT = ICNTL(3) 2571 LP = ICNTL(1) 2572 MP = ICNTL(2) 2573 PROK = (MPRINT.GT.0) 2574 IF (PROK) WRITE(MPRINT,101) 2575 101 FORMAT(/'****** Preprocessing of original matrix '/) 2576 K50 = id%KEEP(50) 2577 SCALINGLOC = .FALSE. 2578 IF(id%KEEP(52) .EQ. -2) THEN 2579 IF(.not.associated(id%A)) THEN 2580 INFO(1) = -22 2581 INFO(2) = 4 2582 GOTO 500 2583 ELSE 2584 SCALINGLOC = .TRUE. 2585 ENDIF 2586 ELSE IF(id%KEEP(52) .EQ. 77) THEN 2587 SCALINGLOC = .TRUE. 2588 IF(K50 .NE. 2) THEN 2589 IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 2590 & .AND. MTRANS .NE. 7) THEN 2591 SCALINGLOC = .FALSE. 2592 IF (PROK) 2593 & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' 2594 ENDIF 2595 ENDIF 2596 IF(.not.associated(id%A)) THEN 2597 SCALINGLOC = .FALSE. 2598 IF (PROK) 2599 & WRITE(MPRINT,*) 'Analysis: auto scaling set OFF' 2600 ENDIF 2601 ENDIF 2602 IF(SCALINGLOC) THEN 2603 IF (PROK) WRITE(MPRINT,*) 2604 & 'Scaling will be computed during analysis' 2605 ENDIF 2606 MTRANSLOC = MTRANS 2607 IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 2608 IF (K50 .EQ. 0) THEN 2609 IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN 2610 GO TO 500 2611 ENDIF 2612 IF(SCALINGLOC) THEN 2613 MTRANSLOC = 5 2614 ENDIF 2615 ELSE 2616 IF (MTRANS .EQ. 7) MTRANSLOC = 5 2617 ENDIF 2618 IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. 2619 & MTRANSLOC .NE. 6 ) THEN 2620 IF (PROK) WRITE(MPRINT,*) 2621 & 'WARNING scaling required: set MTRANS option to 5' 2622 MTRANSLOC = 5 2623 ENDIF 2624 IF (N.EQ.1) THEN 2625 MTRANS=0 2626 GO TO 500 2627 ENDIF 2628 IF(K50 .EQ. 2) THEN 2629 NZTOT = 2*NZ+N 2630 ELSE 2631 NZTOT = NZ 2632 ENDIF 2633 ZERODIAG => id%IS1(N+1:2*N) 2634 STR_KER => id%IS1(2*N+1:3*N) 2635 CALL DMUMPS_448(ICNTL64,CNTL64) 2636 ICNTL64(1) = ICNTL(1) 2637 ICNTL64(2) = ICNTL(2) 2638 ICNTL64(3) = ICNTL(2) 2639 ICNTL64(4) = -1 2640 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 2641 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 2642 ICNTL64(5) = -1 2643 IF (PROK) THEN 2644 WRITE(MPRINT,'(A,I3)') 2645 & 'Compute maximum matching (Maximum Transversal):', 2646 & MTRANSLOC 2647 IF (MTRANSLOC.EQ.1) 2648 & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC 2649 IF (MTRANSLOC.EQ.2) 2650 & WRITE(MPRINT,'(A,I3,A)') 2651 & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' 2652 IF (MTRANSLOC.EQ.3) 2653 & WRITE(MPRINT,'(A,I3,A)') 2654 & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' 2655 IF (MTRANSLOC.EQ.4) 2656 & WRITE(MPRINT,'(A,I3,A)') 2657 & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGIONAL' 2658 IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) 2659 & WRITE(MPRINT,'(A,I3,A)') 2660 & ' ... JOB =',MTRANSLOC, 2661 & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' 2662 ENDIF 2663 id%INFOG(23) = MTRANSLOC 2664 CNTL64(2) = huge(CNTL64(2)) 2665 IRNW = 1 2666 IP = IRNW + NZTOT 2667 PLENR = IP + N + 1 2668 IPIW = PLENR 2669 IF (MTRANSLOC.EQ.1) LIWMIN = 5*N 2670 IF (MTRANSLOC.EQ.2) LIWMIN = 4*N 2671 IF (MTRANSLOC.EQ.3) LIWMIN = 10*N + NZTOT 2672 IF (MTRANSLOC.EQ.4) LIWMIN = 5*N 2673 IF (MTRANSLOC.EQ.5) LIWMIN = 5*N 2674 IF (MTRANSLOC.EQ.6) LIWMIN = 5*N + NZTOT 2675 LIW = LIWMIN 2676 LIWG = LIW + (NZTOT + N + 1) 2677 ALLOCATE(IW(LIWG), stat=allocok) 2678 IF (allocok .GT. 0 ) GOTO 410 2679 IF (MTRANSLOC.EQ.1) THEN 2680 LDWMIN = N+3 2681 ENDIF 2682 IF (MTRANSLOC.EQ.2) LDWMIN = max(N+NZTOT,N+3) 2683 IF (MTRANSLOC.EQ.3) LDWMIN = max(NZTOT+1,N+3) 2684 IF (MTRANSLOC.EQ.4) LDWMIN = 2*N + max(NZTOT,N+3) 2685 IF (MTRANSLOC.EQ.5) LDWMIN = 3*N + NZTOT 2686 IF (MTRANSLOC.EQ.6) LDWMIN = 4*N + NZTOT 2687 LDW = LDWMIN 2688 ALLOCATE(S2(LDW), stat=allocok) 2689 IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT 2690 RSPOS = NZTOT 2691 CSPOS = RSPOS+N 2692 IF (allocok .GT. 0 ) GOTO 430 2693 NZREAL = 0 2694 DO 5 J=1,N 2695 IW(PLENR+J-1) = 0 2696 5 CONTINUE 2697 IF(K50 .EQ. 0) THEN 2698 DO 10 K=1,NZ 2699 I = id%IRN(K) 2700 J = id%JCN(K) 2701 IF ( (J.LE.N).AND.(J.GE.1).AND. 2702 & (I.LE.N).AND.(I.GE.1) ) THEN 2703 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 2704 NZREAL = NZREAL + 1 2705 ENDIF 2706 10 CONTINUE 2707 ELSE 2708 ZERODIAG = 0 2709 NZER_DIAG = N 2710 RZ_DIAG = 0 2711 DO K=1,NZ 2712 I = id%IRN(K) 2713 J = id%JCN(K) 2714 IF ( (J.LE.N).AND.(J.GE.1).AND. 2715 & (I.LE.N).AND.(I.GE.1) ) THEN 2716 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 2717 NZREAL = NZREAL + 1 2718 IF(I .NE. J) THEN 2719 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 2720 NZREAL = NZREAL + 1 2721 ELSE 2722 IF(ZERODIAG(I) .EQ. 0) THEN 2723 ZERODIAG(I) = K 2724 IF(associated(id%A)) THEN 2725 IF(abs(id%A(K)) .EQ. dble(0.0D0)) THEN 2726 RZ_DIAG = RZ_DIAG + 1 2727 ENDIF 2728 ENDIF 2729 NZER_DIAG = NZER_DIAG - 1 2730 ENDIF 2731 ENDIF 2732 ENDIF 2733 ENDDO 2734 IF(MTRANSLOC .GE. 4) THEN 2735 DO I =1, N 2736 IF(ZERODIAG(I) .EQ. 0) THEN 2737 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 2738 NZREAL = NZREAL + 1 2739 ENDIF 2740 ENDDO 2741 ENDIF 2742 ENDIF 2743 IW(IP) = 1 2744 DO 20 J=1,N 2745 IW(IP+J) = IW(IP+J-1)+IW(PLENR+J-1) 2746 20 CONTINUE 2747 DO 25 J=1, N 2748 IW(PLENR+J-1 ) = IW(IP+J-1 ) 2749 25 CONTINUE 2750 IF(K50 .EQ. 0) THEN 2751 IF (MTRANSLOC.EQ.1) THEN 2752 DO 30 K=1,NZ 2753 I = id%IRN(K) 2754 J = id%JCN(K) 2755 IF ( (J.LE.N).AND.(J.GE.1) .AND. 2756 & (I.LE.N).AND.(I.GE.1)) THEN 2757 JPOS = IW(PLENR+J-1) 2758 IW(IRNW+JPOS-1) = I 2759 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 2760 ENDIF 2761 30 CONTINUE 2762 ELSE 2763 IF ( .not.associated(id%A)) THEN 2764 INFO(1) = -22 2765 INFO(2) = 4 2766 GOTO 500 2767 ENDIF 2768 DO 35 K=1,NZ 2769 I = id%IRN(K) 2770 J = id%JCN(K) 2771 IF ( (J.LE.N).AND.(J.GE.1) .AND. 2772 & (I.LE.N).AND.(I.GE.1)) THEN 2773 JPOS = IW(PLENR+J-1) 2774 IW(IRNW+JPOS-1) = I 2775 S2(JPOS) = abs(id%A(K)) 2776 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 2777 ENDIF 2778 35 CONTINUE 2779 ENDIF 2780 ELSE 2781 IF (MTRANSLOC.EQ.1) THEN 2782 DO K=1,NZ 2783 I = id%IRN(K) 2784 J = id%JCN(K) 2785 IF ( (J.LE.N).AND.(J.GE.1) .AND. 2786 & (I.LE.N).AND.(I.GE.1)) THEN 2787 JPOS = IW(PLENR+J-1) 2788 IW(IRNW+JPOS-1) = I 2789 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 2790 IF(I.NE.J) THEN 2791 JPOS = IW(PLENR+I-1) 2792 IW(IRNW+JPOS-1) = J 2793 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 2794 ENDIF 2795 ENDIF 2796 ENDDO 2797 ELSE 2798 IF ( .not.associated(id%A)) THEN 2799 INFO(1) = -22 2800 INFO(2) = 4 2801 GOTO 500 2802 ENDIF 2803 K = 1 2804 THEMIN = ZERO 2805 DO 2806 IF(THEMIN .NE. ZERO) EXIT 2807 THEMIN = abs(id%A(K)) 2808 K = K+1 2809 ENDDO 2810 THEMAX = THEMIN 2811 DO K=1,NZ 2812 I = id%IRN(K) 2813 J = id%JCN(K) 2814 IF ( (J.LE.N).AND.(J.GE.1) .AND. 2815 & (I.LE.N).AND.(I.GE.1)) THEN 2816 JPOS = IW(PLENR+J-1) 2817 IW(IRNW+JPOS-1) = I 2818 S2(JPOS) = abs(id%A(K)) 2819 IW(PLENR+J-1) = IW(PLENR+J-1) + 1 2820 IF(abs(id%A(K)) .GT. THEMAX) THEN 2821 THEMAX = abs(id%A(K)) 2822 ELSE IF(abs(id%A(K)) .LT. THEMIN 2823 & .AND. abs(id%A(K)).GT. ZERO) THEN 2824 THEMIN = abs(id%A(K)) 2825 ENDIF 2826 IF(I.NE.J) THEN 2827 JPOS = IW(PLENR+I-1) 2828 IW(IRNW+JPOS-1) = J 2829 S2(JPOS) = abs(id%A(K)) 2830 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 2831 ENDIF 2832 ENDIF 2833 ENDDO 2834 DO I =1, N 2835 IF(ZERODIAG(I) .EQ. 0) THEN 2836 JPOS = IW(PLENR+I-1) 2837 IW(IRNW+JPOS-1) = I 2838 S2(JPOS) = ZERO 2839 IW(PLENR+I-1) = IW(PLENR+I-1) + 1 2840 ENDIF 2841 ENDDO 2842 CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) 2843 & - log(THEMIN) + ONE 2844 ENDIF 2845 ENDIF 2846 DUPPLI = .FALSE. 2847 I = NZREAL 2848 FLAG => id%IS1(3*N+1:4*N) 2849 IF(MTRANSLOC.NE.1) THEN 2850 CALL DMUMPS_563(N,NZREAL,IW(IP),IW(IRNW),S2, 2851 & PERM,FLAG(1)) 2852 ELSE 2853 CALL DMUMPS_562(N,NZREAL,IW(IP),IW(IRNW), 2854 & PERM,FLAG(1)) 2855 ENDIF 2856 IF(NZREAL .NE. I) DUPPLI = .TRUE. 2857 LS2 = NZTOT 2858 IF ( MTRANSLOC .EQ. 1 ) THEN 2859 LS2 = 1 2860 LDW = 1 2861 ENDIF 2862 CALL DMUMPS_559(MTRANSLOC ,N, N, NZREAL, 2863 & IW(IP), IW(IRNW), S2(1), LS2, 2864 & NUMNZ, PERM, LIW, IW(IPIW), LDW, S2(LS2+1), 2865 & ICNTL64, CNTL64, INFO64) 2866 IF (INFO64(1).LT.0) THEN 2867 IF (LP.GT.0 .AND. ICNTL(4).GE.1) 2868 & WRITE(LP,'(A,I5)') 2869 & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) 2870 INFO(1) = -9964 2871 INFO(2) = INFO64(1) 2872 GO TO 500 2873 ENDIF 2874 IF (INFO64(1).GT.0) THEN 2875 IF (MP.GT.0 .AND. ICNTL(4).GE.2) 2876 & WRITE(MP,'(A,I5)') 2877 & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) 2878 ENDIF 2879 KER_SIZE = 0 2880 IF(K50 .EQ. 2) THEN 2881 DO I=1,N 2882 IF(ZERODIAG(I) .EQ. 0) THEN 2883 IF(PERM(I) .EQ. I) THEN 2884 KER_SIZE = KER_SIZE + 1 2885 PERM(I) = -I 2886 STR_KER(KER_SIZE) = I 2887 ENDIF 2888 ENDIF 2889 ENDDO 2890 ENDIF 2891 IF (NUMNZ.LT.N) GO TO 400 2892 IF(K50 .EQ. 0) THEN 2893 IDENT = .TRUE. 2894 IF (MTRANS .EQ. 0 ) GOTO 102 2895 DO 80 J=1,N 2896 JPERM = PERM(J) 2897 IW(PLENR+JPERM-1) = J 2898 IF (JPERM.NE.J) IDENT = .FALSE. 2899 80 CONTINUE 2900 IF(IDENT) THEN 2901 MTRANS = 0 2902 ELSE 2903 IF(MTRANS .EQ. 7) THEN 2904 MTRANS = -9876543 2905 GOTO 102 2906 ENDIF 2907 IF (PROK) WRITE(MPRINT,'(A)') 2908 & ' ... Apply column permutation' 2909 DO 100 K=1,NZ 2910 J = id%JCN(K) 2911 IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 2912 id%JCN(K) = IW(PLENR+J-1) 2913 100 CONTINUE 2914 IF (MP.GT.0 .AND. ICNTL(4).GE.2) 2915 & WRITE(MP,'(/A)') 2916 & ' WARNING input matrix data modified' 2917 ENDIF 2918 102 CONTINUE 2919 IF (SCALINGLOC) THEN 2920 IF ( associated(id%COLSCA)) 2921 & DEALLOCATE( id%COLSCA ) 2922 IF ( associated(id%ROWSCA)) 2923 & DEALLOCATE( id%ROWSCA ) 2924 ALLOCATE( id%COLSCA(N), stat=allocok) 2925 IF (allocok .GT.0) THEN 2926 id%INFO(1)=-5 2927 id%INFO(2)=N 2928 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN 2929 WRITE (LP,'(/A)') '** Error in DMUMPS_203' 2930 WRITE (LP,'(A)') 2931 & '** Failure during allocation of COLSCA' 2932 GOTO 500 2933 ENDIF 2934 ENDIF 2935 ALLOCATE( id%ROWSCA(N), stat=allocok) 2936 IF (allocok .GT.0) THEN 2937 id%INFO(1)=-5 2938 id%INFO(2)=N 2939 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN 2940 WRITE (LP,'(/A)') '** Error in DMUMPS_203' 2941 WRITE (LP,'(A)') 2942 & '** Failure during allocation of ROWSCA' 2943 GOTO 500 2944 ENDIF 2945 ENDIF 2946 id%KEEP(52) = -2 2947 id%KEEP(74) = 1 2948 MAXDBL = log(huge(MAXDBL)) 2949 DO J=1,N 2950 IF(S2(RSPOS+J) .GT. MAXDBL) THEN 2951 S2(RSPOS+J) = ZERO 2952 ENDIF 2953 IF(S2(CSPOS+J) .GT. MAXDBL) THEN 2954 S2(CSPOS+J)= ZERO 2955 ENDIF 2956 ENDDO 2957 DO 105 J=1,N 2958 id%ROWSCA(J) = exp(S2(RSPOS+J)) 2959 IF(id%ROWSCA(J) .EQ. ZERO) THEN 2960 id%ROWSCA(J) = ONE 2961 ENDIF 2962 IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN 2963 id%COLSCA(J)= exp(S2(CSPOS+J)) 2964 IF(id%COLSCA(J) .EQ. ZERO) THEN 2965 id%COLSCA(J) = ONE 2966 ENDIF 2967 ELSE 2968 id%COLSCA(IW(PLENR+J-1))= exp(S2(CSPOS+J)) 2969 IF(id%COLSCA(IW(PLENR+J-1)) .EQ. ZERO) THEN 2970 id%COLSCA(IW(PLENR+J-1)) = ONE 2971 ENDIF 2972 ENDIF 2973 105 CONTINUE 2974 ENDIF 2975 ELSE 2976 IDENT = .FALSE. 2977 IF(SCALINGLOC) THEN 2978 IF ( associated(id%COLSCA)) DEALLOCATE( id%COLSCA ) 2979 IF ( associated(id%ROWSCA)) DEALLOCATE( id%ROWSCA ) 2980 ALLOCATE( id%COLSCA(N), stat=allocok) 2981 IF (allocok .GT.0) THEN 2982 id%INFO(1)=-5 2983 id%INFO(2)=N 2984 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN 2985 WRITE (LP,'(/A)') '** Error in DMUMPS_203' 2986 WRITE (LP,'(A)') 2987 & '** Failure during allocation of COLSCA' 2988 GOTO 500 2989 ENDIF 2990 ENDIF 2991 ALLOCATE( id%ROWSCA(N), stat=allocok) 2992 IF (allocok .GT.0) THEN 2993 id%INFO(1)=-5 2994 id%INFO(2)=N 2995 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN 2996 WRITE (LP,'(/A)') '** Error in DMUMPS_203' 2997 WRITE (LP,'(A)') 2998 & '** Failure during allocation of ROWSCA' 2999 GOTO 500 3000 ENDIF 3001 ENDIF 3002 id%KEEP(52) = -2 3003 id%KEEP(74) = 1 3004 MAXDBL = log(huge(MAXDBL)) 3005 DO J=1,N 3006 IF(S2(RSPOS+J)+S2(CSPOS+J) .GT. MAXDBL) THEN 3007 S2(RSPOS+J) = ZERO 3008 S2(CSPOS+J)= ZERO 3009 ENDIF 3010 ENDDO 3011 DO J=1,N 3012 IF(PERM(J) .GT. 0) THEN 3013 id%ROWSCA(J) = 3014 & exp((S2(RSPOS+J)+S2(CSPOS+J))/TWO) 3015 IF(id%ROWSCA(J) .EQ. ZERO) THEN 3016 id%ROWSCA(J) = ONE 3017 ENDIF 3018 id%COLSCA(J)= id%ROWSCA(J) 3019 ENDIF 3020 ENDDO 3021 DO JPOS=1,KER_SIZE 3022 I = STR_KER(JPOS) 3023 COLNORM = ZERO 3024 DO J = IW(IP+I-1),IW(IP+I) - 1 3025 IF ( PERM( IW( IRNW+J-1) ) > 0 ) THEN 3026 COLNORM = max(COLNORM,S2(J)) 3027 ENDIF 3028 ENDDO 3029 COLNORM = exp(COLNORM) 3030 id%ROWSCA(I) = ONE / COLNORM 3031 id%COLSCA(I) = id%ROWSCA(I) 3032 ENDDO 3033 ENDIF 3034 IF(MTRANS .EQ. 7 .OR. id%KEEP(95) .EQ. 0) THEN 3035 IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) 3036 & .AND. id%KEEP(95) .EQ. 0) THEN 3037 MTRANS = 0 3038 id%KEEP(95) = 1 3039 GOTO 390 3040 ELSE 3041 IF(id%KEEP(95) .EQ. 0) THEN 3042 IF(SCALINGLOC) THEN 3043 id%KEEP(95) = 3 3044 ELSE 3045 id%KEEP(95) = 2 3046 ENDIF 3047 ENDIF 3048 IF(MTRANS .EQ. 7) MTRANS = 5 3049 ENDIF 3050 ENDIF 3051 IF(MTRANS .EQ. 0) GOTO 390 3052 ICNTL_SYM_MWM = 0 3053 INFO_SYM_MWM = 0 3054 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. 3055 & MTRANS .EQ. 7) THEN 3056 ICNTL_SYM_MWM(1) = 0 3057 ICNTL_SYM_MWM(2) = 1 3058 ELSE IF(MTRANS .EQ. 4) THEN 3059 ICNTL_SYM_MWM(1) = 2 3060 ICNTL_SYM_MWM(2) = 1 3061 ELSE 3062 ICNTL_SYM_MWM(1) = 0 3063 ICNTL_SYM_MWM(2) = 1 3064 ENDIF 3065 MARKED => id%IS1(2*N+1:3*N) 3066 FLAG => id%IS1(3*N+1:4*N) 3067 PIV_OUT => id%IS1(4*N+1:5*N) 3068 IF(MTRANSLOC .LT. 4) THEN 3069 LSC = 1 3070 ELSE 3071 LSC = 2*N 3072 ENDIF 3073 CALL DMUMPS_551( 3074 & N, NZREAL, IW(IP), IW(IRNW), S2(1),LSC, PERM, 3075 & ZERODIAG(1), 3076 & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), 3077 & PIV_OUT(1), INFO_SYM_MWM) 3078 IF(INFO_SYM_MWM(1) .NE. 0) THEN 3079 WRITE(*,*) '** Error in DMUMPS_203' 3080 RETURN 3081 ENDIF 3082 IF(INFO_SYM_MWM(3) .EQ. N) THEN 3083 IDENT = .TRUE. 3084 ELSEIF( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 3085 & ) THEN 3086 IDENT = .TRUE. 3087 id%KEEP(95) = 1 3088 ELSE 3089 DO I=1,N 3090 PERM(I) = PIV_OUT(I) 3091 ENDDO 3092 ENDIF 3093 id%KEEP(93) = INFO_SYM_MWM(4) 3094 id%KEEP(94) = INFO_SYM_MWM(3) 3095 IF (IDENT) MTRANS=0 3096 ENDIF 3097 390 IF(MTRANS .EQ. 0) THEN 3098 id%KEEP(95) = 1 3099 IF (PROK) THEN 3100 WRITE (MPRINT,'(A)') 3101 & ' ... Column permutation not used' 3102 ENDIF 3103 ENDIF 3104 GO TO 500 3105 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) 3106 & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' 3107 INFO(1) = -6 3108 INFO(2) = NUMNZ 3109 GOTO 500 3110 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN 3111 WRITE (LP,'(/A)') '** Error in DMUMPS_203' 3112 WRITE (LP,'(A,I9)') 3113 & '** Failure during allocation of INTEGER array of size ', 3114 & LIWG 3115 ENDIF 3116 INFO(1) = -5 3117 INFO(2) = LIWG 3118 GOTO 500 3119 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN 3120 WRITE (LP,'(/A)') '** Error in DMUMPS_203' 3121 WRITE (LP,'(A)') '** Failure during allocation of S2' 3122 ENDIF 3123 INFO(1) = -5 3124 INFO(2) = LDW 3125 500 CONTINUE 3126 IF (allocated(IW)) DEALLOCATE(IW) 3127 IF (allocated(S2)) DEALLOCATE(S2) 3128 RETURN 3129 END SUBROUTINE DMUMPS_203 3130 SUBROUTINE DMUMPS_100 3131 &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) 3132 IMPLICIT NONE 3133 INTEGER COMM, MYID, KEEP(500), INFO(40), ICNTL(40), INFOG(40) 3134 INTEGER(8) KEEP8(150) 3135 DOUBLE PRECISION RINFO(40), RINFOG(40) 3136 INCLUDE 'mpif.h' 3137 INTEGER MASTER, MPG 3138 PARAMETER( MASTER = 0 ) 3139 MPG = ICNTL(3) 3140 IF ( MYID.eq.MASTER.and.MPG.GT.0) THEN 3141 WRITE(MPG, 99992) INFO(1), INFO(2), 3142 & KEEP8(109), KEEP8(111), INFOG(4), 3143 & INFOG(5), KEEP(28), INFOG(32), INFOG(7), KEEP(23), ICNTL(7), 3144 & KEEP(12), KEEP(56), KEEP(61), RINFOG(1) 3145 IF (KEEP(95).GT.1) 3146 & WRITE(MPG, 99993) KEEP(95) 3147 IF (KEEP(54).GT.0) WRITE(MPG, 99994) KEEP(54) 3148 IF (KEEP(60).GT.0) WRITE(MPG, 99995) KEEP(60) 3149 IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) 3150 ENDIF 3151 RETURN 315299992 FORMAT(/'Leaving analysis phase with ...'/ 3153 & 'INFOG(1) =',I16/ 3154 & 'INFOG(2) =',I16/ 3155 & ' -- (20) Number of entries in factors (estim.) =',I16/ 3156 & ' -- (3) Storage of factors (REAL, estimated) =',I16/ 3157 & ' -- (4) Storage of factors (INT , estimated) =',I16/ 3158 & ' -- (5) Maximum frontal size (estimated) =',I16/ 3159 & ' -- (6) Number of nodes in the tree =',I16/ 3160 & ' -- (32) Type of analysis effectively used =',I16/ 3161 & ' -- (7) Ordering option effectively used =',I16/ 3162 & 'ICNTL(6) Maximum transversal option =',I16/ 3163 & 'ICNTL(7) Pivot order option =',I16/ 3164 & 'Percentage of memory relaxation (effective) =',I16/ 3165 & 'Number of level 2 nodes =',I16/ 3166 & 'Number of split nodes =',I16/ 3167 & 'RINFOG(1) Operations during elimination (estim)= ',1PD10.3) 316899993 FORMAT('Ordering compressed/constrained (ICNTL(12)) =',I16) 316999994 FORMAT('Distributed matrix entry format (ICNTL(18)) =',I16) 317099995 FORMAT('Effective Schur option (ICNTL(19)) =',I16) 317199996 FORMAT('Forward solution during factorization, NRHS =',I16) 3172 END SUBROUTINE DMUMPS_100 3173 SUBROUTINE DMUMPS_97 3174 & ( N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, 3175 & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) 3176 IMPLICIT NONE 3177 INTEGER N, NSTEPS, NSLAVES, KEEP(500) 3178 INTEGER(8) KEEP8(150) 3179 INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) 3180 LOGICAL SPLITROOT 3181 INTEGER MP, LDIAG 3182 INTEGER INFO1, INFO2 3183 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL 3184 INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT 3185 INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT 3186 INTEGER(8) :: K79 3187 INTEGER NFRONT, K82, allocok 3188 K79 = KEEP8(79) 3189 K82 = abs(KEEP(82)) 3190 STRAT=KEEP(62) 3191 IF (KEEP(210).EQ.1) THEN 3192 MAX_DEPTH = 2*NSLAVES*K82 3193 STRAT = STRAT/4 3194 ELSE 3195 IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN 3196 IF (NSLAVES.EQ.1) THEN 3197 MAX_DEPTH = 1 3198 ELSE 3199 MAX_DEPTH = int( log( dble( NSLAVES - 1 ) ) 3200 & / log(2.0D0) ) 3201 ENDIF 3202 ENDIF 3203 ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) 3204 IF (allocok.GT.0) THEN 3205 INFO1= -7 3206 INFO2= NSTEPS+1 3207 RETURN 3208 ENDIF 3209 NROOT = 0 3210 DO INODE = 1, N 3211 IF ( FRERE(INODE) .eq. 0 ) THEN 3212 NROOT = NROOT + 1 3213 IPOOL( NROOT ) = INODE 3214 END IF 3215 END DO 3216 IBEG = 1 3217 IEND = NROOT 3218 IIPOOL = NROOT + 1 3219 IF (SPLITROOT) MAX_DEPTH=1 3220 DO DEPTH = 1, MAX_DEPTH 3221 DO I = IBEG, IEND 3222 INODE = IPOOL( I ) 3223 ISON = INODE 3224 DO WHILE ( ISON .GT. 0 ) 3225 ISON = FILS( ISON ) 3226 END DO 3227 ISON = - ISON 3228 DO WHILE ( ISON .GT. 0 ) 3229 IPOOL( IIPOOL ) = ISON 3230 IIPOOL = IIPOOL + 1 3231 ISON = FRERE( ISON ) 3232 END DO 3233 END DO 3234 IPOOL( IBEG ) = -IPOOL( IBEG ) 3235 IBEG = IEND + 1 3236 IEND = IIPOOL - 1 3237 END DO 3238 IPOOL( IBEG ) = -IPOOL( IBEG ) 3239 TOT_CUT = 0 3240 IF (SPLITROOT) THEN 3241 MAX_CUT = NROOT*max(K82,2) 3242 INODE = abs(IPOOL(1)) 3243 NFRONT = NFSIZ( INODE ) 3244 K79 = max( 3245 & int(NFRONT,8)*int(NFRONT,8)/(int(K82+1,8)*int(K82+1,8)), 3246 & 1_8) 3247 ELSE 3248 MAX_CUT = 2 * NSLAVES 3249 IF (KEEP(210).EQ.1) THEN 3250 MAX_CUT = 4 * (MAX_CUT + 4) 3251 ENDIF 3252 ENDIF 3253 DEPTH = -1 3254 DO I = 1, IIPOOL - 1 3255 INODE = IPOOL( I ) 3256 IF ( INODE .LT. 0 ) THEN 3257 INODE = -INODE 3258 DEPTH = DEPTH + 1 3259 END IF 3260 CALL DMUMPS_313 3261 & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, 3262 & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, 3263 & K79, SPLITROOT, MP, LDIAG ) 3264 IF ( TOT_CUT > MAX_CUT ) EXIT 3265 END DO 3266 KEEP(61) = TOT_CUT 3267 DEALLOCATE(IPOOL) 3268 RETURN 3269 END SUBROUTINE DMUMPS_97 3270 RECURSIVE SUBROUTINE DMUMPS_313 3271 & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, 3272 & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG ) 3273 IMPLICIT NONE 3274 INTEGER(8) :: K79 3275 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, 3276 & DEPTH, TOT_CUT, MP, LDIAG 3277 INTEGER(8) KEEP8(150) 3278 INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) 3279 LOGICAL SPLITROOT 3280 INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM 3281 DOUBLE PRECISION WK_SLAVE, WK_MASTER 3282 INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH 3283 INTEGER NPIV_SON, NPIV_FATH 3284 INTEGER NCB, NSLAVESMIN, NSLAVESMAX 3285 INTEGER MUMPS_50, 3286 & MUMPS_52 3287 EXTERNAL MUMPS_50, 3288 & MUMPS_52 3289 IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. 3290 & (SPLITROOT) ) THEN 3291 IF ( FRERE ( INODE ) .eq. 0 ) THEN 3292 NFRONT = NFSIZ( INODE ) 3293 NPIV = NFRONT 3294 NCB = 0 3295 IF (int(NFRONT,8)*int(NFRONT,8).GT.K79) THEN 3296 GOTO 333 3297 ENDIF 3298 ENDIF 3299 ENDIF 3300 IF ( FRERE ( INODE ) .eq. 0 ) RETURN 3301 NFRONT = NFSIZ( INODE ) 3302 IN = INODE 3303 NPIV = 0 3304 DO WHILE( IN > 0 ) 3305 IN = FILS( IN ) 3306 NPIV = NPIV + 1 3307 END DO 3308 NCB = NFRONT - NPIV 3309 IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN 3310 IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. 3311 &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 3312 IF (KEEP(210).EQ.1) THEN 3313 NSLAVESMIN = 1 3314 NSLAVESMAX = 64 3315 NSLAVES_ESTIM = 32+NSLAVES 3316 ELSE 3317 NSLAVESMIN = MUMPS_50 3318 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), 3319 & NFRONT, NCB) 3320 NSLAVESMAX = MUMPS_52 3321 & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), 3322 & NFRONT, NCB) 3323 NSLAVES_ESTIM = max (1, 3324 & nint( dble(NSLAVESMAX-NSLAVESMIN)/dble(3) ) 3325 & ) 3326 NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) 3327 ENDIF 3328 IF ( KEEP(50) .eq. 0 ) THEN 3329 WK_MASTER = 0.6667D0 * 3330 & dble(NPIV)*dble(NPIV)*dble(NPIV) + 3331 & dble(NPIV)*dble(NPIV)*dble(NCB) 3332 WK_SLAVE = dble( NPIV ) * dble( NCB ) * 3333 & ( 2.0D0 * dble(NFRONT) - dble(NPIV) ) 3334 & / dble(NSLAVES_ESTIM) 3335 ELSE 3336 WK_MASTER = dble(NPIV)*dble(NPIV)*dble(NPIV) / dble(3) 3337 WK_SLAVE = 3338 & (dble(NPIV)*dble(NCB)*dble(NFRONT)) 3339 & / dble(NSLAVES_ESTIM) 3340 ENDIF 3341 IF (KEEP(210).EQ.1) THEN 3342 IF ( dble( 100 + STRAT ) 3343 & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN 3344 ELSE 3345 IF ( dble( 100 + STRAT * max( DEPTH-1, 1 ) ) 3346 & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN 3347 ENDIF 3348 333 CONTINUE 3349 IF (NPIV .LE. 1 ) RETURN 3350 NSTEPS = NSTEPS + 1 3351 TOT_CUT = TOT_CUT + 1 3352 NPIV_SON = max(NPIV/2,1) 3353 NPIV_FATH = NPIV - NPIV_SON 3354 INODE_SON = INODE 3355 IN_SON = INODE 3356 DO I = 1, NPIV_SON - 1 3357 IN_SON = FILS( IN_SON ) 3358 END DO 3359 INODE_FATH = FILS( IN_SON ) 3360 IF ( INODE_FATH .LT. 0 ) THEN 3361 write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH 3362 END IF 3363 IN_FATH = INODE_FATH 3364 DO WHILE ( FILS( IN_FATH ) > 0 ) 3365 IN_FATH = FILS( IN_FATH ) 3366 END DO 3367 FRERE( INODE_FATH ) = FRERE( INODE_SON ) 3368 FRERE( INODE_SON ) = - INODE_FATH 3369 FILS ( IN_SON ) = FILS( IN_FATH ) 3370 FILS ( IN_FATH ) = - INODE_SON 3371 IN = FRERE( INODE_FATH ) 3372 DO WHILE ( IN > 0 ) 3373 IN = FRERE( IN ) 3374 END DO 3375 IF ( IN .eq. 0 ) GO TO 10 3376 IN = -IN 3377 DO WHILE ( FILS( IN ) > 0 ) 3378 IN = FILS( IN ) 3379 END DO 3380 IN_GRANDFATH = IN 3381 IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN 3382 FILS( IN_GRANDFATH ) = -INODE_FATH 3383 ELSE 3384 IN = IN_GRANDFATH 3385 IN = - FILS ( IN ) 3386 DO WHILE ( FRERE( IN ) > 0 ) 3387 IF ( FRERE( IN ) .eq. INODE_SON ) THEN 3388 FRERE( IN ) = INODE_FATH 3389 GOTO 10 3390 END IF 3391 IN = FRERE( IN ) 3392 END DO 3393 WRITE(*,*) 'ERROR 2 in SPLIT NODE', 3394 & IN_GRANDFATH, IN, FRERE(IN) 3395 END IF 3396 10 CONTINUE 3397 NFSIZ(INODE_SON) = NFRONT 3398 NFSIZ(INODE_FATH) = NFRONT - NPIV_SON 3399 KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) 3400 CALL DMUMPS_313 3401 & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, 3402 & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, 3403 & K79, SPLITROOT, MP, LDIAG ) 3404 IF (.NOT. SPLITROOT) THEN 3405 CALL DMUMPS_313 3406 & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, 3407 & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, 3408 & K79, SPLITROOT, MP, LDIAG ) 3409 ENDIF 3410 RETURN 3411 END SUBROUTINE DMUMPS_313 3412 SUBROUTINE DMUMPS_351 3413 & (N,NZ, IRN, ICN, IW, LW, IPE, LEN, 3414 & IQ, FLAG, IWFR, 3415 & NRORM, NIORM, IFLAG,IERROR, ICNTL, 3416 & symmetry, SYM, MedDens, NBQD, AvgDens) 3417 INTEGER N,NZ,LW,IFLAG,IERROR,NRORM,NIORM,IWFR 3418 INTEGER symmetry, SYM 3419 INTEGER MedDens, NBQD, AvgDens 3420 INTEGER ICNTL(40) 3421 INTEGER IRN(NZ), ICN(NZ) 3422 INTEGER LEN(N) 3423 INTEGER IPE(N+1) 3424 INTEGER FLAG(N), IW(LW) 3425 INTEGER IQ(N) 3426 INTEGER MP, MPG 3427 INTEGER I,K,J,N1,LAST,NDUP,K1,K2,L 3428 INTEGER NBERR, THRESH 3429 INTEGER NZOFFA, NDIAGA 3430 DOUBLE PRECISION RSYM 3431 INTRINSIC nint 3432 MP = ICNTL(2) 3433 MPG= ICNTL(3) 3434 NIORM = 3*N 3435 NDIAGA = 0 3436 IERROR = 0 3437 DO 10 I=1,N 3438 IPE(I) = 0 3439 10 CONTINUE 3440 DO 50 K=1,NZ 3441 I = IRN(K) 3442 J = ICN(K) 3443 IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) 3444 & .OR.(J.LT.1)) THEN 3445 IERROR = IERROR + 1 3446 ELSE 3447 IF (I.NE.J) THEN 3448 IPE(I) = IPE(I) + 1 3449 IPE(J) = IPE(J) + 1 3450 NIORM = NIORM + 1 3451 ELSE 3452 NDIAGA = NDIAGA + 1 3453 ENDIF 3454 ENDIF 3455 50 CONTINUE 3456 NZOFFA = NIORM - 3*N 3457 IF (IERROR.GE.1) THEN 3458 NBERR = 0 3459 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 3460 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN 3461 WRITE (MP,99999) 3462 DO 70 K=1,NZ 3463 I = IRN(K) 3464 J = ICN(K) 3465 IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) 3466 & .OR.(J.LT.1)) THEN 3467 NBERR = NBERR + 1 3468 IF (NBERR.LE.10) THEN 3469 IF (mod(K,10).GT.3 .OR. mod(K,10).EQ.0 .OR. 3470 & (10.LE.K .AND. K.LE.20)) THEN 3471 WRITE (MP,'(I8,A,I8,A,I8,A)') 3472 & K,'th entry (in row',I,' and column',J,') ignored' 3473 ELSE 3474 IF (mod(K,10).EQ.1) WRITE(MP,'(I8,A,I8,A,I8,A)') 3475 & K,'st entry (in row',I,' and column',J,') ignored' 3476 IF (mod(K,10).EQ.2) WRITE(MP,'(I8,A,I8,A,I8,A)') 3477 & K,'nd entry (in row',I,' and column',J,') ignored' 3478 IF (mod(K,10).EQ.3) WRITE(MP,'(I8,A,I8,A,I8,A)') 3479 & K,'rd entry (in row',I,' and column',J,') ignored' 3480 ENDIF 3481 ELSE 3482 GO TO 100 3483 ENDIF 3484 ENDIF 3485 70 CONTINUE 3486 ENDIF 3487 ENDIF 3488 100 NRORM = NIORM - 2*N 3489 IQ(1) = 1 3490 N1 = N - 1 3491 IF (N1.GT.0) THEN 3492 DO 110 I=1,N1 3493 IQ(I+1) = IPE(I) + IQ(I) 3494 110 CONTINUE 3495 ENDIF 3496 LAST = max(IPE(N)+IQ(N)-1,IQ(N)) 3497 FLAG(1:N) = 0 3498 IPE(1:N) = IQ(1:N) 3499 IW(1:LAST) = 0 3500 IWFR = LAST + 1 3501 DO 200 K=1,NZ 3502 I = IRN(K) 3503 J = ICN(K) 3504 IF (I.NE.J) THEN 3505 IF (I.LT.J) THEN 3506 IF ((I.GE.1).AND.(J.LE.N)) THEN 3507 IW(IQ(I)) = -J 3508 IQ(I) = IQ(I) + 1 3509 ENDIF 3510 ELSE 3511 IF ((J.GE.1).AND.(I.LE.N)) THEN 3512 IW(IQ(J)) = -I 3513 IQ(J) = IQ(J) + 1 3514 ENDIF 3515 ENDIF 3516 ENDIF 3517 200 CONTINUE 3518 NDUP = 0 3519 DO 260 I=1,N 3520 K1 = IPE(I) 3521 K2 = IQ(I) -1 3522 IF (K1.GT.K2) THEN 3523 LEN(I) = 0 3524 IQ(I) = 0 3525 ELSE 3526 DO 240 K=K1,K2 3527 J = -IW(K) 3528 IF (J.LE.0) GO TO 250 3529 L = IQ(J) 3530 IQ(J) = L + 1 3531 IF (FLAG(J).EQ.I) THEN 3532 NDUP = NDUP + 1 3533 IW(L) = 0 3534 IW(K) = 0 3535 ELSE 3536 IW(L) = I 3537 IW(K) = J 3538 FLAG(J) = I 3539 ENDIF 3540 240 CONTINUE 3541 250 IQ(I) = IQ(I) - IPE(I) 3542 IF (NDUP.EQ.0) LEN(I) = IQ(I) 3543 ENDIF 3544 260 CONTINUE 3545 IF (NDUP.NE.0) THEN 3546 IWFR = 1 3547 DO 280 I=1,N 3548 IF (IQ(I).EQ.0) THEN 3549 LEN(I) = 0 3550 IPE(I) = IWFR 3551 GOTO 280 3552 ENDIF 3553 K1 = IPE(I) 3554 K2 = K1 + IQ(I) - 1 3555 L = IWFR 3556 IPE(I) = IWFR 3557 DO 270 K=K1,K2 3558 IF (IW(K).NE.0) THEN 3559 IW(IWFR) = IW(K) 3560 IWFR = IWFR + 1 3561 ENDIF 3562 270 CONTINUE 3563 LEN(I) = IWFR - L 3564 280 CONTINUE 3565 ENDIF 3566 IPE(N+1) = IPE(N) + LEN(N) 3567 IWFR = IPE(N+1) 3568 IF (SYM.EQ.0) THEN 3569 RSYM = dble(NDIAGA+2*NZOFFA - (IWFR-1))/ 3570 & dble(NZOFFA+NDIAGA) 3571 symmetry = nint (100.0D0*RSYM) 3572 IF (MPG .GT. 0) 3573 & write(MPG,'(A,I5)') 3574 & ' ... Structural symmetry (in percent)=', symmetry 3575 IF (MP.GT.0 .AND. MPG.NE.MP) 3576 & write(MP,'(A,I5)') 3577 & ' ... Structural symmetry (in percent)=', symmetry 3578 ELSE 3579 symmetry = 100 3580 ENDIF 3581 AvgDens = nint(dble(IWFR-1)/dble(N)) 3582 THRESH = AvgDens*50 - AvgDens/10 + 1 3583 NBQD = 0 3584 IF (N.GT.2) THEN 3585 IQ(1:N) = 0 3586 DO I= 1, N 3587 K = max(LEN(I),1) 3588 IQ(K) = IQ(K) + 1 3589 IF (K.GT.THRESH) NBQD = NBQD+1 3590 ENDDO 3591 K = 0 3592 MedDens = 0 3593 DO WHILE (K .LT. (N/2)) 3594 MedDens = MedDens + 1 3595 K = K+IQ(MedDens) 3596 ENDDO 3597 ELSE 3598 MedDens = AvgDens 3599 ENDIF 3600 IF (MPG .GT. 0) 3601 & write(MPG,'(A,3I5)') 3602 & ' Density: NBdense, Average, Median =', 3603 & NBQD, AvgDens, MedDens 3604 IF (MP.GT.0 .AND. MPG.NE.MP) 3605 & write(MP,'(A,3I5)') 3606 & ' Density: NBdense, Average, Median =', 3607 & NBQD, AvgDens, MedDens 3608 RETURN 360999999 FORMAT (/'*** Warning message from analysis routine ***') 3610 END SUBROUTINE DMUMPS_351 3611 SUBROUTINE DMUMPS_701(N, SYM, NPROCS, IORD, 3612 & symmetry,MedDens, NBQD, AvgDens, 3613 & PROK, MP) 3614 IMPLICIT NONE 3615 INTEGER, intent(in) :: N, NPROCS, SYM 3616 INTEGER, intent(in) :: symmetry,MedDens, NBQD, AvgDens, MP 3617 LOGICAL, intent(in) :: PROK 3618 INTEGER, intent(inout) :: IORD 3619 INTEGER MAXQD 3620 PARAMETER (MAXQD=2) 3621 INTEGER SMALLSYM, SMALLUNS 3622 PARAMETER (SMALLUNS=5000, SMALLSYM=10000) 3623#if ! defined(metis) && ! defined(parmetis) 3624 IF ( IORD .EQ. 5 ) THEN 3625 IF (PROK) WRITE(MP,*) 3626 & 'WARNING: METIS not available. Ordering set to default.' 3627 IORD = 7 3628 END IF 3629#endif 3630#if ! defined(pord) 3631 IF ( IORD .EQ. 4 ) THEN 3632 IF (PROK) WRITE(MP,*) 3633 & 'WARNING: PORD not available. Ordering set to default.' 3634 IORD = 7 3635 END IF 3636#endif 3637#if ! defined(scotch) && ! defined(ptscotch) 3638 IF ( IORD .EQ. 3 ) THEN 3639 IF (PROK) WRITE(MP,*) 3640 & 'WARNING: SCOTCH not available. Ordering set to default.' 3641 IORD = 7 3642 END IF 3643#endif 3644 IF (IORD.EQ.7) THEN 3645 IF (SYM.NE.0) THEN 3646 IF ( N.LE.SMALLSYM ) THEN 3647 IF (NBQD.GE.MAXQD) THEN 3648 IORD = 6 3649 ELSE 3650 IORD = 0 3651 ENDIF 3652 ELSE 3653 IF (NBQD.GE.MedDens*NPROCS) THEN 3654 IORD = 6 3655 RETURN 3656 ENDIF 3657#if defined(metis) || defined(parmetis) 3658 IORD = 5 3659#else 3660# if defined(scotch) || defined(ptscotch) 3661 IORD = 3 3662# else 3663# if defined(pord) 3664 IORD = 4 3665# else 3666 IORD = 6 3667# endif 3668# endif 3669#endif 3670 ENDIF 3671 ELSE 3672 IF ( N.LE.SMALLUNS ) THEN 3673 IF (NBQD.GE.MAXQD) THEN 3674 IORD = 6 3675 ELSE 3676 IORD = 0 3677 ENDIF 3678 ELSE 3679 IF (NBQD.GE.MedDens*NPROCS) THEN 3680 IORD = 6 3681 RETURN 3682 ENDIF 3683#if defined(metis) || defined(parmetis) 3684 IORD = 5 3685#else 3686# if defined(scotch) || defined(ptscotch) 3687 IORD = 3 3688# else 3689# if defined(pord) 3690 IORD = 4 3691# else 3692 IORD = 6 3693# endif 3694# endif 3695#endif 3696 ENDIF 3697 ENDIF 3698 ENDIF 3699 RETURN 3700 END SUBROUTINE DMUMPS_701 3701 SUBROUTINE DMUMPS_510 3702 & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) 3703 IMPLICIT NONE 3704 INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 3705 INTEGER (8) :: KEEP821 3706 INTEGER(8) KEEP2_SQUARE, NSLAVES8 3707 NSLAVES8= int(NSLAVES,8) 3708 KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) 3709 KEEP821 = max(KEEP821*int(KEEP2,8),1_8) 3710#if defined(t3e) 3711 KEEP821 = min(1500000_8, KEEP821) 3712#elif defined(SP_) 3713 KEEP821 = min(3000000_8, KEEP821) 3714#else 3715 KEEP821 = min(2000000_8, KEEP821) 3716#endif 3717#if defined(t3e) 3718 IF (NSLAVES .GT. 64) THEN 3719 KEEP821 = 3720 & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) 3721 ELSE 3722 KEEP821 = 3723 & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) 3724 ENDIF 3725#else 3726 IF (NSLAVES.GT.64) THEN 3727 KEEP821 = 3728 & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) 3729 ELSE 3730 KEEP821 = 3731 & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) 3732 ENDIF 3733#endif 3734 IF (KEEP50 .EQ. 0 ) THEN 3735 KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / 3736 & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) 3737 ELSE 3738 KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / 3739 & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) 3740 ENDIF 3741 IF (KEEP50 .EQ. 0 ) THEN 3742#if defined(t3e) 3743 KEEP821 = max(KEEP821,200000_8) 3744#else 3745 KEEP821 = max(KEEP821,300000_8) 3746#endif 3747 ELSE 3748#if defined(t3e) 3749 KEEP821 = max(KEEP821,40000_8) 3750#else 3751 KEEP821 = max(KEEP821,80000_8) 3752#endif 3753 ENDIF 3754 KEEP821 = -KEEP821 3755 RETURN 3756 END SUBROUTINE DMUMPS_510 3757 SUBROUTINE DMUMPS_559(JOB,M,N,NE, 3758 & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, 3759 & ICNTL,CNTL,INFO) 3760 IMPLICIT NONE 3761 INTEGER NICNTL, NCNTL, NINFO 3762 PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) 3763 INTEGER JOB,M,N,NE,NUM,LIW,LDW 3764 INTEGER IP(N+1),IRN(NE),PERM(M),IW(LIW) 3765 INTEGER ICNTL(NICNTL),INFO(NINFO) 3766 INTEGER LA 3767 DOUBLE PRECISION A(LA) 3768 DOUBLE PRECISION DW(LDW),CNTL(NCNTL) 3769 INTEGER I,J,K,WARN1,WARN2,WARN4 3770 DOUBLE PRECISION FACT,ZERO,ONE,RINF,RINF2,RINF3 3771 PARAMETER (ZERO=0.0D+00,ONE=1.0D+0) 3772 EXTERNAL DMUMPS_457,DMUMPS_444,DMUMPS_451, 3773 & DMUMPS_452,DMUMPS_454 3774 INTRINSIC abs,log 3775 RINF = CNTL(2) 3776 RINF2 = huge(RINF2)/dble(2*N) 3777 RINF3 = 0.0D0 3778 WARN1 = 0 3779 WARN2 = 0 3780 WARN4 = 0 3781 IF (JOB.LT.1 .OR. JOB.GT.6) THEN 3782 INFO(1) = -1 3783 INFO(2) = JOB 3784 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB 3785 GO TO 99 3786 ENDIF 3787 IF (M.LT.1 .OR. M.LT.N) THEN 3788 INFO(1) = -2 3789 INFO(2) = M 3790 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M 3791 GO TO 99 3792 ENDIF 3793 IF (N.LT.1) THEN 3794 INFO(1) = -2 3795 INFO(2) = N 3796 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N 3797 GO TO 99 3798 ENDIF 3799 IF (NE.LT.1) THEN 3800 INFO(1) = -3 3801 INFO(2) = NE 3802 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE 3803 GO TO 99 3804 ENDIF 3805 IF (JOB.EQ.1) K = 4*N + M 3806 IF (JOB.EQ.2) K = 2*N + 2*M 3807 IF (JOB.EQ.3) K = 8*N + 2*M + NE 3808 IF (JOB.EQ.4) K = 3*N + 2*M 3809 IF (JOB.EQ.5) K = 3*N + 2*M 3810 IF (JOB.EQ.6) K = 3*N + 2*M + NE 3811 IF (LIW.LT.K) THEN 3812 INFO(1) = -4 3813 INFO(2) = K 3814 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K 3815 GO TO 99 3816 ENDIF 3817 IF (JOB.GT.1) THEN 3818 IF (JOB.EQ.2) K = M 3819 IF (JOB.EQ.3) K = 1 3820 IF (JOB.EQ.4) K = 2*M 3821 IF (JOB.EQ.5) K = N + 2*M 3822 IF (JOB.EQ.6) K = N + 3*M 3823 IF (LDW.LT.K) THEN 3824 INFO(1) = -5 3825 INFO(2) = K 3826 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K 3827 GO TO 99 3828 ENDIF 3829 ENDIF 3830 IF (ICNTL(5).EQ.0) THEN 3831 DO 3 I = 1,M 3832 IW(I) = 0 3833 3 CONTINUE 3834 DO 6 J = 1,N 3835 DO 4 K = IP(J),IP(J+1)-1 3836 I = IRN(K) 3837 IF (I.LT.1 .OR. I.GT.M) THEN 3838 INFO(1) = -6 3839 INFO(2) = J 3840 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I 3841 GO TO 99 3842 ENDIF 3843 IF (IW(I).EQ.J) THEN 3844 INFO(1) = -7 3845 INFO(2) = J 3846 IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I 3847 GO TO 99 3848 ELSE 3849 IW(I) = J 3850 ENDIF 3851 4 CONTINUE 3852 6 CONTINUE 3853 ENDIF 3854 IF (ICNTL(3).GE.0) THEN 3855 IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN 3856 WRITE(ICNTL(3),9020) JOB,M,N,NE 3857 IF (ICNTL(4).EQ.0) THEN 3858 WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) 3859 WRITE(ICNTL(3),9022) (IRN(J),J=1,min(10,NE)) 3860 IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,min(10,NE)) 3861 ELSEIF (ICNTL(4).EQ.1) THEN 3862 WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) 3863 WRITE(ICNTL(3),9022) (IRN(J),J=1,NE) 3864 IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(J),J=1,NE) 3865 ENDIF 3866 WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) 3867 WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) 3868 ENDIF 3869 ENDIF 3870 DO 8 I=1,NINFO 3871 INFO(I) = 0 3872 8 CONTINUE 3873 IF (JOB.EQ.1) THEN 3874 DO 10 J = 1,N 3875 IW(J) = IP(J+1) - IP(J) 3876 10 CONTINUE 3877 CALL DMUMPS_457(M,N,IRN,NE,IP,IW(1),PERM,NUM, 3878 & IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1)) 3879 GO TO 90 3880 ENDIF 3881 IF (JOB.EQ.2) THEN 3882 DW(1) = max(ZERO,CNTL(1)) 3883 CALL DMUMPS_444(M,N,NE,IP,IRN,A,PERM,NUM, 3884 & IW(1),IW(N+1),IW(2*N+1),IW(2*N+M+1),DW,RINF2) 3885 GO TO 90 3886 ENDIF 3887 IF (JOB.EQ.3) THEN 3888 DO 20 K = 1,NE 3889 IW(K) = IRN(K) 3890 20 CONTINUE 3891 CALL DMUMPS_451(N,NE,IP,IW,A) 3892 FACT = max(ZERO,CNTL(1)) 3893 CALL DMUMPS_452(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1), 3894 & IW(NE+N+1),IW(NE+2*N+1),IW(NE+3*N+1),IW(NE+4*N+1), 3895 & IW(NE+5*N+1),IW(NE+5*N+M+1),FACT,RINF2) 3896 GO TO 90 3897 ENDIF 3898 IF (JOB.EQ.4) THEN 3899 DO 50 J = 1,N 3900 FACT = ZERO 3901 DO 30 K = IP(J),IP(J+1)-1 3902 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 3903 30 CONTINUE 3904 IF(FACT .GT. RINF3) RINF3 = FACT 3905 DO 40 K = IP(J),IP(J+1)-1 3906 A(K) = FACT - abs(A(K)) 3907 40 CONTINUE 3908 50 CONTINUE 3909 DW(1) = max(ZERO,CNTL(1)) 3910 DW(2) = RINF3 3911 IW(1) = JOB 3912 CALL DMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, 3913 & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), 3914 & DW(1),DW(M+1),RINF2) 3915 GO TO 90 3916 ENDIF 3917 IF (JOB.EQ.5 .or. JOB.EQ.6) THEN 3918 RINF3=ONE 3919 IF (JOB.EQ.5) THEN 3920 DO 75 J = 1,N 3921 FACT = ZERO 3922 DO 60 K = IP(J),IP(J+1)-1 3923 IF (A(K).GT.FACT) FACT = A(K) 3924 60 CONTINUE 3925 DW(2*M+J) = FACT 3926 IF (FACT.NE.ZERO) THEN 3927 FACT = log(FACT) 3928 IF(FACT .GT. RINF3) RINF3=FACT 3929 DO 70 K = IP(J),IP(J+1)-1 3930 IF (A(K).NE.ZERO) THEN 3931 A(K) = FACT - log(A(K)) 3932 IF(A(K) .GT. RINF3) RINF3=A(K) 3933 ELSE 3934 A(K) = FACT + RINF 3935 ENDIF 3936 70 CONTINUE 3937 ELSE 3938 DO 71 K = IP(J),IP(J+1)-1 3939 A(K) = ONE 3940 71 CONTINUE 3941 ENDIF 3942 75 CONTINUE 3943 ENDIF 3944 IF (JOB.EQ.6) THEN 3945 DO 175 K = 1,NE 3946 IW(3*N+2*M+K) = IRN(K) 3947 175 CONTINUE 3948 DO 61 I = 1,M 3949 DW(2*M+N+I) = ZERO 3950 61 CONTINUE 3951 DO 63 J = 1,N 3952 DO 62 K = IP(J),IP(J+1)-1 3953 I = IRN(K) 3954 IF (A(K).GT.DW(2*M+N+I)) THEN 3955 DW(2*M+N+I) = A(K) 3956 ENDIF 3957 62 CONTINUE 3958 63 CONTINUE 3959 DO 64 I = 1,M 3960 IF (DW(2*M+N+I).NE.ZERO) THEN 3961 DW(2*M+N+I) = 1.0D0/DW(2*M+N+I) 3962 ENDIF 3963 64 CONTINUE 3964 DO 66 J = 1,N 3965 DO 65 K = IP(J),IP(J+1)-1 3966 I = IRN(K) 3967 A(K) = DW(2*M+N+I) * A(K) 3968 65 CONTINUE 3969 66 CONTINUE 3970 CALL DMUMPS_451(N,NE,IP,IW(3*N+2*M+1),A) 3971 DO 176 J = 1,N 3972 IF (IP(J).NE.IP(J+1)) THEN 3973 FACT = A(IP(J)) 3974 ELSE 3975 FACT = ZERO 3976 ENDIF 3977 DW(2*M+J) = FACT 3978 IF (FACT.NE.ZERO) THEN 3979 FACT = log(FACT) 3980 DO 170 K = IP(J),IP(J+1)-1 3981 IF (A(K).NE.ZERO) THEN 3982 A(K) = FACT - log(A(K)) 3983 IF(A(K) .GT. RINF3) RINF3=A(K) 3984 ELSE 3985 A(K) = FACT + RINF 3986 ENDIF 3987 170 CONTINUE 3988 ELSE 3989 DO 171 K = IP(J),IP(J+1)-1 3990 A(K) = ONE 3991 171 CONTINUE 3992 ENDIF 3993 176 CONTINUE 3994 ENDIF 3995 DW(1) = max(ZERO,CNTL(1)) 3996 RINF3 = RINF3+ONE 3997 DW(2) = RINF3 3998 IW(1) = JOB 3999 IF (JOB.EQ.5) THEN 4000 CALL DMUMPS_454(M,N,NE,IP,IRN,A,PERM,NUM, 4001 & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), 4002 & DW(1),DW(M+1),RINF2) 4003 ENDIF 4004 IF (JOB.EQ.6) THEN 4005 CALL DMUMPS_454(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, 4006 & IW(1),IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1), 4007 & DW(1),DW(M+1),RINF2) 4008 ENDIF 4009 IF (JOB.EQ.6) THEN 4010 DO 79 I = 1,M 4011 IF (DW(2*M+N+I).NE.0.0D0) THEN 4012 DW(I) = DW(I) + log(DW(2*M+N+I)) 4013 ENDIF 4014 79 CONTINUE 4015 ENDIF 4016 IF (NUM.EQ.N) THEN 4017 DO 80 J = 1,N 4018 IF (DW(2*M+J).NE.ZERO) THEN 4019 DW(M+J) = DW(M+J) - log(DW(2*M+J)) 4020 ELSE 4021 DW(M+J) = ZERO 4022 ENDIF 4023 80 CONTINUE 4024 ENDIF 4025 FACT = 0.5D0*log(RINF2) 4026 DO 86 I = 1,M 4027 IF (DW(I).LT.FACT) GO TO 86 4028 WARN2 = 2 4029 GO TO 90 4030 86 CONTINUE 4031 DO 87 J = 1,N 4032 IF (DW(M+J).LT.FACT) GO TO 87 4033 WARN2 = 2 4034 GO TO 90 4035 87 CONTINUE 4036 ENDIF 4037 90 IF (NUM.LT.N) WARN1 = 1 4038 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN 4039 IF (CNTL(1).LT.ZERO) WARN4 = 4 4040 ENDIF 4041 IF (INFO(1).EQ.0) THEN 4042 INFO(1) = WARN1 + WARN2 + WARN4 4043 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN 4044 WRITE(ICNTL(2),9010) INFO(1) 4045 IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) 4046 IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) 4047 IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) 4048 ENDIF 4049 ENDIF 4050 IF (ICNTL(3).GE.0) THEN 4051 IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN 4052 WRITE(ICNTL(3),9030) (INFO(J),J=1,2) 4053 WRITE(ICNTL(3),9031) NUM 4054 IF (ICNTL(4).EQ.0) THEN 4055 WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) 4056 IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN 4057 WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) 4058 WRITE(ICNTL(3),9034) (DW(M+J),J=1,min(10,N)) 4059 ENDIF 4060 ELSEIF (ICNTL(4).EQ.1) THEN 4061 WRITE(ICNTL(3),9032) (PERM(J),J=1,M) 4062 IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN 4063 WRITE(ICNTL(3),9033) (DW(J),J=1,M) 4064 WRITE(ICNTL(3),9034) (DW(M+J),J=1,N) 4065 ENDIF 4066 ENDIF 4067 ENDIF 4068 ENDIF 4069 99 RETURN 4070 9001 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2, 4071 & ' because ',(A),' = ',I10) 4072 9004 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ 4073 & ' LIW too small, must be at least ',I8) 4074 9005 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ 4075 & ' LDW too small, must be at least ',I8) 4076 9006 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ 4077 & ' Column ',I8, 4078 & ' contains an entry with invalid row index ',I8) 4079 9007 FORMAT (' ****** Error in DMUMPS_443. INFO(1) = ',I2/ 4080 & ' Column ',I8, 4081 & ' contains two or more entries with row index ',I8) 4082 9010 FORMAT (' ****** Warning from DMUMPS_443. INFO(1) = ',I2) 4083 9011 FORMAT (' - The matrix is structurally singular.') 4084 9012 FORMAT (' - Some scaling factors may be too large.') 4085 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 4086 9020 FORMAT (' ****** Input parameters for DMUMPS_443:'/ 4087 & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I10) 4088 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 4089 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 4090 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 4091 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 4092 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 4093 9030 FORMAT (' ****** Output parameters for DMUMPS_443:'/ 4094 & ' INFO(1:2) = ',2I8) 4095 9031 FORMAT (' NUM = ',I8) 4096 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 4097 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 4098 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) 4099 END SUBROUTINE DMUMPS_559 4100 SUBROUTINE DMUMPS_563(N,NZ,IP,IRN,A,FLAG,POSI) 4101 IMPLICIT NONE 4102 INTEGER N,NZ 4103 INTEGER IP(N+1),IRN(NZ) 4104 DOUBLE PRECISION A(NZ) 4105 INTEGER WR_POS,BEG_COL,ROW,COL,K,SV_POS 4106 INTEGER FLAG(N), POSI(N) 4107 FLAG = 0 4108 WR_POS = 1 4109 DO COL=1,N 4110 BEG_COL = WR_POS 4111 DO K=IP(COL),IP(COL+1)-1 4112 ROW = IRN(K) 4113 IF(FLAG(ROW) .NE. COL) THEN 4114 IRN(WR_POS) = ROW 4115 A(WR_POS) = A(K) 4116 FLAG(ROW) = COL 4117 POSI(ROW) = WR_POS 4118 WR_POS = WR_POS+1 4119 ELSE 4120 SV_POS = POSI(ROW) 4121 A(SV_POS) = A(SV_POS) + A(K) 4122 ENDIF 4123 ENDDO 4124 IP(COL) = BEG_COL 4125 ENDDO 4126 IP(N+1) = WR_POS 4127 NZ = WR_POS-1 4128 RETURN 4129 END SUBROUTINE DMUMPS_563 4130 SUBROUTINE DMUMPS_562(N,NZ,IP,IRN,FLAG,POSI) 4131 IMPLICIT NONE 4132 INTEGER N,NZ 4133 INTEGER IP(N+1),IRN(NZ) 4134 INTEGER WR_POS,BEG_COL,ROW,COL,K 4135 INTEGER FLAG(N), POSI(N) 4136 FLAG = 0 4137 WR_POS = 1 4138 DO COL=1,N 4139 BEG_COL = WR_POS 4140 DO K=IP(COL),IP(COL+1)-1 4141 ROW = IRN(K) 4142 IF(FLAG(ROW) .NE. COL) THEN 4143 IRN(WR_POS) = ROW 4144 FLAG(ROW) = COL 4145 POSI(ROW) = WR_POS 4146 WR_POS = WR_POS+1 4147 ENDIF 4148 ENDDO 4149 IP(COL) = BEG_COL 4150 ENDDO 4151 IP(N+1) = WR_POS 4152 NZ = WR_POS-1 4153 RETURN 4154 END SUBROUTINE DMUMPS_562 4155 SUBROUTINE DMUMPS_181( N, NA, LNA, NE_STEPS, 4156 & PERM, FILS, 4157 & DAD_STEPS, STEP, NSTEPS, INFO) 4158 IMPLICIT NONE 4159 INTEGER, INTENT(IN) :: N, NSTEPS, LNA 4160 INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) 4161 INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) 4162 INTEGER, INTENT(INOUT) :: INFO(40) 4163 INTEGER, INTENT(OUT) :: PERM( N ) 4164 INTEGER :: IPERM, INODE, IN 4165 INTEGER :: INBLEAF, INBROOT, allocok 4166 INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK 4167 INBLEAF = NA(1) 4168 INBROOT = NA(2) 4169 ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) 4170 IF (allocok > 0 ) THEN 4171 INFO(1) = -7 4172 INFO(2) = INBLEAF + NSTEPS 4173 RETURN 4174 ENDIF 4175 POOL(1:INBLEAF) = NA(3:2+INBLEAF) 4176 NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) 4177 IPERM = 1 4178 DO WHILE ( INBLEAF .NE. 0 ) 4179 INODE = POOL( INBLEAF ) 4180 INBLEAF = INBLEAF - 1 4181 IN = INODE 4182 DO WHILE ( IN .GT. 0 ) 4183 PERM ( IN ) = IPERM 4184 IPERM = IPERM + 1 4185 IN = FILS( IN ) 4186 END DO 4187 IN = DAD_STEPS(STEP( INODE )) 4188 IF ( IN .eq. 0 ) THEN 4189 INBROOT = INBROOT - 1 4190 ELSE 4191 NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 4192 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN 4193 INBLEAF = INBLEAF + 1 4194 POOL( INBLEAF ) = IN 4195 END IF 4196 END IF 4197 END DO 4198 DEALLOCATE(POOL, NSTK) 4199 RETURN 4200 END SUBROUTINE DMUMPS_181 4201 SUBROUTINE DMUMPS_746( ID, PTRAR ) 4202 USE DMUMPS_STRUC_DEF 4203 IMPLICIT NONE 4204 include 'mpif.h' 4205 TYPE(DMUMPS_STRUC), INTENT(IN), TARGET :: ID 4206 INTEGER, TARGET :: PTRAR(ID%N,2) 4207 INTEGER :: IERR 4208 INTEGER :: IOLD, K, JOLD, INEW, JNEW, INZ 4209 INTEGER, POINTER :: IIRN(:), IJCN(:), IWORK1(:), IWORK2(:) 4210 LOGICAL :: IDO, PARANAL 4211 PARANAL = .TRUE. 4212 IF (PARANAL) THEN 4213 IF(ID%KEEP(54) .EQ. 3) THEN 4214 IIRN => ID%IRN_loc 4215 IJCN => ID%JCN_loc 4216 INZ = ID%NZ_loc 4217 IWORK1 => PTRAR(1:ID%N,2) 4218 allocate(IWORK2(ID%N)) 4219 IDO = .TRUE. 4220 ELSE 4221 IIRN => ID%IRN 4222 IJCN => ID%JCN 4223 INZ = ID%NZ 4224 IWORK1 => PTRAR(1:ID%N,1) 4225 IWORK2 => PTRAR(1:ID%N,2) 4226 IDO = ID%MYID .EQ. 0 4227 END IF 4228 ELSE 4229 IIRN => ID%IRN 4230 IJCN => ID%JCN 4231 INZ = ID%NZ 4232 IWORK1 => PTRAR(1:ID%N,1) 4233 IWORK2 => PTRAR(1:ID%N,2) 4234 IDO = ID%MYID .EQ. 0 4235 END IF 4236 DO 50 IOLD=1,ID%N 4237 IWORK1(IOLD) = 0 4238 IWORK2(IOLD) = 0 4239 50 CONTINUE 4240 IF(IDO) THEN 4241 DO 70 K=1,INZ 4242 IOLD = IIRN(K) 4243 JOLD = IJCN(K) 4244 IF ( (IOLD.GT.ID%N).OR.(JOLD.GT.ID%N).OR.(IOLD.LT.1) 4245 & .OR.(JOLD.LT.1) ) GOTO 70 4246 IF (IOLD.NE.JOLD) THEN 4247 INEW = ID%SYM_PERM(IOLD) 4248 JNEW = ID%SYM_PERM(JOLD) 4249 IF ( ID%KEEP( 50 ) .EQ. 0 ) THEN 4250 IF (INEW.LT.JNEW) THEN 4251 IWORK2(IOLD) = IWORK2(IOLD) + 1 4252 ELSE 4253 IWORK1(JOLD) = IWORK1(JOLD) + 1 4254 ENDIF 4255 ELSE 4256 IF ( INEW .LT. JNEW ) THEN 4257 IWORK1( IOLD ) = IWORK1( IOLD ) + 1 4258 ELSE 4259 IWORK1( JOLD ) = IWORK1( JOLD ) + 1 4260 END IF 4261 ENDIF 4262 ENDIF 4263 70 CONTINUE 4264 END IF 4265 IF(PARANAL .AND. (ID%KEEP(54) .EQ. 3) ) THEN 4266 CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1,1), ID%N, MPI_INTEGER, 4267 & MPI_SUM, ID%COMM, IERR ) 4268 CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), ID%N, MPI_INTEGER, 4269 & MPI_SUM, ID%COMM, IERR ) 4270 deallocate(IWORK2) 4271 ELSE 4272 CALL MPI_BCAST( PTRAR, 2*ID%N, MPI_INTEGER, 4273 & 0, ID%COMM, IERR ) 4274 END IF 4275 RETURN 4276 END SUBROUTINE DMUMPS_746 4277 MODULE DMUMPS_PARALLEL_ANALYSIS 4278 USE DMUMPS_STRUC_DEF 4279 USE TOOLS_COMMON 4280 INCLUDE 'mpif.h' 4281 PUBLIC DMUMPS_715 4282 INTERFACE DMUMPS_715 4283 MODULE PROCEDURE DMUMPS_715 4284 END INTERFACE 4285 PRIVATE 4286 TYPE ORD_TYPE 4287 INTEGER :: CBLKNBR, N 4288 INTEGER, POINTER :: PERMTAB(:) => null() 4289 INTEGER, POINTER :: PERITAB(:) => null() 4290 INTEGER, POINTER :: RANGTAB(:) => null() 4291 INTEGER, POINTER :: TREETAB(:) => null() 4292 INTEGER, POINTER :: BROTHER(:) => null() 4293 INTEGER, POINTER :: SON(:) => null() 4294 INTEGER, POINTER :: NW(:) => null() 4295 INTEGER, POINTER :: FIRST(:) => null() 4296 INTEGER, POINTER :: LAST(:) => null() 4297 INTEGER, POINTER :: TOPNODES(:) => null() 4298 INTEGER :: COMM, COMM_NODES, NPROCS, NSLAVES, MYID 4299 INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS 4300 LOGICAL :: IDO 4301 END TYPE ORD_TYPE 4302 TYPE GRAPH_TYPE 4303 INTEGER :: NZ_LOC, N, COMM 4304 INTEGER, POINTER :: IRN_LOC(:) => null() 4305 INTEGER, POINTER :: JCN_LOC(:) => null() 4306 END TYPE GRAPH_TYPE 4307 TYPE ARRPNT 4308 INTEGER, POINTER :: BUF(:) => null() 4309 END TYPE ARRPNT 4310 INTEGER :: MEMCNT, MAXMEM, MP, MPG, LP, NRL, TOPROWS 4311 LOGICAL :: PROK, PROKG 4312 CONTAINS 4313 SUBROUTINE DMUMPS_715(id, WORK1, WORK2, NFSIZ, FILS, 4314 & FRERE) 4315 USE DMUMPS_STRUC_DEF 4316 IMPLICIT NONE 4317 TYPE(DMUMPS_STRUC) :: id 4318 INTEGER, POINTER :: WORK1(:), WORK2(:), 4319 & NFSIZ(:), FILS(:), FRERE(:) 4320 TYPE(ORD_TYPE) :: ord 4321 INTEGER, POINTER :: IPE(:), NV(:), 4322 & NE(:), NA(:), NODE(:), 4323 & ND(:), SUBORD(:), NAMALG(:), 4324 & IPS(:), CUMUL(:), 4325 & SAVEIRN(:), SAVEJCN(:) 4326 INTEGER :: MYID, NPROCS, IERR, NEMIN, LDIAG 4327 LOGICAL :: SPLITROOT 4328 INTEGER(8), PARAMETER :: K79REF=12000000_8 4329 nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, 4330 & CUMUL, SAVEIRN, SAVEJCN) 4331 CALL MPI_COMM_RANK (id%COMM, MYID, IERR) 4332 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) 4333 LP = id%ICNTL(1) 4334 MP = id%ICNTL(2) 4335 MPG = id%ICNTL(3) 4336 PROK = (MP.GT.0) 4337 PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) 4338 LDIAG = id%ICNTL(4) 4339 ord%PERMTAB => WORK1(1 : id%N) 4340 ord%PERITAB => WORK1(id%N+1 : 2*id%N) 4341 ord%TREETAB => WORK1(2*id%N+1 : 3*id%N) 4342 IF(id%KEEP(54) .NE. 3) THEN 4343 IF(MYID.EQ.0) THEN 4344 SAVEIRN => id%IRN_loc 4345 SAVEJCN => id%JCN_loc 4346 id%IRN_loc => id%IRN 4347 id%JCN_loc => id%JCN 4348 id%NZ_loc = id%NZ 4349 ELSE 4350 id%NZ_loc = 0 4351 END IF 4352 END IF 4353 MAXMEM=0 4354 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4355#if defined (memprof) 4356 MEMCNT = size(work1)+ size(work2) + 4357 & size(nfsiz) + size(fils) + size(frere) 4358 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT entry:',MEMCNT,MAXMEM 4359#endif 4360 CALL DMUMPS_716(id, ord) 4361 id%INFOG(7) = id%KEEP(245) 4362 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 4363 & id%COMM, id%MYID ) 4364 IF ( id%INFO(1) .LT. 0 ) RETURN 4365 CALL DMUMPS_717(id, ord, WORK2) 4366 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 4367 & id%COMM, id%MYID ) 4368 IF ( id%INFO(1) .LT. 0 ) RETURN 4369 IF(id%MYID .EQ. 0) THEN 4370 CALL MUMPS_733(IPE, id%N, id%INFO, LP, FORCE=.FALSE., 4371 & COPY=.FALSE., STRING='', 4372 & MEMCNT=MEMCNT, ERRCODE=-7) 4373 CALL MUMPS_733(NV, id%N, id%INFO, LP, 4374 & MEMCNT=MEMCNT, ERRCODE=-7) 4375 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4376#if defined (memprof) 4377 write(mp,'(i2,a30,2(i8,5x))')myid, 4378 & 'MEMCNT ipe nv:',MEMCNT,MAXMEM 4379#endif 4380 END IF 4381 ord%SUBSTRAT = 0 4382 ord%TOPSTRAT = 0 4383 CALL DMUMPS_720(id, ord, IPE, NV, WORK2) 4384 IF(id%KEEP(54) .NE. 3) THEN 4385 IF(MYID.EQ.0) THEN 4386 id%IRN_loc => SAVEIRN 4387 id%JCN_loc => SAVEJCN 4388 END IF 4389 END IF 4390 CALL MUMPS_276( id%ICNTL(1), id%INFO(1), 4391 & id%COMM, id%MYID ) 4392 IF ( id%INFO(1) .LT. 0 ) RETURN 4393 NULLIFY(ord%PERMTAB) 4394 NULLIFY(ord%PERITAB) 4395 NULLIFY(ord%TREETAB) 4396 CALL MUMPS_734(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) 4397#if defined (memprof) 4398 write(mp,'(i2,a30,2(i8,5x))')myid, 4399 & 'MEMCNT firstlast:',MEMCNT,MAXMEM 4400#endif 4401 IF (MYID .EQ. 0) THEN 4402 IPS => WORK1(1:id%N) 4403 NE => WORK1(id%N+1 : 2*id%N) 4404 NA => WORK1(2*id%N+1 : 3*id%N) 4405 NODE => WORK2(1 : id%N ) 4406 ND => WORK2(id%N+1 : 2*id%N) 4407 SUBORD => WORK2(2*id%N+1 : 3*id%N) 4408 NAMALG => WORK2(3*id%N+1 : 4*id%N) 4409 CALL MUMPS_733(CUMUL, id%N, id%INFO, LP, 4410 & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) 4411 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4412#if defined (memprof) 4413 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT cumul:',MEMCNT,MAXMEM 4414#endif 4415 NEMIN = id%KEEP(1) 4416 CALL DMUMPS_557(id%N, IPE(1), NV(1), IPS(1), NE(1), 4417 & NA(1), NFSIZ(1), NODE(1), id%INFOG(6), FILS(1), FRERE(1), 4418 & ND(1), NEMIN, SUBORD(1), id%KEEP(60), id%KEEP(20), 4419 & id%KEEP(38), NAMALG(1), id%KEEP(104), CUMUL(1), 4420 & id%KEEP(50), id%ICNTL(13), id%KEEP(37), id%NSLAVES, 4421 & id%KEEP(250).EQ.1) 4422 CALL MUMPS_734(CUMUL, NV, IPE, MEMCNT=MEMCNT) 4423#if defined (memprof) 4424 write(mp,'(i2,a30,2(i8,5x))')myid,'deall cumul:',MEMCNT,MAXMEM 4425#endif 4426 CALL DMUMPS_201(NE(1), ND(1), id%INFOG(6), id%INFOG(5), 4427 & id%KEEP(2), id%KEEP(50), id%KEEP(101), id%KEEP(108), 4428 & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) 4429 IF ( id%KEEP(53) .NE. 0 ) THEN 4430 CALL MUMPS_209(id%N, FRERE(1), FILS(1), NFSIZ(1), 4431 & id%KEEP(20)) 4432 END IF 4433 IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) 4434 & .OR. 4435 & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) 4436 & .OR. 4437 & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN 4438 CALL DMUMPS_510(id%KEEP8(21), id%KEEP(2), 4439 & id%KEEP(48), id%KEEP(50), id%NSLAVES) 4440 END IF 4441 IF ((id%KEEP(210).LT.0) .OR. (id%KEEP(210).GT.2)) 4442 & id%KEEP(210)=0 4443 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).GT.0)) 4444 & id%KEEP(210)=1 4445 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).EQ.0)) 4446 & id%KEEP(210)=2 4447 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) 4448 IF ((id%KEEP(210).EQ.1) .AND. (id%KEEP8(79).LE.0_8)) THEN 4449 IF ( huge(id%KEEP8(79)) / K79REF + 1_8 .GE. 4450 & int(id%NSLAVES,8) ) THEN 4451 id%KEEP8(79)=huge(id%KEEP8(79)) 4452 ELSE 4453 id%KEEP8(79)=K79REF * int(id%NSLAVES,8) 4454 ENDIF 4455 ENDIF 4456 IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. 4457 & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. 4458 & (id%KEEP(79).EQ.6) 4459 & ) THEN 4460 IF (id%KEEP(210).EQ.1) THEN 4461 SPLITROOT = .FALSE. 4462 IF ( id%KEEP(62).GE.1) THEN 4463 CALL DMUMPS_97(id%N, FRERE(1), FILS(1), 4464 & NFSIZ(1), id%INFOG(6), 4465 & id%NSLAVES, id%KEEP(1), id%KEEP8(1), SPLITROOT, 4466 & MP, LDIAG, id%INFOG(1), id%INFOG(2)) 4467 IF (id%INFOG(1).LT.0) RETURN 4468 ENDIF 4469 ENDIF 4470 ENDIF 4471 SPLITROOT = (((id%ICNTL(13).GT.0) .AND. 4472 & (id%NSLAVES.GT.id%ICNTL(13))) .OR. 4473 & (id%ICNTL(13).EQ.-1)) .AND. (id%KEEP(60).EQ.0) 4474 IF (SPLITROOT) THEN 4475 CALL DMUMPS_97(id%N, FRERE(1), FILS(1), NFSIZ(1), 4476 & id%INFOG(6), id%NSLAVES, id%KEEP(1), id%KEEP8(1), 4477 & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) 4478 IF (id%INFOG(1).LT.0) RETURN 4479 ENDIF 4480 END IF 4481#if defined (memprof) 4482 write(mp,'(i2,a30,3(i8,5x))')myid,'MEMCNT exit:',MEMCNT,MAXMEM, 4483 & estimem(myid, id%n, 2*id%nz/id%n) 4484#endif 4485 RETURN 4486 END SUBROUTINE DMUMPS_715 4487 SUBROUTINE DMUMPS_716(id, ord) 4488 TYPE(DMUMPS_STRUC) :: id 4489 TYPE(ORD_TYPE) :: ord 4490 INTEGER :: IERR 4491#if defined(parmetis) 4492 INTEGER :: I, COLOR, BASE 4493 LOGICAL :: IDO 4494#endif 4495 IF(id%MYID .EQ. 0) id%KEEP(245) = id%ICNTL(29) 4496 CALL MPI_BCAST( id%KEEP(245), 1, 4497 & MPI_INTEGER, 0, id%COMM, IERR ) 4498 IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN 4499 id%KEEP(245) = 0 4500 END IF 4501 IF (id%KEEP(245) .EQ. 0) THEN 4502#if defined(ptscotch) 4503 IF(id%NSLAVES .LT. 2) THEN 4504 IF(PROKG) WRITE(MPG,'("Warning: older versions 4505 &of PT-SCOTCH require at least 2 processors.")') 4506 END IF 4507 ord%ORDTOOL = 1 4508 ord%TOPSTRAT = 0 4509 ord%SUBSTRAT = 0 4510 ord%COMM = id%COMM 4511 ord%COMM_NODES = id%COMM_NODES 4512 ord%NPROCS = id%NPROCS 4513 ord%NSLAVES = id%NSLAVES 4514 ord%MYID = id%MYID 4515 ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) 4516 IF(PROKG) WRITE(MPG, 4517 & '("Parallel ordering tool set to PT-SCOTCH.")') 4518 RETURN 4519#endif 4520#if defined(parmetis) 4521 I=1 4522 DO 4523 IF (I .GT. id%NSLAVES) EXIT 4524 ord%NSLAVES = I 4525 I = I*2 4526 END DO 4527 BASE = id%NPROCS-id%NSLAVES 4528 ord%NPROCS = ord%NSLAVES + BASE 4529 IDO = (id%MYID .GE. BASE) .AND. 4530 & (id%MYID .LE. BASE+ord%NSLAVES-1) 4531 ord%IDO = IDO 4532 IF ( IDO ) THEN 4533 COLOR = 1 4534 ELSE 4535 COLOR = MPI_UNDEFINED 4536 END IF 4537 CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, 4538 & ord%COMM_NODES, IERR ) 4539 ord%ORDTOOL = 2 4540 ord%TOPSTRAT = 0 4541 ord%SUBSTRAT = 0 4542 ord%MYID = id%MYID 4543 IF(PROKG) WRITE(MPG, 4544 & '("Parallel ordering tool set to ParMETIS.")') 4545 RETURN 4546#endif 4547 id%INFO(1) = -38 4548 id%INFOG(1) = -38 4549 IF(id%MYID .EQ.0 ) THEN 4550 WRITE(LP, 4551 & '("No parallel ordering tools available.")') 4552 WRITE(LP, 4553 & '("Please install PT-SCOTCH or ParMETIS.")') 4554 END IF 4555 RETURN 4556 ELSE IF (id%KEEP(245) .EQ. 1) THEN 4557#if defined(ptscotch) 4558 IF(id%NSLAVES .LT. 2) THEN 4559 IF(PROKG) WRITE(MPG,'("Warning: older versions 4560 &of PT-SCOTCH require at least 2 processors.")') 4561 END IF 4562 ord%ORDTOOL = 1 4563 ord%TOPSTRAT = 0 4564 ord%SUBSTRAT = 0 4565 ord%COMM = id%COMM 4566 ord%COMM_NODES = id%COMM_NODES 4567 ord%NPROCS = id%NPROCS 4568 ord%NSLAVES = id%NSLAVES 4569 ord%MYID = id%MYID 4570 ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) 4571 IF(PROKG) WRITE(MPG, 4572 & '("Using PT-SCOTCH for parallel ordering.")') 4573 RETURN 4574#else 4575 id%INFOG(1) = -38 4576 id%INFO(1) = -38 4577 IF(id%MYID .EQ.0 ) WRITE(LP, 4578 & '("PT-SCOTCH not available.")') 4579 RETURN 4580#endif 4581 ELSE IF (id%KEEP(245) .EQ. 2) THEN 4582#if defined(parmetis) 4583 I=1 4584 DO 4585 IF (I .GT. id%NSLAVES) EXIT 4586 ord%NSLAVES = I 4587 I = I*2 4588 END DO 4589 BASE = id%NPROCS-id%NSLAVES 4590 ord%NPROCS = ord%NSLAVES + BASE 4591 IDO = (id%MYID .GE. BASE) .AND. 4592 & (id%MYID .LE. BASE+ord%NSLAVES-1) 4593 ord%IDO = IDO 4594 IF ( IDO ) THEN 4595 COLOR = 1 4596 ELSE 4597 COLOR = MPI_UNDEFINED 4598 END IF 4599 CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, ord%COMM_NODES, 4600 & IERR ) 4601 ord%ORDTOOL = 2 4602 ord%TOPSTRAT = 0 4603 ord%SUBSTRAT = 0 4604 ord%MYID = id%MYID 4605 IF(PROKG) WRITE(MPG, 4606 & '("Using ParMETIS for parallel ordering.")') 4607 RETURN 4608#else 4609 id%INFOG(1) = -38 4610 id%INFO(1) = -38 4611 IF(id%MYID .EQ.0 ) WRITE(LP, 4612 & '("ParMETIS not available.")') 4613 RETURN 4614#endif 4615 END IF 4616 END SUBROUTINE DMUMPS_716 4617 SUBROUTINE DMUMPS_717(id, ord, WORK) 4618 IMPLICIT NONE 4619 TYPE(DMUMPS_STRUC) :: id 4620 TYPE(ORD_TYPE) :: ord 4621 INTEGER, POINTER :: WORK(:) 4622#ifdef parmetis 4623 INTEGER :: IERR 4624#endif 4625 IF (ord%ORDTOOL .EQ. 1) THEN 4626#ifdef ptscotch 4627 CALL DMUMPS_719(id, ord, WORK) 4628#else 4629 id%INFOG(1) = -38 4630 id%INFO(1) = -38 4631 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' 4632 CALL MUMPS_ABORT() 4633#endif 4634 ELSE IF (ord%ORDTOOL .EQ. 2) THEN 4635#ifdef parmetis 4636 CALL DMUMPS_718(id, ord, WORK) 4637 if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_NODES, IERR) 4638#else 4639 id%INFOG(1) = -38 4640 id%INFO(1) = -38 4641 WRITE(LP,*)'ParMETIS not available. Aborting...' 4642 CALL MUMPS_ABORT() 4643#endif 4644 END IF 4645 RETURN 4646 END SUBROUTINE DMUMPS_717 4647#if defined(parmetis) 4648 SUBROUTINE DMUMPS_718(id, ord, WORK) 4649 IMPLICIT NONE 4650 TYPE(DMUMPS_STRUC) :: id 4651 TYPE(ORD_TYPE) :: ord 4652 INTEGER, POINTER :: WORK(:) 4653 INTEGER :: I, MYID, NPROCS, IERR, BASE 4654 INTEGER, POINTER :: FIRST(:), 4655 & LAST(:), SWORK(:) 4656 INTEGER :: BASEVAL, VERTLOCNBR, 4657 & EDGELOCNBR, OPTIONS(10), NROWS_LOC 4658 INTEGER, POINTER :: VERTLOCTAB(:), 4659 & EDGELOCTAB(:), RCVCNTS(:) 4660 INTEGER, POINTER :: SIZES(:), ORDER(:) 4661 nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, 4662 & SIZES, ORDER) 4663 CALL MPI_COMM_RANK (id%COMM, MYID, IERR) 4664 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) 4665 IF(MUMPS_795(WORK) .LT. ID%N*3) THEN 4666 WRITE(LP, 4667 & '("Insufficient workspace inside DMUMPS_718")') 4668 CALL MUMPS_ABORT() 4669 END IF 4670 CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, LP, 4671 & STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) 4672 CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, LP, 4673 & STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) 4674 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4675#if defined (memprof) 4676 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT perm peri:', 4677 & MEMCNT,MAXMEM 4678#endif 4679 BASEVAL = 1 4680 BASE = id%NPROCS-id%NSLAVES 4681 VERTLOCTAB => ord%PERMTAB 4682 CALL MUMPS_733(FIRST, NPROCS+1, id%INFO, LP, 4683 & MEMCNT=MEMCNT, ERRCODE=-7) 4684 CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, 4685 & MEMCNT=MEMCNT, ERRCODE=-7) 4686 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4687#if defined (memprof) 4688 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, 4689 & MAXMEM 4690#endif 4691 DO I=0, BASE-1 4692 FIRST(I+1) = 0 4693 LAST(I+1) = -1 4694 END DO 4695 DO I=BASE, BASE+ord%NSLAVES-2 4696 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 4697 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) 4698 END DO 4699 FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* 4700 & (BASE+ord%NSLAVES-1-BASE)+1 4701 LAST(BASE+ord%NSLAVES) = id%N 4702 DO I=BASE+ord%NSLAVES, NPROCS 4703 FIRST(I+1) = id%N+1 4704 LAST(I+1) = id%N 4705 END DO 4706 VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 4707 SWORK => WORK(id%N+1:3*id%N) 4708 CALL DMUMPS_776(id, FIRST, LAST, VERTLOCTAB, 4709 & EDGELOCTAB, SWORK) 4710 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 4711 OPTIONS(:) = 0 4712 NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 4713 ORDER => WORK(1:id%N) 4714 CALL MUMPS_733(SIZES, 2*ord%NSLAVES, id%INFO, LP, 4715 & MEMCNT=MEMCNT, ERRCODE=-7) 4716 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4717#if defined (memprof) 4718 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT sizes:',MEMCNT,MAXMEM 4719#endif 4720 IF(ord%IDO) THEN 4721 CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB, 4722 & EDGELOCTAB, BASEVAL, OPTIONS, ORDER, 4723 & SIZES, ord%COMM_NODES) 4724 END IF 4725 CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) 4726 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4727#if defined (memprof) 4728 write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM 4729#endif 4730 NULLIFY(VERTLOCTAB) 4731 CALL MPI_BCAST(SIZES, 2*ord%NSLAVES, MPI_INTEGER, 4732 & BASE, id%COMM, IERR) 4733 ord%CBLKNBR = 2*ord%NSLAVES-1 4734 CALL MUMPS_733(RCVCNTS, id%NPROCS, id%INFO, LP, 4735 & MEMCNT=MEMCNT, ERRCODE=-7) 4736 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4737#if defined (memprof) 4738 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rcvcnts:',MEMCNT,MAXMEM 4739#endif 4740 DO I=1, id%NPROCS 4741 RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) 4742 END DO 4743 FIRST = FIRST-1 4744 IF(FIRST(1) .LT. 0) THEN 4745 FIRST(1) = 0 4746 END IF 4747 CALL MPI_ALLGATHERV ( ORDER, NROWS_LOC, MPI_INTEGER, ord%PERMTAB, 4748 & RCVCNTS, FIRST, MPI_INTEGER, id%COMM, IERR ) 4749 DO I=1, id%N 4750 ord%PERITAB(ord%PERMTAB(I)) = I 4751 END DO 4752 CALL MUMPS_733(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, 4753 & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) 4754 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4755#if defined (memprof) 4756 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rangtab:',MEMCNT,MAXMEM 4757#endif 4758 CALL MUMPS_733(ord%TREETAB, ord%CBLKNBR, id%INFO, 4759 & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) 4760 CALL DMUMPS_778(ord%TREETAB, ord%RANGTAB, 4761 & SIZES, ord%CBLKNBR) 4762 CALL MUMPS_734(SIZES, FIRST, LAST, 4763 & RCVCNTS, MEMCNT=MEMCNT) 4764#if defined (memprof) 4765 write(mp,'(i2,a30,2(i8,5x))')myid,'deall sizes:',MEMCNT,MAXMEM 4766#endif 4767 CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, 4768 & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) 4769 CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, 4770 & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) 4771 CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, 4772 & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) 4773 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4774#if defined (memprof) 4775 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM 4776#endif 4777 CALL DMUMPS_777(ord) 4778 ord%N = id%N 4779 ord%COMM = id%COMM 4780 RETURN 4781 END SUBROUTINE DMUMPS_718 4782#endif 4783#if defined(ptscotch) 4784 SUBROUTINE DMUMPS_719(id, ord, WORK) 4785 IMPLICIT NONE 4786 INCLUDE 'ptscotchf.h' 4787 TYPE(DMUMPS_STRUC) :: id 4788 TYPE(ORD_TYPE) :: ord 4789 INTEGER, POINTER :: WORK(:) 4790 INTEGER :: I, MYID, NPROCS, IERR 4791 INTEGER, POINTER :: FIRST(:), 4792 & LAST(:), SWORK(:) 4793 INTEGER :: BASEVAL, VERTLOCNBR, 4794 & EDGELOCNBR, MYWORKID, 4795 & BASE 4796 INTEGER, POINTER :: VERTLOCTAB(:), 4797 & EDGELOCTAB(:) 4798 DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), 4799 & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), 4800 & CORDEDAT(SCOTCH_ORDERDIM) 4801 CHARACTER STRSTRING*1024 4802 nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) 4803 IF(MUMPS_795(WORK) .LT. ID%N*3) THEN 4804 WRITE(LP, 4805 & '("Insufficient workspace inside DMUMPS_719")') 4806 CALL MUMPS_ABORT() 4807 END IF 4808 IF(ord%SUBSTRAT .EQ. 0) THEN 4809 STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// 4810 & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,proc=1,'// 4811 & 'seq=q{strat=m{type=h,vert=100,low=h{pass=10},'// 4812 & 'asc=b{width=3,bnd=f{bal=0.2},org=h{pass=10}'// 4813 & 'f{bal=0.2}}}}},ole=s,ose=s,osq=n{sep=/(vert>120)?'// 4814 & 'm{type=h,vert=100,low=h{pass=10},asc=b{width=3,'// 4815 & 'bnd=f{bal=0.2},org=h{pass=10}f{bal=0.2}}};,'// 4816 & 'ole=f{cmin=15,cmax=100000,frat=0.0},ose=g}}' 4817 ELSE 4818 STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// 4819 & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// 4820 & 'proc=1,seq=q{strat=m{type=h,vert=100,'// 4821 & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// 4822 & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' 4823 END IF 4824 CALL MPI_BARRIER(id%COMM, IERR) 4825 CALL MPI_COMM_RANK (id%COMM, MYID, IERR) 4826 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) 4827 BASE = id%NPROCS-id%NSLAVES 4828 BASEVAL = 1 4829 CALL MUMPS_733(FIRST, NPROCS+1, id%INFO, LP, 4830 & MEMCNT=MEMCNT, ERRCODE=-7) 4831 CALL MUMPS_733(LAST, NPROCS+1, id%INFO, LP, 4832 & MEMCNT=MEMCNT, ERRCODE=-7) 4833 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4834#if defined (memprof) 4835 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT first last:',MEMCNT, 4836 & MAXMEM 4837#endif 4838 DO I=0, BASE-1 4839 FIRST(I+1) = 0 4840 LAST(I+1) = -1 4841 END DO 4842 DO I=BASE, BASE+ord%NSLAVES-2 4843 FIRST(I+1) = (id%N/ord%NSLAVES)*(I-BASE)+1 4844 LAST(I+1) = (id%N/ord%NSLAVES)*(I+1-BASE) 4845 END DO 4846 FIRST(BASE+ord%NSLAVES) = (id%N/ord%NSLAVES)* 4847 & (BASE+ord%NSLAVES-1-BASE)+1 4848 LAST(BASE+ord%NSLAVES) = id%N 4849 DO I=BASE+ord%NSLAVES, NPROCS-1 4850 FIRST(I+1) = id%N+1 4851 LAST(I+1) = id%N 4852 END DO 4853 VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 4854 VERTLOCTAB => WORK(1:id%N) 4855 SWORK => WORK(id%N+1:3*id%N) 4856 CALL DMUMPS_776(id, FIRST, LAST, VERTLOCTAB, 4857 & EDGELOCTAB, SWORK) 4858 EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1 4859 CALL MUMPS_733(ord%PERMTAB, id%N, id%INFO, 4860 & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) 4861 CALL MUMPS_733(ord%PERITAB, id%N, id%INFO, 4862 & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) 4863 CALL MUMPS_733(ord%RANGTAB, id%N+1, id%INFO, 4864 & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) 4865 CALL MUMPS_733(ord%TREETAB, id%N, id%INFO, 4866 & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) 4867 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4868#if defined (memprof) 4869 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT permtab:',MEMCNT,MAXMEM 4870#endif 4871 IF(ord%IDO) THEN 4872 CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) 4873 ELSE 4874 MYWORKID = -1 4875 END IF 4876 IF(ord%IDO) THEN 4877 CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) 4878 IF(IERR.NE.0) THEN 4879 WRITE(LP,'("Error in dgraph init")') 4880 CALL MUMPS_ABORT() 4881 END IF 4882 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, 4883 & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), VERTLOCTAB(1), 4884 & VERTLOCTAB(1), EDGELOCNBR, EDGELOCNBR, EDGELOCTAB(1), 4885 & EDGELOCTAB(1), EDGELOCTAB(1), IERR) 4886 IF(IERR.NE.0) THEN 4887 WRITE(LP,'("Error in dgraph build")') 4888 CALL MUMPS_ABORT() 4889 END IF 4890 CALL SCOTCHFSTRATINIT(STRADAT, IERR) 4891 IF(IERR.NE.0) THEN 4892 WRITE(LP,'("Error in strat init")') 4893 CALL MUMPS_ABORT() 4894 END IF 4895 CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) 4896 IF(IERR.NE.0) THEN 4897 WRITE(LP,'("Error in strat build")') 4898 CALL MUMPS_ABORT() 4899 END IF 4900 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) 4901 IF(IERR.NE.0) THEN 4902 WRITE(LP,'("Error in order init")') 4903 CALL MUMPS_ABORT() 4904 END IF 4905 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, 4906 & IERR) 4907 IF(IERR.NE.0) THEN 4908 WRITE(LP,'("Error in order compute")') 4909 CALL MUMPS_ABORT() 4910 END IF 4911 IF(MYWORKID .EQ. 0) THEN 4912 CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, 4913 & ord%PERMTAB, ord%PERITAB, ord%CBLKNBR, ord%RANGTAB, 4914 & ord%TREETAB, IERR) 4915 IF(IERR.NE.0) THEN 4916 WRITE(LP,'("Error in Corder init")') 4917 CALL MUMPS_ABORT() 4918 END IF 4919 END IF 4920 IF(MYWORKID .EQ. 0) THEN 4921 CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, 4922 & CORDEDAT, IERR) 4923 IF(IERR.NE.0) THEN 4924 WRITE(LP,'("Error in order gather")') 4925 CALL MUMPS_ABORT() 4926 END IF 4927 ELSE 4928 CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, 4929 & ORDEDAT, IERR) 4930 IF(IERR.NE.0) THEN 4931 WRITE(LP,'("Error in order gather")') 4932 CALL MUMPS_ABORT() 4933 END IF 4934 END IF 4935 END IF 4936 IF(MYWORKID .EQ. 0) 4937 & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) 4938 CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) 4939 CALL SCOTCHFSTRATEXIT(STRADAT) 4940 CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 4941 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, 4942 & BASE, id%COMM, IERR) 4943 CALL MPI_BCAST (ord%PERMTAB, id%N, MPI_INTEGER, 4944 & BASE, id%COMM, IERR) 4945 CALL MPI_BCAST (ord%PERITAB, id%N, MPI_INTEGER, 4946 & BASE, id%COMM, IERR) 4947 CALL MPI_BCAST (ord%RANGTAB, id%N+1, MPI_INTEGER, 4948 & BASE, id%COMM, IERR) 4949 CALL MPI_BCAST (ord%TREETAB, id%N, MPI_INTEGER, 4950 & BASE, id%COMM, IERR) 4951 CALL MUMPS_733(ord%SON, ord%CBLKNBR, id%INFO, 4952 & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) 4953 CALL MUMPS_733(ord%BROTHER, ord%CBLKNBR, id%INFO, 4954 & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) 4955 CALL MUMPS_733(ord%NW, ord%CBLKNBR, id%INFO, 4956 & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) 4957 CALL DMUMPS_777(ord) 4958 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 4959#if defined (memprof) 4960 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT son:',MEMCNT,MAXMEM 4961#endif 4962 ord%N = id%N 4963 ord%COMM = id%COMM 4964 CALL MUMPS_734(EDGELOCTAB, MEMCNT=MEMCNT) 4965#if defined (memprof) 4966 write(mp,'(i2,a30,2(i8,5x))')myid,'deall elt:',MEMCNT,MAXMEM 4967#endif 4968 RETURN 4969 END SUBROUTINE DMUMPS_719 4970#endif 4971 FUNCTION DMUMPS_793(id, ord, NACTIVE, ANODE, RPROC, 4972 & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) 4973 IMPLICIT NONE 4974 LOGICAL :: DMUMPS_793 4975 INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES 4976 INTEGER :: ALIST(NNODES), LIST(NNODES) 4977 TYPE(ORD_TYPE) :: ord 4978 TYPE(DMUMPS_STRUC) :: id 4979 LOGICAL, OPTIONAL :: CHECKMEM 4980 INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS 4981 INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM 4982 INTEGER :: I, NZ_ROW, WEIGHT 4983 LOGICAL :: ICHECKMEM 4984 IF(present(CHECKMEM)) THEN 4985 ICHECKMEM = CHECKMEM 4986 ELSE 4987 ICHECKMEM = .FALSE. 4988 END IF 4989 DMUMPS_793 = .FALSE. 4990 IF(NACTIVE .GE. RPROC) THEN 4991 DMUMPS_793 = .TRUE. 4992 RETURN 4993 END IF 4994 IF(NACTIVE .EQ. 0) THEN 4995 DMUMPS_793 = .TRUE. 4996 RETURN 4997 END IF 4998 IF(.NOT. ICHECKMEM) RETURN 4999 BIG = ALIST(NACTIVE) 5000 IF(NACTIVE .GT. 1) THEN 5001 MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) 5002 MIN_NROWS = ord%NW(ALIST(1)) 5003 ELSE 5004 MAX_NROWS = 0 5005 MIN_NROWS = id%N 5006 END IF 5007 DO I=1, ANODE 5008 WEIGHT = ord%NW(LIST(I)) 5009 IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT 5010 IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT 5011 END DO 5012 I = ord%SON(BIG) 5013 DO 5014 WEIGHT = ord%NW(I) 5015 IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT 5016 IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT 5017 IF(ord%BROTHER(I) .EQ. -1) EXIT 5018 I = ord%BROTHER(I) 5019 END DO 5020 TOPROWS = ord%TOPNODES(2)+ord%RANGTAB(BIG+1)-ord%RANGTAB(BIG) 5021 SUBMEM = 7 *id%N 5022 HOSTMEM = 12*id%N 5023 NZ_ROW = 2*(id%NZ/id%N) 5024 IF(id%KEEP(46) .EQ. 0) THEN 5025 NRL = 0 5026 ELSE 5027 NRL = MIN_NROWS 5028 END IF 5029 HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW 5030 HOSTMEM = HOSTMEM +NRL 5031 HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) 5032 HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) 5033 HOSTMEM = HOSTMEM + 3*TOPROWS 5034 NRL = MAX_NROWS 5035 SUBMEM = SUBMEM +NRL 5036 SUBMEM = SUBMEM + NRL*(NZ_ROW+2) 5037 SUBMEM = SUBMEM + 6*NRL 5038 IPEAKMEM = max(HOSTMEM, SUBMEM) 5039 IF((IPEAKMEM .GT. PEAKMEM) .AND. 5040 & (PEAKMEM .NE. 0)) THEN 5041 DMUMPS_793 = .TRUE. 5042 RETURN 5043 ELSE 5044 DMUMPS_793 = .FALSE. 5045 PEAKMEM = IPEAKMEM 5046 RETURN 5047 END IF 5048 END FUNCTION DMUMPS_793 5049 FUNCTION DMUMPS_779(NODE, ord) 5050 IMPLICIT NONE 5051 INTEGER :: DMUMPS_779 5052 INTEGER :: NODE 5053 TYPE(ORD_TYPE) :: ord 5054 INTEGER :: CURR 5055 DMUMPS_779 = 0 5056 IF(ord%SON(NODE) .EQ. -1) THEN 5057 RETURN 5058 ELSE 5059 DMUMPS_779 = 1 5060 CURR = ord%SON(NODE) 5061 DO 5062 IF(ord%BROTHER(CURR) .NE. -1) THEN 5063 DMUMPS_779 = DMUMPS_779+1 5064 CURR = ord%BROTHER(CURR) 5065 ELSE 5066 EXIT 5067 END IF 5068 END DO 5069 END IF 5070 RETURN 5071 END FUNCTION DMUMPS_779 5072 SUBROUTINE DMUMPS_781(ord, id) 5073 USE TOOLS_COMMON 5074 IMPLICIT NONE 5075 TYPE(ORD_TYPE) :: ord 5076 TYPE(DMUMPS_STRUC) :: id 5077 INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) 5078 INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, 5079 & NK, PEAKMEM 5080 LOGICAL :: SD 5081 NNODES = ord%NSLAVES 5082 ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), 5083 & WORK(0:NNODES+1)) 5084 ALIST(1) = ord%CBLKNBR 5085 AWEIGHTS(1) = ord%NW(ord%CBLKNBR) 5086 NACTIVE = 1 5087 RPROC = NNODES 5088 ANODE = 0 5089 PEAKMEM = 0 5090 CALL MUMPS_733(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, 5091 & MEMCNT=MEMCNT, ERRCODE=-7) 5092 CALL MUMPS_733(ord%FIRST, id%NPROCS, id%INFO, LP, 5093 & MEMCNT=MEMCNT, ERRCODE=-7) 5094 CALL MUMPS_733(ord%LAST, id%NPROCS, id%INFO, LP, 5095 & MEMCNT=MEMCNT, ERRCODE=-7) 5096 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5097#if defined (memprof) 5098 write(mp,'(i2,a30,2(i8,5x))')ord%myid,'MEMCNT topnodes:',MEMCNT, 5099 & MAXMEM 5100#endif 5101 ord%TOPNODES = 0 5102 IF((ord%CBLKNBR .EQ. 1) .OR. 5103 & ( RPROC .LT. DMUMPS_779(ord%CBLKNBR, ord) )) THEN 5104 ord%TOPNODES(1) = 1 5105 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) 5106 ord%TOPNODES(3) = ord%RANGTAB(1) 5107 ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 5108 ord%FIRST = 0 5109 ord%LAST = -1 5110 RETURN 5111 END IF 5112 DO 5113 IF(NACTIVE .EQ. 0) EXIT 5114 BIG = ALIST(NACTIVE) 5115 NK = DMUMPS_779(BIG, ord) 5116 IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN 5117 ANODE = ANODE+1 5118 LIST(ANODE) = BIG 5119 NACTIVE = NACTIVE-1 5120 RPROC = RPROC-1 5121 CYCLE 5122 END IF 5123 SD = DMUMPS_793(id, ord, NACTIVE, ANODE, 5124 & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) 5125 IF ( SD ) 5126 & THEN 5127 IF(NACTIVE.GT.0) THEN 5128 LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) 5129 ANODE = ANODE+NACTIVE 5130 END IF 5131 EXIT 5132 END IF 5133 ord%TOPNODES(1) = ord%TOPNODES(1)+1 5134 ord%TOPNODES(2) = ord%TOPNODES(2) + 5135 & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) 5136 ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) 5137 ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = 5138 & ord%RANGTAB(BIG+1)-1 5139 CURR = ord%SON(BIG) 5140 ALIST(NACTIVE) = CURR 5141 AWEIGHTS(NACTIVE) = ord%NW(CURR) 5142 DO 5143 IF(ord%BROTHER(CURR) .EQ. -1) EXIT 5144 NACTIVE = NACTIVE+1 5145 CURR = ord%BROTHER(CURR) 5146 ALIST(NACTIVE) = CURR 5147 AWEIGHTS(NACTIVE) = ord%NW(CURR) 5148 END DO 5149 CALL DMUMPS_783(NACTIVE, AWEIGHTS(1:NACTIVE), 5150 & WORK(0:NACTIVE+1)) 5151 CALL DMUMPS_784(NACTIVE, WORK(0:NACTIVE+1), 5152 & AWEIGHTS(1:NACTIVE), 5153 & ALIST(1:NACTIVE)) 5154 END DO 5155 DO I=1, ANODE 5156 AWEIGHTS(I) = ord%NW(LIST(I)) 5157 END DO 5158 CALL DMUMPS_783(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) 5159 CALL DMUMPS_784(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), 5160 & ALIST(1:ANODE)) 5161 IF (id%KEEP(46) .EQ. 1) THEN 5162 BASE = 0 5163 ELSE 5164 ord%FIRST(1) = 0 5165 ord%LAST(1) = -1 5166 BASE = 1 5167 END IF 5168 DO I=1, ANODE 5169 CURR = LIST(I) 5170 ND = CURR 5171 IF(ord%SON(ND) .NE. -1) THEN 5172 ND = ord%SON(ND) 5173 DO 5174 IF((ord%SON(ND) .EQ. -1) .AND. 5175 & (ord%BROTHER(ND).EQ.-1)) THEN 5176 EXIT 5177 ELSE IF(ord%BROTHER(ND) .EQ. -1) THEN 5178 ND = ord%SON(ND) 5179 ELSE 5180 ND = ord%BROTHER(ND) 5181 END IF 5182 END DO 5183 END IF 5184 ord%FIRST(BASE+I) = ord%RANGTAB(ND) 5185 ord%LAST(BASE+I) = ord%RANGTAB(CURR+1)-1 5186 END DO 5187 DO I=ANODE+1, id%NSLAVES 5188 ord%FIRST(BASE+I) = id%N+1 5189 ord%LAST(BASE+I) = id%N 5190 END DO 5191 DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 5192 RETURN 5193 END SUBROUTINE DMUMPS_781 5194 SUBROUTINE DMUMPS_720(id, ord, GPE, GNV, WORK) 5195 IMPLICIT NONE 5196 TYPE(DMUMPS_STRUC) :: id 5197 TYPE(ORD_TYPE) :: ord 5198 INTEGER, POINTER :: GPE(:), GNV(:) 5199 INTEGER, POINTER :: WORK(:) 5200 TYPE(GRAPH_TYPE) :: top_graph 5201 INTEGER, POINTER :: PE(:), IPE(:), 5202 & LENG(:), I_HALO_MAP(:) 5203 INTEGER, POINTER :: NDENSE(:), LAST(:), 5204 & DEGREE(:), W(:), PERM(:), 5205 & LISTVAR_SCHUR(:), NEXT(:), 5206 & HEAD(:), NV(:), ELEN(:), 5207 & RCVCNT(:), LSTVAR(:) 5208 INTEGER, POINTER :: NROOTS(:), MYLIST(:), 5209 & MYNVAR(:), LVARPT(:), 5210 & DISPLS(:), LPERM(:), 5211 & LIPERM(:), 5212 & IPET(:), NVT(:), BUF_PE1(:), 5213 & BUF_PE2(:), BUF_NV1(:), 5214 & BUF_NV2(:), ROOTPERM(:), 5215 & TMP1(:), TMP2(:), BWORK(:) 5216 INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, 5217 & NPROCS, IERR, NROWS_LOC, GLOB_IDX, MYNROOTS, PNT, TMP, 5218 & NCLIQUES, NTVAR, PFREES, PFREET, TGSIZE, MAXS, RHANDPE, 5219 & RHANDNV, STATUSPE(MPI_STATUS_SIZE), 5220 & STATUSNV(MPI_STATUS_SIZE), RIDX, PROC, NBBUCK, 5221 & PFS_SAVE, PFT_SAVE 5222 LOGICAL :: AGG6 5223 INTEGER :: THRESH 5224 nullify(PE, IPE, LENG, I_HALO_MAP) 5225 nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, 5226 & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) 5227 nullify(NROOTS, MYLIST, MYNVAR, LVARPT, DISPLS, 5228 & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, 5229 & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) 5230 CALL MPI_COMM_RANK (id%COMM, MYID, IERR) 5231 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) 5232 IF(MUMPS_795(WORK) .LT. 4*id%N) THEN 5233 WRITE(LP,*)'Insufficient workspace in DMUMPS_720' 5234 CALL MUMPS_ABORT() 5235 ELSE 5236 HEAD => WORK( 1 : id%N) 5237 ELEN => WORK( id%N+1 : 2*id%N) 5238 LENG => WORK(2*id%N+1 : 3*id%N) 5239 PERM => WORK(3*id%N+1 : 4*id%N) 5240 END IF 5241 CALL DMUMPS_781(ord, id) 5242 CALL MUMPS_734(ord%SON, ord%BROTHER, ord%NW, 5243 & ord%RANGTAB, MEMCNT=MEMCNT) 5244#if defined (memprof) 5245 write(mp,'(i2,a30,2(i8,5x))') myid,'deall son:',MEMCNT,MAXMEM 5246#endif 5247 NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 5248 NRL = NROWS_LOC 5249 TOPROWS = ord%TOPNODES(2) 5250 BWORK => WORK(1 : 2*id%N) 5251 CALL DMUMPS_775(id, ord, HIDX, IPE, PE, LENG, 5252 & I_HALO_MAP, top_graph, BWORK) 5253 TMP = id%N 5254 DO I=1, NPROCS 5255 TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) 5256 END DO 5257 TMP = ceiling(dble(TMP)*1.10D0) 5258 IF(MYID .EQ. 0) THEN 5259 TMP = max(max(TMP, HIDX),1) 5260 ELSE 5261 TMP = max(HIDX,1) 5262 END IF 5263 SIZE_SCHUR = HIDX - NROWS_LOC 5264 CALL MUMPS_733(NDENSE, TMP, id%INFO, LP, 5265 & MEMCNT=MEMCNT, ERRCODE=-7) 5266 CALL MUMPS_733(LAST, TMP, id%INFO, LP, 5267 & MEMCNT=MEMCNT, ERRCODE=-7) 5268 CALL MUMPS_733(NEXT, TMP, id%INFO, LP, 5269 & MEMCNT=MEMCNT, ERRCODE=-7) 5270 CALL MUMPS_733(DEGREE, TMP, id%INFO, LP, 5271 & MEMCNT=MEMCNT, ERRCODE=-7) 5272 CALL MUMPS_733(W, TMP, id%INFO, LP, 5273 & MEMCNT=MEMCNT, ERRCODE=-7) 5274 CALL MUMPS_733(NV, TMP, id%INFO, LP, 5275 & MEMCNT=MEMCNT, ERRCODE=-7) 5276 CALL MUMPS_733(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, 5277 & MEMCNT=MEMCNT, ERRCODE=-7) 5278 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5279#if defined (memprof) 5280 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT allsub:',MEMCNT,MAXMEM 5281#endif 5282 DO I=1, SIZE_SCHUR 5283 LISTVAR_SCHUR(I) = NROWS_LOC+I 5284 END DO 5285 THRESH = -1 5286 AGG6 = .TRUE. 5287 PFREES = IPE(NROWS_LOC+1) 5288 PFS_SAVE = PFREES 5289 IF (ord%SUBSTRAT .EQ. 0) THEN 5290 DO I=1, HIDX 5291 PERM(I) = I 5292 END DO 5293 CALL MUMPS_420(1, THRESH, NDENSE(1), HIDX, 5294 & MUMPS_795(PE), IPE(1), PFREES, LENG(1), PE(1), NV(1), 5295 & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), 5296 & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) 5297 ELSE 5298 NBBUCK = 2*TMP 5299 CALL MUMPS_419 (ord%SUBSTRAT, 1, .FALSE., HIDX, NBBUCK, 5300 & MUMPS_795(PE), IPE(1), PFREES, LENG(1), PE(1), NV(1), 5301 & ELEN(1), LAST(1), NCMPA, DEGREE(1), PERM(1), NEXT(1), 5302 & W(1), HEAD(1), AGG6, SIZE_SCHUR, LISTVAR_SCHUR(1) ) 5303 DO I=1, HIDX 5304 PERM(I) = I 5305 END DO 5306 END IF 5307 CALL MUMPS_733(W, 2*NPROCS, id%INFO, 5308 & LP, STRING='W', MEMCNT=MEMCNT, ERRCODE=-7) 5309 if(MEMCNT .gt. MAXMEM) MAXMEM=MEMCNT 5310#if defined (memprof) 5311 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT w:',MEMCNT,MAXMEM 5312#endif 5313 NROOTS => W 5314 DISPLS => W(NPROCS+1:2*NPROCS) 5315 MYNVAR => DEGREE 5316 MYLIST => NDENSE 5317 LVARPT => NEXT 5318 RCVCNT => HEAD 5319 LSTVAR => LAST 5320 NULLIFY(W, DEGREE, NDENSE, NEXT, HEAD, LAST) 5321 MYNROOTS = 0 5322 PNT = 0 5323 DO I=1, HIDX 5324 IF(IPE(I) .GT. 0) THEN 5325 PNT = PNT+LENG(I) 5326 MYNROOTS = MYNROOTS+1 5327 END IF 5328 END DO 5329 CALL MUMPS_733(MYLIST, PNT, id%INFO, 5330 & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) 5331 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5332#if defined (memprof) 5333 write(mp,'(i2,a30,2(i8,5x))')myid, 5334 & 'MEMCNT mylist:',MEMCNT,MAXMEM 5335#endif 5336 MYNROOTS = 0 5337 PNT = 0 5338 DO I=1, HIDX 5339 IF(IPE(I) .GT. 0) THEN 5340 MYNROOTS = MYNROOTS+1 5341 MYNVAR(MYNROOTS) = LENG(I) 5342 DO J=1, LENG(I) 5343 MYLIST(PNT+J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) 5344 END DO 5345 PNT = PNT+LENG(I) 5346 END IF 5347 END DO 5348 CALL MPI_BARRIER(id%COMM, IERR) 5349 CALL MPI_GATHER(MYNROOTS, 1, MPI_INTEGER, NROOTS(1), 1, 5350 & MPI_INTEGER, 0, id%COMM, IERR) 5351 IF(MYID .EQ.0) THEN 5352 DISPLS(1) = 0 5353 DO I=2, NPROCS 5354 DISPLS(I) = DISPLS(I-1)+NROOTS(I-1) 5355 END DO 5356 NCLIQUES = sum(NROOTS(1:NPROCS)) 5357 CALL MUMPS_733(LVARPT, NCLIQUES+1, id%INFO, 5358 & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) 5359 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5360 ELSE 5361 CALL MUMPS_733(LVARPT, 2, id%INFO, 5362 & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) 5363 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5364 END IF 5365#if defined (memprof) 5366 write(mp,'(i2,a30,2(i8,5x))')myid, 5367 & 'MEMCNT lvarpt:',MEMCNT,MAXMEM 5368#endif 5369 CALL MPI_GATHERV(MYNVAR(1), MYNROOTS, MPI_INTEGER, LVARPT(2), 5370 & NROOTS(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) 5371 IF(MYID .EQ. 0) THEN 5372 DO I=1, NPROCS 5373 RCVCNT(I) = sum(LVARPT(2+DISPLS(I):2+DISPLS(I)+NROOTS(I)-1)) 5374 IF(I .EQ. 1) THEN 5375 DISPLS(I) = 0 5376 ELSE 5377 DISPLS(I) = DISPLS(I-1)+RCVCNT(I-1) 5378 END IF 5379 END DO 5380 CALL MUMPS_733(LSTVAR, sum(RCVCNT(1:NPROCS)), id%INFO, 5381 & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) 5382 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5383#if defined (memprof) 5384 write(mp,'(i2,a30,2(i8,5x))')myid, 5385 & 'MEMCNT lstvar:',MEMCNT,MAXMEM 5386#endif 5387 END IF 5388 CALL MPI_GATHERV(MYLIST(1), PNT, MPI_INTEGER, LSTVAR(1), 5389 & RCVCNT(1), DISPLS(1), MPI_INTEGER, 0, id%COMM, IERR) 5390 NULLIFY(DISPLS) 5391 IF(MYID .EQ. 0) THEN 5392 LVARPT(1) = 1 5393 DO I=2, NCLIQUES+1 5394 LVARPT(I) = LVARPT(I-1) + LVARPT(I) 5395 END DO 5396 LPERM => WORK(3*id%N+1 : 4*id%N) 5397 NTVAR = ord%TOPNODES(2) 5398 CALL DMUMPS_782(id, ord%TOPNODES, LPERM, LIPERM, ord) 5399 CALL DMUMPS_774(id, ord%TOPNODES(2), LPERM, 5400 & top_graph, NCLIQUES, LSTVAR, LVARPT, IPET, PE, LENG, ELEN) 5401 TGSIZE = ord%TOPNODES(2)+NCLIQUES 5402 PFREET = IPET(TGSIZE+1) 5403 PFT_SAVE = PFREET 5404 nullify(LPERM) 5405 CALL MUMPS_734(top_graph%IRN_LOC, 5406 & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) 5407 W => NROOTS 5408 DEGREE => MYNVAR 5409 NDENSE => MYLIST 5410 NEXT => LVARPT 5411 HEAD => RCVCNT 5412 LAST => LSTVAR 5413 NULLIFY(NROOTS, MYNVAR, MYLIST, LVARPT, RCVCNT, LSTVAR) 5414 CALL MUMPS_733(PE, max(PFREET+TGSIZE,1), id%INFO, LP, 5415 & COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, ERRCODE=-7) 5416 CALL MUMPS_733(NDENSE, max(TGSIZE,1), id%INFO, LP, 5417 & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) 5418 CALL MUMPS_733(NVT, max(TGSIZE,1), id%INFO, LP, 5419 & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) 5420 CALL MUMPS_733(LAST, max(TGSIZE,1), id%INFO, LP, 5421 & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) 5422 CALL MUMPS_733(DEGREE, max(TGSIZE,1), id%INFO, LP, 5423 & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) 5424 CALL MUMPS_733(NEXT, max(TGSIZE,1), id%INFO, LP, 5425 & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) 5426 CALL MUMPS_733(W, max(TGSIZE,1), id%INFO, LP, 5427 & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) 5428 CALL MUMPS_733(LISTVAR_SCHUR, max(NCLIQUES,1), id%INFO, LP, 5429 & STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) 5430 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5431#if defined (memprof) 5432 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT pe:',MEMCNT,MAXMEM 5433#endif 5434 DO I=1, NCLIQUES 5435 LISTVAR_SCHUR(I) = NTVAR+I 5436 END DO 5437 THRESH = -1 5438 IF(ord%TOPSTRAT .EQ. 0) THEN 5439 CALL MUMPS_733(HEAD, max(TGSIZE,1), id%INFO, 5440 & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) 5441 CALL MUMPS_733(PERM, max(TGSIZE,1), id%INFO, 5442 & LP, COPY=.TRUE., STRING='J2:PERM', 5443 & MEMCNT=MEMCNT, ERRCODE=-7) 5444 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5445#if defined (memprof) 5446 write(mp,'(i2,a30,2(i8,5x))')myid, 5447 & 'MEMCNT rehead:',MEMCNT,MAXMEM 5448#endif 5449 DO I=1, TGSIZE 5450 PERM(I) = I 5451 END DO 5452 CALL MUMPS_420(2, -1, NDENSE(1), TGSIZE, 5453 & MUMPS_795(PE), IPET(1), PFREET, LENG(1), PE(1), 5454 & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), 5455 & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), NCLIQUES, 5456 & AGG6) 5457 ELSE 5458 NBBUCK = 2*TGSIZE 5459 CALL MUMPS_733(HEAD, NBBUCK+2, id%INFO, 5460 & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) 5461 CALL MUMPS_733(PERM, TGSIZE, id%INFO, 5462 & LP, STRING='J2:PERM', MEMCNT=MEMCNT, ERRCODE=-7) 5463 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5464#if defined (memprof) 5465 write(mp,'(i2,a30,2(i8,5x))')myid, 5466 & 'MEMCNT rehead:',MEMCNT,MAXMEM 5467#endif 5468 CALL MUMPS_419 (ord%TOPSTRAT, 2, .FALSE., TGSIZE, 5469 & NBBUCK, MUMPS_795(PE), IPET(1), PFREET, LENG(1), 5470 & PE(1), NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), 5471 & PERM(1), NEXT(1), W(1), HEAD(1), AGG6, NCLIQUES, 5472 & LISTVAR_SCHUR(1) ) 5473 END IF 5474 END IF 5475 CALL MPI_BARRIER(id%COMM, IERR) 5476 CALL MUMPS_734(LISTVAR_SCHUR, PE, MEMCNT=MEMCNT) 5477#if defined (memprof) 5478 write(mp,'(i2,a30,2(i8,5x))')myid,'deall lvs:',MEMCNT,MAXMEM 5479#endif 5480 IF(MYID .EQ. 0) THEN 5481 BUF_PE1 => WORK( 1 : id%N) 5482 BUF_PE2 => WORK( id%N+1 : 2*id%N) 5483 BUF_NV1 => WORK(2*id%N+1 : 3*id%N) 5484 BUF_NV2 => WORK(3*id%N+1 : 4*id%N) 5485 MAXS = NROWS_LOC 5486 DO I=2, NPROCS 5487 IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) 5488 & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) 5489 END DO 5490 CALL MUMPS_733(BUF_PE1, MAXS, id%INFO, 5491 & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) 5492 CALL MUMPS_733(BUF_PE2, MAXS, id%INFO, 5493 & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) 5494 CALL MUMPS_733(BUF_NV1, MAXS, id%INFO, 5495 & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) 5496 CALL MUMPS_733(BUF_NV2, MAXS, id%INFO, 5497 & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) 5498 CALL MUMPS_733(GPE, id%N, id%INFO, 5499 & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) 5500 CALL MUMPS_733(GNV, id%N, id%INFO, 5501 & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) 5502 CALL MUMPS_733(ROOTPERM, NCLIQUES, id%INFO, 5503 & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) 5504 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5505#if defined (memprof) 5506 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT buf_pe1:',MEMCNT, 5507 & MAXMEM 5508#endif 5509 RIDX = 0 5510 TMP1 => BUF_PE1 5511 TMP2 => BUF_NV1 5512 NULLIFY(BUF_PE1, BUF_NV1) 5513 BUF_PE1 => IPE 5514 BUF_NV1 => NV 5515 DO PROC=0, NPROCS-2 5516 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- 5517 & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, 5518 & id%COMM, RHANDPE, IERR) 5519 CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- 5520 & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, 5521 & id%COMM, RHANDNV, IERR) 5522 DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 5523 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) 5524 IF(BUF_PE1(I) .GT. 0) THEN 5525 RIDX=RIDX+1 5526 ROOTPERM(RIDX) = GLOB_IDX 5527 GNV(GLOB_IDX) = BUF_NV1(I) 5528 ELSE IF (BUF_PE1(I) .EQ. 0) THEN 5529 GPE(GLOB_IDX) = 0 5530 GNV(GLOB_IDX) = BUF_NV1(I) 5531 ELSE 5532 GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ 5533 & ord%FIRST(PROC+1)-1) 5534 GNV(GLOB_IDX) = BUF_NV1(I) 5535 END IF 5536 END DO 5537 CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) 5538 CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) 5539 IF(PROC .NE. 0) THEN 5540 TMP1 => BUF_PE1 5541 TMP2 => BUF_NV1 5542 END IF 5543 BUF_PE1 => BUF_PE2 5544 BUF_NV1 => BUF_NV2 5545 NULLIFY(BUF_PE2, BUF_NV2) 5546 BUF_PE2 => TMP1 5547 BUF_NV2 => TMP2 5548 NULLIFY(TMP1, TMP2) 5549 END DO 5550 DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 5551 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) 5552 IF(BUF_PE1(I) .GT. 0) THEN 5553 RIDX=RIDX+1 5554 ROOTPERM(RIDX) = GLOB_IDX 5555 GNV(GLOB_IDX) = BUF_NV1(I) 5556 ELSE IF (BUF_PE1(I) .EQ. 0) THEN 5557 GPE(GLOB_IDX) = 0 5558 GNV(GLOB_IDX) = BUF_NV1(I) 5559 ELSE 5560 GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ 5561 & ord%FIRST(PROC+1)-1) 5562 GNV(GLOB_IDX) = BUF_NV1(I) 5563 END IF 5564 END DO 5565 DO I=1, NTVAR 5566 GLOB_IDX = LIPERM(I) 5567 IF(IPET(I) .EQ. 0) THEN 5568 GPE(GLOB_IDX) = 0 5569 GNV(GLOB_IDX) = NVT(I) 5570 ELSE 5571 GPE(GLOB_IDX) = -LIPERM(-IPET(I)) 5572 GNV(GLOB_IDX) = NVT(I) 5573 END IF 5574 END DO 5575 DO I=1, NCLIQUES 5576 GLOB_IDX = ROOTPERM(I) 5577 GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) 5578 END DO 5579 ELSE 5580 CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, 5581 & MPI_INTEGER, 0, MYID, id%COMM, IERR) 5582 CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, 5583 & MPI_INTEGER, 0, MYID, id%COMM, IERR) 5584 END IF 5585 CALL MUMPS_734(PE, IPE, I_HALO_MAP, NDENSE, 5586 & LAST, DEGREE, MEMCNT=MEMCNT) 5587 CALL MUMPS_734(W, LISTVAR_SCHUR, NEXT, 5588 & NV, MEMCNT=MEMCNT) 5589 CALL MUMPS_734(LSTVAR, NROOTS, MYLIST, MYNVAR, 5590 & LVARPT, MEMCNT=MEMCNT) 5591 CALL MUMPS_734(LPERM, LIPERM, IPET, NVT, 5592 & MEMCNT=MEMCNT) 5593 CALL MUMPS_734(ROOTPERM, TMP1, TMP2, MEMCNT=MEMCNT) 5594 NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) 5595 RETURN 5596 END SUBROUTINE DMUMPS_720 5597 SUBROUTINE DMUMPS_782(id, TOPNODES, LPERM, LIPERM, ord) 5598 IMPLICIT NONE 5599 TYPE(DMUMPS_STRUC) :: id 5600 INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) 5601 TYPE(ORD_TYPE) :: ord 5602 INTEGER :: I, J, K, GIDX 5603 CALL MUMPS_733(LPERM , ord%N, id%INFO, 5604 & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) 5605 CALL MUMPS_733(LIPERM, TOPNODES(2), id%INFO, 5606 & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) 5607 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5608#if defined (memprof) 5609 write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT lperm:',MEMCNT, 5610 & MAXMEM 5611#endif 5612 LPERM = 0 5613 K = 1 5614 DO I=1, TOPNODES(1) 5615 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) 5616 GIDX = ord%PERITAB(J) 5617 LPERM(GIDX) = K 5618 LIPERM(K) = GIDX 5619 K = K+1 5620 END DO 5621 END DO 5622 RETURN 5623 END SUBROUTINE DMUMPS_782 5624 SUBROUTINE DMUMPS_774(id, NLOCVARS, LPERM, 5625 & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) 5626 IMPLICIT NONE 5627 TYPE(DMUMPS_STRUC) :: id 5628 TYPE(GRAPH_TYPE) :: top_graph 5629 INTEGER, POINTER :: LPERM(:), LSTVAR(:), LVARPT(:), 5630 & IPE(:), PE(:), LENG(:), ELEN(:) 5631 INTEGER :: NCLIQUES 5632 INTEGER :: I, J, IDX, NLOCVARS, PNT, SAVEPNT 5633 CALL MUMPS_733(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, 5634 & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) 5635 CALL MUMPS_733(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, 5636 & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) 5637 CALL MUMPS_733(IPE , NLOCVARS+NCLIQUES+1, id%INFO, 5638 & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) 5639 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5640#if defined (memprof) 5641 write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT leng:',MEMCNT, 5642 & MAXMEM 5643#endif 5644 LENG = 0 5645 ELEN = 0 5646 DO I=1, top_graph%NZ_LOC 5647 IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. 5648 & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN 5649 LENG(LPERM(top_graph%IRN_LOC(I))) = 5650 & LENG(LPERM(top_graph%IRN_LOC(I))) + 1 5651 END IF 5652 END DO 5653 DO I=1, NCLIQUES 5654 DO J=LVARPT(I), LVARPT(I+1)-1 5655 ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+1 5656 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 5657 END DO 5658 END DO 5659 IPE(1) = 1 5660 DO I=1, NLOCVARS+NCLIQUES 5661 IPE(I+1) = IPE(I)+LENG(I)+ELEN(I) 5662 END DO 5663 CALL MUMPS_733(PE, IPE(NLOCVARS+NCLIQUES+1)+NLOCVARS+NCLIQUES, 5664 & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) 5665 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5666#if defined (memprof) 5667 write(mp,'(i2,a30,2(i8,5x))')id%myid,'MEMCNT repe:',MEMCNT, 5668 & MAXMEM 5669#endif 5670 LENG = 0 5671 ELEN = 0 5672 DO I=1, NCLIQUES 5673 DO J=LVARPT(I), LVARPT(I+1)-1 5674 IDX = LPERM(LSTVAR(J)) 5675 PE(IPE(IDX)+ELEN(IDX)) = NLOCVARS+I 5676 PE(IPE(NLOCVARS+I)+LENG(NLOCVARS+I)) = IDX 5677 ELEN(LPERM(LSTVAR(J))) = ELEN(LPERM(LSTVAR(J)))+1 5678 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 5679 end do 5680 end do 5681 DO I=1, top_graph%NZ_LOC 5682 IF((LPERM(top_graph%JCN_LOC(I)) .NE. 0) .AND. 5683 & (top_graph%JCN_LOC(I) .NE. top_graph%IRN_LOC(I))) THEN 5684 PE(IPE(LPERM(top_graph%IRN_LOC(I)))+ 5685 & ELEN(LPERM(top_graph%IRN_LOC(I))) + 5686 & LENG(LPERM(top_graph%IRN_LOC(I)))) = 5687 & LPERM(top_graph%JCN_LOC(I)) 5688 LENG(LPERM(top_graph%IRN_LOC(I))) = 5689 & LENG(LPERM(top_graph%IRN_LOC(I))) + 1 5690 END IF 5691 END DO 5692 DO I=1, NLOCVARS+NCLIQUES 5693 LENG(I) = LENG(I)+ELEN(I) 5694 END DO 5695 SAVEPNT = 1 5696 PNT = 0 5697 LPERM(1:NLOCVARS+NCLIQUES) = 0 5698 DO I=1, NLOCVARS+NCLIQUES 5699 DO J=IPE(I), IPE(I+1)-1 5700 IF(LPERM(PE(J)) .EQ. I) THEN 5701 LENG(I) = LENG(I)-1 5702 ELSE 5703 LPERM(PE(J)) = I 5704 PNT = PNT+1 5705 PE(PNT) = PE(J) 5706 END IF 5707 END DO 5708 IPE(I) = SAVEPNT 5709 SAVEPNT = PNT+1 5710 END DO 5711 IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT 5712 RETURN 5713 END SUBROUTINE DMUMPS_774 5714 SUBROUTINE DMUMPS_778(TREETAB, RANGTAB, SIZES, CBLKNBR) 5715 INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) 5716 INTEGER :: CBLKNBR 5717 INTEGER :: LCHILD, RCHILD, K, I 5718 INTEGER, POINTER :: PERM(:) 5719 ALLOCATE(PERM(CBLKNBR)) 5720 TREETAB(CBLKNBR) = -1 5721 IF(CBLKNBR .EQ. 1) THEN 5722 DEALLOCATE(PERM) 5723 TREETAB(1) = -1 5724 RANGTAB(1:2) = (/1, SIZES(1)+1/) 5725 RETURN 5726 END IF 5727 LCHILD = CBLKNBR - (CBLKNBR+1)/2 5728 RCHILD = CBLKNBR-1 5729 K = 1 5730 PERM(CBLKNBR) = CBLKNBR 5731 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) 5732 PERM(RCHILD) = CBLKNBR+1 - (2*K) 5733 TREETAB(RCHILD) = CBLKNBR 5734 TREETAB(LCHILD) = CBLKNBR 5735 IF(CBLKNBR .GT. 3) THEN 5736 CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, 5737 & LCHILD, CBLKNBR, 2*K+1) 5738 CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, 5739 & RCHILD, CBLKNBR, 2*K) 5740 END IF 5741 RANGTAB(1)=1 5742 DO I=1, CBLKNBR 5743 RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) 5744 END DO 5745 DEALLOCATE(PERM) 5746 RETURN 5747 CONTAINS 5748 RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, 5749 & ROOTN, CBLKNBR, K) 5750 INTEGER, POINTER :: TREETAB(:), PERM(:) 5751 INTEGER :: SUBNODES, ROOTN, K, CBLKNBR 5752 INTEGER :: LCHILD, RCHILD 5753 LCHILD = ROOTN - (SUBNODES+1)/2 5754 RCHILD = ROOTN-1 5755 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) 5756 PERM(RCHILD) = CBLKNBR+1 - (2*K) 5757 TREETAB(RCHILD) = ROOTN 5758 TREETAB(LCHILD) = ROOTN 5759 IF(SUBNODES .GT. 3) THEN 5760 CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, 5761 & CBLKNBR, 2*K+1) 5762 CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, 5763 & CBLKNBR, 2*K) 5764 END IF 5765 END SUBROUTINE REC_TREETAB 5766 END SUBROUTINE DMUMPS_778 5767 SUBROUTINE DMUMPS_776(id, FIRST, LAST, IPE, 5768 & PE, WORK) 5769 IMPLICIT NONE 5770 INCLUDE 'mpif.h' 5771 TYPE(DMUMPS_STRUC) :: id 5772 INTEGER, POINTER :: FIRST(:), LAST(:), IPE(:), PE(:), 5773 & WORK(:) 5774 INTEGER :: IERR, MYID, NPROCS 5775 INTEGER :: I, PROC, LOCNNZ, 5776 & NEW_LOCNNZ, J, LOC_ROW 5777 INTEGER :: TOP_CNT, TIDX, 5778 & NROWS_LOC, DUPS, TOTDUPS, OFFDIAG 5779 INTEGER :: STATUS(MPI_STATUS_SIZE) 5780 INTEGER, POINTER :: MAPTAB(:), 5781 & SNDCNT(:), RCVCNT(:), SDISPL(:) 5782 INTEGER, POINTER :: RDISPL(:), 5783 & MSGCNT(:), SIPES(:,:), LENG(:) 5784 INTEGER, POINTER :: PCNT(:), TSENDI(:), 5785 & TSENDJ(:), RCVBUF(:) 5786 TYPE(ARRPNT), POINTER :: APNT(:) 5787 INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, 5788 & SAVEPNT 5789 INTEGER, PARAMETER :: ITAG=30 5790 LOGICAL :: FLAG 5791 DOUBLE PRECISION :: SYMMETRY 5792 nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) 5793 nullify(RDISPL, MSGCNT, SIPES, LENG) 5794 nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) 5795 CALL MPI_COMM_RANK (id%COMM, MYID, IERR) 5796 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) 5797 IF(MUMPS_795(WORK) .LT. id%N*2) THEN 5798 WRITE(LP, 5799 & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') 5800 CALL MUMPS_ABORT() 5801 END IF 5802 CALL MUMPS_733(SNDCNT, NPROCS, id%INFO, LP, 5803 & MEMCNT=MEMCNT, ERRCODE=-7) 5804 CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, 5805 & MEMCNT=MEMCNT, ERRCODE=-7) 5806 CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, 5807 & MEMCNT=MEMCNT, ERRCODE=-7) 5808 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5809#if defined (memprof) 5810 write(mp,'(i2,a30,2(i8,5x))')myid, 5811 & 'MEMCNT sndcnt:',MEMCNT,MAXMEM 5812#endif 5813 ALLOCATE(APNT(NPROCS)) 5814 SNDCNT = 0 5815 TOP_CNT = 0 5816 BUFSIZE = 1000 5817 LOCNNZ = id%NZ_loc 5818 NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 5819 MAPTAB => WORK( 1 : id%N) 5820 LENG => WORK(id%N+1 : 2*id%N) 5821 MAXS = 0 5822 DO I=1, NPROCS 5823 IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN 5824 MAXS = LAST(I)-FIRST(I)+1 5825 END IF 5826 DO J=FIRST(I), LAST(I) 5827 MAPTAB(J) = I 5828 END DO 5829 END DO 5830 ALLOCATE(SIPES(max(1,MAXS), NPROCS)) 5831 OFFDIAG=0 5832 SIPES=0 5833 DO I=1, id%NZ_loc 5834 IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN 5835 OFFDIAG = OFFDIAG+1 5836 PROC = MAPTAB(id%IRN_loc(I)) 5837 LOC_ROW = id%IRN_loc(I)-FIRST(PROC)+1 5838 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 5839 SNDCNT(PROC) = SNDCNT(PROC)+1 5840 PROC = MAPTAB(id%JCN_loc(I)) 5841 LOC_ROW = id%JCN_loc(I)-FIRST(PROC)+1 5842 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 5843 SNDCNT(PROC) = SNDCNT(PROC)+1 5844 END IF 5845 END DO 5846 CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP(114), 1, MPI_INTEGER, 5847 & MPI_SUM, id%COMM, IERR) 5848 id%KEEP(114) = id%KEEP(114)+3*id%N 5849 id%KEEP(113) = id%KEEP(114)-2*id%N 5850 CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, 5851 & MPI_INTEGER, id%COMM, IERR) 5852 SNDCNT(:) = MAXS 5853 CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), 5854 & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) 5855 DEALLOCATE(SIPES) 5856 CALL MUMPS_733(IPE, NROWS_LOC+1, id%INFO, 5857 & LP, STRING='IPE', MEMCNT=MEMCNT, ERRCODE=-7) 5858 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5859#if defined (memprof) 5860 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT ripe:',MEMCNT,MAXMEM 5861#endif 5862 IPE(1) = 1 5863 DO I=1, NROWS_LOC 5864 IPE(I+1) = IPE(I) + LENG(I) 5865 END DO 5866 CALL MUMPS_733(PE, max(IPE(NROWS_LOC+1)-1,1), id%INFO, 5867 & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) 5868 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5869#if defined (memprof) 5870 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe:',MEMCNT,MAXMEM 5871#endif 5872 LENG(:) = 0 5873 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, 5874 & RCVBUF, MSGCNT, SNDCNT, id%COMM) 5875 NEW_LOCNNZ = sum(RCVCNT) 5876 DO I=1, NPROCS 5877 MSGCNT(I) = RCVCNT(I)/BUFSIZE 5878 END DO 5879 RCVPNT = 1 5880 SNDCNT = 0 5881 TIDX = 0 5882 DO I=1, id%NZ_loc 5883 IF(mod(I,BUFSIZE/10) .EQ. 0) THEN 5884 CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, 5885 & FLAG, STATUS, IERR ) 5886 IF(FLAG) THEN 5887 SOURCE = STATUS(MPI_SOURCE) 5888 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, 5889 & ITAG, MPI_COMM_WORLD, STATUS, IERR) 5890 CALL DMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) 5891 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 5892 RCVPNT = RCVPNT + BUFSIZE 5893 END IF 5894 END IF 5895 IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN 5896 PROC = MAPTAB(id%IRN_loc(I)) 5897 APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%IRN_loc(I)- 5898 & FIRST(PROC)+1 5899 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%JCN_loc(I) 5900 SNDCNT(PROC) = SNDCNT(PROC)+1 5901 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN 5902 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, 5903 & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) 5904 END IF 5905 PROC = MAPTAB(id%JCN_loc(I)) 5906 APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = id%JCN_loc(I)- 5907 & FIRST(PROC)+1 5908 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = id%IRN_loc(I) 5909 SNDCNT(PROC) = SNDCNT(PROC)+1 5910 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN 5911 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, 5912 & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) 5913 END IF 5914 END IF 5915 END DO 5916 CALL DMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, 5917 & RCVBUF, MSGCNT, SNDCNT, id%COMM) 5918 DUPS = 0 5919 PNT = 0 5920 SAVEPNT = 1 5921 MAPTAB = 0 5922 DO I=1, NROWS_LOC 5923 DO J=IPE(I),IPE(I+1)-1 5924 IF(MAPTAB(PE(J)) .EQ. I) THEN 5925 DUPS = DUPS+1 5926 ELSE 5927 MAPTAB(PE(J)) = I 5928 PNT = PNT+1 5929 PE(PNT) = PE(J) 5930 END IF 5931 END DO 5932 IPE(I) = SAVEPNT 5933 SAVEPNT = PNT+1 5934 END DO 5935 CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER, MPI_SUM, 5936 & 0, id%COMM, IERR ) 5937 SYMMETRY = dble(TOTDUPS)/(dble(id%NZ)-dble(id%N)) 5938 IF(MYID .EQ. 0) THEN 5939 IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 5940 IF(PROKG) WRITE(MPG,'("Structual symmetry is:",i3,"%")') 5941 & ceiling(SYMMETRY*100.d0) 5942 id%INFOG(8) = ceiling(SYMMETRY*100.0d0) 5943 END IF 5944 IPE(NROWS_LOC+1) = SAVEPNT 5945 CALL MUMPS_734(SNDCNT, RCVCNT, MSGCNT, MEMCNT=MEMCNT) 5946 DEALLOCATE(APNT) 5947#if defined (memprof) 5948 write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM 5949#endif 5950 RETURN 5951 END SUBROUTINE DMUMPS_776 5952 SUBROUTINE DMUMPS_775(id, ord, GSIZE, IPE, PE, LENG, 5953 & I_HALO_MAP, top_graph, WORK) 5954 IMPLICIT NONE 5955 INCLUDE 'mpif.h' 5956 TYPE(DMUMPS_STRUC) :: id 5957 TYPE(ORD_TYPE) :: ord 5958 TYPE(GRAPH_TYPE) :: top_graph 5959 INTEGER, POINTER :: IPE(:), PE(:), LENG(:), 5960 & I_HALO_MAP(:), WORK(:) 5961 INTEGER :: GSIZE 5962 INTEGER :: IERR, MYID, NPROCS 5963 INTEGER :: I, PROC, LOCNNZ, 5964 & NEW_LOCNNZ, J, LOC_ROW 5965 INTEGER :: TOP_CNT,IIDX,JJDX 5966 INTEGER :: HALO_SIZE, TIDX, NROWS_LOC, DUPS 5967 INTEGER :: STATUS(MPI_STATUS_SIZE) 5968 INTEGER, POINTER :: MAPTAB(:), 5969 & SNDCNT(:), RCVCNT(:), 5970 & SDISPL(:), HALO_MAP(:) 5971 INTEGER, POINTER :: RDISPL(:), 5972 & MSGCNT(:), SIPES(:,:) 5973 INTEGER, POINTER :: PCNT(:), TSENDI(:), 5974 & TSENDJ(:), RCVBUF(:) 5975 TYPE(ARRPNT), POINTER :: APNT(:) 5976 INTEGER :: BUFSIZE, SOURCE, RCVPNT, MAXS, PNT, 5977 & SAVEPNT 5978 INTEGER, PARAMETER :: ITAG=30 5979 LOGICAL :: FLAG 5980 nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) 5981 nullify(RDISPL, MSGCNT, SIPES) 5982 nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) 5983 CALL MPI_COMM_RANK (id%COMM, MYID, IERR) 5984 CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) 5985 IF(MUMPS_795(WORK) .LT. id%N*2) THEN 5986 WRITE(LP, 5987 & '("Insufficient workspace inside BUILD_LOC_GRAPH")') 5988 CALL MUMPS_ABORT() 5989 END IF 5990 MAPTAB => WORK( 1 : id%N) 5991 HALO_MAP => WORK(id%N+1 : 2*id%N) 5992 CALL MUMPS_733(SNDCNT, NPROCS, id%INFO, LP, 5993 & MEMCNT=MEMCNT, ERRCODE=-7) 5994 CALL MUMPS_733(RCVCNT, NPROCS, id%INFO, LP, 5995 & MEMCNT=MEMCNT, ERRCODE=-7) 5996 CALL MUMPS_733(MSGCNT, NPROCS, id%INFO, LP, 5997 & MEMCNT=MEMCNT, ERRCODE=-7) 5998 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 5999#if defined (memprof) 6000 write(mp,'(i2,a30,2(i8,5x))')myid, 6001 & 'MEMCNT rrsndcnt:',MEMCNT,MAXMEM 6002#endif 6003 ALLOCATE(APNT(NPROCS)) 6004 SNDCNT = 0 6005 TOP_CNT = 0 6006 BUFSIZE = 10000 6007 LOCNNZ = id%NZ_loc 6008 NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 6009 MAPTAB = 0 6010 MAXS = 0 6011 DO I=1, NPROCS 6012 IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN 6013 MAXS = ord%LAST(I)-ord%FIRST(I)+1 6014 END IF 6015 DO J=ord%FIRST(I), ord%LAST(I) 6016 MAPTAB(ord%PERITAB(J)) = I 6017 END DO 6018 END DO 6019 ALLOCATE(SIPES(max(1,MAXS), NPROCS)) 6020 SIPES(:,:) = 0 6021 TOP_CNT = 0 6022 DO I=1, id%NZ_loc 6023 IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN 6024 PROC = MAPTAB(id%IRN_loc(I)) 6025 IF(PROC .EQ. 0) THEN 6026 TOP_CNT = TOP_CNT+1 6027 ELSE 6028 IIDX = ord%PERMTAB(id%IRN_loc(I)) 6029 LOC_ROW = IIDX-ord%FIRST(PROC)+1 6030 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 6031 SNDCNT(PROC) = SNDCNT(PROC)+1 6032 END IF 6033 PROC = MAPTAB(id%JCN_loc(I)) 6034 IF(PROC .EQ. 0) THEN 6035 TOP_CNT = TOP_CNT+1 6036 ELSE 6037 IIDX = ord%PERMTAB(id%JCN_loc(I)) 6038 LOC_ROW = IIDX-ord%FIRST(PROC)+1 6039 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 6040 SNDCNT(PROC) = SNDCNT(PROC)+1 6041 END IF 6042 END IF 6043 END DO 6044 CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, 6045 & MPI_INTEGER, id%COMM, IERR) 6046 I = ceiling(dble(MAXS)*1.20D0) 6047 CALL MUMPS_733(LENG, max(I,1), id%INFO, 6048 & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) 6049 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 6050#if defined (memprof) 6051 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrleng2:',MEMCNT, 6052 & MAXMEM 6053#endif 6054 SNDCNT(:) = MAXS 6055 CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), SNDCNT(1), 6056 & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) 6057 DEALLOCATE(SIPES) 6058 I = ceiling(dble(NROWS_LOC+1)*1.20D0) 6059 CALL MUMPS_733(IPE, max(I,1), id%INFO, 6060 & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) 6061 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 6062#if defined (memprof) 6063 write(mp,'(i2,a30,2(i8,5x))')myid, 6064 & 'MEMCNT rripe:',MEMCNT,MAXMEM 6065#endif 6066 IPE(1) = 1 6067 DO I=1, NROWS_LOC 6068 IPE(I+1) = IPE(I) + LENG(I) 6069 END DO 6070 CALL MUMPS_733(TSENDI, max(TOP_CNT,1), id%INFO, LP, 6071 & MEMCNT=MEMCNT, ERRCODE=-7) 6072 CALL MUMPS_733(TSENDJ, max(TOP_CNT,1), id%INFO, LP, 6073 & MEMCNT=MEMCNT, ERRCODE=-7) 6074 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 6075#if defined (memprof) 6076 write(mp,'(i2,a30,2(i8,5x))')myid, 6077 & 'MEMCNT tsendi:',MEMCNT,MAXMEM 6078#endif 6079 LENG(:) = 0 6080 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, 6081 & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) 6082 NEW_LOCNNZ = sum(RCVCNT) 6083 DO I=1, NPROCS 6084 MSGCNT(I) = RCVCNT(I)/BUFSIZE 6085 END DO 6086 CALL MUMPS_733(PE, max(NEW_LOCNNZ+2*NROWS_LOC,1), id%INFO, 6087 & LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) 6088 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 6089#if defined (memprof) 6090 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT rrpe2:',MEMCNT,MAXMEM 6091#endif 6092 RCVPNT = 1 6093 SNDCNT = 0 6094 TIDX = 0 6095 DO I=1, id%NZ_loc 6096 IF(mod(I,BUFSIZE/10) .EQ. 0) THEN 6097 CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, MPI_COMM_WORLD, 6098 & FLAG, STATUS, IERR ) 6099 IF(FLAG) THEN 6100 SOURCE = STATUS(MPI_SOURCE) 6101 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, 6102 & ITAG, MPI_COMM_WORLD, STATUS, IERR) 6103 CALL DMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) 6104 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 6105 RCVPNT = RCVPNT + BUFSIZE 6106 END IF 6107 END IF 6108 IF(id%IRN_loc(I) .NE. id%JCN_loc(I)) THEN 6109 PROC = MAPTAB(id%IRN_loc(I)) 6110 IF(PROC .EQ. 0) THEN 6111 TIDX = TIDX+1 6112 TSENDI(TIDX) = id%IRN_loc(I) 6113 TSENDJ(TIDX) = id%JCN_loc(I) 6114 ELSE 6115 IIDX = ord%PERMTAB(id%IRN_loc(I)) 6116 JJDX = ord%PERMTAB(id%JCN_loc(I)) 6117 APNT(PROC)%BUF(2*SNDCNT(PROC)+1) =IIDX-ord%FIRST(PROC)+1 6118 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. 6119 & (JJDX .LE. ord%LAST(PROC)) ) THEN 6120 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 6121 ELSE 6122 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%JCN_loc(I) 6123 END IF 6124 SNDCNT(PROC) = SNDCNT(PROC)+1 6125 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN 6126 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, 6127 & PE, LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) 6128 END IF 6129 END IF 6130 PROC = MAPTAB(id%JCN_loc(I)) 6131 IF(PROC .EQ. 0) THEN 6132 TIDX = TIDX+1 6133 TSENDI(TIDX) = id%JCN_loc(I) 6134 TSENDJ(TIDX) = id%IRN_loc(I) 6135 ELSE 6136 IIDX = ord%PERMTAB(id%JCN_loc(I)) 6137 JJDX = ord%PERMTAB(id%IRN_loc(I)) 6138 APNT(PROC)%BUF(2*SNDCNT(PROC)+1) = IIDX-ord%FIRST(PROC)+1 6139 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. 6140 & (JJDX .LE. ord%LAST(PROC)) ) THEN 6141 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = JJDX-ord%FIRST(PROC)+1 6142 ELSE 6143 APNT(PROC)%BUF(2*SNDCNT(PROC)+2) = -id%IRN_loc(I) 6144 END IF 6145 SNDCNT(PROC) = SNDCNT(PROC)+1 6146 IF(SNDCNT(PROC) .EQ. BUFSIZE) THEN 6147 CALL DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, 6148 & LENG, RCVBUF, MSGCNT, SNDCNT, id%COMM) 6149 END IF 6150 END IF 6151 END IF 6152 END DO 6153 CALL DMUMPS_785(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, 6154 & RCVBUF, MSGCNT, SNDCNT, id%COMM) 6155 DUPS = 0 6156 PNT = 0 6157 SAVEPNT = 1 6158 MAPTAB(:) = 0 6159 HALO_MAP(:) = 0 6160 HALO_SIZE = 0 6161 DO I=1, NROWS_LOC 6162 DO J=IPE(I),IPE(I+1)-1 6163 IF(PE(J) .LT. 0) THEN 6164 IF(HALO_MAP(-PE(J)) .EQ. 0) THEN 6165 HALO_SIZE = HALO_SIZE+1 6166 HALO_MAP(-PE(J)) = NROWS_LOC+HALO_SIZE 6167 END IF 6168 PE(J) = HALO_MAP(-PE(J)) 6169 END IF 6170 IF(MAPTAB(PE(J)) .EQ. I) THEN 6171 DUPS = DUPS+1 6172 LENG(I) = LENG(I)-1 6173 ELSE 6174 MAPTAB(PE(J)) = I 6175 PNT = PNT+1 6176 PE(PNT) = PE(J) 6177 END IF 6178 END DO 6179 IPE(I) = SAVEPNT 6180 SAVEPNT = PNT+1 6181 END DO 6182 IPE(NROWS_LOC+1) = SAVEPNT 6183 CALL MUMPS_733(I_HALO_MAP, HALO_SIZE, id%INFO, LP, 6184 & MEMCNT=MEMCNT, ERRCODE=-7) 6185 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 6186#if defined (memprof) 6187 write(mp,'(i2,a30,2(i8,5x))')myid, 6188 & 'MEMCNT i_halo:',MEMCNT,MAXMEM 6189#endif 6190 J=0 6191 DO I=1, id%N 6192 IF(HALO_MAP(I) .GT. 0) THEN 6193 J = J+1 6194 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I 6195 END IF 6196 IF(J .EQ. HALO_SIZE) EXIT 6197 END DO 6198 CALL MUMPS_733(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, 6199 & LP, COPY=.TRUE., 6200 & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) 6201 LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 6202 CALL MUMPS_733(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, 6203 & LP, COPY=.TRUE., 6204 & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) 6205 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 6206#if defined (memprof) 6207 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT lengipe:',MEMCNT, 6208 & MAXMEM 6209#endif 6210 IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) 6211 GSIZE = NROWS_LOC + HALO_SIZE 6212 CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER, RCVCNT(1), 1, 6213 & MPI_INTEGER, 0, id%COMM, IERR) 6214 RDISPL => MSGCNT 6215 NULLIFY(MSGCNT) 6216 IF(MYID.EQ.0) THEN 6217 NEW_LOCNNZ = sum(RCVCNT) 6218 RDISPL(1) = 0 6219 DO I=2, NPROCS 6220 RDISPL(I) = RDISPL(I-1)+RCVCNT(I-1) 6221 END DO 6222 top_graph%NZ_LOC = NEW_LOCNNZ 6223 top_graph%COMM = id%COMM 6224 CALL MUMPS_733(top_graph%IRN_LOC, NEW_LOCNNZ, id%INFO, 6225 & LP, MEMCNT=MEMCNT, ERRCODE=-7) 6226 CALL MUMPS_733(top_graph%JCN_LOC, NEW_LOCNNZ, id%INFO, 6227 & LP, MEMCNT=MEMCNT, ERRCODE=-7) 6228 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT 6229#if defined (memprof) 6230 write(mp,'(i2,a30,2(i8,5x))')myid,'MEMCNT top_graph:',MEMCNT, 6231 & MAXMEM 6232#endif 6233 ELSE 6234 ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1)) 6235 END IF 6236 CALL MPI_GATHERV(TSENDI(1), TOP_CNT, MPI_INTEGER, 6237 & top_graph%IRN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, 6238 & 0, id%COMM, IERR) 6239 CALL MPI_GATHERV(TSENDJ(1), TOP_CNT, MPI_INTEGER, 6240 & top_graph%JCN_LOC(1), RCVCNT(1), RDISPL(1), MPI_INTEGER, 6241 & 0, id%COMM, IERR) 6242 CALL MUMPS_734(SNDCNT, RCVCNT, RDISPL, 6243 & TSENDI, TSENDJ, MEMCNT=MEMCNT) 6244#if defined (memprof) 6245 write(mp,'(i2,a30,2(i8,5x))')myid,'deall sndcnt:',MEMCNT,MAXMEM 6246#endif 6247 DEALLOCATE(APNT) 6248 RETURN 6249 END SUBROUTINE DMUMPS_775 6250 SUBROUTINE DMUMPS_785(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, 6251 & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) 6252 IMPLICIT NONE 6253 INCLUDE 'mpif.h' 6254 INTEGER :: NPROCS, PROC, COMM 6255 TYPE(ARRPNT) :: APNT(:) 6256 INTEGER :: BUFSIZE 6257 INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:), IPE(:) 6258 INTEGER :: MSGCNT(:), SNDCNT(:) 6259 LOGICAL, SAVE :: INIT = .TRUE. 6260 INTEGER, POINTER, SAVE :: SPACE(:,:,:) 6261 LOGICAL, POINTER, SAVE :: PENDING(:) 6262 INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) 6263 INTEGER :: IERR, MYID, I, SOURCE, TOTMSG 6264 LOGICAL :: FLAG, TFLAG 6265 INTEGER :: STATUS(MPI_STATUS_SIZE), 6266 & TSTATUS(MPI_STATUS_SIZE) 6267 INTEGER, PARAMETER :: ITAG=30, FTAG=31 6268 INTEGER, POINTER :: TMPI(:), RCVCNT(:) 6269 CALL MPI_COMM_RANK (COMM, MYID, IERR) 6270 CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) 6271 IF(INIT) THEN 6272 ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS)) 6273 ALLOCATE(RCVBUF(2*BUFSIZE)) 6274 ALLOCATE(PENDING(NPROCS), CPNT(NPROCS)) 6275 ALLOCATE(REQ(NPROCS)) 6276 PENDING = .FALSE. 6277 DO I=1, NPROCS 6278 APNT(I)%BUF => SPACE(:,1,I) 6279 CPNT(I) = 1 6280 END DO 6281 INIT = .FALSE. 6282 RETURN 6283 END IF 6284 IF(PROC .EQ. -1) THEN 6285 TOTMSG = sum(MSGCNT) 6286 DO 6287 IF(TOTMSG .EQ. 0) EXIT 6288 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, 6289 & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) 6290 CALL DMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) 6291 SOURCE = STATUS(MPI_SOURCE) 6292 TOTMSG = TOTMSG-1 6293 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 6294 END DO 6295 DO I=1, NPROCS 6296 IF(PENDING(I)) THEN 6297 CALL MPI_WAIT(REQ(I), TSTATUS, IERR) 6298 END IF 6299 END DO 6300 ALLOCATE(RCVCNT(NPROCS)) 6301 CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, 6302 & MPI_INTEGER, COMM, IERR) 6303 DO I=1, NPROCS 6304 IF(SNDCNT(I) .GT. 0) THEN 6305 TMPI => APNT(I)%BUF(:) 6306 CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, 6307 & FTAG, COMM, REQ(I), IERR) 6308 END IF 6309 END DO 6310 DO I=1, NPROCS 6311 IF(RCVCNT(I) .GT. 0) THEN 6312 CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, 6313 & FTAG, COMM, STATUS, IERR) 6314 CALL DMUMPS_773(RCVCNT(I), RCVBUF, 6315 & IPE, PE, LENG) 6316 END IF 6317 END DO 6318 DO I=1, NPROCS 6319 IF(SNDCNT(I) .GT. 0) THEN 6320 CALL MPI_WAIT(REQ(I), TSTATUS, IERR) 6321 END IF 6322 END DO 6323 DEALLOCATE(SPACE) 6324 DEALLOCATE(PENDING, CPNT) 6325 DEALLOCATE(REQ) 6326 DEALLOCATE(RCVBUF, RCVCNT) 6327 nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) 6328 INIT = .TRUE. 6329 RETURN 6330 END IF 6331 IF(PENDING(PROC)) THEN 6332 DO 6333 CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) 6334 IF(TFLAG) THEN 6335 PENDING(PROC) = .FALSE. 6336 EXIT 6337 ELSE 6338 CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, 6339 & FLAG, STATUS, IERR ) 6340 IF(FLAG) THEN 6341 SOURCE = STATUS(MPI_SOURCE) 6342 CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, 6343 & SOURCE, ITAG, COMM, STATUS, IERR) 6344 CALL DMUMPS_773(BUFSIZE, RCVBUF, IPE, 6345 & PE, LENG) 6346 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 6347 END IF 6348 END IF 6349 END DO 6350 END IF 6351 TMPI => APNT(PROC)%BUF(:) 6352 CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, 6353 & ITAG, COMM, REQ(PROC), IERR) 6354 PENDING(PROC) = .TRUE. 6355 CPNT(PROC) = mod(CPNT(PROC),2)+1 6356 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) 6357 SNDCNT(PROC) = 0 6358 RETURN 6359 END SUBROUTINE DMUMPS_785 6360 SUBROUTINE DMUMPS_773(BUFSIZE, RCVBUF, IPE, PE, LENG) 6361#ifdef MPELOG 6362 USE MPEMOD 6363 INCLUDE 'mpif.h' 6364#endif 6365 IMPLICIT NONE 6366 INTEGER :: BUFSIZE 6367 INTEGER, POINTER :: RCVBUF(:), IPE(:), PE(:), LENG(:) 6368 INTEGER :: I, ROW, COL 6369#ifdef MPELOG 6370 INTEGER ::IERR 6371 IERR = MPE_LOG_EVENT( MPE_ASM_BUF1, 0, '' ) 6372#endif 6373 DO I=1, 2*BUFSIZE, 2 6374 ROW = RCVBUF(I) 6375 COL = RCVBUF(I+1) 6376 PE(IPE(ROW)+LENG(ROW)) = COL 6377 LENG(ROW) = LENG(ROW) + 1 6378 END DO 6379#ifdef MPELOG 6380 IERR = MPE_LOG_EVENT( MPE_ASM_BUF2, 0, '' ) 6381#endif 6382 RETURN 6383 END SUBROUTINE DMUMPS_773 6384 SUBROUTINE DMUMPS_777(ord) 6385 TYPE(ORD_TYPE) :: ord 6386 INTEGER :: I 6387 ord%SON = -1 6388 ord%BROTHER = -1 6389 ord%NW = 0 6390 DO I=1, ord%CBLKNBR 6391 ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) 6392 IF (ord%TREETAB(I) .NE. -1) THEN 6393 IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN 6394 ord%SON(ord%TREETAB(I)) = I 6395 ELSE 6396 ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) 6397 ord%SON(ord%TREETAB(I)) = I 6398 END IF 6399 ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) 6400 END IF 6401 END DO 6402 RETURN 6403 END SUBROUTINE DMUMPS_777 6404 SUBROUTINE DMUMPS_784(N, L, A1, A2) 6405 INTEGER :: I, LP, ISWAP, N 6406 INTEGER :: L(0:), A1(:), A2(:) 6407 LP = L(0) 6408 I = 1 6409 DO 6410 IF ((LP==0).OR.(I>N)) EXIT 6411 DO 6412 IF (LP >= I) EXIT 6413 LP = L(LP) 6414 END DO 6415 ISWAP = A1(LP) 6416 A1(LP) = A1(I) 6417 A1(I) = ISWAP 6418 ISWAP = A2(LP) 6419 A2(LP) = A2(I) 6420 A2(I) = ISWAP 6421 ISWAP = L(LP) 6422 L(LP) = L(I) 6423 L(I) = LP 6424 LP = ISWAP 6425 I = I + 1 6426 ENDDO 6427 END SUBROUTINE DMUMPS_784 6428 SUBROUTINE DMUMPS_783(N, K, L) 6429 INTEGER :: N 6430 INTEGER :: K(:), L(0:) 6431 INTEGER :: P, Q, S, T 6432 CONTINUE 6433 L(0) = 1 6434 T = N + 1 6435 DO P = 1,N - 1 6436 IF (K(P) <= K(P+1)) THEN 6437 L(P) = P + 1 6438 ELSE 6439 L(T) = - (P+1) 6440 T = P 6441 END IF 6442 END DO 6443 L(T) = 0 6444 L(N) = 0 6445 IF (L(N+1) == 0) THEN 6446 RETURN 6447 ELSE 6448 L(N+1) = iabs(L(N+1)) 6449 END IF 6450 200 CONTINUE 6451 S = 0 6452 T = N+1 6453 P = L(S) 6454 Q = L(T) 6455 IF(Q .EQ. 0) RETURN 6456 300 CONTINUE 6457 IF(K(P) .GT. K(Q)) GOTO 600 6458 CONTINUE 6459 L(S) = sign(P,L(S)) 6460 S = P 6461 P = L(P) 6462 IF (P .GT. 0) GOTO 300 6463 CONTINUE 6464 L(S) = Q 6465 S = T 6466 DO 6467 T = Q 6468 Q = L(Q) 6469 IF (Q .LE. 0) EXIT 6470 END DO 6471 GOTO 800 6472 600 CONTINUE 6473 L(S) = sign(Q, L(S)) 6474 S = Q 6475 Q = L(Q) 6476 IF (Q .GT. 0) GOTO 300 6477 CONTINUE 6478 L(S) = P 6479 S = T 6480 DO 6481 T = P 6482 P = L(P) 6483 IF (P .LE. 0) EXIT 6484 END DO 6485 800 CONTINUE 6486 P = -P 6487 Q = -Q 6488 IF(Q.EQ.0) THEN 6489 L(S) = sign(P, L(S)) 6490 L(T) = 0 6491 GOTO 200 6492 END IF 6493 GOTO 300 6494 END SUBROUTINE DMUMPS_783 6495 FUNCTION MUMPS_795(A) 6496 INTEGER, POINTER :: A(:) 6497 INTEGER :: MUMPS_795 6498 IF(associated(A)) THEN 6499 MUMPS_795 = size(A) 6500 ELSE 6501 MUMPS_795 = 0 6502 END IF 6503 RETURN 6504 END FUNCTION MUMPS_795 6505 SUBROUTINE MUMPS_734(A1, A2, A3, A4, A5, A6, A7, MEMCNT) 6506 INTEGER, POINTER :: A1(:) 6507 INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), 6508 & A6(:), A7(:) 6509 INTEGER, OPTIONAL :: MEMCNT 6510 INTEGER :: IMEMCNT 6511 IMEMCNT = 0 6512 IF(associated(A1)) THEN 6513 IMEMCNT = IMEMCNT+size(A1) 6514 DEALLOCATE(A1) 6515 END IF 6516 IF(present(A2)) THEN 6517 IF(associated(A2)) THEN 6518 IMEMCNT = IMEMCNT+size(A2) 6519 DEALLOCATE(A2) 6520 END IF 6521 END IF 6522 IF(present(A3)) THEN 6523 IF(associated(A3)) THEN 6524 IMEMCNT = IMEMCNT+size(A3) 6525 DEALLOCATE(A3) 6526 END IF 6527 END IF 6528 IF(present(A4)) THEN 6529 IF(associated(A4)) THEN 6530 IMEMCNT = IMEMCNT+size(A4) 6531 DEALLOCATE(A4) 6532 END IF 6533 END IF 6534 IF(present(A5)) THEN 6535 IF(associated(A5)) THEN 6536 IMEMCNT = IMEMCNT+size(A5) 6537 DEALLOCATE(A5) 6538 END IF 6539 END IF 6540 IF(present(A6)) THEN 6541 IF(associated(A6)) THEN 6542 IMEMCNT = IMEMCNT+size(A6) 6543 DEALLOCATE(A6) 6544 END IF 6545 END IF 6546 IF(present(A7)) THEN 6547 IF(associated(A7)) THEN 6548 IMEMCNT = IMEMCNT+size(A7) 6549 DEALLOCATE(A7) 6550 END IF 6551 END IF 6552 IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT 6553 RETURN 6554 END SUBROUTINE MUMPS_734 6555#if defined(memprof) 6556 FUNCTION ESTIMEM(MYID, N, NZR) 6557 INTEGER :: ESTIMEM, MYID, NZR, N 6558 IF(MYID.EQ.0) THEN 6559 ESTIMEM = 12*N 6560 ELSE 6561 ESTIMEM = 7*N 6562 END IF 6563 IF(MYID.NE.0) TOPROWS=0 6564 IF(MYID .EQ. 0) ESTIMEM = ESTIMEM+2*TOPROWS*NZR 6565 ESTIMEM = ESTIMEM+NRL 6566 ESTIMEM = ESTIMEM+max(NRL,TOPROWS)*(NZR+2) 6567 ESTIMEM = ESTIMEM+6*max(NRL,TOPROWS) 6568 IF(MYID.EQ.0) ESTIMEM=ESTIMEM+3*TOPROWS 6569 RETURN 6570 END FUNCTION ESTIMEM 6571#endif 6572 END MODULE 6573 SUBROUTINE DMUMPS_448(ICNTL,CNTL) 6574 IMPLICIT NONE 6575 INTEGER NICNTL, NCNTL 6576 PARAMETER (NICNTL=10, NCNTL=10) 6577 INTEGER ICNTL(NICNTL) 6578 DOUBLE PRECISION CNTL(NCNTL) 6579 INTEGER I 6580 ICNTL(1) = 6 6581 ICNTL(2) = 6 6582 ICNTL(3) = -1 6583 ICNTL(4) = -1 6584 ICNTL(5) = 0 6585 DO 10 I = 6,NICNTL 6586 ICNTL(I) = 0 6587 10 CONTINUE 6588 CNTL(1) = 0.0D0 6589 CNTL(2) = 0.0D0 6590 DO 20 I = 3,NCNTL 6591 CNTL(I) = 0.0D0 6592 20 CONTINUE 6593 RETURN 6594 END SUBROUTINE DMUMPS_448 6595 SUBROUTINE DMUMPS_444 6596 & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) 6597 IMPLICIT NONE 6598 INTEGER M,N,NE,NUM 6599 INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),PR(N),Q(M),L(M) 6600 DOUBLE PRECISION A(NE) 6601 DOUBLE PRECISION D(M), RINF 6602 INTEGER I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, 6603 & K,KK,KK1,KK2,I0,UP,LOW 6604 DOUBLE PRECISION CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX 6605 DOUBLE PRECISION ZERO,MINONE,ONE 6606 PARAMETER (ZERO=0.0D0,MINONE=-1.0D0,ONE=1.0D0) 6607 INTRINSIC abs,min 6608 EXTERNAL DMUMPS_445, DMUMPS_446, DMUMPS_447, DMUMPS_455 6609 RLX = D(1) 6610 NUM = 0 6611 BV = RINF 6612 DO 10 K = 1,N 6613 JPERM(K) = 0 6614 PR(K) = IP(K) 6615 10 CONTINUE 6616 DO 12 K = 1,M 6617 IPERM(K) = 0 6618 D(K) = ZERO 6619 12 CONTINUE 6620 DO 30 J = 1,N 6621 A0 = MINONE 6622 DO 20 K = IP(J),IP(J+1)-1 6623 I = IRN(K) 6624 AI = abs(A(K)) 6625 IF (AI.GT.D(I)) D(I) = AI 6626 IF (JPERM(J).NE.0) GO TO 20 6627 IF (AI.GE.BV) THEN 6628 A0 = BV 6629 IF (IPERM(I).NE.0) GO TO 20 6630 JPERM(J) = I 6631 IPERM(I) = J 6632 NUM = NUM + 1 6633 ELSE 6634 IF (AI.LE.A0) GO TO 20 6635 A0 = AI 6636 I0 = I 6637 ENDIF 6638 20 CONTINUE 6639 IF (A0.NE.MINONE .AND. A0.LT.BV) THEN 6640 BV = A0 6641 IF (IPERM(I0).NE.0) GO TO 30 6642 IPERM(I0) = J 6643 JPERM(J) = I0 6644 NUM = NUM + 1 6645 ENDIF 6646 30 CONTINUE 6647 IF (M.EQ.N) THEN 6648 DO 35 I = 1,M 6649 BV = min(BV,D(I)) 6650 35 CONTINUE 6651 ENDIF 6652 IF (NUM.EQ.N) GO TO 1000 6653 DO 95 J = 1,N 6654 IF (JPERM(J).NE.0) GO TO 95 6655 DO 50 K = IP(J),IP(J+1)-1 6656 I = IRN(K) 6657 AI = abs(A(K)) 6658 IF (AI.LT.BV) GO TO 50 6659 IF (IPERM(I).EQ.0) GO TO 90 6660 JJ = IPERM(I) 6661 KK1 = PR(JJ) 6662 KK2 = IP(JJ+1) - 1 6663 IF (KK1.GT.KK2) GO TO 50 6664 DO 70 KK = KK1,KK2 6665 II = IRN(KK) 6666 IF (IPERM(II).NE.0) GO TO 70 6667 IF (abs(A(KK)).GE.BV) GO TO 80 6668 70 CONTINUE 6669 PR(JJ) = KK2 + 1 6670 50 CONTINUE 6671 GO TO 95 6672 80 JPERM(JJ) = II 6673 IPERM(II) = JJ 6674 PR(JJ) = KK + 1 6675 90 NUM = NUM + 1 6676 JPERM(J) = I 6677 IPERM(I) = J 6678 PR(J) = K + 1 6679 95 CONTINUE 6680 IF (NUM.EQ.N) GO TO 1000 6681 DO 99 I = 1,M 6682 D(I) = MINONE 6683 L(I) = 0 6684 99 CONTINUE 6685 TBV = BV * (ONE-RLX) 6686 DO 100 JORD = 1,N 6687 IF (JPERM(JORD).NE.0) GO TO 100 6688 QLEN = 0 6689 LOW = M + 1 6690 UP = M + 1 6691 CSP = MINONE 6692 J = JORD 6693 PR(J) = -1 6694 DO 115 K = IP(J),IP(J+1)-1 6695 I = IRN(K) 6696 DNEW = abs(A(K)) 6697 IF (CSP.GE.DNEW) GO TO 115 6698 IF (IPERM(I).EQ.0) THEN 6699 CSP = DNEW 6700 ISP = I 6701 JSP = J 6702 IF (CSP.GE.TBV) GO TO 160 6703 ELSE 6704 D(I) = DNEW 6705 IF (DNEW.GE.TBV) THEN 6706 LOW = LOW - 1 6707 Q(LOW) = I 6708 ELSE 6709 QLEN = QLEN + 1 6710 L(I) = QLEN 6711 CALL DMUMPS_445(I,M,Q,D,L,1) 6712 ENDIF 6713 JJ = IPERM(I) 6714 PR(JJ) = J 6715 ENDIF 6716 115 CONTINUE 6717 DO 150 JDUM = 1,NUM 6718 IF (LOW.EQ.UP) THEN 6719 IF (QLEN.EQ.0) GO TO 160 6720 I = Q(1) 6721 IF (CSP.GE.D(I)) GO TO 160 6722 BV = D(I) 6723 TBV = BV * (ONE-RLX) 6724 DO 152 IDUM = 1,M 6725 CALL DMUMPS_446(QLEN,M,Q,D,L,1) 6726 L(I) = 0 6727 LOW = LOW - 1 6728 Q(LOW) = I 6729 IF (QLEN.EQ.0) GO TO 153 6730 I = Q(1) 6731 IF (D(I).LT.TBV) GO TO 153 6732 152 CONTINUE 6733 ENDIF 6734 153 UP = UP - 1 6735 Q0 = Q(UP) 6736 DQ0 = D(Q0) 6737 L(Q0) = UP 6738 J = IPERM(Q0) 6739 DO 155 K = IP(J),IP(J+1)-1 6740 I = IRN(K) 6741 IF (L(I).GE.UP) GO TO 155 6742 DNEW = min(DQ0,abs(A(K))) 6743 IF (CSP.GE.DNEW) GO TO 155 6744 IF (IPERM(I).EQ.0) THEN 6745 CSP = DNEW 6746 ISP = I 6747 JSP = J 6748 IF (CSP.GE.TBV) GO TO 160 6749 ELSE 6750 DI = D(I) 6751 IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 6752 D(I) = DNEW 6753 IF (DNEW.GE.TBV) THEN 6754 IF (DI.NE.MINONE) THEN 6755 CALL DMUMPS_447(L(I),QLEN,M,Q,D,L,1) 6756 ENDIF 6757 L(I) = 0 6758 LOW = LOW - 1 6759 Q(LOW) = I 6760 ELSE 6761 IF (DI.EQ.MINONE) THEN 6762 QLEN = QLEN + 1 6763 L(I) = QLEN 6764 ENDIF 6765 CALL DMUMPS_445(I,M,Q,D,L,1) 6766 ENDIF 6767 JJ = IPERM(I) 6768 PR(JJ) = J 6769 ENDIF 6770 155 CONTINUE 6771 150 CONTINUE 6772 160 IF (CSP.EQ.MINONE) GO TO 190 6773 BV = min(BV,CSP) 6774 TBV = BV * (ONE-RLX) 6775 NUM = NUM + 1 6776 I = ISP 6777 J = JSP 6778 DO 170 JDUM = 1,NUM+1 6779 I0 = JPERM(J) 6780 JPERM(J) = I 6781 IPERM(I) = J 6782 J = PR(J) 6783 IF (J.EQ.-1) GO TO 190 6784 I = I0 6785 170 CONTINUE 6786 190 DO 191 KK = UP,M 6787 I = Q(KK) 6788 D(I) = MINONE 6789 L(I) = 0 6790 191 CONTINUE 6791 DO 192 KK = LOW,UP-1 6792 I = Q(KK) 6793 D(I) = MINONE 6794 192 CONTINUE 6795 DO 193 KK = 1,QLEN 6796 I = Q(KK) 6797 D(I) = MINONE 6798 L(I) = 0 6799 193 CONTINUE 6800 100 CONTINUE 6801 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 6802 CALL DMUMPS_455(M,N,IPERM,L,JPERM) 6803 2000 RETURN 6804 END SUBROUTINE DMUMPS_444 6805 SUBROUTINE DMUMPS_445(I,N,Q,D,L,IWAY) 6806 IMPLICIT NONE 6807 INTEGER I,N,IWAY 6808 INTEGER Q(N),L(N) 6809 DOUBLE PRECISION D(N) 6810 INTEGER IDUM,K,POS,POSK,QK 6811 PARAMETER (K=2) 6812 DOUBLE PRECISION DI 6813 POS = L(I) 6814 IF (POS.LE.1) GO TO 20 6815 DI = D(I) 6816 IF (IWAY.EQ.1) THEN 6817 DO 10 IDUM = 1,N 6818 POSK = POS/K 6819 QK = Q(POSK) 6820 IF (DI.LE.D(QK)) GO TO 20 6821 Q(POS) = QK 6822 L(QK) = POS 6823 POS = POSK 6824 IF (POS.LE.1) GO TO 20 6825 10 CONTINUE 6826 ELSE 6827 DO 15 IDUM = 1,N 6828 POSK = POS/K 6829 QK = Q(POSK) 6830 IF (DI.GE.D(QK)) GO TO 20 6831 Q(POS) = QK 6832 L(QK) = POS 6833 POS = POSK 6834 IF (POS.LE.1) GO TO 20 6835 15 CONTINUE 6836 ENDIF 6837 20 Q(POS) = I 6838 L(I) = POS 6839 RETURN 6840 END SUBROUTINE DMUMPS_445 6841 SUBROUTINE DMUMPS_446(QLEN,N,Q,D,L,IWAY) 6842 IMPLICIT NONE 6843 INTEGER QLEN,N,IWAY 6844 INTEGER Q(N),L(N) 6845 DOUBLE PRECISION D(N) 6846 INTEGER I,IDUM,K,POS,POSK 6847 PARAMETER (K=2) 6848 DOUBLE PRECISION DK,DR,DI 6849 I = Q(QLEN) 6850 DI = D(I) 6851 QLEN = QLEN - 1 6852 POS = 1 6853 IF (IWAY.EQ.1) THEN 6854 DO 10 IDUM = 1,N 6855 POSK = K*POS 6856 IF (POSK.GT.QLEN) GO TO 20 6857 DK = D(Q(POSK)) 6858 IF (POSK.LT.QLEN) THEN 6859 DR = D(Q(POSK+1)) 6860 IF (DK.LT.DR) THEN 6861 POSK = POSK + 1 6862 DK = DR 6863 ENDIF 6864 ENDIF 6865 IF (DI.GE.DK) GO TO 20 6866 Q(POS) = Q(POSK) 6867 L(Q(POS)) = POS 6868 POS = POSK 6869 10 CONTINUE 6870 ELSE 6871 DO 15 IDUM = 1,N 6872 POSK = K*POS 6873 IF (POSK.GT.QLEN) GO TO 20 6874 DK = D(Q(POSK)) 6875 IF (POSK.LT.QLEN) THEN 6876 DR = D(Q(POSK+1)) 6877 IF (DK.GT.DR) THEN 6878 POSK = POSK + 1 6879 DK = DR 6880 ENDIF 6881 ENDIF 6882 IF (DI.LE.DK) GO TO 20 6883 Q(POS) = Q(POSK) 6884 L(Q(POS)) = POS 6885 POS = POSK 6886 15 CONTINUE 6887 ENDIF 6888 20 Q(POS) = I 6889 L(I) = POS 6890 RETURN 6891 END SUBROUTINE DMUMPS_446 6892 SUBROUTINE DMUMPS_447(POS0,QLEN,N,Q,D,L,IWAY) 6893 IMPLICIT NONE 6894 INTEGER POS0,QLEN,N,IWAY 6895 INTEGER Q(N),L(N) 6896 DOUBLE PRECISION D(N) 6897 INTEGER I,IDUM,K,POS,POSK,QK 6898 PARAMETER (K=2) 6899 DOUBLE PRECISION DK,DR,DI 6900 IF (QLEN.EQ.POS0) THEN 6901 QLEN = QLEN - 1 6902 RETURN 6903 ENDIF 6904 I = Q(QLEN) 6905 DI = D(I) 6906 QLEN = QLEN - 1 6907 POS = POS0 6908 IF (IWAY.EQ.1) THEN 6909 IF (POS.LE.1) GO TO 20 6910 DO 10 IDUM = 1,N 6911 POSK = POS/K 6912 QK = Q(POSK) 6913 IF (DI.LE.D(QK)) GO TO 20 6914 Q(POS) = QK 6915 L(QK) = POS 6916 POS = POSK 6917 IF (POS.LE.1) GO TO 20 6918 10 CONTINUE 6919 20 Q(POS) = I 6920 L(I) = POS 6921 IF (POS.NE.POS0) RETURN 6922 DO 30 IDUM = 1,N 6923 POSK = K*POS 6924 IF (POSK.GT.QLEN) GO TO 40 6925 DK = D(Q(POSK)) 6926 IF (POSK.LT.QLEN) THEN 6927 DR = D(Q(POSK+1)) 6928 IF (DK.LT.DR) THEN 6929 POSK = POSK + 1 6930 DK = DR 6931 ENDIF 6932 ENDIF 6933 IF (DI.GE.DK) GO TO 40 6934 QK = Q(POSK) 6935 Q(POS) = QK 6936 L(QK) = POS 6937 POS = POSK 6938 30 CONTINUE 6939 ELSE 6940 IF (POS.LE.1) GO TO 34 6941 DO 32 IDUM = 1,N 6942 POSK = POS/K 6943 QK = Q(POSK) 6944 IF (DI.GE.D(QK)) GO TO 34 6945 Q(POS) = QK 6946 L(QK) = POS 6947 POS = POSK 6948 IF (POS.LE.1) GO TO 34 6949 32 CONTINUE 6950 34 Q(POS) = I 6951 L(I) = POS 6952 IF (POS.NE.POS0) RETURN 6953 DO 36 IDUM = 1,N 6954 POSK = K*POS 6955 IF (POSK.GT.QLEN) GO TO 40 6956 DK = D(Q(POSK)) 6957 IF (POSK.LT.QLEN) THEN 6958 DR = D(Q(POSK+1)) 6959 IF (DK.GT.DR) THEN 6960 POSK = POSK + 1 6961 DK = DR 6962 ENDIF 6963 ENDIF 6964 IF (DI.LE.DK) GO TO 40 6965 QK = Q(POSK) 6966 Q(POS) = QK 6967 L(QK) = POS 6968 POS = POSK 6969 36 CONTINUE 6970 ENDIF 6971 40 Q(POS) = I 6972 L(I) = POS 6973 RETURN 6974 END SUBROUTINE DMUMPS_447 6975 SUBROUTINE DMUMPS_450(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) 6976 IMPLICIT NONE 6977 INTEGER WLEN,NVAL 6978 INTEGER IP(*),LENL(*),LENH(*),W(*) 6979 DOUBLE PRECISION A(*),VAL 6980 INTEGER XX,J,K,II,S,POS 6981 PARAMETER (XX=10) 6982 DOUBLE PRECISION SPLIT(XX),HA 6983 NVAL = 0 6984 DO 10 K = 1,WLEN 6985 J = W(K) 6986 DO 15 II = IP(J)+LENL(J),IP(J)+LENH(J)-1 6987 HA = A(II) 6988 IF (NVAL.EQ.0) THEN 6989 SPLIT(1) = HA 6990 NVAL = 1 6991 ELSE 6992 DO 20 S = NVAL,1,-1 6993 IF (SPLIT(S).EQ.HA) GO TO 15 6994 IF (SPLIT(S).GT.HA) THEN 6995 POS = S + 1 6996 GO TO 21 6997 ENDIF 6998 20 CONTINUE 6999 POS = 1 7000 21 DO 22 S = NVAL,POS,-1 7001 SPLIT(S+1) = SPLIT(S) 7002 22 CONTINUE 7003 SPLIT(POS) = HA 7004 NVAL = NVAL + 1 7005 ENDIF 7006 IF (NVAL.EQ.XX) GO TO 11 7007 15 CONTINUE 7008 10 CONTINUE 7009 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) 7010 RETURN 7011 END SUBROUTINE DMUMPS_450 7012 SUBROUTINE DMUMPS_451(N,NE,IP,IRN,A) 7013 IMPLICIT NONE 7014 INTEGER N,NE 7015 INTEGER IP(N+1),IRN(NE) 7016 DOUBLE PRECISION A(NE) 7017 INTEGER THRESH,TDLEN 7018 PARAMETER (THRESH=15,TDLEN=50) 7019 INTEGER J,IPJ,K,LEN,R,S,HI,FIRST,MID,LAST,TD 7020 DOUBLE PRECISION HA,KEY 7021 INTEGER TODO(TDLEN) 7022 DO 100 J = 1,N 7023 LEN = IP(J+1) - IP(J) 7024 IF (LEN.LE.1) GO TO 100 7025 IPJ = IP(J) 7026 IF (LEN.LT.THRESH) GO TO 400 7027 TODO(1) = IPJ 7028 TODO(2) = IPJ + LEN 7029 TD = 2 7030 500 CONTINUE 7031 FIRST = TODO(TD-1) 7032 LAST = TODO(TD) 7033 KEY = A((FIRST+LAST)/2) 7034 DO 475 K = FIRST,LAST-1 7035 HA = A(K) 7036 IF (HA.EQ.KEY) GO TO 475 7037 IF (HA.GT.KEY) GO TO 470 7038 KEY = HA 7039 GO TO 470 7040 475 CONTINUE 7041 TD = TD - 2 7042 GO TO 425 7043 470 MID = FIRST 7044 DO 450 K = FIRST,LAST-1 7045 IF (A(K).LE.KEY) GO TO 450 7046 HA = A(MID) 7047 A(MID) = A(K) 7048 A(K) = HA 7049 HI = IRN(MID) 7050 IRN(MID) = IRN(K) 7051 IRN(K) = HI 7052 MID = MID + 1 7053 450 CONTINUE 7054 IF (MID-FIRST.GE.LAST-MID) THEN 7055 TODO(TD+2) = LAST 7056 TODO(TD+1) = MID 7057 TODO(TD) = MID 7058 ELSE 7059 TODO(TD+2) = MID 7060 TODO(TD+1) = FIRST 7061 TODO(TD) = LAST 7062 TODO(TD-1) = MID 7063 ENDIF 7064 TD = TD + 2 7065 425 CONTINUE 7066 IF (TD.EQ.0) GO TO 400 7067 IF (TODO(TD)-TODO(TD-1).GE.THRESH) GO TO 500 7068 TD = TD - 2 7069 GO TO 425 7070 400 DO 200 R = IPJ+1,IPJ+LEN-1 7071 IF (A(R-1) .LT. A(R)) THEN 7072 HA = A(R) 7073 HI = IRN(R) 7074 A(R) = A(R-1) 7075 IRN(R) = IRN(R-1) 7076 DO 300 S = R-1,IPJ+1,-1 7077 IF (A(S-1) .LT. HA) THEN 7078 A(S) = A(S-1) 7079 IRN(S) = IRN(S-1) 7080 ELSE 7081 A(S) = HA 7082 IRN(S) = HI 7083 GO TO 200 7084 END IF 7085 300 CONTINUE 7086 A(IPJ) = HA 7087 IRN(IPJ) = HI 7088 END IF 7089 200 CONTINUE 7090 100 CONTINUE 7091 RETURN 7092 END SUBROUTINE DMUMPS_451 7093 SUBROUTINE DMUMPS_452(M,N,NE,IP,IRN,A,IPERM,NUMX, 7094 & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) 7095 IMPLICIT NONE 7096 INTEGER M,N,NE,NUMX 7097 INTEGER IP(N+1),IRN(NE),IPERM(N), 7098 & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) 7099 DOUBLE PRECISION A(NE),RLX,RINF 7100 INTEGER NUM,NVAL,WLEN,II,I,J,K,L,CNT,MOD,IDUM1,IDUM2,IDUM3 7101 DOUBLE PRECISION BVAL,BMIN,BMAX 7102 EXTERNAL DMUMPS_450,DMUMPS_453,DMUMPS_455 7103 DO 20 J = 1,N 7104 FC(J) = J 7105 LEN(J) = IP(J+1) - IP(J) 7106 20 CONTINUE 7107 DO 21 I = 1,M 7108 IW(I) = 0 7109 21 CONTINUE 7110 CNT = 1 7111 MOD = 1 7112 NUMX = 0 7113 CALL DMUMPS_453(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW,NUMX,N, 7114 & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 7115 NUM = NUMX 7116 IF (NUM.NE.N) THEN 7117 BMAX = RINF 7118 ELSE 7119 BMAX = RINF 7120 DO 30 J = 1,N 7121 BVAL = 0.0D0 7122 DO 25 K = IP(J),IP(J+1)-1 7123 IF (A(K).GT.BVAL) BVAL = A(K) 7124 25 CONTINUE 7125 IF (BVAL.LT.BMAX) BMAX = BVAL 7126 30 CONTINUE 7127 BMAX = 1.001D0 * BMAX 7128 ENDIF 7129 BVAL = 0.0D0 7130 BMIN = 0.0D0 7131 WLEN = 0 7132 DO 48 J = 1,N 7133 L = IP(J+1) - IP(J) 7134 LENH(J) = L 7135 LEN(J) = L 7136 DO 45 K = IP(J),IP(J+1)-1 7137 IF (A(K).LT.BMAX) GO TO 46 7138 45 CONTINUE 7139 K = IP(J+1) 7140 46 LENL(J) = K - IP(J) 7141 IF (LENL(J).EQ.L) GO TO 48 7142 WLEN = WLEN + 1 7143 W(WLEN) = J 7144 48 CONTINUE 7145 DO 90 IDUM1 = 1,NE 7146 IF (NUM.EQ.NUMX) THEN 7147 DO 50 I = 1,M 7148 IPERM(I) = IW(I) 7149 50 CONTINUE 7150 DO 80 IDUM2 = 1,NE 7151 BMIN = BVAL 7152 IF (BMAX-BMIN .LE. RLX) GO TO 1000 7153 CALL DMUMPS_450(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) 7154 IF (NVAL.LE.1) GO TO 1000 7155 K = 1 7156 DO 70 IDUM3 = 1,N 7157 IF (K.GT.WLEN) GO TO 71 7158 J = W(K) 7159 DO 55 II = IP(J)+LEN(J)-1,IP(J)+LENL(J),-1 7160 IF (A(II).GE.BVAL) GO TO 60 7161 I = IRN(II) 7162 IF (IW(I).NE.J) GO TO 55 7163 IW(I) = 0 7164 NUM = NUM - 1 7165 FC(N-NUM) = J 7166 55 CONTINUE 7167 60 LENH(J) = LEN(J) 7168 LEN(J) = II - IP(J) + 1 7169 IF (LENL(J).EQ.LENH(J)) THEN 7170 W(K) = W(WLEN) 7171 WLEN = WLEN - 1 7172 ELSE 7173 K = K + 1 7174 ENDIF 7175 70 CONTINUE 7176 71 IF (NUM.LT.NUMX) GO TO 81 7177 80 CONTINUE 7178 81 MOD = 1 7179 ELSE 7180 BMAX = BVAL 7181 IF (BMAX-BMIN .LE. RLX) GO TO 1000 7182 CALL DMUMPS_450(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) 7183 IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 7184 K = 1 7185 DO 87 IDUM3 = 1,N 7186 IF (K.GT.WLEN) GO TO 88 7187 J = W(K) 7188 DO 85 II = IP(J)+LEN(J),IP(J)+LENH(J)-1 7189 IF (A(II).LT.BVAL) GO TO 86 7190 85 CONTINUE 7191 86 LENL(J) = LEN(J) 7192 LEN(J) = II - IP(J) 7193 IF (LENL(J).EQ.LENH(J)) THEN 7194 W(K) = W(WLEN) 7195 WLEN = WLEN - 1 7196 ELSE 7197 K = K + 1 7198 ENDIF 7199 87 CONTINUE 7200 88 MOD = 0 7201 ENDIF 7202 CNT = CNT + 1 7203 CALL DMUMPS_453(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW,NUM,NUMX, 7204 & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 7205 90 CONTINUE 7206 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 7207 CALL DMUMPS_455(M,N,IPERM,IW,W) 7208 2000 RETURN 7209 END SUBROUTINE DMUMPS_452 7210 SUBROUTINE DMUMPS_453 7211 & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, 7212 & PR,ARP,CV,OUT) 7213 IMPLICIT NONE 7214 INTEGER ID,MOD,M,N,LIRN,NUM,NUMX 7215 INTEGER ARP(N),CV(M),IRN(LIRN),IP(N), 7216 & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) 7217 INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK,LAST,NFC, 7218 & NUM0,NUM1,NUM2,ID0,ID1 7219 IF (ID.EQ.1) THEN 7220 DO 5 I = 1,M 7221 CV(I) = 0 7222 5 CONTINUE 7223 DO 6 J = 1,N 7224 ARP(J) = 0 7225 6 CONTINUE 7226 NUM1 = N 7227 NUM2 = N 7228 ELSE 7229 IF (MOD.EQ.1) THEN 7230 DO 8 J = 1,N 7231 ARP(J) = 0 7232 8 CONTINUE 7233 ENDIF 7234 NUM1 = NUMX 7235 NUM2 = N - NUMX 7236 ENDIF 7237 NUM0 = NUM 7238 NFC = 0 7239 ID0 = (ID-1)*N 7240 DO 100 JORD = NUM0+1,N 7241 ID1 = ID0 + JORD 7242 J = FC(JORD-NUM0) 7243 PR(J) = -1 7244 DO 70 K = 1,JORD 7245 IF (ARP(J).GE.LENC(J)) GO TO 30 7246 IN1 = IP(J) + ARP(J) 7247 IN2 = IP(J) + LENC(J) - 1 7248 DO 20 II = IN1,IN2 7249 I = IRN(II) 7250 IF (IPERM(I).EQ.0) GO TO 80 7251 20 CONTINUE 7252 ARP(J) = LENC(J) 7253 30 OUT(J) = LENC(J) - 1 7254 DO 60 KK = 1,JORD 7255 IN1 = OUT(J) 7256 IF (IN1.LT.0) GO TO 50 7257 IN2 = IP(J) + LENC(J) - 1 7258 IN1 = IN2 - IN1 7259 DO 40 II = IN1,IN2 7260 I = IRN(II) 7261 IF (CV(I).EQ.ID1) GO TO 40 7262 J1 = J 7263 J = IPERM(I) 7264 CV(I) = ID1 7265 PR(J) = J1 7266 OUT(J1) = IN2 - II - 1 7267 GO TO 70 7268 40 CONTINUE 7269 50 J1 = PR(J) 7270 IF (J1.EQ.-1) THEN 7271 NFC = NFC + 1 7272 FC(NFC) = J 7273 IF (NFC.GT.NUM2) THEN 7274 LAST = JORD 7275 GO TO 101 7276 ENDIF 7277 GO TO 100 7278 ENDIF 7279 J = J1 7280 60 CONTINUE 7281 70 CONTINUE 7282 80 IPERM(I) = J 7283 ARP(J) = II - IP(J) + 1 7284 NUM = NUM + 1 7285 DO 90 K = 1,JORD 7286 J = PR(J) 7287 IF (J.EQ.-1) GO TO 95 7288 II = IP(J) + LENC(J) - OUT(J) - 2 7289 I = IRN(II) 7290 IPERM(I) = J 7291 90 CONTINUE 7292 95 IF (NUM.EQ.NUM1) THEN 7293 LAST = JORD 7294 GO TO 101 7295 ENDIF 7296 100 CONTINUE 7297 LAST = N 7298 101 DO 110 JORD = LAST+1,N 7299 NFC = NFC + 1 7300 FC(NFC) = FC(JORD-NUM0) 7301 110 CONTINUE 7302 RETURN 7303 END SUBROUTINE DMUMPS_453 7304 SUBROUTINE DMUMPS_454(M,N,NE,IP,IRN,A,IPERM,NUM, 7305 & JPERM,OUT,PR,Q,L,U,D,RINF) 7306 IMPLICIT NONE 7307 INTEGER M,N,NE,NUM 7308 INTEGER IP(N+1),IRN(NE),IPERM(M),JPERM(N),OUT(N),PR(N),Q(M),L(M) 7309 DOUBLE PRECISION A(NE),U(M),D(M),RINF,RINF3 7310 INTEGER I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,ISP,JSP, 7311 & K,K0,K1,K2,KK,KK1,KK2,UP,LOW 7312 DOUBLE PRECISION CSP,DI,DMIN,DNEW,DQ0,VJ,RLX 7313 LOGICAL LORD 7314 DOUBLE PRECISION ZERO, ONE 7315 PARAMETER (ZERO=0.0D0,ONE=1.0D0) 7316 EXTERNAL DMUMPS_445, DMUMPS_446, DMUMPS_447, DMUMPS_455 7317 RLX = U(1) 7318 RINF3 = U(2) 7319 LORD = (JPERM(1).EQ.6) 7320 NUM = 0 7321 DO 10 K = 1,N 7322 JPERM(K) = 0 7323 PR(K) = IP(K) 7324 D(K) = RINF 7325 10 CONTINUE 7326 DO 15 K = 1,M 7327 U(K) = RINF3 7328 IPERM(K) = 0 7329 L(K) = 0 7330 15 CONTINUE 7331 DO 30 J = 1,N 7332 IF (IP(J+1)-IP(J) .GT. N/10 .AND. N.GT.50) GO TO 30 7333 DO 20 K = IP(J),IP(J+1)-1 7334 I = IRN(K) 7335 IF (A(K).GT.U(I)) GO TO 20 7336 U(I) = A(K) 7337 IPERM(I) = J 7338 L(I) = K 7339 20 CONTINUE 7340 30 CONTINUE 7341 DO 40 I = 1,M 7342 J = IPERM(I) 7343 IF (J.EQ.0) GO TO 40 7344 IF (JPERM(J).EQ.0) THEN 7345 JPERM(J) = L(I) 7346 D(J) = U(I) 7347 NUM = NUM + 1 7348 ELSEIF (D(J).GT.U(I)) THEN 7349 K = JPERM(J) 7350 II = IRN(K) 7351 IPERM(II) = 0 7352 JPERM(J) = L(I) 7353 D(J) = U(I) 7354 ELSE 7355 IPERM(I) = 0 7356 ENDIF 7357 40 CONTINUE 7358 IF (NUM.EQ.N) GO TO 1000 7359 DO 45 K = 1,M 7360 D(K) = ZERO 7361 45 CONTINUE 7362 DO 95 J = 1,N 7363 IF (JPERM(J).NE.0) GO TO 95 7364 K1 = IP(J) 7365 K2 = IP(J+1) - 1 7366 IF (K1.GT.K2) GO TO 95 7367 VJ = RINF 7368 DO 50 K = K1,K2 7369 I = IRN(K) 7370 DI = A(K) - U(I) 7371 IF (DI.GT.VJ) GO TO 50 7372 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 7373 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 7374 55 VJ = DI 7375 I0 = I 7376 K0 = K 7377 50 CONTINUE 7378 D(J) = VJ 7379 K = K0 7380 I = I0 7381 IF (IPERM(I).EQ.0) GO TO 90 7382 DO 60 K = K0,K2 7383 I = IRN(K) 7384 IF (A(K)-U(I).GT.VJ) GO TO 60 7385 JJ = IPERM(I) 7386 KK1 = PR(JJ) 7387 KK2 = IP(JJ+1) - 1 7388 IF (KK1.GT.KK2) GO TO 60 7389 DO 70 KK = KK1,KK2 7390 II = IRN(KK) 7391 IF (IPERM(II).GT.0) GO TO 70 7392 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 7393 70 CONTINUE 7394 PR(JJ) = KK2 + 1 7395 60 CONTINUE 7396 GO TO 95 7397 80 JPERM(JJ) = KK 7398 IPERM(II) = JJ 7399 PR(JJ) = KK + 1 7400 90 NUM = NUM + 1 7401 JPERM(J) = K 7402 IPERM(I) = J 7403 PR(J) = K + 1 7404 95 CONTINUE 7405 IF (NUM.EQ.N) GO TO 1000 7406 DO 99 I = 1,M 7407 D(I) = RINF 7408 L(I) = 0 7409 99 CONTINUE 7410 DO 100 JORD = 1,N 7411 IF (JPERM(JORD).NE.0) GO TO 100 7412 DMIN = RINF 7413 QLEN = 0 7414 LOW = M + 1 7415 UP = M + 1 7416 CSP = RINF 7417 J = JORD 7418 PR(J) = -1 7419 DO 115 K = IP(J),IP(J+1)-1 7420 I = IRN(K) 7421 DNEW = A(K) - U(I) 7422 IF (DNEW.GE.CSP) GO TO 115 7423 IF (IPERM(I).EQ.0) THEN 7424 CSP = DNEW 7425 ISP = K 7426 JSP = J 7427 ELSE 7428 IF (DNEW.LT.DMIN) DMIN = DNEW 7429 D(I) = DNEW 7430 QLEN = QLEN + 1 7431 Q(QLEN) = K 7432 ENDIF 7433 115 CONTINUE 7434 Q0 = QLEN 7435 QLEN = 0 7436 DO 120 KK = 1,Q0 7437 K = Q(KK) 7438 I = IRN(K) 7439 IF (CSP.LE.D(I)) THEN 7440 D(I) = RINF 7441 GO TO 120 7442 ENDIF 7443 IF (D(I).LE.DMIN) THEN 7444 LOW = LOW - 1 7445 Q(LOW) = I 7446 L(I) = LOW 7447 ELSE 7448 QLEN = QLEN + 1 7449 L(I) = QLEN 7450 CALL DMUMPS_445(I,M,Q,D,L,2) 7451 ENDIF 7452 JJ = IPERM(I) 7453 OUT(JJ) = K 7454 PR(JJ) = J 7455 120 CONTINUE 7456 DO 150 JDUM = 1,NUM 7457 IF (LOW.EQ.UP) THEN 7458 IF (QLEN.EQ.0) GO TO 160 7459 I = Q(1) 7460 IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) 7461 IF (DMIN.GE.CSP) GO TO 160 7462 152 CALL DMUMPS_446(QLEN,M,Q,D,L,2) 7463 LOW = LOW - 1 7464 Q(LOW) = I 7465 L(I) = LOW 7466 IF (QLEN.EQ.0) GO TO 153 7467 I = Q(1) 7468 IF (D(I).GT.DMIN) GO TO 153 7469 GO TO 152 7470 ENDIF 7471 153 Q0 = Q(UP-1) 7472 DQ0 = D(Q0) 7473 IF (DQ0.GE.CSP) GO TO 160 7474 IF (DMIN.GE.CSP) GO TO 160 7475 UP = UP - 1 7476 J = IPERM(Q0) 7477 VJ = DQ0 - A(JPERM(J)) + U(Q0) 7478 K1 = IP(J+1)-1 7479 IF (LORD) THEN 7480 IF (CSP.NE.RINF) THEN 7481 DI = CSP - VJ 7482 IF (A(K1).GE.DI) THEN 7483 K0 = JPERM(J) 7484 IF (K0.GE.K1-6) GO TO 178 7485 177 CONTINUE 7486 K = (K0+K1)/2 7487 IF (A(K).GE.DI) THEN 7488 K1 = K 7489 ELSE 7490 K0 = K 7491 ENDIF 7492 IF (K0.GE.K1-6) GO TO 178 7493 GO TO 177 7494 178 DO 179 K = K0+1,K1 7495 IF (A(K).LT.DI) GO TO 179 7496 K1 = K - 1 7497 GO TO 181 7498 179 CONTINUE 7499 ENDIF 7500 ENDIF 7501 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 7502 ENDIF 7503 K0 = IP(J) 7504 DI = CSP - VJ 7505 DO 155 K = K0,K1 7506 I = IRN(K) 7507 IF (L(I).GE.LOW) GO TO 155 7508 DNEW = A(K) - U(I) 7509 IF (DNEW.GE.DI) GO TO 155 7510 DNEW = DNEW + VJ 7511 IF (DNEW.GT.D(I)) GO TO 155 7512 IF (IPERM(I).EQ.0) THEN 7513 CSP = DNEW 7514 ISP = K 7515 JSP = J 7516 DI = CSP - VJ 7517 ELSE 7518 IF (DNEW.GE.D(I)) GO TO 155 7519 D(I) = DNEW 7520 IF (DNEW.LE.DMIN) THEN 7521 IF (L(I).NE.0) THEN 7522 CALL DMUMPS_447(L(I),QLEN,M,Q,D,L,2) 7523 ENDIF 7524 LOW = LOW - 1 7525 Q(LOW) = I 7526 L(I) = LOW 7527 ELSE 7528 IF (L(I).EQ.0) THEN 7529 QLEN = QLEN + 1 7530 L(I) = QLEN 7531 ENDIF 7532 CALL DMUMPS_445(I,M,Q,D,L,2) 7533 ENDIF 7534 JJ = IPERM(I) 7535 OUT(JJ) = K 7536 PR(JJ) = J 7537 ENDIF 7538 155 CONTINUE 7539 150 CONTINUE 7540 160 IF (CSP.EQ.RINF) GO TO 190 7541 NUM = NUM + 1 7542 I = IRN(ISP) 7543 J = JSP 7544 IPERM(I) = J 7545 JPERM(J) = ISP 7546 DO 170 JDUM = 1,NUM 7547 JJ = PR(J) 7548 IF (JJ.EQ.-1) GO TO 180 7549 K = OUT(J) 7550 I = IRN(K) 7551 IPERM(I) = JJ 7552 JPERM(JJ) = K 7553 J = JJ 7554 170 CONTINUE 7555 180 DO 182 KK = UP,M 7556 I = Q(KK) 7557 U(I) = U(I) + D(I) - CSP 7558 182 CONTINUE 7559 190 DO 191 KK = UP,M 7560 I = Q(KK) 7561 D(I) = RINF 7562 L(I) = 0 7563 191 CONTINUE 7564 DO 192 KK = LOW,UP-1 7565 I = Q(KK) 7566 D(I) = RINF 7567 L(I) = 0 7568 192 CONTINUE 7569 DO 193 KK = 1,QLEN 7570 I = Q(KK) 7571 D(I) = RINF 7572 L(I) = 0 7573 193 CONTINUE 7574 100 CONTINUE 7575 1000 CONTINUE 7576 DO 1200 J = 1,N 7577 K = JPERM(J) 7578 IF (K.NE.0) THEN 7579 D(J) = A(K) - U(IRN(K)) 7580 ELSE 7581 D(J) = ZERO 7582 ENDIF 7583 1200 CONTINUE 7584 DO 1201 I = 1,M 7585 IF (IPERM(I).EQ.0) U(I) = ZERO 7586 1201 CONTINUE 7587 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 7588 CALL DMUMPS_455(M,N,IPERM,L,JPERM) 7589 2000 RETURN 7590 END SUBROUTINE DMUMPS_454 7591 SUBROUTINE DMUMPS_457 7592 & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) 7593 IMPLICIT NONE 7594 INTEGER LIRN,M,N,NUM 7595 INTEGER ARP(N),CV(M),IRN(LIRN),IP(N),IPERM(M),LENC(N),OUT(N),PR(N) 7596 INTEGER I,II,IN1,IN2,J,J1,JORD,K,KK 7597 EXTERNAL DMUMPS_455 7598 DO 10 I = 1,M 7599 CV(I) = 0 7600 IPERM(I) = 0 7601 10 CONTINUE 7602 DO 12 J = 1,N 7603 ARP(J) = LENC(J) - 1 7604 12 CONTINUE 7605 NUM = 0 7606 DO 1000 JORD = 1,N 7607 J = JORD 7608 PR(J) = -1 7609 DO 70 K = 1,JORD 7610 IN1 = ARP(J) 7611 IF (IN1.LT.0) GO TO 30 7612 IN2 = IP(J) + LENC(J) - 1 7613 IN1 = IN2 - IN1 7614 DO 20 II = IN1,IN2 7615 I = IRN(II) 7616 IF (IPERM(I).EQ.0) GO TO 80 7617 20 CONTINUE 7618 ARP(J) = -1 7619 30 CONTINUE 7620 OUT(J) = LENC(J) - 1 7621 DO 60 KK = 1,JORD 7622 IN1 = OUT(J) 7623 IF (IN1.LT.0) GO TO 50 7624 IN2 = IP(J) + LENC(J) - 1 7625 IN1 = IN2 - IN1 7626 DO 40 II = IN1,IN2 7627 I = IRN(II) 7628 IF (CV(I).EQ.JORD) GO TO 40 7629 J1 = J 7630 J = IPERM(I) 7631 CV(I) = JORD 7632 PR(J) = J1 7633 OUT(J1) = IN2 - II - 1 7634 GO TO 70 7635 40 CONTINUE 7636 50 CONTINUE 7637 J = PR(J) 7638 IF (J.EQ.-1) GO TO 1000 7639 60 CONTINUE 7640 70 CONTINUE 7641 80 CONTINUE 7642 IPERM(I) = J 7643 ARP(J) = IN2 - II - 1 7644 NUM = NUM + 1 7645 DO 90 K = 1,JORD 7646 J = PR(J) 7647 IF (J.EQ.-1) GO TO 1000 7648 II = IP(J) + LENC(J) - OUT(J) - 2 7649 I = IRN(II) 7650 IPERM(I) = J 7651 90 CONTINUE 7652 1000 CONTINUE 7653 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 7654 CALL DMUMPS_455(M,N,IPERM,CV,ARP) 7655 2000 RETURN 7656 END SUBROUTINE DMUMPS_457 7657 SUBROUTINE DMUMPS_455(M,N,IPERM,RW,CW) 7658 IMPLICIT NONE 7659 INTEGER M,N 7660 INTEGER RW(M),CW(N),IPERM(M) 7661 INTEGER I,J,K 7662 DO 10 J = 1,N 7663 CW(J) = 0 7664 10 CONTINUE 7665 K = 0 7666 DO 20 I = 1,M 7667 IF (IPERM(I).EQ.0) THEN 7668 K = K + 1 7669 RW(K) = I 7670 ELSE 7671 J = IPERM(I) 7672 CW(J) = I 7673 ENDIF 7674 20 CONTINUE 7675 K = 0 7676 DO 30 J = 1,N 7677 IF (CW(J).NE.0) GO TO 30 7678 K = K + 1 7679 I = RW(K) 7680 IPERM(I) = -J 7681 30 CONTINUE 7682 DO 40 J = N+1,M 7683 K = K + 1 7684 I = RW(K) 7685 IPERM(I) = -J 7686 40 CONTINUE 7687 RETURN 7688 END SUBROUTINE DMUMPS_455 7689