sfac_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 smumps_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 smumps_ooc, ONLY : io_block
      USE mumps_ooc_common, ONLY : typef_l, strat_try_write
      USE smumps_load
      USE smumps_lr_core
      USE smumps_lr_type
      USE smumps_lr_stats
      USE smumps_fac_lr
      USE smumps_ana_lr, ONLY : get_cut
      USE smumps_lr_data_m
      USE smumps_struc_def, ONLY : smumps_root_struc
      USE smumps_dynamic_memory_m, ONLY : smumps_dm_set_dynptr
!$    USE OMP_LIB
      IMPLICIT NONE
      include 'mumps_headers.h'
      TYPE (smumps_root_struc) :: root
      INTEGER icntl( 60 ), keep( 500 )
      INTEGER(8) keep8(150)
      REAL 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 )
      REAL 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))
      REAL :: 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) )
      REAL 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
      REAL, 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
      REAL one,alpha
      parameter(one = 1.0e0, alpha=-1.0e0)
      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
      REAL, ALLOCATABLE, DIMENSION(:) :: work, tau
      INTEGER, ALLOCATABLE, DIMENSION(:) :: jpvt
      REAL,ALLOCATABLE,DIMENSION(:) :: rwork
      REAL, 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 smumps_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 smumps_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_real,
     &                 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 SMUMPS_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 SMUMPS_PROCESS_BLOCFACTO'
               GOTO 700
            ENDIF
            CALL smumps_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_real,
     &                 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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 smumps_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 sswap(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 strsm('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 SMUMPS_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 smumps_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 smumps_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 SMUMPS_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 SMUMPS_PROCESS_BLOCFACTO'
              GOTO 700
           ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
        CALL smumps_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 smumps_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 smumps_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 smumps_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          
.LT.          IF (IFLAG0) GOTO 700
        ENDIF
      ENDIF
.eq..AND.      IF ( (KEEP(201)1)  
.OR..EQ.     &    (OOCWRITE_COMPATIBLE_WITH_BLR  NPIV0) ) 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 SMUMPS_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
.GT.      IF ( (NPIV  0)
     &   ) THEN
        IF (LR_ACTIVATED) THEN
.GT.          IF (NELIM0) THEN
            UPOS = 1_8+int(NPIV,8)
              CALL SMUMPS_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 SMUMPS_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          
.LT.          IF (IFLAG0) GOTO 700
        ELSE 
              UPOS = POSBLOCFACTO+int(NPIV,8)
              CALL sgemm('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
.not..AND.      IF (  LASTBL  
.EQ.     &   (IW(IOLDPS+1+KEEP(IXSZ))  IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN
        write(*,*) 'internal error 1 **** in blacfacto '
        CALL MUMPS_ABORT()
      ENDIF
      IF (LR_ACTIVATED) THEN
.GT.        IF ((NPIV0)
     &     ) THEN
          CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, KEEP(34))
          DEALLOCATE(BLR_U)
.EQ.          IF (KEEP(486)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 SMUMPS_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 SMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 )
      IF (LASTBL) THEN
.NE.        IF (KEEP(486)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 SMUMPS_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
.EQ.           IF (NPIV0) 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)
.LE.               IF (ICNTL(4)  0) LP=-1
               IF (LP > 0) WRITE(LP,*) MYID,
     &          ': error allocation during smumps_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 SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB)
         ENDIF
#if defined(BLR_MT)          
!$OMP PARALLEL
#endif
         IF (COMPRESS_CB) THEN
           CALL SMUMPS_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
.LT.         IF (IFLAG0) GOTO 700
       ENDIF
         CALL SMUMPS_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
.NOT.            IF ( KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L)
        ENDIF
.GT.        IF ((NPIV0)
     &     ) THEN
          IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U)
        ENDIF
      ENDIF
 600  CONTINUE
      RETURN
 700  CONTINUE
      CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
      RETURN
      END SUBROUTINE SMUMPS_PROCESS_BLOCFACTO
      SUBROUTINE SMUMPS_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 SMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB
      USE SMUMPS_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
.NE.      IF (size(BLR_U)  
     &     MAX(NB_BLOCK_U,1) ) THEN
        WRITE(*,*) "Internal error 1 in SMUMPS_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
.eq.        IF (ISLR_INT  1) THEN
          ISLR = .TRUE.
        ELSE
          ISLR = .FALSE.
        ENDIF
        CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, 
     &             IFLAG, IERROR, KEEP8 )
.LT.        IF (IFLAG0) RETURN
        IF (ISLR) THEN
.GT.          IF (K  0) THEN
            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                     BLR_U(I)%Q(1,1), M*K, MPI_REAL,
     &                     COMM, IERR )
            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                     BLR_U(I)%R(1,1), N*K, MPI_REAL,
     &                     COMM, IERR)
          ENDIF
        ELSE
          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
     &                     BLR_U(I)%Q(1,1), M*N, MPI_REAL,
     &                     COMM, IERR)
        ENDIF
      ENDDO
      RETURN
      END SUBROUTINE SMUMPS_MPI_UNPACK_LR