From bdf13ac3d1d6c9c4270a8e015e342a5c4493566c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 21 Feb 2007 20:53:40 +0000 Subject: [PATCH] Fixes for complex halo gather. --- psb_dasmatbld.f90 | 9 +--- psb_dbjac_bld.f90 | 16 +++++-- psb_dilu_fct.f90 | 4 +- psb_zasmatbld.f90 | 15 +++---- psb_zbjac_bld.f90 | 105 ++++++++++++++++++++++++---------------------- psb_zilu_fct.f90 | 8 +--- 6 files changed, 81 insertions(+), 76 deletions(-) diff --git a/psb_dasmatbld.f90 b/psb_dasmatbld.f90 index 6c469abf..95f4e0ef 100644 --- a/psb_dasmatbld.f90 +++ b/psb_dasmatbld.f90 @@ -191,14 +191,8 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) n_row = desc_p%matrix_data(psb_n_row_) t2 = psb_wtime() -!!$ open(60+me) -!!$ call psb_cdprt(60+me,desc_p,short=.false.) -!!$ close(60+me) -!!$ call psb_barrier(ictxt) + if (debug) write(0,*) 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_) -!!$ ierr = MPE_Log_event( iovrb, 0, "st OVR" ) -!!$ blk%m = n_row-nrow_a -!!$ blk%k = n_row if (present(outfmt)) then if(debug) write(0,*) me,': Calling outfmt SPHALO with ',size(blk%ia2) @@ -217,7 +211,6 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) end if if (debug) write(0,*) 'After psb_sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_) -!!$ ierr = MPE_Log_event( iovre, 0, "ed OVR" ) t3 = psb_wtime() if (debugprt) then diff --git a/psb_dbjac_bld.f90 b/psb_dbjac_bld.f90 index b631b90a..0392caac 100644 --- a/psb_dbjac_bld.f90 +++ b/psb_dbjac_bld.f90 @@ -68,7 +68,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info) character :: trans, unitd type(psb_dspmat_type) :: blck, atmp real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6, t7, t8 - logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false. + logical, parameter :: debugprt=.true., debug=.false., aggr_dump=.false. integer nztota, nztotb, nztmp, nzl, nnr, ir, err_act,& & n_row, nrow_a,n_col, nhalo, ind, iind, i1,i2,ia integer :: ictxt,np,me @@ -198,7 +198,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info) case(f_umf_) - call psb_ipcoo2csc(atmp,info) + call psb_ipcoo2csc(atmp,info,clshr=.true.) if (info /= 0) then call psb_errpush(4010,name,a_err='psb_ipcoo2csc') goto 9999 @@ -240,6 +240,16 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info) case(f_ilu_n_,f_ilu_e_) + if (debugprt) then + call psb_barrier(ictxt) + open(40+me) + call psb_csprt(40+me,a,head='% Local matrix') + close(40+me) + open(60+me) + call psb_csprt(60+me,blck,head='% Halo matrix') + close(60+me) + endif + call psb_ipcoo2csr(blck,info,rwshr=.true.) if(info/=0) then @@ -302,7 +312,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info) goto 9999 end if call psb_rwextd(atmp%m+blck%m,atmp,info,blck,rowscale=.true.) - if (info == 0) call psb_ipcoo2csc(atmp,info) + if (info == 0) call psb_ipcoo2csc(atmp,info,clshr=.true.) if (info /= 0) then call psb_errpush(4010,name,a_err='psb_ipcoo2csc') goto 9999 diff --git a/psb_dilu_fct.f90 b/psb_dilu_fct.f90 index 1228d54e..bb25b0f2 100644 --- a/psb_dilu_fct.f90 +++ b/psb_dilu_fct.f90 @@ -179,7 +179,7 @@ contains ! use spgtblk, slower but able (in principle) to handle ! anything. ! - if (a%fida=='CSR') then + if (toupper(a%fida)=='CSR') then do j = a%ia2(i), a%ia2(i+1) - 1 k = a%ia1(j) ! write(0,*)'KKKKK',k @@ -318,7 +318,7 @@ contains d(i) = 0.d0 - if (b%fida=='CSR') then + if (toupper(b%fida)=='CSR') then do j = b%ia2(i-ma), b%ia2(i-ma+1) - 1 k = b%ia1(j) diff --git a/psb_zasmatbld.f90 b/psb_zasmatbld.f90 index f112be2c..f1e46a62 100644 --- a/psb_zasmatbld.f90 +++ b/psb_zasmatbld.f90 @@ -86,6 +86,8 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) If(debug) Write(0,*)'IN DASMATBLD ', upd ictxt=desc_data%matrix_data(psb_ctxt_) + Call psb_info(ictxt, me, np) + tot_recv=0 nrow_a = desc_data%matrix_data(psb_n_row_) @@ -129,7 +131,6 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) ! ! - ictxt=desc_data%matrix_data(psb_ctxt_) if (novr < 0) then info=3 @@ -138,7 +139,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) goto 9999 endif - if (novr == 0) then + if ((novr == 0).or.(np==1)) then ! ! This is really just Block Jacobi..... ! @@ -169,7 +170,6 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) call psb_get_mpicomm(ictxt,icomm) - Call psb_info(ictxt, me, np) If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr t1 = psb_wtime() @@ -186,7 +186,8 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) end if Endif - if(debug) write(0,*) me,' From bldext:',desc_p%matrix_data(psb_n_row_),desc_p%matrix_data(psb_n_col_) + if(debug) write(0,*) me,' From cdbldext _:',desc_p%matrix_data(psb_n_row_),& + & desc_p%matrix_data(psb_n_col_) n_row = desc_p%matrix_data(psb_n_row_) @@ -195,11 +196,11 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt) if (debug) write(0,*) 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_) if (present(outfmt)) then - if(debug) write(0,*) me,': Calling SPHALO with ',size(blk%ia2) - Call psb_sphalo(a,desc_p,blk,info,outfmt=outfmt) + if(debug) write(0,*) me,': Calling outfmt SPHALO with ',size(blk%ia2) + Call psb_sphalo(a,desc_p,blk,info,outfmt=outfmt,data=psb_comm_ext_) else if(debug) write(0,*) me,': Calling SPHALO with ',size(blk%ia2) - Call psb_sphalo(a,desc_p,blk,info) + Call psb_sphalo(a,desc_p,blk,info,data=psb_comm_ext_) end if diff --git a/psb_zbjac_bld.f90 b/psb_zbjac_bld.f90 index fa572dd0..ffc9884e 100644 --- a/psb_zbjac_bld.f90 +++ b/psb_zbjac_bld.f90 @@ -78,7 +78,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) if(psb_get_errstatus().ne.0) return info=0 - name='psb_bjac_bld' + name='psb_zbjac_bld' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -113,9 +113,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) & blck,desc_a,upd,p%desc_data,info,outfmt=coofmt) if(info/=0) then - info=4010 - ch_err='psb_asmatbld' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(4010,name,a_err='psb_asmatbld') goto 9999 end if @@ -124,7 +122,9 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) if (debug) call psb_barrier(ictxt) - if (p%iprcparm(iren_) > 0) then + select case(p%iprcparm(iren_)) + + case (1:) ! ! Here we allocate a full copy to hold local A and received BLK @@ -133,10 +133,8 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) call psb_sp_renum(a,desc_a,blck,p,atmp,info) - if(info/=0) then - info=4010 - ch_err='psb_sp_renum' - call psb_errpush(info,name,a_err=ch_err) + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_sp_renum') goto 9999 end if @@ -155,20 +153,20 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) case(f_ilu_n_,f_ilu_e_) call psb_ipcoo2csr(atmp,info) + if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_ipcoo2csr') + call psb_errpush(4010,name,a_err='psb_ipcoo2csr') goto 9999 end if call psb_ilu_bld(atmp,p%desc_data,p,upd,info) - if(info/=0) then - info=4010 - call psb_errpush(info,name,a_err='psb_ilu_bld') + if (info/=0) then + call psb_errpush(4010,name,a_err='psb_ilu_bld') goto 9999 end if + if (debugprt) then open(80+me) @@ -188,15 +186,13 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) call psb_ipcoo2csr(atmp,info) if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_ipcoo2csr') + call psb_errpush(4010,name,a_err='psb_ipcoo2csr') goto 9999 end if call psb_slu_bld(atmp,p%desc_data,p,info) if(info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='slu_bld') + call psb_errpush(4010,name,a_err='slu_bld') goto 9999 end if @@ -204,16 +200,14 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) call psb_ipcoo2csc(atmp,info) if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_ipcoo2csc') + call psb_errpush(4010,name,a_err='psb_ipcoo2csc') goto 9999 end if call psb_umf_bld(atmp,p%desc_data,p,info) if(debug) write(0,*)me,': Done umf_bld ',info if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err='umf_bld') + call psb_errpush(4010,name,a_err='umf_bld') goto 9999 end if @@ -231,14 +225,15 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) call psb_sp_free(atmp,info) + if(info/=0) then - info=4010 - call psb_errpush(info,name,a_err='psb_sp_free') + call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if - else if (p%iprcparm(iren_) == 0) then + + case(0) ! No renumbering select case(p%iprcparm(f_type_)) @@ -247,14 +242,19 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) call psb_ipcoo2csr(blck,info,rwshr=.true.) - if (info==0) call psb_ilu_bld(a,desc_a,p,upd,info,blck=blck) + if(info/=0) then + call psb_errpush(4010,name,a_err='psb_ipcoo2csr') + goto 9999 + end if + + call psb_ilu_bld(a,desc_a,p,upd,info,blck=blck) if(info/=0) then - info=4010 - call psb_errpush(info,name,a_err='psb_ilu_bld') + call psb_errpush(4010,name,a_err='psb_ilu_bld') goto 9999 end if + if (debugprt) then open(80+me) @@ -270,63 +270,65 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) endif - case(f_slu_) atmp%fida='COO' call psb_csdp(a,atmp,info) if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_csdp') + call psb_errpush(4010,name,a_err='psb_csdp') goto 9999 end if call psb_rwextd(atmp%m+blck%m,atmp,info,blck,rowscale=.true.) - call psb_ipcoo2csr(atmp,info) - call psb_slu_bld(atmp,p%desc_data,p,info) + if (info == 0) call psb_ipcoo2csr(atmp,info) + if (info == 0) call psb_slu_bld(atmp,p%desc_data,p,info) if(info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='slu_bld') + call psb_errpush(4010,name,a_err='slu_bld') goto 9999 end if call psb_sp_free(atmp,info) if(info/=0) then - info=4010 - call psb_errpush(info,name,a_err='psb_sp_free') + call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if case(f_umf_) - atmp%fida='COO' atmp%fida='COO' call psb_csdp(a,atmp,info) if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_csdp') + call psb_errpush(4010,name,a_err='psb_csdp') goto 9999 end if + if (debugprt) then + call psb_barrier(ictxt) + open(40+me) + call psb_csprt(40+me,atmp,head='% Local matrix') + close(40+me) + open(60+me) + call psb_csprt(60+me,blck,head='% Halo matrix') + close(60+me) + endif + call psb_rwextd(atmp%m+blck%m,atmp,info,blck,rowscale=.true.) if (info == 0) call psb_ipcoo2csc(atmp,info) + if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_ipcoo2csc') + call psb_errpush(4010,name,a_err='psb_ipcoo2csc') goto 9999 end if call psb_umf_bld(atmp,p%desc_data,p,info) if(debug) write(0,*)me,': Done umf_bld ',info if (info /= 0) then - info = 4010 - call psb_errpush(info,name,a_err='umf_bld') + call psb_errpush(4010,name,a_err='umf_bld') goto 9999 end if call psb_sp_free(atmp,info) if(info/=0) then - info=4010 - call psb_errpush(info,name,a_err='psb_sp_free') + call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if @@ -342,22 +344,25 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info) goto 9999 end select + case default + info=4010 + call psb_errpush(info,name,a_err='Invalid renum_') + goto 9999 - endif + end select t6 = psb_wtime() call psb_sp_free(blck,info) if(info/=0) then - info=4010 - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) + call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if if (debug) write(0,*) me,'End of ilu_bld' call psb_erractionrestore(err_act) + return 9999 continue diff --git a/psb_zilu_fct.f90 b/psb_zilu_fct.f90 index a3a7f236..49ced412 100644 --- a/psb_zilu_fct.f90 +++ b/psb_zilu_fct.f90 @@ -175,7 +175,7 @@ contains ! use spgtblk, slower but able (in principle) to handle ! anything. ! - if (a%fida=='CSR') then + if (toupper(a%fida)=='CSR') then do j = a%ia2(i), a%ia2(i+1) - 1 k = a%ia1(j) ! write(0,*)'KKKKK',k @@ -314,22 +314,19 @@ contains d(i) = zzero - if (b%fida=='CSR') then + if (toupper(b%fida)=='CSR') then do j = b%ia2(i-ma), b%ia2(i-ma+1) - 1 k = b%ia1(j) - ! if (me.eq.2) write(0,*)'ecco k=',k if ((k < i).and.(k >= 1)) then l1 = l1 + 1 laspk(l1) = b%aspk(j) lia1(l1) = k - ! if(me.eq.2) write(0,*)'scrivo l' else if (k == i) then d(i) = b%aspk(j) else if ((k > i).and.(k <= m)) then l2 = l2 + 1 uaspk(l2) = b%aspk(j) - ! write(0,*)'KKKKK',k uia1(l2) = k end if enddo @@ -352,7 +349,6 @@ contains if (ktrw > trw%infoa(psb_nnz_)) exit if (trw%ia1(ktrw) > i) exit k = trw%ia2(ktrw) - ! write(0,*)'KKKKK',k if ((k < i).and.(k >= 1)) then l1 = l1 + 1 laspk(l1) = trw%aspk(ktrw)