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
end interface
interface psb_prec_short_descr
module procedure psb_prec_short_descr
end interface
contains
subroutine psb_file_prec_descr(iout,p)
@ -172,6 +176,74 @@ contains
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)
integer, intent(in) :: ip
logical :: is_legal_base_prec
@ -392,23 +464,23 @@ contains
integer, intent(in) :: iprec
character(len=10) :: pr_to_str
select case(iprec)
case(noprec_)
pr_to_str='NOPREC'
case(diagsc_)
pr_to_str='DIAGSC'
case(bja_)
pr_to_str='BJA'
case(asm_)
pr_to_str='ASM'
case(ash_)
pr_to_str='ASM'
case(ras_)
pr_to_str='ASM'
case(rash_)
pr_to_str='ASM'
end select
end function pr_to_str
select case(iprec)
case(noprec_)
pr_to_str='NOPREC'
case(diagsc_)
pr_to_str='DIAGSC'
case(bja_)
pr_to_str='BJA'
case(asm_)
pr_to_str='ASM'
case(ash_)
pr_to_str='ASM'
case(ras_)
pr_to_str='ASM'
case(rash_)
pr_to_str='ASM'
end select
end function pr_to_str
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
Interface psb_realloc
module procedure psb_dreallocate1i
module procedure psb_dreallocate2i
module procedure psb_dreallocate2i1d
module procedure psb_dreallocate1d
module procedure psb_dreallocated2
module procedure psb_dreallocate1i
module procedure psb_dreallocate2i
module procedure psb_dreallocate2i1d
module procedure psb_dreallocate1d
module procedure psb_dreallocated2
end Interface
Interface psb_realloc1it
module procedure psb_dreallocate1it
module procedure psb_dreallocate1it
end Interface
Contains
@ -32,45 +32,45 @@ Contains
call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return
info=0
info=0
if (associated(rrax)) then
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
!!$ write(0,*) 'IA: copying ',len,dim
if (.true.) then
do i=1, min(len,dim)
tmp(i)=rrax(i)
end do
else
tmp(1:min(len,dim))=rrax(1:min(len,dim))
end if
if (.true.) then
do i=1, min(len,dim)
tmp(i)=rrax(i)
end do
else
tmp(1:min(len,dim))=rrax(1:min(len,dim))
end if
!!$ write(0,*) 'IA: copying done'
Deallocate(rrax,stat=info)
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
Deallocate(rrax,stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
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
if (present(pad)) then
!!$ write(0,*) 'IA: padding'
rrax(dim+1:len) = pad
rrax(dim+1:len) = pad
endif
call psb_erractionrestore(err_act)
@ -80,9 +80,9 @@ Contains
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error()
call psb_error()
end if
return
@ -111,44 +111,44 @@ Contains
call psb_erractionsave(err_act)
if (associated(rrax)) then
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
m = min(dim,len)
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
m = min(dim,len)
!!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then
do i=1,m
tmp(i) = rrax(i)
end do
else
tmp(1:m) = rrax(1:m)
end if
if (.true.) then
do i=1,m
tmp(i) = rrax(i)
end do
else
tmp(1:m) = rrax(1:m)
end if
!!$ write(0,*) 'DA: copying done ',m
Deallocate(rrax,stat=info)
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
Deallocate(rrax,stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
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
if (present(pad)) then
rrax(dim+1:len) = pad
rrax(dim+1:len) = pad
endif
call psb_erractionrestore(err_act)
return
@ -157,9 +157,9 @@ Contains
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error()
call psb_error()
end if
return
@ -184,44 +184,44 @@ Contains
call psb_erractionsave(err_act)
if (associated(rrax)) then
dim=size(rrax,1)
If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
m = min(dim,len1)
dim=size(rrax,1)
If (dim /= len1) Then
Allocate(tmp(len1,len2),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
m = min(dim,len1)
!!$ write(0,*) 'DA: copying ',min(len,dim)
if (.true.) then
do i=1,m
tmp(i,:) = rrax(i,:)
end do
else
tmp(1:m,:) = rrax(1:m,:)
end if
if (.true.) then
do i=1,m
tmp(i,:) = rrax(i,:)
end do
else
tmp(1:m,:) = rrax(1:m,:)
end if
!!$ write(0,*) 'DA: copying done ',m
Deallocate(rrax,stat=info)
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
Deallocate(rrax,stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
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
if (present(pad)) then
rrax(dim+1:len1,:) = pad
rrax(dim+1:len1,:) = pad
endif
call psb_erractionrestore(err_act)
return
@ -230,9 +230,9 @@ Contains
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error()
call psb_error()
end if
return
@ -254,18 +254,18 @@ Contains
call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return
info=0
info=0
call psb_dreallocate1i(len,rrax,info,pad=pad)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_dreallocate1i(len,y,info,pad=pad)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -274,9 +274,9 @@ Contains
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error()
call psb_error()
end if
return
@ -302,21 +302,21 @@ Contains
info = 0
call psb_dreallocate1i(len,rrax,info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_dreallocate1i(len,y,info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_dreallocate1d(len,z,info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
err=4000
call psb_errpush(err,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -325,9 +325,9 @@ Contains
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error()
call psb_error()
end if
return
End Subroutine psb_dreallocate2i1d
@ -349,38 +349,38 @@ Contains
call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return
info=0
info=0
if (associated(rrax)) then
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
!!$ 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'
Deallocate(rrax,stat=info)
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
Deallocate(rrax,stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
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
if (present(pad)) then
!!$ write(0,*) 'IA: padding'
rrax(dim+1:len) = pad
rrax(dim+1:len) = pad
endif
call psb_erractionrestore(err_act)
return
@ -389,9 +389,9 @@ Contains
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error()
call psb_error()
end if
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, optional :: lev ! level of neighbours to find
integer, pointer :: tmpn(:)
integer, pointer :: tmpn(:)=>null()
integer :: level, dim, i, j, k, r, c, brow,&
& elem_pt, ii, n1, col_idx, ne, err_act, nn, nidx
character(len=20) :: name, ch_err

Write Preview
Loading…
Cancel
Save