cfac_process_rtnelind.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 cmumps_process_rtnelind( ROOT, 
     &    INODE, NELIM, NSLAVES, ROW_LIST,
     &    COL_LIST, SLAVE_LIST, 
     &
     &    PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST_S, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S,
     &    ITLOC, RHS_MUMPS, COMP,
     &    IFLAG, IERROR, 
     &    IPOOL, LPOOL, LEAF, MYID, SLAVEF,
     &    KEEP, KEEP8, DKEEP,
     &    COMM, COMM_LOAD, FILS, DAD, ND )
      USE cmumps_load
      USE cmumps_struc_def, ONLY : cmumps_root_struc
      IMPLICIT NONE
      TYPE (CMUMPS_ROOT_STRUC) :: ROOT
      INTEGER INODE, NELIM, NSLAVES 
      INTEGER KEEP( 500 )
      INTEGER(8) KEEP8(150)
      REAL DKEEP(230)
      INTEGER ROW_LIST(*), COL_LIST(*), 
     &        SLAVE_LIST(*)
      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      COMPLEX A( LA )
      INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER STEP(N), PIMASTER(KEEP(28))
      INTEGER COMP
      INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) )
      COMPLEX :: RHS_MUMPS(KEEP(255))
      INTEGER PROCNODE_STEPS( KEEP(28) )
      INTEGER IFLAG, IERROR
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER MYID, SLAVEF
      INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28))
      INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL,
     &        noint
      INTEGER(8) :: NOREAL
      include 'mumps_headers.h'
      include 'mumps_tags.h'
      INTEGER MUMPS_TYPENODE
      EXTERNAL mumps_typenode
      iroot        = keep(38)
      nstk_s(step(iroot))= nstk_s(step(iroot)) - 1
      keep(42) = keep(42) + nelim
      type_inode= mumps_typenode( procnode_steps(step(inode)),
     &                            keep(199) )
      IF (type_inode.EQ.1) THEN 
        IF (nelim.EQ.0) THEN
         keep(41) = keep(41) + 1
        ELSE 
         keep(41) = keep(41) + 3
        ENDIF
      ELSE
        IF (nelim.EQ.0) THEN
         keep(41) = keep(41) + nslaves
        ELSE 
         keep(41) = keep(41) + 2*nslaves + 1
        ENDIF
      ENDIF
      IF  (nelim.EQ.0) THEN
        pimaster(step(inode)) = 0 
      ELSE
       noint = 6 + nslaves + nelim  + nelim + keep(ixsz)
       noreal= 0_8
       CALL cmumps_alloc_cb(.false.,0_8,.false.,.false.,
     &   myid,n,keep,keep8,dkeep,iw,liw, a, la,
     &   lrlu, iptrlu,iwpos,iwposcb, slavef, procnode_steps, dad,
     &   ptrist,ptrast,step, pimaster, pamaster,
     &   noint, noreal, inode, s_notfree, .true.,
     &   comp, lrlus, keep8(67), iflag, ierror
     &      )
       IF ( iflag .LT. 0 ) THEN
         WRITE(*,*) ' Failure in int space allocation in CB area ',
     &    ' during assembly of root : CMUMPS_PROCESS_RTNELIND',
     &    ' size required was :', noint,
     &    'INODE=',inode,' NELIM=',nelim, ' NSLAVES=', nslaves
         RETURN
        ENDIF
        pimaster(step( inode )) = iwposcb + 1
        pamaster(step( inode )) = iptrlu  + 1_8
        iw( iwposcb + 1+keep(ixsz) ) = 2*nelim
        iw( iwposcb + 2+keep(ixsz) ) = nelim
        iw( iwposcb + 3+keep(ixsz) ) = 0
        iw( iwposcb + 4+keep(ixsz) ) = 0
        iw( iwposcb + 5+keep(ixsz) ) = 1
        iw( iwposcb + 6+keep(ixsz) ) = nslaves
        IF (nslaves.GT.0) THEN
         iw( iwposcb+7+keep(ixsz):iwposcb+7+keep(ixsz)+nslaves-1) = 
     &                   slave_list(1:nslaves)
        ENDIF
        deb_row = iwposcb+7+nslaves+keep(ixsz)
        iw(deb_row : deb_row+nelim -1) = row_list(1:nelim)
        deb_col = deb_row + nelim
        iw(deb_col : deb_col+nelim -1) = col_list(1:nelim)
      ENDIF
      IF (nstk_s(step(iroot)) .EQ. 0 ) THEN
          CALL cmumps_insert_pool_n(n, ipool, lpool, procnode_steps,
     &         slavef, keep(199),
     &         keep(28), keep(76), keep(80), keep(47),
     &         step, iroot )
          IF (keep(47) .GE. 3) THEN
             CALL cmumps_load_pool_upd_new_pool(
     &            ipool, lpool, 
     &            procnode_steps, keep,keep8, slavef, comm_load,
     &            myid, step, n, nd, fils )
          ENDIF
      END IF
      RETURN
      END SUBROUTINE cmumps_process_rtnelind