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