From 6f2ca4384d3cae6306a94ab86eafe0ae5d8b463b Mon Sep 17 00:00:00 2001 From: Alfredo Buttari Date: Fri, 16 Sep 2005 09:01:40 +0000 Subject: [PATCH] *** empty log message *** --- src/comm/psb_dhalo.f90 | 6 +++--- src/internals/psi_compute_size.f90 | 3 ++- src/internals/psi_crea_index.f90 | 1 + src/internals/psi_dswapdata.f90 | 26 ++++++++++++++++++++++---- src/internals/psi_gthsct.f90 | 1 - src/methd/psb_dcgstab.f90 | 2 -- src/prec/psb_dprec.f90 | 5 +++-- src/psblas/psb_dspsm.f90 | 8 +++++--- src/serial/f77/dswsm.f | 2 +- src/tools/psb_dscasb.f90 | 1 + test/pargen/RUNS/ppde.inp | 2 +- test/pargen/ppde90.f90 | 17 ++++++++--------- 12 files changed, 47 insertions(+), 27 deletions(-) diff --git a/src/comm/psb_dhalo.f90 b/src/comm/psb_dhalo.f90 index c7667990..ee23d586 100644 --- a/src/comm/psb_dhalo.f90 +++ b/src/comm/psb_dhalo.f90 @@ -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)),& diff --git a/src/internals/psi_compute_size.f90 b/src/internals/psi_compute_size.f90 index eb5f23b5..d872a829 100644 --- a/src/internals/psi_compute_size.f90 +++ b/src/internals/psi_compute_size.f90 @@ -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 diff --git a/src/internals/psi_crea_index.f90 b/src/internals/psi_crea_index.f90 index bbc375a2..bf7f4855 100644 --- a/src/internals/psi_crea_index.f90 +++ b/src/internals/psi_crea_index.f90 @@ -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 diff --git a/src/internals/psi_dswapdata.f90 b/src/internals/psi_dswapdata.f90 index 50c125a8..40c63aec 100644 --- a/src/internals/psi_dswapdata.f90 +++ b/src/internals/psi_dswapdata.f90 @@ -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 diff --git a/src/internals/psi_gthsct.f90 b/src/internals/psi_gthsct.f90 index 3c6225b5..c574e639 100644 --- a/src/internals/psi_gthsct.f90 +++ b/src/internals/psi_gthsct.f90 @@ -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 diff --git a/src/methd/psb_dcgstab.f90 b/src/methd/psb_dcgstab.f90 index a5301909..20770c63 100644 --- a/src/methd/psb_dcgstab.f90 +++ b/src/methd/psb_dcgstab.f90 @@ -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 diff --git a/src/prec/psb_dprec.f90 b/src/prec/psb_dprec.f90 index 9d135aac..a826f292 100644 --- a/src/prec/psb_dprec.f90 +++ b/src/prec/psb_dprec.f90 @@ -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,& diff --git a/src/psblas/psb_dspsm.f90 b/src/psblas/psb_dspsm.f90 index 80cc2edc..01823d0c 100644 --- a/src/psblas/psb_dspsm.f90 +++ b/src/psblas/psb_dspsm.f90 @@ -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' diff --git a/src/serial/f77/dswsm.f b/src/serial/f77/dswsm.f index 13a6901c..f83b5e27 100644 --- a/src/serial/f77/dswsm.f +++ b/src/serial/f77/dswsm.f @@ -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, diff --git a/src/tools/psb_dscasb.f90 b/src/tools/psb_dscasb.f90 index 7e4c90cc..56fb2fd9 100644 --- a/src/tools/psb_dscasb.f90 +++ b/src/tools/psb_dscasb.f90 @@ -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 diff --git a/test/pargen/RUNS/ppde.inp b/test/pargen/RUNS/ppde.inp index f08795f5..ee82cf4f 100644 --- a/test/pargen/RUNS/ppde.inp +++ b/test/pargen/RUNS/ppde.inp @@ -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 diff --git a/test/pargen/ppde90.f90 b/test/pargen/ppde90.f90 index d27eed98..c6054975 100644 --- a/test/pargen/ppde90.f90 +++ b/test/pargen/ppde90.f90 @@ -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.'