sfac_process_master2.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_master2(MYID,BUFR, LBUFR, 
     &     LBUFR_BYTES,
     &     PROCNODE_STEPS, SLAVEF,
     &     IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS,
     &     N, IW, LIW, A, LA,
     &     PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S,
     &     COMP,
     &     IFLAG, IERROR, COMM, COMM_LOAD,
     &     IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP,
     &     ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS,
     &     ISTEP_TO_INIV2, TAB_POS_IN_PERE )
      USE smumps_load
      USE smumps_dynamic_memory_m, ONLY : smumps_dm_set_ptr
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR
      INTEGER MYID
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      REAL DKEEP(230)
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER SLAVEF
      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      REAL A( LA )
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28))
      INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) )
      REAL :: RHS_MUMPS(KEEP(255))
      INTEGER COMP
      INTEGER NSTK_S( KEEP(28) )
      INTEGER IFLAG, IERROR, COMM, COMM_LOAD
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28))
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, 
     &        nslaves
      INTEGER(8) :: NOREAL
      INTEGER NOINT, INIV2, NCOL_EFF
      DOUBLE PRECISION FLOP1
      INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
      INTEGER NOREAL_PACKET
      LOGICAL PERETYPE2
      include 'mumps_headers.h'
      REAL, POINTER, DIMENSION(:) :: SON_A
      INTEGER(8) :: DYN_SIZE
      INTEGER  MUMPS_TYPENODE
      EXTERNAL mumps_typenode
      position = 0
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &          ifath, 1, mpi_integer
     &        , comm, ierr)
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &        ison , 1, mpi_integer, 
     &        comm, ierr)
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &        nslaves, 1,
     &        mpi_integer, comm, ierr )
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &          nrow , 1, mpi_integer
     &        , comm, ierr)
      CALL mpi_unpack(bufr, lbufr_bytes, position,
     &          ncol , 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)
      IF ( nslaves .NE. 0 .and. keep(50).ne.0 ) THEN
        ncol_eff = nrow
      ELSE
        ncol_eff = ncol
      ENDIF
      noreal_packet = nbrows_packet * ncol_eff
      IF (nbrows_already_sent .EQ. 0) THEN
        noint = 6 + nrow + ncol + nslaves + keep(ixsz)
        noreal= int(nrow,8) * int(ncol_eff,8)
        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,
     &   noint, noreal, ison, s_notfree, .true.,
     &   comp, lrlus, keep8(67), iflag, ierror
     &     )
        IF ( iflag .LT. 0 ) THEN
          RETURN
        ENDIF
        pimaster(step( ison )) = iwposcb + 1
        pamaster(step( ison )) = iptrlu  + 1_8
        iw( iwposcb + 1 + xxnbpr ) = 0  
        iw( iwposcb + 1 + keep(ixsz) ) = ncol
        nelim = nrow
        iw( iwposcb + 2 + keep(ixsz) ) = nelim
        iw( iwposcb + 3 + keep(ixsz) ) = nrow
        IF ( nslaves .NE. 0 .and. keep(50).ne.0 ) THEN
          iw( iwposcb + 4 + keep(ixsz) ) = nrow - ncol
          IF ( nrow - ncol .GE. 0 ) THEN
            WRITE(*,*) 'Error in PROCESS_MAITRE2:',nrow,ncol
            CALL mumps_abort()
          END IF
        ELSE
          iw( iwposcb + 4 + keep(ixsz) ) = 0
        END IF
        iw( iwposcb + 5 + keep(ixsz) ) = 1
        iw( iwposcb + 6 + keep(ixsz) ) = nslaves
        IF (nslaves.GT.0) THEN
         CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                 iw( iwposcb + 7 + keep(ixsz) ),
     &                 nslaves, mpi_integer, comm, ierr )
        ENDIF
        CALL mpi_unpack(bufr, lbufr_bytes, position,
     &        iw(iwposcb + 7 + keep(ixsz) + nslaves),
     &        nrow, mpi_integer, comm, ierr)
        CALL mpi_unpack(bufr, lbufr_bytes, position,
     &        iw(iwposcb + 7 + keep(ixsz) + nrow + nslaves),
     &        ncol, mpi_integer, comm, ierr)
        IF ( nslaves .GT. 0 ) THEN
          iniv2 = istep_to_iniv2( step(ison) )
          CALL mpi_unpack(bufr, lbufr_bytes, position,
     &        tab_pos_in_pere(1,iniv2),
     &        nslaves+1, mpi_integer, comm, ierr)
          tab_pos_in_pere(slavef+2,iniv2) = nslaves
        ENDIF
      ENDIF
      IF (noreal_packet.GT.0) THEN
        CALL mumps_geti8(dyn_size, iw(pimaster(step(ison))+xxd))
        IF ( dyn_size .GT. 0_8 ) THEN
          CALL smumps_dm_set_ptr( pamaster(step(ison)),
     &                            dyn_size, son_a )
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &        son_a( 1_8 +
     &        int(nbrows_already_sent,8) * int(ncol_eff,8) ),
     &        noreal_packet, mpi_real, comm, ierr )
        ELSE
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &        a( pamaster(step(ison)) +
     &        int(nbrows_already_sent,8) * int(ncol_eff,8) ),
     &        noreal_packet, mpi_real, comm, ierr )
        ENDIF
      ENDIF
      IF ( nbrows_already_sent + nbrows_packet .EQ. nrow ) THEN
        peretype2 = ( mumps_typenode(procnode_steps(step(ifath)),
     &                keep(199)) .EQ. 2 )
        nstk_s( step(ifath ))       = nstk_s( step(ifath) ) - 1
        IF ( nstk_s( step(ifath)) .EQ. 0 ) THEN
          CALL smumps_insert_pool_n(n, ipool, lpool, procnode_steps,
     &         slavef, keep(199),
     &         keep(28), keep(76), keep(80), keep(47),
     &         step, ifath )
          IF (keep(47) .GE. 3) THEN
             CALL smumps_load_pool_upd_new_pool(
     &            ipool, lpool, 
     &            procnode_steps, keep,keep8, slavef, comm_load,
     &            myid, step, n, nd, fils )
          ENDIF
          CALL mumps_estim_flops( ifath, n, procnode_steps,
     &                            keep(199), nd,
     &                            fils,frere, step, pimaster,
     &                            keep(28), keep(50), keep(253),
     &                            flop1,iw, liw, keep(ixsz) )
          IF (ifath.NE.keep(20))
     &    CALL smumps_load_update(1, .false., flop1, keep,keep8)
        END IF
      ENDIF
      RETURN
      END SUBROUTINE smumps_process_master2