zsol_bwd.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_s(N, A, LA, IW, LIW, W, LWC,
     &    NRHS, 
     &    RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD,
     &    PTRICB, PTRACB, IWCB, LIWW, W2, 
     &    NE_STEPS, STEP,
     &    FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, 
     &    MYLEAF, MYROOT, ICNTL, INFO, 
     &    PROCNODE_STEPS,
     &    SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES,
     &    KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, 
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS
     &    , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS
     &    , 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
      INTEGER(8), intent(in) :: LWC
      INTEGER, intent(in) :: N,LIW,LIWW,LPOOL
      INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID
      INTEGER KEEP( 500 )
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
      INTEGER PROCNODE_STEPS(KEEP(28))
      INTEGER NE_STEPS(KEEP(28))
      INTEGER IPOOL(LPOOL)
      INTEGER LPANEL_POS
      INTEGER PANEL_POS(LPANEL_POS)
      INTEGER ICNTL(60), INFO(80)
      INTEGER PTRIST(KEEP(28)),
     &        ptricb(keep(28))
      INTEGER(8) :: PTRACB(KEEP(28))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER NRHS
      COMPLEX(kind=8) A(LA), W(LWC)
      COMPLEX(kind=8) W2(KEEP(133))
      INTEGER IW(LIW),IWCB(LIWW)
      INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N)
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR(LBUFR)
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N)
      COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS)
      INTEGER(8), intent(in) :: LRHS_ROOT
      COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT )
      LOGICAL, INTENT(in) :: PRUN_BELOW
      INTEGER, intent(in)           :: SIZE_TO_PROCESS
      LOGICAL, intent(in)           :: TO_PROCESS(SIZE_TO_PROCESS)
      LOGICAL, intent(in) :: DO_NBSPARSE
      INTEGER, intent(in) :: LRHS_BOUNDS
      INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS)
      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'
      LOGICAL FLAG
      COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR
      INTEGER(8) :: LA_PTR
      INTEGER :: UNDERL0MAP 
      INTEGER(8) :: POSWCB, PLEFTW
      INTEGER POSIWCB
      INTEGER NBFINF
      INTEGER INODE
      INTEGER III,IIPOOL,MYLEAF_LEFT
      LOGICAL BLOQ
      INTEGER DUMMY(1)
      LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD
      LOGICAL :: ALLOW_OTHERS_TO_LEAVE
      LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND
      INTEGER :: allocok
      dummy(1)=0
      keep(266)=0
      ALLOCATE(deja_send( 0:slavef-1 ), stat=allocok)
      if(allocok.ne.0) then
         WRITE(6,*) ' Allocation error of DEJA_SEND in '
     &        //'routine ZMUMPS_SOL_S '
         info(1)=-13
         info(2)=slavef
      endif
      CALL mumps_propinfo( icntl, info, comm, myid )
      IF ( info(1) .LT.0 ) GOTO 340
      pleftw = 1_8
      posiwcb = liww
      poswcb = lwc
      iii = 1
      iipool = myroot + 1
      myleaf_left = myleaf
      nbfinf = slavef
      allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
     &                          keep(31) .EQ. 0 )
      allow_others_to_leave = allow_others_to_leave .OR.
     &                        keep(31) .EQ. 1
      IF (allow_others_to_leave) THEN
        CALL zmumps_mcast2(dummy, 1, mpi_integer, myid, comm, termbwd,
     &                  slavef, keep)
        nbfinf = nbfinf - 1
        IF (nbfinf .EQ. 0 .AND. myleaf_left .EQ. 0) THEN
          GOTO 340
        ENDIF
      ENDIF
      error_was_broadcasted = .false.
      do_mcast2_termbwd = .false.
      DO WHILE ( nbfinf .NE. 0 .OR. myleaf_left .NE. 0 )
        bloq = (  iii .EQ. iipool  )
        CALL zmumps_backslv_recv_and_treat( bloq, flag, bufr, lbufr,
     &     lbufr_bytes, myid, slavef, comm,
     &     n, iwcb, liww, posiwcb,
     &     w, lwc, poswcb,
     &     iipool, nbfinf, ptricb, ptracb, info,
     &     ipool, lpool, panel_pos, lpanel_pos,
     &     step,  frere, fils, procnode_steps,
     &     pleftw, keep,keep8, dkeep,
     &     ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left, 
     &     nrhs, mtype, 
     &     rhscomp, lrhscomp, posinrhscomp_bwd
     &     , prun_below, to_process, size_to_process
     &     , from_pp
     &     )
        IF ( info(1) .LT. 0 ) GOTO 340 
        IF ( .NOT. flag ) THEN
          IF (iii .NE. iipool) THEN
            inode = ipool(iipool-1)
            iipool = iipool - 1
            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_bwd( inode, 
     &        n, ipool, lpool, iipool, nbfinf,
     &        a_ptr(1), la_ptr, iw, liw, w, lwc, nrhs,
     &        poswcb, pleftw, posiwcb,
     &        rhscomp, lrhscomp, posinrhscomp_bwd,
     &        ptricb, ptracb, iwcb, liww, w2, 
     &        ne_steps, step,
     &        frere, fils, ptrist, ptrfac,
     &        myleaf_left, info,
     &        procnode_steps, deja_send,
     &        slavef, comm, myid, bufr, lbufr, lbufr_bytes,
     &        keep,keep8, dkeep, rhs_root, lrhs_root, mtype,
     &        istep_to_iniv2, tab_pos_in_pere, panel_pos, lpanel_pos,
     &        prun_below, to_process, size_to_process
     &        , rhs_bounds, lrhs_bounds, do_nbsparse, from_pp
     &        , error_was_broadcasted
     &        , do_mcast2_termbwd
     &        )
            IF ( info(1) .LT. 0 ) THEN
              IF (.NOT. error_was_broadcasted) THEN
                IF (nbfinf .EQ. 0 ) THEN
                  CALL zmumps_bdc_error( myid, slavef, comm, keep )
                ENDIF
              ENDIF
            ENDIF
            IF (do_mcast2_termbwd) THEN
              CALL zmumps_mcast2( dummy, 1,  mpi_integer, myid, comm,
     &                            termbwd, slavef, keep )
            ENDIF
          ENDIF                   
        END IF                    
      ENDDO
  340 CONTINUE
      IF (ALLOCATED(deja_send)) DEALLOCATE(deja_send)
      RETURN
      END SUBROUTINE zmumps_sol_s