From 564eb857651b8a87a9795865816b886ea7d4113a Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 7 Dec 2005 14:00:37 +0000 Subject: [PATCH] *** empty log message *** --- src/modules/psb_prec_type.f90 | 110 ++++++++++-- src/modules/psb_realloc_mod.f90 | 298 ++++++++++++++++---------------- src/serial/psb_dneigh.f90 | 2 +- 3 files changed, 241 insertions(+), 169 deletions(-) diff --git a/src/modules/psb_prec_type.f90 b/src/modules/psb_prec_type.f90 index d5356796..343ece66 100644 --- a/src/modules/psb_prec_type.f90 +++ b/src/modules/psb_prec_type.f90 @@ -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 diff --git a/src/modules/psb_realloc_mod.f90 b/src/modules/psb_realloc_mod.f90 index f9e14738..40c4498f 100644 --- a/src/modules/psb_realloc_mod.f90 +++ b/src/modules/psb_realloc_mod.f90 @@ -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 diff --git a/src/serial/psb_dneigh.f90 b/src/serial/psb_dneigh.f90 index ac0d13f6..f13d08bd 100644 --- a/src/serial/psb_dneigh.f90 +++ b/src/serial/psb_dneigh.f90 @@ -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