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      MODULE DMUMPS_FAC_LR
14      USE DMUMPS_LR_CORE
15      USE DMUMPS_LR_TYPE
16      USE DMUMPS_LR_STATS
17      USE DMUMPS_ANA_LR
18      IMPLICIT NONE
19      CONTAINS
20      SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_LDLT(
21     &        A, LA, POSELT, IFLAG, IERROR, NFRONT,
22     &        BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L,
23     &        NELIM, IW2, BLOCK,
24     &        MAXI_CLUSTER, NPIV, NIV,
25     &        COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT)
26!$    USE OMP_LIB
27      INTEGER(8), intent(in)       :: LA
28      INTEGER(8), intent(in)       :: POSELT
29      INTEGER, intent(in)          :: NFRONT, NB_BLR, CURRENT_BLR,
30     &   NELIM, MAXI_CLUSTER, NPIV, NIV
31      INTEGER, intent(out)         :: IFLAG, IERROR
32      DOUBLE PRECISION, intent(inout)    :: A(LA)
33      TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR-CURRENT_BLR)
34      DOUBLE PRECISION, INTENT(INOUT), TARGET :: BLOCK(:,:)
35      INTEGER, intent(in) :: IW2(*)
36      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR
37      INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT
38      DOUBLE PRECISION,intent(in) :: TOLEPS
39      INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK
40      DOUBLE PRECISION, POINTER, DIMENSION(:) :: BLOCK_PTR
41      LOGICAL :: BUILDQ
42      INTEGER :: OMP_NUM
43      INTEGER :: IBIS
44#if defined(BLR_MT)
45      INTEGER :: CHUNK
46#endif
47      INTEGER(8) :: POSELTT, POSELTD
48      DOUBLE PRECISION :: ONE, MONE, ZERO
49      PARAMETER (ONE = 1.0D0, MONE=-1.0D0)
50      PARAMETER (ZERO=0.0D0)
51      NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR
52      POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8)
53     &          + int(BEGS_BLR(CURRENT_BLR) - 1,8)
54      OMP_NUM = 0
55      BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,1)
56#if defined(BLR_MT)
57      CHUNK = 1
58!$OMP DO SCHEDULE(DYNAMIC, CHUNK)
59!$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, BLOCK_PTR,
60!$OMP&         MID_RANK, BUILDQ)
61#endif
62      DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2)
63        IF (IFLAG.LT.0) CYCLE
64        I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1
65        J = IBIS - I*(I-1)/2
66#if defined(BLR_MT)
67!$      OMP_NUM = OMP_GET_THREAD_NUM()
68        BLOCK_PTR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)
69#endif
70            POSELTT = POSELT + int(NFRONT,8) *
71     &                int(BEGS_BLR(CURRENT_BLR+I)-1,8)
72     &           + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8)
73            CALL DMUMPS_LRGEMM3('N', 'T', MONE,
74     &            BLR_L(J),BLR_L(I), ONE, A, LA,
75     &            POSELTT, NFRONT, 1, NIV, IFLAG, IERROR,
76     &            COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT,
77     &            MID_RANK, BUILDQ,
78     &            POSELTD, NFRONT,
79     &            IW2,
80     &            BLOCK_PTR,
81     &            MAXI_CLUSTER)
82            IF (IFLAG.LT.0) CYCLE
83            CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_L(J), BLR_L(I), 'N',
84     &          'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ
85     &          , (I.EQ.J)
86     &           )
87         ENDDO
88#if defined(BLR_MT)
89!$OMP END DO
90#endif
91      END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_LDLT
92      SUBROUTINE DMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT(A, LA, POSELT,
93     &        IFLAG, IERROR, NCOL, NROW, POSBLOCFACTO, LD_BLOCFACTO,
94     &        BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM,
95     &        BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS,
96     &        CURRENT_BLR_LM, CURRENT_BLR_LS,
97     &        IW2, BLOCK,
98     &        MAXI_CLUSTER,
99     &        COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT
100     &        )
101!$    USE OMP_LIB
102      INTEGER(8), intent(in)  :: LA, POSBLOCFACTO
103      DOUBLE PRECISION, intent(inout)  :: A(LA)
104      INTEGER(8), intent(in)  :: POSELT
105      INTEGER, intent(out)    :: IFLAG, IERROR
106      INTEGER, intent(in)     :: NCOL, NROW, IW2(*),
107     &                           MAXI_CLUSTER, LD_BLOCFACTO
108      INTEGER, intent(in)     :: NB_BLR_LM, NB_BLR_LS,
109     &                           ISHIFT_LM, ISHIFT_LS,
110     &                           CURRENT_BLR_LM, CURRENT_BLR_LS
111      DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER)
112      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS
113      TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM),
114     &                             BLR_LS(NB_BLR_LS-CURRENT_BLR_LS)
115      INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT
116      DOUBLE PRECISION,intent(in) :: TOLEPS
117      INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK
118      LOGICAL :: BUILDQ
119      INTEGER :: IBIS
120#if defined(BLR_MT)
121      INTEGER :: CHUNK
122#endif
123      INTEGER(8) :: POSELTT, POSELTD
124      DOUBLE PRECISION :: ONE, MONE, ZERO
125      PARAMETER (ONE = 1.0D0, MONE=-1.0D0)
126      PARAMETER (ZERO=0.0D0)
127      NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM
128      NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS
129      POSELTD = POSBLOCFACTO
130#if defined(BLR_MT)
131      CHUNK = 1
132!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
133!$OMP& PRIVATE(I, J, POSELTT, MID_RANK, BUILDQ)
134#endif
135      DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM)
136        IF (IFLAG.LT.0) CYCLE
137        I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1
138        J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM
139            POSELTT = POSELT
140     &           + int(NCOL,8) *
141     &             int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8)
142     &           + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8)
143            CALL DMUMPS_LRGEMM3('N', 'T', MONE,
144     &            BLR_LM(J),BLR_LS(I), ONE, A, LA,
145     &            POSELTT, NCOL,
146     &            1, 2, IFLAG, IERROR,
147     &            COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT,
148     &            MID_RANK, BUILDQ,
149     &            POSELTD, LD_BLOCFACTO,
150     &            IW2,
151     &            BLOCK,
152     &            MAXI_CLUSTER)
153            IF (IFLAG.LT.0) CYCLE
154            CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LM(J), BLR_LS(I),
155     &           'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ,
156     &            .FALSE.)
157         ENDDO
158#if defined(BLR_MT)
159!$OMP END DO
160         IF (IFLAG.LT.0) RETURN
161!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
162!$OMP& PRIVATE(I, J, POSELTT, MID_RANK, BUILDQ)
163#endif
164         DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2)
165          IF (IFLAG.LT.0) CYCLE
166          I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1
167          J = IBIS - I*(I-1)/2
168          POSELTT = POSELT
169     &        + int(NCOL,8) *
170     &          int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8)
171     &        + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8)
172          CALL DMUMPS_LRGEMM3('N', 'T', MONE,
173     &            BLR_LS(J),BLR_LS(I), ONE, A, LA,
174     &            POSELTT, NCOL,
175     &            1, 2, IFLAG, IERROR,
176     &            COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT,
177     &            MID_RANK, BUILDQ,
178     &            POSELTD, LD_BLOCFACTO,
179     &            IW2,
180     &            BLOCK,
181     &            MAXI_CLUSTER)
182            IF (IFLAG.LT.0) CYCLE
183            CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_LS(J), BLR_LS(I),
184     &           'N','T', 2, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ,
185     &            (I.EQ.J))
186      ENDDO
187#if defined(BLR_MT)
188!$OMP END DO
189#endif
190      END SUBROUTINE DMUMPS_SLAVE_BLR_UPD_TRAIL_LDLT
191      SUBROUTINE DMUMPS_BLR_UPDATE_NELIM_VAR(
192     &        A, LA, POSELT, IFLAG, IERROR, NFRONT,
193     &        BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L,
194     &        FIRST_BLOCK, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM)
195!$    USE OMP_LIB
196      INTEGER(8), intent(in)       :: LA
197      INTEGER(8), intent(in)       :: POSELT
198      INTEGER, intent(in)          :: NFRONT, NB_BLR_L, CURRENT_BLR,
199     &                                NELIM,  SYM, NIV, FIRST_BLOCK
200      LOGICAL, intent(in)          :: LBANDSLAVE
201      INTEGER, intent(out)         :: IFLAG, IERROR
202      INTEGER, intent(in)          :: ISHIFT
203      DOUBLE PRECISION, TARGET, intent(inout) :: A(LA)
204      TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR)
205      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U
206      INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL, IS
207      INTEGER :: allocok
208      INTEGER(8) :: POSELT_INCB, POSELT_TOP
209      DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
210      DOUBLE PRECISION :: ONE, MONE, ZERO
211      PARAMETER (ONE = 1.0D0, MONE=-1.0D0)
212      PARAMETER (ZERO=0.0D0)
213      NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR
214      IF (LBANDSLAVE) THEN
215       IS = ISHIFT
216      ELSE
217       IS = 0
218      ENDIF
219#if defined(BLR_MT)
220!$OMP SINGLE
221#endif
222      IF (NELIM.NE.0) THEN
223        DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L
224          KL = BLR_L(I)%K
225          ML = BLR_L(I)%M
226          NL = BLR_L(I)%N
227          IF (BLR_L(I)%ISLR) THEN
228             IF (KL.GT.0) THEN
229               allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok )
230               IF (allocok .GT. 0) THEN
231                 IFLAG  = -13
232                 IERROR = NELIM * KL
233                 write(*,*) 'Allocation problem in BLR routine
234     &         DMUMPS_BLR_UPDATE_NELIM_VAR: ',
235     &         'not enough memory? memory requested = ', IERROR
236                 GOTO 100
237               ENDIF
238               POSELT_TOP  = POSELT
239     &         + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8)
240     &         + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8)
241               POSELT_INCB = POSELT
242     &         + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8)
243     &         + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8)
244               CALL dgemm('N' , 'T' , NELIM, KL, NL , ONE ,
245     &              A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL ,
246     &              ZERO , TEMP_BLOCK , NELIM)
247               CALL dgemm('N' , 'T' , NELIM , ML , KL , MONE ,
248     &              TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML ,
249     &              ONE , A(POSELT_INCB) , NFRONT)
250               deallocate(TEMP_BLOCK)
251             ENDIF
252          ELSE
253            IF (SYM.EQ.0) THEN
254              POSELT_TOP  = POSELT
255     &         + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8)
256     &         + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8)
257              POSELT_INCB = POSELT
258     &         + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8)
259     &         + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8)
260              CALL dgemm('N' , 'T' , NELIM, ML, NL , MONE ,
261     &              A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML ,
262     &              ONE , A(POSELT_INCB) , NFRONT)
263            ELSE
264              POSELT_TOP  = POSELT + int(NFRONT,8)
265     &         * int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8)
266     &         + int((BEGS_BLR_L(CURRENT_BLR)-1),8)
267              POSELT_INCB = POSELT
268     &         + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8)
269     &         + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8)
270              CALL dgemm('T' , 'T' , NELIM, ML, NL , MONE ,
271     &              A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML ,
272     &              ONE , A(POSELT_INCB) , NFRONT)
273            ENDIF
274          ENDIF
275        ENDDO
276      ENDIF
277 100  CONTINUE
278#if defined(BLR_MT)
279!$OMP END SINGLE
280#endif
281      END SUBROUTINE DMUMPS_BLR_UPDATE_NELIM_VAR
282      SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING(
283     &        A, LA, POSELT, IFLAG, IERROR, NFRONT,
284     &        BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L,
285     &        BLR_U,
286     &        NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, K470,
287     &        COMPRESS_MID_PRODUCT, TOLEPS, KPERCENT)
288!$    USE OMP_LIB
289      INTEGER(8), intent(in)       :: LA
290      INTEGER(8), intent(in)       :: POSELT
291      INTEGER, intent(in)          :: NFRONT, NB_BLR_L, NB_BLR_U,
292     &                                CURRENT_BLR, K470,
293     &                                NELIM, NIV, SYM
294      INTEGER, intent(out)         :: IFLAG, IERROR
295      LOGICAL, intent(in)          :: LBANDSLAVE
296      INTEGER, intent(in)          :: ISHIFT
297      DOUBLE PRECISION, TARGET, intent(inout) :: A(LA)
298      TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR)
299      TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR)
300      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U
301      INTEGER,intent(in) :: COMPRESS_MID_PRODUCT, KPERCENT
302      DOUBLE PRECISION,intent(in) :: TOLEPS
303      INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U,
304     &           KL, ML, NL, J, IS, MID_RANK
305      INTEGER :: allocok
306      LOGICAL :: BUILDQ
307      INTEGER :: OMP_NUM
308      CHARACTER(len=1) :: TRANSB1
309      INTEGER :: IBIS
310#if defined(BLR_MT)
311      INTEGER :: CHUNK
312#endif
313      INTEGER(8) :: POSELT_INCB, POSELT_TOP
314      DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
315      DOUBLE PRECISION :: ONE, MONE, ZERO
316      PARAMETER (ONE = 1.0D0, MONE=-1.0D0)
317      PARAMETER (ZERO=0.0D0)
318      NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR
319      NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR
320      IF (LBANDSLAVE) THEN
321       IS = ISHIFT
322      ELSE
323       IS = 0
324      ENDIF
325#if defined(BLR_MT)
326!$OMP SINGLE
327#endif
328      IF (NELIM.NE.0) THEN
329         DO I = 1, NB_BLOCKS_PANEL_L
330            KL = BLR_L(I)%K
331            ML = BLR_L(I)%M
332            NL = BLR_L(I)%N
333            IF (BLR_L(I)%ISLR) THEN
334               IF (KL.GT.0) THEN
335               allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok )
336               IF (allocok .GT. 0) THEN
337                 IFLAG  = -13
338                 IERROR = NELIM * KL
339                 write(*,*) 'Allocation problem in BLR routine
340     &           DMUMPS_BLR_UPDATE_TRAILING: ',
341     &           'not enough memory? memory requested = ', IERROR
342                 GOTO 100
343               ENDIF
344               POSELT_TOP  = POSELT
345     &           + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8)
346     &           + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8)
347               POSELT_INCB = POSELT
348     &           + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8)
349     &           + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8)
350               CALL dgemm('N' , 'T' , NELIM, KL, NL , ONE ,
351     &                A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL ,
352     &                ZERO , TEMP_BLOCK , NELIM)
353               CALL dgemm('N' , 'T' , NELIM , ML , KL , MONE ,
354     &                TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML ,
355     &                ONE , A(POSELT_INCB) , NFRONT)
356               deallocate(TEMP_BLOCK)
357               ENDIF
358            ELSE
359              POSELT_TOP  = POSELT
360     &           + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8)
361     &           + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8)
362              POSELT_INCB = POSELT
363     &           + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8)
364     &           + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8)
365               CALL dgemm('N' , 'T' , NELIM, ML, NL , MONE ,
366     &                A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML ,
367     &                ONE , A(POSELT_INCB) , NFRONT)
368            ENDIF
369         ENDDO
370      ENDIF
371 100  CONTINUE
372#if defined(BLR_MT)
373!$OMP END SINGLE
374#endif
375      IF (IFLAG.LT.0) GOTO 200
376      OMP_NUM = 0
377#if defined(BLR_MT)
378      CHUNK = 1
379!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
380!$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ)
381#endif
382      DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U)
383        IF (IFLAG.LT.0) CYCLE
384        I = (IBIS-1)/NB_BLOCKS_PANEL_U+1
385        J = IBIS - (I-1)*NB_BLOCKS_PANEL_U
386            POSELT_INCB = POSELT
387     &           + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8)
388     &           + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8)
389         IF (SYM.EQ.0) THEN
390           IF (K470.EQ.1) THEN
391             TRANSB1 = 'N'
392           ELSE
393             TRANSB1 = 'T'
394           ENDIF
395            CALL DMUMPS_LRGEMM3(TRANSB1, 'T', MONE, BLR_U(J),
396     &            BLR_L(I), ONE, A, LA, POSELT_INCB,
397     &            NFRONT, 0, NIV, IFLAG, IERROR,
398     &            COMPRESS_MID_PRODUCT, TOLEPS,
399     &            KPERCENT, MID_RANK, BUILDQ)
400            IF (IFLAG.LT.0) CYCLE
401            CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I),
402     &          TRANSB1,
403     &          'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ)
404         ELSE
405            CALL DMUMPS_LRGEMM3('N', 'T', MONE, BLR_U(J),
406     &            BLR_L(I), ONE, A, LA, POSELT_INCB,
407     &            NFRONT, 0, NIV, IFLAG, IERROR,
408     &            COMPRESS_MID_PRODUCT, TOLEPS,
409     &            KPERCENT, MID_RANK, BUILDQ)
410            IF (IFLAG.LT.0) CYCLE
411            CALL UPDATE_FLOP_STATS_LRB_PRODUCT(BLR_U(J), BLR_L(I), 'N',
412     &          'T', NIV, COMPRESS_MID_PRODUCT, MID_RANK, BUILDQ)
413         ENDIF
414         ENDDO
415#if defined(BLR_MT)
416!$OMP END DO
417#endif
418 200  CONTINUE
419      END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING
420      SUBROUTINE DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT,
421     &        COPY_DENSE_BLOCKS,
422     &        BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG,
423     &        NB_BLR, BLR_PANEL, CURRENT_BLR, DIR,
424     &        LD_OR_NPIV, K470,
425     &        BEG_I_IN, END_I_IN)
426!$    USE OMP_LIB
427      INTEGER(8), intent(in)       :: LA
428      DOUBLE PRECISION, intent(inout)       :: A(LA)
429      INTEGER(8), intent(in)       :: POSELT
430      LOGICAL, intent(in)          :: COPY_DENSE_BLOCKS
431      INTEGER, intent(in)          :: NFRONT, NB_BLR, CURRENT_BLR
432      INTEGER, intent(in)          :: BEGS_BLR_DIAG,
433     &                                BEGS_BLR_FIRST_OFFDIAG
434      TYPE(LRB_TYPE),intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR)
435      CHARACTER(len=1) :: DIR
436      INTEGER, intent(in) :: LD_OR_NPIV, K470
437      INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN
438      INTEGER :: IP, M, N, BIP, BEG_I, END_I
439#if defined(BLR_MT)
440      INTEGER :: LAST_IP, CHUNK
441#endif
442      INTEGER :: K, I
443      INTEGER(8) :: POSELT_BLOCK, NFRONT8, LD_BLK_IN_FRONT
444      DOUBLE PRECISION :: ONE, ALPHA, ZERO
445      PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0)
446      PARAMETER (ZERO = 0.0D0)
447      IF(present(BEG_I_IN)) THEN
448        BEG_I = BEG_I_IN
449      ELSE
450        BEG_I = CURRENT_BLR+1
451      ENDIF
452      IF(present(END_I_IN)) THEN
453        END_I = END_I_IN
454      ELSE
455        END_I = NB_BLR
456      ENDIF
457      NFRONT8         = int(NFRONT,8)
458      LD_BLK_IN_FRONT = NFRONT8
459      BIP             = BEGS_BLR_FIRST_OFFDIAG
460#if defined(BLR_MT)
461      LAST_IP = BEG_I
462      CHUNK = 1
463!$OMP PARALLEL DO PRIVATE(POSELT_BLOCK, M, N, K, I)
464!$OMP&         FIRSTPRIVATE(BIP, LAST_IP) SCHEDULE(DYNAMIC, CHUNK)
465#endif
466      DO IP = BEG_I, END_I
467#if defined(BLR_MT)
468        DO I = 1, IP - LAST_IP
469           IF (DIR .eq. 'V') THEN
470              BIP  = BIP +  BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M
471           ELSE
472             IF (K470.EQ.1) THEN
473               BIP  = BIP +  BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M
474             ELSE
475               BIP  = BIP +  BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N
476             ENDIF
477           ENDIF
478        ENDDO
479        LAST_IP = IP
480#endif
481        IF (DIR .eq. 'V') THEN
482           IF (BIP .LE. LD_OR_NPIV) THEN
483             POSELT_BLOCK = POSELT + NFRONT8*int(BIP-1,8) +
484     &              int(BEGS_BLR_DIAG - 1,8)
485           ELSE
486             POSELT_BLOCK = POSELT +NFRONT8*int(LD_OR_NPIV,8)+
487     &              int(BEGS_BLR_DIAG - 1,8)
488             POSELT_BLOCK = POSELT_BLOCK +
489     &                      int(LD_OR_NPIV,8)*int(BIP-1-LD_OR_NPIV,8)
490             LD_BLK_IN_FRONT=int(LD_OR_NPIV,8)
491           ENDIF
492        ELSE
493         POSELT_BLOCK = POSELT +
494     &              NFRONT8*int(BEGS_BLR_DIAG-1,8) +
495     &              int(BIP - 1,8)
496        ENDIF
497           M = BLR_PANEL(IP-CURRENT_BLR)%M
498           N = BLR_PANEL(IP-CURRENT_BLR)%N
499           K = BLR_PANEL(IP-CURRENT_BLR)%K
500        IF ((BLR_PANEL(IP-CURRENT_BLR)%ISLR).AND.
501     &      (BLR_PANEL(IP-CURRENT_BLR)%LRFORM.EQ.1)) THEN
502        IF (K.EQ.0) THEN
503          IF (K470.NE.1.OR.DIR .eq. 'V') THEN
504            DO I = 1, M
505            A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT :
506     &                 POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT
507     &                                                + int(N-1,8))
508     &               = ZERO
509            ENDDO
510          ELSE
511            DO I = 1, N
512            A(POSELT_BLOCK+int(I-1,8)*NFRONT8:
513     &                  POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8))
514     &               = ZERO
515            ENDDO
516          ENDIF
517          GOTO 1800
518        ENDIF
519        IF (K470.NE.1.OR.DIR .eq. 'V') THEN
520           CALL dgemm('T', 'T', N, M, K, ONE ,
521     &          BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K,
522     &          BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M,
523     &          ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT))
524        ELSE
525           CALL dgemm('N', 'N', M, N, K, ONE ,
526     &          BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M,
527     &          BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K,
528     &          ZERO, A(POSELT_BLOCK), NFRONT)
529        ENDIF
530         ELSE  IF (COPY_DENSE_BLOCKS) THEN
531             IF (K470.NE.1.OR.DIR .eq. 'V') THEN
532                 DO I = 1, M
533                     A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT :
534     &                 POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT
535     &                                                + int(N-1,8))
536     &               = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N)
537                 ENDDO
538             ELSE
539                 DO I = 1, N
540                     A(POSELT_BLOCK+int(I-1,8)*NFRONT8:
541     &                  POSELT_BLOCK+int(I-1,8)*NFRONT8 + int(M-1,8))
542     &               = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I)
543                 ENDDO
544             ENDIF
545        ENDIF
546 1800   CONTINUE
547#if !defined(BLR_MT)
548        IF (DIR .eq. 'V') THEN
549           BIP  = BIP +  BLR_PANEL(IP-CURRENT_BLR)%M
550        ELSE
551          IF (K470.EQ.1) THEN
552            BIP  = BIP +  BLR_PANEL(IP-CURRENT_BLR)%M
553          ELSE
554            BIP  = BIP +  BLR_PANEL(IP-CURRENT_BLR)%N
555          ENDIF
556        ENDIF
557#endif
558      END DO
559#if defined(BLR_MT)
560!$OMP END PARALLEL DO
561#endif
562      END SUBROUTINE DMUMPS_DECOMPRESS_PANEL
563      SUBROUTINE DMUMPS_FAKE_COMPRESS_CB(A, LA, POSELT, NFRONT,
564     &        BEGS_BLR_L, NB_BLR_L,
565     &        BEGS_BLR_U,  NB_BLR_U, NPARTSASS_U,
566     &        TOLEPS, NASS, NROW,
567     &        SYM, WORK, TAU, JPVT, LWORK, RWORK,
568     &        BLOCK, MAXI_CLUSTER, INODE, NIV,
569     &        LBANDSLAVE, ISHIFT,KPERCENT)
570      INTEGER(8), intent(in)       :: LA
571      DOUBLE PRECISION, intent(inout)       :: A(LA)
572      INTEGER(8), intent(in)       :: POSELT
573      INTEGER, intent(in)          :: NFRONT, INODE
574      INTEGER, INTENT(IN)          :: NIV, NROW, KPERCENT
575      INTEGER                      :: MAXI_CLUSTER, LWORK, SYM, NASS,
576     &                                NB_BLR_L, NB_BLR_U, NPARTSASS_U
577      DOUBLE PRECISION,intent(in)              :: TOLEPS
578      LOGICAL, intent(in)          :: LBANDSLAVE
579      INTEGER, intent(in)          :: ISHIFT
580      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L,  BEGS_BLR_U
581      DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER)
582      DOUBLE PRECISION,DIMENSION(:) :: RWORK
583      DOUBLE PRECISION, DIMENSION(:) :: WORK, TAU
584      INTEGER, DIMENSION(:) :: JPVT
585      INTEGER :: M, N, NCB, BEGLOOP, RANK, MAXRANK, FRONT_CB_BLR_SAVINGS
586      INTEGER :: INFO, I, J, JJ, IB, JDEB, IS
587      INTEGER :: allocok, MREQ
588      INTEGER(8) :: POSELT_BLOCK
589      DOUBLE PRECISION :: HR_COST, BUILDQ_COST, CB_DEMOTE_COST,
590     &                                          CB_PROMOTE_COST
591      INTEGER T1, T2, COUNT_RATE
592      DOUBLE PRECISION :: LOC_PROMOTING_TIME
593      DOUBLE PRECISION :: LOC_CB_DEMOTING_TIME
594      DOUBLE PRECISION, ALLOCATABLE :: R(:,:)
595      DOUBLE PRECISION :: ONE, ZERO
596      PARAMETER (ONE = 1.0D0)
597      PARAMETER (ZERO = 0.0D0)
598      LOC_PROMOTING_TIME = 0.0D0
599      LOC_CB_DEMOTING_TIME = 0.0D0
600      CB_DEMOTE_COST = 0.0D0
601      CB_PROMOTE_COST = 0.0D0
602      allocate(R(MAXI_CLUSTER,MAXI_CLUSTER),stat=allocok)
603      IF (allocok .GT. 0) THEN
604          MREQ=MAXI_CLUSTER*MAXI_CLUSTER
605          write(*,*) 'Allocation problem in BLR routine
606     &    DMUMPS_FAKE_COMPRESS_CB: ',
607     &    'not enough memory? memory requested = ', MREQ
608          CALL MUMPS_ABORT()
609      ENDIF
610      FRONT_CB_BLR_SAVINGS = 0
611      NCB = NFRONT - NASS
612      IF (NCB.LE.0) RETURN
613      IF (LBANDSLAVE) THEN
614       IS = ISHIFT
615      ELSE
616       IS = 0
617      ENDIF
618      DO J =  NPARTSASS_U+1, NB_BLR_U
619         IF (NIV.EQ.1) THEN
620           IF (SYM.GT.0) THEN
621             BEGLOOP = J
622           ELSE
623             BEGLOOP = NPARTSASS_U + 1
624           ENDIF
625         ELSE
626           BEGLOOP = 2
627         ENDIF
628         IF ((BEGS_BLR_U(J+1)+IS).LE.NASS+1) CYCLE
629         JDEB = max(BEGS_BLR_U(J)+IS,NASS+1)
630          N = BEGS_BLR_U(J+1)+IS-JDEB
631         DO I = BEGLOOP, NB_BLR_L
632           CALL SYSTEM_CLOCK(T1)
633           JPVT = 0
634           M = BEGS_BLR_L(I+1)-BEGS_BLR_L(I)
635           POSELT_BLOCK = POSELT
636     &           + int(NFRONT,8) * int((BEGS_BLR_L(I)-1),8)
637     &           + int(JDEB - 1,8)
638           DO IB=1,M
639               IF((I.EQ.J).AND.(SYM.GT.0).AND.(NIV.EQ.1)) THEN
640                   BLOCK(IB,1:IB) =
641     &             A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) :
642     &                POSELT_BLOCK+
643     &                int((IB-1),8)*int(NFRONT,8)+int(IB-1,8)  )
644                   BLOCK(1:IB-1,IB) = BLOCK(IB,1:IB-1)
645               ELSE
646                   BLOCK(IB,1:N) =
647     &              A( POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8) :
648     &             POSELT_BLOCK+int((IB-1),8)*int(NFRONT,8)+int(N-1,8) )
649               ENDIF
650           END DO
651           MAXRANK = floor(dble(M*N)/dble(M+N))
652           MAXRANK = max (1, int((MAXRANK*KPERCENT/100)))
653           CALL DMUMPS_TRUNCATED_RRQR( M, N, BLOCK(1,1),
654     &          MAXI_CLUSTER, JPVT(1), TAU(1), WORK(1), N,
655     &          RWORK(1), TOLEPS, RANK, MAXRANK, INFO )
656           CALL SYSTEM_CLOCK(T2,COUNT_RATE)
657           LOC_CB_DEMOTING_TIME = LOC_CB_DEMOTING_TIME
658     &          + DBLE(T2-T1)/DBLE(COUNT_RATE)
659            IF (INFO < 0) THEN
660               WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO,
661     &                    " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK
662     &                      IN CB (FAKE COMPRESSION anyway) "
663                CALL MUMPS_ABORT()
664            END IF
665            HR_COST =  4.0D0*dble(RANK)*dble(RANK)*dble(RANK)/3.0D0
666     &               + 4.0D0*dble(RANK)*dble(M)*dble(N)
667     &               - 2.0D0*dble((M+N))*dble(RANK)*dble(RANK)
668            IF (RANK.LE.MAXRANK) THEN
669               CALL SYSTEM_CLOCK(T1)
670               DO JJ=1, N
671                  R(1:MIN(RANK,JJ),JPVT(JJ)) =
672     &                 BLOCK(1:MIN(RANK,JJ),JJ)
673                  IF(JJ.LT.RANK) R(MIN(RANK,JJ)+1:
674     &                 RANK,JPVT(JJ))= ZERO
675               END DO
676               CALL dorgqr(M, RANK, RANK,
677     &              BLOCK(1,1), MAXI_CLUSTER,
678     &              TAU(1), WORK(1), LWORK, INFO)
679               CALL dgemm('T', 'T', N, M, RANK, ONE ,
680     &              R , MAXI_CLUSTER,
681     &              BLOCK(1,1) , MAXI_CLUSTER,
682     &              ZERO, A(POSELT_BLOCK), NFRONT)
683               CALL SYSTEM_CLOCK(T2,COUNT_RATE)
684               LOC_PROMOTING_TIME = LOC_PROMOTING_TIME +
685     &              DBLE(T2-T1)/DBLE(COUNT_RATE)
686               BUILDQ_COST = 4.0D0*dble(RANK)*dble(RANK)*dble(M)
687     &                      - dble(RANK)*dble(RANK)*dble(RANK)
688     &
689               CB_DEMOTE_COST = CB_DEMOTE_COST +
690     &                  (HR_COST+BUILDQ_COST)
691               CB_PROMOTE_COST = CB_PROMOTE_COST +
692     &                      2.0D0*dble(RANK)*dble(M)*dble(N)
693               FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS +
694     &                      (M-RANK)*(N-RANK)-RANK*RANK
695            ELSE
696               CB_DEMOTE_COST = CB_DEMOTE_COST + HR_COST
697            END IF
698         END DO
699      END DO
700      deallocate(R)
701      CALL STATS_COMPUTE_MRY_FRONT_CB(NCB, NROW, SYM, NIV, INODE,
702     &                        FRONT_CB_BLR_SAVINGS)
703      CALL UPDATE_FLOP_STATS_CB_DEMOTE(CB_DEMOTE_COST, NIV)
704      CALL UPDATE_FLOP_STATS_CB_PROMOTE(CB_PROMOTE_COST, NIV)
705      CALL UPDATE_CB_DEMOTING_TIME(INODE, LOC_CB_DEMOTING_TIME)
706      CALL UPDATE_PROMOTING_TIME(INODE, LOC_PROMOTING_TIME)
707      END SUBROUTINE DMUMPS_FAKE_COMPRESS_CB
708      SUBROUTINE DMUMPS_COMPRESS_PANEL(
709     &        A, LA, POSELT, IFLAG, IERROR, NFRONT,
710     &        BEGS_BLR, NB_BLR, TOLEPS, K473, BLR_PANEL, CURRENT_BLR,
711     &        DIR, WORK, TAU, JPVT,
712     &        LWORK, RWORK, BLOCK,
713     &        MAXI_CLUSTER, NELIM,
714     &        LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT,
715     &        K470, KEEP8, K480,
716     &        BEG_I_IN, END_I_IN
717     &        )
718!$    USE OMP_LIB
719      INTEGER(8), intent(in)       :: LA
720      INTEGER(8), intent(in)       :: POSELT
721      INTEGER, intent(in)          :: NFRONT, NB_BLR, CURRENT_BLR, NIV
722      INTEGER, intent(out)          :: IFLAG, IERROR
723      TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR)
724      DOUBLE PRECISION, intent(inout)       :: A(LA)
725      DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK
726      DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK
727      DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU
728      INTEGER, TARGET, DIMENSION(:) :: JPVT
729      INTEGER, POINTER :: BEGS_BLR(:)
730      INTEGER(8) :: KEEP8(150)
731      INTEGER, OPTIONAL, intent(in) :: K480
732      INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN
733      INTEGER, intent(in)          :: NPIV, ISHIFT, KPERCENT, K473, K470
734      LOGICAL, intent(in)          :: LBANDSLAVE
735      INTEGER                      :: MAXI_CLUSTER, LWORK, NELIM
736      DOUBLE PRECISION,intent(in)              :: TOLEPS
737      CHARACTER(len=1) :: DIR
738      INTRINSIC maxval
739      INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK
740      INTEGER :: INFO, I, J, IS, BEG_I, END_I
741      INTEGER(8) :: POSELT_BLOCK
742      LOGICAL :: ISLR
743      DOUBLE PRECISION :: ONE, ALPHA, ZERO
744      PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0)
745      PARAMETER (ZERO = 0.0D0)
746      INTEGER :: OMP_NUM
747      DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR
748      DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: BLOCK_THR
749      DOUBLE PRECISION, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR
750      INTEGER, POINTER, DIMENSION(:) :: JPVT_THR
751#if defined(BLR_MT)
752      INTEGER :: CHUNK
753#endif
754      IF(present(BEG_I_IN)) THEN
755        BEG_I = BEG_I_IN
756      ELSE
757        BEG_I = CURRENT_BLR+1
758      ENDIF
759      IF(present(END_I_IN)) THEN
760        END_I = END_I_IN
761      ELSE
762        END_I = NB_BLR
763      ENDIF
764      IF (LBANDSLAVE) THEN
765       IS = ISHIFT
766      ELSE
767       IS=0
768      ENDIF
769      IF (DIR .eq. 'V') THEN
770         IF (LBANDSLAVE) THEN
771          N = NPIV
772         ELSE
773          N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM
774         ENDIF
775      ELSE IF (DIR .eq. 'H') THEN
776        IF (K470.EQ.1) THEN
777          N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM
778        ELSE
779          M = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM
780        ENDIF
781      ELSE
782         WRITE(*,*) " WRONG ARGUMENT IN DMUMPS_COMPRESS_PANEL "
783         CALL MUMPS_ABORT()
784      END IF
785      NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR
786      OMP_NUM = 0
787#if defined(BLR_MT)
788      CHUNK = 1
789!$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM)
790!$OMP&   SCHEDULE(DYNAMIC,CHUNK)
791#endif
792      DO IP = BEG_I, END_I
793        IF (IFLAG.LT.0) CYCLE
794#if defined(BLR_MT)
795!$      OMP_NUM = OMP_GET_THREAD_NUM()
796#endif
797        BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1:
798     &                  (OMP_NUM+1)*MAXI_CLUSTER)
799        JPVT_THR  => JPVT(OMP_NUM*MAXI_CLUSTER+1:
800     &                 (OMP_NUM+1)*MAXI_CLUSTER)
801        TAU_THR   => TAU(OMP_NUM*MAXI_CLUSTER+1:
802     &                 (OMP_NUM+1)*MAXI_CLUSTER)
803        WORK_THR  => WORK(OMP_NUM*LWORK+1:
804     &                 (OMP_NUM+1)*LWORK)
805        RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1:
806     &                  (OMP_NUM+1)*2*MAXI_CLUSTER)
807        IF (DIR .eq. 'V') THEN
808            M = BEGS_BLR(IP+1)-BEGS_BLR(IP)
809            POSELT_BLOCK = POSELT +
810     &              int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) +
811     &              int(BEGS_BLR(CURRENT_BLR) + IS - 1,8)
812        ELSE
813          IF (K470.EQ.1) THEN
814            M = BEGS_BLR(IP+1)-BEGS_BLR(IP)
815          ELSE
816            N = BEGS_BLR(IP+1)-BEGS_BLR(IP)
817          ENDIF
818          POSELT_BLOCK = POSELT +
819     &              int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) +
820     &              int( BEGS_BLR(IP) - 1,8)
821        END IF
822        JPVT_THR(1:MAXI_CLUSTER) = 0
823        IF (K473.EQ.1) THEN
824            MAXRANK = 1
825            RANK = MAXRANK+1
826            INFO = 0
827            GOTO 3800
828        ENDIF
829        IF (K470.NE.1.OR.DIR .eq. 'V') THEN
830            DO I=1,M
831                BLOCK_THR(I,1:N)=
832     &          A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) :
833     &          POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) )
834            END DO
835        ELSE
836            DO I=1,N
837                BLOCK_THR(1:M,I)=
838     &          A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) :
839     &          POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) )
840            END DO
841        END IF
842        MAXRANK = floor(dble(M*N)/dble(M+N))
843        MAXRANK = max (1, int((MAXRANK*KPERCENT/100)))
844        CALL DMUMPS_TRUNCATED_RRQR( M, N,
845     &       BLOCK_THR(1,1),
846     &       MAXI_CLUSTER, JPVT_THR(1),
847     &       TAU_THR(1),
848     &       WORK_THR(1), N,
849     &       RWORK_THR(1),
850     &       TOLEPS, RANK, MAXRANK, INFO)
851 3800 CONTINUE
852        IF (INFO < 0) THEN
853           WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO,
854     &                 " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK "
855            CALL MUMPS_ABORT()
856        END IF
857        ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0))
858        CALL ALLOC_LRB(BLR_PANEL(IP-CURRENT_BLR), RANK, RANK,
859     &                 M, N, ISLR, IFLAG, IERROR, KEEP8)
860        IF (IFLAG.LT.0) CYCLE
861        IF (ISLR) THEN
862           IF (RANK .EQ. 0) THEN
863           ELSE
864               BLR_PANEL(IP-CURRENT_BLR)%Q = ZERO
865               DO I=1,RANK
866                 BLR_PANEL(IP-CURRENT_BLR)%Q(I,I) = ONE
867               END DO
868               CALL dormqr
869     &           ('L', 'N', M, RANK, RANK,
870     &           BLOCK_THR(1,1),
871     &           MAXI_CLUSTER, TAU_THR(1),
872     &           BLR_PANEL(IP-CURRENT_BLR)%Q(1,1),
873     &           M, WORK_THR(1), LWORK, INFO )
874               IF (INFO < 0) THEN
875                 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO,
876     &                     " OF CUNMQR WHILE COMPRESSING A BLOCK "
877                 CALL MUMPS_ABORT()
878               END IF
879               DO J=1,N
880                 BLR_PANEL(IP-CURRENT_BLR)%R(1:MIN(RANK,J),
881     &               JPVT_THR(J)) =
882     &               BLOCK_THR(1:MIN(RANK,J),J)
883                 IF(J.LT.RANK) BLR_PANEL(IP-CURRENT_BLR)%
884     &               R(MIN(RANK,J)+1:RANK,JPVT_THR(J))= ZERO
885               ENDDO
886             CALL UPDATE_FLOP_STATS_DEMOTE(
887     &               BLR_PANEL(IP-CURRENT_BLR), NIV)
888          END IF
889        ELSE
890           IF (K470.NE.1.OR.DIR .eq. 'V') THEN
891               DO I=1,M
892                   BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) =
893     &             A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) :
894     &               POSELT_BLOCK+int((I-1),8)*int(NFRONT,8)
895     &                           +int(N-1,8) )
896               END DO
897           ELSE
898               DO I=1,N
899                   BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) =
900     &             A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) :
901     &               POSELT_BLOCK+int((I-1),8)*int(NFRONT,8)
902     &                           +int(M-1,8) )
903               END DO
904           END IF
905           IF (K473.EQ.0) THEN
906               CALL UPDATE_FLOP_STATS_DEMOTE(BLR_PANEL(IP-CURRENT_BLR),
907     &                                   NIV)
908           ENDIF
909           BLR_PANEL(IP-CURRENT_BLR)%K = -1
910        END IF
911      END DO
912#if defined(BLR_MT)
913!$OMP END DO NOWAIT
914#endif
915      END SUBROUTINE DMUMPS_COMPRESS_PANEL
916      END MODULE DMUMPS_FAC_LR
917