*** empty log message ***

psblas3-type-indexed
Alfredo Buttari 20 years ago
parent cd656f8f4b
commit 6f2ca4384d

@ -117,7 +117,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
end if end if
end if end if
liwork=ncol liwork=nrow
if (present(work)) then if (present(work)) then
if(size(work).ge.liwork) then if(size(work).ge.liwork) then
iwork => work iwork => work
@ -276,7 +276,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
end if end if
end if end if
liwork=ncol liwork=nrow
if (present(work)) then if (present(work)) then
if(size(work).ge.liwork) then if(size(work).ge.liwork) then
iwork => work iwork => work
@ -298,7 +298,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
goto 9999 goto 9999
end if end if
end if end if
! exchange halo elements ! exchange halo elements
if(ltran.eq.'N') then if(ltran.eq.'N') then
call psi_swapdata(imode,0.d0,x(iix:size(x)),& call psi_swapdata(imode,0.d0,x(iix:size(x)),&

@ -39,7 +39,7 @@ subroutine psi_compute_size(desc_data,&
goto 9999 goto 9999
endif endif
np=npcol np=nprow
allocate(counter_dl(0:np-1),counter_recv(0:np-1)) allocate(counter_dl(0:np-1),counter_recv(0:np-1))
! ..initialize counters... ! ..initialize counters...
do i=0,np-1 do i=0,np-1
@ -51,6 +51,7 @@ subroutine psi_compute_size(desc_data,&
i=1 i=1
do while (index_in(i).ne.-1) do while (index_in(i).ne.-1)
proc=index_in(i) proc=index_in(i)
! write(0,'(i2," index_in(i) ",2i10)')myrow,proc,index_in(i+index_in(i+1)+2)
if ((proc.gt.np-1).or.(proc.lt.0)) then if ((proc.gt.np-1).or.(proc.lt.0)) then
info = 115 info = 115
int_err(1) = 11 int_err(1) = 11

@ -71,6 +71,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
! which every process must communcate with... ! which every process must communcate with...
if (debug) write(*,*) 'crea_halo: calling extract_dep_list' if (debug) write(*,*) 'crea_halo: calling extract_dep_list'
mode = 1 mode = 1
call psi_extract_dep_list(desc_a%matrix_data,index_in,& call psi_extract_dep_list(desc_a%matrix_data,index_in,&
& dep_list,length_dl,np,dl_lda,mode,info) & dep_list,length_dl,np,dl_lda,mode,info)
if(info /= 0) then if(info /= 0) then

@ -96,8 +96,8 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info)
swap_send = iand(flag,psb_swap_send_).ne.0 swap_send = iand(flag,psb_swap_send_).ne.0
swap_recv = iand(flag,psb_swap_recv_).ne.0 swap_recv = iand(flag,psb_swap_recv_).ne.0
h_idx => desc_a%halo_index h_idx => desc_a%halo_index
idxs = 0 idxs = 1
idxr = 0 idxr = 1
totxch = 0 totxch = 0
point_to_proc = 1 point_to_proc = 1
rvhd(:) = mpi_request_null rvhd(:) = mpi_request_null
@ -278,6 +278,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info)
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
@ -507,12 +508,15 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
swap_send = iand(flag,psb_swap_send_).ne.0 swap_send = iand(flag,psb_swap_send_).ne.0
swap_recv = iand(flag,psb_swap_recv_).ne.0 swap_recv = iand(flag,psb_swap_recv_).ne.0
h_idx => desc_a%halo_index h_idx => desc_a%halo_index
idxs = 0 idxs = 1
idxr = 0 idxr = 1
totxch = 0 totxch = 0
point_to_proc = 1 point_to_proc = 1
rvhd(:) = mpi_request_null rvhd(:) = mpi_request_null
n=1 n=1
call blacs_barrier(icontxt,'All') ! to be removed
write(0,'(i2," Inside swapdatav ",10(i6,2x))')myrow,h_idx(1:10)
call blacs_barrier(icontxt,'All') ! to be removed
! prepare info for communications ! prepare info for communications
proc_to_comm = h_idx(point_to_proc+psb_proc_id_) proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
@ -656,6 +660,10 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
else if (swap_send .and. swap_recv) then else if (swap_send .and. swap_recv) then
call blacs_barrier(icontxt,'All') ! to be removed
write(0,'(i2," posting recv ",10(i6,2x))')myrow,h_idx(1:10)
call blacs_barrier(icontxt,'All') ! to be removed
! First I post all the non blocking receives ! First I post all the non blocking receives
point_to_proc = 1 point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_) proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
@ -666,10 +674,12 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(icontxt,proc_to_comm,myrow)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
write(0,'(i2,"---Posting recv: ",5(i6,2x))')myrow,rcv_pt,proc_to_comm,rvsz(proc_to_comm),prcid(proc_to_comm),p2ptag
call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
& p2ptag, icomm,rvhd(proc_to_comm),iret) & p2ptag, icomm,rvhd(proc_to_comm),iret)
if(iret.ne.mpi_success) then if(iret.ne.mpi_success) then
write(0,'(i2," ERROR 1",3(i6,2x))')myrow,iret,mpi_success
int_err(1) = iret int_err(1) = iret
info=400 info=400
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
@ -681,6 +691,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
proc_to_comm = h_idx(point_to_proc+psb_proc_id_) proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
end do end do
write(0,'(i2," posting snd ",10(i6,2x))')myrow,h_idx(1:10)
! Then I post all the blocking sends ! Then I post all the blocking sends
point_to_proc = 1 point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_) proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
@ -695,10 +706,12 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(icontxt,proc_to_comm,myrow)
write(0,'(i2,"--Posting send: ",5(i6,2x))')myrow,snd_pt,proc_to_comm,sdsz(proc_to_comm),prcid(proc_to_comm),p2ptag
call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
if(iret.ne.mpi_success) then if(iret.ne.mpi_success) then
write(0,'(i2," ERROR 2",3(i6,2x))')myrow,iret,mpi_success
int_err(1) = iret int_err(1) = iret
info=400 info=400
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
@ -709,9 +722,11 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
proc_to_comm = h_idx(point_to_proc+psb_proc_id_) proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
end do end do
write(0,'(i2," waiting ",10(i6,2x))')myrow,h_idx(1:10)
do i=1, totxch do i=1, totxch
call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret) call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret)
if(iret.ne.mpi_success) then if(iret.ne.mpi_success) then
write(0,'(i2," ERROR 3",3(i6,2x))')myrow,iret,mpi_success
int_err(1) = iret int_err(1) = iret
info=400 info=400
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
@ -730,6 +745,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),& call psi_sct(nerv,h_idx(idx_pt:idx_pt+nerv-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta,y) & sndbuf(snd_pt:snd_pt+nesd-1),beta,y)
else else
write(0,'(i2," ERROR 4",5(i6,2x))')myrow,iret,mpi_success,mpi_err_request,mpi_err_arg
int_err(1) = ixrec int_err(1) = ixrec
info=400 info=400
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
@ -737,6 +753,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
end if end if
end do end do
write(0,'(i2," cleaning up ",10(i6,2x))')myrow,h_idx(1:10)
point_to_proc = 1 point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_) proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
do while (proc_to_comm .ne. -1) do while (proc_to_comm .ne. -1)
@ -754,6 +771,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info)
proc_to_comm = h_idx(point_to_proc+psb_proc_id_) proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
end do end do
write(0,'(i2," snd/rcv ",10(i6,2x))')myrow,h_idx(1:10)
else if (swap_send) then else if (swap_send) then

@ -7,7 +7,6 @@ subroutine psi_dgthm(n,k,idx,x,y)
! Locals ! Locals
integer :: i, j, pt integer :: i, j, pt
pt=0 pt=0
do j=1,k do j=1,k
do i=1,n do i=1,n

@ -188,9 +188,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
If (itx >= itmax) Exit restart If (itx >= itmax) Exit restart
it = 0 it = 0
Call psb_axpby(one,b,zero,r,desc_a,info) Call psb_axpby(one,b,zero,r,desc_a,info)
!!$ imerr = MPE_Log_event( immb, 0, "st SPMM" )
Call psb_spmm(-one,a,x,one,r,desc_a,info,work=aux) Call psb_spmm(-one,a,x,one,r,desc_a,info,work=aux)
!!$ imerr = MPE_Log_event( imme, 0, "ed SPMM" )
Call psb_axpby(one,r,zero,q,desc_a,info) Call psb_axpby(one,r,zero,q,desc_a,info)
if (info /= 0) Then if (info /= 0) Then
info=4011 info=4011

@ -204,7 +204,6 @@ subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
case(bja_) case(bja_)
write(0,*)'calling bja'
call psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info) call psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
@ -374,7 +373,6 @@ subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
real(kind(1.d0)), parameter :: one=1.d0, zero=0.d0 real(kind(1.d0)), parameter :: one=1.d0, zero=0.d0
external mpi_wtime external mpi_wtime
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
write(0,*)'inside bja'
name='psb_dbjacaply' name='psb_dbjacaply'
info = 0 info = 0
@ -421,6 +419,7 @@ subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
call psb_spsm(one,prec%av(l_pr_),x,zero,ww,desc_data,info,& call psb_spsm(one,prec%av(l_pr_),x,zero,ww,desc_data,info,&
& trans='N',unit=diagl,choice=psb_none_,work=aux) & trans='N',unit=diagl,choice=psb_none_,work=aux)
if(info /=0) goto 9999
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row) ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
call psb_spsm(one,prec%av(u_pr_),ww,beta,y,desc_data,info,& call psb_spsm(one,prec%av(u_pr_),ww,beta,y,desc_data,info,&
& trans='N',unit=diagu,choice=psb_none_, work=aux) & trans='N',unit=diagu,choice=psb_none_, work=aux)
@ -429,6 +428,7 @@ subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
case('T','t','C','c') case('T','t','C','c')
call psb_spsm(one,prec%av(u_pr_),x,zero,ww,desc_data,info,& call psb_spsm(one,prec%av(u_pr_),x,zero,ww,desc_data,info,&
& trans=trans,unit=diagu,choice=psb_none_, work=aux) & trans=trans,unit=diagu,choice=psb_none_, work=aux)
if(info /=0) goto 9999
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row) ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
call psb_spsm(one,prec%av(l_pr_),ww,beta,y,desc_data,info,& call psb_spsm(one,prec%av(l_pr_),ww,beta,y,desc_data,info,&
& trans=trans,unit=diagl,choice=psb_none_,work=aux) & trans=trans,unit=diagl,choice=psb_none_,work=aux)
@ -487,6 +487,7 @@ subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
call psb_spsm(one,prec%av(l_pr_),ty,zero,ww,& call psb_spsm(one,prec%av(l_pr_),ty,zero,ww,&
& prec%desc_data,info,& & prec%desc_data,info,&
& trans='N',unit='U',choice=psb_none_,work=aux) & trans='N',unit='U',choice=psb_none_,work=aux)
if(info /=0) goto 9999
ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row) ww(1:n_row) = ww(1:n_row)*prec%d(1:n_row)
call psb_spsm(one,prec%av(u_pr_),ww,zero,tx,& call psb_spsm(one,prec%av(u_pr_),ww,zero,tx,&
& prec%desc_data,info,& & prec%desc_data,info,&

@ -343,7 +343,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,&
& ix, iy, ik, ijx, ijy, i, lld,& & ix, iy, ik, jx, jy, i, lld,&
& idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy
character :: lunitd character :: lunitd
@ -377,6 +377,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
ix = 1 ix = 1
iy = 1 iy = 1
ik = 1 ik = 1
jx= 1
jy= 1
if (present(choice)) then if (present(choice)) then
lchoice = choice lchoice = choice
@ -456,8 +458,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness ! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a%matrix_data,info,iia,jja) call psb_chkmat(m,m,ia,ja,desc_a%matrix_data,info,iia,jja)
! checking for vectors correctness ! checking for vectors correctness
call psb_chkvect(m,ik,size(x),ix,ijx,desc_a%matrix_data,info,iix,jjx) call psb_chkvect(m,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ik,size(y),iy,ijy,desc_a%matrix_data,info,iiy,jjy) call psb_chkvect(m,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkvect/mat' ch_err='psb_chkvect/mat'

@ -168,7 +168,7 @@ C VAL, INDX, PNTR
C INFOT(*) not used C INFOT(*) not used
C C
CALL DCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, CALL DCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1,
& IT2,B,LDB,BETA,C,LDC,WORK,LWORK) & IT2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR)
ELSE IF (FIDT(1:3).EQ.'JAD') THEN ELSE IF (FIDT(1:3).EQ.'JAD') THEN
CALL DJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2, CALL DJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2,

@ -140,6 +140,7 @@ subroutine psb_dscasb(desc_a,info)
& nhalo,lhalo,halo_index(lhalo) & nhalo,lhalo,halo_index(lhalo)
!.... convert comunication stuctures.... !.... convert comunication stuctures....
! first the halo index ! first the halo index
call psi_crea_index(desc_a,halo_index,& call psi_crea_index(desc_a,halo_index,&
& desc_a%halo_index,.false.,info) & desc_a%halo_index,.false.,info)
if(info.ne.0) then if(info.ne.0) then

@ -5,7 +5,7 @@ CSR A Storage format CSR COO JAD
20 Domain size (acutal sistem is this**3) 20 Domain size (acutal sistem is this**3)
1 Stopping criterion 1 Stopping criterion
080 MAXIT 080 MAXIT
-1 ITRACE 00 ITRACE
02 ML 02 ML

@ -117,7 +117,7 @@ program pde90
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
goto 9999
dim=size(a%aspk) dim=size(a%aspk)
!!$ allocate(h%aspk(dim),h%ia1(dim),h%ia2(dim),h%pl(size(a%pl)),& !!$ allocate(h%aspk(dim),h%ia1(dim),h%ia2(dim),h%pl(size(a%pl)),&
@ -452,14 +452,14 @@ contains
m = idim*idim*idim m = idim*idim*idim
n = m n = m
nnz = ((n*9)/(nprow*npcol)) nnz = ((n*9)/(nprow*npcol))
write(*,*) 'size: n ',n write(*,*) 'size: n ',n,myprow
call psb_dscall(n,n,parts,icontxt,desc_a,info) call psb_dscall(n,n,parts,icontxt,desc_a,info)
write(*,*) 'allocating a : nnz',nnz, info write(*,*) 'allocating a. nnz:',nnz,myprow
call psb_spalloc(a,desc_a,info,nnz=nnz) call psb_spalloc(a,desc_a,info,nnz=nnz)
! define rhs from boundary conditions; also build initial guess ! define rhs from boundary conditions; also build initial guess
write(*,*) 'allocating b', info write(*,*) 'allocating b', info,myprow
call psb_alloc(n,b,desc_a,info) call psb_alloc(n,b,desc_a,info)
write(*,*) 'allocating t', info write(*,*) 'allocating t', info,myprow
call psb_alloc(n,t,desc_a,info) call psb_alloc(n,t,desc_a,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
@ -474,7 +474,7 @@ contains
! !
row_mat%descra(1:1) = 'G' row_mat%descra(1:1) = 'G'
row_mat%fida = 'CSR' row_mat%fida = 'CSR'
write(*,*) 'allocating row_mat',20*nbmax ! write(*,*) 'allocating row_mat',20*nbmax
allocate(row_mat%aspk(20*nbmax),row_mat%ia1(20*nbmax),& allocate(row_mat%aspk(20*nbmax),row_mat%ia1(20*nbmax),&
&row_mat%ia2(20*nbmax),prv(nprow),stat=info) &row_mat%ia2(20*nbmax),prv(nprow),stat=info)
if (info.ne.0 ) then if (info.ne.0 ) then
@ -656,8 +656,6 @@ contains
deallocate(row_mat%aspk,row_mat%ia1,row_mat%ia2) deallocate(row_mat%aspk,row_mat%ia1,row_mat%ia2)
write(*,*) 'calling spasb'
call blacs_barrier(icontxt,'ALL')
t1 = mpi_wtime() t1 = mpi_wtime()
call psb_dscasb(desc_a,info) call psb_dscasb(desc_a,info)
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt) call psb_spasb(a,desc_a,info,dup=1,afmt=afmt)
@ -672,7 +670,8 @@ contains
write(0,*) ' assembly time',(t2-t1),' ',a%fida(1:4) write(0,*) ' assembly time',(t2-t1),' ',a%fida(1:4)
call psb_asb(b,desc_a,info) call psb_asb(b,desc_a,info)
call psb_asb(t,desc_a,info) write(0,*)'Remeber This!!!!!!'
! call psb_asb(t,desc_a,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='asb rout.' ch_err='asb rout.'

Loading…
Cancel
Save