sfac_process_contrib_type1.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 smumps_process_node( MYID,KEEP,KEEP8,DKEEP,
     &           BUFR, LBUFR, LBUFR_BYTES,
     &           IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS,
     &           N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD,
     &           PTRIST, PTRAST, STEP, PIMASTER, PAMASTER,
     &           NSTK_S, COMP,
     &           FPERE, FLAG, IFLAG, IERROR, COMM,
     &           ITLOC, RHS_MUMPS )
      USE smumps_dynamic_memory_m, ONLY : smumps_dm_set_ptr
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR
      INTEGER MYID
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER KEEP(500), BUFR( LBUFR )
      INTEGER(8) KEEP8(150)
      REAL DKEEP(230)
      INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      REAL A( LA )
      INTEGER, INTENT(IN) :: SLAVEF
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
      INTEGER(8) :: PTRAST  (KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER PTRIST( KEEP(28) )
      INTEGER STEP(N), PIMASTER(KEEP(28))
      INTEGER COMP, FPERE
      LOGICAL FLAG
      INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) )
      REAL :: RHS_MUMPS(KEEP(255))
      INTEGER IFLAG, IERROR, COMM
      INTEGER POSITION, FINODE, FLCONT, LREQ
      INTEGER(8) :: LREQCB
      INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET
      INTEGER SIZE_PACKET
      INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
      include 'mumps_headers.h'
      LOGICAL PACKED_CB
      REAL, POINTER, DIMENSION(:) :: SON_A
      INTEGER(8) :: DYN_SIZE
      flag = .false.
      position = 0
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &                finode, 1, mpi_integer,
     &                comm, ierr)
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &                fpere, 1, mpi_integer, 
     &                comm, ierr)
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &                flcont, 1, mpi_integer,
     &                comm, ierr)
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &                nbrows_already_sent, 1, mpi_integer,
     &                comm, ierr)
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &                nbrows_packet, 1, mpi_integer,
     &                comm, ierr)
      packed_cb = (flcont.LT.0) 
      IF (packed_cb) THEN
        flcont   = -flcont
        lreqcb  = (int(flcont,8) * int(flcont+1,8)) / 2_8
      ELSE
        lreqcb  = int(flcont,8) * int(flcont,8)
      ENDIF
      IF (nbrows_already_sent == 0) THEN
        lreq    = 2 * flcont + 6 + keep(ixsz)
        CALL smumps_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,
     &  lreq, lreqcb, finode, s_notfree, .true.,
     &  comp, lrlus, keep8(67), iflag, ierror
     &     )
        IF ( iflag .LT. 0 ) RETURN
        pimaster(step( finode )) = iwposcb + 1
        pamaster(step( finode )) = iptrlu  + 1_8
        IF (packed_cb)  iw(iwposcb + 1 + xxs ) = s_cb1comp
        CALL mpi_unpack(bufr, lbufr_bytes, position,
     &        iw(iwposcb + 1+keep(ixsz)), lreq-keep(ixsz),
     &        mpi_integer, comm, ierr)
      ENDIF
      IF (packed_cb) THEN
        ishift_packet = int(nbrows_already_sent,8) *
     &                  int(nbrows_already_sent+1,8) / 2_8
        size_packet = (nbrows_packet * (nbrows_packet+1))/2 +
     &                 nbrows_already_sent * nbrows_packet
      ELSE
        ishift_packet = int(nbrows_already_sent,8) * int(flcont,8)
        size_packet = nbrows_packet * flcont
      ENDIF
      IF (nbrows_packet.NE.0) THEN
        CALL mumps_geti8(dyn_size, iw(pimaster(step(finode))+xxd))
        IF (dyn_size .GT. 0_8) THEN
          CALL smumps_dm_set_ptr( pamaster(step(finode)),
     &                            dyn_size, son_a )
          ipos_node = 1_8
          CALL mpi_unpack(bufr, lbufr_bytes, position,
     &         son_a(ipos_node + ishift_packet),
     &         size_packet, mpi_real, comm, ierr)
        ELSE
          ipos_node = pamaster(step(finode))
          CALL mpi_unpack(bufr, lbufr_bytes, position,
     &         a(ipos_node + ishift_packet),
     &         size_packet, mpi_real, comm, ierr)
        ENDIF
      ENDIF
      IF (nbrows_already_sent+nbrows_packet == flcont) THEN
        nstk_s(step(fpere)) = nstk_s(step(fpere)) - 1
        IF ( nstk_s(step(fpere)).EQ.0 ) THEN
          flag = . true.
        END IF
      ENDIF
      RETURN
      END SUBROUTINE smumps_process_node