1C 2C This file is part of MUMPS 5.1.2, released 3C on Mon Oct 2 07:37:01 UTC 2017 4C 5C 6C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, 7C University of Bordeaux. 8C 9C This version of MUMPS is provided to you free of charge. It is 10C released under the CeCILL-C license: 11C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html 12C 13 SUBROUTINE SMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) 14 INTEGER, intent(in) :: LREC, XSIZE 15 INTEGER, intent(in) :: IW(LREC) 16 INTEGER(8), intent(out):: SIZE_FREE 17 INCLUDE 'mumps_headers.h' 18 IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. 19 & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN 20 SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) 21 ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. 22 & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN 23 SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ 24 & IW(1+XSIZE + 3) - 25 & ( IW(1+XSIZE + 4) 26 & - IW(1+XSIZE + 3) ), 8) 27 ELSE 28 SIZE_FREE=0_8 29 ENDIF 30 RETURN 31 END SUBROUTINE SMUMPS_SIZEFREEINREC 32 SUBROUTINE SMUMPS_MOVETONEXTRECORD 33 &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) 34 IMPLICIT NONE 35 INCLUDE 'mumps_headers.h' 36 INTEGER(8) :: RCURRENT 37 INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT 38 INTEGER IW(LIW) 39 INTEGER(8) :: RSIZE 40 ICURRENT=NEXT 41 CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) 42 RCURRENT = RCURRENT - RSIZE 43 NEXT=IW(ICURRENT+XXP) 44 IW(IXXP)=ICURRENT+ISIZE2SHIFT 45 IXXP=ICURRENT+XXP 46 RETURN 47 END SUBROUTINE SMUMPS_MOVETONEXTRECORD 48 SUBROUTINE SMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) 49 IMPLICIT NONE 50 INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT 51 INTEGER IW(LIW) 52 INTEGER I 53 IF (ISIZE2SHIFT.GT.0) THEN 54 DO I=END2SHIFT,BEG2SHIFT,-1 55 IW(I+ISIZE2SHIFT)=IW(I) 56 ENDDO 57 ELSE IF (ISIZE2SHIFT.LT.0) THEN 58 DO I=BEG2SHIFT,END2SHIFT 59 IW(I+ISIZE2SHIFT)=IW(I) 60 ENDDO 61 ENDIF 62 RETURN 63 END SUBROUTINE SMUMPS_ISHIFT 64 SUBROUTINE SMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) 65 IMPLICIT NONE 66 INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT 67 REAL A(LA) 68 INTEGER(8) :: I 69 IF (RSIZE2SHIFT.GT.0_8) THEN 70 DO I=END2SHIFT,BEG2SHIFT,-1_8 71 A(I+RSIZE2SHIFT)=A(I) 72 ENDDO 73 ELSE IF (RSIZE2SHIFT.LT.0_8) THEN 74 DO I=BEG2SHIFT,END2SHIFT 75 A(I+RSIZE2SHIFT)=A(I) 76 ENDDO 77 ENDIF 78 RETURN 79 END SUBROUTINE SMUMPS_RSHIFT 80 SUBROUTINE SMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, 81 & LRLU,IPTRLU,IWPOS, 82 & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, 83 & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID) 84 IMPLICIT NONE 85 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS 86 INTEGER N,LIW,KEEP28, 87 & IWPOS,IWPOSCB,KEEP216,XSIZE 88 INTEGER(8) :: PTRAST(KEEP28), PAMASTER(KEEP28) 89 INTEGER IW(LIW),PTRIST(KEEP28), 90 & STEP(N), PIMASTER(KEEP28) 91 REAL A(LA) 92 INTEGER, INTENT(INOUT) :: COMP 93 REAL, INTENT(INOUT) :: ACC_TIME 94 INTEGER, INTENT(IN) :: MYID 95 INCLUDE 'mumps_headers.h' 96 INTEGER ICURRENT, NEXT, STATE_NEXT 97 INTEGER(8) :: RCURRENT 98 INTEGER ISIZE2SHIFT 99 INTEGER(8) :: RSIZE2SHIFT 100 INTEGER IBEGCONTIG 101 INTEGER(8) :: RBEGCONTIG 102 INTEGER(8) :: RBEG2SHIFT, REND2SHIFT 103 INTEGER INODE 104 INTEGER(8) :: FREE_IN_REC 105 INTEGER(8) :: RCURRENT_SIZE 106 INTEGER IXXP 107 EXTERNAL MPI_WTIME 108 DOUBLE PRECISION MPI_WTIME 109 DOUBLE PRECISION TIME_REF, TIME_COMP 110 TIME_REF = MPI_WTIME() 111 ISIZE2SHIFT=0 112 RSIZE2SHIFT=0_8 113 ICURRENT = LIW-XSIZE+1 114 RCURRENT = LA+1_8 115 IBEGCONTIG = -999999 116 RBEGCONTIG = -999999_8 117 NEXT = IW(ICURRENT+XXP) 118 IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 119 COMP=COMP+1 120 STATE_NEXT = IW(NEXT+XXS) 121 IXXP = ICURRENT+XXP 122 10 CONTINUE 123 IF ( STATE_NEXT .NE. S_FREE .AND. 124 & (KEEP216.EQ.3.OR. 125 & (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND. 126 & STATE_NEXT .NE. S_NOLCBCONTIG .AND. 127 & STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND. 128 & STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN 129 CALL SMUMPS_MOVETONEXTRECORD(IW,LIW, 130 & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) 131 CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) 132 IF (IBEGCONTIG < 0) THEN 133 IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 134 ENDIF 135 IF (RBEGCONTIG < 0_8) THEN 136 RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 137 ENDIF 138 INODE=IW(ICURRENT+XXN) 139 IF (RSIZE2SHIFT .NE. 0_8) THEN 140 IF (PTRAST(STEP(INODE)).EQ.RCURRENT) 141 & PTRAST(STEP(INODE))= 142 & PTRAST(STEP(INODE))+RSIZE2SHIFT 143 IF (PAMASTER(STEP(INODE)).EQ.RCURRENT) 144 & PAMASTER(STEP(INODE))= 145 & PAMASTER(STEP(INODE))+RSIZE2SHIFT 146 ENDIF 147 IF (ISIZE2SHIFT .NE. 0) THEN 148 IF (PTRIST(STEP(INODE)).EQ.ICURRENT) 149 & PTRIST(STEP(INODE))= 150 & PTRIST(STEP(INODE))+ISIZE2SHIFT 151 IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) 152 & PIMASTER(STEP(INODE))= 153 & PIMASTER(STEP(INODE))+ISIZE2SHIFT 154 ENDIF 155 IF (NEXT .NE. TOP_OF_STACK) THEN 156 STATE_NEXT=IW(NEXT+XXS) 157 GOTO 10 158 ENDIF 159 ENDIF 160 20 CONTINUE 161 IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN 162 CALL SMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) 163 IF (IXXP .LE.IBEGCONTIG) THEN 164 IXXP=IXXP+ISIZE2SHIFT 165 ENDIF 166 ENDIF 167 IBEGCONTIG=-9999 168 25 CONTINUE 169 IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN 170 CALL SMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) 171 ENDIF 172 RBEGCONTIG=-99999_8 173 30 CONTINUE 174 IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 175 IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. 176 & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. 177 & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. 178 & STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN 179 IF ( KEEP216.eq.3) THEN 180 WRITE(*,*) "Internal error 2 in SMUMPS_COMPRE_NEW" 181 ENDIF 182 IF (RBEGCONTIG > 0_8) GOTO 25 183 CALL SMUMPS_MOVETONEXTRECORD 184 & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) 185 IF (IBEGCONTIG < 0 ) THEN 186 IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 187 ENDIF 188 CALL SMUMPS_SIZEFREEINREC(IW(ICURRENT), 189 & LIW-ICURRENT+1, 190 & FREE_IN_REC, 191 & XSIZE) 192 IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN 193 CALL SMUMPS_MAKECBCONTIG(A,LA,RCURRENT, 194 & IW(ICURRENT+XSIZE+2), 195 & IW(ICURRENT+XSIZE), 196 & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, 197 & IW(ICURRENT+XXS),RSIZE2SHIFT) 198 ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN 199 CALL SMUMPS_MAKECBCONTIG(A,LA,RCURRENT, 200 & IW(ICURRENT+XSIZE+2), 201 & IW(ICURRENT+XSIZE), 202 & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 203 & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), 204 & IW(ICURRENT+XXS),RSIZE2SHIFT) 205 ELSE IF (RSIZE2SHIFT .GT.0_8) THEN 206 RBEG2SHIFT = RCURRENT + FREE_IN_REC 207 CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) 208 REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 209 CALL SMUMPS_RSHIFT(A, LA, 210 & RBEG2SHIFT, REND2SHIFT, 211 & RSIZE2SHIFT) 212 ENDIF 213 INODE=IW(ICURRENT+XXN) 214 IF (ISIZE2SHIFT.NE.0) THEN 215 PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT 216 ENDIF 217 PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ 218 & FREE_IN_REC 219 CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) 220 IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR. 221 & STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN 222 IW(ICURRENT+XXS)=S_NOLCLEANED 223 ELSE 224 IW(ICURRENT+XXS)=S_NOLCLEANED38 225 ENDIF 226 RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC 227 RBEGCONTIG=-9999_8 228 IF (NEXT.EQ.TOP_OF_STACK) THEN 229 GOTO 20 230 ELSE 231 STATE_NEXT=IW(NEXT+XXS) 232 ENDIF 233 GOTO 30 234 ENDIF 235 IF (IBEGCONTIG.GT.0) THEN 236 GOTO 20 237 ENDIF 238 40 CONTINUE 239 IF (STATE_NEXT == S_FREE) THEN 240 ICURRENT = NEXT 241 CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) 242 ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) 243 RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE 244 RCURRENT = RCURRENT - RCURRENT_SIZE 245 NEXT=IW(ICURRENT+XXP) 246 IF (NEXT.EQ.TOP_OF_STACK) THEN 247 WRITE(*,*) "Internal error 1 in SMUMPS_COMPRE_NEW" 248 CALL MUMPS_ABORT() 249 ENDIF 250 STATE_NEXT = IW(NEXT+XXS) 251 GOTO 40 252 ENDIF 253 GOTO 10 254 100 CONTINUE 255 IWPOSCB = IWPOSCB + ISIZE2SHIFT 256 LRLU = LRLU + RSIZE2SHIFT 257 IPTRLU = IPTRLU + RSIZE2SHIFT 258 120 CONTINUE 259 TIME_COMP = MPI_WTIME() - TIME_REF 260 ACC_TIME = ACC_TIME + real(TIME_COMP) 261 RETURN 262 END SUBROUTINE SMUMPS_COMPRE_NEW 263 SUBROUTINE SMUMPS_GET_SIZEHOLE(IREC, IW, LIW, 264 & ISIZEHOLE, RSIZEHOLE) 265 IMPLICIT NONE 266 INTEGER, intent(in) :: IREC, LIW 267 INTEGER, intent(in) :: IW(LIW) 268 INTEGER, intent(out):: ISIZEHOLE 269 INTEGER(8), intent(out) :: RSIZEHOLE 270 INTEGER IRECLOC 271 INTEGER(8) :: RECLOC_SIZE 272 INCLUDE 'mumps_headers.h' 273 ISIZEHOLE=0 274 RSIZEHOLE=0_8 275 IRECLOC = IREC + IW( IREC+XXI ) 276 10 CONTINUE 277 CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) 278 IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN 279 ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) 280 RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE 281 IRECLOC=IRECLOC+IW(IRECLOC+XXI) 282 GOTO 10 283 ENDIF 284 RETURN 285 END SUBROUTINE SMUMPS_GET_SIZEHOLE 286 SUBROUTINE SMUMPS_MAKECBCONTIG(A, LA, RCURRENT, 287 & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) 288 IMPLICIT NONE 289 INCLUDE 'mumps_headers.h' 290 INTEGER LD, NROW, NCB, NELIM, NODESTATE 291 INTEGER(8) :: ISHIFT 292 INTEGER(8) :: LA, RCURRENT 293 REAL A(LA) 294 INTEGER I,J 295 INTEGER(8) :: IOLD,INEW 296 LOGICAL NELIM_ROOT 297 NELIM_ROOT=.TRUE. 298 IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN 299 NELIM_ROOT=.FALSE. 300 IF (NELIM.NE.0) THEN 301 WRITE(*,*) "Internal error 1 IN SMUMPS_MAKECBCONTIG" 302 CALL MUMPS_ABORT() 303 ENDIF 304 ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN 305 WRITE(*,*) "Internal error 2 in SMUMPS_MAKECBCONTIG" 306 & ,NODESTATE 307 CALL MUMPS_ABORT() 308 ENDIF 309 IF (ISHIFT .LT.0_8) THEN 310 WRITE(*,*) "Internal error 3 in SMUMPS_MAKECBCONTIG",ISHIFT 311 CALL MUMPS_ABORT() 312 ENDIF 313 IF (NELIM_ROOT) THEN 314 IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) 315 ELSE 316 IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 317 ENDIF 318 INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 319 DO I = NROW, 1, -1 320 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. 321 & .NOT. NELIM_ROOT) THEN 322 IOLD=IOLD-int(LD,8) 323 INEW=INEW-int(NCB,8) 324 CYCLE 325 ENDIF 326 IF (NELIM_ROOT) THEN 327 DO J=1,NELIM 328 A( INEW ) = A( IOLD + int(- J + 1,8)) 329 INEW = INEW - 1_8 330 ENDDO 331 ELSE 332 DO J=1, NCB 333 A( INEW ) = A( IOLD + int(- J + 1, 8)) 334 INEW = INEW - 1_8 335 ENDDO 336 ENDIF 337 IOLD = IOLD - int(LD,8) 338 ENDDO 339 IF (NELIM_ROOT) THEN 340 NODESTATE=S_NOLCBCONTIG38 341 ELSE 342 NODESTATE=S_NOLCBCONTIG 343 ENDIF 344 RETURN 345 END SUBROUTINE SMUMPS_MAKECBCONTIG 346