From 3b3a589c5699add44389b961061a0d0fd9b2b971 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 31 Mar 2014 13:31:56 +0000 Subject: [PATCH] mld2p4-2: mlprec/impl/mld_c_dec_map_bld.f90 mlprec/impl/mld_caggrmat_biz_asb.f90 mlprec/impl/mld_caggrmat_minnrg_asb.f90 mlprec/impl/mld_caggrmat_smth_asb.f90 mlprec/impl/mld_cmlprec_aply.f90 mlprec/impl/mld_d_dec_map_bld.f90 mlprec/impl/mld_daggrmat_biz_asb.f90 mlprec/impl/mld_daggrmat_minnrg_asb.f90 mlprec/impl/mld_daggrmat_smth_asb.f90 mlprec/impl/mld_dmlprec_aply.f90 mlprec/impl/mld_s_dec_map_bld.f90 mlprec/impl/mld_saggrmat_biz_asb.f90 mlprec/impl/mld_saggrmat_minnrg_asb.f90 mlprec/impl/mld_saggrmat_smth_asb.f90 mlprec/impl/mld_smlprec_aply.f90 mlprec/impl/mld_z_dec_map_bld.f90 mlprec/impl/mld_zaggrmat_biz_asb.f90 mlprec/impl/mld_zaggrmat_minnrg_asb.f90 mlprec/impl/mld_zaggrmat_smth_asb.f90 mlprec/impl/mld_zmlprec_aply.f90 mlprec/impl/smoother/mld_d_jac_smoother_bld.f90 mlprec/impl/solver/mld_c_diag_solver_bld.f90 mlprec/impl/solver/mld_d_diag_solver_bld.f90 mlprec/impl/solver/mld_s_diag_solver_bld.f90 mlprec/impl/solver/mld_z_diag_solver_bld.f90 New function form for get_diag. --- mlprec/impl/mld_c_dec_map_bld.f90 | 9 +------ mlprec/impl/mld_caggrmat_biz_asb.f90 | 12 +++------ mlprec/impl/mld_caggrmat_minnrg_asb.f90 | 6 +++-- mlprec/impl/mld_caggrmat_smth_asb.f90 | 11 +++----- mlprec/impl/mld_cmlprec_aply.f90 | 2 +- mlprec/impl/mld_d_dec_map_bld.f90 | 9 +------ mlprec/impl/mld_daggrmat_biz_asb.f90 | 12 +++------ mlprec/impl/mld_daggrmat_minnrg_asb.f90 | 6 +++-- mlprec/impl/mld_daggrmat_smth_asb.f90 | 11 +++----- mlprec/impl/mld_dmlprec_aply.f90 | 27 +++++++++----------- mlprec/impl/mld_s_dec_map_bld.f90 | 9 +------ mlprec/impl/mld_saggrmat_biz_asb.f90 | 12 +++------ mlprec/impl/mld_saggrmat_minnrg_asb.f90 | 6 +++-- mlprec/impl/mld_saggrmat_smth_asb.f90 | 11 +++----- mlprec/impl/mld_smlprec_aply.f90 | 2 +- mlprec/impl/mld_z_dec_map_bld.f90 | 9 +------ mlprec/impl/mld_zaggrmat_biz_asb.f90 | 12 +++------ mlprec/impl/mld_zaggrmat_minnrg_asb.f90 | 6 +++-- mlprec/impl/mld_zaggrmat_smth_asb.f90 | 11 +++----- mlprec/impl/mld_zmlprec_aply.f90 | 2 +- mlprec/impl/solver/mld_c_diag_solver_bld.f90 | 21 +++++---------- mlprec/impl/solver/mld_d_diag_solver_bld.f90 | 21 +++++---------- mlprec/impl/solver/mld_s_diag_solver_bld.f90 | 21 +++++---------- mlprec/impl/solver/mld_z_diag_solver_bld.f90 | 21 +++++---------- 24 files changed, 83 insertions(+), 186 deletions(-) diff --git a/mlprec/impl/mld_c_dec_map_bld.f90 b/mlprec/impl/mld_c_dec_map_bld.f90 index aa857c1e..17c36a27 100644 --- a/mlprec/impl/mld_c_dec_map_bld.f90 +++ b/mlprec/impl/mld_c_dec_map_bld.f90 @@ -83,14 +83,7 @@ subroutine mld_c_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if - allocate(diag(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nr,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - call a%get_diag(diag,info) + diag = a%get_diag(info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getdiag') diff --git a/mlprec/impl/mld_caggrmat_biz_asb.f90 b/mlprec/impl/mld_caggrmat_biz_asb.f90 index 9594486b..44790a4b 100644 --- a/mlprec/impl/mld_caggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_caggrmat_biz_asb.f90 @@ -144,16 +144,10 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_spk_)') - goto 9999 - end if - ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_caggrmat_minnrg_asb.f90 b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 index de1787e6..8365d522 100644 --- a/mlprec/impl/mld_caggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 @@ -178,7 +178,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),adinv(ncol),& + allocate(adinv(ncol),& & omf(ncol),omp(ntaggr),oden(ntaggr),omi(ncol),stat=info) if (info /= psb_success_) then @@ -188,7 +188,9 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_caggrmat_smth_asb.f90 b/mlprec/impl/mld_caggrmat_smth_asb.f90 index 7f187d51..143797c8 100644 --- a/mlprec/impl/mld_caggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.f90 @@ -158,16 +158,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_spk_)') - goto 9999 - end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index 9d4a8bce..b67b95fa 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -231,7 +231,7 @@ ! b. Call recursively itself passing ! r(ilev) for transfer to the next level ! (r(ilev) matches x(ilev-1) in step 1) - +! ! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! diff --git a/mlprec/impl/mld_d_dec_map_bld.f90 b/mlprec/impl/mld_d_dec_map_bld.f90 index 4dbbb8a8..19f93a31 100644 --- a/mlprec/impl/mld_d_dec_map_bld.f90 +++ b/mlprec/impl/mld_d_dec_map_bld.f90 @@ -83,14 +83,7 @@ subroutine mld_d_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if - allocate(diag(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nr,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - call a%get_diag(diag,info) + diag = a%get_diag(info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getdiag') diff --git a/mlprec/impl/mld_daggrmat_biz_asb.f90 b/mlprec/impl/mld_daggrmat_biz_asb.f90 index 39c3cb24..1f356d91 100644 --- a/mlprec/impl/mld_daggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_daggrmat_biz_asb.f90 @@ -144,16 +144,10 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='real(psb_dpk_)') - goto 9999 - end if - ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 index 77a0b3c3..29587b9d 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 @@ -178,7 +178,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),adinv(ncol),& + allocate(adinv(ncol),& & omf(ncol),omp(ntaggr),oden(ntaggr),omi(ncol),stat=info) if (info /= psb_success_) then @@ -188,7 +188,9 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_daggrmat_smth_asb.f90 b/mlprec/impl/mld_daggrmat_smth_asb.f90 index ddbe06ca..f5490d6f 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.f90 @@ -158,16 +158,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='real(psb_dpk_)') - goto 9999 - end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index bbbdb6b1..8228a299 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -231,7 +231,7 @@ ! b. Call recursively itself passing ! r(ilev) for transfer to the next level ! (r(ilev) matches x(ilev-1) in step 1) - +! ! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! @@ -1028,23 +1028,22 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) end if level = 1 do level = 1, nlev -!!$ write(0,*) me, 'Allocating MLPREC_WRK at level ',level call psb_geasb(mlprec_wrk(level)%vx2l,& & p%precv(level)%base_desc,info,& & scratch=.true.,mold=x%v) - if (info == 0) call psb_geasb(mlprec_wrk(level)%vy2l,& + call psb_geasb(mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc,info,& & scratch=.true.,mold=x%v) - if (info == 0) call psb_geasb(mlprec_wrk(level)%vtx,& + call psb_geasb(mlprec_wrk(level)%vtx,& & p%precv(level)%base_desc,info,& & scratch=.true.,mold=x%v) - if (info == 0) call psb_geasb(mlprec_wrk(level)%vty,& + call psb_geasb(mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info,& & scratch=.true.,mold=x%v) - if ((info/=0).or.psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then nc2l = p%precv(level)%base_desc%get_local_cols() info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/4*nc2l,izero,izero,izero,izero/),& + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& & a_err='real(psb_dpk_)') goto 9999 end if @@ -1066,12 +1065,11 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& & p%precv(level)%base_desc,info) do level = 1, nlev -!!$ write(0,*) me, 'Freeing MLPREC_WRK at level ',level - if (info == 0) call mlprec_wrk(level)%vx2l%free(info) - if (info == 0) call mlprec_wrk(level)%vy2l%free(info) - if (info == 0) call mlprec_wrk(level)%vtx%free(info) - if (info == 0) call mlprec_wrk(level)%vty%free(info) - if ((info /= 0).or.psb_errstatus_fatal()) then + call mlprec_wrk(level)%vx2l%free(info) + call mlprec_wrk(level)%vy2l%free(info) + call mlprec_wrk(level)%vtx%free(info) + call mlprec_wrk(level)%vty%free(info) + if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ nc2l = p%precv(level)%base_desc%get_local_cols() call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& @@ -1216,7 +1214,6 @@ contains select case (trans_) case('N') -!!$ write(0,*) me,' Applying POST at level ',level if (level > 1) then ! Apply the restriction call psb_map_X2Y(done,mlprec_wrk(level-1)%vx2l,& @@ -1289,7 +1286,7 @@ contains end if end if -!!$ write(0,*) me,' Done POST at level ',level + case('T','C') ! Post-smoothing transpose is pre-smoothing diff --git a/mlprec/impl/mld_s_dec_map_bld.f90 b/mlprec/impl/mld_s_dec_map_bld.f90 index 0b6e0841..44a228f9 100644 --- a/mlprec/impl/mld_s_dec_map_bld.f90 +++ b/mlprec/impl/mld_s_dec_map_bld.f90 @@ -83,14 +83,7 @@ subroutine mld_s_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if - allocate(diag(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nr,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - call a%get_diag(diag,info) + diag = a%get_diag(info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getdiag') diff --git a/mlprec/impl/mld_saggrmat_biz_asb.f90 b/mlprec/impl/mld_saggrmat_biz_asb.f90 index 539bf04f..53d22ffa 100644 --- a/mlprec/impl/mld_saggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_saggrmat_biz_asb.f90 @@ -144,16 +144,10 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='real(psb_spk_)') - goto 9999 - end if - ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_saggrmat_minnrg_asb.f90 b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 index bd49ce9d..b9bf78f1 100644 --- a/mlprec/impl/mld_saggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 @@ -178,7 +178,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),adinv(ncol),& + allocate(adinv(ncol),& & omf(ncol),omp(ntaggr),oden(ntaggr),omi(ncol),stat=info) if (info /= psb_success_) then @@ -188,7 +188,9 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_saggrmat_smth_asb.f90 b/mlprec/impl/mld_saggrmat_smth_asb.f90 index de795b8f..af71ad21 100644 --- a/mlprec/impl/mld_saggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.f90 @@ -158,16 +158,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='real(psb_spk_)') - goto 9999 - end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 1be38732..50e2df3d 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -231,7 +231,7 @@ ! b. Call recursively itself passing ! r(ilev) for transfer to the next level ! (r(ilev) matches x(ilev-1) in step 1) - +! ! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! diff --git a/mlprec/impl/mld_z_dec_map_bld.f90 b/mlprec/impl/mld_z_dec_map_bld.f90 index c094c3a2..09faee11 100644 --- a/mlprec/impl/mld_z_dec_map_bld.f90 +++ b/mlprec/impl/mld_z_dec_map_bld.f90 @@ -83,14 +83,7 @@ subroutine mld_z_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if - allocate(diag(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nr,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - call a%get_diag(diag,info) + diag = a%get_diag(info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getdiag') diff --git a/mlprec/impl/mld_zaggrmat_biz_asb.f90 b/mlprec/impl/mld_zaggrmat_biz_asb.f90 index e1ccd616..9a276920 100644 --- a/mlprec/impl/mld_zaggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_biz_asb.f90 @@ -144,16 +144,10 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_dpk_)') - goto 9999 - end if - ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 index ad86d726..752fe67e 100644 --- a/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 @@ -178,7 +178,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),adinv(ncol),& + allocate(adinv(ncol),& & omf(ncol),omp(ntaggr),oden(ntaggr),omi(ncol),stat=info) if (info /= psb_success_) then @@ -188,7 +188,9 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.f90 b/mlprec/impl/mld_zaggrmat_smth_asb.f90 index 2247597f..368b49ea 100644 --- a/mlprec/impl/mld_zaggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.f90 @@ -158,16 +158,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest ! naggr: number of local aggregates ! nrow: local rows. ! - allocate(adiag(ncol),stat=info) - - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=nrow; - call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_dpk_)') - goto 9999 - end if ! Get the diagonal D - call a%get_diag(adiag,info) + adiag = a%get_diag(info) + if (info == psb_success_) & + & call psb_realloc(ncol,adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index 1930e8e1..941fdf13 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -231,7 +231,7 @@ ! b. Call recursively itself passing ! r(ilev) for transfer to the next level ! (r(ilev) matches x(ilev-1) in step 1) - +! ! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! diff --git a/mlprec/impl/solver/mld_c_diag_solver_bld.f90 b/mlprec/impl/solver/mld_c_diag_solver_bld.f90 index 0ad16a00..25c844d9 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_bld.f90 @@ -56,6 +56,7 @@ subroutine mld_c_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: tdb(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='c_diag_solver_bld', ch_err @@ -71,23 +72,13 @@ subroutine mld_c_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() - if (allocated(sv%d)) then - if (size(sv%d) < n_row) then - deallocate(sv%d) - endif - endif - if (.not.allocated(sv%d)) then - allocate(sv%d(n_row),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - call a%get_diag(sv%d,info) + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then - if (info == psb_success_) call b%get_diag(sv%d(nrow_a+1:), info) + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') diff --git a/mlprec/impl/solver/mld_d_diag_solver_bld.f90 b/mlprec/impl/solver/mld_d_diag_solver_bld.f90 index cf7ef28c..b45deed9 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_bld.f90 @@ -56,6 +56,7 @@ subroutine mld_d_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: tdb(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='d_diag_solver_bld', ch_err @@ -71,23 +72,13 @@ subroutine mld_d_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() - if (allocated(sv%d)) then - if (size(sv%d) < n_row) then - deallocate(sv%d) - endif - endif - if (.not.allocated(sv%d)) then - allocate(sv%d(n_row),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - call a%get_diag(sv%d,info) + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then - if (info == psb_success_) call b%get_diag(sv%d(nrow_a+1:), info) + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') diff --git a/mlprec/impl/solver/mld_s_diag_solver_bld.f90 b/mlprec/impl/solver/mld_s_diag_solver_bld.f90 index b3ab0c4d..9ef1c6db 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_bld.f90 @@ -56,6 +56,7 @@ subroutine mld_s_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: tdb(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='s_diag_solver_bld', ch_err @@ -71,23 +72,13 @@ subroutine mld_s_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() - if (allocated(sv%d)) then - if (size(sv%d) < n_row) then - deallocate(sv%d) - endif - endif - if (.not.allocated(sv%d)) then - allocate(sv%d(n_row),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - call a%get_diag(sv%d,info) + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then - if (info == psb_success_) call b%get_diag(sv%d(nrow_a+1:), info) + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') diff --git a/mlprec/impl/solver/mld_z_diag_solver_bld.f90 b/mlprec/impl/solver/mld_z_diag_solver_bld.f90 index 70099cf9..9cf8bb68 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_bld.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_bld.f90 @@ -56,6 +56,7 @@ subroutine mld_z_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: tdb(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level character(len=20) :: name='z_diag_solver_bld', ch_err @@ -71,23 +72,13 @@ subroutine mld_z_diag_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) n_row = desc_a%get_local_rows() nrow_a = a%get_nrows() - if (allocated(sv%d)) then - if (size(sv%d) < n_row) then - deallocate(sv%d) - endif - endif - if (.not.allocated(sv%d)) then - allocate(sv%d(n_row),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - call a%get_diag(sv%d,info) + sv%d = a%get_diag(info) + if (info == psb_success_) call psb_realloc(n_row,sv%d,info) if (present(b)) then - if (info == psb_success_) call b%get_diag(sv%d(nrow_a+1:), info) + tdb=b%get_diag(info) + if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info) + if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) end if if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag')