cfac_front_LDLT_type2.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license 
C  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      MODULE cmumps_fac2_ldlt_m
      CONTAINS
      SUBROUTINE cmumps_fac2_ldlt( COMM_LOAD, ASS_IRECV, 
     &           N, INODE, FPERE, IW, LIW, A, LA,
     &           UU, NNEGW, NPVW, NB22T2W, NBTINYW,
     &           DET_EXPW, DET_MANTW, DET_SIGNW,
     &             COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF,
     &             IFLAG, IERROR, IPOOL,LPOOL,
     &             SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU,
     &             LRLUS, COMP,
     &             PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP,
     &             PIMASTER, PAMASTER,
     &             NSTK_S,PERM,PROCNODE_STEPS, root,
     &             OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &             FILS, DAD, PTRARW, PTRAIW,
     &             INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE,
     &             LPTRAR, NELT, FRTPTR, FRTELT, SEUIL,
     &             ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED,
     &             DKEEP,PIVNUL_LIST,LPN_LIST
     &     , LRGROUPS
     &             )
      USE cmumps_fac_front_aux_m
      USE cmumps_fac_front_type2_aux_m
      USE cmumps_ooc
      USE cmumps_fac_lr
      USE cmumps_lr_type
      USE cmumps_lr_stats
      USE cmumps_ana_lr, ONLY : get_cut
      USE cmumps_lr_data_m
!$    USE OMP_LIB
      USE cmumps_struc_def, ONLY : cmumps_root_struc
      USE cmumps_buf, ONLY : cmumps_buf_test
      IMPLICIT NONE
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER N, INODE, FPERE, LIW
      INTEGER, intent(inout) :: NNEGW, NPVW, NB22T2W, NBTINYW
      INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW
      COMPLEX, intent(inout) :: DET_MANTW
      INTEGER(8) :: LA
      INTEGER, TARGET :: IW( LIW )
      COMPLEX A( LA )
      REAL UU, SEUIL
      TYPE (CMUMPS_ROOT_STRUC) :: root
      INTEGER COMM, MYID, LBUFR, LBUFR_BYTES
      INTEGER LPTRAR, NELT
      INTEGER ICNTL(60), KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER NBFIN, SLAVEF,
     &        iflag, ierror, leaf, lpool
      INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS
      INTEGER IWPOS, IWPOSCB, COMP 
      INTEGER NB_BLOC_FAC
      INTEGER FRTPTR( N + 1 ), FRTELT( NELT )
      INTEGER BUFR( LBUFR ), IPOOL(LPOOL),
     &        itloc(n+keep(253)), fils(n), dad( keep(28) ),
     &        nd( keep(28) ), frere( keep(28) )
      INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR)
      COMPLEX :: RHS_MUMPS(KEEP(255))
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)),
     &        step(n), pimaster(keep(28)),
     &        nstk_s(keep(28)), perm(n),
     &        procnode_steps(keep(28))
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
      DOUBLE PRECISION OPASSW, OPELIW
      COMPLEX DBLARR(KEEP8(26))
      INTEGER INTARR(KEEP8(27))
      LOGICAL AVOID_DELAYED
      INTEGER LPN_LIST
      INTEGER PIVNUL_LIST(LPN_LIST)
      REAL DKEEP(230)
      INTEGER :: LRGROUPS(N)
      INTEGER(8) :: POSELT
      INTEGER IOLDPS, allocok, K263,J
      INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK
      INTEGER NASS, LDAFS, IBEG_BLOCK 
      INTEGER :: NB_POSTPONED
      INTEGER :: IBEG_BLOCK_FOR_IPIV
      LOGICAL LASTBL, LR_ACTIVATED, COMPRESS_PANEL
      LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, 
     &        ooc_effective_on_front, 
     &        ooc_eff_and_write_bypanel
      INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR
      INTEGER Inextpiv
      LOGICAL RESET_TO_ONE
      INTEGER K109_SAVE
      INTEGER XSIZE, NBKJIB_ORIG
      REAL UUTEMP
      include 'mumps_headers.h'
      INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV
      REAL , ALLOCATABLE, DIMENSION ( : )    :: DIAG_ORIG
      INTEGER    :: SIZEDIAG_ORIG
      INTEGER(8) :: LAFAC
      INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten,
     &        idummy, nelim
      TYPE(io_block) :: MonBloc 
      LOGICAL LAST_CALL
      INTEGER PP_FIRST2SWAP_L, IFLAG_OOC
      INTEGER PP_LastPIVRPTRFilled 
      INTEGER INFO_TMP(2)
      INTEGER :: MAXI_RANK
      INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR
      INTEGER MAXI_CLUSTER, LWORK
      TYPE(lrb_type), DIMENSION(1), TARGET  :: BLR_DUMMY
      INTEGER, POINTER, DIMENSION(:)        :: PTDummy
      TYPE(lrb_type), POINTER, DIMENSION(:) :: ACC_LUA
      INTEGER, POINTER, DIMENSION(:)        :: BEGS_BLR
      TYPE(lrb_type), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND
      COMPLEX, POINTER, DIMENSION(:)        :: DIAG
      TYPE(lrb_type), POINTER, DIMENSION(:) :: BLR_PANEL
      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC
      INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT
      INTEGER(8) :: POSELT_DIAG, APOSMAX
      COMPLEX, ALLOCATABLE :: WORK(:), TAU(:)
      INTEGER, ALLOCATABLE :: JPVT(:)
      REAL, ALLOCATABLE :: RWORK(:)
      COMPLEX, ALLOCATABLE :: BLOCK(:,:)
      INTEGER :: OMP_NUM
      INTEGER :: MY_NUM
      INTEGER PIVOT_OPTION
      INTEGER LAST_ROW
      EXTERNAL cmumps_bdc_error
      LOGICAL STATICMODE
      REAL SEUIL_LOC
      REAL GW_FACTCUMUL
      INTEGER PIVSIZ,IWPOSPIV
      COMPLEX ONE
      parameter(one=(1.0e0,0.0e0))
      NULLIFY(ptdummy)
      NULLIFY(acc_lua)
      NULLIFY(begs_blr)
      NULLIFY(blr_l) 
      NULLIFY(blr_send)
      NULLIFY(diag)
      NULLIFY(blr_panel)
      NULLIFY(begs_blr_tmp)
      NULLIFY(begs_blr_static)
      IF (keep(206).GE.1) THEN
        inextpiv = 1   
      ELSE 
        inextpiv = 0   
      ENDIF
      inopv = 0
      IF(keep(97) .EQ. 0) THEN
         staticmode = .false.
      ELSE
         staticmode = .true.
      ENDIF
      IF (avoid_delayed) THEN
        staticmode = .true.
        uutemp=uu
        seuil_loc = max(seuil,epsilon(seuil))
      ELSE
        seuil_loc=seuil
        uutemp=uu
      ENDIF
      reset_to_one = ((keep(110).GT.0).AND.(dkeep(2).LE.0.0e0))
      IF (reset_to_one) THEN
        k109_save = keep(109)
      ENDIF
      ibeg_block  = 1
      nb_bloc_fac = 0
      xsize  = keep(ixsz)
      ioldps = ptlust_s(step( inode ))
      poselt = ptrast(step( inode ))
      nfront = iw(ioldps+xsize)
      nass   = iabs(iw(ioldps+2+xsize))
      ldafs  = nass
      IF ((keep(219).EQ.1).AND.(keep(207).EQ.1).AND.(keep(50).EQ.2)
     &   ) THEN
        aposmax = poselt + int(ldafs,8)*int(ldafs,8)
        nb_postponed = max(nfront - nd(step(inode)),0)
        CALL cmumps_update_parpiv_entries ( inode,
     &     keep, a(aposmax), nass, nb_postponed)
      ENDIF
      iw(ioldps+3+xsize) =  -99999
      lr_activated= .false. 
      lr_activated   = (iw(ioldps+xxlr).GT.0)
      compress_panel = (iw(ioldps+xxlr).GE.2)
      oocwrite_compatible_with_blr = 
     &          ( .NOT.lr_activated.OR.  (.NOT.compress_panel).OR.
     &            (keep(486).NE.2) 
     &          )
      ooc_effective_on_front= ((keep(201).EQ.1).AND. 
     &                         oocwrite_compatible_with_blr)
      IF (nass.LT.keep(4)) THEN
        nbkjib_orig = nass
      ELSE IF (nass .GT. keep(3)) THEN
        nbkjib_orig = min( keep(6), nass )
      ELSE
        nbkjib_orig = min( keep(5), nass )
      ENDIF
      IF (.not.lr_activated) THEN
          nblr_orig     = keep(420)
      ELSE
          nblr_orig  = -9999 
      ENDIF
      IF (lr_activated) THEN
         k263 = 1   
      ELSE
         k263 = keep(263)
         IF (k263 .NE. 0 .AND. nass/nblr_orig < 4) THEN
           IF ( nblr_orig .GT. nbkjib_orig * 4 ) THEN
             nblr_orig = max(nbkjib_orig, (nass+3)/4)
           ELSE
             k263 = 0
           ENDIF
         ENDIF
      ENDIF
      pivot_option = min(2,keep(468))
      IF ((uutemp == 0.0e0) .AND. ooc_effective_on_front) THEN
          IF (k263.EQ.1.AND.(.NOT.lr_activated)) THEN
            pivot_option = 0
          ENDIF
      ENDIF
      iend_block  = 0
      iend_blr    = 0
      current_blr = 0
      ALLOCATE( ipiv( nass ), stat = allocok )
      IF ( allocok .GT. 0 ) THEN
        WRITE(*,*) myid, ' : CMUMPS_FAC2_LDLT failed to allocate ',
     &  nass, ' integers'
        iflag = -13
        ierror=nass
        GO TO 500
      END IF
      IF (keep(219).GE.3) THEN
       sizediag_orig = nass
      ELSE
       sizediag_orig = 1
      ENDIF
      ALLOCATE ( diag_orig(sizediag_orig), stat = allocok )
      IF ( allocok .GT. 0 ) THEN
          WRITE(*,*) myid,
     &      ' : FAC_NIV2 failed to allocate ',
     &      nass, ' REAL/COMPLEX entries'
          iflag=-13
          ierror=nass
          GO TO 500
      END IF
      CALL mumps_geti8(lafac,iw(ioldps+xxr))
      liwfac    = iw(ioldps+xxi)
      IF (ooc_effective_on_front) THEN
        idummy    = -9876
        typefile  = typef_l
        nextpiv2bewritten = 1 
        pp_first2swap_l = nextpiv2bewritten 
        monbloc%LastPanelWritten_L = 0 
        monbloc%INODE    = inode
        monbloc%MASTER   = .true.
        monbloc%Typenode = 2
        monbloc%NROW     = nass
        monbloc%NCOL     = nass
        monbloc%NFS      = nass
        monbloc%Last     = .false.   
        monbloc%LastPiv  = -66666    
        monbloc%INDICES =>
     &  iw(ioldps+6+nfront+xsize+iw(ioldps+5+xsize)
     &    :ioldps+5+2*nfront+xsize+iw(ioldps+5+xsize))
      ENDIF
      IF (lr_activated) THEN
             IF (keep(475).EQ.3) THEN
               IF (uutemp == 0.0e0) THEN
                 pivot_option = 0
               ELSE
                 pivot_option = 1
               ENDIF
             ENDIF
             cnt_nodes = cnt_nodes + 1 
      ENDIF
      hf = 6 + iw(ioldps+5+xsize)+xsize
      ooc_eff_and_write_bypanel  = ( (pivot_option.GE.2) .AND.
     &                                     ooc_effective_on_front )
      IF (lr_activated) THEN
         CALL get_cut(iw(ioldps+hf:ioldps+hf+nfront-1), nass,
     &        0, lrgroups, npartscb, 
     &        npartsass, begs_blr)
         CALL regrouping2(begs_blr, npartsass, nass, npartscb,
     &        0, keep(488), .false., keep(472))     
         nb_blr = npartsass + npartscb
         call max_cluster(begs_blr,nb_blr,maxi_cluster)
         maxi_rank = keep(479)*maxi_cluster
         lwork = maxi_cluster*maxi_cluster
         omp_num = 1
#if defined(blr_mt)
!$       OMP_NUM = OMP_GET_MAX_THREADS()
#endif
         ALLOCATE(block(maxi_cluster, omp_num*maxi_cluster),
     &             rwork(2*maxi_cluster*omp_num), 
     &             tau(maxi_cluster*omp_num),
     &             jpvt(maxi_cluster*omp_num), 
     &             work(lwork*omp_num),stat=allocok)
         IF (allocok > 0) THEN
           iflag  = -13
           ierror = omp_num*(lwork + maxi_cluster*(maxi_cluster+4))
           GOTO 480
         ENDIF
         ALLOCATE(acc_lua(omp_num),stat=allocok)
         IF (allocok > 0) THEN
           iflag  = -13
           ierror = omp_num
           GOTO 480
         ENDIF
         IF (keep(480).GE.3) THEN
           DO my_num=1,omp_num
             CALL alloc_lrb(acc_lua(my_num), maxi_rank,
     &                      maxi_cluster, maxi_cluster, .true., 
     &                      iflag, ierror, keep8)
             IF (iflag.LT.0) GOTO 480
             acc_lua(my_num)%K = 0
           ENDDO
         ENDIF
      ENDIF
      IF (lr_activated.AND.(keep(480).NE.0
     &       .OR.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &      )) THEN
        info_tmp(1) = iflag
        info_tmp(2) = ierror
        CALL cmumps_blr_init_front(iw(ioldps+xxf), info_tmp)
        iflag  = info_tmp(1) 
        ierror = info_tmp(2) 
        IF (iflag.LT.0) GOTO 500
        CALL cmumps_blr_save_init(iw(ioldps+xxf), 
     &              .true., 
     &              .true., 
     &              .false., 
     &              npartsass, 
     &              begs_blr, ptdummy, 
     &              huge(npartsass),  
     &              info_tmp)
        iflag  = info_tmp(1) 
        ierror = info_tmp(2) 
        IF (iflag.LT.0) GOTO 500
      ENDIF
      lastbl = .false.
      DO WHILE (iend_blr < nass ) 
        current_blr = current_blr + 1
        ibeg_blr = iw(ioldps+1+keep(ixsz)) + 1 
        IF (.NOT. lr_activated)THEN
          iend_blr = min(iend_blr + nblr_orig, nass)
        ELSE
          iend_blr = begs_blr(current_blr+1)-1
          begs_blr( current_blr ) = ibeg_blr
          IF ( iend_blr - ibeg_blr + 1 .GT. maxi_cluster ) THEN
            maxi_cluster = iend_blr - ibeg_blr + 1
            lwork = maxi_cluster*maxi_cluster
            DEALLOCATE(block, work, rwork, tau, jpvt)
            ALLOCATE(block(maxi_cluster, omp_num*maxi_cluster),
     &             rwork(2*maxi_cluster*omp_num), 
     &             tau(maxi_cluster*omp_num),
     &             jpvt(maxi_cluster*omp_num), 
     &             work(lwork*omp_num),stat=allocok)
            IF (allocok > 0) THEN
              iflag  = -13
              ierror = omp_num*(lwork + maxi_cluster*(maxi_cluster+4))
              GOTO 480
            ENDIF
            IF (keep(480).GE.3) THEN
              DO my_num=1,omp_num
                CALL dealloc_lrb(acc_lua(my_num), keep8, keep(34))
                CALL alloc_lrb(acc_lua(my_num), maxi_rank,
     &                       maxi_cluster, maxi_cluster, .true., 
     &                       iflag, ierror, keep8)
             IF (iflag.LT.0) GOTO 480
                acc_lua(my_num)%K = 0
              ENDDO
            ENDIF
          ENDIF
        ENDIF
        DO WHILE (iend_block < iend_blr ) 
          ibeg_block = iw(ioldps+1+keep(ixsz)) + 1
          IF (keep(405).EQ.0) THEN
            keep(425)=max(keep(425),iend_block-ibeg_block)
          ELSE
!$OMP       ATOMIC UPDATE
            keep(425)=max(keep(425),iend_block-ibeg_block)
!$OMP       END ATOMIC
          ENDIF
          iend_block = min(iend_block + nbkjib_orig, iend_blr)
  50      CONTINUE  
            IF (k263.EQ.0) THEN
              ibeg_block_for_ipiv = ibeg_block
            ELSE
              ibeg_block_for_ipiv = ibeg_blr
            ENDIF
            CALL cmumps_fac_i_ldlt_niv2(
     &                diag_orig, sizediag_orig, gw_factcumul,
     &                nfront,nass,ibeg_block_for_ipiv,
     &                ibeg_block, iend_block,
     &                nass, ipiv,
     &                n,inode,iw,liw,a,la,
     &                nnegw,nb22t2w,nbtinyw,
     &                det_expw, det_mantw, det_signw,
     &                inopv,
     &                iflag,ioldps,poselt,uu, seuil_loc,
     &                keep,keep8,pivsiz,
     &           dkeep(1),pivnul_list(1),lpn_list,
     &           pp_first2swap_l, monbloc%LastPanelWritten_L,
     &           pp_lastpivrptrfilled,
     &           pivot_option,
     &           inextpiv, iend_blr, lr_activated, 
     &           ooc_effective_on_front)
            IF (iflag.LT.0) GOTO 500
            IF (inopv.EQ. 1) THEN
              IF (staticmode) THEN
                inopv = -1
                GOTO 50
              ENDIF
             lastbl = .true.
            ELSE IF (inopv .LE. 0) THEN 
              inopv = 0
              npvw = npvw + pivsiz
              CALL cmumps_fac_mq_ldlt_niv2(iend_block,
     &             nass, iw(ioldps+1+xsize), inode,a,la,
     &             ldafs, poselt,ifinb,
     &             pivsiz,
     &             keep(219),
     &             pivot_option, iend_blr, lr_activated)
              IF(pivsiz .EQ. 2) THEN
                iwpospiv = ioldps+xsize+iw(ioldps+1+xsize)+6+
     &                     iw(ioldps+5+xsize)
                iw(iwpospiv+nfront) = -iw(iwpospiv+nfront)
              ENDIF
              iw(ioldps+1+xsize) = iw(ioldps+1+xsize) + pivsiz
            IF (ifinb.EQ.0) THEN
              GOTO 50 
            ELSE IF (ifinb .EQ. -1) THEN
              lastbl = .true.
            ENDIF
          ENDIF
          npiv = iw(ioldps+1+xsize)
          IF ( ooc_eff_and_write_bypanel ) THEN
            IF (.NOT.reset_to_one.OR.k109_save.EQ.keep(109)) THEN
              monbloc%Last   = .false.
              monbloc%LastPiv= npiv
              last_call=.false.
              CALL cmumps_ooc_io_lu_panel(
     &        strat_try_write,
     &        typefile, a(poselt),
     &        lafac, monbloc, nextpiv2bewritten, idummy, iw(ioldps),
     &        liwfac, myid, keep8(31), iflag_ooc,last_call )
              IF (iflag_ooc .LT. 0 ) iflag = iflag_ooc
              IF (iflag .LT. 0) GOTO 500
            ENDIF
          ENDIF
          IF (k263.eq.0) THEN
            nelim = iend_blr - npiv
            CALL cmumps_send_factored_blk( comm_load, ass_irecv, 
     &             n, inode, fpere, iw, liw, 
     &             ioldps, poselt, a, la, ldafs,
     &             ibeg_block, npiv, ipiv, nass,lastbl, nb_bloc_fac,
     &             comm, myid, bufr, lbufr, lbufr_bytes,nbfin,leaf,
     &             iflag, ierror, ipool,lpool,
     &             slavef, posfac, iwpos, iwposcb, iptrlu, lrlu,
     &             lrlus, comp, ptrist, ptrast, ptlust_s, ptrfac, step,
     &             pimaster, pamaster,
     &             nstk_s,perm,procnode_steps, root,
     &             opassw, opeliw, itloc, rhs_mumps,
     &             fils, dad, ptrarw, ptraiw,
     &             intarr,dblarr,icntl,keep,keep8,dkeep,nd,frere,
     &             lptrar, nelt, frtptr, frtelt, 
     &             istep_to_iniv2, tab_pos_in_pere
     &             , nelim, .false. 
     &             , npartsass, current_blr, blr_dummy, lrgroups
     & )
            IF ( iflag .LT. 0 ) GOTO 500
            IF (reset_to_one.AND.k109_save.LT.keep(109)) THEN
              CALL cmumps_reset_to_one( 
     &        iw(ioldps+keep(ixsz)+iw(ioldps+5+keep(ixsz))+6),
     &        npiv, ibeg_block,
     &        k109_save, keep(109), pivnul_list, lpn_list,
     &        a, poselt, la, ldafs)
            ENDIF
            IF ( ooc_eff_and_write_bypanel) THEN
              monbloc%Last  = .false.
              monbloc%LastPiv= npiv
              last_call=.false.
              CALL cmumps_ooc_io_lu_panel(
     &        strat_try_write,
     &        typefile, a(poselt),
     &        lafac, monbloc, nextpiv2bewritten, idummy, iw(ioldps),
     &        liwfac, myid, keep8(31), iflag_ooc,last_call )
              IF (iflag_ooc .LT. 0 ) THEN
                iflag = iflag_ooc
                IF (iflag .LT. 0) GOTO 500
              ENDIF
            ENDIF
          ENDIF
          IF ( iend_blr .GT. iend_block ) THEN
              IF (pivot_option.EQ.2) THEN
                last_row = nass
              ELSE
                last_row = iend_blr
              ENDIF
              CALL cmumps_fac_sq_ldlt(ibeg_block,iend_block,npiv,
     &             nass,nass,inode,a,la,
     &             ldafs, poselt,
     &             keep,keep8,
     &             -6666, -6666, 
     &             iend_blr, last_row,
     &             .false., .true., lr_activated,
     &             iw, liw, -6666 
     &             )
          ENDIF
          CALL cmumps_buf_test()
        END DO 
        npiv   = iw(ioldps+1+xsize)
        IF (lr_activated) THEN
          ALLOCATE(blr_l(nb_blr-current_blr),stat=allocok)
          IF (allocok > 0) THEN
             iflag  = -13
             ierror = nb_blr-current_blr
             GOTO 500
          ENDIF
          nelim = iend_block - npiv
          IF (iend_blr.NE.iend_block) THEN
            WRITE(*,*) "Internal error 1 in CMUMPS_FAC2_LDLT",
     &      iend_blr, iend_block
            CALL mumps_abort()
          ENDIF
          IF (nelim .EQ. iend_blr - ibeg_blr + 1) THEN
            IF (keep(480).GE.2
     &       .OR.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &         ) THEN
              DO j=1,nb_blr-current_blr
                 blr_l(j)%M=0
                 blr_l(j)%N=0
                 blr_l(j)%K=0
                 blr_l(j)%ISLR=.false.
                 NULLIFY(blr_l(j)%Q)
                 NULLIFY(blr_l(j)%R)
              ENDDO
              CALL cmumps_blr_save_panel_loru (
     &              iw(ioldps+xxf),
     &              0, 
     &              current_blr, blr_l)
              NULLIFY(blr_l)
            ENDIF
            GOTO 101
          ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL 
#endif
          CALL cmumps_compress_panel(a, la, poselt, iflag, ierror, nass,
     &         begs_blr, nb_blr, dkeep(8), keep(466), keep(473), 
     &         blr_l, 
     &         current_blr, 'V', work, tau, jpvt, lwork, rwork,
     &         block, maxi_cluster, nelim, 
     &         .false., 0, 0,
     &         2, keep(483), keep8
     &        )
#if defined(BLR_MT)          
!$OMP BARRIER
#endif          
          IF (iflag.LT.0) GOTO 400
          IF (pivot_option.LT.2) THEN
            CALL cmumps_blr_panel_lrtrsm(a, la, poselt, nfront,
     &                ibeg_blr,
     &                nb_blr, blr_l, current_blr, current_blr+1, 
     &                nb_blr, 2, 1, 0, .false.,
     &                iw, offset_iw=ioldps+6+xsize+nfront+ibeg_blr-1,
     &                nass=nass)     
#if defined(BLR_MT)          
!$OMP BARRIER
#endif          
          ENDIF
 400      CONTINUE         
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
          IF (iflag.LT.0) GOTO 480
          IF (keep(480).NE.0
     &       .OR.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &       ) THEN
            IF (keep(480).LT.5) THEN
              CALL cmumps_blr_save_panel_loru (
     &              iw(ioldps+xxf),
     &              0, 
     &              current_blr, blr_l)
            ENDIF
          ENDIF
        ENDIF
 101    CONTINUE       
        IF (.NOT. lr_activated) THEN
          CALL cmumps_fac_sq_ldlt(ibeg_blr,iend_blr,npiv,
     &             nass, nass, inode, a, la,
     &             ldafs, poselt,
     &             keep, keep8,
     &             iend_blr, nass,
     &             -6666, -6666, 
     &             (pivot_option.LE.1), .false., lr_activated,
     &             iw, liw, ioldps+6+xsize+nfront+ibeg_blr-1) 
        ENDIF
        IF (k263.NE.0) THEN
          nelim = iend_blr-npiv
          blr_send=>blr_dummy
          IF (associated(blr_l)) THEN
            blr_send=>blr_l
          ENDIF
          CALL cmumps_send_factored_blk( comm_load, ass_irecv,
     &             n, inode, fpere, iw, liw, 
     &             ioldps, poselt, a, la, ldafs,
     &             ibeg_blr, npiv, ipiv, nass,lastbl, nb_bloc_fac,
     &
     &             comm, myid, bufr, lbufr, lbufr_bytes,nbfin,leaf,
     &             iflag, ierror, ipool,lpool,
     &             slavef, posfac, iwpos, iwposcb, iptrlu, lrlu,
     &             lrlus, comp, ptrist, ptrast, ptlust_s, ptrfac, step,
     &             pimaster, pamaster,
     &             nstk_s,perm,procnode_steps, root,
     &             opassw, opeliw, itloc, rhs_mumps,
     &             fils, dad, ptrarw, ptraiw,
     &             intarr,dblarr,icntl,keep,keep8,dkeep,nd,frere,
     &             lptrar, nelt, frtptr, frtelt, 
     &             istep_to_iniv2, tab_pos_in_pere
     &             , nelim, lr_activated
     &             , npartsass, current_blr , blr_send , lrgroups
     &             )
          IF ( iflag .LT. 0 ) GOTO 500
          IF (reset_to_one.AND.k109_save.LT.keep(109)) THEN
              CALL cmumps_reset_to_one( 
     &        iw(ioldps+keep(ixsz)+iw(ioldps+5+keep(ixsz))+6),
     &        npiv, ibeg_blr,
     &        k109_save, keep(109), pivnul_list, lpn_list,
     &        a, poselt, la, ldafs)
          ENDIF
          IF ( ooc_eff_and_write_bypanel ) THEN
              monbloc%Last  = .false.
              monbloc%LastPiv= npiv
              last_call=.false.
              CALL cmumps_ooc_io_lu_panel(
     &        strat_try_write,
     &        typefile, a(poselt),
     &        lafac, monbloc, nextpiv2bewritten, idummy, iw(ioldps),
     &        liwfac, myid, keep8(31), iflag_ooc,last_call )
              IF (iflag_ooc .LT. 0 ) THEN
                iflag = iflag_ooc
                IF (iflag .LT. 0) GOTO 500
              ENDIF
          ENDIF
        ENDIF
        IF (.NOT. lr_activated) THEN
          IF (pivot_option.EQ.2) THEN
            last_row = nass
          ELSE
            last_row = iend_blr
          ENDIF
          CALL cmumps_fac_sq_ldlt(ibeg_blr,iend_blr,npiv,
     &             nass,nass,inode,a,la,
     &             ldafs, poselt,
     &             keep,keep8,
     &             -6666, -6666, 
     &             nass, last_row, 
     &             .false., .true., lr_activated,
     &             iw, liw, -6666 
     &             )
        ELSE
          nelim = iend_block - npiv
          IF (iend_blr.NE.iend_block) THEN
             CALL mumps_abort()
          ENDIF
#if defined(BLR_MT)
!$OMP PARALLEL
#endif
          IF (keep(480).GE.2) THEN
            IF (iend_blr.LT.nass) THEN
              CALL cmumps_blr_upd_panel_left_ldlt(a, la, poselt,
     &          nass, iw(ioldps+xxf), 
     &          begs_blr, current_blr, nb_blr, npartsass,
     &          nelim,
     &          iw(hf+ioldps+nfront), block,
     &          acc_lua, maxi_cluster, maxi_rank,
     &          2, iflag, ierror,
     &          keep(481), dkeep(11), keep(466), keep(477), 
     &          keep(480), keep(479), keep(478), keep(476), 
     &          keep(483), keep8)
            ENDIF
          ENDIF
          IF (nelim .EQ. iend_blr - ibeg_blr + 1) GOTO 450
          IF (keep(480).LT.2) THEN
            CALL cmumps_blr_update_trailing_ldlt(a, la, poselt, 
     &        iflag, ierror, nass,
     &        begs_blr, nb_blr, current_blr, blr_l, nelim,
     &        iw(hf+ioldps+nfront+ibeg_blr-1), block,
     &        maxi_cluster, npiv,
     &        2, 
     &        keep(481), dkeep(11), keep(466), keep(477) 
     &        )
          ENDIF
#if defined(BLR_MT)          
!$OMP BARRIER
#endif          
            IF (iflag.LT.0) GOTO 450
          IF (pivot_option.LT.2) THEN
            IF ((uu.GT.0).OR.(keep(486).NE.2)) THEN
              CALL cmumps_decompress_panel(a, la, poselt, nass, nass,
     &              .true.,  
     &         begs_blr(current_blr),
     &         begs_blr(current_blr+1), nb_blr, blr_l, current_blr, 
     &         'V', 1)
            ENDIF
          ENDIF
 450      CONTINUE
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
          IF (iflag.LT.0) GOTO 480
          IF (nelim .EQ. iend_blr - ibeg_blr + 1) THEN
            IF (keep(486).EQ.3) THEN
              IF (keep(480).EQ.0) THEN
                DEALLOCATE(blr_l)
                NULLIFY(blr_l)
              ENDIF
            ENDIF
            GOTO 100
          ENDIF
          IF (keep(486).EQ.3) THEN
            IF (keep(480).EQ.0) THEN
              CALL dealloc_blr_panel(blr_l, nb_blr-current_blr, keep8,
     &                               keep(34))
              DEALLOCATE(blr_l)
            ENDIF
            NULLIFY(blr_l)
          ENDIF
        ENDIF 
        IF ( ooc_eff_and_write_bypanel ) THEN
          monbloc%Last   = .false.
          monbloc%LastPiv= npiv
          last_call=.false.
          CALL cmumps_ooc_io_lu_panel(
     &        strat_try_write,
     &        typefile, a(poselt),
     &        lafac, monbloc, nextpiv2bewritten, idummy, iw(ioldps),
     &        liwfac, myid, keep8(31), iflag_ooc,last_call )
          IF (iflag_ooc < 0 ) THEN
              iflag = iflag_ooc
              GOTO 500
          ENDIF
        ENDIF
  100   CONTINUE
      END DO 
      IF (lr_activated) THEN
        ibeg_blr = iw(ioldps+1+keep(ixsz)) + 1 
        begs_blr( current_blr + 1 ) = ibeg_blr
        IF 
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &       THEN
          CALL cmumps_blr_retrieve_begsblr_sta(iw(ioldps+xxf),
     &                        begs_blr_static)
          IF (uu.GT.0) THEN
            allocate(begs_blr_tmp(nb_blr+1),stat=allocok)
            IF (allocok > 0) THEN
              iflag  = -13
              ierror = nb_blr+1
              GOTO 500
            ENDIF
            DO j=1,nb_blr+1
               begs_blr_tmp(j) = begs_blr_static(j)
            ENDDO
          ENDIF
        ENDIF
      IF ( 
     &         (keep(486).EQ.2) 
     &       
     &   ) THEN
        mem_tot = 0
#if defined(BLR_MT)
!$OMP PARALLEL
!$OMP& PRIVATE(IP, NELIM)
#endif
#if defined(BLR_MT)
!$omp DO private(diag, diagsiz_sta, diagsiz_dyn, dpos, poselt_diag, mem,
!$OMP&           allocok)
!$OMP&   REDUCTION(+:MEM_TOT)
#endif
        DO ip=1,npartsass
          IF (iflag.LT.0) cycle
          diagsiz_dyn = begs_blr(ip+1)-begs_blr(ip)
          diagsiz_sta = begs_blr_static(ip+1)-begs_blr(ip)
          mem = diagsiz_dyn*diagsiz_sta
          mem_tot = mem_tot + mem
          ALLOCATE(diag(mem),stat=allocok)
          IF (allocok > 0) THEN
            iflag  = -13
            ierror = mem
            cycle
          ENDIF 
          dpos = 1
          poselt_diag = poselt + int(begs_blr(ip)-1,8)*int(ldafs,8)
     &                         + int(begs_blr(ip)-1,8)
          DO i=1,diagsiz_sta
            diag(dpos:dpos+diagsiz_dyn-1) =
     &               a(poselt_diag:poselt_diag+int(diagsiz_dyn-1,8))
            dpos = dpos + diagsiz_dyn
            poselt_diag = poselt_diag + int(ldafs,8)
          ENDDO
          CALL cmumps_blr_save_diag_block(
     &          iw(ioldps+xxf),
     &          ip, diag)
        ENDDO
#if defined(blr_mt)
!$OMP ENDDO
!$OMP SINGLE
#endif
        CALL mumps_dm_fac_upd_dyn_memcnts(int(mem_tot,8),
     &        .false., keep8, iflag, ierror, .true., .true.)
#if defined(BLR_MT)
!$OMP END SINGLE
#endif
        IF (iflag.LT.0) GOTO 460
        IF (uu.GT.0) THEN
          DO ip=1,npartsass
            nelim = begs_blr_tmp(ip+1)-begs_blr(ip+1)
#if defined(BLR_MT)
!$OMP SINGLE
#endif
            CALL cmumps_blr_retrieve_panel_loru(
     &       iw(ioldps+xxf), 0, ip, blr_panel)
            CALL dealloc_blr_panel(blr_panel, npartsass-ip, keep8,
     &                             keep(34))
#if defined(BLR_MT)
!$OMP END SINGLE
#endif
            CALL cmumps_compress_panel(a, la, poselt, iflag,
     &        ierror, ldafs, begs_blr_tmp,
     &        nb_blr, dkeep(8), keep(466), keep(473),
     &        blr_panel, ip,
     &        'V', work, tau, jpvt, lwork, rwork,
     &        block, maxi_cluster, nelim,
     &        .false., 0, 0,
     &        2, keep(483), keep8,
     &        end_i_in=npartsass, frswap=.true.
     &       )
#if defined(BLR_MT)
!$OMP BARRIER
#endif
            IF (iflag.LT.0) GOTO 440
#if defined(BLR_MT)
!$OMP SINGLE
#endif
            begs_blr_tmp(ip+1) = begs_blr(ip+1)
#if defined(BLR_MT)
!$OMP END SINGLE
#endif
          ENDDO
#if defined(BLR_MT)
!$OMP BARRIER
#endif
 440      CONTINUE         
        ENDIF 
 460    CONTINUE          
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif
        IF (uu.GT.0) THEN
          deallocate(begs_blr_tmp)
        ENDIF
        IF (iflag.LT.0) GOTO 500
      ENDIF 
        IF ( 
     &         (keep(486).EQ.2) 
     &       
     &    ) THEN
          CALL cmumps_blr_save_begs_blr_dyn(iw(ioldps+xxf),
     &        begs_blr)
        ENDIF  
      ENDIF 
      IF (ooc_effective_on_front) THEN
          strat        = strat_write_max   
          monbloc%Last = .true.
          monbloc%LastPiv  = iw(ioldps+1+xsize)
          last_call    = .true.
          CALL cmumps_ooc_io_lu_panel
     &          ( strat, typefile, 
     &           a(poselt), lafac, monbloc,
     &           nextpiv2bewritten, idummy,
     &           iw(ioldps), liwfac, 
     &           myid, keep8(31), iflag_ooc, last_call )
          IF (iflag_ooc .LT. 0 ) THEN
             iflag = iflag_ooc
             IF (iflag .LT. 0) GOTO 500
          ENDIF
          CALL cmumps_ooc_pp_tryrelease_space (iwpos, 
     &      ioldps, iw, liw, monbloc , nfront, keep)
      ENDIF
      GOTO 600
 480  CONTINUE
 500  CONTINUE
      CALL cmumps_bdc_error( myid, slavef, comm, keep )
 600  CONTINUE
      IF(allocated(ipiv)) DEALLOCATE( ipiv )
      IF (allocated(diag_orig)) DEALLOCATE(diag_orig)
      IF (lr_activated) THEN
         IF (iflag.GE.0) THEN
           CALL upd_mry_lu_fr(nass, nfront-nass, 1, nelim)
           DO ip=1,npartsass
             CALL cmumps_blr_retrieve_panel_loru(
     &               iw(ioldps+xxf), 0, ip, blr_panel)
             CALL upd_mry_lu_lrgain(blr_panel, npartsass-ip
     &            )
           ENDDO
           CALL upd_flop_facto_fr(nfront, nass, nass-nelim, 2, 2)
         ENDIF 
         IF (allocated(rwork)) DEALLOCATE(rwork)
         IF (allocated(work))  DEALLOCATE(work)
         IF (allocated(tau))   DEALLOCATE(tau)
         IF (allocated(jpvt))  DEALLOCATE(jpvt)
         IF (allocated(block)) DEALLOCATE(block)
         IF (associated(acc_lua)) THEN 
           IF (keep(480).GE.3) THEN
             DO my_num=1,omp_num
               CALL dealloc_lrb(acc_lua(my_num), keep8, keep(34))
             ENDDO
           ENDIF
           DEALLOCATE(acc_lua)
         ENDIF
         IF (associated(begs_blr)) THEN
           DEALLOCATE(begs_blr)
           NULLIFY(begs_blr)
         ENDIF
      ENDIF
      IF (keep(486).NE.0) THEN
        IF (.NOT.lr_activated) THEN
          CALL upd_flop_frfronts(nfront, npiv, nass, keep(50), 2)
        ENDIF
      ENDIF
      IF (lr_activated.AND.keep(480).NE.0) THEN
        IF (.NOT.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &    ) THEN
          CALL cmumps_blr_free_all_panels(iw(ioldps+xxf), 0, 
     &                    keep8, keep(34))
        ENDIF
      ENDIF
      IF (lr_activated) THEN
        IF (.NOT.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &     ) THEN
          CALL cmumps_blr_end_front(iw(ioldps+xxf), iflag, keep8,
     &                              keep(34))
        ENDIF
      ENDIF
      RETURN
      END SUBROUTINE cmumps_fac2_ldlt
      SUBROUTINE cmumps_reset_to_one(FRONT_INDEX_LIST, NPIV,
     & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST, LPN_LIST,
     & A, POSELT, LA, LDAFS)
      INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK
      INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV)
      INTEGER, INTENT(IN) :: K109
      INTEGER, INTENT(INOUT) :: K109_SAVE
      INTEGER, INTENT(IN) :: LPN_LIST
      INTEGER, INTENT(IN) :: PIVNUL_LIST(LPN_LIST)
      INTEGER(8), INTENT(IN) :: POSELT, LA
      INTEGER, INTENT(IN) :: LDAFS
      COMPLEX, INTENT(INOUT) :: A(LA)
      LOGICAL :: TO_UPDATE
      INTEGER :: I, JJ, K
      COMPLEX ONE
      PARAMETER (ONE=(1.0e0,0.0e0))
      DO k = k109_save+1, k109
        to_update = .false. 
        i = pivnul_list(k)  
        DO jj=ibeg_block, npiv
          IF (front_index_list(jj) .EQ.i) THEN
            to_update=.true. 
            EXIT
          ENDIF
        ENDDO
        IF (to_update) THEN
          a(poselt+int(jj,8)+int(ldafs,8)*int(jj-1,8))= one
          to_update=.false. 
       ELSE
          write(*,*) ' Internal error related ', 
     &               'to null pivot row detection'
          CALL mumps_abort()
        ENDIF
      ENDDO
      k109_save = k109
      RETURN
      END SUBROUTINE cmumps_reset_to_one
      END MODULE cmumps_fac2_ldlt_m