[数学库] MKL Scalapack 求解线性方程组的问题

MODULE TestM

CONTAINS

    !******************************************
    SUBROUTINE Test(A,D,N,M)
    IMPLICIT NONE
    INTEGER,PARAMETER::dp=kind(1.0D0)
    INTEGER::N,M
    REAL(dp),ALLOCATABLE::A(:,:)
    REAL(dp),ALLOCATABLE::D(:,:)
    !本程序用到的局部变量
    INTEGER::fnum,i,j,err
    
    M=1
    fnum=10
    OPEN(fnum,file='eq.dat')
    READ(fnum,*)N
    ALLOCATE(A(N,N),stat=err)
    IF(err/=0)GOTO 997
    ALLOCATE(D(N,M),stat=err)
    IF(err/=0)GOTO 997

    DO j=1,N
    READ(fnum,*)(A(i,j),i=1,N)
    ENDDO
    READ(fnum,*)(D(i,1),i=1,N)
    CLOSE(fnum)

    GOTO 1000
    997 WRITE(*,*)'子程序Test空间不足'
    STOP
    1000END SUBROUTINE Test
END MODULE TestM


PROGRAM main
USE TestM
IMPLICIT NONE
INTEGER,PARAMETER::dp=kind(1.0D0)
INTEGER::N,M
REAL(dp),ALLOCATABLE::A(:,:)
REAL(dp),ALLOCATABLE::D(:,:)
!本程序用到的局部变量、
INTEGER::i,j


!-----读文件
CALL Test(A,D,N,M)
CALL RBF_slove_equation(A,D,N,M)
END PROGRAM main

SUBROUTINE RBF_slove_equation(A,D,N,M)
!use mpi
!use mkl_service
implicit double precision(a-h,o-z)
real(kind=8)::A(N,N),D(N,M)
character(len=1):: ORDER
integer,parameter::IA = 1, JA = 1, IB = 1, JB = 1,   & 
     &           MB = 2, NB = 2, NRHS = 1,irsrc=0,icsrc=0
integer::desca(9),descb(9),IPIV( N+NB )

ORDER='R'
NPROW = 2
NPCOL = 2

CALL BLACS_GET(-1, 0, ICTXT)

CALL BLACS_GRIDINIT(ICTXT, ORDER, NPROW, NPCOL)   !     INITIALIZE THE PROCESS GRID
write(*,*)'ICTXT',ICTXT
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )

!CALL BLACS_GRIDINFO(ICTXT, NPROW, NPCOL, MYROW, MYCOL)
write(*,*)'MYROW, MYCOL',MYROW, MYCOL

!CALL DESCINIT (desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
call DESCINIT(desca,n,n,mb, nb,irsrc, icsrc,ICTXT,N,INFO)  
call DESCINIT(descb,n,NRHS,mb, nb,irsrc, icsrc,ICTXT,n,INFO)
write(*,*)'n',n

!-----求解
call pdgesv(n, nrhs, a, ia, ja, desca, ipiv, D, ib, jb, descb, info)

OPEN(10,file='res.dat')
WRITE(10,*)(D(i,M),i=1,N)
CLOSE(10)
 
END !! RBF_slove_equation