zsol_fwd.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
      SUBROUTINE zmumps_sol_r(N, A, LA, IW, LIW, WCB, LWCB,
     &    NRHS,
     &    PTRICB, IWCB, LIWCB, 
     &    RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, 
     &    STEP,
     &    FRERE, DAD, FILS,
     &    NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT,
     &    INFO,
     &    KEEP, KEEP8, DKEEP,
     &    PROCNODE_STEPS,
     &    SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,
     &    RHS_ROOT, LRHS_ROOT, MTYPE, 
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &    , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP
     &    , L0_OMP_MAPPING, LL0_OMP_MAPPING,
     &    L0_OMP_FACTORS, LL0_OMP_FACTORS
     &    )
      USE zmumps_static_ptr_m, ONLY : zmumps_set_static_ptr,
     &                                zmumps_get_tmp_ptr
      USE zmumps_struc_def, ONLY : zmumps_l0ompfac_t
      IMPLICIT NONE
      INTEGER MTYPE
      INTEGER(8), INTENT(IN) :: LA, LWCB
      INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB
      INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID
      INTEGER INFO( 80 ), KEEP(500)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
      INTEGER PROCNODE_STEPS( KEEP(28) )
      INTEGER NRHS
      COMPLEX(kind=8) A( LA ), WCB( LWCB )
      INTEGER(8), intent(in) :: LRHS_ROOT
      COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT )
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ),
     &        dad( keep(28) )
      INTEGER NSTK(KEEP(28)), IPOOL( LPOOL )
      INTEGER PTRIST(KEEP(28))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER PTRICB( KEEP(28) ) 
      LOGICAL, intent(in) :: DO_NBSPARSE
      INTEGER, intent(in) :: LRHS_BOUNDS
      INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS)
      INTEGER IW( LIW ), IWCB( LIWCB )
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER, intent(in) ::  POSINRHSCOMP_FWD(N), LRHSCOMP 
      COMPLEX(kind=8), intent(inout) :: RHSCOMP(LRHSCOMP,NRHS)
      LOGICAL, intent(in) :: FROM_PP
      INTEGER, INTENT( in ) :: LL0_OMP_MAPPING, LL0_OMP_FACTORS
      INTEGER, INTENT( in ) :: L0_OMP_MAPPING( LL0_OMP_MAPPING )
      TYPE (ZMUMPS_L0OMPFAC_T), INTENT(IN) ::
     &                        L0_OMP_FACTORS(LL0_OMP_FACTORS)
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER DUMMY(1)
      LOGICAL FLAG
      COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR
      INTEGER(8) :: LA_PTR
      INTEGER :: UNDERL0MAP 
      INTEGER NBFIN, MYROOT_LEFT
      INTEGER POSIWCB
      INTEGER(8) :: POSWCB, PLEFTWCB
      INTEGER INODE, IFATH
      INTEGER III, LEAF
      LOGICAL BLOQ
      EXTERNAL mumps_procnode
      INTEGER MUMPS_PROCNODE
      LOGICAL ERROR_WAS_BROADCASTED
      DUMMY(1) = 1
      keep(266)=0
      posiwcb = liwcb
      poswcb  = lwcb
      pleftwcb= 1_8
      ptricb = 0
      leaf = myleaf + 1
      iii    = 1
      nbfin = slavef
      myroot_left = myroot
      IF ( myroot_left .EQ. 0 ) THEN
        nbfin = nbfin - 1
        CALL zmumps_mcast2(dummy, 1, mpi_integer, myid, comm,
     &       racine_solve, slavef, keep)
        IF (nbfin.EQ.0) GOTO 260
      END IF
   50 CONTINUE
      IF (slavef .EQ. 1) THEN
         CALL zmumps_get_inode_from_pool
     &        ( ipool(1), lpool, iii, leaf, inode,
     &          keep(208) )
        GOTO 60
      ENDIF
      bloq = ( ( iii .EQ. leaf )
     &     )
      CALL zmumps_solve_recv_and_treat( bloq, flag,
     &     bufr, lbufr, lbufr_bytes,
     &     myid, slavef, comm,
     &     n, nrhs, ipool, lpool, leaf,
     &     nbfin, nstk, iw, liw, a, la, ptrist, ptrfac,
     &     iwcb, liwcb,
     &     wcb, lwcb, poswcb,
     &     pleftwcb, posiwcb,
     &     ptricb, info, keep,keep8, dkeep, step,
     &     procnode_steps,
     &     rhscomp, lrhscomp, posinrhscomp_fwd
     &     , from_pp
     &    )
      IF ( info( 1 ) .LT. 0 .OR. nbfin .EQ. 0 ) GOTO 260
      IF (.not. flag) THEN
         IF (iii .NE. leaf) THEN
            CALL zmumps_get_inode_from_pool
     &           (ipool(1), lpool, iii, leaf, inode,
     &           keep(208) )
            GOTO 60
         ENDIF                  
      ENDIF                     
      GOTO 50
 60   CONTINUE
      IF (keep(400) .GT. 0 ) THEN
        underl0map = l0_omp_mapping(step(inode))
      ELSE
        underl0map = 0
      ENDIF
      IF (underl0map .EQ. 0 .OR. keep(201).GT.0) THEN
        CALL zmumps_set_static_ptr(a)
        CALL zmumps_get_tmp_ptr(a_ptr)
        la_ptr = la
      ELSE
        a_ptr => l0_omp_factors(underl0map)%A
        la_ptr = l0_omp_factors(underl0map)%LA
      ENDIF
      CALL zmumps_solve_node_fwd( inode,
     &        huge(inode), huge(inode), 
     &        bufr, lbufr, lbufr_bytes,
     &        myid, slavef, comm,  n,
     &        ipool, lpool, leaf, nbfin, nstk,
     &        iwcb, liwcb, wcb, lwcb, a_ptr(1), la_ptr,
     &        iw, liw, nrhs, 
     &        poswcb, pleftwcb, posiwcb,
     &        ptricb, ptrist, ptrfac, procnode_steps,
     &        fils, step, frere, dad,
     &        info, 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
     & )
      IF ( info(1) .LT. 0 ) THEN
        IF (.NOT. error_was_broadcasted) THEN
          CALL zmumps_bdc_error( myid, slavef, comm, keep )
        ENDIF
        GOTO 260
      ENDIF
      ifath = dad(step(inode))
      IF ( ifath .EQ. 0 ) THEN
        myroot_left = myroot_left - 1
        IF (myroot_left .EQ. 0) THEN
          nbfin = nbfin - 1
          IF (slavef .GT. 1) THEN
            CALL zmumps_mcast2(dummy, 1, mpi_integer, myid,
     &           comm, racine_solve, slavef, keep)
          ENDIF
        END IF
      ELSE
        IF ( mumps_procnode(procnode_steps(step(ifath)), keep(199))
     &       .EQ. myid ) THEN
           IF ( ptricb(step(inode)) .EQ. 1 .OR.
     &          ptricb(step(inode)) .EQ. -1 ) THEN
             nstk(step(ifath)) = nstk(step(ifath)) - 1
             IF (nstk(step(ifath)) .EQ. 0) THEN
               ipool(leaf) = ifath
               leaf = leaf + 1
               IF (leaf .GT. lpool) THEN
                  WRITE(*,*)
     &            'Internal error ZMUMPS_TRAITER_MESSAGE_SOLVE',
     &            leaf, lpool
                  CALL mumps_abort()
               ENDIF
             ENDIF
             ptricb(step(inode)) = 0
           ENDIF
        ENDIF
      ENDIF
      IF ( nbfin .EQ. 0 ) GOTO 260
      GOTO 50
  260 CONTINUE
      CALL zmumps_clean_pending(info(1), keep, bufr, lbufr,lbufr_bytes,
     &     comm, dummy(1),  
     &     slavef, .true., .false.) 
      RETURN
      END SUBROUTINE zmumps_sol_r