dfac_process_root2son.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
      RECURSIVE SUBROUTINE 
     &    dmumps_process_root2son( comm_load, ass_irecv, 
     &    inode, nelim_root, root, 
     &
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm,
     &    perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &    opassw, opeliw, 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
     &               , lrgroups
     &     )
      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 comm_load, ass_irecv
      INTEGER inode, nelim_root
      INTEGER lbufr, lbufr_bytes
      INTEGER bufr( lbufr )
      INTEGER(8) :: la, posfac, IPTRLU, lrlu, lrlus
      INTEGER iwpos, iwposcb
      INTEGER n, liw
      INTEGER iw( liw )
      DOUBLE PRECISION a( la )
      INTEGER, intent(in) :: LRGROUPS(n)
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER ptrist(keep(28)), ptlust_s(keep(28))
      INTEGER step(n), pimaster(KEEP(28))
      INTEGER comp
      INTEGER nstk_s( keep(28) ), procnode_steps( keep(28) )
      INTEGER perm(n)
      INTEGER iflag, ierror, comm
      INTEGER lpool, leaf
      INTEGER ipool( lpool )
      INTEGER nelt, lptrar
      INTEGER frtptr( n+1 ), frtelt( nelt )
      INTEGER myid, slavef, nbfin
      DOUBLE PRECISION opassw, opeliw
      INTEGER itloc( n + keep(253) ), fils( n ), dad(keep(28))
      DOUBLE PRECISION :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER nd( keep(28) ), frere( keep(28) ) 
      INTEGER intarr(keep8(27))
      DOUBLE PRECISION dblarr(keep8(26))
      INTEGER istep_to_iniv2(keep(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      include 'mumps_tags.h'
      include 'mumps_headers.h'
      INTEGER i, lcont, NCOL_TO_SEND, lda
      INTEGER(8) :: SHIFT_VAL_SON, poselt
      INTEGER fpere, ioldps, NFRONT, npiv, nass, nslaves,
     &        h_inode, nelim, nbcol, list_nelim_row, 
     &        list_nelim_col, nelim_local, type_son, 
     &        nrow, ncol, nbrow, shift_list_row_son,
     &        shift_list_col_son, ldafs, ierr,
     &        ison, pdest_master_ison
      INTEGER :: status(mpi_status_size)
      LOGICAL blocking, set_irecv, message_received
      INTEGER msgsou, msgtag
      LOGICAL transpose_asm
      INTEGER  mumps_procnode, mumps_typenode
      EXTERNAL mumps_procnode, mumps_typenode
      fpere = keep(38)
      type_son = mumps_typenode(procnode_steps(step(inode)),keep(199))
      IF ( mumps_procnode( procnode_steps(step(inode)), 
     &     keep(199) ).EQ.myid) THEN
       ioldps   = ptlust_s(step(inode))
       nfront   = iw(ioldps+keep(ixsz))
       npiv     = iw(ioldps+1+keep(ixsz))
       nass     = iabs(iw(ioldps + 2+keep(ixsz)))
       nslaves  =  iw(ioldps+5+keep(ixsz))
       h_inode  = 6 + nslaves + keep(ixsz)
       nelim    = nass - npiv
       nbcol = nfront - npiv
       list_nelim_row = ioldps + h_inode + npiv
       list_nelim_col = list_nelim_row + nfront
       IF (nelim.LE.0) THEN
            write(6,*) ' ERROR 1 in DMUMPS_PROCESS_ROOT2SON ', nelim
            write(6,*) myid,':Process root2son: INODE=',inode,
     & 'Header=',iw(ptlust_s(step(inode)):ptlust_s(step(inode))
     &  +5+keep(ixsz))
            CALL mumps_abort()
           ENDIF
       nelim_local = nelim_root
       DO i=1, nelim
        root%RG2L_ROW(iw(list_nelim_row)) = nelim_local
        root%RG2L_COL(iw(list_nelim_col)) = nelim_local
        nelim_local = nelim_local + 1
        list_nelim_row = list_nelim_row + 1
        list_nelim_col = list_nelim_col + 1
       ENDDO
       nbrow = nfront - npiv
       nrow = nelim
       IF ( keep( 50 ) .eq. 0 ) THEN
         ncol = nfront - npiv
       ELSE
         ncol = nelim
       END IF
       shift_list_row_son = h_inode + npiv
       shift_list_col_son = h_inode + nfront + npiv
       IF ( keep(50).eq.0 .OR. type_son .eq. 1 ) THEN
         ldafs = nfront
       ELSE
         ldafs = nass
       END IF
       shift_val_son = int(npiv,8) * int(ldafs,8) + int(npiv,8)
       CALL dmumps_build_and_send_cb_root( comm_load,
     &   ass_irecv, 
     &   n, inode, fpere,
     &   ptlust_s(1), ptrast(1),
     &   root, nrow, ncol, shift_list_row_son,
     &   shift_list_col_son , shift_val_son, ldafs,
     &   root_non_elim_cb, myid, comm,
     &   bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &   iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
     &   ptrist, ptlust_s(1), ptrfac(1), ptrast(1),
     &   step, pimaster, pamaster,
     &   nstk_s, comp, iflag, ierror, perm,
     &   ipool, lpool, leaf, nbfin, slavef,
     &   opassw, opeliw, itloc, rhs_mumps,
     &   fils, dad, ptrarw, ptraiw,
     &   intarr,dblarr,icntl,keep,keep8,dkeep,.false.,nd,frere,
     &   lptrar, nelt, frtptr, frtelt, 
     &   istep_to_iniv2, tab_pos_in_pere
     &               , lrgroups
     &    )
       IF (iflag.LT.0 ) RETURN
       IF (type_son.EQ.1) THEN
        nrow = nfront - nass
        ncol = nelim
        shift_list_row_son = h_inode + nass
        shift_list_col_son = h_inode + nfront + npiv
        shift_val_son      = int(nass,8) * int(nfront,8) + int(npiv,8)
        IF ( keep( 50 ) .eq. 0 ) THEN
          transpose_asm = .false.
        ELSE
          transpose_asm = .true.
        END IF
        CALL dmumps_build_and_send_cb_root( comm_load, ass_irecv,
     &    n, inode, fpere,
     &    ptlust_s, ptrast,
     &    root, nrow, ncol, shift_list_row_son,
     &    shift_list_col_son , shift_val_son, nfront,
     &    root_non_elim_cb, myid, comm,
     &
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
     &    ptrist, ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster,
     &    nstk_s, comp, iflag, ierror, perm,
     &    ipool, lpool, leaf, nbfin, slavef,
     &    opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr,dblarr,icntl,keep,keep8,dkeep,
     &    transpose_asm,nd,frere,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere, lrgroups )
        IF (iflag.LT.0 ) RETURN
       ENDIF
       ioldps = ptlust_s(step(inode))
       poselt = ptrast(step(inode))
       iw(ioldps + 4+keep(ixsz)) = step(inode)
       ptrfac(step(inode))=poselt
       IF ( type_son .eq. 1 ) THEN
         nbrow = nfront - npiv
       ELSE
         nbrow = nelim
       END IF
       IF ( type_son .eq. 1 .OR. keep(50).EQ.0) THEN
         lda = nfront
       ELSE
         lda = npiv+nbrow
       ENDIF
       CALL dmumps_compact_factors(a(poselt), lda,
     &          npiv, nbrow, keep,
     &          int(lda,8)*int(nbrow+npiv,8), iw(ioldps+h_inode+nfront))
       iw(ioldps + keep(ixsz))     = nbcol
       iw(ioldps + 1 +keep(ixsz)) = nass - npiv
       IF (type_son.EQ.2) THEN
        iw(ioldps + 2 +keep(ixsz)) = nass
       ELSE
        iw(ioldps + 2 +keep(ixsz)) = nfront
       ENDIF
       iw(ioldps + 3 +keep(ixsz)) = npiv
      CALL dmumps_compress_lu(0_8,myid,n,ioldps,type_son,iw,liw,
     &    a, la, posfac, lrlu, lrlus,
     &    iwpos, ptrast,ptrfac,step, keep,keep8, .false.,inode,ierr
     &    , lrgroups, nass
     &    )
      IF(ierr.LT.0)THEN
         iflag=ierr
         ierror=0
         RETURN
      ENDIF
      ELSE 
        ison = inode
        pdest_master_ison = 
     &      mumps_procnode( procnode_steps(step(ison)), keep(199) )
        IF ( ptrist(step(ison)) .EQ. 0) THEN
          CALL dmumps_treat_descband( ison, comm_load,
     &    ass_irecv,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm,
     &    perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &    root, opassw, opeliw, 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, .true.
     &               , lrgroups
     &   )
          IF ( iflag .LT. 0 ) RETURN
        ENDIF
        DO WHILE (
     &     ( iw( ptrist(step(ison)) + 1  +keep(ixsz)) .NE.
     &       iw( ptrist(step(ison)) + 3  +keep(ixsz)) ) .OR.
     &     ( keep(50) .NE. 0 .AND.
     &       iw( ptrist(step(ison)) + 6  +keep(ixsz)) .NE. 0 ) )
          IF ( keep(50).eq.0) THEN
            msgsou = pdest_master_ison
            msgtag = bloc_facto
          ELSE
            IF ( iw( ptrist(step(ison)) + 1  +keep(ixsz)) .NE.
     &           iw( ptrist(step(ison)) + 3  +keep(ixsz)) ) THEN
              msgsou = pdest_master_ison
              msgtag = bloc_facto_sym
            ELSE
              msgsou = mpi_any_source
              msgtag = bloc_facto_sym_slave
            END IF
          END IF
          blocking  = .true.
          set_irecv = .false.
          message_received = .false.
          CALL dmumps_try_recvtreat( comm_load, ass_irecv,
     &    blocking, set_irecv, message_received,
     &    msgsou, msgtag,
     &    status,
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster, nstk_s, comp,
     &    iflag, ierror, comm,
     &    perm, ipool, lpool, leaf, nbfin, myid, slavef,
     &
     &    root, opassw, opeliw, 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, .true.
     &               , lrgroups
     &   )
          IF ( iflag .LT. 0 ) RETURN
        END DO
       ioldps = ptrist(step(inode))
       lcont  = iw(ioldps+keep(ixsz))
       nrow   = iw(ioldps+2+keep(ixsz))
       npiv   = iw(ioldps+3+keep(ixsz))
       nass   = iw(ioldps+4+keep(ixsz))
       nelim  = nass-npiv
       IF (nelim.LE.0) THEN
         write(6,*) myid,': INODE,LCONT, NROW, NPIV, NASS, NELIM=',
     &   inode,lcont, nrow, npiv, nass, nelim
         write(6,*) myid,': IOLDPS=',ioldps
         write(6,*) myid,': ERROR 2 in DMUMPS_PROCESS_ROOT2SON '
         CALL mumps_abort()
       ENDIF
       nslaves= iw(ioldps+5+keep(ixsz))
       h_inode = 6 + nslaves + keep(ixsz)
       list_nelim_col = ioldps + h_inode + nrow + npiv
       nelim_local = nelim_root
       DO i = 1, nelim
        root%RG2L_COL(iw(list_nelim_col)) = nelim_local
        root%RG2L_ROW(iw(list_nelim_col)) = nelim_local
        nelim_local = nelim_local + 1
        list_nelim_col = list_nelim_col + 1
       ENDDO
       shift_list_row_son = 6 + iw(ioldps+5+keep(ixsz)) + keep(ixsz)
       shift_list_col_son = shift_list_row_son + nrow + npiv
       ncol_to_send       = nelim
       lda = -9999
       shift_val_son = -9999_8
       IF ( keep( 50 ) .eq. 0 ) THEN
         transpose_asm = .false.
       ELSE
         transpose_asm = .true.
       END IF
       CALL dmumps_build_and_send_cb_root( comm_load, ass_irecv, 
     &    n, inode, fpere,
     &    ptrist, ptrast,
     &    root, nrow, ncol_to_send, shift_list_row_son,
     &    shift_list_col_son , shift_val_son, lda,
     &    root_non_elim_cb, myid, comm,
     &
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
     &    ptrist, ptlust_s, ptrfac,
     &    ptrast, step, pimaster, pamaster,
     &    nstk_s, comp, iflag, ierror, perm,
     &    ipool, lpool, leaf, nbfin, slavef,
     &    opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr,dblarr,icntl,keep,keep8,dkeep,transpose_asm,
     &    nd, frere, lptrar, nelt, frtptr, frtelt, 
     &   istep_to_iniv2, tab_pos_in_pere, lrgroups)
        IF (iflag.LT.0 ) RETURN
       IF (keep(214).EQ.2) THEN
        CALL dmumps_stack_band( n, inode,
     &      ptrist, ptrast, ptlust_s, ptrfac, iw, liw, a, la,
     &      lrlu, lrlus, iwpos, iwposcb, posfac, comp,
     &      iptrlu, opeliw, step, pimaster, pamaster,
     &      iflag, ierror, slavef, procnode_steps, dad, myid, comm,
     &      keep, keep8, dkeep,type_son
     &      )
       ENDIF
        IF (iflag.LT.0) THEN
           CALL dmumps_bdc_error( myid, slavef, comm, keep )
        ENDIF
      ENDIF
      RETURN
      END SUBROUTINE dmumps_process_root2son