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_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, 14 & SSARBR, PROCESS_BANDE, 15 & MYID,N, KEEP,KEEP8,DKEEP, 16 & IW, LIW, A, LA, 17 & LRLU, IPTRLU,IWPOS,IWPOSCB, 18 & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, 19 & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, 20 & COMP, LRLUS, IFLAG, IERROR ) 21 USE SMUMPS_LOAD 22 IMPLICIT NONE 23 INTEGER N,LIW, KEEP(500) 24 INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LREQCB 25 INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) 26 INTEGER IWPOS,IWPOSCB 27 INTEGER(8) :: MIN_SPACE_IN_PLACE 28 INTEGER NODE_ARG, STATE_ARG 29 INTEGER(8) KEEP8(150) 30 REAL DKEEP(230) 31 INTEGER IW(LIW),PTRIST(KEEP(28)) 32 INTEGER STEP(N), PIMASTER(KEEP(28)) 33 INTEGER MYID, IXXP 34 REAL A(LA) 35 LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER 36 INTEGER COMP, LREQ, IFLAG, IERROR 37 INCLUDE 'mumps_headers.h' 38 INTEGER INODE_LOC,NPIV,NASS,NROW,NCB 39 INTEGER ISIZEHOLE 40 INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED 41 LOGICAL DONE 42 IF ( INPLACE ) THEN 43 LREQCB_EFF = MIN_SPACE_IN_PLACE 44 IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN 45 LREQCB_WISHED = LREQCB 46 ELSE 47 LREQCB_WISHED = 0_8 48 ENDIF 49 ELSE 50 LREQCB_EFF = LREQCB 51 LREQCB_WISHED = LREQCB 52 ENDIF 53 IF (IWPOSCB.EQ.LIW) THEN 54 IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 55 & .OR. .NOT. SET_HEADER) THEN 56 WRITE(*,*) "Internal error in SMUMPS_ALLOC_CB", 57 & SET_HEADER, LREQ, LREQCB 58 CALL MUMPS_ABORT() 59 ENDIF 60 IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN 61 WRITE(*,*) "Problem with integer stack size",IWPOSCB, 62 & IWPOS, KEEP(IXSZ) 63 IFLAG = -8 64 IERROR = LREQ 65 RETURN 66 ENDIF 67 IWPOSCB=IWPOSCB-KEEP(IXSZ) 68 IW(IWPOSCB+1+XXI)=KEEP(IXSZ) 69 CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) 70 IW(IWPOSCB+1+XXN)=-919191 71 IW(IWPOSCB+1+XXS)=S_NOTFREE 72 IW(IWPOSCB+1+XXP)=TOP_OF_STACK 73 RETURN 74 ENDIF 75 IF (KEEP(214).EQ.1.AND. 76 & KEEP(216).EQ.1.AND. 77 & IWPOSCB.NE.LIW) THEN 78 IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. 79 & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN 80 NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) 81 NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) 82 NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) 83 INODE_LOC= IW( IWPOSCB+1 + XXN) 84 CALL SMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, 85 & ISIZEHOLE,RSIZEHOLE) 86 IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN 87 CALL SMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, 88 & NROW,NCB,NPIV+NCB,0, 89 & IW(IWPOSCB+1 + XXS),RSIZEHOLE) 90 IW(IWPOSCB+1 + XXS) =S_NOLCLEANED 91 MEM_GAIN = int(NROW,8)*int(NPIV,8) 92 ENDIF 93 IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN 94 NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) 95 CALL SMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, 96 & NROW,NCB,NPIV+NCB,NASS-NPIV, 97 & IW(IWPOSCB+1 + XXS),RSIZEHOLE) 98 IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 99 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) 100 ENDIF 101 IF (ISIZEHOLE.NE.0) THEN 102 CALL SMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, 103 & IWPOSCB+IW(IWPOSCB+1+XXI), 104 & ISIZEHOLE ) 105 IWPOSCB=IWPOSCB+ISIZEHOLE 106 IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 107 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ 108 & ISIZEHOLE 109 ENDIF 110 CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) 111 IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE 112 LRLU = LRLU+MEM_GAIN+RSIZEHOLE 113 PTRAST(STEP(INODE_LOC))= 114 & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE 115 ENDIF 116 ENDIF 117 DONE =.FALSE. 118 IF ((IPTRLU.LT.LREQCB_WISHED).OR.(LRLU.LT.LREQCB_WISHED)) THEN 119 IF (LRLUS.LT.LREQCB_EFF) THEN 120 GOTO 620 121 ELSE 122 CALL SMUMPS_COMPRE_NEW(N,KEEP(28),IW,LIW,A,LA, 123 & LRLU,IPTRLU,IWPOS,IWPOSCB, 124 & PTRIST,PTRAST, 125 & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, 126 & KEEP(IXSZ), COMP, DKEEP(97), MYID) 127 IF ( LRLU .NE. LRLUS ) THEN 128 WRITE(*,*) 'PB compress... SMUMPS_ALLOC_CB', 129 & 'LRLU,LRLUS=',LRLU,LRLUS 130 GOTO 620 131 END IF 132 DONE = .TRUE. 133 ENDIF 134 ENDIF 135 IF (IWPOSCB-IWPOS+1 .LT. LREQ) THEN 136 IF (DONE) GOTO 600 137 CALL SMUMPS_COMPRE_NEW(N,KEEP(28),IW,LIW,A,LA, 138 & LRLU,IPTRLU,IWPOS,IWPOSCB, 139 & PTRIST,PTRAST, 140 & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, 141 & KEEP(IXSZ), COMP, DKEEP(97), MYID) 142 IF ( LRLU .NE. LRLUS ) THEN 143 WRITE(*,*) 'PB compress... SMUMPS_ALLOC_CB', 144 & 'LRLU,LRLUS=',LRLU,LRLUS 145 GOTO 620 146 END IF 147 IF (IWPOSCB-IWPOS+1 .LT. LREQ) GOTO 600 148 ENDIF 149 IXXP=IWPOSCB+XXP+1 150 IF (IXXP.GT.LIW) THEN 151 WRITE(*,*) "Internal error 3 in SMUMPS_ALLOC_CB",IXXP 152 ENDIF 153 IF (IW(IXXP).GT.0) THEN 154 WRITE(*,*) "Internal error 2 in SMUMPS_ALLOC_CB",IW(IXXP),IXXP 155 ENDIF 156 IWPOSCB = IWPOSCB - LREQ 157 IF (SET_HEADER) THEN 158 IW(IXXP)= IWPOSCB + 1 159 IW(IWPOSCB+1+XXI)=LREQ 160 CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) 161 IW(IWPOSCB+1+XXS)=STATE_ARG 162 IW(IWPOSCB+1+XXN)=NODE_ARG 163 IW(IWPOSCB+1+XXP)=TOP_OF_STACK 164 IW(IWPOSCB+1+XXP+1:IWPOSCB+1+KEEP(IXSZ))=-99999 165#if ! defined(NO_XXNBPR) 166 IW(IWPOSCB+1+XXNBPR)=0 167#endif 168 ENDIF 169 IPTRLU = IPTRLU - LREQCB 170 LRLU = LRLU - LREQCB 171 LRLUS = LRLUS - LREQCB_EFF 172 KEEP8(67) = min(LRLUS, KEEP8(67)) 173 KEEP8(70) = KEEP8(70) - LREQCB_EFF 174 KEEP8(68) = min(KEEP8(70), KEEP8(68)) 175 KEEP8(71) = KEEP8(71) - LREQCB_EFF 176 KEEP8(69) = min(KEEP8(71), KEEP8(69)) 177#if ! defined(OLD_LOAD_MECHANISM) 178 CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, 179 & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 180#else 181#if defined (CHECK_COHERENCE) 182 CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, 183 & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 184#else 185 CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., 186 & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 187#endif 188#endif 189 RETURN 190 600 IFLAG = -8 191 IERROR = LREQ 192 RETURN 193 620 IFLAG = -9 194 CALL MUMPS_SET_IERROR(LREQCB_EFF - LRLUS, IERROR) 195 RETURN 196 END SUBROUTINE SMUMPS_ALLOC_CB 197