zfac_process_blocfacto.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
      RECURSIVE SUBROUTINE zmumps_process_blocfacto(
     &   COMM_LOAD, ASS_IRECV,
     &   BUFR, LBUFR,
     &   LBUFR_BYTES, PROCNODE_STEPS, MSGSOU,
     &   SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW,
     &   A, LA, PTRIST, PTRAST, NSTK_S, PERM,
     &   COMP, STEP, PIMASTER, PAMASTER, POSFAC,
     &   MYID, COMM, IFLAG, IERROR, NBFIN,
     &
     &    PTLUST_S, PTRFAC, root, OPASSW, OPELIW,
     &    ITLOC, RHS_MUMPS, FILS, DAD,
     &    PTRARW, PTRAIW, INTARR, DBLARR,
     &    ICNTL, KEEP,KEEP8, DKEEP, 
     &    IPOOL, LPOOL, LEAF, ND, FRERE_STEPS,
     &    LPTRAR, NELT, FRTPTR, FRTELT, 
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &               , LRGROUPS
     &    )
      USE zmumps_ooc, ONLY : io_block
      USE mumps_ooc_common, ONLY : typef_l, strat_try_write
      USE zmumps_load
      USE zmumps_lr_core
      USE zmumps_lr_type
      USE zmumps_lr_stats
      USE zmumps_fac_lr
      USE zmumps_ana_lr, ONLY : get_cut
      USE zmumps_lr_data_m
      USE zmumps_struc_def, ONLY : zmumps_root_struc
      USE zmumps_dynamic_memory_m, ONLY : zmumps_dm_set_dynptr
!$    USE OMP_LIB
      IMPLICIT NONE
      include 'mumps_headers.h'
      TYPE (zmumps_root_struc) :: root
      INTEGER icntl( 60 ), keep( 500 )
      INTEGER(8) keep8(150)
      DOUBLE PRECISION dkeep(230)
      INTEGER lbufr, lbufr_bytes
      INTEGER comm_load, ass_irecv
      INTEGER bufr( lbufr )
      INTEGER n, slavef, iwpos, iwposcb, liw
      INTEGER(8) :: iptrlu, lrlu, lrlus, la
      INTEGER(8) :: posfac
      INTEGER comp
      INTEGER iflag, ierror, nbfin, msgsou
      INTEGER procnode_steps(keep(28)), ptrist(keep(28)),
     &        nstk_s(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER perm(n), step(n), 
     & pimaster(keep(28))
      INTEGER iw( liw )
      COMPLEX(kind=8) a( la )
      INTEGER, intent(in) :: LRGROUPS(n)
      INTEGER comm, MYID
      INTEGER nelt, lptrar
      INTEGER frtptr( n+1 ), frtelt( nelt )
      INTEGER ptlust_s(keep(28)),
     &        itloc(n+keep(253)), fils(n), dad(keep(28)), nd(keep(28))
      COMPLEX(kind=8) :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptraiw( lptrar ), ptrarw( lptrar )
      INTEGER frere_steps(keep(28))
      DOUBLE PRECISION opassw, opeliw
      DOUBLE PRECISION flop1
      INTEGER intarr( keep8(27) )
      COMPLEX(kind=8) dblarr( keep8(26) )
      INTEGER leaf, lpool 
      INTEGER ipool( lpool )
      INTEGER istep_to_iniv2(keep(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER :: status(mpi_status_size)
      LOGICAL :: i_have_set_k117
      INTEGER inode, position, npiv, ierr, lp
      INTEGER ncol
      INTEGER(8) :: posblocfacto
      INTEGER :: LD_BLOCFACTO 
      INTEGER(8) :: la_blocfacto 
      INTEGER(8) :: la_ptr 
      INTEGER(8) :: poselt
      COMPLEX(kind=8), DIMENSION(:), POINTER :: a_ptr
      INTEGER ioldps, lcont1, nass1, nrow1, ncol1, npiv1
      INTEGER nslav1, hs, isw
      INTEGER (8) :: lpos, upos, lpos2, ipos, kpos
      INTEGER ict11
      INTEGER i, ipiv, fpere
      LOGICAL lastbl, keep_begs_blr_l
      LOGICAL blocking, set_irecv, message_received
      COMPLEX(kind=8) one,alpha
      parameter(one=(1.0d0,0.0d0), alpha=(-1.0d0,0.0d0))
      INTEGER liwfac, strat, NextPivDummy
      TYPE(io_block) :: monbloc
      LOGICAL last_call
      INTEGER lrelay_info
      INTEGER :: info_tmp(2)
      INTEGER :: idummy(1)
      INTEGER :: nelim, npartsass_master, npartsass_master_aux,
     &           ipanel, 
     &           current_blr, 
     &           nb_blr_l, nb_blr_u, nb_blr_col
      TYPE (lrb_type), POINTER, DIMENSION(:,:) :: cb_lrb
      TYPE (lrb_type), DIMENSION(:), POINTER :: blr_u, blr_l
      LOGICAL :: lr_activated, compress_cb, compress_panel
      LOGICAL oocwrite_compatible_with_blr
      INTEGER :: lr_activated_int
      INTEGER, POINTER, DIMENSION(:) :: begs_blr_l, begs_blr_u,
     & begs_blr_col
      COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: work, tau
      INTEGER, ALLOCATABLE, DIMENSION(:) :: jpvt
      DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: rwork
      COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: block
      INTEGER :: omp_num
      INTEGER npartsass, npartscb, MAXI_CLUSTER, lwork,
     &        maxi_cluster_l, maxi_cluster_u, maxi_cluster_col
      INTEGER  :: allocok
      INTEGER mumps_procnode
      EXTERNAL mumps_procnode
      keep_begs_blr_l = .false.
      nullify(begs_blr_l)
      nb_blr_u = -7654321
      NULLIFY(begs_blr_u)
      i_have_set_k117 = .false.
      fpere    = -1
      position = 0
      CALL mpi_unpack( bufr, lbufr_bytes, position, inode, 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, npiv, 1,
     &                 mpi_integer, comm, ierr )
      lastbl = (npiv.LE.0)
      IF (lastbl) THEN 
         npiv = -npiv
         CALL mpi_unpack( bufr, lbufr_bytes, position, fpere, 1,
     &                 mpi_integer, comm, ierr )
      ENDIF
      CALL mpi_unpack( bufr, lbufr_bytes, position, ncol, 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, nelim, 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, 
     &                 npartsass_master , 1,
     &                 mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, ipanel,
     &                 1, mpi_integer, comm, ierr )
      CALL mpi_unpack( bufr, lbufr_bytes, position, lr_activated_int,
     &                 1, mpi_integer, comm, ierr )
      lr_activated    = (lr_activated_int.EQ.1)
      IF ( lr_activated ) THEN
        la_blocfacto = int(npiv,8) * int(npiv+nelim,8)
      ELSE
        la_blocfacto = int(npiv,8) * int(ncol,8)
      ENDIF
      CALL zmumps_get_size_needed(
     &      npiv, la_blocfacto, .false.,
     &      keep(1), keep8(1),
     &      n, iw, liw, a, la,
     &      lrlu, iptrlu,
     &      iwpos, iwposcb, ptrist, ptrast,
     &      step, pimaster, pamaster, lrlus,
     &      keep(ixsz),comp,dkeep(97),myid,slavef, procnode_steps, 
     &      dad, iflag, ierror)
      IF (iflag.LT.0) GOTO 700
      lrlu  = lrlu - la_blocfacto
      lrlus = lrlus - la_blocfacto
      keep8(67) = min(lrlus, keep8(67))
      keep8(69) = keep8(69) + la_blocfacto
      keep8(68) = max(keep8(69), keep8(68))
      posblocfacto = posfac
      posfac = posfac + la_blocfacto
      CALL zmumps_load_mem_update(.false., .false.,
     &               la-lrlus,0_8,la_blocfacto,keep,keep8,lrlus)
      IF ((npiv .EQ. 0) 
     &     ) THEN
        ipiv=1
      ELSE
        ipiv = iwpos
        iwpos = iwpos + npiv
        IF (npiv .GT. 0) THEN
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 iw( ipiv ), npiv,
     &                 mpi_integer, comm, ierr )
        ENDIF
        IF ( lr_activated ) THEN
            CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 a(posblocfacto), npiv*(npiv+nelim),
     &                 mpi_double_complex,
     &                 comm, ierr )
            ld_blocfacto = npiv+nelim
            CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 nb_blr_u, 1, mpi_integer,
     &                 comm, ierr )
            ALLOCATE(blr_u(max(nb_blr_u,1)), stat=allocok)
            IF (allocok > 0 ) THEN
               iflag = -13
               ierror = max(nb_blr_u,1)
               lp = icntl(1)
               IF (icntl(4) .LE. 0) lp=-1
               IF (lp > 0) WRITE(lp,*) myid,
     &              ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO'
               GOTO 700
            ENDIF
            ALLOCATE(begs_blr_u(nb_blr_u+2), stat=allocok)
            IF (allocok > 0 ) THEN
               iflag = -13
               ierror = nb_blr_u+2
               lp = icntl(1)
               IF (icntl(4) .LE. 0) lp=-1
               IF (lp > 0) WRITE(lp,*) myid,
     &              ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO'
               GOTO 700
            ENDIF
            CALL zmumps_mpi_unpack_lr(bufr, lbufr, lbufr_bytes, 
     &                             position, npiv, nelim, 'H',
     &                             blr_u(1), nb_blr_u, 
     &                             begs_blr_u(1),
     &                             keep8, comm, ierr, iflag, ierror)
            IF (iflag.LT.0) GOTO 700
        ELSE
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 a(posblocfacto), npiv*ncol,
     &                 mpi_double_complex,
     &                 comm, ierr )
          ld_blocfacto = ncol
        ENDIF
      ENDIF 
      CALL mpi_unpack( bufr, lbufr_bytes, position, 
     &                 lrelay_info, 1,
     &                 mpi_integer, comm, ierr )
      IF (ptrist(step( inode )) .EQ. 0) THEN
          CALL zmumps_treat_descband( inode, comm_load,
     &    ass_irecv,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm,
     &    perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &    root, opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr, dblarr, icntl,keep,keep8,dkeep,nd, frere_steps,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere, .true.
     &               , lrgroups
     &    )
          IF ( iflag .LT. 0 ) GOTO 600
      ENDIF
      IF ( iw( ptrist(step(inode)) + 3 +keep(ixsz)) .EQ. 0 ) THEN
       DO WHILE ( iw(ptrist(step(inode)) + xxnbpr) .NE. 0)
        blocking = .true.
        set_irecv = .false.
        message_received = .false.
        CALL zmumps_try_recvtreat( comm_load,
     &    ass_irecv, blocking, set_irecv, message_received,
     &    mpi_any_source, contrib_type2,
     &    status,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm,
     &    perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &    root, opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr, dblarr, icntl,keep,keep8,dkeep,nd, frere_steps,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere, .true. 
     &               , lrgroups
     &      )
        IF ( iflag .LT. 0 ) GOTO 600
       END  DO
      ENDIF
        set_irecv = .true.
        blocking  = .false.
        message_received = .true.
        CALL zmumps_try_recvtreat( comm_load, ass_irecv,
     &    blocking, set_irecv, message_received,
     &    mpi_any_source, mpi_any_tag, 
     &    status,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm,
     &    perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &    root, opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere_steps,
     &    lptrar, nelt, frtptr, frtelt,
     &    istep_to_iniv2, tab_pos_in_pere, .true. 
     &               , lrgroups
     &    )
      ioldps = ptrist(step(inode))
      CALL zmumps_dm_set_dynptr( iw(ioldps+xxs), a, la,
     &     ptrast(step(inode)), iw(ioldps+xxd), iw(ioldps+xxr),
     &     a_ptr, poselt, la_ptr )
      lcont1 = iw( ioldps + keep(ixsz))
      nass1  = iw( ioldps + 1 + keep(ixsz))
      compress_panel = (iw(ioldps+xxlr).GE.2)
      oocwrite_compatible_with_blr = 
     &          ( .NOT.lr_activated.OR.  (.NOT.compress_panel).OR.
     &            (keep(486).NE.2) 
     &          )
      IF ( nass1 < 0 ) THEN
        nass1 = -nass1
        iw( ioldps + 1 + keep(ixsz)) = nass1
        IF (keep(55) .EQ. 0) THEN 
          CALL zmumps_asm_slave_arrowheads(inode, n, iw, liw,
     &       ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
     &       fils, ptraiw,
     &       ptrarw, intarr, dblarr, keep8(27), keep8(26), rhs_mumps, 
     &       lrgroups)
        ELSE
          CALL zmumps_asm_slave_elements(inode, n, nelt, iw, liw,
     &       ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
     &       fils, ptraiw,
     &       ptrarw, intarr, dblarr, keep8(27), keep8(26),
     &       frtptr, frtelt, rhs_mumps, lrgroups)
        ENDIF
      ENDIF
      nrow1  = iw( ioldps + 2 +keep(ixsz))
      npiv1  = iw( ioldps + 3 +keep(ixsz))
      nslav1 = iw( ioldps + 5 + keep(ixsz))
      hs     = 6 + nslav1 + keep(ixsz)
      ncol1  = lcont1 + npiv1
      IF (npiv.GT.0) THEN
        ict11 = ioldps+hs+nrow1+npiv1 - 1
          DO i = 1, npiv
            IF (iw(ipiv+i-1).EQ.i) cycle
            isw = iw(ict11+i)
            iw(ict11+i) = iw(ict11+iw(ipiv+i-1))
            iw(ict11+iw(ipiv+i-1)) = isw
            ipos = poselt + int(npiv1 + i - 1,8)
            kpos = poselt + int(npiv1 + iw(ipiv+i-1) - 1,8)
            CALL zswap(nrow1, a_ptr(ipos), ncol1, a_ptr(kpos), ncol1)
          ENDDO
        lpos2 = poselt + int(npiv1,8)
        lpos  = lpos2 + int(npiv,8)
        IF ((.NOT. lr_activated).OR.keep(475).EQ.0) THEN
              CALL ztrsm('L','L','N','N', npiv, nrow1, one,
     &             a(posblocfacto), ld_blocfacto,
     &             a_ptr(lpos2), ncol1)
        ENDIF
      ENDIF 
      compress_cb = .false.
      IF ( lr_activated) THEN 
        compress_cb    = ((iw(ioldps+xxlr).EQ.1).OR.
     &                    (iw(ioldps+xxlr).EQ.3))
        IF (compress_cb.AND.npiv.EQ.0) THEN
           compress_cb = .false.
           iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
        ENDIF
        IF (npiv.NE.0) THEN
        IF ( (npiv1.EQ.0) 
     &     ) THEN
          ioldps = ptrist(step(inode))
          CALL get_cut(iw(ioldps+hs:ioldps+hs+nrow1-1), 0,
     &                    nrow1, lrgroups, npartscb, 
     &                    npartsass, begs_blr_l)
          CALL regrouping2(begs_blr_l, npartsass, 0, npartscb,
     &                        nrow1-0, keep(488), .true., keep(472))
          nb_blr_l =  npartscb
          IF (ipanel.EQ.1) THEN
           begs_blr_col=>begs_blr_u
          ELSE
           ALLOCATE(begs_blr_col(size(begs_blr_u)+ipanel-1),
     &               stat=allocok)
           IF (allocok > 0 ) THEN
               iflag = -13
               ierror = size(begs_blr_u)+ipanel-1
               lp = icntl(1)
               IF (icntl(4) .LE. 0) lp=-1
               IF (lp > 0) WRITE(lp,*) myid,
     &           ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO'
               GOTO 700
            ENDIF
            begs_blr_col(1:ipanel-1) = 1
            DO i=1,size(begs_blr_u)
               begs_blr_col(ipanel+i-1) =  begs_blr_u(i)
            ENDDO
          ENDIF
          info_tmp(1) = iflag
          info_tmp(2) = ierror
          IF (iflag.LT.0) GOTO 700
          CALL zmumps_blr_save_init(iw(ioldps+xxf), 
     &           .false.,       
     &           .true.,        
     &           .true.,        
     &           npartsass_master, 
     &           begs_blr_l, 
     &           begs_blr_col, 
     &           huge(npartsass_master),
     &           info_tmp)
          iflag  = info_tmp(1) 
          ierror = info_tmp(2) 
          IF (ipanel.NE.1) THEN
            DEALLOCATE(begs_blr_col)
          ENDIF
          IF (iflag.LT.0) GOTO 700
        ELSE           
          CALL zmumps_blr_retrieve_begs_blr_l (iw(ioldps+xxf), 
     &                  begs_blr_l)
          keep_begs_blr_l = .true.  
          nb_blr_l  = size(begs_blr_l) - 2
          npartsass = 1
          npartscb  = nb_blr_l
        ENDIF 
      ENDIF
      ENDIF
      IF ( (npiv .GT. 0)
     &   ) THEN
        IF (lr_activated) THEN
        call max_cluster(begs_blr_l,nb_blr_l+1,maxi_cluster_l)
        call max_cluster(begs_blr_u,nb_blr_u+1,maxi_cluster_u)
        IF (lastbl.AND.compress_cb) THEN
          maxi_cluster=max(maxi_cluster_u+nelim,maxi_cluster_l)
        ELSE
          maxi_cluster=max(maxi_cluster_u,maxi_cluster_l)
        ENDIF
        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 = maxi_cluster*omp_num*maxi_cluster
     &          + 2*maxi_cluster*omp_num
     &          + maxi_cluster*omp_num
     &          + maxi_cluster*omp_num
     &          + lwork*omp_num
           lp = icntl(1)
           IF (icntl(4) .LE. 0) lp=-1
           IF (lp > 0) WRITE(lp,*) myid,
     &          ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO'
           GOTO 700
        ENDIF
        current_blr=1 
        ALLOCATE(blr_l(nb_blr_l), stat=allocok)
        IF (allocok > 0 ) THEN
              iflag = -13
              ierror = nb_blr_l
              lp = icntl(1)
              IF (icntl(4) .LE. 0) lp=-1
              IF (lp > 0) WRITE(lp,*) myid,
     &             ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO'
              GOTO 700
           ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
        CALL zmumps_compress_panel_i_noopt
     &        (a_ptr(poselt), la_ptr, 1_8,
     &        iflag, ierror, ncol1,
     &        begs_blr_l(1), size(begs_blr_l), nb_blr_l+1,
     &        dkeep(8), keep(466), keep(473),
     &        blr_l(1), 
     &        current_blr, 'V', work, tau, jpvt, lwork, rwork,
     &        block, maxi_cluster, nelim, 
     &        .true.,  
     &        npiv, npiv1,
     &        2, keep(483), keep8,
     &        omp_num )
#if defined(BLR_MT)
!$OMP MASTER
#endif
        IF ( (keep(486).EQ.2) 
     &     ) THEN
          CALL zmumps_blr_save_panel_loru (
     &         iw(ioldps+xxf),
     &         0, 
     &         ipanel, blr_l)
        ENDIF
#if defined(BLR_MT)          
!$OMP END MASTER
!$OMP BARRIER
#endif
          IF (iflag.LT.0) GOTO 300
          IF (keep(475).GE.1) THEN
              CALL zmumps_blr_panel_lrtrsm(a, la, posblocfacto, 
     &              ld_blocfacto, -6666, 
     &              nb_blr_l+1,  
     &              blr_l, current_blr, current_blr+1, nb_blr_l+1, 
     &              2, 0, 0,  
     &              .true.) 
#if defined(BLR_MT)          
!$OMP BARRIER
#endif          
            IF (keep(486).NE.2) THEN
              CALL zmumps_decompress_panel_i_noopt(
     &        a_ptr(poselt), la_ptr, 1_8,
     &        ncol1, ncol1,
     &        .true.,    
     &        npiv1+1,   
     &        1,         
     &        nb_blr_l+1, blr_l(1), current_blr, 'V', 1)
            ENDIF
          ENDIF
 300      CONTINUE
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
          IF (iflag.LT.0) GOTO 700
        ENDIF
      ENDIF
      IF ( (keep(201).eq.1) .AND. 
     &    (oocwrite_compatible_with_blr .OR. npiv.EQ.0) ) THEN
        monbloc%INODE = inode
        monbloc%MASTER = .false.
        monbloc%Typenode = 2
        monbloc%NROW = nrow1
        monbloc%NCOL = ncol1  
        monbloc%NFS  = nass1
        monbloc%LastPiv = npiv1 + npiv 
        monbloc%LastPanelWritten_L = -9999 
        monbloc%LastPanelWritten_U = -9999 
        NULLIFY(monbloc%INDICES)
        monbloc%Last = lastbl
        strat = strat_try_write 
        nextpivdummy      = -8888 
        liwfac = iw(ioldps+xxi)
        last_call = .false.
        CALL zmumps_ooc_io_lu_panel_i( strat, typef_l,
     &       a_ptr(poselt),
     &       la_ptr, monbloc, nextpivdummy, nextpivdummy,
     &       iw(ioldps), liwfac, myid, keep8(31), iflag,last_call)
      ENDIF
      IF ( (npiv .GT. 0)
     &   ) THEN
        IF (lr_activated) THEN
          IF (nelim.GT.0) THEN
            upos = 1_8+int(npiv,8)
              CALL zmumps_blr_upd_nelim_var_l_i(
     &        a(posblocfacto), la_blocfacto, upos,
     &        a_ptr(poselt), la_ptr, lpos-poselt+1_8,
     &        iflag, ierror, ld_blocfacto, ncol1,
     &        begs_blr_l(1), size(begs_blr_l),
     &        current_blr, blr_l(1), nb_blr_l+1, 
     &        current_blr+1, nelim, 'N')
          ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
         CALL zmumps_blr_update_trailing_i(
     &        a_ptr(poselt), la_ptr, 1_8, 
     &        iflag, ierror, ncol1,
     &        begs_blr_l(1), size(begs_blr_l),
     &        begs_blr_u(1), size(begs_blr_u), current_blr, 
     &        blr_l(1), nb_blr_l+1, 
     &        blr_u(1), nb_blr_u+1, 
     &        0,      
     &        .true., 
     &        npiv1,  
     &        2, 0, 
     &        keep(481), dkeep(11), keep(466), keep(477) 
     &        )
#if defined(BLR_MT)          
!$OMP END PARALLEL
#endif          
          IF (iflag.LT.0) GOTO 700
        ELSE 
              upos = posblocfacto+int(npiv,8)
              CALL zgemm('N','N', ncol-npiv, nrow1, npiv,
     &             alpha,a(upos), ncol,
     &             a_ptr(lpos2), ncol1, one, a_ptr(lpos), ncol1)
        ENDIF 
      ENDIF 
      iw(ioldps+keep(ixsz) ) = iw(ioldps+keep(ixsz) ) - npiv
      iw(ioldps + 3+keep(ixsz) ) = iw(ioldps+3+keep(ixsz) ) + npiv
      IF (lastbl) THEN
        iw(ioldps+1+keep(ixsz) ) = iw(ioldps + 3+keep(ixsz) )
      ENDIF
      IF ( .not. lastbl .AND. 
     &   (iw(ioldps+1+keep(ixsz)) .EQ. iw(ioldps + 3+keep(ixsz))) ) THEN
        write(*,*) 'Internal ERROR 1 **** IN BLACFACTO '
        CALL mumps_abort()
      ENDIF
      IF (lr_activated) THEN
        IF ((npiv.GT.0)
     &     ) THEN
          CALL dealloc_blr_panel( blr_u, nb_blr_u, keep8, keep(34))
          DEALLOCATE(blr_u)
          IF (keep(486).EQ.3) THEN
            CALL dealloc_blr_panel( blr_l, nb_blr_l, keep8, keep(34))
            DEALLOCATE(blr_l)
          ELSE
            CALL upd_mry_lu_lrgain(blr_l, npartscb
     &               )
          ENDIF
      ENDIF 
      ENDIF 
        lrlu  = lrlu + la_blocfacto
        lrlus = lrlus + la_blocfacto
        keep8(69) = keep8(69) - la_blocfacto
        posfac = posfac - la_blocfacto
        CALL zmumps_load_mem_update(.false.,.false.,
     &             la-lrlus,0_8,-la_blocfacto,keep,keep8,lrlus)
        iwpos = iwpos - npiv
      flop1 = dble( npiv1*nrow1 ) +
     &        dble(nrow1*npiv1)*dble(2*ncol1-npiv1-1)
     &   -
     &        dble((npiv1+npiv)*nrow1 ) -
     &        dble(nrow1*(npiv1+npiv))*dble(2*ncol1-npiv1-npiv-1)
      CALL zmumps_load_update( 1, .false., flop1, keep,keep8 )
      IF (lastbl) THEN
        IF (keep(486).NE.0) THEN
          IF (lr_activated) THEN
            CALL stats_compute_flop_slave_type2(nrow1, ncol1, nass1,
     &              keep(50), inode)
          ELSE
            CALL upd_flop_frfront_slave(nrow1, ncol1, nass1,
     &              keep(50), inode)
          ENDIF
        ENDIF
       IF (lr_activated) THEN
         IF (compress_cb) THEN
           CALL zmumps_blr_retrieve_begs_blr_c (iw(ioldps+xxf), 
     &                  begs_blr_col, npartsass_master_aux)
           begs_blr_col(1+npartsass_master) = 
     &               begs_blr_col(1+npartsass_master) - nelim
           nb_blr_col = size(begs_blr_col) - 1
           IF (npiv.EQ.0) THEN
             call max_cluster(begs_blr_l,nb_blr_l+1,maxi_cluster_l)
             call max_cluster(begs_blr_col,nb_blr_col,maxi_cluster_col)
             IF (compress_cb) THEN
              maxi_cluster=max(maxi_cluster_col+nelim,maxi_cluster_l)
             ELSE
              maxi_cluster=max(maxi_cluster_col,maxi_cluster_l)
             ENDIF
             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 = maxi_cluster*omp_num*maxi_cluster
     &           + 2*maxi_cluster*omp_num
     &           + maxi_cluster*omp_num
     &           + maxi_cluster*omp_num
     &           + lwork*omp_num
               lp = icntl(1)
               IF (icntl(4) .LE. 0) lp=-1
               IF (lp > 0) WRITE(lp,*) myid,
     &          ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO'
               GOTO 700
             ENDIF
           ENDIF
           allocate(cb_lrb(nb_blr_l,nb_blr_col-npartsass_master),
     &                 stat=allocok)
           IF (allocok > 0) THEN
             iflag  = -13
             ierror = nb_blr_l*(nb_blr_col-npartsass_master)
             GOTO 700
           ENDIF
           CALL zmumps_blr_save_cb_lrb(iw(ioldps+xxf),cb_lrb)
         ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
         IF (compress_cb) THEN
           CALL zmumps_compress_cb_i(
     &      a_ptr(poselt), la_ptr, 1_8, ncol1,
     &      begs_blr_l(1), size(begs_blr_l),
     &      begs_blr_col(1), size(begs_blr_col),
     &      nb_blr_l, nb_blr_col-npartsass_master,
     &      npartsass_master, 
     &      nrow1, ncol1-npiv1-npiv, inode,
     &      iw(ioldps+xxf), 0, 2, iflag, ierror,
     &      dkeep(12), keep(466), keep(484), keep(489),
     &      cb_lrb(1,1),
     &      work, tau, jpvt, lwork, rwork, block,
     &      maxi_cluster, keep8, omp_num,
     &      -9999, -9999, -9999, keep(1),
     &      idummy, 0, -9999 )
#if defined(BLR_MT)
!$OMP BARRIER
#endif
         ENDIF
#if defined(blr_mt)          
!$OMP END PARALLEL
#endif
         IF (iflag.LT.0) GOTO 700
       ENDIF
         CALL zmumps_end_facto_slave(
     &    comm_load, ass_irecv, 
     &    n, inode, fpere, 
     &    root, 
     &    myid, comm,
     &    
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
     &    ptrist, ptlust_s, ptrfac, ptrast, step, pimaster,
     &    pamaster,
     &    nstk_s, comp, iflag, ierror, perm,
     &    ipool, lpool, leaf, nbfin, slavef,
     &    opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw,
     &    intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere_steps,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &     )
      ENDIF 
      IF (lr_activated) THEN
        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(begs_blr_l)) THEN
            IF (.NOT. keep_begs_blr_l) DEALLOCATE(begs_blr_l)
        ENDIF
        IF ((npiv.GT.0)
     &     ) THEN
          IF (associated(begs_blr_u)) DEALLOCATE(begs_blr_u)
        ENDIF
      ENDIF
 600  CONTINUE
      RETURN
 700  CONTINUE
      CALL zmumps_bdc_error( myid, slavef, comm, keep )
      RETURN
      END SUBROUTINE zmumps_process_blocfacto
      SUBROUTINE zmumps_mpi_unpack_lr(
     &           BUFR, LBUFR, LBUFR_BYTES, POSITION,
     &                             NPIV, NELIM, DIR, 
     &                             BLR_U, NB_BLOCK_U,
     &                             BEGS_BLR_U, KEEP8,
     &                             COMM, IERR, IFLAG, IERROR)
      USE zmumps_lr_core, ONLY : lrb_type, alloc_lrb
      USE zmumps_lr_type
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: LBUFR
      INTEGER, INTENT(IN) :: LBUFR_BYTES
      INTEGER, INTENT(IN) :: BUFR(LBUFR)
      INTEGER, INTENT(INOUT) :: POSITION
      INTEGER, INTENT(IN)    :: NB_BLOCK_U, NELIM, NPIV
      CHARACTER(len=1) :: DIR
      INTEGER, INTENT(IN) :: COMM
      INTEGER, INTENT(INOUT) :: IFLAG, IERROR
      INTEGER, INTENT(OUT) :: IERR
      TYPE (LRB_TYPE), INTENT(OUT), 
     &          DIMENSION(max(NB_BLOCK_U,1)):: blr_u
      INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2)  :: BEGS_BLR_U 
      INTEGER(8) :: KEEP8(150)
      LOGICAL :: ISLR
      INTEGER :: ISLR_INT, I
      INTEGER :: K, M, N
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      IERR = 0
      IF (size(blr_u) .NE. 
     &     max(nb_block_u,1) ) THEN
        WRITE(*,*) "Internal error 1 in ZMUMPS_MPI_UNPACK",
     &             nb_block_u,size(blr_u)
        CALL mumps_abort()
      ENDIF
      begs_blr_u(1) = 1
      begs_blr_u(2) = npiv+nelim+1 
      DO i = 1, nb_block_u
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 islr_int, 1, mpi_integer, comm, ierr )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 k, 1,
     &                 mpi_integer, comm, ierr )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 m, 1,
     &                 mpi_integer, comm, ierr )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 n, 1,
     &                 mpi_integer, comm, ierr )
        begs_blr_u(i+2) = begs_blr_u(i+1) + m
        IF (islr_int .eq. 1) THEN
          islr = .true.
        ELSE
          islr = .false.
        ENDIF
        CALL alloc_lrb( blr_u(i), k, m, n, islr, 
     &             iflag, ierror, keep8 )
        IF (iflag.LT.0) RETURN
        IF (islr) THEN
          IF (k .GT. 0) THEN
            CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                     blr_u(i)%Q(1,1), m*k, mpi_double_complex,
     &                     comm, ierr )
            CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                     blr_u(i)%R(1,1), n*k, mpi_double_complex,
     &                     comm, ierr)
          ENDIF
        ELSE
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                     blr_u(i)%Q(1,1), m*n, mpi_double_complex,
     &                     comm, ierr)
        ENDIF
      ENDDO
      RETURN
      END SUBROUTINE zmumps_mpi_unpack_lr