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