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 ZMUMPS_COMPACT_FACTORS(A, LDA, NPIV, NBROW, K50,
14     &           SIZEA )
15      IMPLICIT NONE
16      INTEGER LDA, NPIV, NBROW, K50
17      INTEGER(8), INTENT(IN) :: SIZEA
18      COMPLEX(kind=8) A(SIZEA)
19      INTEGER(8) :: IOLD, INEW, J8
20      INTEGER I , ILAST
21      INTEGER NBROW_L_RECTANGLE_TO_MOVE
22      IF ((NPIV.EQ.0).OR.(LDA.EQ.NPIV)) GOTO 500
23      IF ( K50.NE.0 ) THEN
24        IOLD = int(LDA  + 1,8)
25        INEW = int(NPIV + 1,8)
26        IF (IOLD .EQ. INEW ) THEN
27          INEW = INEW + int(NPIV,8) * int(NPIV - 1,8)
28          IOLD = IOLD + int(LDA,8) * int(NPIV - 1,8)
29        ELSE
30          DO I = 1, NPIV - 1
31            IF ( I .LE. NPIV-2 ) THEN
32              ILAST = I+1
33            ELSE
34              ILAST = I
35            ENDIF
36            DO J8 = 0_8, int(ILAST,8)
37              A( INEW + J8 ) = A( IOLD + J8 )
38            END DO
39            INEW = INEW + int(NPIV,8)
40            IOLD = IOLD + int(LDA,8)
41          END DO
42        ENDIF
43        NBROW_L_RECTANGLE_TO_MOVE = NBROW
44      ELSE
45        INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8)
46        IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8)
47        NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1
48      ENDIF
49      DO I = 1, NBROW_L_RECTANGLE_TO_MOVE
50         DO J8 = 0_8, int(NPIV - 1,8)
51           A( INEW + J8 ) = A( IOLD + J8 )
52         END DO
53         INEW = INEW + int(NPIV,8)
54         IOLD = IOLD + int(LDA,8)
55      ENDDO
56 500  RETURN
57      END SUBROUTINE ZMUMPS_COMPACT_FACTORS
58      SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG,
59     &                                        SIZEA )
60      IMPLICIT NONE
61      INTEGER,    INTENT(IN)     :: NCONTIG, NPIV, LDA
62      INTEGER(8), INTENT(IN)     :: SIZEA
63      COMPLEX(kind=8),    INTENT(INOUT)  :: A(SIZEA)
64      INTEGER I, J
65      INTEGER(8) :: INEW, IOLD
66      INEW = int(NPIV+1,8)
67      IOLD = int(LDA+1,8)
68      DO I = 2, NCONTIG
69        DO J = 1, NPIV
70          A(INEW)=A(IOLD)
71          INEW = INEW + 1_8
72          IOLD = IOLD + 1_8
73        ENDDO
74        IOLD = IOLD + int(LDA - NPIV,8)
75      ENDDO
76      RETURN
77      END SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM
78      SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT,
79     &           IPTRLU, NPIV,
80     &           NBCOL_STACK, NBROW_STACK,
81     &           NBROW_SEND, SIZECB, KEEP, COMPRESSCB,
82     &           LAST_ALLOWED, NBROW_ALREADY_STACKED )
83      IMPLICIT NONE
84      INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB
85      LOGICAL, intent (in) :: COMPRESSCB
86      COMPLEX(kind=8) A(LA)
87      INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK,
88     &                      NBROW_SEND
89      INTEGER, intent(inout) :: NBROW_ALREADY_STACKED
90      INTEGER(8), intent(in)    :: LAST_ALLOWED
91      INTEGER(8) :: APOS, NPOS
92      INTEGER NBROW
93      INTEGER(8) :: J
94      INTEGER I, KEEP(500)
95#if defined(ZERO_TRIANGLE)
96      COMPLEX(kind=8) ZERO
97        PARAMETER( ZERO = (0.0D0,0.0D0) )
98#endif
99      NBROW = NBROW_STACK + NBROW_SEND
100      IF (NBROW_STACK .NE. 0 ) THEN
101        NPOS = IPTRLU + SIZECB
102        APOS = POSELT + int(NPIV+NBROW,8)
103     &       * int(LDA,8) - 1_8
104        IF ( KEEP(50) .EQ. 0 .OR. .NOT. COMPRESSCB ) THEN
105          APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8)
106          NPOS = NPOS
107     &         - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8)
108        ELSE
109          APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8)
110          NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) *
111     &                    int(NBROW_ALREADY_STACKED+1,8) ) / 2_8
112        ENDIF
113        DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1
114          IF (KEEP(50).EQ.0) THEN
115            IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT.
116     &                                  LAST_ALLOWED ) THEN
117              EXIT
118            ENDIF
119            DO J= 1_8,int(NBCOL_STACK,8)
120              A(NPOS-J+1_8) = A(APOS-J+1_8)
121            ENDDO
122            NPOS = NPOS - int(NBCOL_STACK,8)
123          ELSE
124            IF (.NOT. COMPRESSCB) THEN
125              IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT.
126     &                                  LAST_ALLOWED ) THEN
127                EXIT
128              ENDIF
129#if defined(ZERO_TRIANGLE)
130              DO J = 1_8, int(NBCOL_STACK - I,8)
131                A(NPOS - J + 1_8) = ZERO
132              END DO
133#endif
134              NPOS = NPOS + int(- NBCOL_STACK + I,8)
135            ENDIF
136            IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN
137              EXIT
138            ENDIF
139            DO J =1_8, int(I,8)
140              A(NPOS-J+1_8) = A(APOS-J+1_8)
141            ENDDO
142            NPOS = NPOS - int(I,8)
143          ENDIF
144          IF (KEEP(50).EQ.0) THEN
145            APOS = APOS - int(LDA,8)
146          ELSE
147            APOS = APOS - int(LDA + 1,8)
148          ENDIF
149          NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1
150        ENDDO
151      END IF
152      RETURN
153      END SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT
154      SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT,
155     &           IPTRLU, NPIV,
156     &           NBCOL_STACK, NBROW_STACK,
157     &           NBROW_SEND, SIZECB, KEEP, COMPRESSCB)
158      IMPLICIT NONE
159      INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB
160      LOGICAL, intent (in) :: COMPRESSCB
161      COMPLEX(kind=8) A(LA)
162      INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK,
163     &                      NBROW_SEND
164      INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini
165      INTEGER I, KEEP(500)
166      INTEGER(8) :: J, LDA8
167#if defined(ZERO_TRIANGLE)
168      COMPLEX(kind=8) ZERO
169        PARAMETER( ZERO = (0.0D0,0.0D0) )
170#endif
171      LDA8 = int(LDA,8)
172      NPOS_ini = IPTRLU + 1_8
173      APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8)
174!$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > 300)
175      DO I = 1, NBROW_STACK
176         IF (COMPRESSCB) THEN
177            NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 +
178     &             int(I-1,8) * int(NBROW_SEND,8)
179         ELSE
180            NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8)
181        ENDIF
182        APOS  =  APOS_ini + int(I-1,8) * LDA8
183        IF (KEEP(50).EQ.0) THEN
184          DO J = 1_8, int(NBCOL_STACK,8)
185            A(NPOS+J-1_8) = A(APOS+J-1_8)
186          ENDDO
187        ELSE
188          DO J  = 1_8, int(I + NBROW_SEND,8)
189            A(NPOS+J-1_8)=A(APOS+J-1_8)
190          ENDDO
191#if defined(ZERO_TRIANGLE)
192          IF (.NOT. COMPRESSCB) THEN
193            A(NPOS+int(I+NBROW_SEND,8):
194     &        NPOS+int(NBCOL_STACK-1,8))=ZERO
195          ENDIF
196#endif
197        ENDIF
198      ENDDO
199!$OMP END PARALLEL DO
200      RETURN
201      END SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT
202