fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
psblas3-type-indexed
Alfredo Buttari 19 years ago
parent aaad9595f0
commit 56e81f5080
11 changed files with 71 additions and 74 deletions
Show Stats Download Patch File Download Diff File

1
src/internals/psi_compute_size.f90
Unescape Escape View File

@ -51,7 +51,6 @@ 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

11
src/internals/psi_crea_index.f90
Unescape Escape View File

@ -14,7 +14,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
! ....local scalars... ! ....local scalars...
integer :: me,npcol,mycol,nprow,i,j,k,& integer :: me,npcol,mycol,nprow,i,j,k,&
& mode, int_err(5), err, err_act, np,& & mode, int_err(5), err, err_act, np,&
& dl_lda, icontxt & dl_lda, icontxt, proc, nerv, nesd
! ...parameters... ! ...parameters...
integer, pointer :: dep_list(:,:), length_dl(:) integer, pointer :: dep_list(:,:), length_dl(:)
integer,parameter :: root=0,no_comm=-1 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 subroutine psi_sort_dl
end interface 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 interface
subroutine psi_desc_index(desc_data,index_in,dep_list,& subroutine psi_desc_index(desc_data,index_in,dep_list,&
& length_dl,loc_to_glob,glob_to_loc,desc_index,& & 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 ! allocate dependency list
call psi_compute_size(desc_a%matrix_data, index_in, dl_lda, info) 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)) allocate(dep_list(max(1,dl_lda),0:np),length_dl(0:np))
! ...extract dependence list (ordered list of identifer process ! ...extract dependence list (ordered list of identifer process
! which every process must communcate with... ! 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),& 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,& & length_dl(me),desc_a%loc_to_glob,desc_a%glob_to_loc,&
& index_out,glob_idx,info) & index_out,glob_idx,info)
if(info.ne.0) then if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_desc_index') call psb_errpush(4010,name,a_err='psi_desc_index')
goto 9999 goto 9999

57
src/internals/psi_dl_check.f90
Unescape Escape View File

@ -8,38 +8,41 @@ subroutine psi_dl_check(dep_list,dl_lda,np,length_dl)
! locals ! locals
integer :: proc, proc2, i, j 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 ! ...if in dep_list of process i there is j
! and in dep_list of process j there isn't i, ! and in dep_list of process j there isn't i,
! add to it process i... ! add to it process i...
do proc=0,np-1 do proc=0,np-1
i=1 i=1
do while (i.le.length_dl(proc)) outer: do
proc2=dep_list(i,proc) if (i >length_dl(proc)) exit outer
if (proc2.ne.psb_no_comm_) then proc2=dep_list(i,proc)
! ...search proc in proc2's dep_list.... if (proc2.ne.psb_no_comm_) then
j=1 ! ...search proc in proc2's dep_list....
do while ((j.le.length_dl(proc2).and.& j=1
& dep_list(j,proc2).ne.proc)) p2loop:do
j=j+1 if (j > length_dl(proc2)) exit p2loop
enddo if (dep_list(j,proc2) == proc) exit p2loop
if ((dep_list(j,proc2).ne.proc).or.& j=j+1
& (j.gt.length_dl(proc2))) then enddo p2loop
! ...proc not found... if (j > length_dl(proc2)) then
! ...add proc to proc2's dep_list..... ! ...add proc to proc2 s dep_list.....',proc,proc2
length_dl(proc2)=length_dl(proc2)+1 length_dl(proc2) = length_dl(proc2)+1
if (length_dl(proc2).gt.size(dep_list,1)) then if (length_dl(proc2) > size(dep_list,1)) then
write(0,*)'error in crea_halo', proc2,& write(0,*)'error in crea_halo', proc2,proc,&
& length_dl(proc2),'>',size(dep_list,1) & length_dl(proc2),'>',size(dep_list,1)
endif endif
dep_list(length_dl(proc2),proc2)=proc dep_list(length_dl(proc2),proc2) = proc
endif 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 endif
i=i+1 endif
enddo i=i+1
enddo outer
enddo enddo
end subroutine psi_dl_check end subroutine psi_dl_check

2
src/internals/psi_extrct_dl.f
Unescape Escape View File

@ -139,6 +139,7 @@ c ..if number of element to be exchanged !=0
info = 3999 info = 3999
goto 998 goto 998
endif endif
! if((me.eq.1).and.(proc.eq.3))write(0,*)'found 3'
if (mode.eq.1) then if (mode.eq.1) then
c ...search if already exist proc c ...search if already exist proc
c in dep_list(*,me)... c in dep_list(*,me)...
@ -254,6 +255,7 @@ c ...send to root dependence list....
endif endif
end if end if
return return
9999 continue 9999 continue

3
src/methd/psb_dcg.f90
Unescape Escape View File

@ -146,8 +146,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
itrac = -1 itrac = -1
end if end if
!!$ DIAGL = 'U' itx=0
!!$ DIAGU = 'R'
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call blacs_get(icontxt,16,isvch) call blacs_get(icontxt,16,isvch)

23
src/modules/psb_prec_type.f90
Unescape Escape View File

@ -51,15 +51,15 @@ module psb_prec_type
type psb_dbase_prec 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() real(kind(1.d0)), pointer :: d(:) => null()
type(psb_desc_type), pointer :: desc_data => null() type(psb_desc_type), pointer :: desc_data => null() !
integer, pointer :: iprcparm(:) => null() integer, pointer :: iprcparm(:) => null() !
real(kind(1.d0)), pointer :: dprcparm(:) => null() real(kind(1.d0)), pointer :: dprcparm(:) => null() !
integer, pointer :: perm(:) => null(), invperm(:) => null() integer, pointer :: perm(:) => null(), invperm(:) => null()
integer, pointer :: mlia(:) => null(), nlaggr(:) => null() integer, pointer :: mlia(:) => null(), nlaggr(:) => null() !
type(psb_dspmat_type), pointer :: aorig => null() type(psb_dspmat_type), pointer :: aorig => null() !
real(kind(1.d0)), pointer :: dorig(:) => null() real(kind(1.d0)), pointer :: dorig(:) => null() !
end type psb_dbase_prec end type psb_dbase_prec
@ -347,7 +347,6 @@ contains
endif endif
if (associated(p%dorig)) then if (associated(p%dorig)) then
deallocate(p%dorig,stat=info) deallocate(p%dorig,stat=info)
nullify(p%dorig)
endif endif
if (associated(p%mlia)) then if (associated(p%mlia)) then
@ -358,6 +357,14 @@ contains
deallocate(p%nlaggr,stat=info) deallocate(p%nlaggr,stat=info)
endif 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 (associated(p%iprcparm)) then
if (p%iprcparm(f_type_)==f_slu_) then if (p%iprcparm(f_type_)==f_slu_) then
call fort_slu_free(p%iprcparm(slu_ptr_),info) call fort_slu_free(p%iprcparm(slu_ptr_),info)

24
src/prec/psb_dcsrsetup.f90
Unescape Escape View File

@ -132,16 +132,6 @@ Subroutine psb_dcsrsetup(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
endif endif
call blacs_get(icontxt,10,icomm ) 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) Call blacs_gridinfo(icontxt,nprow,npcol,me,mycol)
If(debug)Write(0,*)'BEGIN dcsrsetup',me,upd,novr 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_) ! Build the auiliary descriptor',desc_p%matrix_data(psb_n_row_)
! !
call psb_dscov(a,desc_data,novr,desc_p,info) call psb_dscov(a,desc_data,novr,desc_p,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_dscov' ch_err='psb_dscov'
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
Endif Endif
if(debug) write(0,*) me,' From dscov _:',desc_p%matrix_data(psb_n_row_),desc_p%matrix_data(psb_n_col_) if(debug) write(0,*) me,' From dscov _:',desc_p%matrix_data(psb_n_row_),desc_p%matrix_data(psb_n_col_)

4
src/psblas/psb_dspmm.f90
Unescape Escape View File

@ -154,8 +154,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
! check for presence/size of a work area ! check for presence/size of a work area
liwork= 2*ncol liwork= 2*ncol
if (a%pr(1) /= 0) llwork = liwork + n * ik if (a%pr(1) /= 0) liwork = liwork + n * ik
if (a%pl(1) /= 0) llwork = llwork + m * ik if (a%pl(1) /= 0) liwork = liwork + m * ik
if (present(work)) then if (present(work)) then
if(size(work).lt.liwork) then if(size(work).lt.liwork) then
call psb_realloc(liwork,work,info) call psb_realloc(liwork,work,info)

15
src/tools/psb_descasb.f90
Unescape Escape View File

@ -72,18 +72,6 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,&
tch = 0.0 tch = 0.0
t4 = 0.0 t4 = 0.0
call blacs_get(icontxt,10,icomm ) 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_) mglob = desc_a%matrix_data(psb_m_)
m = desc_a%matrix_data(psb_n_row_) 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 tot_recv = 0
counter_h = 1 counter_h = 1
counter_o = 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. ! See comment in main loop below.
call InitPairSearchTree(info) 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" ) !!$ 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,'Checktmp_o_i 1',tmp_ovr_idx(1:10)
if (debug) write(0,*) myrow,'Calling Crea_Halo' 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_index(desc_p,t_halo_in,t_halo_out,.false.,info)
!!$ Call psi_crea_halo(desc_p%matrix_data,t_halo_in,& !!$ Call psi_crea_halo(desc_p%matrix_data,t_halo_in,&
!!$ & np,t_halo_out,Size(t_halo_out),dep_list,& !!$ & np,t_halo_out,Size(t_halo_out),dep_list,&

3
src/tools/psb_dscasb.f90
Unescape Escape View File

@ -169,7 +169,8 @@ subroutine psb_dscasb(desc_a,info)
! Ok, register into MATRIX_DATA & free temporary work areas ! Ok, register into MATRIX_DATA & free temporary work areas
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ 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 if (info /= 0) then
info =4000 info =4000
call psb_errpush(info,name) call psb_errpush(info,name)

2
src/tools/psb_dscov.f90
Unescape Escape View File

@ -179,7 +179,7 @@ Subroutine psb_dscov(a,desc_a,novr,desc_ov,info)
! The real work goes on in here.... ! The real work goes on in here....
! !
Call psb_descasb(novr,desc_ov,desc_a,a,& 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 if (info.ne.0) then
info=4010 info=4010
ch_err='psb_descasb' ch_err='psb_descasb'

Write Preview
Loading…
Cancel
Save