From 56e81f5080b0e7813e67137d0ca638f266da17b2 Mon Sep 17 00:00:00 2001 From: Alfredo Buttari Date: Thu, 1 Dec 2005 16:17:48 +0000 Subject: [PATCH] *** empty log message *** --- src/internals/psi_compute_size.f90 | 1 - src/internals/psi_crea_index.f90 | 11 +++++- src/internals/psi_dl_check.f90 | 57 ++++++++++++++++-------------- src/internals/psi_extrct_dl.f | 2 ++ src/methd/psb_dcg.f90 | 3 +- src/modules/psb_prec_type.f90 | 23 +++++++----- src/prec/psb_dcsrsetup.f90 | 24 ++++--------- src/psblas/psb_dspmm.f90 | 4 +-- src/tools/psb_descasb.f90 | 15 +------- src/tools/psb_dscasb.f90 | 3 +- src/tools/psb_dscov.f90 | 2 +- 11 files changed, 71 insertions(+), 74 deletions(-) diff --git a/src/internals/psi_compute_size.f90 b/src/internals/psi_compute_size.f90 index d872a829..0d33eefd 100644 --- a/src/internals/psi_compute_size.f90 +++ b/src/internals/psi_compute_size.f90 @@ -51,7 +51,6 @@ 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 96af75b0..e0461001 100644 --- a/src/internals/psi_crea_index.f90 +++ b/src/internals/psi_crea_index.f90 @@ -14,7 +14,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) ! ....local scalars... integer :: me,npcol,mycol,nprow,i,j,k,& & mode, int_err(5), err, err_act, np,& - & dl_lda, icontxt + & dl_lda, icontxt, proc, nerv, nesd ! ...parameters... integer, pointer :: dep_list(:,:), length_dl(:) integer,parameter :: root=0,no_comm=-1 @@ -35,6 +35,13 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) end subroutine psi_sort_dl end interface + interface + subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) + integer :: np,dl_lda,length_dl(0:np) + integer :: dep_list(dl_lda,0:np) + end subroutine psi_dl_check + end interface + interface subroutine psi_desc_index(desc_data,index_in,dep_list,& & length_dl,loc_to_glob,glob_to_loc,desc_index,& @@ -66,6 +73,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) ! allocate dependency list call psi_compute_size(desc_a%matrix_data, index_in, dl_lda, info) +! dl_lda=dl_lda+3 allocate(dep_list(max(1,dl_lda),0:np),length_dl(0:np)) ! ...extract dependence list (ordered list of identifer process ! which every process must communcate with... @@ -100,6 +108,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) call psi_desc_index(desc_a%matrix_data,index_in,dep_list(1:,me),& & length_dl(me),desc_a%loc_to_glob,desc_a%glob_to_loc,& & index_out,glob_idx,info) + if(info.ne.0) then call psb_errpush(4010,name,a_err='psi_desc_index') goto 9999 diff --git a/src/internals/psi_dl_check.f90 b/src/internals/psi_dl_check.f90 index bc03a213..f67cec0a 100644 --- a/src/internals/psi_dl_check.f90 +++ b/src/internals/psi_dl_check.f90 @@ -8,38 +8,41 @@ subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) ! locals integer :: proc, proc2, i, j -! ...i must order communication in in halo + ! ...i must order communication in in halo -! ...if in dep_list of process i there is j -! and in dep_list of process j there isn't i, -! add to it process i... + ! ...if in dep_list of process i there is j + ! and in dep_list of process j there isn't i, + ! add to it process i... do proc=0,np-1 - i=1 - do while (i.le.length_dl(proc)) - proc2=dep_list(i,proc) - if (proc2.ne.psb_no_comm_) then - ! ...search proc in proc2's dep_list.... - j=1 - do while ((j.le.length_dl(proc2).and.& - & dep_list(j,proc2).ne.proc)) - j=j+1 - enddo - if ((dep_list(j,proc2).ne.proc).or.& - & (j.gt.length_dl(proc2))) then + i=1 + outer: do + if (i >length_dl(proc)) exit outer + proc2=dep_list(i,proc) + if (proc2.ne.psb_no_comm_) then + ! ...search proc in proc2's dep_list.... + j=1 + p2loop:do + if (j > length_dl(proc2)) exit p2loop + if (dep_list(j,proc2) == proc) exit p2loop + j=j+1 + enddo p2loop - ! ...proc not found... - ! ...add proc to proc2's dep_list..... - length_dl(proc2)=length_dl(proc2)+1 - if (length_dl(proc2).gt.size(dep_list,1)) then - write(0,*)'error in crea_halo', proc2,& - & length_dl(proc2),'>',size(dep_list,1) - endif - dep_list(length_dl(proc2),proc2)=proc - endif + if (j > length_dl(proc2)) then + ! ...add proc to proc2 s dep_list.....',proc,proc2 + length_dl(proc2) = length_dl(proc2)+1 + if (length_dl(proc2) > size(dep_list,1)) then + write(0,*)'error in crea_halo', proc2,proc,& + & length_dl(proc2),'>',size(dep_list,1) + endif + dep_list(length_dl(proc2),proc2) = proc + else if (dep_list(j,proc2) /= proc) then + write(0,*) 'PSI_DL_CHECK This should not happen!!! ',& + & j,proc2,dep_list(j,proc2),proc endif - i=i+1 - enddo + endif + i=i+1 + enddo outer enddo end subroutine psi_dl_check diff --git a/src/internals/psi_extrct_dl.f b/src/internals/psi_extrct_dl.f index 85e18676..d0372edb 100644 --- a/src/internals/psi_extrct_dl.f +++ b/src/internals/psi_extrct_dl.f @@ -139,6 +139,7 @@ c ..if number of element to be exchanged !=0 info = 3999 goto 998 endif +! if((me.eq.1).and.(proc.eq.3))write(0,*)'found 3' if (mode.eq.1) then c ...search if already exist proc c in dep_list(*,me)... @@ -254,6 +255,7 @@ c ...send to root dependence list.... endif end if + return 9999 continue diff --git a/src/methd/psb_dcg.f90 b/src/methd/psb_dcg.f90 index d73bd3da..51c627bd 100644 --- a/src/methd/psb_dcg.f90 +++ b/src/methd/psb_dcg.f90 @@ -146,8 +146,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,& itrac = -1 end if -!!$ DIAGL = 'U' -!!$ DIAGU = 'R' + itx=0 ! Ensure global coherence for convergence checks. call blacs_get(icontxt,16,isvch) diff --git a/src/modules/psb_prec_type.f90 b/src/modules/psb_prec_type.f90 index 807e4170..d5356796 100644 --- a/src/modules/psb_prec_type.f90 +++ b/src/modules/psb_prec_type.f90 @@ -51,15 +51,15 @@ module psb_prec_type type psb_dbase_prec - type(psb_dspmat_type), pointer :: av(:) => null() + type(psb_dspmat_type), pointer :: av(:) => null() ! real(kind(1.d0)), pointer :: d(:) => null() - type(psb_desc_type), pointer :: desc_data => null() - integer, pointer :: iprcparm(:) => null() - real(kind(1.d0)), pointer :: dprcparm(:) => null() + type(psb_desc_type), pointer :: desc_data => null() ! + integer, pointer :: iprcparm(:) => null() ! + real(kind(1.d0)), pointer :: dprcparm(:) => null() ! integer, pointer :: perm(:) => null(), invperm(:) => null() - integer, pointer :: mlia(:) => null(), nlaggr(:) => null() - type(psb_dspmat_type), pointer :: aorig => null() - real(kind(1.d0)), pointer :: dorig(:) => null() + integer, pointer :: mlia(:) => null(), nlaggr(:) => null() ! + type(psb_dspmat_type), pointer :: aorig => null() ! + real(kind(1.d0)), pointer :: dorig(:) => null() ! end type psb_dbase_prec @@ -347,7 +347,6 @@ contains endif if (associated(p%dorig)) then deallocate(p%dorig,stat=info) - nullify(p%dorig) endif if (associated(p%mlia)) then @@ -358,6 +357,14 @@ contains deallocate(p%nlaggr,stat=info) endif + if (associated(p%perm)) then + deallocate(p%perm,stat=info) + endif + + if (associated(p%invperm)) then + deallocate(p%invperm,stat=info) + endif + if (associated(p%iprcparm)) then if (p%iprcparm(f_type_)==f_slu_) then call fort_slu_free(p%iprcparm(slu_ptr_),info) diff --git a/src/prec/psb_dcsrsetup.f90 b/src/prec/psb_dcsrsetup.f90 index f5cdbeae..74b38187 100644 --- a/src/prec/psb_dcsrsetup.f90 +++ b/src/prec/psb_dcsrsetup.f90 @@ -132,16 +132,6 @@ Subroutine psb_dcsrsetup(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) endif call blacs_get(icontxt,10,icomm ) -!!$ call MPI_Comm_rank(icomm,irank,ierr) -!!$ idscb = mpe_log_get_event_number() -!!$ idsce = mpe_log_get_event_number() -!!$ iovrb = mpe_log_get_event_number() -!!$ iovre = mpe_log_get_event_number() -!!$ if (irank==0) then -!!$ info = mpe_describe_state(idscb,idsce,"DSCASB ","NavyBlue") -!!$ info = mpe_describe_state(iovrb,iovre,"DSCOVR ","DeepPink") -!!$ endif -!!$ Call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) If(debug)Write(0,*)'BEGIN dcsrsetup',me,upd,novr @@ -151,13 +141,13 @@ Subroutine psb_dcsrsetup(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) ! ! Build the auiliary descriptor',desc_p%matrix_data(psb_n_row_) ! - call psb_dscov(a,desc_data,novr,desc_p,info) - if(info /= 0) then - info=4010 - ch_err='psb_dscov' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + call psb_dscov(a,desc_data,novr,desc_p,info) + if(info /= 0) then + info=4010 + ch_err='psb_dscov' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if Endif if(debug) write(0,*) me,' From dscov _:',desc_p%matrix_data(psb_n_row_),desc_p%matrix_data(psb_n_col_) diff --git a/src/psblas/psb_dspmm.f90 b/src/psblas/psb_dspmm.f90 index 07890ff1..0f75999d 100644 --- a/src/psblas/psb_dspmm.f90 +++ b/src/psblas/psb_dspmm.f90 @@ -154,8 +154,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! check for presence/size of a work area liwork= 2*ncol - if (a%pr(1) /= 0) llwork = liwork + n * ik - if (a%pl(1) /= 0) llwork = llwork + m * ik + if (a%pr(1) /= 0) liwork = liwork + n * ik + if (a%pl(1) /= 0) liwork = liwork + m * ik if (present(work)) then if(size(work).lt.liwork) then call psb_realloc(liwork,work,info) diff --git a/src/tools/psb_descasb.f90 b/src/tools/psb_descasb.f90 index eecb7599..80855906 100644 --- a/src/tools/psb_descasb.f90 +++ b/src/tools/psb_descasb.f90 @@ -72,18 +72,6 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,& tch = 0.0 t4 = 0.0 call blacs_get(icontxt,10,icomm ) -!!$ call MPI_Comm_rank(icomm,irank,ierr) -!!$ idscb = mpe_log_get_event_number() -!!$ idsce = mpe_log_get_event_number() -!!$ iovrb = mpe_log_get_event_number() -!!$ iovre = mpe_log_get_event_number() -!!$ icrhb = mpe_log_get_event_number() -!!$ icrhe = mpe_log_get_event_number() -!!$ if (irank==0) then -!!$ info = mpe_describe_state(idscb,idsce,"DSCLOOP ","gold") -!!$ info = mpe_describe_state(icrhb,icrhe,"CRTHAL ","turquoise3") -!!$ info = mpe_describe_state(iovrb,iovre,"CNVRTC ","red4") -!!$ endif mglob = desc_a%matrix_data(psb_m_) m = desc_a%matrix_data(psb_n_row_) @@ -117,8 +105,6 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,& tot_recv = 0 counter_h = 1 counter_o = 1 -!!$ write(0,*) 'Before ',tmp_ovr_idx(1:10) -!!$ ierr = MPE_Log_event( idscb, 0, "st DSCLP " ) ! See comment in main loop below. call InitPairSearchTree(info) @@ -552,6 +538,7 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,& !!$ ierr = MPE_Log_event( icrhb, 0, "st CRTHAL" ) if (debug) write(0,*) myrow,'Checktmp_o_i 1',tmp_ovr_idx(1:10) if (debug) write(0,*) myrow,'Calling Crea_Halo' + call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,info) !!$ Call psi_crea_halo(desc_p%matrix_data,t_halo_in,& !!$ & np,t_halo_out,Size(t_halo_out),dep_list,& diff --git a/src/tools/psb_dscasb.f90 b/src/tools/psb_dscasb.f90 index 56fb2fd9..44834467 100644 --- a/src/tools/psb_dscasb.f90 +++ b/src/tools/psb_dscasb.f90 @@ -169,7 +169,8 @@ subroutine psb_dscasb(desc_a,info) ! Ok, register into MATRIX_DATA & free temporary work areas desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ - deallocate(halo_index,ovrlap_index, stat=info) + deallocate(ovrlap_index, stat=info) + deallocate(halo_index, stat=info) if (info /= 0) then info =4000 call psb_errpush(info,name) diff --git a/src/tools/psb_dscov.f90 b/src/tools/psb_dscov.f90 index d59220e5..d7f24915 100644 --- a/src/tools/psb_dscov.f90 +++ b/src/tools/psb_dscov.f90 @@ -179,7 +179,7 @@ Subroutine psb_dscov(a,desc_a,novr,desc_ov,info) ! The real work goes on in here.... ! Call psb_descasb(novr,desc_ov,desc_a,a,& - & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) + & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) if (info.ne.0) then info=4010 ch_err='psb_descasb'