dfac_process_root2slave.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 dmumps_process_root2slave( TOT_ROOT_SIZE,
     &    TOT_CONT_TO_RECV, root,
     &    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_S, COMP,
     &    IFLAG, IERROR, COMM, COMM_LOAD,
     &    IPOOL, LPOOL, LEAF,
     &    NBFIN, MYID, SLAVEF,
     &
     &    OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD,
     &    LPTRAR, NELT, FRTPTR, FRTELT, 
     &    PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND)
      USE dmumps_load
      USE dmumps_ooc        
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      TYPE (DMUMPS_ROOT_STRUC) :: root
      INTEGER KEEP(500), ICNTL(60)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION DKEEP(230)
      INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC
      INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      DOUBLE PRECISION A( LA )
      INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28))
      INTEGER STEP(N), PIMASTER(KEEP(28))
      INTEGER COMP
      INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) )
      INTEGER ND( KEEP(28) )
      INTEGER IFLAG, IERROR, COMM, COMM_LOAD
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER MYID, SLAVEF, NBFIN
      DOUBLE PRECISION OPASSW, OPELIW
      INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28))
      INTEGER LPTRAR, NELT
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR)
      DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
      INTEGER INTARR(KEEP8(27))
      DOUBLE PRECISION DBLARR(KEEP8(26))
      INTEGER ::  allocok
      DOUBLE PRECISION, DIMENSION(:,:), POINTER :: TMP
      INTEGER NEW_LOCAL_M, NEW_LOCAL_N
      INTEGER OLD_LOCAL_M, OLD_LOCAL_N
      INTEGER I, J
      INTEGER LREQI, IROOT
      INTEGER(8) :: LREQA
      INTEGER POSHEAD, IPOS_SON,IERR
      LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT
      DOUBLE PRECISION ZERO
      parameter( zero = 0.0d0 )
      include 'mumps_headers.h'
      INTEGER numroc, MUMPS_PROCNODE
      EXTERNAL numroc, mumps_procnode
      iroot = keep( 38 )
      root%TOT_ROOT_SIZE = tot_root_size
      master_of_root = ( myid .EQ. 
     &                   mumps_procnode( procnode_steps(step(iroot)),
     &                   keep(199) ) )
      new_local_m  = numroc( tot_root_size, root%MBLOCK,
     &               root%MYROW, 0, root%NPROW )
      new_local_m  = max( 1, new_local_m )
      new_local_n  = numroc( tot_root_size, root%NBLOCK,
     &               root%MYCOL, 0, root%NPCOL )
      IF ( ptrist(step( iroot )).GT.0) THEN
        old_local_n = -iw( ptrist(step( iroot )) + keep(ixsz) )
        old_local_m =  iw( ptrist(step( iroot )) + 1  + keep(ixsz))
      ELSE
        old_local_n = 0
        old_local_m = new_local_m
      ENDIF
      IF (ptrist(step(iroot)) .EQ.0) THEN
        no_old_root = .true.
      ELSE
        no_old_root =.false.
      ENDIF
      IF (keep(60) .NE. 0) THEN
        IF ( master_of_root ) THEN
          lreqi=6+2*tot_root_size+keep(ixsz)
          lreqa=0_8
          IF ( iwpos + lreqi - 1. gt. iwposcb ) THEN
           CALL dmumps_compre_new( n, keep, iw, liw, a, la,
     &           lrlu, iptrlu,
     &           iwpos, iwposcb, ptrist, ptrast,
     &           step, pimaster, pamaster, lrlus,
     &           keep(ixsz),comp,dkeep(97),
     &           myid, slavef, procnode_steps, dad )
           IF ( lrlu .NE. lrlus ) THEN
                  WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=',
     &            lrlu, lrlus
                  iflag = -9
                  CALL mumps_set_ierror(lreqa-lrlus, ierror)
                  GOTO 700
           END IF
          ENDIF
          IF ( iwpos + lreqi - 1. gt. iwposcb ) THEN
            iflag = -8
            ierror = iwpos + lreqi - 1 - iwposcb
            GOTO 700
          ENDIF
          ptlust(step(iroot))= iwpos
          iwpos = iwpos + lreqi
          poshead = ptlust( step(iroot))
          iw( poshead + xxi )=lreqi
          CALL mumps_storei8( lreqa, iw(poshead + xxr) )
          CALL mumps_storei8( 0_8, iw(poshead + xxd) )
          iw( poshead + xxs )=-9999
          iw(poshead+xxs+1:poshead+keep(ixsz)-1)=-99999
          iw( poshead +keep(ixsz)) = 0
          iw( poshead + 1 +keep(ixsz)) = -1
          iw( poshead + 2 +keep(ixsz)) = -1
          iw( poshead + 4 +keep(ixsz)) = step(iroot)
          iw( poshead + 5 +keep(ixsz)) = 0
          iw( poshead + 3 +keep(ixsz)) = tot_root_size
        ELSE 
          ptlust(step(iroot)) = -4444
        ENDIF
        ptrist(step(iroot)) = 0
        ptrfac(step(iroot)) = -4445_8
        IF (root%yes .and. no_old_root) THEN
          IF (new_local_n .GT. 0) THEN
            CALL dmumps_set_to_zero(root%SCHUR_POINTER(1),
     &      root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC,
     &      keep)
            IF (keep(55).EQ.0) THEN
              CALL dmumps_asm_arr_root( n, root, iroot,
     &        root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC,
     &        root%SCHUR_NLOC, fils, ptraiw, ptrarw, intarr, dblarr,
     &        keep8(27), keep8(26), myid )
            ELSE
              CALL dmumps_asm_elt_root(n, root,
     &        root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC,
     &        root%SCHUR_NLOC, lptrar, nelt, frtptr, frtelt,
     &        ptraiw, ptrarw, intarr, dblarr,
     &        keep8(27), keep8(26), keep, keep8, myid )
            ENDIF
          ENDIF
        ENDIF
      ELSE
        IF ( master_of_root ) THEN
          lreqi = 6 + 2 * tot_root_size+keep(ixsz)
        ELSE
          lreqi = 6+keep(ixsz)
        END IF
        lreqa = int(new_local_m, 8) * int(new_local_n, 8)
        CALL dmumps_get_size_needed( 
     &           lreqi , lreqa, .false.,
     &           keep(1), keep8(1),
     &           n, iw, liw, a, la,
     &           lrlu, iptrlu,
     &           iwpos, iwposcb, ptrist, ptrast,
     &           step, pimaster, pamaster, lrlus,
     &           keep(ixsz), comp, dkeep(97),
     &           myid, slavef, procnode_steps, dad, 
     &           iflag, ierror )
        IF (iflag.LT.0) GOTO 700
        ptlust(step( iroot )) = iwpos
        iwpos           = iwpos + lreqi
        IF (lreqa.EQ.0_8) THEN
          ptrast(step(iroot)) = posfac
          ptrfac(step(iroot)) = posfac
        ELSE
          ptrast(step(iroot)) = posfac
          ptrfac(step(iroot)) = posfac
        ENDIF
        posfac           = posfac + lreqa
        lrlu   = lrlu  - lreqa
        lrlus  = lrlus - lreqa
        keep8(67) = min(keep8(67), lrlus)
        keep8(69) = keep8(69) + lreqa
        keep8(68) = max(keep8(69), keep8(68))
        CALL dmumps_load_mem_update(.false.,.false.,
     &            la-lrlus,0_8,lreqa,keep,keep8,lrlus)
        poshead = ptlust( step(iroot))
        iw( poshead + xxi )     = lreqi
        CALL mumps_storei8( lreqa, iw(poshead + xxr))
        CALL mumps_storei8( 0_8, iw(poshead + xxd))
        iw( poshead + xxs ) = s_notfree
        iw(poshead+xxs+1:poshead+keep(ixsz)-1)=-99999
        iw( poshead + keep(ixsz) ) = 0
        iw( poshead + 1 + keep(ixsz) ) = new_local_n
        iw( poshead + 2 + keep(ixsz) ) = new_local_m
        iw( poshead + 4 + keep(ixsz) ) = step(iroot)
        iw( poshead + 5 + keep(ixsz) ) = 0
        IF ( master_of_root ) THEN
          iw( poshead + 3 + keep(ixsz) ) = tot_root_size
        ELSE
          iw( poshead + 3 + keep(ixsz) ) = 0
        ENDIF
        IF ( ptrist(step(iroot)) .EQ. 0) THEN
          CALL dmumps_set_to_zero(a(ptrast(step(iroot))),
     &    new_local_m, new_local_m, new_local_n, keep)
          IF (keep(55) .EQ.0 ) THEN
            CALL dmumps_asm_arr_root( n, root, iroot,
     &      a(ptrast(step(iroot))),
     &      new_local_m, new_local_m, new_local_n,
     &      fils, ptraiw, ptrarw, intarr, dblarr,
     &      keep8(27), keep8(26), myid )
          ELSE
            CALL dmumps_asm_elt_root( n, root,
     &      a(ptrast(step(iroot))),
     &      new_local_m, new_local_m, new_local_n,
     &      lptrar, nelt, frtptr, frtelt,
     &      ptraiw, ptrarw, intarr, dblarr,
     &      keep8(27), keep8(26), keep, keep8, myid )
          ENDIF
          pamaster(step(iroot)) = 0_8
        ELSE IF ( ptrist(step(iroot)) .LT. 0 ) THEN
          CALL dmumps_set_to_zero(a(ptrast(step(iroot))),
     &    new_local_m, new_local_m, new_local_n, keep)
        ELSE
          old_local_n = -iw( ptrist(step( iroot )) + keep(ixsz) )
          old_local_m =  iw( ptrist(step( iroot )) + 1  + keep(ixsz))
          IF ( tot_root_size .eq. root%ROOT_SIZE ) THEN
            IF ( lreqa .NE. int(old_local_m,8) * int(old_local_n,8) )
     &            THEN
              write(*,*) 'error 1 in PROCESS_ROOT2SLAVE',
     &        old_local_m, old_local_n
              CALL mumps_abort()
            END IF
            CALL dmumps_copyi8size(lreqa,
     &                            a( pamaster(step(iroot)) ),
     &                            a( ptrast(step(iroot)) ) )
          ELSE
            CALL dmumps_copy_root( a( ptrast(step(iroot))), 
     &          new_local_m,
     &          new_local_n, a( pamaster( step(iroot)) ), old_local_m,
     &          old_local_n )
          END IF
          IF ( ptrist( step( iroot ) ) .GT. 0 ) THEN
             ipos_son= ptrist( step(iroot))
             CALL dmumps_free_block_cb_static(.false.,
     &            myid, n, ipos_son,
     &            iw, liw, lrlu, lrlus, iptrlu,
     &            iwposcb, la, keep,keep8, .false.
     &           )
          END IF
        ENDIF 
        ptrist(step( iroot ))   = 0
        pamaster(step( iroot )) = 0_8
      ENDIF 
      IF ( no_old_root ) THEN
          IF (keep(253) .GT.0) THEN
            root%RHS_NLOC = numroc( keep(253), root%NBLOCK,
     &                      root%MYCOL, 0, root%NPCOL )
            root%RHS_NLOC = max( root%RHS_NLOC, 1 )
          ELSE
            root%RHS_NLOC = 1
          ENDIF
          IF (associated(root%RHS_ROOT)) DEALLOCATE(root%RHS_ROOT)
          ALLOCATE(root%RHS_ROOT(new_local_m, root%RHS_NLOC),
     &              stat=allocok)
          IF ( allocok.GT.0 ) THEN
             iflag = -13
             ierror = new_local_n * root%RHS_NLOC
            GOTO 700
          ENDIF
          IF (keep(253) .NE. 0) THEN
            root%RHS_ROOT=zero
            CALL dmumps_asm_rhs_root( n, fils, root, keep, rhs_mumps,
     &      iflag, ierror )
          ENDIF
      ELSE IF (new_local_m.GT.old_local_m .AND. keep(253) .GT.0) THEN
          tmp => root%RHS_ROOT
          NULLIFY(root%RHS_ROOT)
          ALLOCATE (root%RHS_ROOT(new_local_m, root%RHS_NLOC), 
     &                stat=allocok)
          IF ( allocok.GT.0) THEN
              iflag=-13
              ierror = new_local_m*root%RHS_NLOC
              GOTO 700
          ENDIF
          DO j = 1, root%RHS_NLOC
            DO i = 1, old_local_m
              root%RHS_ROOT(i,j)=tmp(i,j)
            ENDDO
            DO i = old_local_m+1, new_local_m
              root%RHS_ROOT(i,j) = zero
            ENDDO
          ENDDO
          DEALLOCATE(tmp)
          NULLIFY(tmp) 
      ENDIF
      keep(121) = keep(121) + tot_cont_to_recv
      IF ( keep(121) .eq. 0 ) 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
        CALL dmumps_insert_pool_n( n, ipool, lpool, procnode_steps,
     &       slavef, keep(199), keep(28), keep(76), keep(80), keep(47),
     &       step, iroot + n )
        IF (keep(47) .GE. 3) THEN
           CALL dmumps_load_pool_upd_new_pool(
     &          ipool, lpool, 
     &          procnode_steps, keep,keep8, slavef, comm_load,
     &          myid, step, n, nd, fils )
        ENDIF
      END IF
      RETURN
 700  CONTINUE
      CALL dmumps_bdc_error( myid, slavef, comm, keep )
      RETURN
      END SUBROUTINE dmumps_process_root2slave
      SUBROUTINE dmumps_copy_root
     &( new, m_new, n_new,old, m_old, n_old )
      INTEGER M_NEW, N_NEW, M_OLD, N_OLD
      DOUBLE PRECISION NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD )
      INTEGER J
      DOUBLE PRECISION ZERO
      PARAMETER( ZERO = 0.0d0 )
      DO j = 1, n_old
        new( 1: m_old, j ) = old( 1: m_old, j )
        new( m_old + 1: m_new, j ) = zero
      END DO
      new( 1: m_new,n_old + 1: n_new ) = zero
      RETURN
      END SUBROUTINE dmumps_copy_root