fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-17 03:12:15 +00:00
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
Alfredo Buttari
2005-09-16 09:01:40 +00:00
parent cd656f8f4b
commit 6f2ca4384d
12 changed files with 47 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/comm/psb_dhalo.f90
+3 -3
View File
@@ -117,7 +117,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
end if
end if
liwork=ncol
liwork=nrow
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
@@ -276,7 +276,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
end if
end if
liwork=ncol
liwork=nrow
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
@@ -298,7 +298,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
goto 9999
end if
end if
! exchange halo elements
if(ltran.eq.'N') then
call psi_swapdata(imode,0.d0,x(iix:size(x)),&
src/internals/psi_compute_size.f90
+2 -1
View File
@@ -39,7 +39,7 @@ subroutine psi_compute_size(desc_data,&
goto 9999
endif
np=npcol
np=nprow
allocate(counter_dl(0:np-1),counter_recv(0:np-1))
! ..initialize counters...
do i=0,np-1
@@ -51,6 +51,7 @@ subroutine psi_compute_size(desc_data,&
i=1
do while (index_in(i).ne.-1)
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
info = 115
int_err(1) = 11
src/internals/psi_crea_index.f90
+1
View File
@@ -71,6 +71,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
! which every process must communcate with...
if (debug) write(*,*) 'crea_halo: calling extract_dep_list'
mode = 1
call psi_extract_dep_list(desc_a%matrix_data,index_in,&
& dep_list,length_dl,np,dl_lda,mode,info)
if(info /= 0) then
src/internals/psi_dswapdata.f90
+22 -4
View File
@@ -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_recv = iand(flag,psb_swap_recv_).ne.0
h_idx => desc_a%halo_index
idxs = 0
idxr = 0
idxs = 1
idxr = 1
totxch = 0
point_to_proc = 1
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_
snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,h_idx(idx_pt:idx_pt+nesd-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_recv = iand(flag,psb_swap_recv_).ne.0
h_idx => desc_a%halo_index
idxs = 0
idxr = 0
idxs = 1
idxr = 1
totxch = 0
point_to_proc = 1
rvhd(:) = mpi_request_null
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
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
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
point_to_proc = 1
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
p2ptag = krecvid(icontxt,proc_to_comm,myrow)
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),&
& mpi_double_precision,prcid(proc_to_comm),&
& p2ptag, icomm,rvhd(proc_to_comm),iret)
if(iret.ne.mpi_success) then
write(0,'(i2," ERROR 1",3(i6,2x))')myrow,iret,mpi_success
int_err(1) = iret
info=400
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_)
end do
write(0,'(i2," posting snd ",10(i6,2x))')myrow,h_idx(1:10)
! Then I post all the blocking sends
point_to_proc = 1
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
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),&
& mpi_double_precision,prcid(proc_to_comm),&
& p2ptag,icomm,iret)
if(iret.ne.mpi_success) then
write(0,'(i2," ERROR 2",3(i6,2x))')myrow,iret,mpi_success
int_err(1) = iret
info=400
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_)
end do
write(0,'(i2," waiting ",10(i6,2x))')myrow,h_idx(1:10)
do i=1, totxch
call mpi_waitany(nprow,rvhd,ixrec,p2pstat,iret)
if(iret.ne.mpi_success) then
write(0,'(i2," ERROR 3",3(i6,2x))')myrow,iret,mpi_success
int_err(1) = iret
info=400
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),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta,y)
else
write(0,'(i2," ERROR 4",5(i6,2x))')myrow,iret,mpi_success,mpi_err_request,mpi_err_arg
int_err(1) = ixrec
info=400
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 do
write(0,'(i2," cleaning up ",10(i6,2x))')myrow,h_idx(1:10)
point_to_proc = 1
proc_to_comm = h_idx(point_to_proc+psb_proc_id_)
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_)
end do
write(0,'(i2," snd/rcv ",10(i6,2x))')myrow,h_idx(1:10)
else if (swap_send) then
src/internals/psi_gthsct.f90
-1
View File
@@ -7,7 +7,6 @@ subroutine psi_dgthm(n,k,idx,x,y)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
src/methd/psb_dcgstab.f90
-2
View File
@@ -188,9 +188,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
If (itx >= itmax) Exit restart
it = 0
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)
!!$ imerr = MPE_Log_event( imme, 0, "ed SPMM" )
Call psb_axpby(one,r,zero,q,desc_a,info)
if (info /= 0) Then
info=4011
src/prec/psb_dprec.f90
+3 -2
View File
@@ -204,7 +204,6 @@ subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
case(bja_)
write(0,*)'calling bja'
call psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then
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
external mpi_wtime
character(len=20) :: name, ch_err
write(0,*)'inside bja'
name='psb_dbjacaply'
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,&
& 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)
call psb_spsm(one,prec%av(u_pr_),ww,beta,y,desc_data,info,&
& 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')
call psb_spsm(one,prec%av(u_pr_),x,zero,ww,desc_data,info,&
& 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)
call psb_spsm(one,prec%av(l_pr_),ww,beta,y,desc_data,info,&
& 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,&
& prec%desc_data,info,&
& 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)
call psb_spsm(one,prec%av(u_pr_),ww,zero,tx,&
& prec%desc_data,info,&
src/psblas/psb_dspsm.f90
+5 -3
View File
@@ -343,7 +343,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& 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
character :: lunitd
@@ -377,6 +377,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
ix = 1
iy = 1
ik = 1
jx= 1
jy= 1
if (present(choice)) then
lchoice = choice
@@ -456,8 +458,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
! checking for matrix correctness
call psb_chkmat(m,m,ia,ja,desc_a%matrix_data,info,iia,jja)
! 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(y),iy,ijy,desc_a%matrix_data,info,iiy,jjy)
call psb_chkvect(m,ik,size(x),ix,jx,desc_a%matrix_data,info,iix,jjx)
call psb_chkvect(m,ik,size(y),iy,jy,desc_a%matrix_data,info,iiy,jjy)
if(info.ne.0) then
info=4010
ch_err='psb_chkvect/mat'
src/serial/f77/dswsm.f
+1 -1
View File
@@ -168,7 +168,7 @@ C VAL, INDX, PNTR
C INFOT(*) not used
C
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
CALL DJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2,
src/tools/psb_dscasb.f90
+1
View File
@@ -140,6 +140,7 @@ subroutine psb_dscasb(desc_a,info)
& nhalo,lhalo,halo_index(lhalo)
!.... convert comunication stuctures....
! first the halo index
call psi_crea_index(desc_a,halo_index,&
& desc_a%halo_index,.false.,info)
if(info.ne.0) then
test/pargen/RUNS/ppde.inp
+1 -1
View File
@@ -5,7 +5,7 @@ CSR A Storage format CSR COO JAD
20 Domain size (acutal sistem is this**3)
1 Stopping criterion
080 MAXIT
-1 ITRACE
00 ITRACE
02 ML
test/pargen/ppde90.f90
+8 -9
View File
@@ -117,7 +117,7 @@ program pde90
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
goto 9999
dim=size(a%aspk)
!!$ allocate(h%aspk(dim),h%ia1(dim),h%ia2(dim),h%pl(size(a%pl)),&
@@ -452,14 +452,14 @@ contains
m = idim*idim*idim
n = m
nnz = ((n*9)/(nprow*npcol))
write(*,*) 'size: n ',n
write(*,*) 'size: n ',n,myprow
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)
! 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)
write(*,*) 'allocating t', info
write(*,*) 'allocating t', info,myprow
call psb_alloc(n,t,desc_a,info)
if(info.ne.0) then
info=4010
@@ -474,7 +474,7 @@ contains
!
row_mat%descra(1:1) = 'G'
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),&
&row_mat%ia2(20*nbmax),prv(nprow),stat=info)
if (info.ne.0 ) then
@@ -656,8 +656,6 @@ contains
deallocate(row_mat%aspk,row_mat%ia1,row_mat%ia2)
write(*,*) 'calling spasb'
call blacs_barrier(icontxt,'ALL')
t1 = mpi_wtime()
call psb_dscasb(desc_a,info)
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)
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
info=4010
ch_err='asb rout.'