OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
smumps_fac_lr Module Reference

Functions/Subroutines

subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)
subroutine smumps_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)

Function/Subroutine Documentation

◆ smumps_blr_panel_lrtrsm()

subroutine smumps_fac_lr::smumps_blr_panel_lrtrsm ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(in) nfront,
integer, intent(in) ibeg_block,
integer, intent(in) nb_blr,
type(lrb_type), dimension(:), intent(inout) blr_loru,
integer, intent(in) current_blr,
integer, intent(in) first_block,
integer, intent(in) last_block,
integer, intent(in) niv,
integer, intent(in) sym,
integer, intent(in) loru,
logical, intent(in) lbandslave,
integer, dimension(*), optional iw,
integer, optional offset_iw,
integer, intent(in), optional nass )

Definition at line 2429 of file sfac_lr.F.

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 REAL, 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 REAL :: ONE, MONE, ZERO
2455 parameter(one = 1.0e0, mone=-1.0e0)
2456 parameter(zero=0.0e0)
2457 lda = nfront
2458 IF (loru.EQ.0.AND.sym.NE.0.AND.niv.EQ.2
2459 & .AND.(.NOT.lbandslave)) THEN
2460 IF (present(nass)) THEN
2461 lda = nass
2462 ELSE
2463 write(*,*) 'Internal error in SMUMPS_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 smumps_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
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25

◆ smumps_blr_slv_upd_trail_ldlt()

subroutine smumps_fac_lr::smumps_blr_slv_upd_trail_ldlt ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) ncol,
integer, intent(in) nrow,
real, dimension(la_blocfacto), intent(in) a_blocfacto,
integer(8), intent(in) la_blocfacto,
integer, intent(in) ld_blocfacto,
integer, dimension(:) begs_blr_lm,
integer, intent(in) nb_blr_lm,
type(lrb_type), dimension(nb_blr_lm-current_blr_lm), intent(in) blr_lm,
integer, intent(in) ishift_lm,
integer, dimension(:) begs_blr_ls,
integer, intent(in) nb_blr_ls,
type(lrb_type), dimension(nb_blr_ls-current_blr_ls), intent(in) blr_ls,
integer, intent(in) ishift_ls,
integer, intent(in) current_blr_lm,
integer, intent(in) current_blr_ls,
integer, dimension(*), intent(in) iw2,
real, dimension(maxi_cluster,*), intent(inout) block,
integer, intent(in) maxi_cluster,
integer, intent(in) midblk_compress,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent )

Definition at line 86 of file sfac_lr.F.

96!$ USE OMP_LIB
97 INTEGER(8), intent(in) :: LA, LA_BLOCFACTO
98 REAL, intent(inout) :: A(LA)
99 REAL, 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 REAL, 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 REAL,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 REAL :: ONE, MONE, ZERO
122 parameter(one = 1.0e0, mone=-1.0e0)
123 parameter(zero=0.0e0)
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 smumps_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 smumps_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

◆ smumps_blr_upd_cb_left()

subroutine smumps_fac_lr::smumps_blr_upd_cb_left ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(in) nfront,
integer, dimension(:) begs_blr,
integer, dimension(:) begs_blr_u,
integer, intent(in) nb_rows,
integer, intent(in) nb_incb,
integer, intent(in) nb_inasm,
integer, intent(in) nass,
integer, intent(in) iwhandler,
integer, intent(in) niv,
logical, intent(in) lbandslave,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) midblk_compress,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent_rmb,
type(lrb_type), dimension(:), pointer acc_lua,
integer, intent(in) k480,
integer, intent(in) k479,
integer, intent(in) k478,
integer, intent(in) kpercent_lua,
integer, intent(in) kpercent,
integer, intent(in) maxi_cluster,
integer, intent(in) maxi_rank,
integer, intent(in) k474,
integer, intent(in) fsorcb,
type(lrb_type), dimension(:), pointer blr_u_col,
logical, intent(in) compress_cb,
type(lrb_type), dimension(:,:), pointer cb_lrb,
integer(8), dimension(150) keep8 )

Definition at line 1420 of file sfac_lr.F.

1428!$ USE OMP_LIB
1429 INTEGER(8), intent(in) :: LA
1430 REAL, 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 REAL,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 REAL :: ONE, MONE, ZERO
1465 parameter(one = 1.0e0, mone=-1.0e0)
1466 parameter(zero=0.0e0)
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 SMUMPS_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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(real(acc_lrb%M*acc_lrb%N)/real(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 smumps_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 smumps_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 smumps_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 smumps_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
max
#define max(a, b)
Definition macros.h:21

◆ smumps_blr_upd_cb_left_ldlt()

subroutine smumps_fac_lr::smumps_blr_upd_cb_left_ldlt ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(in) nfront,
integer, dimension(:) begs_blr,
integer, dimension(:) begs_blr_dyn,
integer, intent(in) nb_incb,
integer, intent(in) nb_inasm,
integer, intent(in) nass,
integer, intent(in) iwhandler,
integer, dimension(*), intent(in) iw2,
real, dimension(maxi_cluster,*), intent(inout) block,
type(lrb_type), dimension(:), pointer acc_lua,
integer, intent(in) maxi_cluster,
integer, intent(in) maxi_rank,
integer, intent(in) niv,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) midblk_compress,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent_rmb,
integer, intent(in) k480,
integer, intent(in) k479,
integer, intent(in) k478,
integer, intent(in) kpercent_lua,
integer, intent(in) kpercent,
integer(8), dimension(150) keep8 )

Definition at line 1123 of file sfac_lr.F.

1130!$ USE OMP_LIB
1131 INTEGER(8), intent(in) :: LA
1132 REAL, 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 REAL, 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 REAL,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 REAL :: ONE, MONE, ZERO
1163 parameter(one = 1.0e0, mone=-1.0e0)
1164 parameter(zero=0.0e0)
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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 & 'SMUMPS_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 smumps_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 & 'SMUMPS_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 & 'SMUMPS_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 smumps_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(real(acc_lrb%M*acc_lrb%N)/real(acc_lrb%M+
1373 & acc_lrb%N))
1374 IF (compressed_fr.AND.(acc_lrb%K.LE.maxrank)) THEN
1375 CALL smumps_decompress_acc(acc_lrb,maxi_cluster,
1376 & maxi_rank, a, la, poselt_block, nfront, niv, 2,
1377 & count_flops=.false.)
1378 ELSE
1379 CALL smumps_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 smumps_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 smumps_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 smumps_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

◆ smumps_blr_upd_nelim_var_l()

subroutine smumps_fac_lr::smumps_blr_upd_nelim_var_l ( real, dimension(la_u), intent(inout), target a_u,
integer(8), intent(in) la_u,
integer(8), intent(in) upos,
real, dimension(la_l), intent(inout), target a_l,
integer(8), intent(in) la_l,
integer(8), intent(in) lpos,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) ldu,
integer, intent(in) ldl,
integer, dimension(:) begs_blr_l,
integer, intent(in) current_blr,
type(lrb_type), dimension(:), intent(in) blr_l,
integer, intent(in) nb_blr_l,
integer, intent(in) first_block,
integer, intent(in) nelim,
character(len=1), intent(in) utrans )

Definition at line 255 of file sfac_lr.F.

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 REAL, 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 REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
273 REAL :: ONE, MONE, ZERO
274 parameter(one = 1.0e0, mone=-1.0e0)
275 parameter(zero=0.0e0)
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 & SMUMPS_BLR_UPD_NELIM_VAR_L: ',
296 & 'not enough memory? memory requested = ', ierror
297 GOTO 100
298 ENDIF
299 CALL sgemm(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 sgemm('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 sgemm(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
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187
nl
character *2 function nl()
Definition message.F:2354

◆ smumps_blr_upd_nelim_var_u()

subroutine smumps_fac_lr::smumps_blr_upd_nelim_var_u ( real, dimension(la), intent(inout), target a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) nfront,
integer, dimension(:) begs_blr,
integer, intent(in) current_blr,
type(lrb_type), dimension(:), intent(in), target blr_u,
integer, intent(in) nb_blr,
integer, intent(in) first_block,
integer, intent(in) ibeg_blr,
integer, intent(in) npiv,
integer, intent(in) nelim )

Definition at line 196 of file sfac_lr.F.

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 REAL, 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 REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
214 REAL :: ONE, MONE, ZERO
215 parameter(one = 1.0e0, mone=-1.0e0)
216 parameter(zero=0.0e0)
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 sgemm('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 sgemm('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 sgemm('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

◆ smumps_blr_upd_panel_left()

subroutine smumps_fac_lr::smumps_blr_upd_panel_left ( real, dimension(la), intent(inout), target a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(in) nfront,
integer, intent(in) iwhandler,
integer, intent(in) loru,
integer, dimension(:) begs_blr,
integer, dimension(:) begs_blr_u,
integer, intent(in) current_blr,
type(lrb_type), dimension(:), pointer acc_lua,
integer, intent(in) nb_blr,
integer, intent(in) npartsass,
integer, intent(in) nelim,
integer, intent(in) niv,
integer, intent(in) sym,
logical, intent(in) lbandslave,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) ishift,
integer, intent(in) midblk_compress,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent_rmb,
integer, intent(in) k480,
integer, intent(in) k479,
integer, intent(in) k478,
integer, intent(in) kpercent_lua,
integer, intent(in) kpercent,
integer, intent(in) maxi_cluster,
integer, intent(in) maxi_rank,
integer, intent(in) k474,
integer, intent(in) fsorcb,
type(lrb_type), dimension(:), pointer blr_u_col,
integer(8), dimension(150) keep8,
integer, intent(in), optional first_block,
integer, intent(in), optional beg_i_in,
integer, intent(in), optional end_i_in )

Definition at line 753 of file sfac_lr.F.

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 REAL, 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 REAL,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 REAL :: ONE, MONE, ZERO
797 parameter(one = 1.0e0, mone=-1.0e0)
798 parameter(zero=0.0e0)
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 smumps_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 & SMUMPS_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 & 'SMUMPS_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 smumps_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 & 'SMUMPS_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 & 'SMUMPS_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 smumps_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(real(acc_lrb%M*acc_lrb%N)/real(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 smumps_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 smumps_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 smumps_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 smumps_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

◆ smumps_blr_upd_panel_left_ldlt()

subroutine smumps_fac_lr::smumps_blr_upd_panel_left_ldlt ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(in) nfront,
integer, intent(in) iwhandler,
integer, dimension(:) begs_blr,
integer, intent(in) current_blr,
integer, intent(in) nb_blr,
integer, intent(in) npartsass,
integer, intent(in) nelim,
integer, dimension(*), intent(in) iw2,
real, dimension(maxi_cluster,*) block,
type(lrb_type), dimension(:), pointer acc_lua,
integer, intent(in) maxi_cluster,
integer, intent(in) maxi_rank,
integer, intent(in) niv,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) midblk_compress,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent_rmb,
integer, intent(in) k480,
integer, intent(in) k479,
integer, intent(in) k478,
integer, intent(in) kpercent_lua,
integer, intent(in) kpercent,
integer(8), dimension(150) keep8,
integer, intent(in), optional first_block )

Definition at line 437 of file sfac_lr.F.

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 REAL, intent(inout) :: A(LA)
456 INTEGER, intent(in) :: IW2(*)
457 REAL :: 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 REAL,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 REAL :: ONE, MONE, ZERO
481 parameter(one = 1.0e0, mone=-1.0e0)
482 parameter(zero=0.0e0)
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 smumps_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 & SMUMPS_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 & 'SMUMPS_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 smumps_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 & 'SMUMPS_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 & 'SMUMPS_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 smumps_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(real(acc_lrb%M*acc_lrb%N)/real(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 smumps_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 smumps_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 smumps_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 smumps_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

◆ smumps_blr_update_trailing()

subroutine smumps_fac_lr::smumps_blr_update_trailing ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) nfront,
integer, dimension(:) begs_blr_l,
integer, dimension(:) begs_blr_u,
integer, intent(in) current_blr,
type(lrb_type), dimension(:), intent(in), target blr_l,
integer, intent(in) nb_blr_l,
type(lrb_type), dimension(:), intent(in), target blr_u,
integer, intent(in) nb_blr_u,
integer, intent(in) nelim,
logical, intent(in) lbandslave,
integer, intent(in) ishift,
integer, intent(in) niv,
integer, intent(in) sym,
integer, intent(in) midblk_compress,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent )

Definition at line 319 of file sfac_lr.F.

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 REAL, 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 REAL,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 REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK
351 REAL :: ONE, MONE, ZERO
352 parameter(one = 1.0e0, mone=-1.0e0)
353 parameter(zero=0.0e0)
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 sgemm('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 sgemm('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 sgemm('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 smumps_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

◆ smumps_blr_update_trailing_ldlt()

subroutine smumps_fac_lr::smumps_blr_update_trailing_ldlt ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) nfront,
integer, dimension(:) begs_blr,
integer, intent(in) nb_blr,
integer, intent(in) current_blr,
type(lrb_type), dimension(:), intent(in) blr_l,
integer, intent(in) nelim,
integer, dimension(*), intent(in) iw2,
real, dimension(maxi_cluster,*), intent(inout) block,
integer, intent(in) maxi_cluster,
integer, intent(in) npiv,
integer, intent(in) niv,
integer, intent(in) midblk_compress,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent )

Definition at line 18 of file sfac_lr.F.

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 REAL, intent(inout) :: A(LA)
31 TYPE(LRB_TYPE),intent(in) :: BLR_L(:)
32 REAL, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*)
33 INTEGER, intent(in) :: IW2(*)
34 INTEGER, DIMENSION(:) :: BEGS_BLR
35 INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT
36 REAL,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 REAL :: ONE, MONE, ZERO
46 parameter(one = 1.0e0, mone=-1.0e0)
47 parameter(zero=0.0e0)
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 smumps_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

◆ smumps_compress_cb()

subroutine smumps_fac_lr::smumps_compress_cb ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(in) lda,
integer, dimension(:) begs_blr,
integer, dimension(:) begs_blr_u,
integer, intent(in) nb_rows,
integer, intent(in) nb_cols,
integer, intent(in) nb_inasm,
integer, intent(in) nrows,
integer, intent(in) ncols,
integer, intent(in) inode,
integer, intent(in) iwhandler,
integer, intent(in) sym,
integer, intent(in) niv,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) kpercent,
integer, intent(in) k489,
type(lrb_type), dimension(:,:), intent(inout), target cb_lrb,
real, dimension(:), target work,
real, dimension(:), target tau,
integer, dimension(:), target jpvt,
integer, intent(in) lwork,
real, dimension(:), target rwork,
real, dimension(:,:), target block,
integer, intent(in) maxi_cluster,
integer(8), dimension(150) keep8,
integer, intent(in) nfs4father,
integer, intent(in) npiv,
integer, intent(in) nvschur_k253,
integer, dimension(500), intent(in) keep,
real, dimension(max(nfs4father,1)), optional m_array,
integer, intent(in), optional nelim,
integer, intent(in), optional nbrowsinf )

Definition at line 1939 of file sfac_lr.F.

1951!$ USE OMP_LIB
1952 INTEGER(8), intent(in) :: LA
1953 REAL, 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 REAL, TARGET, DIMENSION(:) :: RWORK
1963 REAL, TARGET, DIMENSION(:,:) :: BLOCK
1964 REAL, TARGET, DIMENSION(:) :: WORK, TAU
1965 INTEGER, TARGET, DIMENSION(:) :: JPVT
1966 INTEGER(8) :: KEEP8(150)
1967 REAL,intent(in) :: TOLEPS
1968 INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500)
1969 REAL, 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 REAL, POINTER, DIMENSION(:) :: RWORK_THR
1984 REAL, POINTER, DIMENSION(:,:) :: BLOCK_THR
1985 REAL, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR
1986 INTEGER, POINTER, DIMENSION(:) :: JPVT_THR
1987 REAL :: ONE, MONE, ZERO
1988 parameter(one = 1.0e0, mone=-1.0e0)
1989 parameter(zero=0.0e0)
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 smumps_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(real(m*n)/real(m+n))
2117 maxrank = max(1, int((maxrank*kpercent/100)))
2118 CALL smumps_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 sorgqr
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
sorgqr
subroutine sorgqr(m, n, k, a, lda, tau, work, lwork, info)
SORGQR
Definition sorgqr.f:128
min
#define min(a, b)
Definition macros.h:20
smumps_truncated_rrqr
subroutine smumps_truncated_rrqr(m, n, a, lda, jpvt, tau, work, ldw, rwork, toleps, tol_opt, rank, maxrank, info, islr)
Definition slr_core.F:1611
smumps_compute_maxpercol
subroutine smumps_compute_maxpercol(a, asize, ncol, nrow, m_array, nmax, packed_cb, lrow1)
Definition stools.F:1643

◆ smumps_compress_panel()

subroutine smumps_fac_lr::smumps_compress_panel ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(inout) iflag,
integer, intent(inout) ierror,
integer, intent(in) nfront,
integer, dimension(:) begs_blr,
integer, intent(in) nb_blr,
real, intent(in) toleps,
integer, intent(in) tol_opt,
integer, intent(in) k473,
type(lrb_type), dimension(:), intent(inout) blr_panel,
integer, intent(in) current_blr,
character(len=1) dir,
real, dimension(:), target work,
real, dimension(:), target tau,
integer, dimension(:), target jpvt,
integer lwork,
real, dimension(:), target rwork,
real, dimension(:,:), target block,
integer maxi_cluster,
integer nelim,
logical, intent(in) lbandslave,
integer, intent(in) npiv,
integer, intent(in) ishift,
integer, intent(in) niv,
integer, intent(in) kpercent,
integer(8), dimension(150) keep8,
integer, intent(in), optional k480,
integer, intent(in), optional beg_i_in,
integer, intent(in), optional end_i_in,
logical, intent(in), optional frswap )

Definition at line 2188 of file sfac_lr.F.

2199!$ USE OMP_LIB
2200 INTEGER(8), intent(in) :: LA
2201 REAL, 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 REAL, TARGET, DIMENSION(:) :: RWORK
2207 REAL, TARGET, DIMENSION(:,:) :: BLOCK
2208 REAL, 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 REAL,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 REAL :: ONE, ALPHA, ZERO
2226 parameter(one = 1.0e0, alpha=-1.0e0)
2227 parameter(zero = 0.0d0)
2228 INTEGER :: OMP_NUM
2229 REAL, POINTER, DIMENSION(:) :: RWORK_THR
2230 REAL, POINTER, DIMENSION(:,:) :: BLOCK_THR
2231 REAL, 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 SMUMPS_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 SMUMPS_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 SMUMPS_COMPRESS_PANEL',
2308 & ' N size inconsistency',n,
2309 & blr_panel(ip-current_blr)%N
2310 CALL mumps_abort()
2311 ENDIF
2312 maxrank = floor(real(m*n)/real(m+n))
2313 IF (blr_panel(ip-current_blr)%K.GT.maxrank) THEN
2314 write(*,*) 'Internal error in SMUMPS_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(real(m*n)/real(m+n))
2345 maxrank = max(1, int((maxrank*kpercent/100)))
2346 CALL smumps_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 IF (iflag.LT.0) cycle
2363 IF ((m.EQ.0).OR.(n.EQ.0)) THEN
2364 GOTO 3000
2365 ENDIF
2366 IF (islr) THEN
2367 IF (rank .EQ. 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 IF(j.LT.rank) blr_panel(ip-current_blr)%
2374 & r(min(rank,j)+1:rank,jpvt_thr(j))= zero
2375 ENDDO
2376 CALL sorgqr
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 IF (dir .eq. '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 IF (k473.EQ.0) 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
alpha
#define alpha
Definition eval.h:35

◆ smumps_decompress_panel()

subroutine smumps_fac_lr::smumps_decompress_panel ( real, dimension(la), intent(inout) a,
integer(8), intent(in) la,
integer(8), intent(in) poselt,
integer, intent(in) lda11,
integer, intent(in) lda21,
logical, intent(in) copy_dense_blocks,
integer, intent(in) begs_blr_diag,
integer, intent(in) begs_blr_first_offdiag,
integer, intent(in) nb_blr,
type(lrb_type), dimension(:), intent(inout) blr_panel,
integer, intent(in) current_blr,
character(len=1) dir,
integer, intent(in) decomp_timer,
integer, intent(in), optional beg_i_in,
integer, intent(in), optional end_i_in,
integer, intent(in), optional only_nelim_in,
logical, intent(in), optional cbasm_tofix_in )

Definition at line 1749 of file sfac_lr.F.

1754!$ USE OMP_LIB
1755 INTEGER(8), intent(in) :: LA
1756 REAL, 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 REAL :: ONE, ALPHA, ZERO
1777 parameter(one = 1.0e0, alpha=-1.0e0)
1778 parameter(zero = 0.0e0)
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 sgemm('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 sgemm('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 sgemm('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 sgemm('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