OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfac_lr.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, 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 (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 MODULE dmumps_fac_lr
15 USE dmumps_lr_core
16 IMPLICIT NONE
17 CONTAINS
18 SUBROUTINE dmumps_blr_update_trailing_ldlt(
19 & A, LA, POSELT, IFLAG, IERROR, NFRONT,
20 & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L,
21 & NELIM, IW2, BLOCK,
22 & MAXI_CLUSTER, NPIV, NIV,
23 & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT)
24!$ USE OMP_LIB
25 INTEGER(8), intent(in) :: LA
26 INTEGER(8), intent(in) :: POSELT
27 INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR,
28 & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT
29 INTEGER, intent(inout) :: IFLAG, IERROR
30 DOUBLE PRECISION, intent(inout) :: A(LA)
31 TYPE(lrb_type),intent(in) :: BLR_L(:)
32 DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*)
33 INTEGER, intent(in) :: IW2(*)
34 INTEGER, DIMENSION(:) :: BEGS_BLR
35 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT
36 DOUBLE PRECISION,intent(in) :: TOLEPS
37 INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK
38 LOGICAL :: BUILDQ
39 INTEGER :: OMP_NUM
40 INTEGER :: IBIS
41#if defined(BLR_MT)
42 INTEGER :: CHUNK
43#endif
44 INTEGER(8) :: POSELTT, POSELTD
45 DOUBLE PRECISION :: ONE, MONE, ZERO
46 PARAMETER (ONE = 1.0d0, mone=-1.0d0)
47 parameter(zero=0.0d0)
48 nb_blocks_panel = nb_blr-current_blr
49 poseltd = poselt + int(nfront,8) * int(begs_blr(current_blr)-1,8)
50 & + int(begs_blr(current_blr) - 1,8)
51 omp_num = 0
52#if defined(BLR_MT)
53 chunk = 1
54!$OMP DO SCHEDULE(DYNAMIC, CHUNK)
55!$OMP& PRIVATE(I, J, POSELTT, OMP_NUM,
56!$OMP& MID_RANK, BUILDQ)
57#endif
58 DO ibis = 1, (nb_blocks_panel*(nb_blocks_panel+1)/2)
59 IF (iflag.LT.0) cycle
60 i = ceiling((1.0d0+sqrt(1.0d0+8.0d0*dble(ibis)))/2.0d0)-1
61 j = ibis - i*(i-1)/2
62#if defined(BLR_MT)
63 omp_num = 0
64!$ OMP_NUM = OMP_GET_THREAD_NUM()
65#endif
66 poseltt = poselt + int(nfront,8) *
67 & int(begs_blr(current_blr+i)-1,8)
68 & + int(begs_blr(current_blr+j) - 1, 8)
69 CALL dmumps_lrgemm4(mone,
70 & blr_l(j), blr_l(i), one, a, la,
71 & poseltt, nfront, 1, iflag, ierror,
72 & midblk_compress, toleps, tol_opt, kpercent,
73 & mid_rank, buildq,
74 & .false., maxi_cluster=maxi_cluster,
75 & diag=a(poseltd), ld_diag=nfront, iw2=iw2,
76 & block=block(1:maxi_cluster,omp_num*maxi_cluster+1))
77 IF (iflag.LT.0) cycle
78 CALL upd_flop_update(blr_l(j), blr_l(i),
79 & midblk_compress, mid_rank, buildq,
80 & (i.EQ.j), .false.)
81 ENDDO
82#if defined(BLR_MT)
83!$OMP END DO
84#endif
85 END SUBROUTINE dmumps_blr_update_trailing_ldlt
86 SUBROUTINE dmumps_blr_slv_upd_trail_ldlt(A, LA, POSELT,
87 & IFLAG, IERROR, NCOL, NROW,
88 & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO,
89 & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM,
90 & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS,
91 & CURRENT_BLR_LM, CURRENT_BLR_LS,
92 & IW2, BLOCK,
93 & MAXI_CLUSTER,
94 & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT
95 & )
96!$ USE OMP_LIB
97 INTEGER(8), intent(in) :: LA, LA_BLOCFACTO
98 DOUBLE PRECISION, intent(inout) :: A(LA)
99 DOUBLE PRECISION, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO)
100 INTEGER(8), intent(in) :: POSELT
101 INTEGER, intent(inout) :: IFLAG, IERROR
102 INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT,
103 & MAXI_CLUSTER, LD_BLOCFACTO
104 INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS,
105 & ISHIFT_LM, ISHIFT_LS,
106 & CURRENT_BLR_LM, CURRENT_BLR_LS
107 DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*)
108 INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS
109 TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM),
110 & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS)
111 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT
112 DOUBLE PRECISION,intent(in) :: TOLEPS
113 INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK
114 LOGICAL :: BUILDQ
115 INTEGER :: OMP_NUM
116 INTEGER :: IBIS
117#if defined(BLR_MT)
118 INTEGER :: CHUNK
119#endif
120 INTEGER(8) :: POSELTT, POSELTD
121 DOUBLE PRECISION :: ONE, MONE, ZERO
122 parameter(one = 1.0d0, mone=-1.0d0)
123 parameter(zero=0.0d0)
124 nb_blocks_panel_lm = nb_blr_lm-current_blr_lm
125 nb_blocks_panel_ls = nb_blr_ls-current_blr_ls
126 poseltd = 1_8
127 omp_num = 0
128#if defined(BLR_MT)
129 chunk = 1
130!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
131!$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ)
132#endif
133 DO ibis = 1, (nb_blocks_panel_ls*nb_blocks_panel_lm)
134 IF (iflag.LT.0) cycle
135 i = (ibis-1)/nb_blocks_panel_lm+1
136 j = ibis - (i-1)*nb_blocks_panel_lm
137#if defined(BLR_MT)
138 omp_num = 0
139!$ OMP_NUM = OMP_GET_THREAD_NUM()
140#endif
141 poseltt = poselt
142 & + int(ncol,8) *
143 & int((begs_blr_ls(current_blr_ls+i)+ishift_ls-1),8)
144 & + int((begs_blr_lm(current_blr_lm+j)+ishift_lm-1),8)
145 CALL dmumps_lrgemm4(mone,
146 & blr_lm(j), blr_ls(i), one, a, la,
147 & poseltt, ncol,
148 & 1, iflag, ierror,
149 & midblk_compress, toleps, tol_opt, kpercent,
150 & mid_rank, buildq,
151 & .false., maxi_cluster=maxi_cluster,
152 & diag=a_blocfacto, ld_diag=ld_blocfacto, iw2=iw2,
153 & block=block(1:maxi_cluster,omp_num*maxi_cluster+1))
154 IF (iflag.LT.0) cycle
155 CALL upd_flop_update(blr_lm(j), blr_ls(i),
156 & midblk_compress, mid_rank, buildq,
157 & .false., .false.)
158 ENDDO
159#if defined(BLR_MT)
160!$OMP END DO
161 IF (iflag.LT.0) RETURN
162!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
163!$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ)
164#endif
165 DO ibis = 1, (nb_blocks_panel_ls*(nb_blocks_panel_ls+1)/2)
166 IF (iflag.LT.0) cycle
167 i = ceiling((1.0d0+sqrt(1.0d0+8.0d0*dble(ibis)))/2.0d0)-1
168 j = ibis - i*(i-1)/2
169#if defined(BLR_MT)
170 omp_num = 0
171!$ OMP_NUM = OMP_GET_THREAD_NUM()
172#endif
173 poseltt = poselt
174 & + int(ncol,8) *
175 & int((begs_blr_ls(current_blr_ls+i)+ishift_ls-1),8)
176 & + int((ncol-nrow+(begs_blr_ls(current_blr_ls+j)-1)),8)
177 CALL dmumps_lrgemm4(mone,
178 & blr_ls(j),blr_ls(i), one, a, la,
179 & poseltt, ncol,
180 & 1, iflag, ierror,
181 & midblk_compress, toleps, tol_opt, kpercent,
182 & mid_rank, buildq,
183 & .false., maxi_cluster=maxi_cluster,
184 & diag=a_blocfacto, ld_diag=ld_blocfacto, iw2=iw2,
185 & block=block(1:maxi_cluster,omp_num*maxi_cluster+1))
186 IF (iflag.LT.0) cycle
187 CALL upd_flop_update(blr_ls(j), blr_ls(i),
188 & midblk_compress, mid_rank, buildq,
189 & (i.EQ.j), .false.)
190 ENDDO
191#if defined(BLR_MT)
192!$OMP END DO
193#endif
194 RETURN
195 END SUBROUTINE dmumps_blr_slv_upd_trail_ldlt
196 SUBROUTINE dmumps_blr_upd_nelim_var_u(
197 & A, LA, POSELT, IFLAG, IERROR, NFRONT,
198 & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR,
199 & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM)
200!$ USE OMP_LIB
201 INTEGER(8), intent(in) :: LA
202 INTEGER(8), intent(in) :: POSELT
203 INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR,
204 & ibeg_blr, npiv, nelim, first_block
205 INTEGER, intent(inout) :: IFLAG, IERROR
206 DOUBLE PRECISION, TARGET, intent(inout) :: A(LA)
207 TYPE(lrb_type),TARGET,intent(in) :: BLR_U(:)
208 INTEGER, DIMENSION(:) :: BEGS_BLR
209 TYPE(LRB_TYPE), POINTER :: LRB
210 INTEGER :: IP
211 INTEGER :: allocok
212 INTEGER(8) :: LPOS, UPOS
213 DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
214 DOUBLE PRECISION :: ONE, MONE, ZERO
215 PARAMETER (ONE = 1.0d0, mone=-1.0d0)
216 parameter(zero=0.0d0)
217 IF (nelim.NE.0) THEN
218 lpos = poselt + int(nfront,8)*int(npiv,8) + int(ibeg_blr-1,8)
219#if defined(BLR_MT)
220!$OMP DO PRIVATE(LRB, UPOS)
221#endif
222 DO ip = first_block, nb_blr
223 IF (iflag.LT.0) cycle
224 lrb => blr_u(ip-current_blr)
225 upos = poselt + int(nfront,8)*int(npiv,8)
226 & + int(begs_blr(ip)-1,8)
227 IF (lrb%ISLR) THEN
228 IF (lrb%K.GT.0) THEN
229 allocate(temp_block( lrb%K, nelim ), stat=allocok )
230 IF (allocok .GT. 0) THEN
231 iflag = -13
232 ierror = nelim * lrb%K
233 GOTO 100
234 ENDIF
235 CALL dgemm('N', 'N', lrb%K, nelim, lrb%N, one,
236 & lrb%R(1,1), lrb%K, a(lpos), nfront,
237 & zero, temp_block, lrb%K)
238 CALL dgemm('N', 'N', lrb%M, nelim, lrb%K, mone,
239 & lrb%Q(1,1), lrb%M, temp_block, lrb%K,
240 & one, a(upos), nfront)
241 deallocate(temp_block)
242 ENDIF
243 ELSE
244 CALL dgemm('N', 'N', lrb%M, nelim, lrb%N, mone,
245 & lrb%Q(1,1), lrb%M, a(lpos), nfront,
246 & one, a(upos), nfront)
247 ENDIF
248 100 CONTINUE
249 ENDDO
250#if defined(blr_mt)
251!$OMP ENDDO
252#endif
253 ENDIF
254 END SUBROUTINE dmumps_blr_upd_nelim_var_u
255 SUBROUTINE dmumps_blr_upd_nelim_var_l(
256 & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL,
257 & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L,
258 & FIRST_BLOCK, NELIM, UTRANS)
259!$ USE OMP_LIB
260 INTEGER(8), intent(in) :: LA_U, LA_L
261 INTEGER(8), intent(in) :: UPOS, LPOS
262 INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR,
263 & nelim, first_block
264 CHARACTER(len=1),INTENT(IN) :: UTRANS
265 INTEGER, intent(inout) :: IFLAG, IERROR
266 DOUBLE PRECISION, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U)
267 TYPE(lrb_type),intent(in) :: BLR_L(:)
268 INTEGER :: BEGS_BLR_L(:)
269 INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL
270 INTEGER :: allocok
271 INTEGER(8) :: IPOS
272 DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
273 DOUBLE PRECISION :: ONE, MONE, ZERO
274 parameter(one = 1.0d0, mone=-1.0d0)
275 parameter(zero=0.0d0)
276 nb_blocks_panel_l = nb_blr_l-current_blr
277 IF (nelim.NE.0) THEN
278#if defined(BLR_MT)
279!$OMP DO PRIVATE(KL, ML, NL, IPOS)
280#endif
281 DO i = first_block-current_blr, nb_blocks_panel_l
282 IF (iflag.LT.0) cycle
283 kl = blr_l(i)%K
284 ml = blr_l(i)%M
285 nl = blr_l(i)%N
286 ipos = lpos + int(ldl,8) *
287 & int(begs_blr_l(current_blr+i)-begs_blr_l(current_blr+1),8)
288 IF (blr_l(i)%ISLR) THEN
289 IF (kl.GT.0) THEN
290 allocate(temp_block( nelim, kl ), stat=allocok )
291 IF (allocok .GT. 0) THEN
292 iflag = -13
293 ierror = nelim * kl
294 write(*,*) 'Allocation problem in BLR routine
295 & DMUMPS_BLR_UPD_NELIM_VAR_L: ',
296 & 'not enough memory? memory requested = ', ierror
297 GOTO 100
298 ENDIF
299 CALL dgemm(utrans , 'T' , nelim, kl, nl , one ,
300 & a_u(upos) , ldu , blr_l(i)%R(1,1) , kl ,
301 & zero , temp_block , nelim)
302 CALL dgemm('N' , 'T' , nelim , ml , kl , mone ,
303 & temp_block , nelim , blr_l(i)%Q(1,1) , ml ,
304 & one , a_l(ipos) , ldl)
305 deallocate(temp_block)
306 ENDIF
307 ELSE
308 CALL dgemm(utrans , 'T' , nelim, ml, nl , mone ,
309 & a_u(upos) , ldu , blr_l(i)%Q(1,1) , ml ,
310 & one , a_l(ipos) , ldl)
311 ENDIF
312 100 CONTINUE
313 ENDDO
314#if defined(BLR_MT)
315!$OMP ENDDO
316#endif
317 ENDIF
318 END SUBROUTINE dmumps_blr_upd_nelim_var_l
319 SUBROUTINE dmumps_blr_update_trailing(
320 & A, LA, POSELT, IFLAG, IERROR, NFRONT,
321 & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L,
322 & BLR_U,
323 & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM,
324 & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT)
325!$ USE OMP_LIB
326 INTEGER(8), intent(in) :: LA
327 INTEGER(8), intent(in) :: POSELT
328 INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U,
329 & CURRENT_BLR,
330 & nelim, niv, sym, tol_opt
331 INTEGER, intent(inout) :: IFLAG, IERROR
332 LOGICAL, intent(in) :: LBANDSLAVE
333 INTEGER, intent(in) :: ISHIFT
334 DOUBLE PRECISION, intent(inout) :: A(LA)
335 TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:)
336 TYPE(lrb_type),TARGET,intent(in) :: BLR_L(:)
337 INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:)
338 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT
339 DOUBLE PRECISION,intent(in) :: TOLEPS
340 INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U,
341 & KL, ML, NL, J, IS, MID_RANK
342 INTEGER :: allocok
343 LOGICAL :: BUILDQ
344 INTEGER :: OMP_NUM
345 INTEGER :: IBIS
346#if defined(BLR_MT)
347 INTEGER :: CHUNK
348#endif
349 INTEGER(8) :: POSELT_INCB, POSELT_TOP
350 DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
351 DOUBLE PRECISION :: ONE, MONE, ZERO
352 parameter(one = 1.0d0, mone=-1.0d0)
353 parameter(zero=0.0d0)
354 nb_blocks_panel_l = nb_blr_l-current_blr
355 nb_blocks_panel_u = nb_blr_u-current_blr
356 IF (lbandslave) THEN
357 is = ishift
358 ELSE
359 is = 0
360 ENDIF
361#if defined(BLR_MT)
362!$OMP SINGLE
363#endif
364 IF (nelim.NE.0) THEN
365 DO i = 1, nb_blocks_panel_l
366 kl = blr_l(i)%K
367 ml = blr_l(i)%M
368 nl = blr_l(i)%N
369 IF (blr_l(i)%ISLR) THEN
370 IF (kl.GT.0) THEN
371 allocate(temp_block( nelim, kl ), stat=allocok )
372 IF (allocok .GT. 0) THEN
373 iflag = -13
374 ierror = nelim * kl
375 GOTO 100
376 ENDIF
377 poselt_top = poselt
378 & + int(nfront,8) * int((begs_blr_u(current_blr)-1),8)
379 & + int(begs_blr_u(current_blr+1) + is - nelim - 1,8)
380 poselt_incb = poselt
381 & + int(nfront,8) * int((begs_blr_l(current_blr+i)-1),8)
382 & + int(begs_blr_u(current_blr+1)+is-nelim-1,8)
383 CALL dgemm('N' , 'T' , nelim, kl, nl , one ,
384 & a(poselt_top) , nfront , blr_l(i)%R(1,1) , kl ,
385 & zero , temp_block , nelim)
386 CALL dgemm('N' , 'T' , nelim , ml , kl , mone ,
387 & temp_block , nelim , blr_l(i)%Q(1,1) , ml ,
388 & one , a(poselt_incb) , nfront)
389 deallocate(temp_block)
390 ENDIF
391 ELSE
392 poselt_top = poselt
393 & + int(nfront,8) * int((begs_blr_l(current_blr)-1),8)
394 & + int(begs_blr_u(current_blr+1)+is-nelim-1,8)
395 poselt_incb = poselt
396 & + int(nfront,8) * int((begs_blr_l(current_blr+i)-1),8)
397 & + int(begs_blr_u(current_blr+1) + is - nelim - 1, 8)
398 CALL dgemm('N' , 'T' , nelim, ml, nl , mone ,
399 & a(poselt_top) , nfront , blr_l(i)%Q(1,1) , ml ,
400 & one , a(poselt_incb) , nfront)
401 ENDIF
402 ENDDO
403 ENDIF
404 100 CONTINUE
405#if defined(BLR_MT)
406!$OMP END SINGLE
407#endif
408 IF (iflag.LT.0) GOTO 200
409 omp_num = 0
410#if defined(BLR_MT)
411 chunk = 1
412!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
413!$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ)
414#endif
415 DO ibis = 1, (nb_blocks_panel_l*nb_blocks_panel_u)
416 IF (iflag.LT.0) cycle
417 i = (ibis-1)/nb_blocks_panel_u+1
418 j = ibis - (i-1)*nb_blocks_panel_u
419 poselt_incb = poselt
420 & + int(nfront,8) * int((begs_blr_l(current_blr+i)-1),8)
421 & + int(begs_blr_u(current_blr+j) +is - 1,8)
422 CALL dmumps_lrgemm4(mone, blr_u(j),
423 & blr_l(i), one, a, la, poselt_incb,
424 & nfront, 0, iflag, ierror,
425 & midblk_compress, toleps, tol_opt,
426 & kpercent, mid_rank, buildq, .false.)
427 IF (iflag.LT.0) cycle
428 CALL upd_flop_update(blr_u(j), blr_l(i),
429 & midblk_compress, mid_rank, buildq,
430 & .false., .false.)
431 ENDDO
432#if defined(BLR_MT)
433!$OMP END DO
434#endif
435 200 CONTINUE
436 END SUBROUTINE dmumps_blr_update_trailing
437 SUBROUTINE dmumps_blr_upd_panel_left_ldlt(
438 & A, LA, POSELT, NFRONT, IWHANDLER,
439 & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS,
440 & NELIM, IW2, BLOCK, ACC_LUA,
441 & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR,
442 & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB,
443 & K480, K479, K478, KPERCENT_LUA, KPERCENT,
444 & KEEP8,
445 & FIRST_BLOCK
446 & )
447!$ USE OMP_LIB
448 INTEGER(8), intent(in) :: LA
449 INTEGER(8), intent(in) :: POSELT
450 INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS,
451 & current_blr, iwhandler, tol_opt,
452 & nelim, niv, k480, k479, k478,
453 & maxi_cluster, maxi_rank,
454 & kpercent_lua, kpercent
455 DOUBLE PRECISION, intent(inout) :: A(LA)
456 INTEGER, intent(in) :: IW2(*)
457 DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER,*)
458 TYPE(LRB_TYPE), POINTER :: ACC_LUA(:)
459 INTEGER(8) :: KEEP8(150)
460 INTEGER, DIMENSION(:) :: BEGS_BLR
461 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB
462 DOUBLE PRECISION,intent(in) :: TOLEPS
463 INTEGER,intent(inout) :: IFLAG, IERROR
464 INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK
465 TYPE(lrb_type), POINTER :: BLR_L(:), NEXT_BLR_L(:)
466 TYPE(LRB_TYPE), POINTER :: ACC_LRB
467 INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES,
468 & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX,
469 & maxrank, nb_dec, fr_rank
470 INTEGER :: MID_RANK, allocok
471 INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR)
472 INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:)
473 LOGICAL :: BUILDQ, COMPRESSED_FR
474 INTEGER :: OFFSET_IW
475 INTEGER :: OMP_NUM
476#if defined(BLR_MT)
477 INTEGER :: CHUNK
478#endif
479 INTEGER(8) :: POSELT_INCB, POSELTD
480 DOUBLE PRECISION :: ONE, MONE, ZERO
481 PARAMETER (ONE = 1.0d0, mone=-1.0d0)
482 parameter(zero=0.0d0)
483 nb_blocks_panel = nb_blr-current_blr
484 acc_lrb => acc_lua(1)
485 IF (k480.GE.5) THEN
486 IF (nb_blocks_panel.GT.1) THEN
487 CALL dmumps_blr_retrieve_panel_loru(
488 & iwhandler,
489 & 0,
490 & current_blr+1, next_blr_l)
491 ENDIF
492 IF (.not.(present(first_block))) THEN
493 write(*,*) "Internal error in
494 & DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",k480,
495 & ">= 5, but FIRST_BLOCK argument is missing"
496 CALL mumps_abort()
497 ENDIF
498 ENDIF
499 omp_num = 0
500#if defined(BLR_MT)
501 chunk = 1
502!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
503!$omp& private(i, j, jj, poselt_incb, mid_rank, buildq, k_max,
504!$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK,
505!$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC,
506!$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK,
507!$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW)
508#endif
509 DO i = 1, nb_blocks_panel
510#if defined(BLR_MT)
511 IF (iflag.LT.0) cycle
512 omp_num = 0
513!$ OMP_NUM = OMP_GET_THREAD_NUM()
514 acc_lrb => acc_lua(omp_num+1)
515#endif
516 poselt_incb = poselt
517 & + int(nfront,8) * int((begs_blr(current_blr+i)-1),8)
518 & + int(begs_blr(current_blr+1)-1,8)
519 acc_lrb%N = begs_blr(current_blr+i+1)-begs_blr(current_blr+i)
520 acc_lrb%M = begs_blr(current_blr+2)-begs_blr(current_blr+1)
521 max_acc_rank = 0
522 new_acc_rank = 0
523 compressed_fr = .false.
524 IF (k480.EQ.2) THEN
525 DO j = 1, current_blr
526 j_order(j) = j
527 ENDDO
528 ELSE
529 CALL dmumps_get_lua_order(current_blr, j_order, j_rank,
530 & iwhandler,
531 & 1, 0, i, 0,
532 & frfr_updates)
533 ENDIF
534 fr_rank = 0
535 IF ((k480.GE.5).AND.(i.NE.1)) THEN
536 IF (i.GT.first_block) THEN
537 IF (frfr_updates.EQ.0) THEN
538 CALL dmumps_compress_fr_updates(acc_lrb,
539 & maxi_cluster, maxi_rank, a, la, poselt_incb,
540 & nfront, niv, toleps, tol_opt, kpercent,
541 & compressed_fr, 0, .false.)
542 max_acc_rank = acc_lrb%K
543 new_acc_rank = acc_lrb%K
544 fr_rank = acc_lrb%K
545 ENDIF
546 ENDIF
547 ENDIF
548 nb_dec = frfr_updates
549 DO jj = 1, current_blr
550 j = j_order(jj)
551 k_max = j_rank(jj)
552 poseltd = poselt + int(nfront,8) * int(begs_blr(j)-1,8)
553 & + int(begs_blr(j) - 1,8)
554 offset_iw = begs_blr(j)
555 ind_l = current_blr+i-j
556 ind_u = current_blr+1-j
557 CALL dmumps_blr_retrieve_panel_loru(
558 & iwhandler,
559 & 0,
560 & j, blr_l)
561 IF (blr_l(ind_l)%M.EQ.0) THEN
562 cycle
563 ENDIF
564 IF (k480.GE.3) THEN
565 IF (acc_lrb%K+k_max.GT.maxi_rank) THEN
566 nb_dec = jj-1
567 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
568 & maxi_rank, a, la, poselt_incb, nfront, niv, 0)
569 compressed_fr = .false.
570 max_acc_rank = 0
571 ENDIF
572 old_acc_rank = acc_lrb%K
573 ENDIF
574 CALL dmumps_lrgemm4(mone,
575 & blr_l(ind_u), blr_l(ind_l), one,
576 & a, la, poselt_incb,
577 & nfront, 1, iflag, ierror,
578 & midblk_compress, toleps, tol_opt,
579 & kpercent_rmb, mid_rank, buildq,
580 & (k480.GE.3), loru=0,
581 & lrb3=acc_lrb, maxi_rank=maxi_rank,
582 & maxi_cluster=maxi_cluster,
583 & diag=a(poseltd), ld_diag=nfront,
584 & iw2=iw2(offset_iw),
585 & block=block(1:maxi_cluster,omp_num*maxi_cluster+1))
586 IF (iflag.LT.0) GOTO 100
587 CALL upd_flop_update(blr_l(ind_u),
588 & blr_l(ind_l), midblk_compress,
589 & mid_rank, buildq, (i.EQ.1), (k480.GE.3))
590 IF ((midblk_compress.GE.1).AND.buildq) THEN
591 j_rank(jj) = mid_rank
592 ENDIF
593 IF (k480.GE.3) THEN
594 new_acc_rank = new_acc_rank + acc_lrb%K - old_acc_rank
595 max_acc_rank = max(max_acc_rank, acc_lrb%K - old_acc_rank)
596 IF (k480.EQ.4) THEN
597 IF ((k478.GT.0).AND.((acc_lrb%K-max_acc_rank).GE.k478))
598 & THEN
599 IF (acc_lrb%K.GT.0) THEN
600 CALL dmumps_recompress_acc(acc_lrb,
601 & maxi_cluster, maxi_rank, a, la, poselt_incb,
602 & nfront, niv, midblk_compress, toleps,
603 & tol_opt,
604 & kpercent_rmb, kpercent_lua, new_acc_rank)
605 max_acc_rank = acc_lrb%K
606 ENDIF
607 ENDIF
608 ENDIF
609 IF ((k480.GE.5).AND.(i.NE.1)) THEN
610 IF (i.GT.first_block) THEN
611 IF (jj.EQ.frfr_updates) THEN
612 CALL dmumps_compress_fr_updates(acc_lrb,
613 & maxi_cluster, maxi_rank, a, la, poselt_incb,
614 & nfront, niv, toleps, tol_opt, kpercent,
615 & compressed_fr, 0, .false.)
616 max_acc_rank = acc_lrb%K
617 new_acc_rank = acc_lrb%K
618 IF (compressed_fr) THEN
619 j_rank(jj) = acc_lrb%K
620 nb_dec = frfr_updates-1
621 ENDIF
622 ENDIF
623 ENDIF
624 ENDIF
625 ENDIF
626 ENDDO
627 IF (k480.GE.3) THEN
628 IF ((k480.GE.5)) THEN
629 IF (compressed_fr.OR.(k480.GE.6)) THEN
630 IF (acc_lrb%K.GT.0) THEN
631 IF (k478.EQ.-1) THEN
632 IF (current_blr-frfr_updates.GT.1) THEN
633 CALL dmumps_recompress_acc(acc_lrb,
634 & maxi_cluster, maxi_rank, a, la, poselt_incb,
635 & nfront, niv, midblk_compress, toleps, tol_opt,
636 & kpercent_rmb, kpercent_lua, new_acc_rank)
637 ENDIF
638 ELSEIF (k478.LE.-2) THEN
639 IF (frfr_updates.GT.0) THEN
640 allocate(pos_list(current_blr-nb_dec),stat=allocok)
641 IF (allocok .GT. 0) THEN
642 iflag = -13
643 ierror = current_blr-nb_dec
644 write(*,*) 'Allocation problem in BLR routine ',
645 & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ',
646 & 'not enough memory? memory requested = ',
647 & ierror
648 GOTO 100
649 ENDIF
650 pos_list(1) = 1
651 DO ii = 1,current_blr-nb_dec-1
652 pos_list(ii+1)=pos_list(ii)+j_rank(nb_dec+ii)
653 ENDDO
654 CALL dmumps_recompress_acc_narytree(acc_lrb,
655 & maxi_cluster, maxi_rank, a, la, poselt_incb, keep8,
656 & nfront, niv, midblk_compress, toleps, tol_opt,
657 & kpercent_rmb, kpercent_lua, k478,
658 & j_rank(nb_dec+1:current_blr), pos_list,
659 & current_blr-nb_dec, 0)
660 ELSE
661 allocate(pos_list(current_blr+1),stat=allocok)
662 IF (allocok .GT. 0) THEN
663 iflag = -13
664 ierror = current_blr+1
665 write(*,*) 'Allocation problem in BLR routine ',
666 & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ',
667 & 'not enough memory? memory requested = ',
668 & ierror
669 GOTO 100
670 ENDIF
671 pos_list(1) = 1
672 pos_list(2) = 1 + fr_rank
673 DO ii = 2,current_blr
674 pos_list(ii+1)=pos_list(ii)+j_rank(ii-1)
675 ENDDO
676 allocate(rank_list(current_blr+1),stat=allocok)
677 IF (allocok .GT. 0) THEN
678 iflag = -13
679 ierror = current_blr+1
680 write(*,*) 'Allocation problem in BLR routine ',
681 & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ',
682 & 'not enough memory? memory requested = ',
683 & ierror
684 GOTO 100
685 ENDIF
686 rank_list(1) = fr_rank
687 DO ii = 2,current_blr+1
688 rank_list(ii) = j_rank(ii-1)
689 ENDDO
690 CALL dmumps_recompress_acc_narytree(acc_lrb,
691 & maxi_cluster, maxi_rank, a, la, poselt_incb, keep8,
692 & nfront, niv, midblk_compress, toleps, tol_opt,
693 & kpercent_rmb, kpercent_lua, k478,
694 & rank_list, pos_list,
695 & current_blr+1, 0)
696 deallocate(rank_list)
697 ENDIF
698 deallocate(pos_list)
699 ENDIF
700 ENDIF
701 ENDIF
702 maxrank = floor(dble(acc_lrb%M*acc_lrb%N)/dble(acc_lrb%M+
703 & acc_lrb%N))
704 IF (compressed_fr.AND.(acc_lrb%K.LE.maxrank)) THEN
705 CALL alloc_lrb_from_acc(acc_lrb, next_blr_l(i-1),
706 & acc_lrb%K, acc_lrb%M, acc_lrb%N, 0,
707 & iflag, ierror, keep8)
708 IF (iflag.LT.0) cycle
709 acc_lrb%K = 0
710 ELSE
711 IF (i.NE.1) next_blr_l(i-1)%ISLR=.false.
712 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
713 & maxi_rank, a, la, poselt_incb, nfront, niv, 0)
714 ENDIF
715 ELSE
716 IF ((k480.EQ.4).AND.(k478.EQ.-1).AND.(acc_lrb%K.GT.0)) THEN
717 IF (current_blr-frfr_updates.GT.1) THEN
718 CALL dmumps_recompress_acc(acc_lrb,
719 & maxi_cluster, maxi_rank, a, la, poselt_incb,
720 & nfront, niv, midblk_compress, toleps, tol_opt,
721 & kpercent_rmb, kpercent_lua, new_acc_rank)
722 ENDIF
723 ELSEIF ((k480.EQ.4).AND.(k478.LE.-2).AND.(acc_lrb%K.GT.0))
724 & THEN
725 allocate(pos_list(current_blr-nb_dec),stat=allocok)
726 IF (allocok .GT. 0) THEN
727 iflag = -13
728 ierror = current_blr-nb_dec
729 GOTO 100
730 ENDIF
731 pos_list(1) = 1
732 DO ii = 1,current_blr-nb_dec-1
733 pos_list(ii+1)=pos_list(ii)+j_rank(nb_dec+ii)
734 ENDDO
735 CALL dmumps_recompress_acc_narytree(acc_lrb,
736 & maxi_cluster, maxi_rank, a, la, poselt_incb, keep8,
737 & nfront, niv, midblk_compress, toleps, tol_opt,
738 & kpercent_rmb, kpercent_lua, k478,
739 & j_rank(nb_dec+1:current_blr), pos_list,
740 & current_blr-nb_dec, 0)
741 deallocate(pos_list)
742 ENDIF
743 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
744 & maxi_rank, a, la, poselt_incb, nfront, niv, 0)
745 ENDIF
746 ENDIF
747 100 CONTINUE
748 ENDDO
749#if defined(BLR_MT)
750!$OMP END DO
751#endif
752 END SUBROUTINE dmumps_blr_upd_panel_left_ldlt
753 SUBROUTINE dmumps_blr_upd_panel_left(
754 & A, LA, POSELT, NFRONT, IWHANDLER, LorU,
755 & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA,
756 & NB_BLR, NPARTSASS, NELIM, NIV, SYM,
757 & LBANDSLAVE, IFLAG, IERROR, ISHIFT,
758 & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB,
759 & K480, K479, K478, KPERCENT_LUA, KPERCENT,
760 & MAXI_CLUSTER, MAXI_RANK,
761 & K474, FSorCB, BLR_U_COL, KEEP8,
762 & FIRST_BLOCK, BEG_I_IN, END_I_IN)
763!$ USE OMP_LIB
764 INTEGER(8), intent(in) :: LA
765 INTEGER(8), intent(in) :: POSELT
766 INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS,
767 & CURRENT_BLR, IWHANDLER, LorU,
768 & nelim, niv, sym, k480, k479, k478,
769 & maxi_cluster, maxi_rank,
770 & kpercent_lua, kpercent, ishift,
771 & k474, fsorcb
772 LOGICAL, intent(in) :: LBANDSLAVE
773 DOUBLE PRECISION, TARGET, intent(inout) :: A(LA)
774 TYPE(lrb_type), POINTER :: ACC_LUA(:), BLR_U_COL(:)
775 INTEGER(8) :: KEEP8(150)
776 INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U
777 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT
778 DOUBLE PRECISION,intent(in) :: TOLEPS
779 INTEGER,intent(inout) :: IFLAG, IERROR
780 INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK
781 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN
782 TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:)
783 TYPE(LRB_TYPE), POINTER :: ACC_LRB
784 INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES,
785 & nb_dec, fr_rank, maxrank, beg_i, end_i
786 INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX
787 INTEGER :: MID_RANK, allocok
788 INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR)
789 INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:)
790 LOGICAL :: BUILDQ, COMPRESSED_FR
791#if defined(BLR_MT)
792 INTEGER :: OMP_NUM
793 INTEGER :: CHUNK
794#endif
795 INTEGER(8) :: POSELT_INCB
796 DOUBLE PRECISION :: ONE, MONE, ZERO
797 PARAMETER (ONE = 1.0d0, mone=-1.0d0)
798 parameter(zero=0.0d0)
799 IF (niv.EQ.2.AND.loru.EQ.0) THEN
800 IF (lbandslave) THEN
801 nb_blocks_panel = nb_blr
802 ELSE
803 nb_blocks_panel = npartsass-current_blr
804 ENDIF
805 ELSE
806 nb_blocks_panel = nb_blr-current_blr
807 ENDIF
808 acc_lrb => acc_lua(1)
809 IF (k480.GE.5) THEN
810 IF (nb_blocks_panel.GT.1) THEN
811 CALL dmumps_blr_retrieve_panel_loru(
812 & iwhandler,
813 & loru,
814 & current_blr+1, next_blr)
815 ENDIF
816 IF (.not.(present(first_block))) THEN
817 write(*,*) "Internal error in
818 & DMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",k480,
819 & ">=5, but FIRST_BLOCK argument is missing"
820 CALL mumps_abort()
821 ENDIF
822 ENDIF
823 IF (loru.EQ.0) THEN
824 beg_i = 1
825 ELSE
826 beg_i = 2
827 ENDIF
828 end_i = nb_blocks_panel
829 IF (k474.EQ.3) THEN
830 IF(present(beg_i_in)) THEN
831 beg_i = beg_i_in - current_blr
832 ENDIF
833 IF(present(end_i_in)) THEN
834 end_i = end_i_in - current_blr
835 ENDIF
836 ENDIF
837#if defined(BLR_MT)
838 chunk = 1
839!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
840!$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ,
841!$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX,
842!$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB,
843!$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK,
844!$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR)
845#endif
846 DO i = beg_i, end_i
847 IF (iflag.LT.0) cycle
848#if defined(BLR_MT)
849 omp_num = 0
850!$ OMP_NUM = OMP_GET_THREAD_NUM()
851 acc_lrb => acc_lua(omp_num+1)
852#endif
853 IF (loru.EQ.0) THEN
854 IF (lbandslave) THEN
855 poselt_incb = poselt
856 & + int(nfront,8) * int((begs_blr(i+1)-1),8)
857 & + int(begs_blr_u(2)+ishift-1,8)
858 acc_lrb%N = begs_blr(i+2)-begs_blr(i+1)
859 acc_lrb%M = begs_blr_u(3)-begs_blr_u(2)
860 IF (k474.GE.2) THEN
861 blr_u => blr_u_col
862 ENDIF
863 ELSE
864 poselt_incb = poselt
865 & + int(nfront,8) * int((begs_blr(current_blr+i)-1),8)
866 & + int(begs_blr(current_blr+1)-1,8)
867 acc_lrb%N = begs_blr(current_blr+i+1)
868 & -begs_blr(current_blr+i)
869 acc_lrb%M = begs_blr(current_blr+2)-begs_blr(current_blr+1)
870 ENDIF
871 ELSE
872 poselt_incb = poselt
873 & + int(nfront,8) * int((begs_blr(current_blr+1)-1),8)
874 & + int(begs_blr(current_blr+i)-1,8)
875 acc_lrb%N = begs_blr(current_blr+2)-begs_blr(current_blr+1)
876 acc_lrb%M = begs_blr(current_blr+i+1)-begs_blr(current_blr+i)
877 ENDIF
878 max_acc_rank = 0
879 new_acc_rank = 0
880 compressed_fr = .false.
881 IF (k480.EQ.2) THEN
882 DO j = 1, current_blr
883 j_order(j) = j
884 ENDDO
885 ELSE
886 CALL dmumps_get_lua_order(current_blr, j_order, j_rank,
887 & iwhandler,
888 & 0, 0, i, loru,
889 & frfr_updates,
890 & lbandslave, k474, blr_u_col)
891 ENDIF
892 fr_rank = 0
893 IF ((k480.GE.5).AND.(i.NE.1)) THEN
894 IF (i.GT.first_block) THEN
895 IF (frfr_updates.EQ.0) THEN
896 CALL dmumps_compress_fr_updates(acc_lrb,
897 & maxi_cluster, maxi_rank, a, la, poselt_incb,
898 & nfront, niv, toleps, tol_opt, kpercent,
899 & compressed_fr, loru, .false.)
900 max_acc_rank = acc_lrb%K
901 new_acc_rank = acc_lrb%K
902 fr_rank = acc_lrb%K
903 ENDIF
904 ENDIF
905 ENDIF
906 nb_dec = frfr_updates
907 DO jj = 1, current_blr
908 j = j_order(jj)
909 k_max = j_rank(jj)
910 IF (loru.EQ.0) THEN
911 IF (lbandslave) THEN
912 ind_l = i
913 IF (k474.LT.2) THEN
914 ind_u = current_blr+1-j
915 ELSE
916 ind_u = j
917 ENDIF
918 ELSE
919 ind_l = current_blr+i-j
920 ind_u = current_blr+1-j
921 ENDIF
922 ELSE
923 ind_l = current_blr+1-j
924 ind_u = current_blr+i-j
925 ENDIF
926 CALL dmumps_blr_retrieve_panel_loru(
927 & iwhandler,
928 & 0,
929 & j, blr_l)
930 IF (blr_l(ind_l)%M.EQ.0) THEN
931 cycle
932 ENDIF
933 IF (.NOT.lbandslave.OR.k474.LT.2) THEN
934 CALL dmumps_blr_retrieve_panel_loru(
935 & iwhandler,
936 & 1,
937 & j, blr_u)
938 ENDIF
939 IF (k480.GE.3) THEN
940 IF (acc_lrb%K+k_max.GT.maxi_rank) THEN
941 nb_dec = jj-1
942 CALL dmumps_decompress_acc(acc_lrb, maxi_cluster,
943 & maxi_rank, a, la, poselt_incb, nfront, niv, loru)
944 compressed_fr = .false.
945 max_acc_rank = 0
946 ENDIF
947 old_acc_rank = acc_lrb%K
948 ENDIF
949 CALL dmumps_lrgemm4(mone,
950 & blr_u(ind_u), blr_l(ind_l), one,
951 & a, la, poselt_incb,
952 & nfront, 0, iflag, ierror,
953 & midblk_compress, toleps, tol_opt,
954 & kpercent_rmb, mid_rank, buildq,
955 & (k480.GE.3), loru=loru,
956 & lrb3=acc_lrb, maxi_rank=maxi_rank,
957 & maxi_cluster=maxi_cluster
958 & )
959 IF (iflag.LT.0) GOTO 100
960 CALL upd_flop_update(blr_u(ind_u), blr_l(ind_l),
961 & midblk_compress, mid_rank, buildq,
962 & .false., (k480.GE.3))
963 IF ((midblk_compress.GE.1).AND.buildq) THEN
964 j_rank(jj) = mid_rank
965 ENDIF
966 IF (k480.GE.3) THEN
967 new_acc_rank = new_acc_rank + acc_lrb%K - old_acc_rank
968 max_acc_rank = max(max_acc_rank, acc_lrb%K - old_acc_rank)
969 IF (k480.EQ.4) THEN
970 IF ((k478.GT.0).AND.((acc_lrb%K-max_acc_rank).GE.k478))
971 & THEN
972 CALL dmumps_recompress_acc(acc_lrb,maxi_cluster,
973 & maxi_rank, a, la, poselt_incb, nfront, niv,
974 & midblk_compress, toleps, tol_opt, kpercent_rmb,
975 & kpercent_lua, new_acc_rank)
976 max_acc_rank = acc_lrb%K
977 ENDIF
978 ENDIF
979 ENDIF
980 IF ((k480.GE.5).AND.(i.NE.1)) THEN
981 IF (i.GT.first_block) THEN
982 IF (jj.EQ.frfr_updates) THEN
983 CALL dmumps_compress_fr_updates(acc_lrb,
984 & maxi_cluster, maxi_rank, a, la, poselt_incb,
985 & nfront, niv, toleps, tol_opt, kpercent,
986 & compressed_fr, loru, .false.)
987 max_acc_rank = acc_lrb%K
988 new_acc_rank = acc_lrb%K
989 IF (compressed_fr) THEN
990 j_rank(jj) = acc_lrb%K
991 nb_dec = frfr_updates-1
992 ENDIF
993 ENDIF
994 ENDIF
995 ENDIF
996 ENDDO
997 IF (k480.GE.3) THEN
998 IF ((k480.GE.5)) THEN
999 IF (compressed_fr.OR.(k480.GE.6)) THEN
1000 IF (acc_lrb%K.GT.0) THEN
1001 IF (k478.EQ.-1) THEN
1002 IF (current_blr-frfr_updates.GT.1) THEN
1003 CALL dmumps_recompress_acc(acc_lrb,
1004 & maxi_cluster, maxi_rank, a, la, poselt_incb,
1005 & nfront, niv, midblk_compress, toleps, tol_opt,
1006 & kpercent_rmb, kpercent_lua, new_acc_rank)
1007 ENDIF
1008 ELSEIF (k478.LE.-2) THEN
1009 IF (frfr_updates.GT.0) THEN
1010 allocate(pos_list(current_blr-nb_dec),stat=allocok)
1011 IF (allocok .GT. 0) THEN
1012 iflag = -13
1013 ierror = current_blr-nb_dec
1014 write(*,*) 'Allocation problem in BLR routine ',
1015 & 'DMUMPS_BLR_UPD_PANEL_LEFT: ',
1016 & 'not enough memory? memory requested = ',
1017 & ierror
1018 GOTO 100
1019 ENDIF
1020 pos_list(1) = 1
1021 DO ii = 1,current_blr-nb_dec-1
1022 pos_list(ii+1)=pos_list(ii)+j_rank(nb_dec+ii)
1023 ENDDO
1024 CALL dmumps_recompress_acc_narytree(acc_lrb,
1025 & maxi_cluster, maxi_rank, a, la, poselt_incb, keep8,
1026 & nfront, niv, midblk_compress, toleps, tol_opt,
1027 & kpercent_rmb, kpercent_lua, k478,
1028 & j_rank(nb_dec+1:current_blr), pos_list,
1029 & current_blr-nb_dec, 0)
1030 ELSE
1031 allocate(pos_list(current_blr+1),stat=allocok)
1032 IF (allocok .GT. 0) THEN
1033 iflag = -13
1034 ierror = current_blr+1
1035 write(*,*) 'Allocation problem in BLR routine ',
1036 & 'DMUMPS_BLR_UPD_PANEL_LEFT: ',
1037 & 'not enough memory? memory requested = ',
1038 & ierror
1039 GOTO 100
1040 ENDIF
1041 pos_list(1) = 1
1042 pos_list(2) = 1 + fr_rank
1043 DO ii = 2,current_blr
1044 pos_list(ii+1)=pos_list(ii)+j_rank(ii-1)
1045 ENDDO
1046 allocate(rank_list(current_blr+1),stat=allocok)
1047 IF (allocok .GT. 0) THEN
1048 iflag = -13
1049 ierror = current_blr+1
1050 write(*,*) 'Allocation problem in BLR routine ',
1051 & 'DMUMPS_BLR_UPD_PANEL_LEFT: ',
1052 & 'not enough memory? memory requested = ',
1053 & ierror
1054 GOTO 100
1055 ENDIF
1056 rank_list(1) = fr_rank
1057 DO ii = 2,current_blr+1
1058 rank_list(ii) = j_rank(ii-1)
1059 ENDDO
1060 CALL dmumps_recompress_acc_narytree(acc_lrb,
1061 & maxi_cluster, maxi_rank, a, la, poselt_incb, keep8,
1062 & nfront, niv, midblk_compress, toleps, tol_opt,
1063 & kpercent_rmb, kpercent_lua, k478,
1064 & rank_list, pos_list,
1065 & current_blr+1, 0)
1066 deallocate(rank_list)
1067 ENDIF
1068 deallocate(pos_list)
1069 ENDIF
1070 ENDIF
1071 ENDIF
1072 maxrank = floor(dble(acc_lrb%M*acc_lrb%N)/dble(acc_lrb%M+
1073 & acc_lrb%N))
1074 IF (compressed_fr.AND.(acc_lrb%K.LE.maxrank)) THEN
1075 CALL alloc_lrb_from_acc(acc_lrb, next_blr(i-1),
1076 & acc_lrb%K, acc_lrb%M, acc_lrb%N, loru,
1077 & iflag, ierror, keep8)
1078 IF (iflag.LT.0) cycle
1079 acc_lrb%K = 0
1080 ELSE
1081 IF (i.NE.1) next_blr(i-1)%ISLR=.false.
1082 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
1083 & maxi_rank, a, la, poselt_incb, nfront, niv, loru)
1084 ENDIF
1085 ELSE
1086 IF ((k480.EQ.4).AND.(k478.EQ.-1).AND.(acc_lrb%K.GT.0)) THEN
1087 IF (current_blr-frfr_updates.GT.1) THEN
1088 CALL dmumps_recompress_acc(acc_lrb,
1089 & maxi_cluster, maxi_rank, a, la, poselt_incb,
1090 & nfront, niv, midblk_compress, toleps, tol_opt,
1091 & kpercent_rmb, kpercent_lua, new_acc_rank)
1092 ENDIF
1093 ELSEIF ((k480.EQ.4).AND.(k478.LE.-2).AND.(acc_lrb%K.GT.0))
1094 & THEN
1095 allocate(pos_list(current_blr-nb_dec),stat=allocok)
1096 IF (allocok .GT. 0) THEN
1097 iflag = -13
1098 ierror = current_blr-nb_dec
1099 GOTO 100
1100 ENDIF
1101 pos_list(1) = 1
1102 DO ii = 1,current_blr-nb_dec-1
1103 pos_list(ii+1)=pos_list(ii)+j_rank(nb_dec+ii)
1104 ENDDO
1105 CALL dmumps_recompress_acc_narytree(acc_lrb,
1106 & maxi_cluster, maxi_rank, a, la, poselt_incb, keep8,
1107 & nfront, niv, midblk_compress, toleps, tol_opt,
1108 & kpercent_rmb, kpercent_lua, k478,
1109 & j_rank(nb_dec+1:current_blr), pos_list,
1110 & current_blr-nb_dec, 0)
1111 deallocate(pos_list)
1112 ENDIF
1113 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
1114 & maxi_rank, a, la, poselt_incb, nfront, niv, loru)
1115 ENDIF
1116 ENDIF
1117 100 CONTINUE
1118 ENDDO
1119#if defined(BLR_MT)
1120!$OMP END DO NOWAIT
1121#endif
1122 END SUBROUTINE dmumps_blr_upd_panel_left
1123 SUBROUTINE dmumps_blr_upd_cb_left_ldlt(A, LA, POSELT, NFRONT,
1124 & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS,
1125 & IWHANDLER,
1126 & IW2, BLOCK, ACC_LUA,
1127 & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR,
1128 & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB,
1129 & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8)
1130!$ USE OMP_LIB
1131 INTEGER(8), intent(in) :: LA
1132 DOUBLE PRECISION, intent(inout) :: A(LA)
1133 INTEGER(8), intent(in) :: POSELT
1134 INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM
1135 INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER,
1136 & maxi_rank, k480, k479, k478, nass,
1137 & kpercent_lua, kpercent
1138 INTEGER, intent(inout) :: IFLAG, IERROR
1139 INTEGER(8) :: KEEP8(150)
1140 INTEGER, DIMENSION(:) :: BEGS_BLR
1141 INTEGER, DIMENSION(:) :: BEGS_BLR_DYN
1142 DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*)
1143 INTEGER, intent(in) :: IW2(*)
1144 TYPE(lrb_type), POINTER :: ACC_LUA(:)
1145 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT
1146 DOUBLE PRECISION,intent(in) :: TOLEPS
1147 INTEGER :: M, N, allocok
1148 INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS,
1149 & k_order(nb_inasm), k_rank(nb_inasm), nb_dec
1150 INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:)
1151 INTEGER(8) :: POSELT_BLOCK, POSELTD
1152 INTEGER :: NCB, MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK
1153 LOGICAL :: BUILDQ, COMPRESSED_FR
1154 TYPE(lrb_type), POINTER :: BLR_L(:)
1155 TYPE(LRB_TYPE), POINTER :: ACC_LRB
1156 INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK
1157 INTEGER :: OFFSET_IW
1158 INTEGER :: OMP_NUM
1159#if defined(BLR_MT)
1160 INTEGER :: CHUNK
1161#endif
1162 DOUBLE PRECISION :: ONE, MONE, ZERO
1163 PARAMETER (ONE = 1.0d0, mone=-1.0d0)
1164 parameter(zero=0.0d0)
1165 ncb = nfront - nass
1166 acc_lrb => acc_lua(1)
1167 omp_num = 0
1168#if defined(BLR_MT)
1169 chunk = 1
1170!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
1171!$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ,
1172!$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK,
1173!$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD,
1174!$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK,
1175!$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II)
1176#endif
1177 DO ibis = 1,nb_incb*(nb_incb+1)/2
1178 IF (iflag.LT.0) cycle
1179 i = ceiling((1.0d0+sqrt(1.0d0+8.0d0*dble(ibis)))/2.0d0)-1
1180 j = ibis - i*(i-1)/2
1181 i = i+nb_inasm
1182 j = j+nb_inasm
1183#if defined(BLR_MT)
1184 omp_num = 0
1185!$ OMP_NUM = OMP_GET_THREAD_NUM()
1186 acc_lrb => acc_lua(omp_num+1)
1187#endif
1188 max_acc_rank = 0
1189 new_acc_rank = 0
1190 m = begs_blr(i+1)-begs_blr(i)
1191 n = begs_blr(j+1)-begs_blr(j)
1192 poselt_block = poselt + int(nfront,8)*int(begs_blr(i)-1,8) +
1193 & int(begs_blr(j)-1,8)
1194 acc_lrb%M = n
1195 acc_lrb%N = m
1196 IF (k480.EQ.2) THEN
1197 DO k = 1, nb_inasm
1198 k_order(k) = k
1199 ENDDO
1200 ELSE
1201 CALL dmumps_get_lua_order(nb_inasm, k_order, k_rank,
1202 & iwhandler,
1203 & 1, 1, i, j,
1204 & frfr_updates)
1205 ENDIF
1206 fr_rank = 0
1207 IF ((k480.GE.5).AND.(i.NE.j)) THEN
1208 IF (frfr_updates.EQ.0) THEN
1209 CALL dmumps_compress_fr_updates(acc_lrb,
1210 & maxi_cluster, maxi_rank, a, la, poselt_block,
1211 & nfront, niv, toleps, tol_opt, kpercent,
1212 & compressed_fr, 0, .true.)
1213 fr_rank = acc_lrb%K
1214 max_acc_rank = acc_lrb%K
1215 new_acc_rank = acc_lrb%K
1216 ENDIF
1217 ENDIF
1218 nb_dec = frfr_updates
1219 DO kk = 1, nb_inasm
1220 k = k_order(kk)
1221 k_max = k_rank(kk)
1222 poseltd = poselt + int(nfront,8) * int(begs_blr_dyn(k)-1,8)
1223 & + int(begs_blr_dyn(k) - 1,8)
1224 offset_iw = begs_blr_dyn(k)
1225 ind_l = i-k
1226 ind_u = j-k
1227 CALL dmumps_blr_retrieve_panel_loru(
1228 & iwhandler,
1229 & 0,
1230 & k, blr_l)
1231 IF (blr_l(ind_l)%M.EQ.0) THEN
1232 cycle
1233 ENDIF
1234 IF (k480.GE.3) THEN
1235 IF (acc_lrb%K+k_max.GT.maxi_rank) THEN
1236 nb_dec = kk-1
1237 CALL dmumps_decompress_acc(acc_lrb,
1238 & maxi_cluster, maxi_rank, a, la, poselt_block,
1239 & nfront, niv, 2)
1240 compressed_fr = .false.
1241 max_acc_rank = 0
1242 ENDIF
1243 old_acc_rank = acc_lrb%K
1244 ENDIF
1245 CALL dmumps_lrgemm4(mone,
1246 & blr_l(ind_u), blr_l(ind_l), one,
1247 & a, la, poselt_block,
1248 & nfront, 1, iflag, ierror,
1249 & midblk_compress, toleps, tol_opt,
1250 & kpercent_rmb, mid_rank, buildq,
1251 & (k480.GE.3), loru=2,
1252 & lrb3=acc_lrb, maxi_rank=maxi_rank,
1253 & maxi_cluster=maxi_cluster,
1254 & diag=a(poseltd), ld_diag=nfront,
1255 & iw2=iw2(offset_iw),
1256 & block=block(1:maxi_cluster,omp_num*maxi_cluster+1))
1257 IF (iflag.LT.0) GOTO 100
1258 CALL upd_flop_update(blr_l(ind_u), blr_l(ind_l),
1259 & midblk_compress, mid_rank, buildq,
1260 & (i.EQ.j), (k480.GE.3))
1261 IF ((midblk_compress.GE.1).AND.buildq) THEN
1262 k_rank(kk) = mid_rank
1263 ENDIF
1264 IF (k480.GE.3) THEN
1265 new_acc_rank = new_acc_rank + acc_lrb%K - old_acc_rank
1266 max_acc_rank = max(max_acc_rank, acc_lrb%K - old_acc_rank)
1267 IF (k480.EQ.4) THEN
1268 IF ((k478.GT.0).AND.((acc_lrb%K-max_acc_rank).GE.k478))
1269 & THEN
1270 IF (acc_lrb%K.GT.0) THEN
1271 CALL dmumps_recompress_acc(acc_lrb,
1272 & maxi_cluster, maxi_rank, a, la, poselt_block,
1273 & nfront, niv, midblk_compress, toleps,
1274 & tol_opt,
1275 & kpercent_rmb, kpercent_lua, new_acc_rank)
1276 max_acc_rank = acc_lrb%K
1277 ENDIF
1278 ENDIF
1279 ENDIF
1280 IF ((k480.GE.5).AND.(i.NE.j)) THEN
1281 IF (kk.EQ.frfr_updates) THEN
1282 CALL dmumps_compress_fr_updates(acc_lrb,
1283 & maxi_cluster, maxi_rank, a, la, poselt_block,
1284 & nfront, niv, toleps, tol_opt, kpercent,
1285 & compressed_fr, 0, .true.)
1286 IF (compressed_fr) THEN
1287 k_rank(kk) = acc_lrb%K
1288 nb_dec = frfr_updates-1
1289 ENDIF
1290 max_acc_rank = acc_lrb%K
1291 new_acc_rank = acc_lrb%K
1292 ENDIF
1293 ENDIF
1294 ENDIF
1295 END DO
1296 IF (k480.GE.3) THEN
1297 IF ((k480.GE.5)) THEN
1298 IF (compressed_fr.OR.(k480.GE.6)) THEN
1299 IF (acc_lrb%K.GT.0) THEN
1300 IF (k478.EQ.-1) THEN
1301 IF (nb_inasm-frfr_updates.GT.1) THEN
1302 CALL dmumps_recompress_acc(acc_lrb,
1303 & maxi_cluster, maxi_rank, a, la, poselt_block,
1304 & nfront, niv, midblk_compress, toleps,
1305 & tol_opt,
1306 & kpercent_rmb, kpercent_lua, new_acc_rank)
1307 ENDIF
1308 ELSEIF (k478.LE.-2) THEN
1309 IF (frfr_updates.GT.0) THEN
1310 allocate(pos_list(nb_inasm-nb_dec),stat=allocok)
1311 IF (allocok .GT. 0) THEN
1312 iflag = -13
1313 ierror = nb_inasm-nb_dec
1314 write(*,*) 'Allocation problem in BLR routine ',
1315 & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ',
1316 & 'not enough memory? memory requested = ',
1317 & ierror
1318 GOTO 100
1319 ENDIF
1320 pos_list(1) = 1
1321 DO ii = 1,nb_inasm-nb_dec-1
1322 pos_list(ii+1)=pos_list(ii)+k_rank(nb_dec+ii)
1323 ENDDO
1324 CALL dmumps_recompress_acc_narytree(acc_lrb,
1325 & maxi_cluster, maxi_rank, a, la, poselt_block,keep8,
1326 & nfront, niv, midblk_compress, toleps, tol_opt,
1327 & kpercent_rmb, kpercent_lua, k478,
1328 & k_rank(nb_dec+1:nb_inasm), pos_list,
1329 & nb_inasm-nb_dec, 0)
1330 ELSE
1331 allocate(pos_list(nb_inasm+1),stat=allocok)
1332 IF (allocok .GT. 0) THEN
1333 iflag = -13
1334 ierror = nb_inasm+1
1335 write(*,*) 'Allocation problem in BLR routine ',
1336 & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ',
1337 & 'not enough memory? memory requested = ',
1338 & ierror
1339 GOTO 100
1340 ENDIF
1341 pos_list(1) = 1
1342 pos_list(2) = 1 + fr_rank
1343 DO ii = 2,nb_inasm
1344 pos_list(ii+1)=pos_list(ii)+k_rank(ii-1)
1345 ENDDO
1346 allocate(rank_list(nb_inasm+1),stat=allocok)
1347 IF (allocok .GT. 0) THEN
1348 iflag = -13
1349 ierror = nb_inasm+1
1350 write(*,*) 'Allocation problem in BLR routine ',
1351 & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ',
1352 & 'not enough memory? memory requested = ',
1353 & ierror
1354 GOTO 100
1355 ENDIF
1356 rank_list(1) = fr_rank
1357 DO ii = 2,nb_inasm+1
1358 rank_list(ii) = k_rank(ii-1)
1359 ENDDO
1360 CALL dmumps_recompress_acc_narytree(acc_lrb,
1361 & maxi_cluster, maxi_rank, a, la, poselt_block,keep8,
1362 & nfront, niv, midblk_compress, toleps, tol_opt,
1363 & kpercent_rmb, kpercent_lua, k478,
1364 & rank_list, pos_list,
1365 & nb_inasm+1, 0)
1366 deallocate(rank_list)
1367 ENDIF
1368 deallocate(pos_list)
1369 ENDIF
1370 ENDIF
1371 ENDIF
1372 maxrank = floor(dble(acc_lrb%M*acc_lrb%N)/dble(acc_lrb%M+
1373 & acc_lrb%N))
1374 IF (compressed_fr.AND.(acc_lrb%K.LE.maxrank)) THEN
1375 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
1376 & maxi_rank, a, la, poselt_block, nfront, niv, 2,
1377 & count_flops=.false.)
1378 ELSE
1379 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
1380 & maxi_rank, a, la, poselt_block, nfront, niv, 2)
1381 ENDIF
1382 ELSE
1383 IF ((k480.EQ.4).AND.(k478.EQ.-1).AND.(acc_lrb%K.GT.0)) THEN
1384 IF (nb_inasm-frfr_updates.GT.1) THEN
1385 CALL dmumps_recompress_acc(acc_lrb,
1386 & maxi_cluster, maxi_rank, a, la, poselt_block,
1387 & nfront, niv, midblk_compress, toleps, tol_opt,
1388 & kpercent_rmb, kpercent_lua, new_acc_rank)
1389 ENDIF
1390 ELSEIF ((k480.EQ.4).AND.(k478.LE.-2).AND.(acc_lrb%K.GT.0))
1391 & THEN
1392 allocate(pos_list(nb_inasm-nb_dec),stat=allocok)
1393 IF (allocok .GT. 0) THEN
1394 iflag = -13
1395 ierror = nb_inasm-nb_dec
1396 GOTO 100
1397 ENDIF
1398 pos_list(1) = 1
1399 DO ii = 1,nb_inasm-nb_dec-1
1400 pos_list(ii+1)=pos_list(ii)+k_rank(nb_dec+ii)
1401 ENDDO
1402 CALL dmumps_recompress_acc_narytree(acc_lrb,
1403 & maxi_cluster, maxi_rank, a, la, poselt_block,
1404 & keep8, nfront, niv, midblk_compress, toleps,
1405 & tol_opt, kpercent_rmb, kpercent_lua, k478,
1406 & k_rank(nb_dec+1:nb_inasm), pos_list,
1407 & nb_inasm-nb_dec, 0)
1408 deallocate(pos_list)
1409 ENDIF
1410 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
1411 & maxi_rank, a, la, poselt_block, nfront, niv, 2)
1412 ENDIF
1413 ENDIF
1414 100 CONTINUE
1415 END DO
1416#if defined(BLR_MT)
1417!$OMP END DO
1418#endif
1419 END SUBROUTINE dmumps_blr_upd_cb_left_ldlt
1420 SUBROUTINE dmumps_blr_upd_cb_left(A, LA, POSELT, NFRONT,
1421 & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS,
1422 & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR,
1423 & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB,
1424 & ACC_LUA, K480, K479, K478, KPERCENT_LUA,
1425 & KPERCENT,
1426 & MAXI_CLUSTER, MAXI_RANK,
1427 & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8)
1428!$ USE OMP_LIB
1429 INTEGER(8), intent(in) :: LA
1430 DOUBLE PRECISION, intent(inout) :: A(LA)
1431 INTEGER(8), intent(in) :: POSELT
1432 INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM
1433 INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER,
1434 & maxi_rank, kpercent_lua, kpercent
1435 INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474,
1436 & FSorCB
1437 INTEGER, intent(inout) :: IFLAG, IERROR
1438 INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U
1439#if defined(MUMPS_F2003)
1440 TYPE(lrb_type), POINTER, intent(inout) :: CB_LRB(:,:)
1441#else
1442 TYPE(lrb_type), POINTER :: CB_LRB(:,:)
1443#endif
1444 TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:)
1445 INTEGER(8) :: KEEP8(150)
1446 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT
1447 DOUBLE PRECISION,intent(in) :: TOLEPS
1448 LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB
1449 INTEGER :: M, N, allocok
1450 INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS,
1451 & k_order(nb_inasm), k_rank(nb_inasm)
1452 INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:)
1453 INTEGER(8) :: POSELT_BLOCK
1454 INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC
1455 LOGICAL :: BUILDQ, COMPRESSED_FR
1456 TYPE(lrb_type), POINTER :: BLR_U(:), BLR_L(:)
1457 TYPE(lrb_type), POINTER :: ACC_LRB, LRB
1458 INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK,
1459 & FR_RANK
1460#if defined(BLR_MT)
1461 INTEGER :: OMP_NUM
1462 INTEGER :: CHUNK
1463#endif
1464 DOUBLE PRECISION :: ONE, MONE, ZERO
1465 parameter(one = 1.0d0, mone=-1.0d0)
1466 parameter(zero=0.0d0)
1467 acc_lrb => acc_lua(1)
1468#if defined(BLR_MT)
1469 chunk = 1
1470!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
1471!$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ,
1472!$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N,
1473!$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK,
1474!$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK,
1475!$OMP& FRFR_UPDATES, LRB)
1476#endif
1477 DO ibis = 1,nb_rows*nb_incb
1478 IF (iflag.LT.0) cycle
1479 i = (ibis-1)/nb_incb+1
1480 j = ibis - (i-1)*nb_incb
1481 IF (.NOT.lbandslave) THEN
1482 i = i+nb_inasm
1483 ENDIF
1484 j = j+nb_inasm
1485#if defined(BLR_MT)
1486 omp_num=0
1487!$ OMP_NUM = OMP_GET_THREAD_NUM()
1488 acc_lrb => acc_lua(omp_num+1)
1489#endif
1490 max_acc_rank = 0
1491 new_acc_rank = 0
1492 IF (lbandslave) THEN
1493 m = begs_blr(i+2)-begs_blr(i+1)
1494 IF (k474.EQ.1) THEN
1495 poselt_block = poselt + int(nfront,8)*int(begs_blr(i+1)-1,8)
1496 & +int(nass,8) + int(begs_blr_u(j-nb_inasm+1)-1,8)
1497 n = begs_blr_u(j-nb_inasm+2)-begs_blr_u(j-nb_inasm+1)
1498 ELSEIF (k474.GE.2) THEN
1499 blr_u => blr_u_col
1500 poselt_block = poselt + int(nfront,8)*int(begs_blr(i+1)-1,8)
1501 & + int(nass-1,8)
1502 n = begs_blr_u(3)-begs_blr_u(2)
1503 ELSE
1504 write(*,*) 'Internal error in DMUMPS_BLR_UPD_CB_LEFT',
1505 & lbandslave,k474
1506 CALL mumps_abort()
1507 ENDIF
1508 ELSE
1509 m = begs_blr(i+1)-begs_blr(i)
1510 poselt_block = poselt + int(nfront,8)*int(begs_blr(i)-1,8) +
1511 & int(begs_blr_u(j)-1,8)
1512 n = begs_blr_u(j+1)-begs_blr_u(j)
1513 ENDIF
1514 acc_lrb%M = n
1515 acc_lrb%N = m
1516 IF (k480.EQ.2) THEN
1517 DO k = 1, nb_inasm
1518 k_order(k) = k
1519 ENDDO
1520 ELSE
1521 CALL dmumps_get_lua_order(nb_inasm, k_order, k_rank,
1522 & iwhandler,
1523 & 0, 1, i, j,
1524 & frfr_updates,
1525 & lbandslave, k474, blr_u_col)
1526 ENDIF
1527 compressed_fr = .false.
1528 fr_rank = 0
1529 DO kk = 1, nb_inasm
1530 IF ((k480.GE.5.OR.compress_cb).AND.i.NE.j) THEN
1531 IF (kk-1.EQ.frfr_updates) THEN
1532 CALL dmumps_compress_fr_updates(acc_lrb,
1533 & maxi_cluster, maxi_rank, a, la, poselt_block,
1534 & nfront, niv, toleps, tol_opt, kpercent,
1535 & compressed_fr, 0, .true.)
1536 IF (compressed_fr) THEN
1537 k_rank(kk) = acc_lrb%K
1538 nb_dec = frfr_updates-1
1539 ENDIF
1540 max_acc_rank = acc_lrb%K
1541 new_acc_rank = acc_lrb%K
1542 fr_rank = acc_lrb%K
1543 ENDIF
1544 ENDIF
1545 k = k_order(kk)
1546 k_max = k_rank(kk)
1547 IF (lbandslave) THEN
1548 ind_l = i
1549 IF (k474.LT.2) THEN
1550 ind_u = j-k
1551 ELSE
1552 ind_u = k
1553 ENDIF
1554 ELSE
1555 ind_l = i-k
1556 ind_u = j-k
1557 ENDIF
1558 CALL dmumps_blr_retrieve_panel_loru(
1559 & iwhandler,
1560 & 0,
1561 & k, blr_l)
1562 IF (blr_l(ind_l)%M.EQ.0) THEN
1563 cycle
1564 ENDIF
1565 IF (.NOT.lbandslave.OR.k474.LT.2) THEN
1566 CALL dmumps_blr_retrieve_panel_loru(
1567 & iwhandler,
1568 & 1,
1569 & k, blr_u)
1570 ENDIF
1571 IF (k480.GE.3) THEN
1572 IF (acc_lrb%K+k_max.GT.maxi_rank) THEN
1573 compressed_fr = .false.
1574 nb_dec = kk-1
1575 CALL dmumps_decompress_acc(acc_lrb,
1576 & maxi_cluster, maxi_rank, a, la, poselt_block,
1577 & nfront, niv, 2)
1578 max_acc_rank = 0
1579 ENDIF
1580 old_acc_rank = acc_lrb%K
1581 ENDIF
1582 CALL dmumps_lrgemm4(mone,
1583 & blr_u(ind_u), blr_l(ind_l), one,
1584 & a, la, poselt_block,
1585 & nfront, 0, iflag, ierror,
1586 & midblk_compress, toleps, tol_opt,
1587 & kpercent_rmb, mid_rank, buildq,
1588 & (k480.GE.3), loru=2,
1589 & lrb3=acc_lrb, maxi_rank=maxi_rank,
1590 & maxi_cluster=maxi_cluster)
1591 IF (iflag.LT.0) GOTO 100
1592 CALL upd_flop_update(blr_u(ind_u), blr_l(ind_l),
1593 & midblk_compress, mid_rank, buildq,
1594 & .false., (k480.GE.3))
1595 IF ((midblk_compress.GE.1).AND.buildq) THEN
1596 k_rank(kk) = mid_rank
1597 ENDIF
1598 IF (k480.GE.3) THEN
1599 new_acc_rank = new_acc_rank + acc_lrb%K - old_acc_rank
1600 max_acc_rank = max(max_acc_rank, acc_lrb%K - old_acc_rank)
1601 IF (k480.EQ.4) THEN
1602 IF ((k478.GT.0).AND.((acc_lrb%K-max_acc_rank).GE.k478))
1603 & THEN
1604 CALL dmumps_recompress_acc(acc_lrb,
1605 & maxi_cluster, maxi_rank, a, la, poselt_block,
1606 & nfront, niv, midblk_compress, toleps,
1607 & tol_opt,
1608 & kpercent_rmb, kpercent_lua, new_acc_rank)
1609 max_acc_rank = acc_lrb%K
1610 ENDIF
1611 ENDIF
1612 ENDIF
1613 END DO
1614 IF (k480.GE.3) THEN
1615 IF (k480.GE.5.OR.compress_cb) THEN
1616 IF (k480.GE.5.AND.(compressed_fr.OR.k480.GE.6)) THEN
1617 IF (acc_lrb%K.GT.0) THEN
1618 IF (k478.EQ.-1) THEN
1619 IF (nb_inasm-frfr_updates.GT.1) THEN
1620 CALL dmumps_recompress_acc(acc_lrb,
1621 & maxi_cluster, maxi_rank, a, la, poselt_block,
1622 & nfront, niv, midblk_compress, toleps, tol_opt,
1623 & kpercent_rmb, kpercent_lua, new_acc_rank)
1624 ENDIF
1625 ELSEIF (k478.LE.-2) THEN
1626 IF (frfr_updates.GT.0) THEN
1627 allocate(pos_list(nb_inasm-nb_dec),stat=allocok)
1628 IF (allocok .GT. 0) THEN
1629 iflag = -13
1630 ierror = nb_inasm-nb_dec
1631 GOTO 100
1632 ENDIF
1633 pos_list(1) = 1
1634 DO ii = 1,nb_inasm-nb_dec-1
1635 pos_list(ii+1)=pos_list(ii)+k_rank(nb_dec+ii)
1636 ENDDO
1637 CALL dmumps_recompress_acc_narytree(acc_lrb,
1638 & maxi_cluster, maxi_rank, a, la, poselt_block,keep8,
1639 & nfront, niv, midblk_compress, toleps, tol_opt,
1640 & kpercent_rmb, kpercent_lua, k478,
1641 & k_rank(nb_dec+1:nb_inasm), pos_list,
1642 & nb_inasm-nb_dec, 0)
1643 ELSE
1644 allocate(pos_list(nb_inasm+1),stat=allocok)
1645 IF (allocok .GT. 0) THEN
1646 iflag = -13
1647 ierror = nb_inasm+1
1648 GOTO 100
1649 ENDIF
1650 pos_list(1) = 1
1651 pos_list(2) = 1 + fr_rank
1652 DO ii = 2,nb_inasm
1653 pos_list(ii+1)=pos_list(ii)+k_rank(ii-1)
1654 ENDDO
1655 allocate(rank_list(nb_inasm+1),stat=allocok)
1656 IF (allocok .GT. 0) THEN
1657 iflag = -13
1658 ierror = nb_inasm+1
1659 GOTO 100
1660 ENDIF
1661 rank_list(1) = fr_rank
1662 DO ii = 2,nb_inasm+1
1663 rank_list(ii) = k_rank(ii-1)
1664 ENDDO
1665 CALL dmumps_recompress_acc_narytree(acc_lrb,
1666 & maxi_cluster, maxi_rank, a, la, poselt_block,keep8,
1667 & nfront, niv, midblk_compress, toleps, tol_opt,
1668 & kpercent_rmb, kpercent_lua, k478,
1669 & rank_list, pos_list,
1670 & nb_inasm+1, 0)
1671 deallocate(rank_list)
1672 ENDIF
1673 deallocate(pos_list)
1674 ENDIF
1675 ENDIF
1676 ENDIF
1677 maxrank = floor(dble(acc_lrb%M*acc_lrb%N)/dble(acc_lrb%M+
1678 & acc_lrb%N))
1679 IF (compressed_fr.AND.(acc_lrb%K.LE.maxrank)) THEN
1680 lrb => cb_lrb(i-nb_inasm,j-nb_inasm)
1681 CALL alloc_lrb_from_acc(acc_lrb, lrb,
1682 & acc_lrb%K, acc_lrb%M, acc_lrb%N, 0,
1683 & iflag, ierror, keep8)
1684 CALL upd_mry_cb_lrgain(lrb
1685 & )
1686 acc_lrb%K = 0
1687 IF (iflag.LT.0) GOTO 100
1688 ELSE
1689 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
1690 & maxi_rank, a, la, poselt_block, nfront, niv, 2)
1691 lrb => cb_lrb(i-nb_inasm,j-nb_inasm)
1692 CALL alloc_lrb(lrb, acc_lrb%K, acc_lrb%N, acc_lrb%M,
1693 & .false., iflag, ierror, keep8)
1694 IF (iflag.LT.0) GOTO 100
1695 DO ii=1,acc_lrb%N
1696 lrb%Q(ii,1:acc_lrb%M) =
1697 & a( poselt_block+int((ii-1),8)*int(nfront,8) :
1698 & poselt_block+int((ii-1),8)*int(nfront,8)
1699 & +int(acc_lrb%M-1,8) )
1700 END DO
1701 ENDIF
1702 ELSE
1703 IF ((k480.EQ.4).AND.(k478.EQ.-1).AND.(acc_lrb%K.GT.0)) THEN
1704 IF (nb_inasm-frfr_updates.GT.1) THEN
1705 CALL dmumps_recompress_acc(acc_lrb,
1706 & maxi_cluster, maxi_rank, a, la, poselt_block,
1707 & nfront, niv, midblk_compress, toleps, tol_opt,
1708 & kpercent_rmb, kpercent_lua, new_acc_rank)
1709 ENDIF
1710 ELSEIF ((k480.EQ.4).AND.(k478.LE.-2).AND.(acc_lrb%K.GT.0))
1711 & THEN
1712 allocate(pos_list(nb_inasm-nb_dec),stat=allocok)
1713 IF (allocok .GT. 0) THEN
1714 iflag = -13
1715 ierror = nb_inasm-nb_dec
1716 GOTO 100
1717 ENDIF
1718 pos_list(1) = 1
1719 DO ii = 1,nb_inasm-nb_dec-1
1720 pos_list(ii+1)=pos_list(ii)+k_rank(nb_dec+ii)
1721 ENDDO
1722 CALL dmumps_recompress_acc_narytree(acc_lrb,
1723 & maxi_cluster, maxi_rank, a, la, poselt_block,
1724 & keep8,nfront, niv, midblk_compress, toleps,
1725 & tol_opt, kpercent_rmb, kpercent_lua, k478,
1726 & k_rank(nb_dec+1:nb_inasm), pos_list,
1727 & nb_inasm-nb_dec, 0)
1728 deallocate(pos_list)
1729 ENDIF
1730 CALL dmumps_decompress_acc(acc_lrb,maxi_cluster,
1731 & maxi_rank, a, la, poselt_block, nfront, niv, 2)
1732 ENDIF
1733 ENDIF
1734 100 CONTINUE
1735 END DO
1736#if defined(BLR_MT)
1737!$OMP END DO
1738#endif
1739#if defined(BLR_MT)
1740!$OMP MASTER
1741#endif
1742 IF (compress_cb) THEN
1743 CALL upd_mry_cb_fr(nfront-nass, nfront-nass, 0)
1744 ENDIF
1745#if defined(BLR_MT)
1746!$OMP END MASTER
1747#endif
1748 END SUBROUTINE dmumps_blr_upd_cb_left
1749 SUBROUTINE dmumps_decompress_panel(A, LA, POSELT, LDA11,
1750 & LDA21, COPY_DENSE_BLOCKS,
1751 & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG,
1752 & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER,
1753 & BEG_I_IN, END_I_IN, ONLY_NELIM_IN, CBASM_TOFIX_IN)
1754!$ USE OMP_LIB
1755 INTEGER(8), intent(in) :: LA
1756 DOUBLE PRECISION, intent(inout) :: A(LA)
1757 INTEGER(8), intent(in) :: POSELT
1758 LOGICAL, intent(in) :: COPY_DENSE_BLOCKS
1759 INTEGER, intent(in) :: NB_BLR, CURRENT_BLR
1760 INTEGER, intent(in) :: BEGS_BLR_DIAG,
1761 & begs_blr_first_offdiag
1762 TYPE(lrb_type), intent(inout) :: BLR_PANEL(:)
1763 CHARACTER(len=1) :: DIR
1764 INTEGER, intent(in) :: LDA11, LDA21
1765 INTEGER, intent(in) :: DECOMP_TIMER
1766 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN
1767 LOGICAL,OPTIONAL,intent(in) :: CBASM_TOFIX_IN
1768 INTEGER :: IP, M, N, BIP, BEG_I, END_I, ONLY_NELIM
1769 LOGICAL :: CBASM_TOFIX
1770#if defined(BLR_MT)
1771 INTEGER :: LAST_IP, CHUNK
1772#endif
1773 INTEGER :: K, I
1774 DOUBLE PRECISION :: PROMOTE_COST
1775 INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT
1776 DOUBLE PRECISION :: ONE, ALPHA, ZERO
1777 parameter(one = 1.0d0, alpha=-1.0d0)
1778 parameter(zero = 0.0d0)
1779 IF(present(beg_i_in)) THEN
1780 beg_i = beg_i_in
1781 ELSE
1782 beg_i = current_blr+1
1783 ENDIF
1784 IF(present(end_i_in)) THEN
1785 end_i = end_i_in
1786 ELSE
1787 end_i = nb_blr
1788 ENDIF
1789 IF(present(only_nelim_in)) THEN
1790 only_nelim = only_nelim_in
1791 ELSE
1792 only_nelim = 0
1793 ENDIF
1794 IF (present(cbasm_tofix_in)) THEN
1795 cbasm_tofix = cbasm_tofix_in
1796 ELSE
1797 cbasm_tofix = .false.
1798 ENDIF
1799 ld_blk_in_front = int(lda11,8)
1800 bip = begs_blr_first_offdiag
1801#if !defined(BLR_MT)
1802 IF (beg_i .NE. current_blr+1) THEN
1803 DO i = 1, beg_i - current_blr - 1
1804 IF (cbasm_tofix) THEN
1805 bip = bip + blr_panel(i)%N
1806 ELSE
1807 bip = bip + blr_panel(i)%M
1808 ENDIF
1809 ENDDO
1810 ENDIF
1811#endif
1812#if defined(BLR_MT)
1813 last_ip = current_blr+1
1814 chunk = 1
1815!$OMP DO PRIVATE(POSELT_BLOCK, M, N, K, I) SCHEDULE(DYNAMIC, CHUNK)
1816#endif
1817 DO ip = beg_i, end_i
1818#if defined(BLR_MT)
1819 DO i = 1, ip - last_ip
1820 IF (cbasm_tofix) THEN
1821 bip = bip + blr_panel(last_ip-current_blr+i-1)%N
1822 ELSE
1823 bip = bip + blr_panel(last_ip-current_blr+i-1)%M
1824 ENDIF
1825 ENDDO
1826 last_ip = ip
1827#endif
1828 IF (dir .eq. 'V') THEN
1829 IF (bip .LE. lda21) THEN
1830 IF (cbasm_tofix) THEN
1831 poselt_block = poselt
1832 & + int(lda11,8)*int(begs_blr_diag-1,8) + int(bip-1,8)
1833 ELSE
1834 poselt_block = poselt + int(lda11,8)*int(bip-1,8) +
1835 & int(begs_blr_diag - 1,8)
1836 ENDIF
1837 ELSE
1838 poselt_block = poselt + int(lda11,8)*int(lda21,8)+
1839 & int(begs_blr_diag - 1,8)
1840 poselt_block = poselt_block +
1841 & int(lda21,8)*int(bip-1-lda21,8)
1842 ld_blk_in_front=int(lda21,8)
1843 ENDIF
1844 ELSE
1845 poselt_block = poselt + int(lda11,8)*int(begs_blr_diag-1,8)
1846 & + int(bip-1,8)
1847 ENDIF
1848 m = blr_panel(ip-current_blr)%M
1849 n = blr_panel(ip-current_blr)%N
1850 IF(present(only_nelim_in)) THEN
1851 only_nelim = only_nelim_in
1852 ELSE
1853 only_nelim = n
1854 ENDIF
1855 k = blr_panel(ip-current_blr)%K
1856 IF (blr_panel(ip-current_blr)%ISLR) THEN
1857 IF (k.EQ.0) THEN
1858 IF (dir .eq. 'V') THEN
1859 DO i = 1, m
1860 IF (bip+i-1.GT.lda21) THEN
1861 ld_blk_in_front = int(lda21,8)
1862 ENDIF
1863 a(poselt_block+int(i-1,8)*ld_blk_in_front :
1864 & poselt_block+int(i-1,8)*ld_blk_in_front
1865 & + int(n-1,8)) = zero
1866 ENDDO
1867 ELSE
1868 DO i = n-only_nelim+1, n
1869 a(poselt_block+int(i-1,8)*int(lda11,8):
1870 & poselt_block+int(i-1,8)*int(lda11,8) + int(m-1,8))
1871 & = zero
1872 ENDDO
1873 ENDIF
1874 GOTO 1800
1875 ENDIF
1876 IF (dir .eq. 'V') THEN
1877 IF (dir .eq.'V' .AND. bip .LE. lda21
1878 & .AND. bip + m - 1 .GT. lda21
1879 & .AND..NOT.cbasm_tofix) THEN
1880 CALL dgemm('T', 'T', n, lda21-bip+1, k, one ,
1881 & blr_panel(ip-current_blr)%R(1,1) , k,
1882 & blr_panel(ip-current_blr)%Q(1,1) , m,
1883 & zero, a(poselt_block), int(ld_blk_in_front))
1884 CALL dgemm('T', 'T', n, bip+m-lda21-1, k, one ,
1885 & blr_panel(ip-current_blr)%R(1,1) , k,
1886 & blr_panel(ip-current_blr)%Q(lda21-bip+2,1) , m,
1887 & zero, a(poselt_block+int(lda21-bip,8)*int(lda11,8)),
1888 & lda21)
1889 ELSE
1890 CALL dgemm('T', 'T', n, m, k, one ,
1891 & blr_panel(ip-current_blr)%R(1,1) , k,
1892 & blr_panel(ip-current_blr)%Q(1,1) , m,
1893 & zero, a(poselt_block), int(ld_blk_in_front))
1894 ENDIF
1895 ELSE
1896 CALL dgemm('N', 'N', m, only_nelim, k, one,
1897 & blr_panel(ip-current_blr)%Q(1,1), m,
1898 & blr_panel(ip-current_blr)%R(1,n-only_nelim+1), k, zero,
1899 & a(poselt_block+int(n-only_nelim,8)*int(lda11,8)), lda11)
1900 ENDIF
1901 promote_cost = 2.0d0*m*k*only_nelim
1902 IF (cbasm_tofix) THEN
1903 CALL upd_flop_decompress(promote_cost, .true.)
1904 ELSEIF(present(only_nelim_in)) THEN
1905 CALL upd_flop_decompress(promote_cost, .false.)
1906 ENDIF
1907 ELSE IF (copy_dense_blocks) THEN
1908 IF (dir .eq. 'V') THEN
1909 DO i = 1, m
1910 IF (bip+i-1.GT.lda21) THEN
1911 ld_blk_in_front = int(lda21,8)
1912 ENDIF
1913 a(poselt_block+int(i-1,8)*ld_blk_in_front :
1914 & poselt_block+int(i-1,8)*ld_blk_in_front
1915 & + int(n-1,8))
1916 & = blr_panel(ip-current_blr)%Q(i,1:n)
1917 ENDDO
1918 ELSE
1919 DO i = n-only_nelim+1, n
1920 a(poselt_block+int(i-1,8)*int(lda11,8):
1921 & poselt_block+int(i-1,8)*int(lda11,8) + int(m-1,8))
1922 & = blr_panel(ip-current_blr)%Q(1:m,i)
1923 ENDDO
1924 ENDIF
1925 ENDIF
1926 1800 CONTINUE
1927#if !defined(BLR_MT)
1928 IF (cbasm_tofix) THEN
1929 bip = bip + blr_panel(ip-current_blr)%N
1930 ELSE
1931 bip = bip + blr_panel(ip-current_blr)%M
1932 ENDIF
1933#endif
1934 ENDDO
1935#if defined(BLR_MT)
1936!$OMP END DO
1937#endif
1938 END SUBROUTINE dmumps_decompress_panel
1939 SUBROUTINE dmumps_compress_cb(A, LA, POSELT, LDA,
1940 & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM,
1941 & NROWS, NCOLS, INODE,
1942 & IWHANDLER, SYM, NIV, IFLAG, IERROR,
1943 & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB,
1944 & WORK, TAU, JPVT, LWORK, RWORK, BLOCK,
1945 & MAXI_CLUSTER, KEEP8,
1946 & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP,
1947 & M_ARRAY,
1948 & NELIM,
1949 & NBROWSinF
1950 & )
1951!$ USE OMP_LIB
1952 INTEGER(8), intent(in) :: LA
1953 DOUBLE PRECISION, intent(inout) :: A(LA)
1954 INTEGER(8), intent(in) :: POSELT
1955 INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM
1956 INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER,
1957 & KPERCENT, TOL_OPT, LWORK
1958 INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM
1959 INTEGER, intent(inout) :: IFLAG, IERROR
1960 TYPE(lrb_type), TARGET, intent(inout) :: CB_LRB(:,:)
1961 INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U
1962 DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK
1963 DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK
1964 DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU
1965 INTEGER, TARGET, DIMENSION(:) :: JPVT
1966 INTEGER(8) :: KEEP8(150)
1967 DOUBLE PRECISION,intent(in) :: TOLEPS
1968 INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500)
1969 DOUBLE PRECISION, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1))
1970 INTEGER, intent(in), OPTIONAL :: NELIM
1971 INTEGER, intent(in), OPTIONAL :: NBROWSinF
1972 INTEGER :: M, N, INFO
1973 INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ
1974 INTEGER(8) :: POSELT_BLOCK
1975 LOGICAL :: ISLR
1976 TYPE(lrb_type), POINTER :: LRB
1977 INTEGER :: OMP_NUM
1978 INTEGER(8) :: POSA, ASIZE
1979 INTEGER :: NROWS_CM
1980#if defined(BLR_MT)
1981 INTEGER :: CHUNK
1982#endif
1983 DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR
1984 DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: BLOCK_THR
1985 DOUBLE PRECISION, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR
1986 INTEGER, POINTER, DIMENSION(:) :: JPVT_THR
1987 DOUBLE PRECISION :: ONE, MONE, ZERO
1988 parameter(one = 1.0d0, mone=-1.0d0)
1989 parameter(zero=0.0d0)
1990#if defined(BLR_MT)
1991!$OMP MASTER
1992#endif
1993 IF ( (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
1994 & (nfs4father.GT.0) ) THEN
1995 IF (niv.EQ.1) THEN
1996 nrows_cm = nrows - (nfs4father-nelim)
1997 ELSE
1998 nrows_cm = nrows - nbrowsinf
1999 ENDIF
2000 IF (nrows_cm-nvschur_k253.GT.0) THEN
2001 IF (niv.EQ.1) THEN
2002 posa = poselt
2003 & + int(lda,8)*int(npiv+nfs4father,8)
2004 & + int(npiv,8)
2005 asize = int(lda,8)*int(lda,8)
2006 & - int(lda,8)*int(npiv+nfs4father,8)
2007 & - int(npiv,8)
2008 ELSE
2009 posa = poselt
2010 & + int(lda,8)*int(nbrowsinf,8)
2011 & + int(npiv,8)
2012 asize = int(nrows,8)*int(lda,8)
2013 & - int(lda,8)*int(nbrowsinf,8)
2014 & - int(npiv,8)
2015 ENDIF
2016 CALL dmumps_compute_maxpercol (
2017 & a(posa), asize, lda,
2018 & nrows_cm-nvschur_k253,
2019 & m_array(1), nfs4father, .false.,
2020 & -9999)
2021 ELSE
2022 DO i=1, nfs4father
2023 m_array(i) = zero
2024 ENDDO
2025 ENDIF
2026 ENDIF
2027#if defined(blr_mt)
2028!$OMP END MASTER
2029!$OMP BARRIER
2030#endif
2031 omp_num = 0
2032 IF (sym.EQ.0.OR.niv.EQ.2) THEN
2033 ibis_end = nb_rows*nb_cols
2034 ELSE
2035 ibis_end = nb_rows*(nb_cols+1)/2
2036 ENDIF
2037#if defined(BLR_MT)
2038 chunk = 1
2039!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
2040!$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK,
2041!$OMP& MAXRANK, ISLR, II, JJ, LRB)
2042#endif
2043 DO ibis = 1,ibis_end
2044 IF (iflag.LT.0) cycle
2045#if defined(BLR_MT)
2046 omp_num = 0
2047!$ OMP_NUM = OMP_GET_THREAD_NUM()
2048#endif
2049 block_thr => block(1:maxi_cluster,omp_num*maxi_cluster+1:
2050 & (omp_num+1)*maxi_cluster)
2051 jpvt_thr => jpvt(omp_num*maxi_cluster+1:
2052 & (omp_num+1)*maxi_cluster)
2053 tau_thr => tau(omp_num*maxi_cluster+1:
2054 & (omp_num+1)*maxi_cluster)
2055 work_thr => work(omp_num*lwork+1:
2056 & (omp_num+1)*lwork)
2057 rwork_thr => rwork(omp_num*2*maxi_cluster+1:
2058 & (omp_num+1)*2*maxi_cluster)
2059 IF (sym.EQ.0.OR.niv.EQ.2) THEN
2060 i = (ibis-1)/nb_cols+1
2061 j = ibis - (i-1)*nb_cols
2062 ELSE
2063 i = ceiling((1.0d0+sqrt(1.0d0+8.0d0*dble(ibis)))/2.0d0)-1
2064 j = ibis - i*(i-1)/2
2065 ENDIF
2066 IF (niv.EQ.1) THEN
2067 i = i+nb_inasm
2068 j = j+nb_inasm
2069 ELSE
2070 j = j+nb_inasm
2071 IF (sym.NE.0) THEN
2072 IF (begs_blr_u(j).GE.begs_blr(i+2)+ncols-nrows-1+
2073 & begs_blr_u(nb_inasm+1)) THEN
2074 cycle
2075 ENDIF
2076 ENDIF
2077 ENDIF
2078 IF (niv.EQ.1) THEN
2079 m = begs_blr(i+1)-begs_blr(i)
2080 poselt_block = poselt + int(lda,8)*int(begs_blr(i)-1,8) +
2081 & int(begs_blr_u(j)-1,8)
2082 IF (i .EQ. nb_inasm+1 .AND. present(nelim)) THEN
2083 poselt_block = poselt_block + int(nelim,8)*int(lda,8)
2084 m = m - nelim
2085 ENDIF
2086 n = begs_blr_u(j+1)-begs_blr_u(j)
2087 ELSE
2088 m = begs_blr(i+2)-begs_blr(i+1)
2089 poselt_block = poselt + int(lda,8)*int(begs_blr(i+1)-1,8)
2090 & + int(begs_blr_u(j)-1,8)
2091 IF (sym.EQ.0) THEN
2092 n = begs_blr_u(j+1)-begs_blr_u(j)
2093 ELSE
2094 n = min(begs_blr_u(j+1), begs_blr(i+2) + ncols - nrows -1
2095 & + begs_blr_u(nb_inasm+1)) - begs_blr_u(j)
2096 ENDIF
2097 ENDIF
2098 jpvt_thr(1:maxi_cluster) = 0
2099 IF (niv.EQ.1) THEN
2100 lrb => cb_lrb(i-nb_inasm,j-nb_inasm)
2101 ELSE
2102 lrb => cb_lrb(i,j-nb_inasm)
2103 ENDIF
2104 IF (k489.EQ.3) THEN
2105 maxrank = 1
2106 rank = maxrank+1
2107 info = 0
2108 islr = .false.
2109 GOTO 3800
2110 ENDIF
2111 DO ii=1,m
2112 block_thr(ii,1:n)=
2113 & a( poselt_block+int(ii-1,8)*int(lda,8) :
2114 & poselt_block+int(ii-1,8)*int(lda,8)+int(n-1,8) )
2115 ENDDO
2116 maxrank = floor(dble(m*n)/dble(m+n))
2117 maxrank = max(1, int((maxrank*kpercent/100)))
2118 CALL dmumps_truncated_rrqr( m, n,
2119 & block_thr(1,1),
2120 & maxi_cluster, jpvt_thr(1),
2121 & tau_thr(1),
2122 & work_thr(1), n,
2123 & rwork_thr(1),
2124 & toleps, tol_opt, rank, maxrank, info,
2125 & islr)
2126 3800 CONTINUE
2127 IF (info < 0) THEN
2128 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",info,
2129 & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK"
2130 CALL mumps_abort()
2131 END IF
2132 CALL alloc_lrb(lrb, rank, m, n, islr, iflag, ierror, keep8)
2133 IF (iflag.LT.0) cycle
2134 IF (islr) THEN
2135 IF (rank .GT. 0) THEN
2136 DO jj=1,n
2137 DO ii=1,min(rank,jj)
2138 lrb%R(ii,jpvt_thr(jj)) = block_thr(ii,jj)
2139 ENDDO
2140 IF(jj.LT.rank) lrb%R(min(rank,jj)+1:rank,jpvt_thr(jj))
2141 & = zero
2142 ENDDO
2143 CALL dorgqr
2144 & (m, rank, rank,
2145 & block_thr(1,1),
2146 & maxi_cluster, tau_thr(1),
2147 & work_thr(1), lwork, info )
2148 DO ii=1,rank
2149 DO jj= 1, m
2150 lrb%Q(jj,ii) = block_thr(jj,ii)
2151 ENDDO
2152 END DO
2153 IF (info < 0) THEN
2154 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",info,
2155 & " OF CUNGQR WHILE COMPRESSING A CB BLOCK"
2156 CALL mumps_abort()
2157 END IF
2158 IF (k489.NE.3) THEN
2159 CALL upd_flop_compress(lrb, cb_compress=.true.)
2160 ENDIF
2161 END IF
2162 CALL upd_mry_cb_lrgain(lrb
2163 & )
2164 ELSE
2165 DO ii=1,m
2166 lrb%Q(ii,1:n) =
2167 & a( poselt_block+int((ii-1),8)*int(lda,8) :
2168 & poselt_block+int((ii-1),8)*int(lda,8)
2169 & +int(n-1,8) )
2170 END DO
2171 IF (k489.NE.3) THEN
2172 CALL upd_flop_compress(lrb, cb_compress=.true.)
2173 ENDIF
2174 lrb%K = -1
2175 END IF
2176 END DO
2177#if defined(BLR_MT)
2178!$omp END DO
2179#endif
2180#if defined(BLR_MT)
2181!$OMP MASTER
2182#endif
2183 CALL upd_mry_cb_fr(nrows, ncols, sym)
2184#if defined(BLR_MT)
2185!$OMP END MASTER
2186#endif
2187 END SUBROUTINE dmumps_compress_cb
2188 SUBROUTINE dmumps_compress_panel(
2189 & A, LA, POSELT, IFLAG, IERROR, NFRONT,
2190 & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL,
2191 & CURRENT_BLR,
2192 & DIR, WORK, TAU, JPVT,
2193 & LWORK, RWORK, BLOCK,
2194 & MAXI_CLUSTER, NELIM,
2195 & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT,
2196 & KEEP8,
2197 & K480, BEG_I_IN, END_I_IN, FRSWAP
2198 & )
2199!$ USE OMP_LIB
2200 INTEGER(8), intent(in) :: LA
2201 DOUBLE PRECISION, intent(inout) :: A(LA)
2202 INTEGER(8), intent(in) :: POSELT
2203 INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV
2204 INTEGER, intent(inout) :: IFLAG, IERROR
2205 TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:)
2206 DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK
2207 DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK
2208 DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU
2209 INTEGER, TARGET, DIMENSION(:) :: JPVT
2210 INTEGER :: BEGS_BLR(:)
2211 INTEGER(8) :: KEEP8(150)
2212 INTEGER, OPTIONAL, intent(in) :: K480
2213 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN
2214 LOGICAL, OPTIONAL, intent(in) :: FRSWAP
2215 INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473,
2216 & tol_opt
2217 LOGICAL, intent(in) :: LBANDSLAVE
2218 INTEGER :: MAXI_CLUSTER, LWORK, NELIM
2219 DOUBLE PRECISION,intent(in) :: TOLEPS
2220 CHARACTER(len=1) :: DIR
2221 INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK
2222 INTEGER :: INFO, I, J, IS, BEG_I, END_I
2223 INTEGER(8) :: POSELT_BLOCK
2224 LOGICAL :: ISLR
2225 DOUBLE PRECISION :: ONE, ALPHA, ZERO
2226 PARAMETER (ONE = 1.0d0, alpha=-1.0d0)
2227 parameter(zero = 0.0d0)
2228 INTEGER :: OMP_NUM
2229 DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR
2230 DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: BLOCK_THR
2231 DOUBLE PRECISION, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR
2232 INTEGER, POINTER, DIMENSION(:) :: JPVT_THR
2233#if defined(BLR_MT)
2234 INTEGER :: CHUNK
2235#endif
2236 IF(present(beg_i_in)) THEN
2237 beg_i = beg_i_in
2238 ELSE
2239 beg_i = current_blr+1
2240 ENDIF
2241 IF(present(end_i_in)) THEN
2242 end_i = end_i_in
2243 ELSE
2244 end_i = nb_blr
2245 ENDIF
2246 IF (lbandslave) THEN
2247 is = ishift
2248 ELSE
2249 is=0
2250 ENDIF
2251 IF (dir .eq. 'V') THEN
2252 IF (lbandslave) THEN
2253 n = npiv
2254 ELSE
2255 n = begs_blr(current_blr+1)-begs_blr(current_blr)-nelim
2256 ENDIF
2257 ELSE IF (dir .eq. 'H') THEN
2258 n = begs_blr(current_blr+1)-begs_blr(current_blr)-nelim
2259 ELSE
2260 WRITE(*,*) " WRONG ARGUMENT IN DMUMPS_COMPRESS_PANEL "
2261 CALL mumps_abort()
2262 END IF
2263 nb_blocks_panel = nb_blr-current_blr
2264 omp_num = 0
2265#if defined(BLR_MT)
2266 chunk = 1
2267!$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM)
2268!$OMP& SCHEDULE(DYNAMIC,CHUNK)
2269#endif
2270 DO ip = beg_i, end_i
2271 IF (iflag.LT.0) cycle
2272#if defined(BLR_MT)
2273 omp_num = 0
2274!$ OMP_NUM = OMP_GET_THREAD_NUM()
2275#endif
2276 block_thr => block(1:maxi_cluster,omp_num*maxi_cluster+1:
2277 & (omp_num+1)*maxi_cluster)
2278 jpvt_thr => jpvt(omp_num*maxi_cluster+1:
2279 & (omp_num+1)*maxi_cluster)
2280 tau_thr => tau(omp_num*maxi_cluster+1:
2281 & (omp_num+1)*maxi_cluster)
2282 work_thr => work(omp_num*lwork+1:
2283 & (omp_num+1)*lwork)
2284 rwork_thr => rwork(omp_num*2*maxi_cluster+1:
2285 & (omp_num+1)*2*maxi_cluster)
2286 rank = 0
2287 m = begs_blr(ip+1)-begs_blr(ip)
2288 IF (dir .eq. 'V') THEN
2289 poselt_block = poselt +
2290 & int(nfront,8) * int(begs_blr(ip)-1,8) +
2291 & int(begs_blr(current_blr) + is - 1,8)
2292 ELSE
2293 poselt_block = poselt +
2294 & int(nfront,8)*int(begs_blr(current_blr)-1,8) +
2295 & int( begs_blr(ip) - 1,8)
2296 ENDIF
2297 IF (present(k480)) then
2298 IF (k480.GE.5) THEN
2299 IF (blr_panel(ip-current_blr)%ISLR) THEN
2300 IF (m.NE.blr_panel(ip-current_blr)%M) THEN
2301 write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL',
2302 & ' M size inconsistency',m,
2303 & blr_panel(ip-current_blr)%M
2304 CALL mumps_abort()
2305 ENDIF
2306 IF (n.NE.blr_panel(ip-current_blr)%N) THEN
2307 write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL',
2308 & ' N size inconsistency',n,
2309 & blr_panel(ip-current_blr)%N
2310 CALL mumps_abort()
2311 ENDIF
2312 maxrank = floor(dble(m*n)/dble(m+n))
2313 IF (blr_panel(ip-current_blr)%K.GT.maxrank) THEN
2314 write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL',
2315 & ' MAXRANK inconsistency',maxrank,
2316 & blr_panel(ip-current_blr)%K
2317 CALL mumps_abort()
2318 ENDIF
2319 GOTO 3000
2320 ENDIF
2321 ENDIF
2322 ENDIF
2323 jpvt_thr(1:maxi_cluster) = 0
2324 IF (k473.EQ.1) THEN
2325 maxrank = 1
2326 rank = maxrank+1
2327 info = 0
2328 islr = .false.
2329 GOTO 3800
2330 ENDIF
2331 IF (dir .eq. 'v') THEN
2332 DO I=1,M
2333 BLOCK_THR(I,1:N)=
2334 & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) :
2335 & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) )
2336 END DO
2337 ELSE
2338 DO I=1,N
2339 BLOCK_THR(1:M,I)=
2340 & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) :
2341 & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) )
2342 END DO
2343 END IF
2344 MAXRANK = floor(dble(M*N)/dble(M+N))
2345 MAXRANK = max (1, int((MAXRANK*KPERCENT/100)))
2346 CALL DMUMPS_TRUNCATED_RRQR( M, N,
2347 & BLOCK_THR(1,1),
2348 & MAXI_CLUSTER, JPVT_THR(1),
2349 & TAU_THR(1),
2350 & WORK_THR(1), N,
2351 & RWORK_THR(1),
2352 & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO,
2353 & ISLR)
2354 3800 CONTINUE
2355 IF (INFO < 0) THEN
2356 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO,
2357 & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK "
2358 CALL MUMPS_ABORT()
2359 END IF
2360 CALL ALLOC_LRB(BLR_PANEL(IP-CURRENT_BLR), RANK,
2361 & M, N, ISLR, IFLAG, IERROR, KEEP8)
2362.LT. IF (IFLAG0) CYCLE
2363.EQ..OR..EQ. IF ((M0)(N0)) THEN
2364 GOTO 3000
2365 ENDIF
2366 IF (ISLR) THEN
2367.EQ. IF (RANK 0) THEN
2368 ELSE
2369 DO J=1,N
2370 BLR_PANEL(IP-CURRENT_BLR)%R(1:MIN(RANK,J),
2371 & JPVT_THR(J)) =
2372 & BLOCK_THR(1:MIN(RANK,J),J)
2373.LT. IF(JRANK) BLR_PANEL(IP-CURRENT_BLR)%
2374 & R(MIN(RANK,J)+1:RANK,JPVT_THR(J))= ZERO
2375 ENDDO
2376 CALL dorgqr
2377 & (M, RANK, RANK,
2378 & BLOCK_THR(1,1),
2379 & MAXI_CLUSTER, TAU_THR(1),
2380 & WORK_THR(1), LWORK, INFO )
2381 DO I=1,RANK
2382 BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = BLOCK_THR(1:M,I)
2383 END DO
2384 IF (INFO < 0) THEN
2385 WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO,
2386 & " OF CUNGQR WHILE COMPRESSING A BLOCK "
2387 CALL MUMPS_ABORT()
2388 END IF
2389 IF (present(FRSWAP)) THEN
2390 CALL UPD_FLOP_COMPRESS(
2391 & BLR_PANEL(IP-CURRENT_BLR), FRSWAP=FRSWAP)
2392 ELSE
2393 CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR))
2394 ENDIF
2395 END IF
2396 ELSE
2397.eq. IF (DIR 'v') THEN
2398 DO I=1,M
2399 BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) =
2400 & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) :
2401 & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8)
2402 & +int(N-1,8) )
2403 END DO
2404 ELSE
2405 DO I=1,N
2406 BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) =
2407 & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) :
2408 & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8)
2409 & +int(M-1,8) )
2410 END DO
2411 END IF
2412.EQ. IF (K4730) THEN
2413 IF (present(FRSWAP)) THEN
2414 CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR),
2415 & FRSWAP=FRSWAP)
2416 ELSE
2417 CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR))
2418 ENDIF
2419 ENDIF
2420 BLR_PANEL(IP-CURRENT_BLR)%K = -1
2421 END IF
2422 3000 CONTINUE
2423 END DO
2424#if defined(BLR_MT)
2425!$OMP END DO NOWAIT
2426#endif
2427 RETURN
2428 END SUBROUTINE DMUMPS_COMPRESS_PANEL
2429 SUBROUTINE DMUMPS_BLR_PANEL_LRTRSM(
2430 & A,
2431 & LA, POSELT, NFRONT,
2432 & IBEG_BLOCK, NB_BLR,
2433 & BLR_LorU,
2434 & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK,
2435 & NIV, SYM, LorU, LBANDSLAVE,
2436 & IW, OFFSET_IW, NASS)
2437!$ USE OMP_LIB
2438 INTEGER(8), intent(in) :: LA
2439 INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR,
2440 & NIV, SYM, LorU
2441 LOGICAL, intent(in) :: LBANDSLAVE
2442 INTEGER(8), intent(in) :: POSELT
2443 INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK
2444 INTEGER, OPTIONAL, intent(in) :: NASS
2445 DOUBLE PRECISION, intent(inout) :: A(LA)
2446 TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:)
2447 INTEGER, OPTIONAL :: OFFSET_IW
2448 INTEGER, OPTIONAL :: IW(*)
2449 INTEGER(8) :: POSELT_LOCAL
2450 INTEGER :: IP, LDA
2451#if defined(BLR_MT)
2452 INTEGER :: CHUNK
2453#endif
2454 DOUBLE PRECISION :: ONE, MONE, ZERO
2455 PARAMETER (ONE = 1.0D0, MONE=-1.0D0)
2456 PARAMETER (ZERO=0.0D0)
2457 LDA = NFRONT
2458.EQ..AND..NE..AND..EQ. IF (LorU0SYM0NIV2
2459.AND..NOT. & (LBANDSLAVE)) THEN
2460 IF (present(NASS)) THEN
2461 LDA = NASS
2462 ELSE
2463 write(*,*) 'internal error in dmumps_blr_panel_lrtrsm'
2464 CALL MUMPS_ABORT()
2465 ENDIF
2466 ENDIF
2467 IF (LBANDSLAVE) THEN
2468 POSELT_LOCAL = POSELT
2469 ELSE
2470 POSELT_LOCAL = POSELT +
2471 & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8)
2472 ENDIF
2473#if defined(BLR_MT)
2474 CHUNK = 1
2475!$OMP DO
2476!$OMP& SCHEDULE(DYNAMIC,CHUNK)
2477#endif
2478 DO IP = FIRST_BLOCK, LAST_BLOCK
2479 CALL DMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA,
2480 & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU,
2481 & IW, OFFSET_IW)
2482 END DO
2483#if defined(BLR_MT)
2484!$OMP END DO NOWAIT
2485#endif
2486 END SUBROUTINE DMUMPS_BLR_PANEL_LRTRSM
2487 END MODULE DMUMPS_FAC_LR
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
dmumps_truncated_rrqr
subroutine dmumps_truncated_rrqr(m, n, a, lda, jpvt, tau, work, ldw, rwork, toleps, tol_opt, rank, maxrank, info, islr)
Definition dlr_core.F:1611
dmumps_compute_maxpercol
subroutine dmumps_compute_maxpercol(a, asize, ncol, nrow, m_array, nmax, packed_cb, lrow1)
Definition dtools.F:1643
alpha
#define alpha
Definition eval.h:35
dorgqr
subroutine dorgqr(m, n, k, a, lda, tau, work, lwork, info)
DORGQR
Definition dorgqr.f:128
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
dmumps_fac_lr
Definition dfac_lr.F:14
dmumps_fac_lr::dmumps_blr_upd_nelim_var_u
subroutine dmumps_blr_upd_nelim_var_u(a, la, poselt, iflag, ierror, nfront, begs_blr, current_blr, blr_u, nb_blr, first_block, ibeg_blr, npiv, nelim)
Definition dfac_lr.F:200
dmumps_fac_lr::dmumps_blr_upd_cb_left_ldlt
subroutine dmumps_blr_upd_cb_left_ldlt(a, la, poselt, nfront, begs_blr, begs_blr_dyn, nb_incb, nb_inasm, nass, iwhandler, iw2, block, acc_lua, maxi_cluster, maxi_rank, niv, iflag, ierror, midblk_compress, toleps, tol_opt, kpercent_rmb, k480, k479, k478, kpercent_lua, kpercent, keep8)
Definition dfac_lr.F:1130
dmumps_fac_lr::dmumps_blr_update_trailing
subroutine dmumps_blr_update_trailing(a, la, poselt, iflag, ierror, nfront, begs_blr_l, begs_blr_u, current_blr, blr_l, nb_blr_l, blr_u, nb_blr_u, nelim, lbandslave, ishift, niv, sym, midblk_compress, toleps, tol_opt, kpercent)
Definition dfac_lr.F:325
dmumps_fac_lr::dmumps_blr_upd_panel_left
subroutine dmumps_blr_upd_panel_left(a, la, poselt, nfront, iwhandler, loru, begs_blr, begs_blr_u, current_blr, acc_lua, nb_blr, npartsass, nelim, niv, sym, lbandslave, iflag, ierror, ishift, midblk_compress, toleps, tol_opt, kpercent_rmb, k480, k479, k478, kpercent_lua, kpercent, maxi_cluster, maxi_rank, k474, fsorcb, blr_u_col, keep8, first_block, beg_i_in, end_i_in)
Definition dfac_lr.F:763
dmumps_fac_lr::dmumps_blr_panel_lrtrsm
subroutine dmumps_blr_panel_lrtrsm(a, la, poselt, nfront, ibeg_block, nb_blr, blr_loru, current_blr, first_block, last_block, niv, sym, loru, lbandslave, iw, offset_iw, nass)
Definition dfac_lr.F:2437
dmumps_fac_lr::dmumps_blr_upd_panel_left_ldlt
subroutine dmumps_blr_upd_panel_left_ldlt(a, la, poselt, nfront, iwhandler, begs_blr, current_blr, nb_blr, npartsass, nelim, iw2, block, acc_lua, maxi_cluster, maxi_rank, niv, iflag, ierror, midblk_compress, toleps, tol_opt, kpercent_rmb, k480, k479, k478, kpercent_lua, kpercent, keep8, first_block)
Definition dfac_lr.F:447
dmumps_fac_lr::dmumps_decompress_panel
subroutine dmumps_decompress_panel(a, la, poselt, lda11, lda21, copy_dense_blocks, begs_blr_diag, begs_blr_first_offdiag, nb_blr, blr_panel, current_blr, dir, decomp_timer, beg_i_in, end_i_in, only_nelim_in, cbasm_tofix_in)
Definition dfac_lr.F:1754
dmumps_fac_lr::dmumps_blr_upd_cb_left
subroutine dmumps_blr_upd_cb_left(a, la, poselt, nfront, begs_blr, begs_blr_u, nb_rows, nb_incb, nb_inasm, nass, iwhandler, niv, lbandslave, iflag, ierror, midblk_compress, toleps, tol_opt, kpercent_rmb, acc_lua, k480, k479, k478, kpercent_lua, kpercent, maxi_cluster, maxi_rank, k474, fsorcb, blr_u_col, compress_cb, cb_lrb, keep8)
Definition dfac_lr.F:1428
dmumps_fac_lr::dmumps_compress_cb
subroutine dmumps_compress_cb(a, la, poselt, lda, begs_blr, begs_blr_u, nb_rows, nb_cols, nb_inasm, nrows, ncols, inode, iwhandler, sym, niv, iflag, ierror, toleps, tol_opt, kpercent, k489, cb_lrb, work, tau, jpvt, lwork, rwork, block, maxi_cluster, keep8, nfs4father, npiv, nvschur_k253, keep, m_array, nelim, nbrowsinf)
Definition dfac_lr.F:1951
dmumps_fac_lr::dmumps_blr_update_trailing_ldlt
subroutine dmumps_blr_update_trailing_ldlt(a, la, poselt, iflag, ierror, nfront, begs_blr, nb_blr, current_blr, blr_l, nelim, iw2, block, maxi_cluster, npiv, niv, midblk_compress, toleps, tol_opt, kpercent)
Definition dfac_lr.F:24
dmumps_fac_lr::dmumps_blr_upd_nelim_var_l
subroutine dmumps_blr_upd_nelim_var_l(a_u, la_u, upos, a_l, la_l, lpos, iflag, ierror, ldu, ldl, begs_blr_l, current_blr, blr_l, nb_blr_l, first_block, nelim, utrans)
Definition dfac_lr.F:259
dmumps_fac_lr::dmumps_compress_panel
subroutine dmumps_compress_panel(a, la, poselt, iflag, ierror, nfront, begs_blr, nb_blr, toleps, tol_opt, k473, blr_panel, current_blr, dir, work, tau, jpvt, lwork, rwork, block, maxi_cluster, nelim, lbandslave, npiv, ishift, niv, kpercent, keep8, k480, beg_i_in, end_i_in, frswap)
Definition dfac_lr.F:2199
dmumps_fac_lr::dmumps_blr_slv_upd_trail_ldlt
subroutine dmumps_blr_slv_upd_trail_ldlt(a, la, poselt, iflag, ierror, ncol, nrow, a_blocfacto, la_blocfacto, ld_blocfacto, begs_blr_lm, nb_blr_lm, blr_lm, ishift_lm, begs_blr_ls, nb_blr_ls, blr_ls, ishift_ls, current_blr_lm, current_blr_ls, iw2, block, maxi_cluster, midblk_compress, toleps, tol_opt, kpercent)
Definition dfac_lr.F:96
dmumps_lr_core
Definition dlr_core.F:18
dmumps_lr_core::dmumps_get_lua_order
subroutine dmumps_get_lua_order(nb_blocks, order, rank, iwhandler, sym, fs_or_cb, i, j, frfr_updates, lbandslave_in, k474, blr_u_col)
Definition dlr_core.F:1318
dmumps_lr_core::dmumps_decompress_acc
subroutine dmumps_decompress_acc(acc_lrb, maxi_cluster, maxi_rank, a, la, poseltt, nfront, niv, loru, count_flops)
Definition dlr_core.F:763
dmumps_lr_core::dmumps_lrgemm4
subroutine dmumps_lrgemm4(alpha, lrb1, lrb2, beta, a, la, poseltt, nfront, sym, iflag, ierror, midblk_compress, toleps, tol_opt, kpercent, rank, buildq, lua_activated, loru, lrb3, maxi_rank, maxi_cluster, diag, ld_diag, iw2, block)
Definition dlr_core.F:406
dmumps_lr_core::dmumps_recompress_acc_narytree
recursive subroutine dmumps_recompress_acc_narytree(acc_lrb, maxi_cluster, maxi_rank, a, la, poseltt, keep8, nfront, niv, midblk_compress, toleps, tol_opt, kpercent_rmb, kpercent_lua, k478, rank_list, pos_list, nb_nodes, level, acc_tmp)
Definition dlr_core.F:1053
dmumps_lr_core::alloc_lrb
subroutine alloc_lrb(lrb_out, k, m, n, islr, iflag, ierror, keep8)
Definition dlr_core.F:111
dmumps_lr_core::dmumps_compress_fr_updates
subroutine dmumps_compress_fr_updates(acc_lrb, maxi_cluster, maxi_rank, a, la, poseltt, nfront, niv, toleps, tol_opt, kpercent, buildq, loru, cb_compress)
Definition dlr_core.F:788
dmumps_lr_core::dmumps_recompress_acc
subroutine dmumps_recompress_acc(acc_lrb, maxi_cluster, maxi_rank, a, la, poseltt, nfront, niv, midblk_compress, toleps, tol_opt, kpercent_rmb, kpercent_lua, new_acc_rank)
Definition dlr_core.F:868
dmumps_lr_core::alloc_lrb_from_acc
subroutine alloc_lrb_from_acc(acc_lrb, lrb_out, k, m, n, loru, iflag, ierror, keep8)
Definition dlr_core.F:160