mld2p4-2:

mlprec/mld_daggrmat_minnrg_asb.F90

Fixed minenergy. To be replicated to other versions. 
TBD: cleanup, "style" uniformity of aggrmat_asb routines.
stopcriterion
Salvatore Filippone 13 years ago
parent 10961f823f
commit aa674f69ef

@ -94,6 +94,8 @@ mld_prec_mod.o: mld_prec_type.o mld_s_prec_mod.o mld_d_prec_mod.o mld_c_prec_mod
$(MODOBJS): $(PSBINCDIR)/psb_base_mod$(.mod) $(MODOBJS): $(PSBINCDIR)/psb_base_mod$(.mod)
mld_base_prec_type.o: mld_const.h
$(SINNEROBJS) $(SOUTEROBJS): $(SMODOBJS) $(SINNEROBJS) $(SOUTEROBJS): $(SMODOBJS)
$(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS) $(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS)
$(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS) $(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS)

@ -224,13 +224,11 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call acoo%set_asb() call acoo%set_asb()
call ptilde%mv_from(acoo) call ptilde%mv_from(acoo)
call ptilde%cscnv(info,type='csr') call ptilde%cscnv(info,type='csr')
call a%clone(am3,info)
call am3%cscnv(info,type='csr')
call a%clone(da,info)
call da%cscnv(info,type='csr')
!!$ if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
!!$ if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999 goto 9999
@ -260,8 +258,8 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_numbmm(da,atmp,dadap) call psb_numbmm(da,atmp,dadap)
call atmp%free() call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap)
call dap%mv_to(csc_dap) call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap) call dadap%mv_to(csc_dadap)
@ -270,15 +268,16 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp) call psb_sum(ictxt,omp)
call psb_sum(ictxt,oden) call psb_sum(ictxt,oden)
! !$ write(0,*) trim(name),' OMP :',omp ! !$ write(0,*) trim(name),' OMP :',omp
! !$ write(0,*) trim(name),' ODEN:',oden ! !$ write(0,*) trim(name),' ODEN:',oden
omp = omp/oden omp = omp/oden
! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10))
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done NUMBMM 1'
call am3%mv_to(acsr3) call am3%mv_to(acsr3)
! Compute omega_int ! Compute omega_int
ommx = -1d300 ommx = -1d300
@ -330,7 +329,6 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
tmpcoo%ja(k) = tmpcoo%ja(j) tmpcoo%ja(k) = tmpcoo%ja(j)
end if end if
end do end do
! !$ write(debug_unit,*) me,' ',trim(name),' Non zeros from filtered matrix:',k,acsrf%m,acsrf%k
call tmpcoo%set_nzeros(k) call tmpcoo%set_nzeros(k)
call acsrf%mv_from_coo(tmpcoo,info) call acsrf%mv_from_coo(tmpcoo,info)
@ -350,6 +348,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1' & 'Done gather, going for SYMBMM 1'
call af%mv_from(acsrf) call af%mv_from(acsrf)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
@ -373,22 +372,22 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Build the smoothed prolongator using the original matrix ! Build the smoothed prolongator using the original matrix
! !
do i=1,acsr3%get_nrows() do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1 do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then if (acsr3%ja(j) == i) then
acsr3%val(j) = done - omf(i)*acsr3%val(j) acsr3%val(j) = done - omf(i)*acsr3%val(j)
else else
acsr3%val(j) = - omf(i)*acsr3%val(j) acsr3%val(j) = - omf(i)*acsr3%val(j)
end if end if
end do
end do end do
end do
call am3%mv_from(acsr3) call am3%mv_from(acsr3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1' & 'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*A)Ptilde ! am1 = (I-w*D*A)Ptilde
! !
@ -408,20 +407,11 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
! !
! Ok, let's start over with the restrictor ! Ok, let's start over with the restrictor
! !
if (.false.) then call ptilde%transp(rtilde)
call ptilde%transp(rtilde)
else
call ptilde%clone(rtilde,info)
call rtilde%transp()
end if
call a%cscnv(atmp,info,type='csr') call a%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,& call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.) & colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows() nrt = am4%get_nrows()
@ -430,6 +420,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free() call am4%free()
call atmp2%free() call atmp2%free()
! This is to compute the transpose. It ONLY works if the ! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern. ! original A has a symmetric pattern.
call atmp%transp(atmp2) call atmp%transp(atmp2)
@ -461,10 +452,10 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_sum(ictxt,oden) call psb_sum(ictxt,oden)
! !$ write(debug_unit,*) trim(name),' OMP_R :',omp ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp
! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden
omp = omp/oden omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int ! Compute omega_int
ommx = -1d300 ommx = -1d300
do i=1, ncol do i=1, ncol
@ -560,7 +551,8 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,am1,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,am1,am3)
@ -574,42 +566,62 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Extend am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(am2,am3,b,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(am2,am3,b)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
call b%mv_to(bcoo)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build b = am2 x am3')
goto 9999 goto 9999
end if end if
call b%mv_to(bcoo)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done mv_to_coo'
select case(p%parms%coarse_mat) select case(p%parms%coarse_mat)
case(mld_distr_mat_) case(mld_distr_mat_)
nzl = bcoo%get_nrows() nzl = bcoo%get_nzeros()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' B matrix nzl: ',nzl
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info) if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Creating p%desc_ac and converting ac') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.' & ' Assembld aux descr. distr.'
call bcoo%set_nrows(p%desc_ac%get_local_rows()) call bcoo%set_nrows(p%desc_ac%get_local_rows())
call bcoo%set_ncols(p%desc_ac%get_local_cols()) call bcoo%set_ncols(p%desc_ac%get_local_cols())
call bcoo%fix(info)
call p%ac%mv_from(bcoo) call p%ac%mv_from(bcoo)
call p%ac%set_asb() call p%ac%set_asb()
call p%ac%cscnv(info,type='csr') call p%ac%cscnv(info,type='csr')
if (np>1) then if (np>1) then
@ -813,4 +825,17 @@ contains
end function sparse_srtd_dot end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header)
type(psb_dspmat_type), intent(in) :: mat
integer, intent(in) :: me
character(len=*), intent(in) :: name
character(len=*), intent(in) :: header
character(len=80) :: filename
write(filename,'(a,a,i0,a,i0,a)') trim(name),'.p',me
open(20+me,file=filename)
call mat%print(20+me,head=trim(header))
close(20+me)
end subroutine local_dump
end subroutine mld_daggrmat_minnrg_asb end subroutine mld_daggrmat_minnrg_asb

Loading…
Cancel
Save