dfac_process_master2.F File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	dmumps_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)

Function/Subroutine Documentation

dmumps_process_master2()

subroutine dmumps_process_master2	(	integer	myid,
		integer, dimension( lbufr )	bufr,
		integer	lbufr,
		integer	lbufr_bytes,
		integer, dimension( keep(28) )	procnode_steps,
		integer	slavef,
		integer	iwpos,
		integer	iwposcb,
		integer(8)	iptrlu,
		integer(8)	lrlu,
		integer(8)	lrlus,
		integer	n,
		integer, dimension( liw )	iw,
		integer	liw,
		double precision, dimension( la )	a,
		integer(8)	la,
		integer, dimension(keep(28))	ptrist,
		integer(8), dimension(keep(28))	ptrast,
		integer, dimension(n)	step,
		integer, dimension(keep(28))	pimaster,
		integer(8), dimension(keep(28))	pamaster,
		integer, dimension( keep(28) )	nstk_s,
		integer	comp,
		integer	iflag,
		integer	ierror,
		integer	comm,
		integer	comm_load,
		integer, dimension( lpool )	ipool,
		integer	lpool,
		integer	leaf,
		integer, dimension(500)	keep,
		integer(8), dimension(150)	keep8,
		double precision, dimension(230)	dkeep,
		integer, dimension(keep(28))	nd,
		integer, dimension( n )	fils,
		integer, dimension(keep(28))	dad,
		integer, dimension(keep(28))	frere,
		integer, dimension( n +keep(253) )	itloc,
		double precision, dimension(keep(255))	rhs_mumps,
		integer, dimension(keep(71))	istep_to_iniv2,
		integer, dimension(slavef+2,max(1,keep(56)))	tab_pos_in_pere )

Definition at line 14 of file dfac_process_master2.F.

      USE dmumps_load
      USE dmumps_dynamic_memory_m, ONLY : dmumps_dm_set_ptr
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR
      INTEGER MYID
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION 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 )
      DOUBLE PRECISION 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) )
      DOUBLE PRECISION :: 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'
      DOUBLE PRECISION, 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 dmumps_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 dmumps_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_double_precision, 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_double_precision, 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 dmumps_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 dmumps_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 dmumps_load_update(1, .false., flop1, keep,keep8)
        END IF
      ENDIF
      RETURN