dfac_par_m.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 dmumps_fac_par_m
      CONTAINS
      SUBROUTINE dmumps_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, NB22T1, NB22T2, NBTINY, DET_EXP,
     & DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER,
     & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL,
     & L0_OMP_MAPPING, LL0_OMP_MAPPING,
     & MUMPS_TPS_ARR, DMUMPS_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, PERM, NELT, FRTPTR, FRTELT, LPTRAR,
     & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE,
     & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS )
!$    USE OMP_LIB
      USE dmumps_dynamic_memory_m, ONLY : 
     &                                    dmumps_dm_freealldynamiccb
      USE dmumps_load
      USE dmumps_ooc
      USE dmumps_fac_asm_master_m
      USE dmumps_fac_asm_master_elt_m
      USE dmumps_fac1_ldlt_m
      USE dmumps_fac2_ldlt_m
      USE dmumps_fac1_lu_m
      USE dmumps_fac2_lu_m
      USE omp_lib
      USE mumps_tps_m
      USE dmumps_tps_m
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      TYPE (DMUMPS_ROOT_STRUC) :: root
      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) :: NB22T1, NB22T2, NBTINY
      INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP
      DOUBLE PRECISION, INTENT(INOUT) :: DET_MANT
      INTEGER(8) :: LA
      DOUBLE PRECISION, TARGET :: 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))
      DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
      INTEGER IW(LIW), NSTK_STEPS(KEEP(28))
      INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR)
      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))
      DOUBLE PRECISION 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
      DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2
      INTEGER NELT
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      DOUBLE PRECISION DBLARR( KEEP8(26) )
      INTEGER INTARR( KEEP8(27) )
      LOGICAL IS_ISOLATED_NODE
      INTEGER LPN_LIST
      INTEGER PIVNUL_LIST(LPN_LIST)
      DOUBLE PRECISION DKEEP(230)
      INTEGER LRGROUPS(N)
      INTEGER, INTENT( IN ) :: LTPS_ARR
      TYPE (MUMPS_TPS_T), TARGET  :: MUMPS_TPS_ARR( LTPS_ARR )
      TYPE (DMUMPS_TPS_T), TARGET :: DMUMPS_TPS_ARR( LTPS_ARR )
      INTEGER, INTENT( IN ) :: LL0_OMP_MAPPING
      INTEGER, INTENT( IN ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING )
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      INTEGER :: IERR
      DOUBLE PRECISION, PARAMETER :: DZERO = 0.0d0, done = 1.0d0
      INTEGER INODE
      INTEGER IWPOSCB
      INTEGER FPERE, TYPEF
      INTEGER MP, LP, DUMMY(1)
      INTEGER NBFIN, NBROOT_TRAITEES
      INTEGER NFRONT, IOLDPS, NASS, HF, XSIZE
      INTEGER(8) :: NFRONT8
      INTEGER(8) :: POSELT
      INTEGER IPOSROOT, IPOSROOTROWINDICES
      INTEGER GLOBK109
      INTEGER(8) :: LBUFRX
      DOUBLE PRECISION, POINTER, DIMENSION(:) :: BUFRX
      LOGICAL :: IS_BUFRX_ALLOCATED
      DOUBLE PRECISION FLOP1
      INTEGER TYPE
      LOGICAL SON_LEVEL2, SET_IRECV, BLOCKING,
     &        message_received
      LOGICAL AVOID_DELAYED
      LOGICAL LAST_CALL
      INTEGER MASTER_ROOT
      INTEGER LOCAL_M, LOCAL_N
      INTEGER LRHS_CNTR_MASTER_ROOT, FWD_LOCAL_N_RHS
      LOGICAL ROOT_OWNER
      EXTERNAL mumps_typenode, mumps_procnode
      INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE
      LOGICAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR
      EXTERNAL mumps_inssarbr,mumps_rootssarbr
      LOGICAL DMUMPS_POOL_EMPTY
      EXTERNAL dmumps_pool_empty, dmumps_extract_pool
      LOGICAL STACK_RIGHT_AUTHORIZED
      INTEGER numroc
      EXTERNAL numroc
      INTEGER JOBASS, ETATASS
      INTEGER(8) :: LAFAC
      INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten,
     &        idummy
      INTEGER(8) :: ITMP8
      TYPE(io_block) :: MonBloc
      include 'mumps_headers.h'
      INTEGER MPA
      DOUBLE PRECISION  OPLAST_PRINTED
      INTEGER:: ITH
      DOUBLE PRECISION :: DUMMY_FLOP_ESTIM_ACC
#if defined(multicore_profiling)
      DOUBLE PRECISION :: LATIME, LFTIME, LSTIME
      DOUBLE PRECISION :: GATIME, GFTIME, GSTIME
      gatime = 0
      gftime = 0
      gstime = 0
#endif
      dummy_flop_estim_acc = 0.0d0
      itloc(1:n+keep(253)) =0
      ass_irecv = mpi_request_null
      mp = icntl(2)
      lp = icntl(1)
      iwposcb = liw
      NULLIFY(bufrx)
      is_bufrx_allocated = .false.
      keep(143) = -1
      IF ( info(1) .LT. 0 ) THEN
        GOTO 640
      ENDIF
      oplast_printed = done
      mpa            = icntl(2)
      IF (icntl(4).LT.2) mpa=0
      IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
      stack_right_authorized = .true.
      CALL dmumps_alloc_cb( .false., 0_8,
     &     .false., .false., myid_nodes, n, keep, keep8, dkeep,
     &     iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb,
     &     slavef, procnode_steps, dad,
     &     ptrist, ptrast, step, pimaster,
     &     pamaster, keep(ixsz), 0_8, -444, -444, .true.,
     &     comp, lrlus, keep8(67),
     &     info(1), info(2)
     &     )
      jobass  = 0
      etatass = 0
      nbfin = nbrtot
      nbroot_traitees = 0
      keep(121)=0
      IF ( keep(38).NE.0 ) THEN
        IF (root%yes) THEN
            CALL dmumps_root_alloc_static(
     &        root, keep(38), n, iw, liw,
     &        a, la,
     &        fils, dad, myid_nodes, slavef, procnode_steps,
     &        lptrar, nelt, frtptr, frtelt,
     &        ptraiw, ptrarw,
     &        intarr, dblarr,
     &        lrlu, iptrlu,
     &        iwpos, iwposcb, ptrist, ptrast,
     &        step, pimaster, pamaster, itloc, rhs_mumps,
     &        comp, lrlus, info(1), keep,keep8, dkeep, info(2) )
        ENDIF
        IF ( info(1) .LT. 0 ) GOTO 635
      END IF
      IF (keep(400).GT.0) THEN
        nbroot_traitees = nbroot_under_l0
        IF (nbroot_traitees .GT.0) THEN
          IF (nbroot_traitees.EQ.nbroot) THEN
            nbfin = nbfin - nbroot
            IF (slavef .GT. 1) THEN
               CALL dmumps_mcast2( nbroot, 1, mpi_integer,
     &         myid_nodes, comm_nodes, racine, slavef, keep )
            ENDIF
          ENDIF
        ENDIF
        IF (nbfin .EQ. 0) GOTO 640
      ENDIF
      keep(429)=0
 20   CONTINUE
      niv1_flag=0
      set_irecv = .true.
      blocking = .false.
      message_received = .false.
      CALL dmumps_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, ptrfac,
     &      ptrast, step, pimaster, pamaster, nstk_steps,
     &      comp, info(1), info(2), comm_nodes, perm,
     &      ipool, lpool, leaf, nbfin, myid_nodes, slavef,
     &      root, opass, opeli, 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,
     &      stack_right_authorized
     &               , lrgroups
     &       )
      CALL dmumps_load_recv_msgs(comm_load)
      IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
      IF (message_received) THEN
          IF ( info(1) .LT. 0 ) GO TO 640
          IF ( nbfin .eq. 0 ) GOTO 640
      ELSE
          IF ( .NOT. dmumps_pool_empty( ipool, lpool) )THEN
            CALL dmumps_extract_pool( n, ipool, lpool,
     &      procnode_steps,
     &      slavef, step, inode, keep,keep8, myid_nodes, nd,
     &      (.NOT. stack_right_authorized) )
            stack_right_authorized = .true.
            IF (keep(47) .GE. 3) THEN
              CALL dmumps_load_pool_upd_new_pool(
     &              ipool, lpool,
     &              procnode_steps, keep,keep8, slavef, comm_load,
     &              myid_nodes, step, n, nd, fils )
            ENDIF
            IF (keep(47).EQ.4) THEN
               IF(inode.GT.0.AND.inode.LE.n)THEN
                  IF((ne(step(inode)).EQ.0).AND.
     &                 (frere(step(inode)).EQ.0))THEN
                     is_isolated_node=.true.
                  ELSE
                     is_isolated_node=.false.
                  ENDIF
               ENDIF
               CALL dmumps_load_sbtr_upd_new_pool(
     &              is_isolated_node,inode,ipool,lpool,
     &              myid_nodes,slavef,comm_load,keep,keep8)
            ENDIF
            IF ((( keep(80) == 2 .OR. keep(80)==3 ) .AND.
     &           ( keep(47) == 4 )).OR.
     &           (keep(80) == 1 .AND. keep(47) .GE. 1)) THEN
               CALL dmumps_upper_predict(inode,step,keep(28),
     &         procnode_steps,frere,nd,comm_load,slavef,
     &         myid_nodes,keep,keep8,n)
            END IF
            GOTO 30
          ENDIF
      ENDIF
      GO TO 20
 30   CONTINUE
      IF ( inode .LT. 0 ) THEN
        inode = -inode
        fpere = dad(step(inode))
        GOTO 130
      ELSE IF (inode.GT.n) THEN
       inode = inode - n
       IF (inode.EQ.keep(38)) THEN
         nbroot_traitees = nbroot_traitees + 1
         IF ( nbroot_traitees .EQ. nbroot ) THEN
            nbfin = nbfin - nbroot
            IF (slavef.GT.1) THEN
                dummy(1) = nbroot
                CALL dmumps_mcast2(dummy, 1, mpi_integer, myid_nodes,
     &          comm_nodes, racine, slavef, keep )
            END IF
         ENDIF
         IF (nbfin.EQ.0) GOTO 640
         GOTO 20
       ENDIF
       TYPE = mumps_typenode(procnode_steps(step(inode)),keep(199))
       IF (type.EQ.1) GOTO 100
       fpere = dad(step(inode))
       avoid_delayed = ( (fpere .eq. keep(20) .OR. fpere .eq. keep(38))
     &                   .AND. keep(60).ne.0 )
       IF ( keep(50) .eq. 0 ) THEN
         CALL  dmumps_fac2_lu( comm_load, ass_irecv,
     &        n, inode, fpere, iw, liw, a, la, uu,
     &        noffnegpv, ntotpv, nbtiny,
     &        det_exp, det_mant, det_sign,
     &        comm_nodes, myid_nodes, bufr, lbufr,lbufr_bytes,
     &        nbfin,leaf, info(1), info(2), ipool,lpool,
     &        slavef, posfac, iwpos, iwposcb, iptrlu, lrlu,
     &        lrlus, comp, ptrist, ptrast, ptlust, ptrfac,
     &        step, pimaster, pamaster,
     &        nstk_steps,perm,procnode_steps,
     &        root, opass, opeli, 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(1),pivnul_list(1),lpn_list
     &        , lrgroups
     &             )
        IF ( info(1) .LT. 0 ) GOTO 640
        IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
       ELSE
         CALL dmumps_fac2_ldlt( comm_load, ass_irecv,
     &             n, inode, fpere, iw, liw, a, la, uu,
     &             noffnegpv, ntotpv,
     &             nb22t2, nbtiny, det_exp, det_mant, det_sign,
     &             comm_nodes, myid_nodes, bufr, lbufr,lbufr_bytes,
     &             nbfin,leaf, info(1), info(2), ipool,lpool,
     &             slavef, posfac, iwpos, iwposcb, iptrlu, lrlu,
     &             lrlus, comp, ptrist, ptrast, ptlust, ptrfac,
     &             step, pimaster, pamaster,
     &             nstk_steps,perm,procnode_steps,
     &             root, opass, opeli, itloc, rhs_mumps,
     &             fils, dad, ptrarw, ptraiw,
     &             intarr, dblarr, icntl, keep,keep8, nd, frere,
     &             lptrar, nelt, frtptr, frtelt, seuil_ldlt_niv2,
     &             istep_to_iniv2, tab_pos_in_pere, avoid_delayed,
     &              dkeep(1),pivnul_list(1),lpn_list
     &           , lrgroups
     &             )
        IF ( info(1) .LT. 0 ) GOTO 640
        IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
        IF ( iw( ptlust(step(inode)) + keep(ixsz) + 5 ) .GT. 1 ) THEN
             GOTO 20
        END IF
       END IF
       GOTO 130
      ENDIF
      IF (inode.EQ.keep(38)) THEN
         CALL  dmumps_last_rtnelind( comm_load, ass_irecv,
     &    root, frere,
     &    inode,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_steps, comp,
     &    info(1), info(2), comm_nodes,
     &    perm,
     &    ipool, lpool, leaf,
     &    nbfin, myid_nodes, slavef,
     &
     &    opass, opeli, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr, dblarr,icntl,keep,keep8,dkeep, nd,
     &    lptrar, nelt, frtptr, frtelt,
     &    istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &      )
         IF ( info(1) .LT. 0 ) GOTO 640
         IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
        GOTO 20
      ENDIF
      TYPE = mumps_typenode(procnode_steps(step(inode)),keep(199))
      IF (type.EQ.1) THEN
        IF (keep(55).NE.0) THEN
         CALL dmumps_fac_asm_niv1_elt( comm_load, ass_irecv,
     &        nelt, frtptr, frtelt,
     &        n,inode,iw,liw,a,la,
     &        info(1),nd,
     &        fils,frere,dad,maxfrt,root,opass, opeli,
     &     ptrist,ptlust,ptrfac,ptrast,step, pimaster,pamaster,
     &        ptrarw,ptraiw,
     &        itloc, rhs_mumps, nstepsdone, son_level2,
     &        comp, lrlu, iptrlu,
     &        iwpos,iwposcb, posfac, lrlus, keep8(67),
     &        icntl, keep,keep8,dkeep,
     &        intarr,keep8(27),dblarr,keep8(26),
     &    nstk_steps,procnode_steps, slavef,
     &    comm_nodes, myid_nodes,
     &    bufr, lbufr, lbufr_bytes, nbfin, ipool, lpool, leaf,
     &    perm, istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &    , mumps_tps_arr, dmumps_tps_arr,
     &    l0_omp_mapping
     &    )
        ELSE
         jobass = 0
         CALL dmumps_fac_asm_niv1(comm_load, ass_irecv,
     &        n,inode,iw,liw,a,la,
     &        info(1),nd,
     &        fils,frere,dad,maxfrt,root,opass, opeli,
     &      ptrist,ptlust,ptrfac,ptrast,step, pimaster,pamaster,
     &        ptrarw,ptraiw,
     &        itloc, rhs_mumps, nstepsdone, son_level2,
     &        comp, lrlu, iptrlu,
     &        iwpos,iwposcb, posfac, lrlus, keep8(67),
     &        icntl, keep,keep8,dkeep, intarr,keep8(27),
     &        dblarr,keep8(26),
     &    nstk_steps,procnode_steps, slavef,
     &    comm_nodes, myid_nodes,
     &    bufr, lbufr, lbufr_bytes, nbfin, ipool, lpool, leaf,
     &    perm,
     &    istep_to_iniv2, tab_pos_in_pere, jobass,etatass
     &               , lrgroups
     &    , mumps_tps_arr, dmumps_tps_arr,
     &    l0_omp_mapping
     &    )
        ENDIF
        IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
       IF ( info(1) .LT. 0 ) GOTO 640
        IF ((iw(ptlust(step(inode))+xxnbpr).GT.0).OR.(son_level2)) THEN
          GOTO 20
        ENDIF
      ELSE
        IF ( keep(55) .eq. 0 ) THEN
          CALL dmumps_fac_asm_niv2(comm_load, ass_irecv,
     &    n, inode, iw, liw, a, la,
     &    info(1),
     &    nd, fils, frere, dad, cand,
     &    istep_to_iniv2, tab_pos_in_pere,
     &    maxfrt,
     &    root, opass, opeli, ptrist, ptlust, ptrfac,
     &    ptrast, step, pimaster, pamaster, ptrarw, nstk_steps,
     &    ptraiw, itloc, rhs_mumps, nstepsdone,
     &    comp, lrlu, iptrlu, iwpos, iwposcb, posfac, lrlus,
     &    icntl, keep,keep8,dkeep,intarr,keep8(27),dblarr,keep8(26),
     &    procnode_steps, slavef, comm_nodes,
     &    myid_nodes,
     &    bufr, lbufr, lbufr_bytes,
     &    nbfin, leaf, ipool, lpool, perm,
     &    mem_distrib(0)
     &               , lrgroups
     &    )
        ELSE
          CALL dmumps_fac_asm_niv2_elt( comm_load, ass_irecv,
     &    nelt, frtptr, frtelt,
     &    n, inode, iw, liw, a, la, info(1),
     &    nd, fils, frere, dad, cand,
     &    istep_to_iniv2, tab_pos_in_pere,
     &    maxfrt,
     &    root, opass, opeli, ptrist, ptlust, ptrfac,
     &    ptrast, step, pimaster, pamaster, ptrarw, nstk_steps,
     &    ptraiw, itloc, rhs_mumps, nstepsdone,
     &    comp, lrlu, iptrlu, iwpos, iwposcb, posfac, lrlus,
     &    icntl, keep,keep8,dkeep,intarr,keep8(27),dblarr,keep8(26),
     &    procnode_steps, slavef, comm_nodes,
     &    myid_nodes,
     &    bufr, lbufr, lbufr_bytes,
     &    nbfin, leaf, ipool, lpool, perm,
     &    mem_distrib(0)
     &               , lrgroups
     &     )
        END IF
        IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
        IF (info(1).LT.0) GOTO 640
        GOTO 20
      ENDIF
 100  CONTINUE
       fpere = dad(step(inode))
      IF ( inode .eq. keep(20) ) THEN
        poselt = ptrast(step(inode))
        IF (ptrfac(step(inode)).NE.poselt) THEN
          WRITE(*,*) "ERROR 2 in DMUMPS_FAC_PAR", poselt
          GOTO 635
        ENDIF
        CALL dmumps_change_header
     &       ( iw(ptlust(step(inode))+keep(ixsz)), keep(253) )
        GOTO 200
      END IF
      poselt = ptrast(step(inode))
      ioldps = ptlust(step(inode))
      xsize =  keep(ixsz)
      hf = 6 + iw(ioldps+5+xsize)+xsize
      nfront = iw(ioldps+xsize) 
      nass   = iabs(iw(ioldps+2+xsize))
      avoid_delayed = ( (fpere .eq. keep(20) .OR. fpere .eq. keep(38))
     &                   .AND. keep(60).ne.0 )
      IF (keep(50).EQ.0) THEN
           CALL dmumps_fac1_lu ( 
     &               n, inode, iw, liw, a, la,
     &               ioldps, poselt,
     &               info(1), info(2), uu, noffnegpv, ntotpv, nbtiny,
     &               det_exp, det_mant, det_sign,
     &               keep,keep8,
     &               step, procnode_steps, myid_nodes, slavef,
     &               seuil, avoid_delayed, etatass,
     &              dkeep(1),pivnul_list(1),lpn_list, iwpos 
     &           , lrgroups
     &           , perm
     &           )
           IF (info(1).LT.0) GOTO 635
#if defined(multicore_profiling)
         lftime = mpi_wtime() - lftime
         gftime = gftime + lftime
         WRITE(*,*)'FAC ',lftime
#endif
      ELSE  
            iw( ioldps+4+keep(ixsz) ) = 1
              CALL dmumps_fac1_ldlt( n, inode,
     &           iw, liw, a, la,
     &           ioldps, poselt,
     &           info(1), info(2), uu, noffnegpv, ntotpv,
     &           nb22t1, nbtiny, det_exp, det_mant, det_sign,
     &           keep,keep8, myid_nodes, seuil, avoid_delayed,
     &           etatass,
     &           dkeep(1),pivnul_list(1),lpn_list, iwpos
     &           , lrgroups
     &           , perm
     &           )
             IF (info(1).LT.0) GOTO 635
            iw( ioldps+4+keep(ixsz) ) = step(inode)
          ENDIF 
          jobass = etatass          
          IF (jobass.EQ.1) THEN
#if defined(multicore_profiling)
              latime = mpi_wtime()
#endif
              CALL dmumps_fac_asm_niv1(comm_load, ass_irecv,
     &        n,inode,iw,liw,a,la,
     &        info(1),nd,
     &        fils,frere,dad,maxfrt,root,opass, opeli,
     &        ptrist,ptlust,ptrfac,ptrast,step,pimaster,pamaster,
     &        ptrarw,ptraiw,
     &        itloc, rhs_mumps, nstepsdone, son_level2,
     &        comp, lrlu, iptrlu,
     &        iwpos,iwposcb, posfac, lrlus, keep8(67),
     &        icntl, keep,keep8,dkeep,intarr,keep8(27),dblarr,keep8(26),
     &        nstk_steps, procnode_steps, slavef,
     &        comm_nodes, myid_nodes,
     &        bufr, lbufr, lbufr_bytes, nbfin, ipool, lpool, leaf,
     &        perm,
     &        istep_to_iniv2, tab_pos_in_pere,
     &        jobass,etatass
     &               , lrgroups
     &         )
#if defined(multicore_profiling)
         latime = mpi_wtime() - latime
         gatime = gatime + latime
         WRITE(*,*)'ASS ',latime
#endif
          ENDIF
          IF (mpa.GT.0)
     &    CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
      IF (info(1).LT.0) GOTO 635
 130  CONTINUE
      TYPE  = mumps_typenode(procnode_steps(step(inode)),keep(199))
      IF ( fpere .NE. 0 ) THEN
        typef = mumps_typenode(procnode_steps(step(fpere)),keep(199))
      ELSE
        typef = -9999
      END IF
#if defined(multicore_profiling)
         lstime = mpi_wtime()
#endif
      CALL dmumps_fac_stack( comm_load, ass_irecv,
     &       n,inode,TYPE,typef,la,iw,liw,a,
     &       info(1),INFO(2),OPELI,NELVA,NMAXNPIV,
     &       ptrist,ptlust,ptrfac,
     &       ptrast, step, pimaster, pamaster,
     &       ne, posfac,lrlu, lrlus,keep8(67),
     &       iptrlu,icntl,keep,keep8,dkeep,comp,iwpos,iwposcb,
     &       procnode_steps,slavef,fpere,comm_nodes,myid_nodes,
     &       ipool, lpool, leaf,
     &       nstk_steps, perm, bufr, lbufr, lbufr_bytes, nbfin,
     &       root, opass, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw,
     &       intarr, dblarr,
     &       nd, frere, lptrar, nelt, frtptr, frtelt,
     &       istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &       ,dummy_flop_estim_acc
     &       )
#if defined(multicore_profiling)
         lstime = mpi_wtime() - lstime
         gstime = gstime + lstime
         WRITE(*,*)'STK ',lstime
#endif
      IF (mpa.GT.0)
     &   CALL mumps_print_still_active (myid_nodes, keep, 
     &                        dble(dkeep(17)), 
     &                        opeli,
     &                        oplast_printed, mpa)
      IF (info(1).LT.0) GOTO 640
 200  CONTINUE
      IF ( inode .eq. keep(38) ) THEN
        WRITE(*,*) 'Error .. in DMUMPS_FAC_PAR: ',
     &             ' INODE == KEEP(38)'
        CALL mumps_abort()
      END IF
      IF ( fpere.EQ.0 ) THEN
        nbroot_traitees = nbroot_traitees + 1
        IF ( nbroot_traitees .EQ. nbroot ) THEN
           IF (keep(201).EQ.1) THEN 
              CALL dmumps_ooc_force_wrt_buf_panel(ierr)
           ELSE IF ( keep(201).EQ.2) THEN 
              CALL dmumps_force_write_buf(ierr)
           ENDIF
            nbfin = nbfin - nbroot
            IF ( nbfin .LT. 0 ) THEN
              WRITE(*,*) ' ERROR 1 in DMUMPS_FAC_PAR: ',
     &                   ' NBFIN=', nbfin
              CALL mumps_abort()
            END IF
            IF ( nbroot .LT. 0 ) THEN
              WRITE(*,*) ' ERROR 1 in DMUMPS_FAC_PAR: ',
     &                   ' NBROOT=', nbroot
              CALL mumps_abort()
            END IF
            IF (slavef.GT.1) THEN
                dummy(1) = nbroot
                CALL dmumps_mcast2( dummy(1), 1, mpi_integer,
     &          myid_nodes, comm_nodes, racine, slavef, keep )
            END IF
        ENDIF
        IF (nbfin.EQ.0)THEN
           GOTO 640
        ENDIF
      ELSEIF ( fpere.NE.keep(38) .AND.
     &         mumps_procnode(procnode_steps(step(fpere)),
     &         keep(199)) .EQ.  myid_nodes ) THEN
        nstk_steps(step(fpere)) = nstk_steps(step(fpere))-1
        IF ( nstk_steps( step( fpere )).EQ.0) THEN
          IF (keep(234).NE.0 .AND.
     &      mumps_inssarbr(procnode_steps(step(inode)),keep(199)))
     &      THEN
            stack_right_authorized = .false.
          ENDIF
          CALL dmumps_insert_pool_n(n, ipool, lpool,
     &         procnode_steps, slavef, keep(199), keep(28), keep(76),
     &         keep(80), keep(47), step, fpere )
          IF (keep(47) .GE. 3) THEN
             CALL dmumps_load_pool_upd_new_pool(
     &            ipool, lpool,
     &            procnode_steps, keep,keep8, slavef, comm_load,
     &            myid_nodes, step, n, nd, fils )
          ENDIF
          CALL mumps_estim_flops( fpere, n, procnode_steps,keep(199),
     &           nd, fils, frere, step, pimaster, keep(28),
     &           keep(50), keep(253), flop1,
     &           iw, liw, keep(ixsz) )
          IF (fpere.NE.keep(20))
     &    CALL dmumps_load_update(1,.false.,flop1,keep,keep8)
        ENDIF
      ENDIF
      GO TO 20
 635  CONTINUE
      CALL dmumps_bdc_error( myid_nodes, slavef, comm_nodes, keep )
 640  CONTINUE
        CALL dmumps_cancel_irecv( info(1),
     &       keep,
     &       ass_irecv, bufr, lbufr,
     &       lbufr_bytes,
     &       comm_nodes,
     &       myid_nodes, slavef)
       CALL dmumps_clean_pending( info(1), keep,
     &      bufr, lbufr,
     &      lbufr_bytes,
     &      comm_nodes, comm_load, slavef,
     &      .true.,
     &      .true.)
      CALL mpi_barrier( comm_nodes, ierr )
      IF (info(1) .LT. 0) THEN
        CALL dmumps_dm_freealldynamiccb( myid, n, slavef, keep, keep8,
     &  iw, liw, iwposcb, iwpos,
     &  step, ptrast, pamaster, procnode_steps, dad,
     &  .false. ) 
        IF (keep(400) .GT. 0) THEN
!$OMP PARALLEL DO SCHEDULE(STATIC,1)
            DO ith = 1, keep(400)
              IF (associated(mumps_tps_arr(ith)%IW)) THEN
                CALL dmumps_dm_freealldynamiccb_i( myid, n, slavef,
     &          keep, keep8,
     &          mumps_tps_arr(ith)%IW(1), mumps_tps_arr(ith)%LIW,
     &          mumps_tps_arr(ith)%IWPOSCB, mumps_tps_arr(ith)%IWPOS,
     &          step, ptrast, pamaster, procnode_steps, dad,
     &          .true. ) 
              ENDIF
            ENDDO
!$OMP END PARALLEL DO
        ENDIF
      ENDIF
      IF ( info(1) .GE. 0 ) THEN
          IF( keep(38) .NE. 0 .OR. keep(20).NE.0) THEN
            master_root = mumps_procnode(
     &                  procnode_steps(step(max(keep(38),keep(20)))),
     &                  keep(199))
            root_owner  = (master_root .EQ. myid_nodes)
            IF ( keep(38) .NE. 0 ) THEN
               IF (keep(60).EQ.0) THEN
                 ioldps  = ptlust(step(keep(38)))
                 local_m = iw(ioldps+2+keep(ixsz))
                 local_n = iw(ioldps+1+keep(ixsz))
               ELSE
                 ioldps  = -999
                 local_m = root%SCHUR_MLOC
                 local_n = root%SCHUR_NLOC
               ENDIF
               itmp8   = int(local_m,8)*int(local_n,8)
               lbufrx = min(int(root%MBLOCK,8)*int(root%NBLOCK,8),
     &            int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) )
               is_bufrx_allocated = .false.
               IF ( lrlu .GT. lbufrx ) THEN
                   bufrx => a(posfac:posfac+lrlu-1_8)
                   lbufrx=lrlu
               ELSE
                   ALLOCATE( bufrx( lbufrx ), stat = ierr )
                   IF (ierr.gt.0) THEN
                         info(1) = -13
                         CALL mumps_set_ierror(lbufrx, info(2) )
                         IF (lp > 0 )
     &                   write(lp,*) ' Error allocating, real array ',
     &                   'of size before DMUMPS_FACTO_ROOT',  lbufrx
                         CALL mumps_abort()
                   ENDIF
                   is_bufrx_allocated = .true.
               ENDIF
               CALL dmumps_facto_root( 
     &               mpa, myid_nodes, master_root,
     &               root, n, keep(38),
     &               comm_nodes, iw, liw, iwpos + 1,
     &               a, la, ptrast, ptlust, ptrfac, step,
     &               info(1), keep(50), keep(19),
     &               bufrx(1), lbufrx, keep,keep8, dkeep,
     &               opeli, det_exp, det_mant, det_sign )
               IF (is_bufrx_allocated) DEALLOCATE ( bufrx )
               NULLIFY(bufrx)
               is_bufrx_allocated = .false.
                IF ( myid_nodes .eq. 
     &               mumps_procnode(procnode_steps(step(keep(38))),
     &                              keep(199))
     &             ) THEN
                   IF ( info(1) .EQ. -10 .OR. info(1) .EQ. -40 ) THEN
                      ntotpv = ntotpv + info(2)
                   ELSE
                      ntotpv = ntotpv + root%TOT_ROOT_SIZE
                      nmaxnpiv = max(nmaxnpiv,root%TOT_ROOT_SIZE)
                   END IF
                END IF
                IF (root%yes.AND.keep(60).EQ.0) THEN
                  IF (keep(252).EQ.0) THEN
                  IF (keep(201).EQ.1) THEN 
                    CALL mumps_geti8(lafac, iw(ioldps+xxr))
                    liwfac    = iw(ioldps+xxi)
                    typefile  = typef_l
                    nextpiv2bewritten = 1 
                    monbloc%INODE    = keep(38)   
                    monbloc%MASTER   = .true.
                    monbloc%Typenode = 3
                    monbloc%NROW     = local_m
                    monbloc%NCOL     = local_n
                    monbloc%NFS      = monbloc%NCOL
                    monbloc%Last     = .true.   
                    monbloc%LastPiv  =  monbloc%NCOL
                    monbloc%LastPanelWritten_L=-9999 
                    monbloc%LastPanelWritten_U=-9999 
                    NULLIFY(monbloc%INDICES)
                    strat        = strat_write_max
                    monbloc%Last = .true.
                    last_call = .true.
                    CALL dmumps_ooc_io_lu_panel
     &                                 ( strat, typefile,
     &                                  a(ptrfac(step(keep(38)))),
     &                                  lafac, monbloc,
     &                                  nextpiv2bewritten, idummy,
     &                                  iw(ioldps), liwfac,
     &                                  myid, keep8(31), ierr,last_call)
                  ELSE IF (keep(201).EQ.2) THEN
                    keep8(31)=keep8(31)+ itmp8
                    CALL dmumps_new_factor(keep(38),ptrfac,
     &              keep,keep8,a,la, itmp8, ierr)
                    IF(ierr.LT.0)THEN
                      WRITE(*,*)myid,
     &                ': Internal error in DMUMPS_NEW_FACTOR'
                      CALL mumps_abort()
                    ENDIF
                  ENDIF 
                  ENDIF 
                  IF (keep(201).NE.0 .OR. keep(252).NE.0) THEN
                     lrlus = lrlus + itmp8 
                     keep8(69) = keep8(69) - itmp8 
                     IF (keep(252).NE.0) THEN
                       CALL dmumps_load_mem_update(.false.,.false.,
     &                 la-lrlus
     &                 ,0_8,-itmp8,
     &                 keep,keep8,lrlus)
                     ELSE         
                       CALL dmumps_load_mem_update(.false.,.false.,
     &                 la-lrlus
     &                 ,itmp8,    
     &                 0_8,
     &                 keep,keep8,lrlus)
                     ENDIF
                     IF (ptrfac(step(keep(38))).EQ.posfac-itmp8) THEN
                       posfac = posfac  - itmp8
                       lrlu   = lrlu    + itmp8
                     ENDIF
                  ELSE
                       CALL dmumps_load_mem_update(.false.,.false.,
     &                 la-lrlus
     &                 ,itmp8,    
     &                 0_8,
     &                 keep,keep8,lrlus)
                  ENDIF
                ENDIF  
                IF (root%yes. and. keep(252) .NE. 0 .AND.
     &              (keep(60).EQ.0 .OR. keep(221).EQ.1)) THEN
                  IF (myid_nodes .EQ. master_root) THEN
                    lrhs_cntr_master_root = root%TOT_ROOT_SIZE*keep(253)
                  ELSE
                    lrhs_cntr_master_root = 1
                  ENDIF
                  ALLOCATE(root%RHS_CNTR_MASTER_ROOT( 
     &                     lrhs_cntr_master_root), stat=ierr )
                  IF (ierr.gt.0) THEN
                    info(1) = -13
                    info(2) = lrhs_cntr_master_root
                    IF (lp > 0 )
     &              write(lp,*) ' Error allocating, real array ',
     &              'of size before DMUMPS_FACTO_ROOT',
     &              lrhs_cntr_master_root
                    CALL mumps_abort()
                  ENDIF
                  fwd_local_n_rhs = numroc(keep(253), root%NBLOCK,
     &            root%MYCOL, 0, root%NPCOL)
                  fwd_local_n_rhs = max(1,fwd_local_n_rhs)
                  CALL dmumps_gather_root( myid_nodes,
     &            root%TOT_ROOT_SIZE, keep(253),
     &            root%RHS_CNTR_MASTER_ROOT(1), local_m,
     &            fwd_local_n_rhs, root%MBLOCK, root%NBLOCK,
     &            root%RHS_ROOT(1,1), master_root,
     &            root%NPROW, root%NPCOL, comm_nodes )
     &             
                ENDIF
            ELSE
                IF (keep(19).NE.0) THEN
                  CALL mpi_reduce(keep(109), globk109, 1,
     &                 mpi_integer, mpi_sum,
     &                 master_root,
     &                 comm_nodes, ierr)
                ENDIF
                IF (root_owner) THEN
                   iposroot = ptlust(step(keep(20)))
                   nfront   = iw(iposroot+keep(ixsz)+3)   
                   nfront8  = int(nfront,8)
                   iposrootrowindices=iposroot+6+keep(ixsz)+ 
     &                             iw(iposroot+5+keep(ixsz)) 
                   ntotpv = ntotpv + nfront 
                   nmaxnpiv = max(nmaxnpiv,nfront)
                END IF
                IF (root_owner.AND.keep(60).NE.0) THEN 
                  itmp8 = nfront8*nfront8
                  IF ( ptrfac(step(keep(20))) .EQ. posfac -
     &                 itmp8 ) THEN
                    posfac = posfac - itmp8
                    lrlus  = lrlus  + itmp8
                    lrlu   = lrlus  + itmp8
                    keep8(69) = keep8(69) - itmp8
                    CALL dmumps_load_mem_update(.false.,.false.,
     &              la-lrlus,0_8,-itmp8,keep,keep8,lrlus)
                  ENDIF
                ENDIF
            END IF
            IF (info(1).LT.0) GOTO 500
          END IF  
       END IF 
 500   CONTINUE
       IF ( keep(38) .NE. 0 ) THEN
         IF (myid_nodes.EQ. 
     &        mumps_procnode(procnode_steps(step(keep(38))),keep(199))
     &      ) THEN
           maxfrt = max( maxfrt, root%TOT_ROOT_SIZE)
         END IF
       END IF
      RETURN
      END SUBROUTINE dmumps_fac_par
      SUBROUTINE dmumps_change_header( HEADER, KEEP253 )
        INTEGER HEADER( 6 ), KEEP253
        INTEGER NFRONT, NASS
        nfront = header(1)
        IF ( header(2) .ne. 0 ) THEN
          WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',header(2)
          CALL mumps_abort()
        END IF
        nass   = abs( header( 3 ) )
        IF ( nass .NE. abs( header( 4 ) ) ) THEN
          WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',header(3:4)
          CALL mumps_abort()
        END IF
        IF ( nass+keep253 .NE. nfront ) THEN
          WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root',
     &    nass, keep253, nfront
          CALL mumps_abort()
        END IF
        header( 1 ) = keep253 
        header( 2 ) = 0
        header( 3 ) = nfront 
        header( 4 ) = nfront-keep253    
        RETURN
      END SUBROUTINE dmumps_change_header
      END MODULE dmumps_fac_par_m