dsol_omp_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_sol_l0omp_m
!$    USE OMP_LIB, ONLY: OMP_LOCK_KIND
      INTEGER, PARAMETER :: nb_lock_max = 18
!$    INTEGER(OMP_LOCK_KIND),
!$   &ALLOCATABLE, DIMENSION(:), SAVE :: LOCK_FOR_SCATTER
      CONTAINS
      SUBROUTINE dmumps_sol_l0omp_li( K400 )
!$    USE OMP_LIB, ONLY: OMP_INIT_LOCK
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: K400
!$    INTEGER :: I
!$    IF (K400 .GT. 0) THEN
!$      ALLOCATE(LOCK_FOR_SCATTER(min(NB_LOCK_MAX,K400)))
!$      DO I = 1, min(NB_LOCK_MAX,K400)
!$        CALL OMP_INIT_LOCK(LOCK_FOR_SCATTER(I))
!$      ENDDO
!$    ENDIF
      RETURN
      END SUBROUTINE dmumps_sol_l0omp_li
      SUBROUTINE dmumps_sol_l0omp_ld( K400 )
!$    USE OMP_LIB, ONLY : OMP_DESTROY_LOCK
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: K400
!$    INTEGER :: I
!$    IF (K400 .GT. 0) THEN
!$      DO I = 1, min(NB_LOCK_MAX,K400)
!$        CALL OMP_DESTROY_LOCK(LOCK_FOR_SCATTER(I))
!$      ENDDO
!$      DEALLOCATE(LOCK_FOR_SCATTER)
!$    ENDIF
      RETURN
      END SUBROUTINE dmumps_sol_l0omp_ld
      SUBROUTINE dmumps_sol_l0omp_r(N, MTYPE,
     &  NRHS, LIW, IW, PTRICB, RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD,
     &  STEP, FRERE, DAD, FILS, NSTK, PTRIST, PTRFAC, INFO,
     &  KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF,
     &  COMM, MYID,              
     &  BUFR, LBUFR, LBUFR_BYTES,
     &  RHS_ROOT, LRHS_ROOT,             
     &  ISTEP_TO_INIV2, TAB_POS_IN_PERE, 
     &  RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE,
     &  FROM_PP, 
     &  NBROOT_UNDER_L0, LPOOL_B_L0_OMP, IPOOL_B_L0_OMP,
     &  L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP,
     &  PERM_L0_OMP, PTR_LEAFS_L0_OMP,
     &  L0_OMP_MAPPING, LL0_OMP_MAPPING,
     &  L0_OMP_FACTORS, LL0_OMP_FACTORS,
     &  DO_PRUN, TO_PROCESS )
      USE dmumps_struc_def, ONLY : dmumps_l0ompfac_t
!$      USE OMP_LIB
      IMPLICIT NONE
      INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW
      INTEGER, INTENT( in ) :: IW(LIW)
      INTEGER               :: INFO( 80 ), KEEP(500)
      INTEGER(8)            :: KEEP8(150)
      DOUBLE PRECISION                  :: DKEEP(230)
      INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) )
      INTEGER               :: PTRICB( KEEP(28) ) 
      INTEGER, INTENT( in ) :: POSINRHSCOMP_FWD(N), LRHSCOMP 
      DOUBLE PRECISION, INTENT(inout):: RHSCOMP(LRHSCOMP,NRHS)
      INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N ),
     &                         DAD( KEEP(28) )
      INTEGER, INTENT( inout ) :: NSTK(KEEP(28))
      INTEGER, INTENT( in )    :: PTRIST(KEEP(28))
      INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28))
      INTEGER,    INTENT( IN ) :: COMM, MYID
      INTEGER,    INTENT( IN ) :: LBUFR, LBUFR_BYTES
      INTEGER                  :: BUFR(LBUFR)
      INTEGER(8), INTENT(IN)   :: LRHS_ROOT
      DOUBLE PRECISION                  :: RHS_ROOT(LRHS_ROOT)
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      LOGICAL, INTENT( in ) :: DO_NBSPARSE
      INTEGER, INTENT( in ) :: LRHS_BOUNDS
      INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS)
      LOGICAL, INTENT( in ) :: FROM_PP
      INTEGER, INTENT( out ):: NBROOT_UNDER_L0
      INTEGER, INTENT( in ) :: LPOOL_B_L0_OMP
      INTEGER, INTENT( in ) :: IPOOL_B_L0_OMP
     &                         ( lpool_b_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 ) :: 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( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING )
      INTEGER, INTENT( in ) :: LL0_OMP_FACTORS
      LOGICAL, INTENT( in ) :: DO_PRUN
      LOGICAL, INTENT( in ) :: TO_PROCESS( KEEP(28) )
      TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) ::
     &                        l0_omp_factors(ll0_omp_factors)
      INTEGER :: LASTFSSBTRSTA_P, LASTFSSBTRDYN_P
      INTEGER :: THREAD_ID, IL0OMPFAC
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WCB_P
      INTEGER :: LPOOL_P, LEAF_P, LIWCB_P
      INTEGER(8) :: LWCB_P
      INTEGER(8) :: POSWCB_P, PLEFTWCB_P
      INTEGER    :: POSIWCB_P
      LOGICAL :: IS_INODE_PROCESSED_P
      LOGICAL :: ERROR_WAS_BROADCASTED_P
      INTEGER :: INFO_P(2), allocok
      INTEGER :: I, VIRTUAL_TASK, PHYSICAL_TASK
      INTEGER :: INODE, IFATH, IROOT_SBTR
      INTEGER :: NBROOT_PROCESSED 
      INTEGER :: NEXT_TASK_DYN 
!$    INTEGER :: NOMP_SAVE
      INTEGER :: NBFIN_DUMMY
      nbfin_dummy = huge(nbfin_dummy)
      nbroot_processed = 0
      ptricb = 0
      next_task_dyn = keep(400)+1
!$OMP PARALLEL
!$OMP& SHARED ( NEXT_TASK_DYN, IPOOL_B_L0_OMP,
!$OMP&          LPOOL_B_L0_OMP, NBFIN_DUMMY )
!$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK,
!$omp&           ipool_p, lpool_p, leaf_p,
!$OMP&           LIWCB_P, LWCB_P, IWCB_P, WCB_P,
!$OMP&           PLEFTWCB_P, POSWCB_P, POSIWCB_P,
!$OMP&           LASTFSSBTRSTA_P, LASTFSSBTRDYN_P,
!$OMP&           INODE, IROOT_SBTR, IFATH,
!$OMP&           IS_INODE_PROCESSED_P,
!$OMP&           INFO_P, ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok )
!$OMP& REDUCTION( + : NBROOT_PROCESSED )
!$    nomp_save = omp_get_max_threads()
      thread_id = 1
!$    THREAD_ID = OMP_GET_THREAD_NUM() + 1
!$OMP BARRIER
!$    CALL omp_set_num_threads(1)
      lpool_p = lpool_b_l0_omp
      info_p(1:2) = 0
      lwcb_p  = int(keep(133),8)*int(nrhs,8)
      liwcb_p = keep(133)
      pleftwcb_p = 1_8
      poswcb_p = lwcb_p
      posiwcb_p = liwcb_p
      ALLOCATE(ipool_p(lpool_p), iwcb_p(liwcb_p), wcb_p( lwcb_p),
     &         stat=allocok)
      IF ( allocok > 0 ) THEN
        info_p(1) = -13
        CALL mumps_seti8toi4(lpool_p + liwcb_p + lwcb_p,
     &                       info(2))
!$OMP CRITICAL(critical_info)
        info(1) = -13
        info(2) = info_p(2)
!$OMP END CRITICAL(critical_info)
      ENDIF
!$OMP BARRIER
      IF (info(1) .LT. 0) THEN
        GOTO 50
      ENDIF
      virtual_task = thread_id
 600  CONTINUE
      IF (virtual_task .LT. l_virt_l0_omp) THEN
        DO physical_task = virt_l0_omp( virtual_task ),
     &       virt_l0_omp( virtual_task + 1 ) - 1
          leaf_p = 1
          DO i = ptr_leafs_l0_omp( perm_l0_omp( physical_task )+1 )+1,
     &      ptr_leafs_l0_omp( perm_l0_omp( physical_task ) )
            IF ( ipool_b_l0_omp(i) .GT. 0 ) THEN
              ipool_p(leaf_p) = ipool_b_l0_omp(i)
              leaf_p = leaf_p + 1
            ENDIF
          ENDDO
          IF ( leaf_p .EQ. 1 ) THEN
                WRITE(*,*) " Internal error 1 in DMUMPS_SOL_L0OMP_R",
     &             leaf_p
          ENDIF
          iroot_sbtr = phys_l0_omp( perm_l0_omp( physical_task ))
          IF (do_prun) THEN
            IF (.NOT. to_process(step(iroot_sbtr))) THEN
              cycle
            ENDIF
          ENDIF
          inode = iroot_sbtr
          DO WHILE (inode .GT. 0)
            lastfssbtrsta_p = inode
            inode=fils(inode)
          ENDDO
          CALL mumps_compute_lastfs_dyn( iroot_sbtr, lastfssbtrdyn_p,
     &    mtype, keep, iw, liw, n, step, ptrist, fils, frere )
          DO WHILE (leaf_p .NE.1 .AND. info_p(1) .GE. 0)
            leaf_p = leaf_p - 1
            inode = ipool_p(leaf_p)
            ifath = dad(step(inode) )
            il0ompfac = l0_omp_mapping(step(inode))
            IF (il0ompfac .NE. thread_id) THEN
            ENDIF
            IF (do_prun) THEN
              is_inode_processed_p = to_process(step(inode))
            ELSE
              is_inode_processed_p = .true.
            ENDIF
            IF ( is_inode_processed_p ) THEN
              CALL dmumps_solve_node_fwd( inode,
     &        lastfssbtrsta_p, lastfssbtrdyn_p,
     &        bufr, lbufr, lbufr_bytes, myid, slavef, comm,   
     &        n, ipool_p, lpool_p, leaf_p,  nbfin_dummy, nstk,
     &        iwcb_p, liwcb_p, wcb_p, lwcb_p,
     &        l0_omp_factors(il0ompfac)%A(1),
     &        l0_omp_factors(il0ompfac)%LA,
     &        iw, liw, 
     &        nrhs, poswcb_p, pleftwcb_p, posiwcb_p, 
     &        ptricb, ptrist, ptrfac, procnode_steps,
     &        fils, step, frere, dad, info_p, keep, keep8, dkeep,
     &        rhs_root, lrhs_root, mtype,
     &        rhscomp, lrhscomp, posinrhscomp_fwd,
     &        istep_to_iniv2, tab_pos_in_pere, 
     &        rhs_bounds, lrhs_bounds, do_nbsparse, from_pp
     &        , error_was_broadcasted_p )
              IF (info_p(1) .LT. 0) THEN
!$OMP CRITICAL(critical_info)
                info(1) = info_p(1)
                info(2) = info_p(2)
!$OMP END CRITICAL(critical_info)
              ENDIF
              IF ( info(1) .LT. 0 ) GOTO 50
              IF (error_was_broadcasted_p) THEN
                WRITE(*,*) " Internal error 2 in DMUMPS_SOL_L0OMP_R",
     &          error_was_broadcasted_p
              ENDIF
            ENDIF
            IF ( ifath .EQ. 0 ) THEN
              IF ( is_inode_processed_p ) THEN
                nbroot_processed = nbroot_processed + 1
              ENDIF
            ELSE
              ptricb(step(inode)) = 0
              IF (ifath .NE. 0) THEN
                IF ( inode .NE. iroot_sbtr ) THEN
                  IF ( is_inode_processed_p ) THEN
                    nstk(step(ifath)) = nstk(step(ifath)) - 1
                  ENDIF
                  IF (nstk(step(ifath)) .EQ. 0 .OR.
     &                nstk(step(ifath)) .EQ. -1 ) THEN
                    ipool_p( leaf_p ) = ifath
                    leaf_p = leaf_p + 1
                    IF (do_prun) THEN
                      nstk(step(ifath)) = huge(nstk(step(ifath)))
                    ENDIF
                  ENDIF
                ELSE
                  IF ( is_inode_processed_p ) THEN
!$OMP ATOMIC UPDATE
                    nstk(step(ifath)) = nstk(step(ifath)) - 1
!$OMP END ATOMIC
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ENDDO
!$OMP ATOMIC CAPTURE
        virtual_task = next_task_dyn
        next_task_dyn = next_task_dyn + 1
!$OMP END ATOMIC
        GOTO 600
      ENDIF
  50  CONTINUE
      IF (allocated(ipool_p)) DEALLOCATE(ipool_p)
      IF (allocated(iwcb_p)) DEALLOCATE(iwcb_p)
      IF (allocated(wcb_p)) DEALLOCATE(wcb_p)
#if defined(WORKAROUNDINTELILP64OPENMPLIMITATION)
!$    CALL omp_set_num_threads(int(NOMP_SAVE,4))
#else
!$    CALL omp_set_num_threads(NOMP_SAVE)
#endif
!$OMP END PARALLEL
      nbroot_under_l0 = nbroot_processed
      RETURN
      END SUBROUTINE dmumps_sol_l0omp_r
      SUBROUTINE dmumps_sol_l0omp_s(N, MTYPE, NRHS, LIW, IW,
     &  PTRICB, PTRACB, RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD,
     &  STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO,
     &  KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF,
     &  COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, RHS_ROOT, LRHS_ROOT, 
     &  ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS,
     &  PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS,
     &  RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP, LPOOL_B_L0_OMP,
     &  L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP,
     &  PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING,
     &  L0_OMP_FACTORS, LL0_OMP_FACTORS )
      USE dmumps_struc_def, ONLY : dmumps_l0ompfac_t
      USE omp_lib
      IMPLICIT NONE
      INTEGER, INTENT( in ) :: N, MTYPE, NRHS, SLAVEF, LIW
      INTEGER, INTENT( in ) :: IW(LIW)
      INTEGER               :: INFO( 80 ), KEEP(500)
      INTEGER(8)            :: KEEP8(150)
      DOUBLE PRECISION                  :: DKEEP(230)
      INTEGER, INTENT( in ) :: PROCNODE_STEPS( KEEP(28) )
      INTEGER               :: PTRICB( KEEP(28) ) 
      INTEGER(8)            :: PTRACB( KEEP(28) ) 
      INTEGER, INTENT( in ) :: POSINRHSCOMP_BWD(N), LRHSCOMP 
      DOUBLE PRECISION, INTENT(inout):: RHSCOMP(LRHSCOMP,NRHS)
      INTEGER, INTENT( in ) :: STEP(N), FRERE( KEEP(28) ), FILS( N )
      INTEGER, INTENT( inout ) :: NE_STEPS(KEEP(28))
      INTEGER, INTENT( in )    :: PTRIST(KEEP(28))
      INTEGER(8), INTENT( in ) :: PTRFAC(KEEP(28))
      INTEGER,    INTENT( IN ) :: COMM, MYID
      INTEGER,    INTENT( IN ) :: LBUFR, LBUFR_BYTES
      INTEGER                  :: BUFR(LBUFR)
      INTEGER(8), INTENT(IN)   :: LRHS_ROOT
      DOUBLE PRECISION                  :: RHS_ROOT(LRHS_ROOT)
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
      INTEGER    :: LPANEL_POS
      INTEGER    :: PANEL_POS(LPANEL_POS)
      LOGICAL, INTENT( in ) :: DO_NBSPARSE
      INTEGER, INTENT( in ) :: LRHS_BOUNDS
      INTEGER, INTENT( in ) :: RHS_BOUNDS(LRHS_BOUNDS)
      LOGICAL, INTENT( in ) :: PRUN_BELOW_BWD
      INTEGER, INTENT( in ) :: SIZE_TO_PROCESS
      LOGICAL, INTENT( in ) :: TO_PROCESS(SIZE_TO_PROCESS)
      LOGICAL, INTENT( in ) :: FROM_PP
      INTEGER, INTENT( in ) :: LPOOL_B_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 ) :: 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( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING )
      INTEGER, INTENT( in ) :: LL0_OMP_FACTORS
      TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) ::
     &                        l0_omp_factors(ll0_omp_factors)
      INTEGER :: THREAD_ID, IL0OMPFAC
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOOL_P
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IWCB_P
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WCB_P
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: W2_P
      INTEGER, ALLOCATABLE, DIMENSION(:) :: PANEL_POS_P
      INTEGER :: LPOOL_P, IIPOOL_P, LIWCB_P, LPANEL_POS_P
      INTEGER :: MYLEAF_LEFT_HUGE_P 
      INTEGER(8) :: LWCB_P
      INTEGER(8) :: POSWCB_P, PLEFTWCB_P
      INTEGER    :: POSIWCB_P
      LOGICAL :: DO_MCAST2_TERMBWD_P
      LOGICAL :: ERROR_WAS_BROADCASTED_P
      INTEGER :: INFO_P(2), allocok
      INTEGER :: VIRTUAL_TASK, PHYSICAL_TASK
      INTEGER :: INODE
      INTEGER :: NEXT_TASK_DYN 
!$    INTEGER :: NOMP_SAVE
      INTEGER :: NBFIN_DUMMY
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: DEJA_SEND_DUMMY
      nbfin_dummy = huge(nbfin_dummy)
      ALLOCATE(deja_send_dummy( 0:slavef-1 ), stat=allocok)
      if(allocok.ne.0) then
         WRITE(6,*) ' Allocation error of DEJA_SEND_DUMMY in '
     &        //'routine DMUMPS_SOL_S '
         info(1)=-13
         info(2)=slavef
         GOTO 100
      endif
      ptricb = 0
      next_task_dyn = keep(400)+1
!$OMP PARALLEL
!$OMP& SHARED ( NEXT_TASK_DYN, LPOOL_B_L0_OMP,
!$omp&          nbfin_dummy, deja_send_dummy )
!$OMP& PRIVATE ( THREAD_ID, IL0OMPFAC, VIRTUAL_TASK, PHYSICAL_TASK,
!$OMP&           IPOOL_P, LPOOL_P, IIPOOL_P, MYLEAF_LEFT_HUGE_P,
!$OMP&           LIWCB_P, LWCB_P, IWCB_P, WCB_P, W2_P, LPANEL_POS_P,
!$OMP&           PANEL_POS_P,
!$OMP&           PLEFTWCB_P, POSWCB_P, POSIWCB_P,
!$OMP&           INODE,
!$OMP&           INFO_P, DO_MCAST2_TERMBWD_P,
!$OMP&           ERROR_WAS_BROADCASTED_P, NOMP_SAVE, allocok )
!$    NOMP_SAVE = omp_get_max_threads()
      thread_id = 1
!$    thread_id = omp_get_thread_num() + 1
!$OMP BARRIER
!$    CALL omp_set_num_threads(1)
      lpool_p = lpool_b_l0_omp
      info_p(1:2) = 0
      lwcb_p  = int(keep(133),8)*int(nrhs,8)
      liwcb_p = keep(133)
      pleftwcb_p = 1_8
      poswcb_p = lwcb_p
      posiwcb_p = liwcb_p
      IF (keep(201).EQ.1) THEN
        lpanel_pos_p = keep(228)+1 
        CALL mumps_abort()
      ELSE
        lpanel_pos_p = 1
      ENDIF
      ALLOCATE(ipool_p(lpool_p), iwcb_p(liwcb_p), wcb_p( lwcb_p),
     &         w2_p(keep(133)), panel_pos_p(lpanel_pos_p), stat=allocok)
      IF ( allocok > 0 ) THEN
        info_p(1) = -13
        CALL mumps_seti8toi4(lpool_p + liwcb_p + lwcb_p +
     &                       keep(133)+lpanel_pos_p, info(2))
!$OMP CRITICAL(critical_info)
        info(1) = -13
        info(2) = info_p(2)
!$omp END CRITICAL(critical_info)
      ENDIF
!$OMP BARRIER
      IF (info(1) .LT. 0) THEN
        GOTO 50
      ENDIF
      virtual_task = thread_id
 600  CONTINUE
      IF (virtual_task .LT. l_virt_l0_omp) THEN
        DO physical_task = virt_l0_omp( virtual_task ),
     &       virt_l0_omp( virtual_task + 1 ) - 1
          inode = phys_l0_omp( perm_l0_omp( physical_task ) )
          ipool_p(1) = inode
          iipool_p = 2
          myleaf_left_huge_p = huge(myleaf_left_huge_p)
          IF ( prun_below_bwd ) THEN
            IF ( .NOT. to_process(step(inode)) ) THEN
            cycle
            ENDIF
          ENDIF
          DO WHILE (iipool_p .NE.1 .AND. info_p(1) .GE. 0)
            iipool_p = iipool_p - 1
            inode = ipool_p(iipool_p)
            il0ompfac = l0_omp_mapping(step(inode))
            IF (il0ompfac .NE. thread_id) THEN
            ENDIF
            CALL dmumps_solve_node_bwd( inode, n, ipool_p, lpool_p,
     &      iipool_p,  nbfin_dummy, l0_omp_factors(il0ompfac)%A(1),
     &      l0_omp_factors(il0ompfac)%LA, iw, liw, 
     &      wcb_p, lwcb_p, nrhs, poswcb_p, pleftwcb_p, posiwcb_p,
     &      rhscomp, lrhscomp, posinrhscomp_bwd,
     &      ptricb, ptracb, iwcb_p, liwcb_p, w2_p, ne_steps, step,
     &      frere, fils, ptrist, ptrfac, myleaf_left_huge_p, info_p, 
     &      procnode_steps,
     &      deja_send_dummy,      
     &      slavef, comm, myid, bufr, lbufr, lbufr_bytes, 
     &      keep, keep8, dkeep, rhs_root, lrhs_root, mtype,
     &      istep_to_iniv2, tab_pos_in_pere, panel_pos_p, lpanel_pos_p,
     &      prun_below_bwd, to_process, size_to_process,
     &      rhs_bounds, lrhs_bounds, do_nbsparse, from_pp
     &          , error_was_broadcasted_p
     &          , do_mcast2_termbwd_p
     &    )
            IF (info_p(1) .LT. 0) THEN
!$OMP CRITICAL(critical_info)
              info(1) = info_p(1)
              info(2) = info_p(2)
!$OMP END CRITICAL(critical_info)
            ENDIF
            IF ( info(1) .LT. 0 ) GOTO 50
            IF (error_was_broadcasted_p) THEN
              WRITE(*,*) " Internal error 1 in DMUMPS_SOL_L0OMP_R",
     &        error_was_broadcasted_p
            ENDIF
            IF (do_mcast2_termbwd_p) THEN
              WRITE(*,*) " Internal error 2 in DMUMPS_SOL_L0OMP_R",
     &        do_mcast2_termbwd_p
            ENDIF
          ENDDO
        ENDDO
!$OMP ATOMIC CAPTURE
        virtual_task = next_task_dyn
        next_task_dyn = next_task_dyn + 1
!$OMP END ATOMIC
        GOTO 600
      ENDIF
  50  CONTINUE
      IF (allocated(ipool_p)) DEALLOCATE(ipool_p)
      IF (allocated(iwcb_p)) DEALLOCATE(iwcb_p)
      IF (allocated(wcb_p)) DEALLOCATE(wcb_p)
      IF (allocated(w2_p)) DEALLOCATE(w2_p)
      IF (allocated(panel_pos_p)) DEALLOCATE(panel_pos_p)
#if defined(workaroundintelilp64openmplimitation)
!$    CALL omp_set_num_threads(int(NOMP_SAVE,4))
#else
!$    CALL omp_set_num_threads(NOMP_SAVE)
#endif
!$OMP END PARALLEL
 100  CONTINUE
      IF (allocated(deja_send_dummy)) DEALLOCATE(deja_send_dummy)
      RETURN
      END SUBROUTINE dmumps_sol_l0omp_s
      END MODULE dmumps_sol_l0omp_m