ssol_root_parallel.F File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	smumps_root_solve (nrhs, desca_par, cntxt_par, local_m, local_n, mblock, nblock, ipiv, lpiv, master_root, myid, comm, rhs_seq, size_root, a, info, mtype, ldlt)
subroutine	smumps_solve_2d_bcyclic (size_root, nrhs, mtype, a, desca_par, local_m, local_n, local_n_rhs, ipiv, lpiv, rhs_par, ldlt, mblock, nblock, cntxt_par, ierr)

Function/Subroutine Documentation

smumps_root_solve()

subroutine smumps_root_solve	(	integer	nrhs,
		integer, dimension( 9 )	desca_par,
		integer	cntxt_par,
		integer	local_m,
		integer	local_n,
		integer	mblock,
		integer	nblock,
		integer, dimension( lpiv )	ipiv,
		integer	lpiv,
		integer	master_root,
		integer	myid,
		integer	comm,
		real, dimension( size_root *nrhs)	rhs_seq,
		integer	size_root,
		real, dimension( local_m, local_n )	a,
		integer, dimension(80)	info,
		integer	mtype,
		integer	ldlt )

Definition at line 14 of file ssol_root_parallel.F.

      IMPLICIT NONE
      INTEGER NRHS, MTYPE
      INTEGER DESCA_PAR( 9 )
      INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK
      INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT
      INTEGER MYID, COMM
      INTEGER LPIV, IPIV( LPIV )
      INTEGER INFO(80), LDLT
      REAL RHS_SEQ( SIZE_ROOT *NRHS)
      REAL A( LOCAL_M, LOCAL_N )
      INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL
      INTEGER LOCAL_N_RHS
      REAL, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR
      EXTERNAL numroc
      INTEGER  numroc
      INTEGER allocok
      CALL blacs_gridinfo( cntxt_par, nprow, npcol, myrow, mycol )
      local_n_rhs = numroc(nrhs, nblock, mycol, 0, npcol)
      local_n_rhs = max(1,local_n_rhs)
      ALLOCATE(rhs_par(local_m, local_n_rhs),stat=allocok)
      IF (allocok > 0 ) THEN
        WRITE(*,*) ' Problem during solve of the root.'
        WRITE(*,*) ' Reduce number of right hand sides.'
        CALL mumps_abort()
      ENDIF
      CALL smumps_scatter_root( myid, size_root, nrhs, rhs_seq,
     &      local_m, local_n_rhs,
     &      mblock, nblock, rhs_par, master_root,
     &      nprow, npcol, comm )
      CALL smumps_solve_2d_bcyclic (size_root, nrhs, mtype,
     &     a, desca_par, local_m, local_n, local_n_rhs,
     &     ipiv, lpiv, rhs_par, ldlt, 
     &     mblock, nblock, cntxt_par,
     &     ierr)
      CALL smumps_gather_root( myid, size_root, nrhs,
     &    rhs_seq, local_m, local_n_rhs,
     &    mblock, nblock, rhs_par, master_root,
     &    nprow, npcol, comm )
      DEALLOCATE(rhs_par)
      RETURN

smumps_solve_2d_bcyclic()

subroutine smumps_solve_2d_bcyclic	(	integer, intent(in)	size_root,
		integer, intent(in)	nrhs,
		integer, intent(in)	mtype,
		real, dimension( local_m, local_n ), intent(in)	a,
		integer, dimension( 9 ), intent(in)	desca_par,
		integer, intent(in)	local_m,
		integer, intent(in)	local_n,
		integer, intent(in)	local_n_rhs,
		integer, dimension( lpiv ), intent(in)	ipiv,
		integer, intent(in)	lpiv,
		real, dimension(local_m, local_n_rhs), intent(inout)	rhs_par,
		integer, intent(in)	ldlt,
		integer, intent(in)	mblock,
		integer, intent(in)	nblock,
		integer, intent(in)	cntxt_par,
		integer, intent(out)	ierr )

Definition at line 59 of file ssol_root_parallel.F.

      IMPLICIT NONE
      INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, 
     &                        LOCAL_N, LOCAL_N_RHS, 
     &                        MBLOCK, NBLOCK, CNTXT_PAR, MTYPE
      INTEGER, intent (in) :: DESCA_PAR( 9 ) 
      INTEGER, intent (in) :: LPIV, IPIV( LPIV )
      REAL, intent (in) :: A( LOCAL_M, LOCAL_N )
      REAL, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS)
      INTEGER, intent (out) :: IERR
      INTEGER              :: DESCB_PAR( 9 )
      ierr = 0
      CALL descinit( descb_par, size_root, 
     &      nrhs, mblock, nblock, 0, 0,
     &      cntxt_par, local_m, ierr )
            IF (ierr.NE.0) THEN
              WRITE(*,*) 'After DESCINIT, IERR = ', ierr
              CALL mumps_abort()
            END IF
      IF ( ldlt .eq. 0 .OR. ldlt .eq. 2 ) THEN
        IF ( mtype .eq. 1 ) THEN
          CALL psgetrs('N',size_root,nrhs,a,1,1,desca_par,ipiv,
     &      rhs_par,1,1,descb_par,ierr)
        ELSE
          CALL psgetrs('T',size_root,nrhs,a,1,1,desca_par,ipiv,
     &      rhs_par, 1, 1, descb_par,ierr)
        END IF
      ELSE
        CALL pspotrs( 'L', size_root, nrhs, a, 1, 1, desca_par,
     &    rhs_par, 1, 1, descb_par, ierr )
      END IF
      IF ( ierr .LT. 0 ) THEN
        WRITE(*,*) ' Problem during solve of the root'
        CALL mumps_abort()
      END IF
      RETURN