diff --git a/Make.inc b/Make.inc index ae5835bd..3ed867b0 100644 --- a/Make.inc +++ b/Make.inc @@ -9,9 +9,9 @@ F90=ifort FC=ifort CC=icc F77=$(FC) -F90COPT=-g -CB -no_cpprt -FCOPT=-g -CB -no_cpprt -CCOPT=-g -CB -no_cpprt +F90COPT= -check arg_temp_created +FCOPT=-check arg_temp_created +CCOPT= ####################### Section 2 ####################### # Define your linker and linker flags here # @@ -64,15 +64,15 @@ MODS=$(LIBDIR)/psb_tools_const$(.mod) $(LIBDIR)/psb_spmat_type$(.mod) $(LIBDIR)/ $(.mod).o: .f.o: - $(FC) $(FCOPT) -I $(INCDIRS) -c $< + $(FC) $(FCOPT) $(INCDIRS) -c $< .c.o: - $(CC) $(CCOPT) -I $(INCDIRS) $(CDEFINES) -c $< + $(CC) $(CCOPT) $(INCDIRS) $(CDEFINES) -c $< .f$(.mod): - $(F90) $(FCOPT) -I $(INCDIRS) -c $< + $(F90) $(FCOPT) $(INCDIRS) -c $< .f90$(.mod): - $(F90) $(F90COPT) -I $(INCDIRS) -c $< + $(F90) $(F90COPT) $(INCDIRS) -c $< .f90.o: - $(F90) $(F90COPT) -I $(INCDIRS) -c $< + $(F90) $(F90COPT) $(INCDIRS) -c $< diff --git a/Makefile b/Makefile index cea20e2f..c176825f 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,12 @@ include Make.inc -lib: +library: ( [ -d lib ] || mkdir lib) (cd src; make lib) + clean: (cd src; make clean) + veryclean: (cd src; make veryclean) (cd lib; /bin/rm -f *.a *$(.mod) V*.inc *.pc *.pcl) diff --git a/src/comm/Makefile b/src/comm/Makefile index 5d87db27..4781eaf1 100644 --- a/src/comm/Makefile +++ b/src/comm/Makefile @@ -4,7 +4,7 @@ OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ psb_ihalo.o MPFOBJS = psb_dscatter.o -INCDIRS = ../../lib +INCDIRS = -I ../../lib -I . lib: mpfobjs $(OBJS) diff --git a/src/internals/Makefile b/src/internals/Makefile index 360d77b5..c7716ea7 100644 --- a/src/internals/Makefile +++ b/src/internals/Makefile @@ -8,7 +8,7 @@ COBJS = avltree.o MPFOBJS = psi_dswapdata.o psi_dswaptran.o psi_iswapdata.o \ psi_iswaptran.o psi_extrct_dl.o psi_desc_index.o -INCDIRS = ../../lib . +INCDIRS = -I ../../lib -I . lib: mpfobjs $(FOBJS) $(COBJS) diff --git a/src/internals/psi_extrct_dl.f b/src/internals/psi_extrct_dl.f index ece5fdfa..85e18676 100644 --- a/src/internals/psi_extrct_dl.f +++ b/src/internals/psi_extrct_dl.f @@ -229,9 +229,9 @@ c$$$ + i, i, -ione ,-ione,-ione) else - if (me.eq.root) then + if (me.eq.psb_root_) then do proc=0,np-1 - if (proc.ne.root) then + if (proc.ne.psb_root_) then if (debug) write(0,*) 'receiving from: ',proc c ...receive from proc length of its dependence list.... call igerv2d(icontxt,1,1,length_dl(proc),1, @@ -243,14 +243,14 @@ c ...receive from proc its dependence list.... endif enddo - else if (me.ne.root) then + else if (me.ne.psb_root_) then c ...send to root dependence list length..... - if (debug) write(0,*) 'sending to: ',me,root - call igesd2d(icontxt,1,1,length_dl(me),1,root,mycol) - if (debug) write(0,*) 'sending to: ',me,root + if (debug) write(0,*) 'sending to: ',me,psb_root_ + call igesd2d(icontxt,1,1,length_dl(me),1,psb_root_,mycol) + if (debug) write(0,*) 'sending to: ',me,psb_root_ c ...send to root dependence list.... call igesd2d(icontxt,length_dl(me),1,dep_list(1,me), - + length_dl(me),root,mycol) + + length_dl(me),psb_root_,mycol) endif end if diff --git a/src/modules/Makefile b/src/modules/Makefile index 09b6ff58..a8626a2f 100644 --- a/src/modules/Makefile +++ b/src/modules/Makefile @@ -1,7 +1,7 @@ include ../../Make.inc MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \ - psb_desc_type.o \ + psb_desc_type.o psb_spsb_mod.o\ psb_blacs_mod.o psb_serial_mod.o psb_tools_mod.o \ psb_prec_type.o psb_error_mod.o psb_prec_mod.o \ psb_methd_mod.o psb_const_mod.o \ @@ -9,7 +9,7 @@ MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \ OBJS = error.o parts.o -INCDIRS = ../../lib +INCDIRS = -I ../../lib psb_realloc_mod.o : psb_error_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o diff --git a/src/modules/psb_const.fh b/src/modules/psb_const.fh index 71015db6..64cffec7 100644 --- a/src/modules/psb_const.fh +++ b/src/modules/psb_const.fh @@ -1,8 +1,8 @@ - integer, parameter :: psb_nohalo_=0, psb_halo_=4 - integer, parameter :: psb_none_=0,psb_sum_=1 - integer, parameter :: psb_avg_=2,psb_square_root_=3 - integer, parameter :: psb_swap_send_=1,psb_swap_recv_=2 - integer, parameter :: psb_swap_sync_=4,psb_swap_mpi_=8 + integer, parameter :: psb_nohalo_=0, psb_halo_=4 + integer, parameter :: psb_none_=0, psb_sum_=1 + integer, parameter :: psb_avg_=2, psb_square_root_=3 + integer, parameter :: psb_swap_send_=1, psb_swap_recv_=2 + integer, parameter :: psb_swap_sync_=4, psb_swap_mpi_=8 integer, parameter :: psb_deadlock_check_=0 integer, parameter :: psb_local_mtrx_check_=1 integer, parameter :: psb_local_comm_check_=2 @@ -11,28 +11,43 @@ integer, parameter :: psb_order_communication_=5 integer, parameter :: psb_change_represent_=6 integer, parameter :: psb_loc_to_glob_check_=7 - integer, parameter :: psb_convert_halo_=1 - integer, parameter :: psb_convert_ovrlap_=2 - integer, parameter :: psb_act_ret_=0 - integer, parameter :: psb_act_abort_=1, no_err_=0 - integer, parameter :: psb_dec_type_=1,psb_m_=2,psb_n_=3 - integer, parameter :: psb_n_row_=4,psb_n_col_=5,psb_ctxt_=6 + integer, parameter :: psb_convert_halo_=1, psb_convert_ovrlap_=2 + integer, parameter :: psb_act_ret_=0, psb_act_abort_=1, no_err_=0 + integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3 + integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6 integer, parameter :: psb_loc_to_glob_=7 integer, parameter :: psb_mpi_c_=9,psb_mdata_size_=10 integer, parameter :: psb_desc_asb_=3099 integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 + integer, parameter :: psb_desc_repl_=3199 integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 integer, parameter :: psb_desc_upd_asb_=psb_desc_upd_+1 - integer, parameter :: psb_upd_glb_=998,psb_upd_loc_=997 - integer, parameter :: psb_proc_id_=0,psb_n_elem_recv_=1 - integer, parameter :: psb_elem_recv_=2,psb_n_elem_send_=2 - integer, parameter :: psb_elem_send_=3,psb_n_ovrlp_elem_=1 - integer, parameter :: psb_ovrlp_elem_to_=2,psb_ovrlp_elem_=0 - integer, parameter :: psb_nnz_=1, psb_n_dom_ovr_=1 - integer, parameter :: psb_no_comm_=-1, psb_nzsizereq_=3 - integer, parameter :: ione=1, done=1.d0,izero=0, dzero=0.d0 - integer, parameter :: itwo=2, ithree=3,root=0, act_abort=1 - integer, parameter :: psb_nztotreq_=1,psb_nzrowreq_=2 - character, parameter :: psb_all_='A',psb_topdef_=' ' - + integer, parameter :: psb_upd_glb_=998, psb_upd_loc_=997 + integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1 + integer, parameter :: psb_elem_recv_=2, psb_n_elem_send_=2 + integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1 + integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 + integer, parameter :: psb_n_dom_ovr_=1 + integer, parameter :: psb_nnz_=1 + integer, parameter :: psb_no_comm_=-1 + integer, parameter :: ione=1, done=1.d0, izero=0, dzero=0.d0 + integer, parameter :: itwo=2, ithree=3,mone=-1, psb_root_=0 + integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2 + integer, parameter :: psb_nzsizereq_=3 + integer, parameter :: psb_del_bnd_=6, psb_srtd_=7 + integer, parameter :: psb_state_=8, psb_upd_=9 + integer, parameter :: psb_upd_pnt_=10, psb_ifasize_=10 + integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 + integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 + integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0 + integer, parameter :: psb_iflag_=2, psb_ichk_=3 + integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6 + integer, parameter :: psb_perm_update_=98765,psb_isrtdcoo_=98764 + integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4 + integer, parameter :: psb_dbleint_=2 + integer, parameter :: act_ret=0, act_abort=1, no_err=0 + real(kind(1.d0)), parameter :: psb_colrow_=0.33, psb_percent_=0.7 + + character, parameter :: psb_all_='A', psb_topdef_=' ' + character(len=5) :: psb_fidef_='CSR' diff --git a/src/modules/psb_const_mod.f90 b/src/modules/psb_const_mod.f90 index ae3f36c4..725880fc 100644 --- a/src/modules/psb_const_mod.f90 +++ b/src/modules/psb_const_mod.f90 @@ -24,7 +24,7 @@ module psb_const_mod integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0, psb_n_dom_ovr_=1 integer, parameter :: psb_nnz_=1 integer, parameter :: psb_no_comm_=-1 - integer, parameter :: ione=1, done=1.d0, izero=0, dzero=0.d0 + integer, parameter :: ione=1, done=1.d0, izero=0, dzero=0.d0,mone=-1 integer, parameter :: itwo=2, ithree=3, psb_root_=0 integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2, psb_nzsizereq_=3 integer, parameter :: psb_del_bnd_=6, psb_srtd_=7 @@ -32,10 +32,17 @@ module psb_const_mod integer, parameter :: psb_upd_pnt_=10, psb_ifasize_=10 integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 + integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0 + integer, parameter :: psb_iflag_=2, psb_ichk_=3 + integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6 + integer, parameter :: psb_perm_update_=98765, psb_isrtdcoo_=98764 + integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4 + integer, parameter :: psb_dbleint_=2 - real(kind(1.d0)), parameter :: psb_colrow_=0.33 + real(kind(1.d0)), parameter :: psb_colrow_=0.33, psb_percent_=0.7 character, parameter :: psb_all_='A', psb_topdef_=' ' + character(len=5) :: psb_fidef_='CSR' diff --git a/src/psblas/psb_ddot.f90 b/src/psblas/psb_ddot.f90 index 28e26f62..4598c70c 100644 --- a/src/psblas/psb_ddot.f90 +++ b/src/psblas/psb_ddot.f90 @@ -19,6 +19,7 @@ ! function psb_ddot(x, y,desc_a, info, jx, jy) use psb_descriptor_type +! use psb_spsb_mod use psb_error_mod implicit none @@ -26,23 +27,24 @@ function psb_ddot(x, y,desc_a, info, jx, jy) type(psb_desc_type), intent(in) :: desc_a integer, intent(in), optional :: jx, jy integer, intent(out) :: info - real(kind(1.D0)) :: f90_psddot + real(kind(1.D0)) :: psb_ddot ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.D0)) :: dot_local + real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_ddot' info=0 call psb_erractionsave(err_act) - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -ione) then info = 2010 call psb_errpush(info,name) @@ -74,11 +76,11 @@ function psb_ddot(x, y,desc_a, info, jx, jy) goto 9999 end if - m = desc_a%matrix_data(m_) + m = desc_a%matrix_data(psb_m_) ! check vector correctness - call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx) - call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy) + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) + call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then info=4010 ch_err='psb_chkvect' @@ -94,29 +96,29 @@ function psb_ddot(x, y,desc_a, info, jx, jy) if(m.ne.0) then if(desc_a%matrix_data(psb_n_row_).gt.0) then - dot = ddot(desc_a%matrix_data(psb_n_row_),& + dot_local = ddot(desc_a%matrix_data(psb_n_row_),& & x(iix,jjx),ione,y(iiy,jjy),ione) - ! adjust dot because overlapped elements are computed more than once + ! adjust dot_local because overlapped elements are computed more than once i=1 do while (desc_a%ovrlap_elem(i).ne.-ione) - dot = dot -& + dot_local = dot_local -& & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & x(iix+desc_a%ovrlap_elem(i)-1,jjx)* + & x(iix+desc_a%ovrlap_elem(i)-1,jjx)*& & y(iiy+desc_a%ovrlap_elem(i)-1,jjy) i = i+2 end do else - dot=0.d0 + dot_local=0.d0 end if else - dot=0.d0 + dot_local=0.d0 end if ! compute global sum - call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,& + call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& & ione, mone ,mycol) - psb_ddot = dot + psb_ddot = dot_local call psb_erractionrestore(err_act) return @@ -156,20 +158,21 @@ function psb_ddotv(x, y,desc_a, info) real(kind(1.D0)) :: psb_ddotv ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.D0)) :: dot_local + real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_ddot' info=0 call psb_erractionsave(err_act) - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -ione) then info = 2010 call psb_errpush(info,name) @@ -183,11 +186,11 @@ function psb_ddotv(x, y,desc_a, info) ix = ione iy = ione - m = desc_a%matrix_data(m_) + m = desc_a%matrix_data(psb_m_) ! check vector correctness - call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx) - call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy) + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) + call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then info=4010 ch_err='psb_chkvect' @@ -203,29 +206,29 @@ function psb_ddotv(x, y,desc_a, info) if(m.ne.0) then if(desc_a%matrix_data(psb_n_row_).gt.0) then - dot = ddot(desc_a%matrix_data(psb_n_row_),& + dot_local = ddot(desc_a%matrix_data(psb_n_row_),& & x,ione,y,ione) - ! adjust dot because overlapped elements are computed more than once + ! adjust dot_local because overlapped elements are computed more than once i=1 do while (desc_a%ovrlap_elem(i).ne.-ione) - dot = dot -& + dot_local = dot_local -& & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & x(desc_a%ovrlap_elem(i))* + & x(desc_a%ovrlap_elem(i))*& & y(desc_a%ovrlap_elem(i)) i = i+2 end do else - dot=0.d0 + dot_local=0.d0 end if else - dot=0.d0 + dot_local=0.d0 end if ! compute global sum - call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,& + call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& & ione, mone ,mycol) - psb_ddotv = dot + psb_ddotv = dot_local call psb_erractionrestore(err_act) return @@ -265,20 +268,21 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) integer, intent(out) :: info ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.D0)) :: dot_local + real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_ddot' info=0 call psb_erractionsave(err_act) - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -ione) then info = 2010 call psb_errpush(info,name) @@ -292,11 +296,11 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) ix = ione iy = ione - m = desc_a%matrix_data(m_) + m = desc_a%matrix_data(psb_m_) ! check vector correctness - call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx) - call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy) + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) + call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then info=4010 ch_err='psb_chkvect' @@ -312,29 +316,29 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) if(m.ne.0) then if(desc_a%matrix_data(psb_n_row_).gt.0) then - dot = ddot(desc_a%matrix_data(psb_n_row_),& + dot_local = ddot(desc_a%matrix_data(psb_n_row_),& & x,ione,y,ione) - ! adjust dot because overlapped elements are computed more than once + ! adjust dot_local because overlapped elements are computed more than once i=1 do while (desc_a%ovrlap_elem(i).ne.-ione) - dot = dot -& + dot_local = dot_local -& & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & x(desc_a%ovrlap_elem(i))* + & x(desc_a%ovrlap_elem(i))*& & y(desc_a%ovrlap_elem(i)) i = i+2 end do else - dot=0.d0 + dot_local=0.d0 end if else - dot=0.d0 + dot_local=0.d0 end if ! compute global sum - call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,& + call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& & ione, mone ,mycol) - res = dot + res = dot_local call psb_erractionrestore(err_act) return @@ -347,7 +351,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) return end if return -end function psb_ddotvs +end subroutine psb_ddotvs @@ -379,20 +383,20 @@ subroutine psb_dmdots(res, x, y, desc_a, info) integer, intent(out) :: info ! locals - integer :: int_err(5), icontxt, nprow, npcol, me, mycol,& - & err_act, n, iix, jjx, temp(2) - real(kind(1.d0)),pointer :: dot(:) - real(kind(1.D0)) :: dot_local + integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& + & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k + real(kind(1.d0)),pointer :: dot_local(:) + real(kind(1.d0)) :: ddot character(len=20) :: name, ch_err name='psb_dmdots' info=0 call psb_erractionsave(err_act) - icontxt=desc_data(psb_ctxt_) + icontxt=desc_a%matrix_data(psb_ctxt_) ! check on blacs grid - call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) + call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) if (nprow == -ione) then info = 2010 call psb_errpush(info,name) @@ -407,11 +411,11 @@ subroutine psb_dmdots(res, x, y, desc_a, info) ix = ione iy = ione - m = desc_a%matrix_data(m_) + m = desc_a%matrix_data(psb_m_) ! check vector correctness - call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_data%matrix_data,info,iix,jjx) - call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_data%matrix_data,info,iiy,jjy) + call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a%matrix_data,info,iix,jjx) + call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a%matrix_data,info,iiy,jjy) if(info.ne.0) then info=4010 ch_err='psb_chkvect' @@ -426,35 +430,35 @@ subroutine psb_dmdots(res, x, y, desc_a, info) end if k = min(size(x,2),size(y,2)) - allocate(dot(k)) + allocate(dot_local(k)) if(m.ne.0) then if(desc_a%matrix_data(psb_n_row_).gt.0) then do j=1,k - dot(j) = ddot(desc_a%matrix_data(psb_n_row_),& + dot_local(j) = ddot(desc_a%matrix_data(psb_n_row_),& & x(iix,jjx+j-1),ione,y(iiy,jjy+j-1),ione) - ! adjust dot because overlapped elements are computed more than once + ! adjust dot_local because overlapped elements are computed more than once i=1 do while (desc_a%ovrlap_elem(i).ne.-ione) - dot(j) = dot(j) -& + dot_local(j) = dot_local(j) -& & (desc_a%ovrlap_elem(i+1)-1)/desc_a%ovrlap_elem(i+1)*& - & x(iix+desc_a%ovrlap_elem(i)-1,jjx+j-1)* + & x(iix+desc_a%ovrlap_elem(i)-1,jjx+j-1)*& & y(iiy+desc_a%ovrlap_elem(i)-1,jjy+j-1) i = i+2 end do end do else - dot(:)=0.d0 + dot_local(:)=0.d0 end if else - dot(:)=0.d0 + dot_local(:)=0.d0 end if ! compute global sum - call dgsum2d(icontxt, 'A', ' ', ione, ione, dot,& + call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& & ione, mone ,mycol) - res(1:k) = dot(1:k) + res(1:k) = dot_local(1:k) call psb_erractionrestore(err_act) return diff --git a/src/serial/Makefile b/src/serial/Makefile index 141d52fa..cda79acc 100644 --- a/src/serial/Makefile +++ b/src/serial/Makefile @@ -1,30 +1,45 @@ include ../../Make.inc -#FCOPT= $(FCOPT) -F90_PSDOBJS= dcsdp90.o dcssm90.o dcssm90v.o dfixcoo.o dipcoo2csr.o dipcsr2coo.o\ - dcsprt90.o dspgtdiag.o dspinfo.o dspgtrow.o dspscal.o imsr.o imsrx.o \ - dsymbmm90.o dnumbmm90.o drwextd.o dtransp90.o smmp.o dcsmm90.o dcsmv90.o\ - dcsrws90.o psdneigh.o psbdcoins.o string_impl.o dcsnmi90.o +FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \ + psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \ + psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \ + psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtrow.o \ + psb_dspinfo.o psb_dspscal.o psb_dsymbmm.o psb_dtransp.o \ + string_impl.o -LIBDIR= ../../lib -INCLUDES=-I$(LIBDIR) -I.. -LIBNAME=$(LIBDIR)/$(F90LIB) -HERE=. -INCDIRS=-I. -I.. -I$(LIBDIR) +INCDIRS = -I ../../lib -I . -lib: $(F90_PSDOBJS) - ar -cur $(LIBNAME) $(F90_PSDOBJS) - ranlib $(LIBNAME) +lib: auxd cood csrd jadd f77d dpd lib1 -#$(F90_PSDOBJS): $(MODS) -.f.o: - $(F90) $(FCOPT) $(INCDIRS) -c $< +lib1: $(FOBJS) -veryclean: clean - /bin/rm -f $(LIBNAME) -clean: - /bin/rm -f $(F90_PSDOBJS) $(LOCAL_MODS) +auxd: + (cd aux; make lib) + +cood: + (cd coo; make lib) + +csrd: + (cd csr; make lib) + +jadd: + (cd jad; make lib) + +dpd: + (cd dp; make lib) + +f77d: + (cd f77; make lib) + +clean: + /bin/rm -f $(FOBJS) + (cd aux; make clean) + (cd coo; make clean) + (cd csr; make clean) + (cd jad; make clean) + (cd dp; make clean) + (cd f77; make clean) diff --git a/src/serial/aux/Makefile b/src/serial/aux/Makefile index 357d9f00..38e3f4c5 100644 --- a/src/serial/aux/Makefile +++ b/src/serial/aux/Makefile @@ -1,15 +1,10 @@ -include ../../../../Make.inc +include ../../../Make.inc # # The object files # -FOBJS = daxpby.o getrepflag.o geterr.o \ - isr.o isrx.o lsame.o \ - setrepflag.o seterr.o sperror.o \ - write_message.o mrgsrt.o xerbla.o \ - xsperr.o zaxpby.o zseterr.o \ - zsperror.o zwrite_message.o \ - zxsperr.o zsetrepflag.o isaperm.o ibsrch.o +FOBJS = isr.o isrx.o lsame.o \ + mrgsrt.o isaperm.o ibsrch.o OBJS=$(FOBJS) @@ -20,8 +15,7 @@ OBJS=$(FOBJS) #LIBDIR=../../../LIB #LIBNAME=libsparker.a LIBFILE=$(LIBDIR)/$(LIBNAME) -SPARKERDIR=.. -INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) +INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below @@ -30,15 +24,8 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) default: lib lib: $(OBJS) - $(AR) $(LIBFILE) $(OBJS) - $(RANLIB) $(LIBFILE) -$(FOBJS): $(SPARKERDIR)/sparker.fh +clean: + /bin/rm -f $(OBJS) -clean: cleanobjs - -veryclean: cleanobjs - -cleanobjs: - /bin/rm -f $(OBJS) diff --git a/src/serial/coo/Makefile b/src/serial/coo/Makefile index bebd4912..8b48ce82 100644 --- a/src/serial/coo/Makefile +++ b/src/serial/coo/Makefile @@ -1,13 +1,10 @@ -include ../../../../Make.inc +include ../../../Make.inc # # The object files # +FOBJS = dcooprt.o dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o -#FOBJS = dcsrck.o dcsrmm.o dcsrsm.o dsrmv.o dsrsv.o dcrnrmi.o dcrrs.o \ -# dcrupdate.o dcooprt.o -FOBJS = dcooprt.o dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o\ - zcoonrmi.o zcoomm.o zcoomv.o zcoosm.o zcoosv.o zcooprt.o #zcsrck.o zcrnrmi.o zcsrmm.o zsrmv.o zcsrsm.o zsrsv.o @@ -30,10 +27,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) default: lib lib: $(OBJS) - $(AR) $(LIBFILE) $(OBJS) - $(RANLIB) $(LIBFILE) - -$(OBJS): $(SPARKERDIR)/sparker.fh clean: cleanobjs diff --git a/src/serial/csr/Makefile b/src/serial/csr/Makefile index ba89924a..232d90f5 100644 --- a/src/serial/csr/Makefile +++ b/src/serial/csr/Makefile @@ -1,4 +1,4 @@ -include ../../../../Make.inc +include ../../../Make.inc # # The object files @@ -6,19 +6,16 @@ include ../../../../Make.inc FOBJS = dcsrck.o dcsrmm.o dcsrsm.o dcsrmv.o dcsrsv.o dcrnrmi.o \ dcrcrupd.o dcocrupd.o dcsrprt.o dcsrmv4.o dcsrmv2.o dcsrmv3.o\ - zcsrck.o zcrnrmi.o zcsrmm.o zsrmv.o zcsrsm.o zsrsv.o \ - zcrcrupd.o zcocrupd.o zcsrprt.o OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -#LIBDIR=../../LIB +LIBDIR=../../../lib #LIBNAME=libsparker.a LIBFILE=$(LIBDIR)/$(LIBNAME) -SPARKERDIR=.. -INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) +INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below @@ -28,11 +25,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) default: lib lib: $(OBJS) - $(AR) $(LIBFILE) $(OBJS) - $(RANLIB) $(LIBFILE) - -$(OBJS): $(SPARKERDIR)/sparker.fh - clean: cleanobjs diff --git a/src/serial/csr/dcocrupd.f b/src/serial/csr/dcocrupd.f index 0851f4fb..a7e6f5e3 100644 --- a/src/serial/csr/dcocrupd.f +++ b/src/serial/csr/dcocrupd.f @@ -12,7 +12,7 @@ C Flag = 1: replace elements with new value; C Flag = 2: sum block value to elements; C IMPLICIT NONE - include 'sparker.fh' + include 'psb_const.fh' C .. Scalar Arguments .. INTEGER IA, JA, IH, JH, M, N, + IERROR, FLAG, LIWORK @@ -27,18 +27,18 @@ C .. Local scalars .. C .. Local arrays .. IERROR = 0 c$$$ write(0,*) 'dcocrupd ',infoa(upd_),ibits(infoa(upd_),2,1) - IF (IBITS(INFOA(UPD_),2,1).EQ.1) THEN + IF (IBITS(INFOA(PSB_UPD_),2,1).EQ.1) THEN C C Smart update capability C - IP1 = INFOA(UPD_PNT_) - NNZ = IA2(IP1+NNZ_) + IP1 = INFOA(PSB_UPD_PNT_) + NNZ = IA2(IP1+PSB_NNZ_) NNZI = INFOH(1) DO J = 1, NNZI NNZ = NNZ + 1 A(NNZ) = H(J) ENDDO - IA2(IP1+NNZ_) = NNZ + IA2(IP1+PSB_NNZ_) = NNZ ELSE IERROR = 2 ENDIF diff --git a/src/serial/csr/dcrcrupd.f b/src/serial/csr/dcrcrupd.f index 9341f4d6..2bf5a884 100644 --- a/src/serial/csr/dcrcrupd.f +++ b/src/serial/csr/dcrcrupd.f @@ -12,7 +12,7 @@ C Flag = 1: replace elements with new value; C Flag = 2: sum block value to elements; C IMPLICIT NONE - include 'sparker.fh' + include 'psb_const.fh' C .. Scalar Arguments .. INTEGER IA, JA, IH, JH, M, N, + IERROR, FLAG, LIWORK @@ -28,12 +28,12 @@ C .. Local scalars .. C .. Local arrays .. IERROR = 0 c$$$ write(0,*) 'dcrcrupd ',infoa(upd_),ibits(infoa(upd_),2,1) - IF (IBITS(INFOA(UPD_),2,1).EQ.1) THEN + IF (IBITS(INFOA(PSB_UPD_),2,1).EQ.1) THEN C C Smart update capability C - IP1 = INFOA(UPD_PNT_) - NNZ = IA2(IP1+NNZ_) + IP1 = INFOA(PSB_UPD_PNT_) + NNZ = IA2(IP1+PSB_NNZ_) DO I = 1, M XBLCK = IH + I - 1 DO J = IH2(XBLCK),IH2(XBLCK+1) - 1 @@ -41,7 +41,7 @@ C A(NNZ) = H(J) ENDDO ENDDO - IA2(IP1+NNZ_) = NNZ + IA2(IP1+PSB_NNZ_) = NNZ ELSE IF (FLAG.EQ.0) THEN DO I = 1, M diff --git a/src/serial/dp/Makefile b/src/serial/dp/Makefile index 7ae0d7eb..ac7e1b3f 100644 --- a/src/serial/dp/Makefile +++ b/src/serial/dp/Makefile @@ -1,13 +1,12 @@ -include ../../../../Make.inc +include ../../../Make.inc # # The object files # FOBJS = dcrcr.o dcrdi.o dcrel.o dcrjd.o dgblock.o partition.o \ dgindex.o djadrp.o djadrp1.o dcsrrp.o dcsrp1.o check_dim.o \ - Max_nnzero.o dcoco.o dcocr.o dcrco.o dcrinco.o djdcox.o djdco.o dvtfg.o dgind_tri.o \ - gen_block.o dcoinco.o reordvn.o zreordvn.o\ - zcrcr.o zcsrrp.o zcsrp1.o zgindex.o zgind_tri.o zcocr.o zcrinco.o zcoco.o + Max_nnzero.o dcoco.o dcocr.o dcrco.o djdcox.o djdco.o dvtfg.o dgind_tri.o \ + gen_block.o reordvn.o # # dgind_tri.o @@ -19,11 +18,10 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -#LIBDIR=../../LIB +LIBDIR=../../../lib #LIBNAME=libsparker.a LIBFILE=$(LIBDIR)/$(LIBNAME) -SPARKERDIR=.. -INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) +INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below @@ -31,10 +29,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) lib: $(FOBJS) - $(AR) $(LIBFILE) $(OBJS) - $(RANLIB) $(LIBFILE) - -$(FOBJS): $(SPARKERDIR)/sparker.fh clean: cleanobjs diff --git a/src/serial/dp/check_dim.f b/src/serial/dp/check_dim.f index e54272a3..295bc72a 100644 --- a/src/serial/dp/check_dim.f +++ b/src/serial/dp/check_dim.f @@ -2,14 +2,14 @@ + NZ, LARN, LIAN1, LIAN2, IERRV) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. INTEGER M,N,NG,LARN,LIAN1,LIAN2, NZ C .. Array Arguments .. - INTEGER IA(3,*), RES(*), IA2(*), IERRV(*) + INTEGER IA(3,*), IA2(*), IERRV(*) C Local scalars INTEGER NNZ, BLOCK, DIM_BLOCK, LIMIT @@ -21,11 +21,11 @@ C Local scalars NNZ = NZ - LIMIT = INT(DIM_BLOCK*PERCENT) + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) DO BLOCK = 1, NG DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PERCENT) + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) NNZ = NNZ+(DIM_BLOCK-LIMIT)*MAX_NZ END DO diff --git a/src/serial/dp/dcoco.f b/src/serial/dp/dcoco.f index c5173036..668644ca 100644 --- a/src/serial/dp/dcoco.f +++ b/src/serial/dp/dcoco.f @@ -1,250 +1,250 @@ -C Covert matrix from COO format to COO Format -C - SUBROUTINE DCOCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * P1,DESCRN,ARN,IA1N,IA2N,INFON,P2,LARN,LIA1N, - * LIA2N,AUX,LAUX,IERROR) - - IMPLICIT NONE - INCLUDE 'sparker.fh' - -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIA1N, LIA2N, - + M, N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - DOUBLE PRECISION AR(*), ARN(*), D(*) - INTEGER AUX(0:LAUX-1) - INTEGER IA1(*), IA2(*), INFO(*), IA1N(*), IA2N(*), - * INFON(*), P1(*), P2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER IPX, IP1, IP2, CHECK_FLAG - INTEGER NNZ, K, I, J, NZL, IRET - INTEGER ELEM_IN, ELEM_OUT - LOGICAL SCALE - INTEGER MAX_NNZERO +c covert matrix from COO format to COO format +c + subroutine dcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, + * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, + * lia2n,aux,laux,ierror) + + implicit none + include 'psb_const.fh' + +c .. scalar arguments .. + integer larn, laux, lia1n, lia2n, + + m, n, ierror + character trans,unitd +c .. array arguments .. + double precision ar(*), arn(*), d(*) + integer aux(0:laux-1) + integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*), + * infon(*), p1(*), p2(*) + character descra*11, descrn*11 +c .. local scalars .. + integer ipx, ip1, ip2, check_flag, err_act + integer nnz, k, i, j, nzl, iret + integer elem_in, elem_out + logical scale + integer max_nnzero logical debug parameter (debug=.false.) -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) -C -C ...Common variables... -C This flag describe the action to do +c .. local arrays .. + character*20 name + integer int_val(5) +c +c ...common variables... +c this flag describe the action to do -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - - NAME = 'DCOCO\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - CHECK_FLAG=IBITS(info(upd_),1,2) - IF (TRANS.EQ.'N') THEN - SCALE = (UNITD.EQ.'L') ! meaningless - P1(1) = 0 - P2(1) = 0 - - NNZ = INFO(nnz_) +c .. external subroutines .. + external max_nnzero +c .. executable statements .. +c + + name = 'dcoco\0' + ierror = 0 + call fcpsb_erractionsave(err_act) + + check_flag=ibits(info(psb_upd_),1,2) + if (trans.eq.'N') then + scale = (unitd.eq.'L') ! meaningless + p1(1) = 0 + p2(1) = 0 + + nnz = info(psb_nnz_) if (debug) then - write(*,*) 'On entry to DCOCO: NNZ LAUX ', + write(*,*) 'on entry to dcoco: nnz laux ', + nnz,laux,larn,lia1n,lia2n endif - IF (LAUX.LT.NNZ+2) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LIA1N.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LIA2N.LT.M+1) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ENDIF + if (laux.lt.nnz+2) then + ierror = 60 + int_val(1) = 22 + int_val(2) = nnz+2 + int_val(3) = laux + else if (larn.lt.nnz) then + ierror = 60 + int_val(1) = 18 + int_val(2) = nnz+2 + int_val(3) = laux + else if (lia1n.lt.nnz) then + ierror = 60 + int_val(1) = 19 + int_val(2) = nnz+2 + int_val(3) = laux + else if (lia2n.lt.m+1) then + ierror = 60 + int_val(1) = 20 + int_val(2) = nnz+2 + int_val(3) = laux + endif -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (DESCRA(1:1).EQ.'G') THEN -C -C Sort COO data structure -C - if (debug) write(*,*)'First sort',nnz +c +c error handling +c + if(ierror.ne.0) then + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + end if + + if (descra(1:1).eq.'G') then +c +c sort COO data structure +c + if (debug) write(*,*)'first sort',nnz do k=1, nnz arn(k) = ar(k) ia1n(k) = ia1(k) ia2n(k) = ia2(k) enddo - if (debug) write(*,*)'Second sort' + if (debug) write(*,*)'second sort' - if ((lia2n.ge.(2*nnz+ireg_flgs+1)) + if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1)) + .and.(laux.ge.2*(2+nnz))) then -C -C Prepare for smart regeneration +c +c prepare for smart regeneration c ipx = nnz+3 do i=1, nnz aux(ipx+i-1) = i enddo - ip1 = nnz+2 - infon(upd_pnt_) = ip1 - ip2 = ip1+ireg_flgs - ia2n(ip1+ip2_) = ip2 - ia2n(ip1+iflag_) = check_flag - ia2n(ip1+nnzt_) = nnz - ia2n(ip1+nnz_) = 0 - ia2n(ip1+ichk_) = nnz+check_flag - if (debug) write(0,*) 'Build check :',ia2n(ip1+nnzt_) + ip1 = nnz+2 + infon(psb_upd_pnt_) = ip1 + ip2 = ip1+psb_ireg_flgs_ + ia2n(ip1+psb_ip2_) = ip2 + ia2n(ip1+psb_iflag_) = check_flag + ia2n(ip1+psb_nnzt_) = nnz + ia2n(ip1+psb_nnz_) = 0 + ia2n(ip1+psb_ichk_) = nnz+check_flag + if (debug) write(0,*) 'build check :',ia2n(ip1+psb_nnzt_) -C .... Order with key IA1N ... - CALL MRGSRT(NNZ,IA1N,AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN3(NNZ,ARN,IA1N,IA2N,AUX(IPX),AUX) -C .... Order with key IA2N ... +c .... order with key ia1n ... + call mrgsrt(nnz,ia1n,aux,iret) + if (iret.eq.0) call reordvn3(nnz,arn,ia1n,ia2n,aux(ipx),aux) +c .... order with key ia2n ... - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA1N(J).EQ.IA1N(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - NZL = J - I - CALL MRGSRT(NZL,IA2N(I),AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN3(NZL,ARN(I),IA1N(I),IA2N(I), - + AUX(IPX+I-1),AUX) - I = J - ENDDO + i = 1 + j = i + do while (i.le.nnz) + do while ((ia1n(j).eq.ia1n(i)).and. + + (j.le.nnz)) + j = j+1 + enddo + nzl = j - i + call mrgsrt(nzl,ia2n(i),aux,iret) + if (iret.eq.0) call reordvn3(nzl,arn(i),ia1n(i),ia2n(i), + + aux(ipx+i-1),aux) + i = j + enddo ia2n(ip2+aux(ipx+1-1)-1) = 1 -C ... Construct final COO Representation... - ELEM_OUT = 1 -C ... Insert remaining element ... - DO ELEM_IN = 2, NNZ - IF ((IA1N(ELEM_IN).EQ.IA1N(ELEM_OUT)).AND. - + (IA2N(ELEM_IN).EQ.IA2N(ELEM_OUT))) THEN - IF (CHECK_FLAG.EQ.1) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.2) THEN -C ... Insert only the first duplicated element ... +c ... construct final COO representation... + elem_out = 1 +c ... insert remaining element ... + do elem_in = 2, nnz + if ((ia1n(elem_in).eq.ia1n(elem_out)).and. + + (ia2n(elem_in).eq.ia2n(elem_out))) then + if (check_flag.eq.1) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.2) then +c ... insert only the first duplicated element ... ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - ELSE IF (CHECK_FLAG.EQ.3) THEN -C ... Sum the duplicated element ... - ARN(ELEM_OUT) = ARN(ELEM_OUT) + ARN(ELEM_IN) + else if (check_flag.eq.3) then +c ... sum the duplicated element ... + arn(elem_out) = arn(elem_out) + arn(elem_in) ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - END IF - ELSE - ELEM_OUT = ELEM_OUT + 1 - ARN(ELEM_OUT) = ARN(ELEM_IN) + end if + else + elem_out = elem_out + 1 + arn(elem_out) = arn(elem_in) ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - IA1N(ELEM_OUT) = IA1N(ELEM_IN) - IA2N(ELEM_OUT) = IA2N(ELEM_IN) - ENDIF - ENDDO + ia1n(elem_out) = ia1n(elem_in) + ia2n(elem_out) = ia2n(elem_in) + endif + enddo - ELSE + else -C .... Order with key IA1N ... - CALL MRGSRT(NNZ,IA1N,AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NNZ,ARN,IA1N,IA2N,AUX) -C .... Order with key IA2N ... +c .... order with key ia1n ... + call mrgsrt(nnz,ia1n,aux,iret) + if (iret.eq.0) call reordvn(nnz,arn,ia1n,ia2n,aux) +c .... order with key ia2n ... - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA1N(J).EQ.IA1N(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - NZL = J - I - CALL MRGSRT(NZL,IA2N(I),AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NZL,ARN(I),IA1N(I),IA2N(I), - + AUX) - I = J - ENDDO -C ... Construct final COO Representation... - ELEM_OUT = 1 -C ... Insert remaining element ... - DO ELEM_IN = 2, NNZ - IF ((IA1N(ELEM_IN).EQ.IA1N(ELEM_OUT)).AND. - + (IA2N(ELEM_IN).EQ.IA2N(ELEM_OUT))) THEN - IF (CHECK_FLAG.EQ.1) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.2) THEN -C ... Insert only the first duplicated element ... - ELSE IF (CHECK_FLAG.EQ.3) THEN -C ... Sum the duplicated element ... - ARN(ELEM_OUT) = ARN(ELEM_OUT) + ARN(ELEM_IN) - END IF - ELSE - ELEM_OUT = ELEM_OUT + 1 - ARN(ELEM_OUT) = ARN(ELEM_IN) - IA1N(ELEM_OUT) = IA1N(ELEM_IN) - IA2N(ELEM_OUT) = IA2N(ELEM_IN) - ENDIF - ENDDO - ENDIF - INFON(nnz_) = ELEM_OUT - infon(srtd_) = isrtdcoo + i = 1 + j = i + do while (i.le.nnz) + do while ((ia1n(j).eq.ia1n(i)).and. + + (j.le.nnz)) + j = j+1 + enddo + nzl = j - i + call mrgsrt(nzl,ia2n(i),aux,iret) + if (iret.eq.0) call reordvn(nzl,arn(i),ia1n(i),ia2n(i), + + aux) + i = j + enddo +c ... construct final COO representation... + elem_out = 1 +c ... insert remaining element ... + do elem_in = 2, nnz + if ((ia1n(elem_in).eq.ia1n(elem_out)).and. + + (ia2n(elem_in).eq.ia2n(elem_out))) then + if (check_flag.eq.1) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.2) then +c ... insert only the first duplicated element ... + else if (check_flag.eq.3) then +c ... sum the duplicated element ... + arn(elem_out) = arn(elem_out) + arn(elem_in) + end if + else + elem_out = elem_out + 1 + arn(elem_out) = arn(elem_in) + ia1n(elem_out) = ia1n(elem_in) + ia2n(elem_out) = ia2n(elem_in) + endif + enddo + endif + infon(psb_nnz_) = elem_out + infon(psb_srtd_) = psb_isrtdcoo_ - if (debug) write(*,*)'Done Rebuild COO',infon(1) + if (debug) write(*,*)'done rebuild COO',infon(1) - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN + else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then - DO 20 K = 1, M - P2(K) = K - 20 CONTINUE + do 20 k = 1, m + p2(k) = k + 20 continue - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN + else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN + else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then - END IF -C - ELSE IF (TRANS.NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END + end if +c + else if (trans.ne.'N') then +c +c to do +c + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + + end if + + call fcpsb_erractionrestore(err_act) + return + + 9999 continue + call fcpsb_erractionrestore(err_act) + + if ( err_act .ne. 0 ) then + call fcpsb_serror() + return + endif + + return + end diff --git a/src/serial/dp/dcocr.f b/src/serial/dp/dcocr.f index fbe6be7d..72923560 100644 --- a/src/serial/dp/dcocr.f +++ b/src/serial/dp/dcocr.f @@ -6,7 +6,7 @@ C * LIAN2,AUX,LAUX,IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. @@ -21,7 +21,7 @@ C .. Array Arguments .. CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. INTEGER NNZ, K, ROW, I, J, NZL, IRET - integer ipx, ip1, ip2, CHECK_FLAG + integer ipx, ip1, ip2, CHECK_FLAG, err_act INTEGER ELEM, ELEM_CSR LOGICAL SCALE INTEGER MAX_NNZERO @@ -43,10 +43,10 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - CHECK_FLAG=IBITS(INFO(UPD_),1,2) + CHECK_FLAG=IBITS(INFO(PSB_UPD_),1,2) c$$$ write(0,*) 'DCOCR FLAG ',info(upd_),check_flag IF (TRANS.EQ.'N') THEN - IERRV(1) = 0 + SCALE = (UNITD.EQ.'L') ! meaningless P1(1) = 0 P2(1) = 0 @@ -66,12 +66,12 @@ c$$$ write(0,*) 'DCOCR FLAG ',info(upd_),check_flag INT_VAL(1) = 18 INT_VAL(2) = NNZ+2 INT_VAL(3) = LAUX - ELSE IF (LIA1N.LT.NNZ) THEN + ELSE IF (LIAN1.LT.NNZ) THEN IERROR = 60 INT_VAL(1) = 19 INT_VAL(2) = NNZ+2 INT_VAL(3) = LAUX - ELSE IF (LIA2N.LT.M+1) THEN + ELSE IF (LIAN2.LT.M+1) THEN IERROR = 60 INT_VAL(1) = 20 INT_VAL(2) = NNZ+2 @@ -96,7 +96,7 @@ c$$$ do k=1,nnz c$$$ write(*,*) k,ia(k),ja(k),ar(k) c$$$ enddo c$$$ endif - if ((lian2.ge.((m+1)+nnz+ireg_flgs+1)) + if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) + .and.(laux.ge.2*(2+nnz))) then C C Prepare for smart regeneration @@ -106,19 +106,19 @@ c do i=1, nnz aux(ipx+i-1) = i enddo - ip1 = m+2 - infon(upd_pnt_) = ip1 - ip2 = ip1+ireg_flgs - ian2(ip1+ip2_) = ip2 - ian2(ip1+iflag_) = check_flag - ian2(ip1+nnzt_) = nnz - ian2(ip1+nnz_) = 0 - ian2(ip1+ichk_) = nnz+check_flag + ip1 = m+2 + infon(psb_upd_pnt_) = ip1 + ip2 = ip1+psb_ireg_flgs_ + ian2(ip1+psb_ip2_) = ip2 + ian2(ip1+psb_iflag_) = check_flag + ian2(ip1+psb_nnzt_) = nnz + ian2(ip1+psb_nnz_) = 0 + ian2(ip1+psb_ichk_) = nnz+check_flag c$$$ write(0,*)'DCOCR m,ip1,ip2,nnz',m, c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_) - if (debug) write(0,*) 'Build check :',ian2(ip1+nnzt_) + if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_) C .... Order with key IA ... CALL MRGSRT(NNZ,IA,AUX,IRET) IF (IRET.EQ.0) CALL REORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX) @@ -152,10 +152,6 @@ c$$$ + (J.LE.NNZ)) I = J ENDDO - - - - C ... Construct CSR Representation... ELEM = 1 ELEM_CSR = 1 diff --git a/src/serial/dp/dcoinco.f b/src/serial/dp/dcoinco.f index 0ecff660..6ed3fadc 100644 --- a/src/serial/dp/dcoinco.f +++ b/src/serial/dp/dcoinco.f @@ -3,7 +3,7 @@ + DESCRH,H,IH1,IH2,INFOH,IH,JH,WORK,LWORK,IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER LWORK, M, N, IERROR INTEGER LATOT,LIA1TOT,LIA2TOT,IA,JA,IH,JH diff --git a/src/serial/dp/dcrco.f b/src/serial/dp/dcrco.f index fe0f4a68..cf01e68e 100644 --- a/src/serial/dp/dcrco.f +++ b/src/serial/dp/dcrco.f @@ -3,7 +3,7 @@ * LIAN2,AUX,LAUX,IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. @@ -16,7 +16,7 @@ C .. Array Arguments .. CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. INTEGER NNZ, K, ROW, J - INTEGER ELEM + INTEGER ELEM, ERR_ACT LOGICAL SCALE INTEGER MAX_NNZERO c .. Local Arrays .. diff --git a/src/serial/dp/dcrcr.f b/src/serial/dp/dcrcr.f index 29d99fa5..a87162d8 100644 --- a/src/serial/dp/dcrcr.f +++ b/src/serial/dp/dcrcr.f @@ -144,7 +144,7 @@ C .. Array Arguments .. * INFOA(*), INFON(*) CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. - INTEGER I, J + INTEGER I, J, ERR_ACT LOGICAL EXIT c .. Local Arrays .. CHARACTER*20 NAME diff --git a/src/serial/dp/dcrinco.f b/src/serial/dp/dcrinco.f index a07e766f..f82ce904 100644 --- a/src/serial/dp/dcrinco.f +++ b/src/serial/dp/dcrinco.f @@ -2,7 +2,7 @@ + INFOA,IA,JA,LATOT,LIA1TOT,LIA2TOT, + DESCRH,H,IH1,IH2,INFOH,IH,JH,WORK,LWORK,IERRV) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER LWORK, M, N INTEGER LATOT,LIA1TOT,LIA2TOT,IA,JA,IH,JH diff --git a/src/serial/dp/dcrjd.f b/src/serial/dp/dcrjd.f index a343aead..b550e1fe 100644 --- a/src/serial/dp/dcrjd.f +++ b/src/serial/dp/dcrjd.f @@ -30,7 +30,7 @@ C ARN,IAN1 C IAN2,INFON, IP1, IP2 C IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. @@ -44,7 +44,7 @@ C .. Array Arguments .. CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. INTEGER IOFF, ISTROW, NJA, NZ, PIA, - + PJA, PNG, K, MAX_NG, NG, IERROR, LJA, ERR_ACT + + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT LOGICAL SCALE logical debug parameter (debug=.false.) @@ -52,7 +52,7 @@ C .. Local Scalars .. INTEGER MAX_NNZERO c .. Local Arrays .. CHARACTER*20 NAME - INTEGER INT_VAL(5), IERRV(*) + INTEGER INT_VAL(5), IERRV(5) C .. External Subroutines .. EXTERNAL DVTFG @@ -89,15 +89,15 @@ C C C CHECK ON DIMENSION OF IAN2 AND AUX C - MAX_NG = M/MINJDROWS+1 + MAX_NG = M/PSB_MINJDROWS_+1 IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN C ... If I haven't sufficent memory to compute NG in IAN2 ... - IF (M+1+3*(MAX_NG+1)/DBLEINT_+1.GT.LAUX) THEN + IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN C ... If I haven't sufficent memory to compute NG in AUX ... IERROR = 60 INT_VAL(1) = 22 - INT_VAL(2) = M+1+3*(MAX_NG+1)/DBLEINT_+1 + INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1 INT_VAL(3) = LAUX CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 diff --git a/src/serial/dp/dcsrp1.f b/src/serial/dp/dcsrp1.f index 72c16304..d7e3c3d6 100644 --- a/src/serial/dp/dcsrp1.f +++ b/src/serial/dp/dcsrp1.f @@ -87,7 +87,7 @@ C SUBROUTINE DCSRP1(TRANS,M,N,DESCRA,JA,IA, + P,WORK,IWORK,LWORK,IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER LWORK,M, N, IERROR CHARACTER TRANS @@ -96,7 +96,7 @@ C .. Array Arguments .. INTEGER JA(*), IA(*), P(*), IWORK(*) CHARACTER DESCRA*11 C .. Local Scalars .. - INTEGER I, J + INTEGER I, J, ERR_ACT c .. Local Arrays .. CHARACTER*20 NAME INTEGER INT_VAL(5) @@ -122,9 +122,9 @@ C LWORK refers here to INTEGER IWORK (alias for WORK) C IF(LWORK.LT.M) THEN IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX + INT_VAL(1) = 10 + INT_VAL(2) = M + INT_VAL(3) = LWORK CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 ENDIF @@ -145,7 +145,7 @@ C C C WORK(1) refers here to a value for a DOUBLE PRECISION WORK C - WORK(1) = DBLE((M+1)/DBLEINT_) + WORK(1) = DBLE((M+1)/PSB_DBLEINT_) ENDIF CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) diff --git a/src/serial/dp/dcsrrp.f b/src/serial/dp/dcsrrp.f index 0cbd0e5f..42e66ffd 100644 --- a/src/serial/dp/dcsrrp.f +++ b/src/serial/dp/dcsrrp.f @@ -99,6 +99,8 @@ C .. Array Arguments .. DOUBLE PRECISION WORK(*) INTEGER JA(*), IA(*), P(*) CHARACTER DESCRA*11 +C .. Local Scalars .. + INTEGER ERR_ACT c .. Local Arrays .. CHARACTER*20 NAME INTEGER INT_VAL(5) diff --git a/src/serial/dp/dgind_tri.f b/src/serial/dp/dgind_tri.f index 59bd8c06..76b32c0f 100644 --- a/src/serial/dp/dgind_tri.f +++ b/src/serial/dp/dgind_tri.f @@ -2,7 +2,7 @@ + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C ... Scalar arguments ... @@ -16,7 +16,7 @@ C ... Array arguments ... C .... Local scalars ... INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, - + DIM_BLOCK, LIMIT + + DIM_BLOCK, LIMIT, ERR_ACT LOGICAL CSR c .. Local Arrays .. CHARACTER*20 NAME @@ -49,7 +49,7 @@ C .... Invert Permutation Matrix... DO BLOCK = 1, N_BLOCKS COL = 1 DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PERCENT) + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) POINT_JA = POINT_JA+1 IF (LJA.LT.POINT_JA) THEN IERROR = 60 diff --git a/src/serial/dp/dgindex.f b/src/serial/dp/dgindex.f index 8c6637e7..d3ce5f6e 100644 --- a/src/serial/dp/dgindex.f +++ b/src/serial/dp/dgindex.f @@ -2,7 +2,7 @@ + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C ... Scalar arguments ... INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, @@ -16,7 +16,8 @@ C ... Array arguments ... C .... Local scalars ... INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1, - + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG + + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, + + ERR_ACT LOGICAL CSR c .. Local Arrays .. CHARACTER*20 NAME @@ -28,7 +29,7 @@ c .. Local Arrays .. POINT_AR = 1 POINT_JA = 0 - CHECK_FLAG=IBITS(INFON(UPD_),1,2) + CHECK_FLAG=IBITS(INFON(PSB_UPD_),1,2) IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN IERROR = 60 @@ -56,18 +57,18 @@ C Prepare for smart regeneration C IPW = M + 2 - IP1 = (LKA-IREG_FLGS-2)/2 - IP2 = IP1+IREG_FLGS + IP1 = (LKA-PSB_IREG_FLGS_-2)/2 + IP2 = IP1+PSB_IREG_FLGS_ IPC = IP2 + NNZ + 1 - KA(IP1 + IPC_) = IPC - KA(IP1+IP2_) = IP2 - INFON(UPD_PNT_) = IP1 - KA(IP1+IFLAG_) = CHECK_FLAG - KA(IP1+NNZT_) = NNZ - KA(IP1+NNZ_) = 0 - KA(IP1+ICHK_) = NNZ+CHECK_FLAG + KA(IP1 + PSB_IPC_) = IPC + KA(IP1+PSB_IP2_) = IP2 + INFON(PSB_UPD_PNT_) = IP1 + KA(IP1+PSB_IFLAG_) = CHECK_FLAG + KA(IP1+PSB_NNZT_) = NNZ + KA(IP1+PSB_NNZ_) = 0 + KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG I = M+2 - IPX = IA2(I+IP2_) + IPX = IA2(I+PSB_IP2_) C Invert permutation for smart regeneration @@ -81,12 +82,12 @@ C Construct JAD matrix... COL = 1 DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) c$$$ write(0,*) 'DGINDEX: BLOCK LOOP ',block,n_blocks,dim_block - if (dim_block .gt. maxjdrows) then + if (dim_block .gt. PSB_MAXJDROWS_) then write(0,*) 'Wrong value for dim_block',block, + IA(1,BLOCK+1),IA(1,BLOCK) return endif - LIMIT = INT(DIM_BLOCK*PERCENT) + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) POINT_JA = POINT_JA+1 IF (LJA.LT.POINT_JA) THEN IERROR = 60 @@ -244,7 +245,7 @@ c$$$ c write(*,*)'inizio a ciclare sui blocchi' DO BLOCK = 1, N_BLOCKS COL = 1 DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PERCENT) + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) POINT_JA = POINT_JA+1 IF (LJA.LT.POINT_JA) THEN IERROR = 60 @@ -386,7 +387,7 @@ C ... For each nnzero elements belonging to current row ... ENDIF IA(2,N_BLOCKS+1) = POINT_JA - KA(IP1 + ZERO_) = COUNT + KA(IP1 + PSB_ZERO_) = COUNT IF(POINT_AR.GE.IP1) THEN SIZE_REQ=NNZ+COUNT diff --git a/src/serial/dp/djadrp.f b/src/serial/dp/djadrp.f index eec4c4aa..ed6b4ef6 100644 --- a/src/serial/dp/djadrp.f +++ b/src/serial/dp/djadrp.f @@ -95,7 +95,7 @@ C .. Array Arguments .. INTEGER JA(*), IA(*), P(*) CHARACTER DESCRA*11 C .. Local Scalars .. - INTEGER PIA, PJA, PNG, IOFF + INTEGER PIA, PJA, PNG, IOFF, ERR_ACT C .. Intrinsic Functions .. INTRINSIC DBLE c .. Local Arrays .. diff --git a/src/serial/dp/djadrp1.f b/src/serial/dp/djadrp1.f index a874d47b..eb16d523 100644 --- a/src/serial/dp/djadrp1.f +++ b/src/serial/dp/djadrp1.f @@ -80,7 +80,7 @@ C .. Array Arguments .. INTEGER KA(*), JA(*), IA(3,*), P(*), IWORK(LWORK) CHARACTER DESCRA*11 C .. Local Scalars .. - INTEGER I, K, IPG + INTEGER I, K, IPG, ERR_ACT C .. Intrinsic Functions .. INTRINSIC DBLE LOGICAL DEBUG diff --git a/src/serial/dp/djdco.f b/src/serial/dp/djdco.f index c4af5776..c737b262 100644 --- a/src/serial/dp/djdco.f +++ b/src/serial/dp/djdco.f @@ -2,7 +2,7 @@ * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, * LIA2N,AUX,LAUX,IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. INTEGER LARN, LAUX, LIA1N, LIA2N, M, N, IERROR @@ -14,7 +14,7 @@ C .. Array Arguments .. * IA2N(*), INFON(*), IP1(*), IP2(*) CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. - INTEGER PIA, PJA, PNG + INTEGER PIA, PJA, PNG, ERR_ACT logical debug parameter (debug=.false.) c .. Local Arrays .. diff --git a/src/serial/dp/djdcox.f b/src/serial/dp/djdcox.f index 9dd20ea9..a4839bd8 100755 --- a/src/serial/dp/djdcox.f +++ b/src/serial/dp/djdcox.f @@ -7,7 +7,7 @@ C * LIA2N,AUX,LAUX,IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. @@ -21,7 +21,7 @@ C .. Array Arguments .. CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. INTEGER IPX, IPG, NNZ, K, ROW, - * I, J, NZL, IRET + * I, J, NZL, IRET, ERR_ACT LOGICAL SCALE logical debug parameter (debug=.false.) diff --git a/src/serial/dp/gen_block.f b/src/serial/dp/gen_block.f index f9c50bfa..36641e3d 100644 --- a/src/serial/dp/gen_block.f +++ b/src/serial/dp/gen_block.f @@ -1,7 +1,7 @@ SUBROUTINE GEN_BLOCK(M,NG,IA,AUX) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' INTEGER M, NG INTEGER IA(3,*), AUX(*) @@ -13,9 +13,9 @@ AUX(1) = 1 DO WHILE(.TRUE.) - IF (N_ROWS.GT.MAXJDROWS) THEN - AUX(BLOCK) = AUX(BLOCK-1)+MAXJDROWS - N_ROWS = N_ROWS-MAXJDROWS + IF (N_ROWS.GT.PSB_MAXJDROWS_) THEN + AUX(BLOCK) = AUX(BLOCK-1)+PSB_MAXJDROWS_ + N_ROWS = N_ROWS-PSB_MAXJDROWS_ BLOCK = BLOCK+1 ELSE IF (N_ROWS.GT.0) THEN AUX(BLOCK) = AUX(BLOCK-1)+N_ROWS diff --git a/src/serial/dp/partition.f b/src/serial/dp/partition.f index 8faf7aff..0c510df7 100644 --- a/src/serial/dp/partition.f +++ b/src/serial/dp/partition.f @@ -1,7 +1,7 @@ SUBROUTINE PARTITION(M, WORK, IA, N_BLOCK) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C ...Scalar arguments... @@ -24,11 +24,11 @@ C ...Local scalars... IA(1,1) = 1 DO WHILE(.TRUE.) - IF (N_ROWS.GT.MAXJDROWS) THEN - IA(1,BLOCK) = IA(1,BLOCK-1)+MAXJDROWS - N_ROWS = N_ROWS-MAXJDROWS + IF (N_ROWS.GT.PSB_MAXJDROWS_) THEN + IA(1,BLOCK) = IA(1,BLOCK-1)+PSB_MAXJDROWS_ + N_ROWS = N_ROWS-PSB_MAXJDROWS_ BLOCK = BLOCK+1 - ELSE IF (N_ROWS.GE.MINJDROWS) THEN + ELSE IF (N_ROWS.GE.PSB_MINJDROWS_) THEN IA(1,BLOCK) = IA(1,BLOCK-1)+N_ROWS N_ROWS = 0 BLOCK = BLOCK+1 diff --git a/src/serial/f77/dcsmm.f b/src/serial/f77/dcsmm.f index 3e9434a4..3d0b286d 100644 --- a/src/serial/f77/dcsmm.f +++ b/src/serial/f77/dcsmm.f @@ -161,6 +161,8 @@ C SUBROUTINE DCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) IMPLICIT NONE + INCLUDE 'psb_const.fh' + C .. Scalar Arguments .. INTEGER M,N,K,LDB,LDC,LWORK, IERROR CHARACTER TRANS @@ -170,17 +172,13 @@ C .. Array Arguments .. CHARACTER DESCRA*11, FIDA*5 DOUBLE PRECISION A(*),B(LDB,*),C(LDC,*),WORK(*) C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P + INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT LOGICAL LP, RP C .. Local Array.. INTEGER INT_VAL(5) CHARACTER*20 NAME DOUBLE PRECISION REAL_VAL(5) CHARACTER*30 STRINGS(2) -C .. Parameters .. - DOUBLE PRECISION ZERO - INTEGER IONE - PARAMETER (ZERO=0.D0,IONE=1) C .. External Subroutines .. EXTERNAL DSWMM, DLPUPD, DSCAL, XERBLA C .. Intrinsic Functions .. @@ -271,9 +269,9 @@ C C Both right and left permutation required C P=LWORKB+1 - CALL DLPUPD(K,N,PR,B,LDB,ZERO,WORK,K) + CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,ZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) + & WORK,K,DZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) LWORKS = IDINT(WORK(P+LWORKC)) IF(IERROR .NE. 0) THEN IERROR=4011 @@ -286,7 +284,7 @@ C C Only right permutation required C P=LWORKB+1 - CALL DLPUPD(K,N,PR,B,LDB,ZERO,WORK,K) + CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) LWORKS = IDINT(WORK(P)) @@ -301,7 +299,7 @@ C Only left permutation required C P=LWORKC+1 CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,ZERO,WORK,M,WORK(P),LWORKS,IERROR) + & B,LDB,DZERO,WORK,M,WORK(P),LWORKS,IERROR) LWORKS = IDINT(WORK(P)) IF(IERROR .NE. 0) THEN IERROR=4011 diff --git a/src/serial/f77/dcsnmi.f b/src/serial/f77/dcsnmi.f index cf042d7f..f3607218 100644 --- a/src/serial/f77/dcsnmi.f +++ b/src/serial/f77/dcsnmi.f @@ -73,10 +73,11 @@ C .. Array Arguments .. INTEGER IA1(*),IA2(*),INFOA(*) CHARACTER DESCRA*11, FIDA*5 DOUBLE PRECISION A(*) +C .. Local Scalars.. + INTEGER ERR_ACT C .. Local Array.. INTEGER INT_VAL(5) DOUBLE PRECISION REAL_VAL(5) - CHARACTER*30 NAME, STRINGS(2) C .. External Subroutines .. DOUBLE PRECISION DCRNRMI, DJDNRMI, DCOONRMI EXTERNAL DCRNRMI, DJDNRMI, DCOONRMI @@ -103,7 +104,6 @@ C ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN IERROR = 40 INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' ENDIF C diff --git a/src/serial/f77/dcsrp.f b/src/serial/f77/dcsrp.f index f39aafc1..ed06f53a 100644 --- a/src/serial/f77/dcsrp.f +++ b/src/serial/f77/dcsrp.f @@ -92,6 +92,8 @@ C C .. Scalar Arguments .. INTEGER LWORK, M, N, IERROR CHARACTER TRANS +C .. Local Scalars.. + INTEGER ERR_ACT C .. Array Arguments .. DOUBLE PRECISION WORK(LWORK) INTEGER IA1(*), IA2(*), INFOA(*), P(*), INT_VAL(5) diff --git a/src/serial/f77/dcssm.f b/src/serial/f77/dcssm.f index 132afafe..2817327f 100644 --- a/src/serial/f77/dcssm.f +++ b/src/serial/f77/dcssm.f @@ -175,7 +175,7 @@ C .. Array Arguments .. INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*) CHARACTER DESCRT*11, FIDT*5 C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKS, P + INTEGER LWORKM, LWORKB, LWORKS, P, ERR_ACT DOUBLE PRECISION ZERO LOGICAL LP, RP C .. Local Array.. diff --git a/src/serial/f77/dcsupd.f b/src/serial/f77/dcsupd.f index e9fe3443..8c11a528 100644 --- a/src/serial/f77/dcsupd.f +++ b/src/serial/f77/dcsupd.f @@ -12,6 +12,8 @@ C .. Array Arguments .. + GLOB_TO_LOC(*) CHARACTER DESCRA*11,DESCRH*11, FIDA*5, FIDH*5 DOUBLE PRECISION A(*),H(*) +C .. Local Scalars.. + INTEGER ERR_ACT C .. Local Array.. integer int_val(5) double precision real_val(5) diff --git a/src/serial/f77/dgelp.f b/src/serial/f77/dgelp.f index 96de3fb4..5a1a5861 100644 --- a/src/serial/f77/dgelp.f +++ b/src/serial/f77/dgelp.f @@ -68,8 +68,10 @@ C .. Array Arguments .. DOUBLE PRECISION B(LDB,*), WORK(*) INTEGER P(*) C .. Local Scalars .. - INTEGER I, J + INTEGER I, J, ERR_ACT logical istran,isnotran +C .. Local Arrays.. + INTEGER INT_VAL C .. Intrinsic Functions .. INTRINSIC DBLE logical lsame diff --git a/src/serial/f77/smmp.f b/src/serial/f77/smmp.f index e31cac61..24e936d1 100644 --- a/src/serial/f77/smmp.f +++ b/src/serial/f77/smmp.f @@ -16,7 +16,7 @@ c======================================================================= * ib, jb, diagb, * ic, jc, diagc, * index) - use realloc + use psb_realloc_mod c integer ia(*), ja(*), diaga, * ib(*), jb(*), diagb, @@ -93,7 +93,7 @@ c else nze = max(ic(i+1), nint((dble(ic(i))*(dble(n)/i))) ) endif - call psrealloc(nze,jc,info) + call psb_realloc(nze,jc,info) end if do 40 j= ic(i),ic(i+1)-1 if (diagc.eq.1 .and. istart.eq.i) then diff --git a/src/serial/jad/Makefile b/src/serial/jad/Makefile index 1defe97e..e4996024 100644 --- a/src/serial/jad/Makefile +++ b/src/serial/jad/Makefile @@ -1,4 +1,4 @@ -include ../../../../Make.inc +include ../../../Make.inc # # The object files # @@ -11,11 +11,10 @@ OBJS=$(FOBJS) # # Where the library should go, and how it is called. # Note that we are regenerating most of libsparker.a on the fly. -#LIBDIR=../../LIB +LIBDIR=../../../lib #LIBNAME=libsparker.a LIBFILE=$(LIBDIR)/$(LIBNAME) -SPARKERDIR=.. -INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) +INCDIRS=-I. -I$(LIBDIR) # # No change should be needed below @@ -24,10 +23,6 @@ INCDIRS=-I. -I$(SPARKERDIR) -I$(LIBDIR) default: lib lib: $(OBJS) - $(AR) $(LIBFILE) $(OBJS) - $(RANLIB) $(LIBFILE) - -$(FOBJS): $(SPARKERDIR)/sparker.fh clean: cleanobjs diff --git a/src/serial/jad/dcojdupd.f b/src/serial/jad/dcojdupd.f index 6d007bc3..cc80a8f7 100644 --- a/src/serial/jad/dcojdupd.f +++ b/src/serial/jad/dcojdupd.f @@ -12,7 +12,7 @@ C Flag = 1: replace elements with new value; C Flag = 2: sum block value to elements; C IMPLICIT NONE - include 'sparker.fh' + include 'psb_const.fh' C .. Scalar Arguments .. INTEGER IA, JA, IH, JH, M, N, + IERROR, FLAG, LIWORK @@ -26,18 +26,18 @@ C .. Local scalars .. INTEGER J, NNZ, IP1, NNZI C .. Local arrays .. IERROR = 0 - IF (IBITS(INFOA(UPD_),2,1).EQ.1) THEN + IF (IBITS(INFOA(PSB_UPD_),2,1).EQ.1) THEN C C Smart update capability C - IP1 = INFOA(UPD_PNT_) - NNZ = IA1(IP1+NNZ_) + IP1 = INFOA(PSB_UPD_PNT_) + NNZ = IA1(IP1+PSB_NNZ_) NNZI = INFOH(1) DO J = 1, NNZI NNZ = NNZ + 1 A(NNZ) = H(J) ENDDO - IA1(IP1+NNZ_) = NNZ + IA1(IP1+PSB_NNZ_) = NNZ ELSE IERROR = 2 ENDIF diff --git a/src/serial/jad/djadnr.f b/src/serial/jad/djadnr.f index 3fb5238c..fd20c034 100644 --- a/src/serial/jad/djadnr.f +++ b/src/serial/jad/djadnr.f @@ -2,7 +2,7 @@ C ... Compute infinity norma for sparse matrix in CSR Format ... DOUBLE PRECISION FUNCTION DJADNR(TRANS,M,N,NG,A,KA,JA,IA, + INFOA,IERROR) IMPLICIT NONE - INCLUDE 'sparker.fh' + INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER M,N, IERROR, NG CHARACTER TRANS @@ -10,7 +10,7 @@ C .. Array Arguments .. INTEGER KA(*),JA(*),IA(3,*),INFOA(*) DOUBLE PRECISION A(*) C ... Local Array .. - DOUBLE PRECISION NRMI_BLOCK(MAXJDROWS) + DOUBLE PRECISION NRMI_BLOCK(PSB_MAXJDROWS_) C ... Local Scalars .. DOUBLE PRECISION NRMI INTEGER I, K, IPG, NPG, IPX diff --git a/src/serial/psb_cest.f90 b/src/serial/psb_cest.f90 index f9a9bd04..7cc8d4ab 100644 --- a/src/serial/psb_cest.f90 +++ b/src/serial/psb_cest.f90 @@ -1,6 +1,7 @@ subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info) use psb_error_mod + use psb_const_mod implicit none ! .. scalar arguments .. @@ -11,11 +12,11 @@ subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info) integer :: int_val(5), err_act character(len=20) :: name - name = 'cest' + name = 'psb_cest' call psb_erractionsave(err_act) if (afmt.eq.'???') then - afmt = fidef + afmt = psb_fidef_ endif if (up.eq.'y') then @@ -39,15 +40,15 @@ subroutine psb_cest(afmt, nnz, lia1, lia2, lar, up, info) else if (up.eq.'n') then - if (afmt.eq.'jad') then + if (afmt.eq.'JAD') then lia1 = nnz + nnz/5 lia2 = nnz + nnz/5 lar = nnz + nnz/5 - else if (afmt.eq.'coo') then + else if (afmt.eq.'COO') then lia1 = nnz lia2 = nnz lar = nnz - else if(afmt.eq.'csr') then + else if(afmt.eq.'CSR') then lia1 = nnz lia2 = nnz lar = nnz diff --git a/src/serial/psb_dcoins.f90 b/src/serial/psb_dcoins.f90 new file mode 100644 index 00000000..fb73a43e --- /dev/null +++ b/src/serial/psb_dcoins.f90 @@ -0,0 +1,221 @@ +! File: psbdcoins.f90 + ! Subroutine: + ! Parameters: +subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_error_mod + use psb_serial_mod, only : psb_spinfo + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:),gtl(:) + real(kind(1.d0)), intent(in) :: val(:) + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + + character(len=5) :: ufida + integer :: i,j,ir,ic,nr,nc, ng, nza, isza,spstate, nnz,& + & ip1, nzl, err_act, int_err(5) + logical, parameter :: debug=.true. + character(len=20) :: name, ch_err + + name='psb_dcoins' + info = 0 + call psb_erractionsave(err_act) + + info = 0 + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + +!!$ ufida = toupper(a%fida) + call touppers(a%fida,ufida) + ng = size(gtl) + spstate = a%infoa(psb_state_) + + select case(spstate) + case(psb_spmat_bld_) + if ((ufida /= 'COO').and.(ufida/='COI')) then + info = 134 + ch_err(1:3)=ufida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_spinfo(psb_nztotreq_,a,nza,info) + call psb_spinfo(psb_nzsizereq_,a,isza,info) + if(info.ne.izero) then + info=4010 + ch_err='psb_spinfo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if ((nza+nz)>isza) then + call psb_spreall(a,nza+nz,info) + if(info.ne.izero) then + info=4010 + ch_err='psb_spreall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + endif + call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,gtl,& + & imin,imax,jmin,jmax,info) + if(info.ne.izero) then + info=4010 + ch_err='psb_inner_ins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + if (debug) then + if ((nza - a%infoa(psb_nnz_)) /= nz) then + write(0,*) 'PSB_COINS: insert discarded items ' + end if + end if + if ((nza - a%infoa(psb_nnz_)) /= nz) then + a%infoa(psb_del_bnd_) = nza + endif + a%infoa(psb_nnz_) = nza + + case(psb_spmat_upd_) + + if (ibits(a%infoa(psb_upd_),2,1).eq.1) then + ip1 = a%infoa(psb_upd_pnt_) + nza = a%ia2(ip1+psb_nnz_) + nzl = a%infoa(psb_del_bnd_) + + call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,gtl,& + & imin,imax,jmin,jmax,nzl,info) + if(info.ne.izero) then + info=4010 + ch_err='psb_inner_upd' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif +!!$ if (debug) then +!!$ if ((nza - a%ia2(ip1+nnz_)) /= nz) then +!!$ write(0,*) 'PSB_COINS: update discarded items ' +!!$ end if +!!$ end if + + a%ia2(ip1+psb_nnz_) = nza + else + info = 2231 + call psb_errpush(info,name) + goto 9999 + endif + + case default + info = 2232 + call psb_errpush(info,name) + goto 9999 + end select + return + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.act_abort) then + call psb_error() + return + end if + return + +contains + subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,gtl,imin,imax,jmin,jmax,nzl,info) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(*),ja(*),gtl(*) + integer, intent(inout) :: nza + real(kind(1.d0)), intent(in) :: val(*) + real(kind(1.d0)), intent(inout) :: aspk(*) + integer, intent(out) :: info + integer :: i,ir,ic + + info = 0 + + if (nza >= nzl) then + do i=1, nz + nza = nza + 1 + a%aspk(nza) = val(i) + end do + else + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + a%aspk(nza) = val(i) + end if + end if + end do + end if + + end subroutine psb_inner_upd + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,gtl,& + & imin,imax,jmin,jmax,info) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(*),ja(*),gtl(*) + integer, intent(inout) :: nza,ia1(*),ia2(*) + real(kind(1.d0)), intent(in) :: val(*) + real(kind(1.d0)), intent(inout) :: aspk(*) + integer, intent(out) :: info + + integer :: i,ir,ic + + info = 0 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + a%ia1(nza) = ir + a%ia2(nza) = ic + a%aspk(nza) = val(i) + end if + end if + end do + + end subroutine psb_inner_ins +end subroutine psb_dcoins + diff --git a/src/serial/psb_dcsdp.f90 b/src/serial/psb_dcsdp.f90 index c869b078..ef220a4c 100644 --- a/src/serial/psb_dcsdp.f90 +++ b/src/serial/psb_dcsdp.f90 @@ -112,9 +112,9 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd) case ('CSR') - ia1_size=a%infoa(nnz_) + ia1_size=a%infoa(psb_nnz_) ia2_size=a%m+1 - aspk_size=a%infoa(nnz_) + aspk_size=a%infoa(psb_nnz_) call psb_spreall(b,ia1_size,ia2_size,aspk_size,info) call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& @@ -280,12 +280,12 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd) else if (check_=='R') then !...Regenerating matrix - if (b%infoa(state_) /= spmat_upd) then + if (b%infoa(psb_state_) /= psb_spmat_upd_) then info = 8888 call psb_errpush(info,name) goto 9999 endif - if (ibits(b%infoa(upd_),2,1).eq.0) then + if (ibits(b%infoa(psb_upd_),2,1).eq.0) then ! ! Nothing to be done...... ! @@ -296,19 +296,19 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd) if (b%fida(1:3)/='JAD') then - ip1 = b%infoa(upd_pnt_) - ip2 = b%ia2(ip1+ip2_) - nnz = b%ia2(ip1+nnz_) - iflag = b%ia2(ip1+iflag_) - ichk = b%ia2(ip1+ichk_) - nnzt = b%ia2(ip1+nnzt_) + ip1 = b%infoa(psb_upd_pnt_) + ip2 = b%ia2(ip1+psb_ip2_) + nnz = b%ia2(ip1+psb_nnz_) + iflag = b%ia2(ip1+psb_iflag_) + ichk = b%ia2(ip1+psb_ichk_) + nnzt = b%ia2(ip1+psb_nnzt_) if (debug) write(*,*) 'Regeneration start: ',& - & b%infoa(upd_),perm_update,nnz,nnzt ,iflag,info + & b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,info if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then info = 8889 write(*,*) 'Regeneration start error: ',& - & b%infoa(upd_),perm_update,nnz,nnzt ,iflag,ichk + & b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk call psb_errpush(info,name) goto 9999 endif @@ -330,22 +330,22 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd) else if (b%fida(1:3) == 'JAD') then - ip1 = b%infoa(upd_pnt_) - ip2 = b%ia1(ip1+ip2_) - count = b%ia1(ip1+zero_) - ipc = b%ia1(ip1+ipc_) - nnz = b%ia1(ip1+nnz_) - iflag = b%ia1(ip1+iflag_) - ichk = b%ia1(ip1+ichk_) - nnzt = b%ia1(ip1+nnzt_) + ip1 = b%infoa(psb_upd_pnt_) + ip2 = b%ia1(ip1+psb_ip2_) + count = b%ia1(ip1+psb_zero_) + ipc = b%ia1(ip1+psb_ipc_) + nnz = b%ia1(ip1+psb_nnz_) + iflag = b%ia1(ip1+psb_iflag_) + ichk = b%ia1(ip1+psb_ichk_) + nnzt = b%ia1(ip1+psb_nnzt_) if (debug) write(*,*) 'Regeneration start: ',& - & b%infoa(upd_),perm_update,nnz,nnzt,count, & + & b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt,count, & & iflag,info if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then info = 10 write(*,*) 'Regeneration start error: ',& - & b%infoa(upd_),perm_update,nnz,nnzt ,iflag,ichk + & b%infoa(psb_upd_),psb_perm_update_,nnz,nnzt ,iflag,ichk call psb_errpush(info,name) goto 9999 endif @@ -372,7 +372,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd) end if - b%infoa(state_) = spmat_asb + b%infoa(psb_state_) = psb_spmat_asb_ call psb_erractionrestore(err_act) return diff --git a/src/serial/psb_dcsnmi.f90 b/src/serial/psb_dcsnmi.f90 index 2f05e671..28405026 100644 --- a/src/serial/psb_dcsnmi.f90 +++ b/src/serial/psb_dcsnmi.f90 @@ -36,11 +36,11 @@ real(kind(1.d0)) function psb_dcsnmi(a,info,trans) itrans='N' end if - dcsnmi90 = dcsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) + psb_dcsnmi = dcsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) if(info/=0) then - dcsnmi90 = -1 + psb_dcsnmi = -1 info=4010 - ch_err='dcsnmi' + ch_err='psb_dcsnmi' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if diff --git a/src/serial/psb_dcsprt.f90 b/src/serial/psb_dcsprt.f90 index 97e6888c..144749a5 100644 --- a/src/serial/psb_dcsprt.f90 +++ b/src/serial/psb_dcsprt.f90 @@ -85,23 +85,23 @@ subroutine psb_dcsprt(iout,a,iv,eirs,eics,head,ivr,ivc) else if (a%fida=='COO') then if (present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(nnz_) - do j=1,a%infoa(nnz_) + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) write(iout,frmtr) ivr(a%ia1(j)),a%ia2(j),a%aspk(j) enddo else if (present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(nnz_) - do j=1,a%infoa(nnz_) + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) write(iout,frmtr) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j) enddo else if (.not.present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(nnz_) - do j=1,a%infoa(nnz_) + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) write(iout,frmtr) a%ia1(j),ivc(a%ia2(j)),a%aspk(j) enddo else if (.not.present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(nnz_) - do j=1,a%infoa(nnz_) + write(iout,*) a%m,a%k,a%infoa(psb_nnz_) + do j=1,a%infoa(psb_nnz_) write(iout,frmtr) a%ia1(j),a%ia2(j),a%aspk(j) enddo endif diff --git a/src/serial/psb_dfixcoo.f90 b/src/serial/psb_dfixcoo.f90 index 0d95a8b5..4f1d8b72 100644 --- a/src/serial/psb_dfixcoo.f90 +++ b/src/serial/psb_dfixcoo.f90 @@ -4,6 +4,7 @@ Subroutine psb_dfixcoo(A,INFO) use psb_spmat_type + use psb_const_mod implicit none !....Parameters... @@ -24,7 +25,7 @@ Subroutine psb_dfixcoo(A,INFO) return end if - nza = a%infoa(nnz_) + nza = a%infoa(psb_nnz_) if (nza < 2) return allocate(iaux(nza+2),stat=info) @@ -64,8 +65,8 @@ Subroutine psb_dfixcoo(A,INFO) icl = a%ia2(i) endif enddo - a%infoa(nnz_) = i - a%infoa(srtd_) = isrtdcoo + a%infoa(psb_nnz_) = i + a%infoa(psb_srtd_) = psb_isrtdcoo_ if(debug) write(0,*)'FIXCOO: end second loop' diff --git a/src/serial/psb_dipcoo2csr.f90 b/src/serial/psb_dipcoo2csr.f90 index f84f1965..964fa355 100644 --- a/src/serial/psb_dipcoo2csr.f90 +++ b/src/serial/psb_dipcoo2csr.f90 @@ -4,7 +4,8 @@ subroutine psb_dipcoo2csr(a,info,rwshr) use psb_spmat_type - use psb_serial_mod, only : fixcoo + use psb_const_mod + use psb_serial_mod, only : psb_fixcoo use psb_error_mod implicit none @@ -40,7 +41,7 @@ subroutine psb_dipcoo2csr(a,info,rwshr) call psb_fixcoo(a,info) nr = a%m - nza = a%infoa(nnz_) + nza = a%infoa(psb_nnz_) allocate(iaux(nr+1)) if(debug) write(0,*)'DIPCOO2CSR: out of fixcoo',nza,nr,size(a%ia2),size(iaux) diff --git a/src/serial/psb_dipcsr2coo.f90 b/src/serial/psb_dipcsr2coo.f90 index bef665aa..1aac60ad 100644 --- a/src/serial/psb_dipcsr2coo.f90 +++ b/src/serial/psb_dipcsr2coo.f90 @@ -4,6 +4,7 @@ Subroutine psb_dipcsr2coo(a,info) use psb_spmat_type + use psb_const_mod use psb_error_mod implicit none @@ -11,12 +12,12 @@ Subroutine psb_dipcsr2coo(a,info) Type(psb_dspmat_type), intent(inout) :: A Integer, intent(out) :: info - integer, pointer :: iaux(:), itemp(:) !locals Integer :: nza, nr integer :: i,j,err_act logical, parameter :: debug=.false. - character(len=20) :: name, ch_err + integer, pointer :: iaux(:), itemp(:) + character(len=20) :: name, ch_err name='psb_dipcsr2coo' info = 0 @@ -47,8 +48,8 @@ Subroutine psb_dipcsr2coo(a,info) end do a%fida='COO' - a%infoa(nnz_) = nza - a%infoa(srtd_) = isrtdcoo + a%infoa(psb_nnz_) = nza + a%infoa(psb_srtd_) = psb_isrtdcoo_ deallocate(itemp) call psb_erractionrestore(err_act) diff --git a/src/serial/psb_dneigh.f90 b/src/serial/psb_dneigh.f90 index 211a4e71..39976ea2 100644 --- a/src/serial/psb_dneigh.f90 +++ b/src/serial/psb_dneigh.f90 @@ -5,6 +5,7 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev) use psb_realloc_mod + use psb_const_mod use psb_spmat_type implicit none @@ -18,7 +19,6 @@ subroutine psb_dneigh(a,idx,neigh,n,info,lev) integer :: level, dim, i, j, k, r, c, brow,& & elem_pt, ii, n1, col_idx, ne, err_act - integer, parameter :: izero=0 character(len=20) :: name, ch_err name='psb_dneigh' diff --git a/src/serial/psb_dspgtdiag.f90 b/src/serial/psb_dspgtdiag.f90 index e5988c1c..773e3bec 100644 --- a/src/serial/psb_dspgtdiag.f90 +++ b/src/serial/psb_dspgtdiag.f90 @@ -44,7 +44,7 @@ subroutine psb_dspgtdiag(a,d,info) else if (a%fida == 'COO') then - do i=1,a%infoa(nnz_) + do i=1,a%infoa(psb_nnz_) j=a%ia1(i) if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then d(j) = a%aspk(i) diff --git a/src/serial/psb_dspgtrow.f90 b/src/serial/psb_dspgtrow.f90 index 102abeb9..98c54508 100644 --- a/src/serial/psb_dspgtrow.f90 +++ b/src/serial/psb_dspgtrow.f90 @@ -57,7 +57,7 @@ subroutine psb_dspgtrow(irw,a,b,info,append,iren,lrw) if (append_) then - nzb = b%infoa(nnz_) + nzb = b%infoa(psb_nnz_) else nzb = 0 b%m = 0 @@ -126,7 +126,7 @@ contains nr = lrw - irw + 1 nz = a%ia2(idx+nr) - a%ia2(idx) if (append) then - nzb = b%infoa(nnz_) + nzb = b%infoa(psb_nnz_) else nzb = 0 endif @@ -159,7 +159,7 @@ contains end do enddo end if - b%infoa(nnz_) = nzb+nz + b%infoa(psb_nnz_) = nzb+nz if (a%pr(1) /= 0) then write(0,*) 'Feeling lazy today, Right Permutation will have to wait' endif @@ -181,7 +181,7 @@ contains integer, pointer :: iren(:) integer :: lrw - nza = a%infoa(nnz_) + nza = a%infoa(psb_nnz_) if (a%pl(1) /= 0) then write(0,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!' idx = -1 @@ -193,7 +193,7 @@ contains return end if - if (a%infoa(srtd_) == isrtdcoo) then + if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then !!$ write(0,*) 'Gtrow_: srtd coo',irw ! In this case we can do a binary search. do @@ -274,7 +274,7 @@ contains if (associated(iren)) then k = 0 - do i=1,a%infoa(nnz_) + do i=1,a%infoa(psb_nnz_) if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then k = k + 1 if (k > nz) then @@ -288,7 +288,7 @@ contains enddo else k = 0 - do i=1,a%infoa(nnz_) + do i=1,a%infoa(psb_nnz_) if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then k = k + 1 if (k > nz) then @@ -303,7 +303,7 @@ contains end if end if - b%infoa(nnz_) = nzb + k + b%infoa(psb_nnz_) = nzb + k b%m = b%m+lrw-irw+1 b%k = max(b%k,a%k) end subroutine coo_dspgtrow diff --git a/src/serial/psb_dspinfo.f90 b/src/serial/psb_dspinfo.f90 index 82a93b09..55fd43ab 100644 --- a/src/serial/psb_dspinfo.f90 +++ b/src/serial/psb_dspinfo.f90 @@ -28,12 +28,12 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux) call psb_erractionsave(err_act) - if (ireq == nztotreq) then + if (ireq == psb_nztotreq_) then if (a%fida == 'CSR') then nr = a%m ires = a%ia2(nr+1)-1 else if ((a%fida == 'COO').or.(a%fida == 'COI')) then - ires = a%infoa(nnz_) + ires = a%infoa(psb_nnz_) else if (a%fida == 'JAD') then ires=-1 info=135 @@ -48,7 +48,7 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux) goto 9999 end if - else if (ireq == nzrowreq) then + else if (ireq == psb_nzrowreq_) then if (.not.present(iaux)) then write(0,*) 'Need IAUX when ireq=nzrowreq' ires=-1 @@ -59,10 +59,10 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux) ires = a%ia2(irw+1)-a%ia2(irw) else if ((a%fida == 'COO').or.(a%fida == 'COI')) then - if (a%infoa(srtd_) == isrtdcoo) then + if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then !!$ write(0,*) 'Gtrow_: srtd coo',irw ! In this case we can do a binary search. - nz = a%infoa(nnz_) + nz = a%infoa(psb_nnz_) call ibsrch(ip,irw,nz,a%ia1) jp = ip ! expand [ip,jp] to contain all row entries. @@ -85,10 +85,10 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux) end do ires = jp-ip else - ires = count(a%ia1(1:a%infoa(nnz_))==irw) + ires = count(a%ia1(1:a%infoa(psb_nnz_))==irw) endif !!$ ires = 0 -!!$ do i=1, a%infoa(nnz_) +!!$ do i=1, a%infoa(psb_nnz_) !!$ if (a%ia1(i) == irw) ires = ires + 1 !!$ enddo else if (a%fida == 'JAD') then @@ -105,13 +105,13 @@ subroutine psb_dspinfo(ireq,a,ires,info,iaux) goto 9999 end if - else if (ireq == nzsizereq) then + else if (ireq == psb_nzsizereq_) then if (a%fida == 'CSR') then ires = size(a%aspk) else if ((a%fida == 'COO').or.(a%fida == 'COI')) then ires = size(a%aspk) else if (a%fida == 'JAD') then - ires = a%infoa(nnz_) + ires = a%infoa(psb_nnz_) else ires=-1 info=136 diff --git a/src/serial/psb_dspscal.f90 b/src/serial/psb_dspscal.f90 index cdfe009f..753c6a7a 100644 --- a/src/serial/psb_dspscal.f90 +++ b/src/serial/psb_dspscal.f90 @@ -35,7 +35,7 @@ subroutine psb_dspscal(a,d,info) else if (a%fida == 'COO') then - do i=1,a%infoa(nnz_) + do i=1,a%infoa(psb_nnz_) j=a%ia1(i) a%aspk(i) = a%aspk(i) * d(j) enddo diff --git a/src/serial/psb_dtransp.f90 b/src/serial/psb_dtransp.f90 index 6511b91d..fa3d01e6 100644 --- a/src/serial/psb_dtransp.f90 +++ b/src/serial/psb_dtransp.f90 @@ -4,7 +4,7 @@ subroutine psb_dtransp(a,b,c,fmt) use psb_spmat_type - use psb_serial_mod, only : ipcoo2csr, ipcsr2coo, fixcoo + use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo implicit none type(psb_dspmat_type) :: a,b diff --git a/src/tools/Makefile b/src/tools/Makefile index 71a32d2f..004c4e6c 100644 --- a/src/tools/Makefile +++ b/src/tools/Makefile @@ -11,7 +11,7 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_descprt.o \ MPFOBJS = psb_descasb.o psb_dcsrovr.o -INCDIRS = ../../lib . +INCDIRS = -I ../../lib -I . lib: mpfobjs $(FOBJS)