cfac_process_contrib_type1.F File Reference

Go to the source code of this file.

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

Function/Subroutine Documentation

cmumps_process_node()

subroutine cmumps_process_node	(	integer	myid,
		integer, dimension(500)	keep,
		integer(8), dimension(150)	keep8,
		real, dimension(230)	dkeep,
		integer, dimension( lbufr )	bufr,
		integer	lbufr,
		integer	lbufr_bytes,
		integer	iwpos,
		integer	iwposcb,
		integer(8)	iptrlu,
		integer(8)	lrlu,
		integer(8)	lrlus,
		integer	n,
		integer, dimension( liw )	iw,
		integer	liw,
		complex, dimension( la )	a,
		integer(8)	la,
		integer, intent(in)	slavef,
		integer, dimension(keep(28)), intent(in)	procnode_steps,
		integer, dimension(keep(28)), intent(in)	dad,
		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	fpere,
		logical	flag,
		integer	iflag,
		integer	ierror,
		integer	comm,
		integer, dimension( n + keep(253) )	itloc,
		complex, dimension(keep(255))	rhs_mumps )

Definition at line 14 of file cfac_process_contrib_type1.F.

      USE cmumps_dynamic_memory_m, ONLY : cmumps_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 )
      COMPLEX 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) )
      COMPLEX :: 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
      COMPLEX, 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 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,
     &  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 cmumps_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_complex, comm, ierr)
        ELSE
          ipos_node = pamaster(step(finode))
          CALL mpi_unpack(bufr, lbufr_bytes, position,
     &         a(ipos_node + ishift_packet),
     &         size_packet, mpi_complex, 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