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