sfac_mem_stack_aux.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, 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  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      SUBROUTINE smumps_compact_factors(A, LDA, NPIV, NBROW, KEEP,
     &           SIZEA, IW )
      IMPLICIT NONE
      INTEGER,    INTENT(IN) :: LDA, NPIV, NBROW
      INTEGER(8), INTENT(IN) :: SIZEA
      INTEGER, INTENT(IN) :: IW( NPIV )
      INTEGER :: KEEP(500)
      REAL :: A(SIZEA)
      INTEGER(8) :: IOLD, INEW, J8
      INTEGER I , ILAST
      INTEGER NBROW_L_RECTANGLE_TO_MOVE
      INTEGER :: ICOL_BEG, ICOL_END, NBPANELS, NB_TARGET
      INTEGER :: NBCOLS_PANEL, NBROWS_PANEL
      IF ( npiv .EQ. 0 ) GOTO 500
      nb_target = npiv
      IF ( keep(459) .GT. 1 .AND. keep(50) .NE. 0 ) THEN
        CALL mumps_ldltpanel_nbtarget( npiv, nb_target, keep )
      ENDIF
      IF ( keep(50) .EQ.0 .OR. nb_target .EQ. npiv ) THEN
        IF (lda.EQ.npiv) GOTO 500
        IF ( keep(50) .NE. 0 ) THEN
          iold = int(lda  + 1,8)
          inew = int(npiv + 1,8)
          IF (iold .EQ. inew ) THEN
            WRITE(*,*) " internal error in smumps_compact_factors",
     &      IOLD, INEW, NPIV
            CALL MUMPS_ABORT()
          ENDIF
          DO I = 1, NPIV - 1
.LE.            IF ( I  NPIV-2 ) THEN
              ILAST = I+1
            ELSE
              ILAST = I
            ENDIF
            DO J8 = 0_8, int(ILAST,8)
              A( INEW + J8 ) = A( IOLD + J8 )
            END DO
            INEW = INEW + int(NPIV,8)
            IOLD = IOLD + int(LDA,8)
          END DO
          NBROW_L_RECTANGLE_TO_MOVE = NBROW
        ELSE 
          INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8)
          IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8)
          NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1
        ENDIF
      ELSE
        ICOL_BEG = 1               
        NBPANELS  = 0
        INEW = 1_8
        NBROWS_PANEL = NPIV
.LE.        DO WHILE ( ICOL_BEG  NPIV )
          NBPANELS=NBPANELS + 1
          ICOL_END = min(NB_TARGET * NBPANELS, NPIV)
          IF ( IW( ICOL_END ) < 0 ) THEN 
            ICOL_END = ICOL_END + 1
          ENDIF
          NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1
          IOLD = int(ICOL_BEG-1,8) * int(LDA,8) + int(ICOL_BEG,8)
          DO I =1, NBROWS_PANEL
.NE.            IF (IOLD  INEW) THEN
              DO J8=0, min(I+1, NBCOLS_PANEL)-1 
              A(INEW+J8) = A(IOLD+J8)
              ENDDO
            ENDIF
            INEW = INEW + int(NBCOLS_PANEL,8)
            IOLD = IOLD + int(LDA,8)
          ENDDO
          NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL
          ICOL_BEG = ICOL_END + 1
        ENDDO
        IOLD = 1_8 + int(LDA,8)*int(NPIV,8)
        NBROW_L_RECTANGLE_TO_MOVE = NBROW
      ENDIF
      DO I = 1, NBROW_L_RECTANGLE_TO_MOVE
         DO J8 = 0_8, int(NPIV - 1,8)
           A( INEW + J8 ) = A( IOLD + J8 )
         END DO
         INEW = INEW + int(NPIV,8)
         IOLD = IOLD + int(LDA,8)
      ENDDO
 500  RETURN
      END SUBROUTINE SMUMPS_COMPACT_FACTORS
      SUBROUTINE SMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG,
     &                                        SIZEA )
      IMPLICIT NONE
      INTEGER,    INTENT(IN)     :: NCONTIG, NPIV, LDA
      INTEGER(8), INTENT(IN)     :: SIZEA
      REAL,    INTENT(INOUT)  :: A(SIZEA)
      INTEGER I, J
      INTEGER(8) :: INEW, IOLD
      INEW = int(NPIV+1,8)
      IOLD = int(LDA+1,8)
      DO I = 2, NCONTIG
        DO J = 1, NPIV
          A(INEW)=A(IOLD)
          INEW = INEW + 1_8
          IOLD = IOLD + 1_8
        ENDDO
        IOLD = IOLD + int(LDA - NPIV,8)
      ENDDO
      RETURN
      END SUBROUTINE SMUMPS_COMPACT_FACTORS_UNSYM
      SUBROUTINE SMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT,
     &           IPTRLU, NPIV,
     &           NBCOL_STACK, NBROW_STACK,
     &           NBROW_SEND, SIZECB, KEEP, PACKED_CB,
     &           LAST_ALLOWED, NBROW_ALREADY_STACKED )
      IMPLICIT NONE
      INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB
      LOGICAL, intent (in) :: PACKED_CB
      REAL A(LA)
      INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK,
     &                      NBROW_SEND
      INTEGER, intent(inout) :: NBROW_ALREADY_STACKED
      INTEGER(8), intent(in)    :: LAST_ALLOWED
      INTEGER(8) :: APOS, NPOS
      INTEGER NBROW
      INTEGER(8) :: J
      INTEGER I, KEEP(500)
#if defined(ZERO_TRIANGLE)
      REAL ZERO
        PARAMETER( ZERO = 0.0E0 )
#endif
      NBROW = NBROW_STACK + NBROW_SEND
.NE.      IF (NBROW_STACK  0 ) THEN
        NPOS = IPTRLU + SIZECB         
        APOS = POSELT + int(NPIV+NBROW,8) 
     &       * int(LDA,8) - 1_8 
.EQ..OR..NOT.        IF ( KEEP(50)  0   PACKED_CB ) THEN
          APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8)
          NPOS = NPOS
     &         - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8)
        ELSE
          APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8)
          NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) *
     &                    int(NBROW_ALREADY_STACKED+1,8) ) / 2_8
        ENDIF
        DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1
.EQ.          IF (KEEP(50)0) THEN
.LT.            IF ( NPOS - int(NBCOL_STACK,8) + 1_8 
     &                                  LAST_ALLOWED ) THEN
              EXIT
            ENDIF
            DO J= 1_8,int(NBCOL_STACK,8)
              A(NPOS-J+1_8) = A(APOS-J+1_8)
            ENDDO
            NPOS = NPOS - int(NBCOL_STACK,8)
          ELSE
.NOT.            IF ( PACKED_CB) THEN
.LT.              IF ( NPOS - int(NBCOL_STACK,8) + 1_8 
     &                                  LAST_ALLOWED ) THEN
                EXIT
              ENDIF
#if defined(ZERO_TRIANGLE)
              DO J = 1_8, int(NBCOL_STACK - I,8)
                A(NPOS - J + 1_8) = ZERO
              END DO
#endif
              NPOS = NPOS + int(- NBCOL_STACK + I,8)
            ENDIF
.LT.            IF ( NPOS - int(I,8) + 1_8  LAST_ALLOWED ) THEN
              EXIT
            ENDIF
            DO J =1_8, int(I,8)
              A(NPOS-J+1_8) = A(APOS-J+1_8)
            ENDDO
            NPOS = NPOS - int(I,8)
          ENDIF
.EQ.          IF (KEEP(50)0) THEN
            APOS = APOS - int(LDA,8)
          ELSE
            APOS = APOS - int(LDA + 1,8)
          ENDIF
          NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1
        ENDDO
      END IF
      RETURN
      END SUBROUTINE SMUMPS_COPY_CB_RIGHT_TO_LEFT
      SUBROUTINE SMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT,
     &           IPTRLU, NPIV,
     &           NBCOL_STACK, NBROW_STACK,
     &           NBROW_SEND, SIZECB, KEEP, PACKED_CB)
      IMPLICIT NONE
      INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB
      LOGICAL, intent (in) :: PACKED_CB
      REAL A(LA)
      INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK,
     &                      NBROW_SEND
      INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini
      INTEGER I, KEEP(500)
      INTEGER(8) :: J, LDA8
#if defined(ZERO_TRIANGLE)
      REAL ZERO
        PARAMETER( ZERO = 0.0E0 )
#endif
      LDA8 = int(LDA,8)
      NPOS_ini = IPTRLU + 1_8
      APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8)
!$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360))
      DO I = 1, NBROW_STACK
        IF (PACKED_CB) THEN
            NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 +
     &             int(I-1,8) * int(NBROW_SEND,8)
        ELSE
            NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8)
        ENDIF
        APOS  =  APOS_ini + int(I-1,8) * LDA8
.EQ.        IF (KEEP(50)0) THEN
          DO J = 1_8, int(NBCOL_STACK,8)
            A(NPOS+J-1_8) = A(APOS+J-1_8)
          ENDDO
        ELSE
          DO J  = 1_8, int(I + NBROW_SEND,8)
            A(NPOS+J-1_8)=A(APOS+J-1_8)
          ENDDO
#if defined(ZERO_TRIANGLE)
.NOT.          IF ( PACKED_CB) THEN
            A(NPOS+int(I+NBROW_SEND,8):
     &        NPOS+int(NBCOL_STACK-1,8))=ZERO
          ENDIF
#endif
        ENDIF
      ENDDO
!$OMP END PARALLEL DO
      RETURN
      END SUBROUTINE SMUMPS_COPY_CB_LEFT_TO_RIGHT