dfac_lastrtnelind.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_last_rtnelind( COMM_LOAD, ASS_IRECV, 
     &    root, FRERE, IROOT, 
     &    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,
     &    LPTRAR, NELT, FRTPTR, FRTELT, 
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE  
     &               , LRGROUPS
     &     )
      USE dmumps_buf
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      TYPE (DMUMPS_ROOT_STRUC) :: root
      INTEGER IROOT
      INTEGER ICNTL( 60 ), KEEP( 500 )
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION    DKEEP(230)
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS
      INTEGER IWPOS, IWPOSCB
      INTEGER(8) :: LA
      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 LPTRAR, NELT
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER MYID, SLAVEF, NBFIN
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      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))
      DOUBLE PRECISION DBLARR( KEEP8(26) )
      INTEGER INTARR( KEEP8(27) )
      INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, 
     &        nfront, irow, jcol, pdest, hf, ioldps,
     &        in, deb_row, iloc_row, ifson, iloc_col,
     &        ipos_son, nelim_son, nslaves_son, hs,
     &        irow_son, icol_son, islave, ierr, 
     &        nelim_sent, ipos_statrec, type_son
      INTEGER MUMPS_PROCNODE
      EXTERNAL mumps_procnode
      include 'mumps_headers.h'
      include 'mumps_tags.h'
      nb_contri_global = keep(41)
      numorg    = root%ROOT_SIZE
      nelim     = keep(42)
      nfront    = numorg + keep(42)
      DO irow = 0, root%NPROW - 1
        DO jcol = 0, root%NPCOL - 1
            pdest = irow * root%NPCOL + jcol
          IF ( pdest .NE. myid ) THEN
           CALL dmumps_buf_send_root2slave(nfront, 
     &     nb_contri_global, pdest, comm, keep, ierr)
           if (ierr.lt.0) then
                write(6,*) ' error detected by ',
     &          'DMUMPS_BUF_SEND_ROOT2SLAVE'
                CALL mumps_abort()
               endif
           ENDIF
        END DO
      END DO
      CALL  dmumps_process_root2slave( nfront,
     &    nb_contri_global, 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, 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 )
       IF (iflag < 0 ) RETURN
      hf = 6 + keep(ixsz)
      ioldps = ptlust_s(step(iroot))
      in = iroot
      deb_row = ioldps + hf
      iloc_row    = deb_row
      DO WHILE (in.GT.0) 
       iw(iloc_row)           = in
       iw(iloc_row+nfront)    = in
       iloc_row = iloc_row + 1
       in = fils(in)
      END DO
      ifson = -in
      iloc_row    = ioldps + hf + numorg
      iloc_col    = iloc_row + nfront
      IF ( nelim.GT.0 ) THEN
        in = ifson
        DO WHILE (in.GT.0)
          ipos_son  = pimaster(step(in))
          IF (ipos_son .EQ. 0) GOTO 100
          nelim_son   = iw(ipos_son+1+keep(ixsz))
          if (nelim_son.eq.0) then
                write(6,*) ' error 1 in process_last_rtnelind'
                CALL mumps_abort()
              endif
          nslaves_son = iw(ipos_son+5+keep(ixsz))
          hs          = 6 + nslaves_son + keep(ixsz)
          irow_son    = ipos_son + hs
          icol_son    = irow_son + nelim_son
          DO i = 1, nelim_son
            iw( iloc_row+i-1 ) = iw( irow_son+i-1 )
          ENDDO
          DO i = 1, nelim_son
            iw( iloc_col+i-1 ) = iw( icol_son+i-1 )
          ENDDO
          nelim_sent = iloc_row - ioldps - hf + 1
          DO islave = 0,nslaves_son
            IF (islave.EQ.0) THEN
             pdest= mumps_procnode(procnode_steps(step(in)),keep(199))
            ELSE
             pdest = iw(ipos_son + 5 + islave+keep(ixsz))
            ENDIF
            IF (pdest.NE.myid) THEN
             CALL dmumps_buf_send_root2son(in, nelim_sent,
     &        pdest, comm, keep, ierr )
             if (ierr.lt.0) then
                write(6,*) ' error detected by ',
     &          'DMUMPS_BUF_SEND_ROOT2SLAVE'
                CALL mumps_abort()
               endif
            ELSE
             CALL dmumps_process_root2son( comm_load, ass_irecv,
     &       in, nelim_sent, 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
     &       )
             IF ( islave .NE. 0 ) THEN
               IF (keep(50) .EQ. 0) THEN
                ipos_statrec = ptrist(step(in))+6+keep(ixsz)
               ELSE
                ipos_statrec = ptrist(step(in))+8+keep(ixsz)
               ENDIF
               IF (iw(ipos_statrec).EQ. s_rec_contstatic) THEN
                  iw(ipos_statrec) = s_root2son_called
               ELSE
                IF (nslaves_son .EQ. 0) THEN
                  type_son = 1
                ELSE
                  type_son = 2
                ENDIF
                CALL dmumps_free_band( n, in, ptrist, ptrast,
     &          iw, liw, a, la, lrlu, lrlus, iwposcb,
     &          iptrlu, step, myid, keep, keep8, type_son
     &        )
               ENDIF
             ENDIF
             ipos_son  = pimaster(step(in))
            ENDIF
          END DO
          CALL  dmumps_free_block_cb_static(
     &       .false., myid, n, ipos_son,
     &       iw, liw,
     &       lrlu, lrlus, iptrlu,
     &       iwposcb, la, keep,keep8, .false.
     &         )
          iloc_row = iloc_row + nelim_son
          iloc_col = iloc_col + nelim_son
 100      CONTINUE
          in = frere(step(in))
        ENDDO
      ENDIF
      RETURN
      END SUBROUTINE dmumps_last_rtnelind