mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-20 04:42:08 +00:00
*** empty log message ***
This commit is contained in:
Salvatore Filippone
@@ -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
|
||||
@@ -391,24 +463,24 @@ 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
|
||||
|
||||
+155
-155
@@ -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
|
||||
!!$ 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
|
||||
!!$ 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
|
||||
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
|
||||
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
|
||||
!!$ 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
|
||||
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)
|
||||
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
|
||||
!!$ 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
|
||||
If (dim /= len) Then
|
||||
Allocate(tmp(len),stat=info)
|
||||
if (info /= 0) then
|
||||
err=4000
|
||||
call psb_errpush(err,name)
|
||||
goto 9999
|
||||
end if
|
||||
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
|
||||
!!$ 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
|
||||
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)
|
||||
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
|
||||
!!$ 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
|
||||
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
|
||||
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
|
||||
!!$ 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
|
||||
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
|
||||
!!$ write(0,*) 'IA: copying ',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
|
||||
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
|
||||
end if
|
||||
!!$ write(0,*) 'IA: copying ',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
|
||||
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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user