dfac_process_contrib_type3.F File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	dmumps_process_contrib_type3 (bufr, lbufr, lbufr_bytes, root, n, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptlust, ptrfac, ptrast, step, pimaster, pamaster, comp, lrlus, ipool, lpool, leaf, fils, dad, myid, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, keep, keep8, dkeep, iflag, ierror, comm, comm_load, itloc, rhs_mumps, nd, procnode_steps, slavef, opassw)

Function/Subroutine Documentation

dmumps_process_contrib_type3()

subroutine dmumps_process_contrib_type3	(	integer, dimension( lbufr_bytes )	bufr,
		integer	lbufr,
		integer	lbufr_bytes,
		type (dmumps_root_struc )	root,
		integer	n,
		integer, dimension( liw )	iw,
		integer	liw,
		double precision, dimension( la )	a,
		integer(8)	la,
		integer(8)	lrlu,
		integer(8)	iptrlu,
		integer	iwpos,
		integer	iwposcb,
		integer, dimension(keep(28))	ptrist,
		integer, dimension(keep(28))	ptlust,
		integer(8), dimension(keep(28))	ptrfac,
		integer(8), dimension(keep(28))	ptrast,
		integer, dimension(n)	step,
		integer, dimension(keep(28))	pimaster,
		integer(8), dimension(keep(28))	pamaster,
		integer	comp,
		integer(8)	lrlus,
		integer, dimension( leaf )	ipool,
		integer	lpool,
		integer	leaf,
		integer, dimension( n )	fils,
		integer, dimension(keep(28))	dad,
		integer	myid,
		integer	lptrar,
		integer	nelt,
		integer, dimension( n+1 )	frtptr,
		integer, dimension( nelt )	frtelt,
		integer(8), dimension( lptrar ), intent(in)	ptraiw,
		integer(8), dimension( lptrar ), intent(in)	ptrarw,
		integer, dimension(keep8(27))	intarr,
		double precision, dimension(keep8(26))	dblarr,
		integer, dimension( 500 )	keep,
		integer(8), dimension(150)	keep8,
		double precision, dimension(230)	dkeep,
		integer	iflag,
		integer	ierror,
		integer	comm,
		integer	comm_load,
		integer, dimension( n+keep(253) )	itloc,
		double precision, dimension(keep(255))	rhs_mumps,
		integer, dimension(keep(28))	nd,
		integer, dimension(keep(28))	procnode_steps,
		integer	slavef,
		double precision	opassw )

Definition at line 14 of file dfac_process_contrib_type3.F.

      USE dmumps_load
      USE dmumps_ooc
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      TYPE (DMUMPS_ROOT_STRUC ) :: root
      INTEGER    :: KEEP( 500 )
      INTEGER(8) :: KEEP8(150)
      DOUBLE PRECISION       :: DKEEP(230)
      INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER LBUFR, LBUFR_BYTES, N, LIW,
     &        IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG,
     &        IERROR
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LEAF )
      INTEGER PTRIST(KEEP(28))
      INTEGER PTLUST(KEEP(28))
      INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) )
      DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
      INTEGER BUFR( LBUFR_BYTES )
      INTEGER IW( LIW )
      INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28))
      INTEGER SLAVEF
      DOUBLE PRECISION A( LA )
      INTEGER  MYID
      INTEGER FILS( N ), DAD(KEEP(28))
      INTEGER LPTRAR, NELT
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR )
      INTEGER INTARR(KEEP8(27))
      DOUBLE PRECISION DBLARR(KEEP8(26))
      DOUBLE PRECISION OPASSW
        include 'mpif.h'
        INTEGER IERR
        EXTERNAL mumps_procnode
        INTEGER MUMPS_PROCNODE
        INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI
        INTEGER(8) :: LREQA, POS_ROOT
        INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF
        INTEGER NSUPCOL_EFF
        INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
        INTEGER NSUPROW, NSUPCOL, BBPCBP
        include 'mumps_headers.h'
        position = 0
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   ison, 1, mpi_integer, comm, ierr )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   nsubset_row, 1, mpi_integer, comm, ierr )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   nsuprow, 1, mpi_integer, comm, ierr )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   nsubset_col, 1, mpi_integer, comm, ierr )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   nsupcol, 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 )
        CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   bbpcbp, 1, mpi_integer,
     &                   comm, ierr )
        IF (bbpcbp .EQ. 1) THEN
          nsubset_col_eff = nsubset_col - nsupcol
          nsupcol_eff = 0
        ELSE
          nsubset_col_eff = nsubset_col
          nsupcol_eff = nsupcol
        ENDIF
        iroot = keep( 38 )
        IF ( ptrist( step(iroot) ) .NE. 0 .OR.
     &       ptlust( step(iroot)) .NE. 0 ) THEN
          IF (nbrows_already_sent + nbrows_packet .EQ. nsubset_row
     &       - nsuprow .OR.  nsubset_row - nsuprow.EQ.0 .OR.
     &       nsubset_col_eff .EQ. 0)THEN
            keep(121) = keep(121) - 1
            IF ( keep(121) .eq. 0 ) THEN
              IF (keep(201).EQ.1) THEN 
                 CALL dmumps_ooc_force_wrt_buf_panel(ierr)
              ELSEIF (keep(201).EQ.2) THEN 
                 CALL dmumps_force_write_buf(ierr)              
              ENDIF
              CALL dmumps_insert_pool_n( n, ipool, lpool,
     &             procnode_steps, slavef, keep(199),
     &             keep(28), keep(76),
     &             keep(80), keep(47),
     &             step, iroot + n)
              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
            ENDIF
          ENDIF
        ELSE
           IF (nbrows_already_sent + nbrows_packet .EQ.
     &       nsubset_row - nsuprow .OR.
     &        nsubset_row - nsuprow.EQ.0 .OR.
     &        nsubset_col_eff .EQ. 0)THEN
             keep(121)=-1
           ENDIF
           CALL dmumps_root_alloc_static( root, iroot, n,
     &                iw, liw, a, la,
     &                fils, dad, myid, slavef, procnode_steps,
     &                lptrar, nelt, frtptr, frtelt,
     &                ptraiw, ptrarw, intarr, dblarr,
     &                lrlu, iptrlu,
     &                iwpos, iwposcb, ptrist, ptrast,
     &                step, pimaster, pamaster, itloc, rhs_mumps,
     &                comp, lrlus, iflag, keep,keep8,dkeep,ierror )
            IF ( iflag .LT. 0 ) RETURN
        END IF
      IF (keep(60) .EQ.0) THEN
        IF ( ptrist(step(iroot)) .GE. 0 ) THEN
          IF ( ptrist(step(iroot)) .NE. 0 ) THEN
               local_n  = -iw( ptrist(step( iroot )) + keep(ixsz)    )
               local_m  =  iw( ptrist(step( iroot )) + 1 + keep(ixsz))
               pos_root = pamaster(step( iroot ))
          ELSE
               local_n = iw( ptlust(step( iroot ) ) + 1 + keep(ixsz))
               local_m = iw( ptlust(step( iroot ) ) + 2 + keep(ixsz))
               pos_root = ptrfac(iw(ptlust(step(iroot))+4+
     &                    keep(ixsz)))
          END IF
         ENDIF
      ELSE
          local_m = root%SCHUR_LLD
          local_n = root%SCHUR_NLOC
      ENDIF
        IF ( (bbpcbp.EQ.1).AND. (nbrows_already_sent.EQ.0).AND.
     &     (min(nsuprow, nsupcol) .GT. 0)
     &     ) THEN
         lreqi = nsuprow+nsupcol
         lreqa = int(nsuprow,8) * int(nsupcol,8)
         IF ( (lreqa.NE.0_8) .AND.
     &       (ptrist(step(iroot)).LT.0).AND.
     &        keep(60)==0) THEN
          WRITE(*,*) ' Error in DMUMPS_PROCESS_CONTRIB_TYPE3'
          CALL mumps_abort()
         ENDIF
         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,
     &     lreqi, lreqa, -1234, s_notfree, .false.,
     &     comp, lrlus, keep8(67), iflag, ierror
     &          )
         IF ( iflag .LT. 0 ) RETURN
         CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   iw( iwposcb + 1 ), lreqi,
     &                   mpi_integer, comm, ierr )
         CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   a( iptrlu + 1_8 ), int(lreqa),
     &                   mpi_double_precision, comm, ierr )
         opassw = opassw + lreqa 
         CALL dmumps_ass_root( root, keep(50), nsuprow, nsupcol,
     &                     iw( iwposcb + 1 ), 
     &                     iw( iwposcb + nsuprow + 1 ), nsupcol,
     &                     a( iptrlu + 1_8 ),
     &                     a( 1 ), 
     &                     local_m, local_n,
     &                  root%RHS_ROOT(1,1), root%RHS_NLOC,
     &                  1)
         iwposcb = iwposcb + lreqi
         iptrlu  = iptrlu  + lreqa
         lrlu    = lrlu    + lreqa
         lrlus   = lrlus   + lreqa
         keep8(69) = keep8(69) - lreqa
         CALL dmumps_load_mem_update(.false.,.false.,
     &                    la-lrlus,0_8,-lreqa,keep,keep8,lrlus)
        ENDIF  
        lreqi = nbrows_packet + nsubset_col_eff
        lreqa = int(nbrows_packet,8) * int(nsubset_col_eff,8)
        IF ( (lreqa.NE.0_8) .AND.
     &       (ptrist(step(iroot)).LT.0).AND.
     &       keep(60)==0) THEN
         WRITE(*,*) ' Error in DMUMPS_PROCESS_CONTRIB_TYPE3'
         CALL mumps_abort()
        ENDIF
        IF (lreqa.NE.0_8) THEN
          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,
     &     lreqi, lreqa, -1234, s_notfree, .false.,
     &     comp, lrlus, keep8(67), iflag, ierror
     &          )
          IF ( iflag .LT. 0 ) RETURN
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   iw( iwposcb + 1 ), lreqi,
     &                   mpi_integer, comm, ierr )
          CALL mpi_unpack( bufr, lbufr_bytes, position,
     &                   a( iptrlu + 1_8 ), int(lreqa),
     &                   mpi_double_precision, comm, ierr )
          opassw = opassw + lreqa 
          IF (keep(60).EQ.0) THEN
            CALL dmumps_ass_root( root, keep(50),
     &                     nbrows_packet, nsubset_col_eff,
     &                     iw( iwposcb + 1 ),
     &                     iw( iwposcb + nbrows_packet + 1 ),
     &                     nsupcol_eff,
     &                     a( iptrlu + 1_8 ),
     &                     a( pos_root ), local_m, local_n,
     &                  root%RHS_ROOT(1,1), root%RHS_NLOC,
     &                  0)   
          ELSE
            CALL dmumps_ass_root( root, keep(50),
     &                     nbrows_packet, nsubset_col_eff,
     &                     iw( iwposcb + 1 ),
     &                     iw( iwposcb + nbrows_packet + 1 ),
     &                     nsupcol_eff,
     &                     a( iptrlu + 1_8 ),
     &                     root%SCHUR_POINTER(1),
     &                     root%SCHUR_LLD , root%SCHUR_NLOC,
     &                  root%RHS_ROOT(1,1), root%RHS_NLOC,
     &                  0)  
          ENDIF
          iwposcb = iwposcb + lreqi
          iptrlu  = iptrlu  + lreqa
          lrlu    = lrlu    + lreqa
          lrlus   = lrlus   + lreqa
          keep8(69) = keep8(69) - lreqa
          CALL dmumps_load_mem_update(.false.,.false.,
     &                    la-lrlus,0_8,-lreqa,keep,keep8,lrlus)
        ENDIF
      RETURN