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
Salvatore Filippone 19 years ago
parent 432e910566
commit 564eb85765
3 changed files with 241 additions and 169 deletions
Show Stats Download Patch File Download Diff File

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

@ -103,6 +103,10 @@ module psb_prec_type
module procedure psb_file_prec_descr module procedure psb_file_prec_descr
end interface end interface
interface psb_prec_short_descr
module procedure psb_prec_short_descr
end interface
contains contains
subroutine psb_file_prec_descr(iout,p) subroutine psb_file_prec_descr(iout,p)
@ -172,6 +176,74 @@ contains
end subroutine psb_file_prec_descr end subroutine psb_file_prec_descr
function psb_prec_short_descr(p)
type(psb_dprec_type), intent(in) :: p
character(len=20) :: psb_prec_short_descr
psb_prec_short_descr = ' '
!!$ write(iout,*) 'Preconditioner description'
!!$ if (associated(p%baseprecv)) then
!!$ if (size(p%baseprecv)>=1) then
!!$ write(iout,*) 'Base preconditioner'
!!$ select case(p%baseprecv(1)%iprcparm(p_type_))
!!$ case(noprec_)
!!$ write(iout,*) 'No preconditioning'
!!$ case(diagsc_)
!!$ write(iout,*) 'Diagonal scaling'
!!$ case(bja_)
!!$ write(iout,*) 'Block Jacobi with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ case(asm_,ras_,ash_,rash_)
!!$ write(iout,*) 'Additive Schwarz with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ write(iout,*) 'Overlap:',&
!!$ & p%baseprecv(1)%iprcparm(n_ovr_)
!!$ write(iout,*) 'Restriction: ',&
!!$ & restrict_names(p%baseprecv(1)%iprcparm(restr_))
!!$ write(iout,*) 'Prolongation: ',&
!!$ & prolong_names(p%baseprecv(1)%iprcparm(prol_))
!!$ end select
!!$ end if
!!$ if (size(p%baseprecv)>=2) then
!!$ if (.not.associated(p%baseprecv(2)%iprcparm)) then
!!$ write(iout,*) 'Inconsistent MLPREC part!'
!!$ return
!!$ endif
!!$ write(iout,*) 'Multilevel: ',ml_names(p%baseprecv(2)%iprcparm(ml_type_))
!!$ if (p%baseprecv(2)%iprcparm(ml_type_)>no_ml_) then
!!$ write(iout,*) 'Multilevel aggregation: ', &
!!$ & aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
!!$ write(iout,*) 'Smoother: ', &
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
!!$ write(iout,*) 'Smoothing position: ',&
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
!!$ write(iout,*) 'Coarse matrix: ',&
!!$ & matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
!!$ write(iout,*) 'Factorization type: ',&
!!$ & fact_names(p%baseprecv(2)%iprcparm(f_type_))
!!$ select case(p%baseprecv(2)%iprcparm(f_type_))
!!$ case(f_ilu_n_)
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
!!$ case(f_ilu_e_)
!!$ write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
!!$ case(f_slu_,f_umf_)
!!$ case default
!!$ write(iout,*) 'Should never get here!'
!!$ end select
!!$ write(iout,*) 'Number of Jacobi sweeps: ', &
!!$ & (p%baseprecv(2)%iprcparm(jac_sweeps_))
!!$
!!$ end if
!!$ end if
!!$
!!$ else
!!$ write(iout,*) 'No Base preconditioner available, something is wrong!'
!!$ return
!!$ endif
end function psb_prec_short_descr
function is_legal_base_prec(ip) function is_legal_base_prec(ip)
integer, intent(in) :: ip integer, intent(in) :: ip
logical :: is_legal_base_prec logical :: is_legal_base_prec
@ -392,23 +464,23 @@ contains
integer, intent(in) :: iprec integer, intent(in) :: iprec
character(len=10) :: pr_to_str character(len=10) :: pr_to_str
select case(iprec) select case(iprec)
case(noprec_) case(noprec_)
pr_to_str='NOPREC' pr_to_str='NOPREC'
case(diagsc_) case(diagsc_)
pr_to_str='DIAGSC' pr_to_str='DIAGSC'
case(bja_) case(bja_)
pr_to_str='BJA' pr_to_str='BJA'
case(asm_) case(asm_)
pr_to_str='ASM' pr_to_str='ASM'
case(ash_) case(ash_)
pr_to_str='ASM' pr_to_str='ASM'
case(ras_) case(ras_)
pr_to_str='ASM' pr_to_str='ASM'
case(rash_) case(rash_)
pr_to_str='ASM' pr_to_str='ASM'
end select end select
end function pr_to_str end function pr_to_str
end module psb_prec_type end module psb_prec_type

298
src/modules/psb_realloc_mod.f90
Unescape Escape View File

@ -2,15 +2,15 @@ module psb_realloc_mod
implicit none implicit none
Interface psb_realloc Interface psb_realloc
module procedure psb_dreallocate1i module procedure psb_dreallocate1i
module procedure psb_dreallocate2i module procedure psb_dreallocate2i
module procedure psb_dreallocate2i1d module procedure psb_dreallocate2i1d
module procedure psb_dreallocate1d module procedure psb_dreallocate1d
module procedure psb_dreallocated2 module procedure psb_dreallocated2
end Interface end Interface
Interface psb_realloc1it Interface psb_realloc1it
module procedure psb_dreallocate1it module procedure psb_dreallocate1it
end Interface end Interface
Contains Contains
@ -32,45 +32,45 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax) dim=size(rrax)
If (dim /= len) Then If (dim /= len) Then
Allocate(tmp(len),stat=info) Allocate(tmp(len),stat=info)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
!!$ write(0,*) 'IA: copying ',len,dim !!$ write(0,*) 'IA: copying ',len,dim
if (.true.) then if (.true.) then
do i=1, min(len,dim) do i=1, min(len,dim)
tmp(i)=rrax(i) tmp(i)=rrax(i)
end do end do
else else
tmp(1:min(len,dim))=rrax(1:min(len,dim)) tmp(1:min(len,dim))=rrax(1:min(len,dim))
end if end if
!!$ write(0,*) 'IA: copying done' !!$ write(0,*) 'IA: copying done'
Deallocate(rrax,stat=info) Deallocate(rrax,stat=info)
if (info /= 0) then if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
rrax=>tmp
End If
else
!!$ write(0,*) 'IA: allocating ',len
allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
rrax=>tmp
End If
else
!!$ write(0,*) 'IA: allocating ',len
allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
endif endif
if (present(pad)) then if (present(pad)) then
!!$ write(0,*) 'IA: padding' !!$ write(0,*) 'IA: padding'
rrax(dim+1:len) = pad rrax(dim+1:len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -80,9 +80,9 @@ Contains
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error() call psb_error()
end if end if
return return
@ -111,44 +111,44 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax) dim=size(rrax)
If (dim /= len) Then If (dim /= len) Then
Allocate(tmp(len),stat=info) Allocate(tmp(len),stat=info)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
m = min(dim,len) m = min(dim,len)
!!$ write(0,*) 'DA: copying ',min(len,dim) !!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then if (.true.) then
do i=1,m do i=1,m
tmp(i) = rrax(i) tmp(i) = rrax(i)
end do end do
else else
tmp(1:m) = rrax(1:m) tmp(1:m) = rrax(1:m)
end if end if
!!$ write(0,*) 'DA: copying done ',m !!$ write(0,*) 'DA: copying done ',m
Deallocate(rrax,stat=info) Deallocate(rrax,stat=info)
if (info /= 0) then if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
rrax=>tmp
End If
else
dim = 0
Allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
rrax=>tmp
End If
else
dim = 0
Allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(dim+1:len) = pad rrax(dim+1:len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -157,9 +157,9 @@ Contains
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error() call psb_error()
end if end if
return return
@ -184,44 +184,44 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax,1) dim=size(rrax,1)
If (dim /= len1) Then If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info) Allocate(tmp(len1,len2),stat=info)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
m = min(dim,len1) m = min(dim,len1)
!!$ write(0,*) 'DA: copying ',min(len,dim) !!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then if (.true.) then
do i=1,m do i=1,m
tmp(i,:) = rrax(i,:) tmp(i,:) = rrax(i,:)
end do end do
else else
tmp(1:m,:) = rrax(1:m,:) tmp(1:m,:) = rrax(1:m,:)
end if end if
!!$ write(0,*) 'DA: copying done ',m !!$ write(0,*) 'DA: copying done ',m
Deallocate(rrax,stat=info) Deallocate(rrax,stat=info)
if (info /= 0) then if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
rrax=>tmp
End If
else
dim = 0
Allocate(rrax(len1,len2),stat=info)
if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
rrax=>tmp
End If
else
dim = 0
Allocate(rrax(len1,len2),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(dim+1:len1,:) = pad rrax(dim+1:len1,:) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -230,9 +230,9 @@ Contains
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error() call psb_error()
end if end if
return return
@ -254,18 +254,18 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
call psb_dreallocate1i(len,rrax,info,pad=pad) call psb_dreallocate1i(len,rrax,info,pad=pad)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
call psb_dreallocate1i(len,y,info,pad=pad) call psb_dreallocate1i(len,y,info,pad=pad)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -274,9 +274,9 @@ Contains
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error() call psb_error()
end if end if
return return
@ -302,21 +302,21 @@ Contains
info = 0 info = 0
call psb_dreallocate1i(len,rrax,info) call psb_dreallocate1i(len,rrax,info)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
call psb_dreallocate1i(len,y,info) call psb_dreallocate1i(len,y,info)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
call psb_dreallocate1d(len,z,info) call psb_dreallocate1d(len,z,info)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -325,9 +325,9 @@ Contains
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error() call psb_error()
end if end if
return return
End Subroutine psb_dreallocate2i1d End Subroutine psb_dreallocate2i1d
@ -349,38 +349,38 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax) dim=size(rrax)
If (dim /= len) Then If (dim /= len) Then
Allocate(tmp(len),stat=info) Allocate(tmp(len),stat=info)
if (info /= 0) then if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
!!$ write(0,*) 'IA: copying ',min(len,dim) !!$ write(0,*) 'IA: copying ',min(len,dim)
tmp(1:min(len,dim))=rrax(1:min(len,dim)) tmp(1:min(len,dim))=rrax(1:min(len,dim))
!!$ write(0,*) 'IA: copying done' !!$ write(0,*) 'IA: copying done'
Deallocate(rrax,stat=info) Deallocate(rrax,stat=info)
if (info /= 0) then if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
rrax=>tmp
End If
else
allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000 err=4000
call psb_errpush(err,name) call psb_errpush(err,name)
goto 9999 goto 9999
end if end if
rrax=>tmp
End If
else
allocate(rrax(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
endif endif
if (present(pad)) then if (present(pad)) then
!!$ write(0,*) 'IA: padding' !!$ write(0,*) 'IA: padding'
rrax(dim+1:len) = pad rrax(dim+1:len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -389,9 +389,9 @@ Contains
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error() call psb_error()
end if end if
return return

2
src/serial/psb_dneigh.f90
Unescape Escape View File

@ -16,7 +16,7 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev)
integer, pointer :: neigh(:) ! the neighbours integer, pointer :: neigh(:) ! the neighbours
integer, optional :: lev ! level of neighbours to find integer, optional :: lev ! level of neighbours to find
integer, pointer :: tmpn(:) integer, pointer :: tmpn(:)=>null()
integer :: level, dim, i, j, k, r, c, brow,& integer :: level, dim, i, j, k, r, c, brow,&
& elem_pt, ii, n1, col_idx, ne, err_act, nn, nidx & elem_pt, ii, n1, col_idx, ne, err_act, nn, nidx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

Write Preview
Loading…
Cancel
Save