C
C  This file is part of MUMPS 5.8.1, released
C  on Wed Jul 30 16:49:18 UTC 2025
C
C
C  Copyright 1991-2025 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
      SUBROUTINE CMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM,
     & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, 
     & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR,
     & PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR, PTRIST,
     & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL,
     &  CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF,
     & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES,
     & CMUMPS_LBUF, INTARR, DBLARR, root, roota,  NELT, FRTPTR, FRTELT,
     & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB,
     & DKEEP, PIVNUL_LIST_STRUCT, LRGROUPS
     & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP,
     & LPOOL_A_L0_OMP, L_VIRT_L0_OMP, VIRT_L0_OMP,
     & VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP, PERM_L0_OMP,
     & PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING, THREAD_LA,
     & L0_OMP_FACTORS, LL0_OMP_FACTORS, I4_L0_OMP, NBSTATS_I4,
     & NBCOLS_I4, I8_L0_OMP, NBSTATS_I8, NBCOLS_I8
     &     )
      USE MUMPS_LOAD 
      USE MUMPS_BUF_COMMON, ONLY : MUMPS_BUF_ALLOC_CB,
     &                             MUMPS_BUF_DEALL_CB
      USE CMUMPS_BUF, ONLY : CMUMPS_BUF_MAX_ARRAY_MINSIZE
     &                     , CMUMPS_BUF_DEALL_MAX_ARRAY
      USE CMUMPS_FAC_S_IS_POINTERS_M, ONLY : CMUMPS_S_IS_POINTERS_T
      USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T
      USE OMP_LIB
      USE MUMPS_TPS_M
      USE CMUMPS_TPS_M
      USE CMUMPS_FAC_OMP_M
      USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_ALLOC_S_WK,
     &                                   CMUMPS_DM_FREE_S_WK
      USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC
      USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC
     &                            , CMUMPS_L0OMPFAC_T
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      TYPE (MUMPS_ROOT_STRUC) :: root
      TYPE (CMUMPS_ROOT_STRUC) :: roota
      INTEGER(8) :: LA
      INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES
      INTEGER MYID, MYID_NODES,LNA
      TYPE (CMUMPS_S_IS_POINTERS_T) :: S_IS_POINTERS
      REAL RINFO(40)
      INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES
      INTEGER :: BUFR( LBUFR )
      INTEGER, INTENT( IN ) :: CMUMPS_LBUF
      INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB
      INTEGER NELT, LDPTRAR
      INTEGER FRTPTR(*), FRTELT(*)
      REAL CNTL1
      INTEGER   ICNTL(60)
      INTEGER   INFO(80), KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER LRGROUPS(KEEP(280))
      INTEGER   SYM_PERM(N), NA(LNA),
     &          NE_STEPS(KEEP(28)), FILS(N),
     &          FRERE(KEEP(28)), NFSIZ(KEEP(28)), 
     &          DAD(KEEP(28))
      INTEGER   CAND(SLAVEF+1, max(1,KEEP(56)))
      INTEGER   STEP(N)
      INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2)
      INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193))
      INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194))
      INTEGER, INTENT(IN) :: NINROWARR(KEEP(195))
      INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER   PTRIST(KEEP(28)), PTLUST_S(KEEP(28))
      INTEGER   IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL)
      COMPLEX :: RHS_MUMPS(KEEP8(85))
      INTEGER(8) :: IW2(2*KEEP(28))
      INTEGER   PROCNODE_STEPS(KEEP(28))
      INTEGER   COMM_LOAD, ASS_IRECV
      INTEGER   ISTEP_TO_INIV2(KEEP(71)), 
     &          TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
      COMPLEX   DBLARR(KEEP8(26))
      INTEGER   INTARR(KEEP8(27))
      REAL SEUIL, SEUIL_LDLT_NIV2
      TYPE(PIVNUL_LIST_STRUCT_T)     :: PIVNUL_LIST_STRUCT
      REAL DKEEP(230)
      INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP
      INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP )
      INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP
      INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP )
      INTEGER, INTENT (IN) :: L_PHYS_L0_OMP
      INTEGER, INTENT (IN) :: PHYS_L0_OMP( L_PHYS_L0_OMP )
      INTEGER, INTENT (IN) :: L_VIRT_L0_OMP
      INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP )
      INTEGER, INTENT (IN) :: VIRT_L0_OMP_MAPPING( L_VIRT_L0_OMP )
      INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP )
      INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1)
      INTEGER, INTENT (IN) :: LL0_OMP_MAPPING
      INTEGER, INTENT (OUT):: L0_OMP_MAPPING( LL0_OMP_MAPPING )
      INTEGER, INTENT (IN) :: LL0_OMP_FACTORS
      TYPE(CMUMPS_L0OMPFAC_T), INTENT (INOUT) :: L0_OMP_FACTORS(
     &                                           LL0_OMP_FACTORS )
      INTEGER, INTENT (IN) :: NBSTATS_I4, NBSTATS_I8
      INTEGER, INTENT (IN) :: NBCOLS_I4, NBCOLS_I8
      INTEGER, INTENT (IN) :: I4_L0_OMP(NBSTATS_I4, NBCOLS_I4)
      INTEGER(8), INTENT (IN) :: I8_L0_OMP(NBSTATS_I8, NBCOLS_I8)
      INTEGER(8), INTENT ( IN ) :: THREAD_LA
       INTEGER, EXTERNAL :: MUMPS_PROCNODE
      INTEGER allocok
      REAL UULOC
      INTEGER IERR
      INTEGER LP, MPRINT
      LOGICAL LPOK
      INTEGER NSTK,PTRAST
      INTEGER PIMASTER, PAMASTER
      LOGICAL PROK
      REAL,PARAMETER :: ZERO = 0.0E0
      INTEGER I
      INTEGER LTPS_ARR
      TYPE (MUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: MUMPS_TPS_ARR
      TYPE (CMUMPS_TPS_T), DIMENSION(:), ALLOCATABLE :: CMUMPS_TPS_ARR
      INTEGER NBROOT_UNDER_L0
      INTEGER :: NSTEPSDONE
      DOUBLE PRECISION :: OPASS, OPELI
      INTEGER :: NELVA, COMP
      INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV, NULLNEGPV
      INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN
      COMPLEX :: DET_MANT
      INTEGER :: NTOTPVTOT
      INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS
      INTEGER IWPOS, LEAF, NBROOT, NROOT
      INTEGER    :: LIW_ARG_FAC_PAR
      INTEGER(8) :: LA_ARG_FAC_PAR
      COMPLEX, TARGET:: CDUMMY(1)
      INTEGER, TARGET :: IDUMMY(1)
      LOGICAL :: IW_DUMMY, A_DUMMY,
     &           IW_ALLOCATED_HERE, A_ALLOCATED_HERE
      KEEP(41)=0
      KEEP(42)=0
      LP     = ICNTL(1)
      LPOK   = (LP.GT.0) .AND. (ICNTL(4).GE.1)
      MPRINT = ICNTL(2)
      PROK   = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2)
      UULOC = CNTL1
      PIMASTER   = 1
      NSTK       = PIMASTER + KEEP(28)
      PTRAST = 1
      PAMASTER = 1 + KEEP(28)
      IF (KEEP(4).LE.0) KEEP(4)=32
      IF (KEEP(5).LE.0) KEEP(5)=16
      IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4)
      IF (KEEP(6).LE.0) KEEP(6)=24
      IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2
      IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3)
      POSFAC = 1_8
      IWPOS  = 1
      LRLU = LA
      LRLUS = LRLU
      KEEP8(62) = 0_8
      KEEP8(63) = 0_8
      KEEP8(64) = 0_8
      KEEP8(65) = 0_8
      KEEP8(66) = 0_8
      KEEP8(68) = 0_8
      KEEP8(69) = 0_8
      KEEP8(70) = 0_8
      KEEP8(71) = 0_8
      KEEP8(73) = 0_8
      KEEP8(74) = 0_8
      IPTRLU = LRLU
      DKEEP(19)=huge(0.0E0)
      DKEEP(20)=huge(0.0E0)
      DKEEP(21)=0.0E0
      NSTEPSDONE = 0
      OPASS      = 0.0D0
      OPELI      = 0.0D0
      NELVA      = 0
      COMP       = 0
      MAXFRT     = 0  
      NMAXNPIV   = 0
      NTOTPV     = 0
      NOFFNEGPV  = 0
      NULLNEGPV  = 0
      NB22T1     = 0  
      NB22T2     = 0  
      NBTINY     = 0  
      DET_EXP    = 0
      DET_SIGN   = 1
      DET_MANT   = cmplx(1.0E0,0.0E0, kind=kind(1.0E0))
      IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28))
      CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT,
     &                     MYID_NODES,
     &                     SLAVEF, NA, LNA,
     &                     KEEP, STEP,
     &                     PROCNODE_STEPS)
      IF (KEEP(400) .GT. 0
     &   ) THEN
         IF (LPOOL .NE. LPOOL_A_L0_OMP) THEN
          WRITE(*,*) "Check LPOOL vs. LPOOL_A_L0_OMP",
     &    LPOOL, LPOOL_A_L0_OMP, KEEP(28)
          CALL MUMPS_ABORT()
        ENDIF
        DO I = 1, LPOOL
          POOL(I) = IPOOL_A_L0_OMP(I)
        ENDDO
      ELSE
        CALL MUMPS_INIT_POOL_DIST(N, LEAF,
     &                     MYID_NODES,
     &                     SLAVEF, NA, LNA,
     &                     KEEP,KEEP8, STEP,
     &                     PROCNODE_STEPS,
     &                     POOL, LPOOL)
        CALL CMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF)     
      ENDIF  
      CALL MUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8)
      IF ( KEEP( 38 ) .NE. 0 ) THEN
        NBROOT = NBROOT + root%NPROW * root%NPCOL - 1
      END IF
      IF ( root%yes )  THEN 
         IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))),
     &                                       KEEP(199) )
     &         .NE. MYID_NODES ) THEN
             NROOT = NROOT + 1
         END IF
      END IF
      PTRIST(1:KEEP(28))=0
      PTLUST_S(1:KEEP(28))=0
      PTRFAC(1:KEEP(28))=-99999_8
      IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8
      IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8
      KEEP(405) = 0
      NBROOT_UNDER_L0 = 0
      IF (KEEP(400).GT.0
     &   ) THEN
        KEEP(405)=1
        ALLOCATE( MUMPS_TPS_ARR( KEEP(400) ), stat=allocok )
        IF (allocok .GT. 0) THEN
          IF (LPOK) THEN
            WRITE(LP,*) "Problem allocating MUMPS_TPS_ARR",
     &                KEEP(400) 
          ENDIF
          CALL MUMPS_ABORT()
        ENDIF
        ALLOCATE( CMUMPS_TPS_ARR( KEEP(400) ), stat=allocok )
        IF (allocok .GT. 0) THEN
          WRITE(*,*) "Problem allocating CMUMPS_TPS_ARR", KEEP(400)
          CALL MUMPS_ABORT()
        ENDIF
        CALL CMUMPS_FAC_L0_OMP(N,LIW, IW1(NSTK), NFSIZ, FILS,STEP,FRERE,
     &  DAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRIST, IW2(PTRAST),
     &  IW1(PIMASTER), IW2(PAMASTER), PTRAR(1,2), PTRAR(1,1), 
     &  PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR,
     &  ITLOC, RHS_MUMPS, RINFO, NROOT, NBROOT, NBROOT_UNDER_L0,
     &  UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8,
     &  PROCNODE_STEPS,SLAVEF, COMM_NODES, MYID, MYID_NODES, BUFR,
     &  LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,SYM_PERM,NELT,FRTPTR,
     &  FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2,
     &  MEM_DISTRIB, NE_STEPS, DKEEP, PIVNUL_LIST_STRUCT,
     &  LPOOL_B_L0_OMP, IPOOL_B_L0_OMP, L_VIRT_L0_OMP,
     &  VIRT_L0_OMP, VIRT_L0_OMP_MAPPING, L_PHYS_L0_OMP, PHYS_L0_OMP,
     &  PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING,
     &  THREAD_LA, MUMPS_TPS_ARR, CMUMPS_TPS_ARR, NSTEPSDONE,
     &  OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV,
     &  NULLNEGPV, NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN,
     &  LRGROUPS(1), L0_OMP_FACTORS, LL0_OMP_FACTORS,
     &  I4_L0_OMP, NBSTATS_I4, NBCOLS_I4,
     &  I8_L0_OMP, NBSTATS_I8, NBCOLS_I8 )
        KEEP(405)=0
        DKEEP(16) = OPELI
        KEEP8(75)=KEEP8(76)
        KEEP8(63)=KEEP8(74)
        KEEP8(62) = KEEP8(74)-KEEP8(62)
        IF (INFO(1) .LT. 0) THEN
          KEEP8(69) = KEEP8(73)
        ENDIF
        KEEP8(74) = KEEP8(73)
        IF ((INFO(1).GE.0).AND.(KEEP8(74).GT.KEEP8(75))) THEN
          INFO(1) = -19
          CALL MUMPS_SET_IERROR (
     &             KEEP8(74)-KEEP8(75), INFO(2))
          IF (LPOK) THEN
            WRITE(LP,'(/A/,A,I8,A,I10/,A/,A/)')
     &     '** ERROR: memory allowed (ICNTL(23)) is not large enough:',
     &     '   INFO(1)=',  INFO(1), ' INFO(2)=',  INFO(2),
     &     '   memory used at the end of the treatment of L0 thread ',
     &     '   does not enable processing nodes above L0 thread '
          ENDIF
        ENDIF
        KEEP8(66) = KEEP8(68)
        KEEP8(65) = KEEP8(64) + KEEP8(71) 
      ENDIF
        KEEP8(67) = LRLUS
      IW_ALLOCATED_HERE = .FALSE.
      A_ALLOCATED_HERE  = .FALSE.
      IF (associated(S_IS_POINTERS%IW)) THEN
        WRITE(*,*) " Internal error CMUMPS_FAC_B IW"
        CALL MUMPS_ABORT()
      ENDIF
      IF (INFO(1) .GE. 0 ) THEN
        ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok)
        IF (allocok .GT.0) THEN
          INFO(1) = -13
          INFO(2) = LIW
          IF (LPOK) THEN
            WRITE(LP,*) 
     &     'Allocation error for id%IS(',LIW,') on worker',
     &      MYID_NODES
          ENDIF
        ELSE
          IW_ALLOCATED_HERE = .TRUE.
        ENDIF
      ENDIF
      IF (INFO(1) .GE. 0) THEN
        IF (.NOT. associated(S_IS_POINTERS%A)) THEN
          CALL CMUMPS_DM_ALLOC_S_WK(S_IS_POINTERS%A,
     &           LA, allocok, KEEP(430), KEEP(35) )
          IF (allocok .GT. 0) THEN
            INFO(1) = -13
            CALL MUMPS_SETI8TOI4(LA, INFO(2))
            DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW)
            IW_ALLOCATED_HERE = .FALSE.
            KEEP8(23)=0_8
          ELSE
            A_ALLOCATED_HERE = .TRUE.
            KEEP8(23)=LA
          ENDIF
        ENDIF
      ENDIF
      IF (INFO(1) .GE. 0) THEN
        CALL MUMPS_BUF_ALLOC_CB( CMUMPS_LBUF, IERR )
        IF ( IERR .NE. 0 ) THEN
          INFO(1)= -13
          INFO(2)= (CMUMPS_LBUF+KEEP(34)-1)/KEEP(34)
          IF (LPOK) THEN
            WRITE(LP,*) 
     &     'Allocation error in CMUMPS_BUF_ALLOC_CB'
     &     ,INFO(2), ' on worker', MYID_NODES
          ENDIF
        ELSE
          IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN
            CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR)
            IF (IERR .NE. 0) THEN
              INFO(1) = -13
              INFO(2) = max(KEEP(108),1)
            END IF
          ENDIF
        ENDIF
      ENDIF
      IF ( KEEP(400) .EQ. 0
     &   ) THEN
         LTPS_ARR = 1
         ALLOCATE( MUMPS_TPS_ARR(1))
         ALLOCATE(CMUMPS_TPS_ARR(1))
      ELSE
         LTPS_ARR = KEEP(400)
      ENDIF
      IW_DUMMY = .FALSE.;
      A_DUMMY  = .FALSE.;
      IF (INFO(1) .GE. 0) THEN
        LIW_ARG_FAC_PAR = LIW
        LA_ARG_FAC_PAR  = LA
      ELSE
        IF (IW_ALLOCATED_HERE) THEN
          DEALLOCATE(S_IS_POINTERS%IW)
          NULLIFY(S_IS_POINTERS%IW)
          IW_ALLOCATED_HERE = .FALSE.
        ENDIF
        IF (A_ALLOCATED_HERE) THEN
          CALL CMUMPS_DM_FREE_S_WK(S_IS_POINTERS%A, KEEP(430))
          NULLIFY(S_IS_POINTERS%A)
          A_ALLOCATED_HERE = .FALSE.
        ENDIF
        LIW_ARG_FAC_PAR = 1
        LA_ARG_FAC_PAR  = 1_8
        IF (.NOT. associated(S_IS_POINTERS%IW)) THEN
          S_IS_POINTERS%IW  => IDUMMY
          IW_DUMMY = .TRUE.
        ENDIF
        IF (.NOT. associated(S_IS_POINTERS%A)) THEN
          S_IS_POINTERS%A  => CDUMMY
          A_DUMMY  = .TRUE.
        ENDIF
      ENDIF
      IF ( INFO(1) .LT. 0 ) THEN
        CALL CMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP )
      ENDIF
      KEEP(398)=NSTEPSDONE
      CALL CMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR,
     & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), NFSIZ,FILS,STEP,
     & FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, NSTEPSDONE,
     & OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV,
     & NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN,
     & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER),
     & PTRAR(1,2), PTRAR(1,1), PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR,
     & ITLOC, RHS_MUMPS, POOL, LPOOL,
     & L0_OMP_MAPPING, LL0_OMP_MAPPING,
     & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, LTPS_ARR,
     & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT,
     & NBROOT_UNDER_L0,
     & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8,
     & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR,
     & LBUFR_BYTES, INTARR, DBLARR, root, roota, SYM_PERM, NELT, FRTPTR,
     & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2,
     & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST_STRUCT,
     & LRGROUPS(1) )
      IF (IW_DUMMY) THEN
        NULLIFY( S_IS_POINTERS%IW )
      ENDIF
      IF (A_DUMMY) THEN
        NULLIFY( S_IS_POINTERS%A )
      ENDIF
      IF ((KEEP(50).EQ.2).AND.(KEEP(219).NE.0)) THEN
        CALL CMUMPS_BUF_DEALL_MAX_ARRAY()
      ENDIF
      CALL MUMPS_BUF_DEALL_CB( IERR )
      RINFO(2)  = real(OPASS)
      RINFO(3)  = real(OPELI)
      INFO(13)  = NELVA
      INFO(14)  = COMP
      KEEP(33)  = MAXFRT; INFO(11)  = MAXFRT
      KEEP(246) = NMAXNPIV
      KEEP(89)  = NTOTPV; INFO(23)  = NTOTPV
      INFO(12)  = NOFFNEGPV
      INFO(40)  = NULLNEGPV
      KEEP(103) = NB22T1
      KEEP(105) = NB22T2
      KEEP(98)  = NBTINY
      IF (KEEP(258) .NE. 0) THEN
        KEEP(260) = KEEP(260) * DET_SIGN
        KEEP(259) = KEEP(259) + DET_EXP
        CALL CMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) )
      ENDIF
      IF (KEEP(400) .GT. 0
     &  ) THEN
        IF (LL0_OMP_FACTORS.NE.KEEP(400)) THEN
          WRITE(*,*) "Internal error in CMUMPS_FAC_B, KEEP(400), L..=",
     &    KEEP(400), LL0_OMP_FACTORS
          CALL MUMPS_ABORT()
        ENDIF
        IF ( INFO(1) .GE. 0 ) THEN
          CALL CMUMPS_L0OMP_COPY_IW(S_IS_POINTERS%IW,
     &    LIW, IWPOS, MUMPS_TPS_ARR, KEEP, PTLUST_S,
     &    ICNTL, INFO)
        ENDIF
!$OMP   PARALLEL DO
        DO I=1, KEEP(400)
          IF (INFO(1) .LT. 0) THEN
            IF ( associated( L0_OMP_FACTORS(I)%A ) ) THEN
              DEALLOCATE( L0_OMP_FACTORS(I)%A )
              NULLIFY   ( L0_OMP_FACTORS(I)%A )
              CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(
     &        -L0_OMP_FACTORS(I)%LA, .TRUE., 
     &        KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. )
            ENDIF
            L0_OMP_FACTORS(I)%LA  =  -99999_8
          ENDIF
          IF (associated(MUMPS_TPS_ARR(I)%IW)) THEN
            DEALLOCATE(MUMPS_TPS_ARR(I)%IW)
            NULLIFY(MUMPS_TPS_ARR(I)%IW)
            CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS(
     &              -((int(MUMPS_TPS_ARR(I)%LIW,8) * int(KEEP(34),8))
     &              / int(KEEP(35),8)),
     &      .TRUE., 
     &      KEEP8, INFO(1), INFO(2), .TRUE., .FALSE. )
          ENDIF
        ENDDO
!$OMP   END PARALLEL DO
      ENDIF
      IF (allocated(MUMPS_TPS_ARR)) THEN
        DEALLOCATE(MUMPS_TPS_ARR)
      ENDIF
      IF (allocated(CMUMPS_TPS_ARR)) THEN
        DEALLOCATE(CMUMPS_TPS_ARR)
      ENDIF
      POSFAC = POSFAC -1_8
      IWPOS = IWPOS -1
      IF (KEEP(201).LE.0) THEN
        IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN
          POSFAC = 0_8
        ENDIF
        KEEP8(31) = POSFAC 
         RINFO(6)  = ZERO
      ELSE
         RINFO(6)  = real(KEEP8(31)*int(KEEP(35),8))/1E6
      ENDIF
      KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64)
      KEEP(32) = IWPOS
      CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9))
      INFO(10) = KEEP(32)
      KEEP8(67) = LA - KEEP8(67)
      CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, 
     &                COMM_NODES, IERR)
      IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40)
     &       .AND. (NTOTPVTOT.EQ.N) )
     &     .OR. ( NTOTPVTOT.GT.N ) ) THEN
       write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N
       CALL MUMPS_ABORT()
      ENDIF
      IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. 
     &     (INFO(1).GE.0) )  THEN
       write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT 
       CALL MUMPS_ABORT()
      ENDIF
      IF ( (INFO(1) .GE. 0 ) 
     &      .AND. (NTOTPVTOT.NE.N) ) THEN
         INFO(1) = -10
      ENDIF
      IF (INFO(1).EQ.-10) THEN
         INFO(2) = NTOTPVTOT
      ENDIF
      IF (PROK) THEN
        WRITE (MPRINT,99980) INFO(1), INFO(2),
     &       KEEP(28), KEEP8(48), INFO(10), INFO(11)
        IF(KEEP(50) .EQ. 0) THEN
          WRITE(MPRINT,99982) INFO(12)
        ENDIF
        WRITE (MPRINT, 99986)
     &       INFO(13), INFO(14), RINFO(2), RINFO(3)
        IF (KEEP(97) .NE. 0) THEN
           WRITE (MPRINT, 99987)  INFO(25)
        ENDIF
      ENDIF
      RETURN
99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/
     &      ' INFO (1)                                      =',I15/
     &      '  --- (2)                                      =',I15/
     &      '           Number of nodes in the tree         =',I15/
     &      ' INFO (9)  Real space for factors              =',I15/
     &      '  --- (10) Integer space for factors           =',I15/
     &      '  --- (11) Maximum size of frontal matrices    =',I15)
99982 FORMAT ('  --- (12) Number of off diagonal pivots       =',I15)
99986 FORMAT ('  --- (13) Number of delayed pivots            =',I15/
     &      '  --- (14) Number of memory compresses         =',I15/
     &  ' RINFO(2)  Operations during node assembly     =',1PD10.3/
     &  ' -----(3)  Operations during node elimination  =',1PD10.3)
99987 FORMAT (' INFO (25) Number of tiny pivots(static)       =',I15)
      END SUBROUTINE CMUMPS_FAC_B
      SUBROUTINE CMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS,
     & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE,
     & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV,
     & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT,
     & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR,
     & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL,
     & L0_OMP_MAPPING, LL0_OMP_MAPPING,
     & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, LTPS_ARR,
     & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT,
     & NBROOT_UNDER_L0, 
     & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8,
     & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES,
     & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, roota,
     & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV,
     & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP,
     & PIVNUL_LIST_STRUCT, LRGROUPS )
      USE MUMPS_TPS_M, ONLY : MUMPS_TPS_T
      USE CMUMPS_TPS_M, ONLY:  CMUMPS_TPS_T
      USE MUMPS_INTR_TYPES, ONLY : MUMPS_ROOT_STRUC
      USE CMUMPS_INTR_TYPES, ONLY : CMUMPS_ROOT_STRUC
      USE CMUMPS_FAC_PAR_M, ONLY : CMUMPS_FAC_PAR
      USE MUMPS_PIVNUL_MOD, ONLY : PIVNUL_LIST_STRUCT_T
      IMPLICIT NONE
      TYPE (MUMPS_ROOT_STRUC) :: root
      TYPE (CMUMPS_ROOT_STRUC) :: roota
      INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80)
      DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI
      INTEGER, INTENT(INOUT) :: NELVA, COMP
      INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV
      INTEGER, INTENT(INOUT) :: NULLNEGPV
      INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY
      INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP
      COMPLEX, INTENT(INOUT) :: DET_MANT
      INTEGER(8) :: LA
      COMPLEX :: A(LA)
      INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES
      INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB
      INTEGER KEEP(500), ICNTL(60)
      INTEGER(8) KEEP8(150)
      INTEGER LPOOL
      INTEGER PROCNODE_STEPS(KEEP(28))
      INTEGER ITLOC(N+KEEP(253))
      COMPLEX :: RHS_MUMPS(KEEP8(85))
      INTEGER IW(LIW), NSTK_STEPS(KEEP(28))
      INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR)
      INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193))
      INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194))
      INTEGER, INTENT(IN) :: NINROWARR(KEEP(195))
      INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196))
      INTEGER ND(KEEP(28))
      INTEGER FILS(N),PTRIST(KEEP(28))
      INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28))
      INTEGER PIMASTER(KEEP(28))
      INTEGER PTLUST(KEEP(28)), PERM(N)
      INTEGER CAND(SLAVEF+1,max(1,KEEP(56)))
      INTEGER   ISTEP_TO_INIV2(KEEP(71)),
     &          TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
      INTEGER IPOOL(LPOOL)
      INTEGER NE(KEEP(28))
      REAL RINFO(40)
      INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU
      INTEGER IWPOS, LEAF, NBROOT, NBRTOT
      INTEGER, INTENT(in) :: NBROOT_UNDER_L0
      INTEGER COMM_LOAD, ASS_IRECV
      REAL UU, SEUIL, SEUIL_LDLT_NIV2
      INTEGER NELT
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      COMPLEX DBLARR( KEEP8(26) )
      INTEGER INTARR( KEEP8(27) )
      TYPE(PIVNUL_LIST_STRUCT_T)     :: PIVNUL_LIST_STRUCT
      REAL DKEEP(230)
      INTEGER LRGROUPS(KEEP(280))
      INTEGER, INTENT( IN ) :: LTPS_ARR, LL0_OMP_MAPPING
      TYPE (MUMPS_TPS_T)  ::  MUMPS_TPS_ARR(LTPS_ARR)
      TYPE (CMUMPS_TPS_T) :: CMUMPS_TPS_ARR(LTPS_ARR)
      INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING )
      CALL CMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS,
     & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE,
     & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV,
     & NOFFNEGPV, NULLNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT,
     & DET_SIGN,PTRIST,PTRAST,PIMASTER,PAMASTER,PTRARW,PTRAIW,PTR8ARR,
     & NINCOLARR, NINROWARR, PTRDEBARR, ITLOC, RHS_MUMPS, IPOOL, LPOOL,
     & L0_OMP_MAPPING, LL0_OMP_MAPPING,
     & MUMPS_TPS_ARR, CMUMPS_TPS_ARR, LTPS_ARR,
     & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT,
     & NBROOT_UNDER_L0, 
     & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8,
     & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES,
     & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root,roota,PERM, NELT,
     & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV,
     & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP,
     & PIVNUL_LIST_STRUCT, LRGROUPS )
      RETURN
      END SUBROUTINE CMUMPS_FAC_PAR_I
