cfac_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 
     &    cmumps_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 cmumps_struc_def, ONLY : cmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      TYPE (cmumps_root_struc) :: root
      INTEGER keep(500), icntl( 60 )
      INTEGER(8) keep8(150)
      REAL       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 )
      COMPLEX 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))
      COMPLEX :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER nd( keep(28) ), frere( keep(28) ) 
      INTEGER intarr(keep8(27))
      COMPLEX 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 CMUMPS_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 cmumps_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 cmumps_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 cmumps_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 cmumps_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 cmumps_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 cmumps_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 cmumps_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
.eq.       IF ( KEEP( 50 )  0 ) THEN
         TRANSPOSE_ASM = .FALSE.
       ELSE
         TRANSPOSE_ASM = .TRUE.
       END IF
       CALL CMUMPS_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)
.LT.        IF (IFLAG0 ) RETURN
.EQ.       IF (KEEP(214)2) THEN
        CALL CMUMPS_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
.LT.        IF (IFLAG0) THEN
           CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
        ENDIF
      ENDIF
      RETURN
      END SUBROUTINE CMUMPS_PROCESS_ROOT2SON