C
C  This file is part of MUMPS 5.1.1, released
C  on Mon Mar 20 14:34:33 UTC 2017
C
C
C  Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license:
C  http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html
C
      SUBROUTINE CMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE)
      INTEGER, intent(in) :: LREC, XSIZE
      INTEGER, intent(in) :: IW(LREC)
      INTEGER(8), intent(out):: SIZE_FREE
      INCLUDE 'mumps_headers.h'
      IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR.
     &    IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN
        SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8)
      ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR.
     &         IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN
        SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+
     &            IW(1+XSIZE + 3) -
     &          ( IW(1+XSIZE + 4)
     &          - IW(1+XSIZE + 3) ), 8)
      ELSE
        SIZE_FREE=0_8
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_SIZEFREEINREC
      SUBROUTINE CMUMPS_MOVETONEXTRECORD
     &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT)
      IMPLICIT NONE
      INCLUDE 'mumps_headers.h'
      INTEGER(8) :: RCURRENT
      INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT
      INTEGER IW(LIW)
      INTEGER(8) :: RSIZE
      ICURRENT=NEXT
      CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) )
      RCURRENT = RCURRENT - RSIZE
      NEXT=IW(ICURRENT+XXP)
      IW(IXXP)=ICURRENT+ISIZE2SHIFT
      IXXP=ICURRENT+XXP
      RETURN
      END SUBROUTINE CMUMPS_MOVETONEXTRECORD
      SUBROUTINE CMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT)
      IMPLICIT NONE
      INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT
      INTEGER IW(LIW)
      INTEGER I
      IF (ISIZE2SHIFT.GT.0) THEN
        DO I=END2SHIFT,BEG2SHIFT,-1
          IW(I+ISIZE2SHIFT)=IW(I)
        ENDDO
      ELSE IF (ISIZE2SHIFT.LT.0) THEN
        DO I=BEG2SHIFT,END2SHIFT
          IW(I+ISIZE2SHIFT)=IW(I)
        ENDDO
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_ISHIFT
      SUBROUTINE CMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT)
      IMPLICIT NONE
      INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT
      COMPLEX A(LA)
      INTEGER(8) :: I
      IF (RSIZE2SHIFT.GT.0_8) THEN
        DO I=END2SHIFT,BEG2SHIFT,-1_8
          A(I+RSIZE2SHIFT)=A(I)
        ENDDO
      ELSE IF (RSIZE2SHIFT.LT.0_8) THEN
        DO I=BEG2SHIFT,END2SHIFT
          A(I+RSIZE2SHIFT)=A(I)
        ENDDO
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_RSHIFT
      SUBROUTINE CMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA,
     &       LRLU,IPTRLU,IWPOS,
     &       IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER,
     &       KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID)
      IMPLICIT NONE
      INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS
      INTEGER N,LIW,KEEP28,
     &        IWPOS,IWPOSCB,KEEP216,XSIZE
      INTEGER(8) :: PTRAST(KEEP28), PAMASTER(KEEP28)
      INTEGER IW(LIW),PTRIST(KEEP28),
     &        STEP(N), PIMASTER(KEEP28)
      COMPLEX A(LA)
      INTEGER, INTENT(INOUT) :: COMP
      REAL, INTENT(INOUT)    :: ACC_TIME
      INTEGER, INTENT(IN)    :: MYID
      INCLUDE 'mumps_headers.h' 
      INTEGER ICURRENT, NEXT, STATE_NEXT
      INTEGER(8) :: RCURRENT
      INTEGER ISIZE2SHIFT
      INTEGER(8) :: RSIZE2SHIFT
      INTEGER IBEGCONTIG
      INTEGER(8) :: RBEGCONTIG
      INTEGER(8) :: RBEG2SHIFT, REND2SHIFT
      INTEGER INODE
      INTEGER(8) :: FREE_IN_REC
      INTEGER(8) :: RCURRENT_SIZE
      INTEGER IXXP
      EXTERNAL MPI_WTIME
      DOUBLE PRECISION MPI_WTIME
      DOUBLE PRECISION TIME_REF, TIME_COMP
      TIME_REF = MPI_WTIME()
      ISIZE2SHIFT=0
      RSIZE2SHIFT=0_8
      ICURRENT  = LIW-XSIZE+1
      RCURRENT = LA+1_8
      IBEGCONTIG = -999999 
      RBEGCONTIG = -999999_8 
      NEXT = IW(ICURRENT+XXP)
      IF (NEXT.EQ.TOP_OF_STACK) GOTO 120
      COMP=COMP+1
      STATE_NEXT = IW(NEXT+XXS)
      IXXP = ICURRENT+XXP
  10     CONTINUE
         IF ( STATE_NEXT .NE. S_FREE .AND.
     &        (KEEP216.EQ.3.OR.
     &         (STATE_NEXT .NE. S_NOLCBNOCONTIG .AND.
     &          STATE_NEXT .NE. S_NOLCBCONTIG .AND.
     &          STATE_NEXT .NE. S_NOLCBNOCONTIG38 .AND.
     &          STATE_NEXT .NE. S_NOLCBCONTIG38))) THEN
            CALL CMUMPS_MOVETONEXTRECORD(IW,LIW,
     &           IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT)
            CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR))
            IF (IBEGCONTIG < 0) THEN
              IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1
            ENDIF
            IF (RBEGCONTIG < 0_8) THEN
              RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8
            ENDIF
            INODE=IW(ICURRENT+XXN)
            IF (RSIZE2SHIFT .NE. 0_8) THEN
                IF (PTRAST(STEP(INODE)).EQ.RCURRENT)
     &            PTRAST(STEP(INODE))=
     &            PTRAST(STEP(INODE))+RSIZE2SHIFT
                IF (PAMASTER(STEP(INODE)).EQ.RCURRENT)
     &            PAMASTER(STEP(INODE))=
     &            PAMASTER(STEP(INODE))+RSIZE2SHIFT
            ENDIF
            IF (ISIZE2SHIFT .NE. 0) THEN
                IF (PTRIST(STEP(INODE)).EQ.ICURRENT)
     &            PTRIST(STEP(INODE))=
     &            PTRIST(STEP(INODE))+ISIZE2SHIFT
                IF (PIMASTER(STEP(INODE)).EQ.ICURRENT)
     &            PIMASTER(STEP(INODE))=
     &            PIMASTER(STEP(INODE))+ISIZE2SHIFT
            ENDIF
            IF (NEXT .NE. TOP_OF_STACK) THEN
              STATE_NEXT=IW(NEXT+XXS)
              GOTO 10
            ENDIF
         ENDIF
  20     CONTINUE
         IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN
           CALL CMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT)
           IF (IXXP .LE.IBEGCONTIG) THEN
           IXXP=IXXP+ISIZE2SHIFT
           ENDIF
         ENDIF
         IBEGCONTIG=-9999
  25     CONTINUE
         IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN
           CALL CMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT)
         ENDIF
         RBEGCONTIG=-99999_8
  30     CONTINUE
         IF (NEXT.EQ. TOP_OF_STACK) GOTO 100
         IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR.
     &       STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR.
     &       STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR.
     &       STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN
           IF ( KEEP216.eq.3) THEN
             WRITE(*,*) "Internal error 2 in CMUMPS_COMPRE_NEW"
           ENDIF
           IF (RBEGCONTIG > 0_8) GOTO 25
           CALL CMUMPS_MOVETONEXTRECORD
     &       (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT)
           IF (IBEGCONTIG < 0 ) THEN
             IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1
           ENDIF
           CALL CMUMPS_SIZEFREEINREC(IW(ICURRENT),
     &                              LIW-ICURRENT+1,
     &                              FREE_IN_REC,
     &                              XSIZE)
           IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN
             CALL CMUMPS_MAKECBCONTIG(A,LA,RCURRENT,
     &            IW(ICURRENT+XSIZE+2),
     &            IW(ICURRENT+XSIZE),
     &            IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0,
     &            IW(ICURRENT+XXS),RSIZE2SHIFT) 
           ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN
             CALL CMUMPS_MAKECBCONTIG(A,LA,RCURRENT,
     &            IW(ICURRENT+XSIZE+2),
     &            IW(ICURRENT+XSIZE),
     &            IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3),
     &            IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), 
     &            IW(ICURRENT+XXS),RSIZE2SHIFT) 
           ELSE IF (RSIZE2SHIFT .GT.0_8) THEN
             RBEG2SHIFT = RCURRENT + FREE_IN_REC
             CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR))
             REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8
             CALL CMUMPS_RSHIFT(A, LA,
     &                          RBEG2SHIFT, REND2SHIFT,
     &                          RSIZE2SHIFT)
           ENDIF
           INODE=IW(ICURRENT+XXN)
           IF (ISIZE2SHIFT.NE.0) THEN
             PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT
           ENDIF
           PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+
     &                         FREE_IN_REC
           CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC)
           IF (STATE_NEXT.EQ.S_NOLCBCONTIG.OR.
     &         STATE_NEXT.EQ.S_NOLCBNOCONTIG) THEN
             IW(ICURRENT+XXS)=S_NOLCLEANED
           ELSE
             IW(ICURRENT+XXS)=S_NOLCLEANED38
           ENDIF
           RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC
           RBEGCONTIG=-9999_8
           IF (NEXT.EQ.TOP_OF_STACK) THEN
             GOTO 20
           ELSE
             STATE_NEXT=IW(NEXT+XXS)
           ENDIF
           GOTO 30
         ENDIF
         IF (IBEGCONTIG.GT.0) THEN
           GOTO 20
         ENDIF
  40     CONTINUE
         IF (STATE_NEXT == S_FREE) THEN
            ICURRENT = NEXT
            CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) )
            ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI)
            RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE
            RCURRENT    = RCURRENT    - RCURRENT_SIZE
            NEXT=IW(ICURRENT+XXP)
            IF (NEXT.EQ.TOP_OF_STACK) THEN
              WRITE(*,*) "Internal error 1 in CMUMPS_COMPRE_NEW"
              CALL MUMPS_ABORT()
            ENDIF
            STATE_NEXT  = IW(NEXT+XXS)
            GOTO 40
         ENDIF
      GOTO 10
 100  CONTINUE
      IWPOSCB = IWPOSCB + ISIZE2SHIFT
      LRLU    = LRLU    + RSIZE2SHIFT
      IPTRLU  = IPTRLU  + RSIZE2SHIFT
 120  CONTINUE
      TIME_COMP = MPI_WTIME() - TIME_REF
      ACC_TIME = ACC_TIME + real(TIME_COMP)
      RETURN
      END SUBROUTINE CMUMPS_COMPRE_NEW
      SUBROUTINE CMUMPS_GET_SIZEHOLE(IREC, IW, LIW,
     &            ISIZEHOLE, RSIZEHOLE)
      IMPLICIT NONE
      INTEGER, intent(in) :: IREC, LIW
      INTEGER, intent(in) :: IW(LIW)
      INTEGER, intent(out):: ISIZEHOLE
      INTEGER(8), intent(out) :: RSIZEHOLE
      INTEGER IRECLOC
      INTEGER(8) :: RECLOC_SIZE
      INCLUDE 'mumps_headers.h'
      ISIZEHOLE=0
      RSIZEHOLE=0_8
      IRECLOC = IREC + IW( IREC+XXI )
 10   CONTINUE
      CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR))
      IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN
        ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI)
        RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE
        IRECLOC=IRECLOC+IW(IRECLOC+XXI)
        GOTO 10
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_GET_SIZEHOLE
      SUBROUTINE CMUMPS_MAKECBCONTIG(A, LA, RCURRENT,
     &           NROW, NCB, LD, NELIM, NODESTATE, ISHIFT)
      IMPLICIT NONE
      INCLUDE 'mumps_headers.h'
      INTEGER LD, NROW, NCB, NELIM, NODESTATE
      INTEGER(8) :: ISHIFT
      INTEGER(8) :: LA, RCURRENT
      COMPLEX A(LA)
      INTEGER I,J
      INTEGER(8) :: IOLD,INEW
      LOGICAL NELIM_ROOT
      NELIM_ROOT=.TRUE.
      IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN
         NELIM_ROOT=.FALSE.
         IF (NELIM.NE.0)  THEN
           WRITE(*,*) "Internal error 1 IN CMUMPS_MAKECBCONTIG"
           CALL MUMPS_ABORT()
         ENDIF
      ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN
           WRITE(*,*) "Internal error 2 in CMUMPS_MAKECBCONTIG"
     &                ,NODESTATE
           CALL MUMPS_ABORT()
      ENDIF
      IF (ISHIFT .LT.0_8) THEN
        WRITE(*,*) "Internal error 3 in CMUMPS_MAKECBCONTIG",ISHIFT
        CALL MUMPS_ABORT()
      ENDIF
      IF (NELIM_ROOT) THEN
        IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8)
      ELSE
        IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8
      ENDIF
      INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8
      DO I = NROW, 1, -1
        IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND.
     &    .NOT. NELIM_ROOT) THEN
          IOLD=IOLD-int(LD,8)
          INEW=INEW-int(NCB,8)
          CYCLE
        ENDIF
        IF (NELIM_ROOT) THEN
          DO J=1,NELIM
            A( INEW ) = A( IOLD + int(- J + 1,8))
            INEW = INEW - 1_8
          ENDDO
        ELSE
          DO J=1, NCB
            A( INEW ) = A( IOLD + int(- J + 1, 8))
            INEW = INEW - 1_8
          ENDDO
        ENDIF
        IOLD = IOLD - int(LD,8)
      ENDDO
      IF (NELIM_ROOT) THEN
        NODESTATE=S_NOLCBCONTIG38
      ELSE
        NODESTATE=S_NOLCBCONTIG
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_MAKECBCONTIG
