diff --git a/base/modules/Makefile b/base/modules/Makefile index 3177d8ba6..4cb518578 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -98,6 +98,8 @@ UTIL_MODS = auxil/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_m serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_mat_mod.o \ serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o #\ +# serial/psb_ls_csr_mat_mod.o serial/psb_ld_csr_mat_mod.o serial/psb_lc_csr_mat_mod.o serial/psb_lz_csr_mat_mod.o +#\ # serial/psb_ld_base_mat_mod.o serial/psb_lbase_mat_mod.o serial/psb_ld_csc_mat_mod.o serial/psb_ld_csr_mat_mod.o @@ -209,15 +211,18 @@ serial/psb_z_base_mat_mod.o: serial/psb_z_base_vect_mod.o serial/psb_l_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: auxil/psi_serial_mod.o psb_realloc_mod.o -serial/psb_s_mat_mod.o: serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_vect_mod.o -serial/psb_d_mat_mod.o: serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_vect_mod.o serial/psb_i_vect_mod.o -#serial/psb_d_mat_mod.o: serial/psb_ld_base_mat_mod.o -serial/psb_c_mat_mod.o: serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_vect_mod.o -serial/psb_z_mat_mod.o: serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_vect_mod.o -serial/psb_s_csc_mat_mod.o serial/psb_s_csr_mat_mod.o: serial/psb_s_base_mat_mod.o -serial/psb_d_csc_mat_mod.o serial/psb_d_csr_mat_mod.o: serial/psb_d_base_mat_mod.o -serial/psb_c_csc_mat_mod.o serial/psb_c_csr_mat_mod.o: serial/psb_c_base_mat_mod.o -serial/psb_z_csc_mat_mod.o serial/psb_z_csr_mat_mod.o: serial/psb_z_base_mat_mod.o +serial/psb_s_mat_mod.o: serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_d_mat_mod.o: serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_c_mat_mod.o: serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_z_mat_mod.o: serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_s_csc_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_ls_csr_mat_mod.o: serial/psb_s_base_mat_mod.o +serial/psb_d_csc_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_ld_csr_mat_mod.o: serial/psb_d_base_mat_mod.o +serial/psb_c_csc_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_lc_csr_mat_mod.o: serial/psb_c_base_mat_mod.o +serial/psb_z_csc_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_lz_csr_mat_mod.o: serial/psb_z_base_mat_mod.o serial/psb_mat_mod.o: serial/psb_vect_mod.o serial/psb_s_mat_mod.o serial/psb_d_mat_mod.o serial/psb_c_mat_mod.o serial/psb_z_mat_mod.o serial/psb_serial_mod.o: serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o diff --git a/base/modules/auxil/psb_c_ip_reord_mod.F90 b/base/modules/auxil/psb_c_ip_reord_mod.F90 index 5df79b0d8..daec3a65f 100644 --- a/base/modules/auxil/psb_c_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_c_ip_reord_mod.F90 @@ -40,20 +40,23 @@ module psb_c_ip_reord_mod use psb_const_mod interface psb_ip_reord - module procedure psb_ip_reord_c1,& - & psb_ip_reord_c1i1, psb_ip_reord_c1i2,& - & psb_ip_reord_c1i3 + module procedure psb_ip_reord_c1m,& + & psb_ip_reord_c1m1, psb_ip_reord_c1m2,& + & psb_ip_reord_c1m3 + module procedure psb_ip_reord_c1e,& + & psb_ip_reord_c1e1, psb_ip_reord_c1e2,& + & psb_ip_reord_c1e3 end interface contains - subroutine psb_ip_reord_c1(n,x,iaux) + subroutine psb_ip_reord_c1m(n,x,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_spk_) :: x(*) - integer(psb_ipk_) :: lswap, lp, k + integer(psb_mpk_) :: lswap, lp, k complex(psb_spk_) :: swap lp = iaux(0) @@ -74,14 +77,14 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_c1 + end subroutine psb_ip_reord_c1m - subroutine psb_ip_reord_c1i1(n,x,indx,iaux) + subroutine psb_ip_reord_c1m1(n,x,indx,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_spk_) :: x(*) - integer(psb_ipk_) :: indx(*) - integer(psb_ipk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap complex(psb_spk_) :: swap lp = iaux(0) @@ -105,16 +108,16 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_c1i1 + end subroutine psb_ip_reord_c1m1 - subroutine psb_ip_reord_c1i2(n,x,i1,i2,iaux) + subroutine psb_ip_reord_c1m2(n,x,i1,i2,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) + integer(psb_mpk_) :: i1(*), i2(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 complex(psb_spk_) :: swap lp = iaux(0) @@ -141,15 +144,15 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_c1i2 + end subroutine psb_ip_reord_c1m2 - subroutine psb_ip_reord_c1i3(n,x,i1,i2,i3,iaux) + subroutine psb_ip_reord_c1m3(n,x,i1,i2,i3,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 complex(psb_spk_) :: swap lp = iaux(0) @@ -179,6 +182,139 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_c1i3 + end subroutine psb_ip_reord_c1m3 + + + subroutine psb_ip_reord_c1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e + + subroutine psb_ip_reord_c1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e1 + + subroutine psb_ip_reord_c1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e2 + subroutine psb_ip_reord_c1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e3 + end module psb_c_ip_reord_mod diff --git a/base/modules/auxil/psb_d_ip_reord_mod.F90 b/base/modules/auxil/psb_d_ip_reord_mod.F90 index df483f1c9..7cd0a2699 100644 --- a/base/modules/auxil/psb_d_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_d_ip_reord_mod.F90 @@ -40,20 +40,23 @@ module psb_d_ip_reord_mod use psb_const_mod interface psb_ip_reord - module procedure psb_ip_reord_d1,& - & psb_ip_reord_d1i1, psb_ip_reord_d1i2,& - & psb_ip_reord_d1i3 + module procedure psb_ip_reord_d1m,& + & psb_ip_reord_d1m1, psb_ip_reord_d1m2,& + & psb_ip_reord_d1m3 + module procedure psb_ip_reord_d1e,& + & psb_ip_reord_d1e1, psb_ip_reord_d1e2,& + & psb_ip_reord_d1e3 end interface contains - subroutine psb_ip_reord_d1(n,x,iaux) + subroutine psb_ip_reord_d1m(n,x,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_dpk_) :: x(*) - integer(psb_ipk_) :: lswap, lp, k + integer(psb_mpk_) :: lswap, lp, k real(psb_dpk_) :: swap lp = iaux(0) @@ -74,14 +77,14 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_d1 + end subroutine psb_ip_reord_d1m - subroutine psb_ip_reord_d1i1(n,x,indx,iaux) + subroutine psb_ip_reord_d1m1(n,x,indx,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_dpk_) :: x(*) - integer(psb_ipk_) :: indx(*) - integer(psb_ipk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap real(psb_dpk_) :: swap lp = iaux(0) @@ -105,16 +108,16 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_d1i1 + end subroutine psb_ip_reord_d1m1 - subroutine psb_ip_reord_d1i2(n,x,i1,i2,iaux) + subroutine psb_ip_reord_d1m2(n,x,i1,i2,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) + integer(psb_mpk_) :: i1(*), i2(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 real(psb_dpk_) :: swap lp = iaux(0) @@ -141,15 +144,15 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_d1i2 + end subroutine psb_ip_reord_d1m2 - subroutine psb_ip_reord_d1i3(n,x,i1,i2,i3,iaux) + subroutine psb_ip_reord_d1m3(n,x,i1,i2,i3,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 real(psb_dpk_) :: swap lp = iaux(0) @@ -179,6 +182,139 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_d1i3 + end subroutine psb_ip_reord_d1m3 + + + subroutine psb_ip_reord_d1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e + + subroutine psb_ip_reord_d1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e1 + + subroutine psb_ip_reord_d1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e2 + subroutine psb_ip_reord_d1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e3 + end module psb_d_ip_reord_mod diff --git a/base/modules/auxil/psb_e_ip_reord_mod.F90 b/base/modules/auxil/psb_e_ip_reord_mod.F90 index 1fff0b9d1..7369d1f2f 100644 --- a/base/modules/auxil/psb_e_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_e_ip_reord_mod.F90 @@ -40,16 +40,152 @@ module psb_e_ip_reord_mod use psb_const_mod interface psb_ip_reord - module procedure psb_ip_reord_e1,& - & psb_ip_reord_e1i1, psb_ip_reord_e1i2,& - & psb_ip_reord_e1i3 + module procedure psb_ip_reord_e1m,& + & psb_ip_reord_e1m1, psb_ip_reord_e1m2,& + & psb_ip_reord_e1m3 + module procedure psb_ip_reord_e1e,& + & psb_ip_reord_e1e1, psb_ip_reord_e1e2,& + & psb_ip_reord_e1e3 end interface contains - subroutine psb_ip_reord_e1(n,x,iaux) + subroutine psb_ip_reord_e1m(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: lswap, lp, k + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m + + subroutine psb_ip_reord_e1m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m1 + + subroutine psb_ip_reord_e1m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m2 + + subroutine psb_ip_reord_e1m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m3 + + + subroutine psb_ip_reord_e1e(n,x,iaux) integer(psb_ipk_), intent(in) :: n integer(psb_epk_) :: iaux(0:*) integer(psb_epk_) :: x(*) @@ -74,9 +210,9 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_e1 + end subroutine psb_ip_reord_e1e - subroutine psb_ip_reord_e1i1(n,x,indx,iaux) + subroutine psb_ip_reord_e1e1(n,x,indx,iaux) integer(psb_ipk_), intent(in) :: n integer(psb_epk_) :: iaux(0:*) integer(psb_epk_) :: x(*) @@ -105,9 +241,9 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_e1i1 + end subroutine psb_ip_reord_e1e1 - subroutine psb_ip_reord_e1i2(n,x,i1,i2,iaux) + subroutine psb_ip_reord_e1e2(n,x,i1,i2,iaux) integer(psb_ipk_), intent(in) :: n integer(psb_epk_) :: iaux(0:*) integer(psb_epk_) :: x(*) @@ -141,9 +277,9 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_e1i2 + end subroutine psb_ip_reord_e1e2 - subroutine psb_ip_reord_e1i3(n,x,i1,i2,i3,iaux) + subroutine psb_ip_reord_e1e3(n,x,i1,i2,i3,iaux) integer(psb_ipk_), intent(in) :: n integer(psb_epk_) :: iaux(0:*) integer(psb_epk_) :: x(*) @@ -179,6 +315,6 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_e1i3 - + end subroutine psb_ip_reord_e1e3 + end module psb_e_ip_reord_mod diff --git a/base/modules/auxil/psb_m_ip_reord_mod.F90 b/base/modules/auxil/psb_m_ip_reord_mod.F90 index 300b5487d..29ea47f14 100644 --- a/base/modules/auxil/psb_m_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_m_ip_reord_mod.F90 @@ -40,20 +40,23 @@ module psb_m_ip_reord_mod use psb_const_mod interface psb_ip_reord - module procedure psb_ip_reord_m1,& - & psb_ip_reord_m1i1, psb_ip_reord_m1i2,& - & psb_ip_reord_m1i3 + module procedure psb_ip_reord_m1m,& + & psb_ip_reord_m1m1, psb_ip_reord_m1m2,& + & psb_ip_reord_m1m3 + module procedure psb_ip_reord_m1e,& + & psb_ip_reord_m1e1, psb_ip_reord_m1e2,& + & psb_ip_reord_m1e3 end interface contains - subroutine psb_ip_reord_m1(n,x,iaux) + subroutine psb_ip_reord_m1m(n,x,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) integer(psb_mpk_) :: x(*) - integer(psb_ipk_) :: lswap, lp, k + integer(psb_mpk_) :: lswap, lp, k integer(psb_mpk_) :: swap lp = iaux(0) @@ -74,14 +77,14 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_m1 + end subroutine psb_ip_reord_m1m - subroutine psb_ip_reord_m1i1(n,x,indx,iaux) + subroutine psb_ip_reord_m1m1(n,x,indx,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) integer(psb_mpk_) :: x(*) - integer(psb_ipk_) :: indx(*) - integer(psb_ipk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap integer(psb_mpk_) :: swap lp = iaux(0) @@ -105,16 +108,16 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_m1i1 + end subroutine psb_ip_reord_m1m1 - subroutine psb_ip_reord_m1i2(n,x,i1,i2,iaux) + subroutine psb_ip_reord_m1m2(n,x,i1,i2,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) integer(psb_mpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) + integer(psb_mpk_) :: i1(*), i2(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 integer(psb_mpk_) :: swap lp = iaux(0) @@ -141,15 +144,15 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_m1i2 + end subroutine psb_ip_reord_m1m2 - subroutine psb_ip_reord_m1i3(n,x,i1,i2,i3,iaux) + subroutine psb_ip_reord_m1m3(n,x,i1,i2,i3,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) integer(psb_mpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 integer(psb_mpk_) :: swap lp = iaux(0) @@ -179,6 +182,139 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_m1i3 + end subroutine psb_ip_reord_m1m3 + + + subroutine psb_ip_reord_m1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e + + subroutine psb_ip_reord_m1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e1 + + subroutine psb_ip_reord_m1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e2 + subroutine psb_ip_reord_m1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e3 + end module psb_m_ip_reord_mod diff --git a/base/modules/auxil/psb_s_ip_reord_mod.F90 b/base/modules/auxil/psb_s_ip_reord_mod.F90 index 42d1a435d..1b291d502 100644 --- a/base/modules/auxil/psb_s_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_s_ip_reord_mod.F90 @@ -40,20 +40,23 @@ module psb_s_ip_reord_mod use psb_const_mod interface psb_ip_reord - module procedure psb_ip_reord_s1,& - & psb_ip_reord_s1i1, psb_ip_reord_s1i2,& - & psb_ip_reord_s1i3 + module procedure psb_ip_reord_s1m,& + & psb_ip_reord_s1m1, psb_ip_reord_s1m2,& + & psb_ip_reord_s1m3 + module procedure psb_ip_reord_s1e,& + & psb_ip_reord_s1e1, psb_ip_reord_s1e2,& + & psb_ip_reord_s1e3 end interface contains - subroutine psb_ip_reord_s1(n,x,iaux) + subroutine psb_ip_reord_s1m(n,x,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_spk_) :: x(*) - integer(psb_ipk_) :: lswap, lp, k + integer(psb_mpk_) :: lswap, lp, k real(psb_spk_) :: swap lp = iaux(0) @@ -74,14 +77,14 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_s1 + end subroutine psb_ip_reord_s1m - subroutine psb_ip_reord_s1i1(n,x,indx,iaux) + subroutine psb_ip_reord_s1m1(n,x,indx,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_spk_) :: x(*) - integer(psb_ipk_) :: indx(*) - integer(psb_ipk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap real(psb_spk_) :: swap lp = iaux(0) @@ -105,16 +108,16 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_s1i1 + end subroutine psb_ip_reord_s1m1 - subroutine psb_ip_reord_s1i2(n,x,i1,i2,iaux) + subroutine psb_ip_reord_s1m2(n,x,i1,i2,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) + integer(psb_mpk_) :: i1(*), i2(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 real(psb_spk_) :: swap lp = iaux(0) @@ -141,15 +144,15 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_s1i2 + end subroutine psb_ip_reord_s1m2 - subroutine psb_ip_reord_s1i3(n,x,i1,i2,i3,iaux) + subroutine psb_ip_reord_s1m3(n,x,i1,i2,i3,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) real(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 real(psb_spk_) :: swap lp = iaux(0) @@ -179,6 +182,139 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_s1i3 + end subroutine psb_ip_reord_s1m3 + + + subroutine psb_ip_reord_s1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e + + subroutine psb_ip_reord_s1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e1 + + subroutine psb_ip_reord_s1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e2 + subroutine psb_ip_reord_s1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e3 + end module psb_s_ip_reord_mod diff --git a/base/modules/auxil/psb_z_ip_reord_mod.F90 b/base/modules/auxil/psb_z_ip_reord_mod.F90 index fb35f792f..f8ddc182c 100644 --- a/base/modules/auxil/psb_z_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_z_ip_reord_mod.F90 @@ -40,20 +40,23 @@ module psb_z_ip_reord_mod use psb_const_mod interface psb_ip_reord - module procedure psb_ip_reord_z1,& - & psb_ip_reord_z1i1, psb_ip_reord_z1i2,& - & psb_ip_reord_z1i3 + module procedure psb_ip_reord_z1m,& + & psb_ip_reord_z1m1, psb_ip_reord_z1m2,& + & psb_ip_reord_z1m3 + module procedure psb_ip_reord_z1e,& + & psb_ip_reord_z1e1, psb_ip_reord_z1e2,& + & psb_ip_reord_z1e3 end interface contains - subroutine psb_ip_reord_z1(n,x,iaux) + subroutine psb_ip_reord_z1m(n,x,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_dpk_) :: x(*) - integer(psb_ipk_) :: lswap, lp, k + integer(psb_mpk_) :: lswap, lp, k complex(psb_dpk_) :: swap lp = iaux(0) @@ -74,14 +77,14 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_z1 + end subroutine psb_ip_reord_z1m - subroutine psb_ip_reord_z1i1(n,x,indx,iaux) + subroutine psb_ip_reord_z1m1(n,x,indx,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_dpk_) :: x(*) - integer(psb_ipk_) :: indx(*) - integer(psb_ipk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap complex(psb_dpk_) :: swap lp = iaux(0) @@ -105,16 +108,16 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_z1i1 + end subroutine psb_ip_reord_z1m1 - subroutine psb_ip_reord_z1i2(n,x,i1,i2,iaux) + subroutine psb_ip_reord_z1m2(n,x,i1,i2,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) + integer(psb_mpk_) :: i1(*), i2(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 complex(psb_dpk_) :: swap lp = iaux(0) @@ -141,15 +144,15 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_z1i2 + end subroutine psb_ip_reord_z1m2 - subroutine psb_ip_reord_z1i3(n,x,i1,i2,i3,iaux) + subroutine psb_ip_reord_z1m3(n,x,i1,i2,i3,iaux) integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) + integer(psb_mpk_) :: iaux(0:*) complex(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 complex(psb_dpk_) :: swap lp = iaux(0) @@ -179,6 +182,139 @@ contains k = k + 1 enddo return - end subroutine psb_ip_reord_z1i3 + end subroutine psb_ip_reord_z1m3 + + + subroutine psb_ip_reord_z1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e + + subroutine psb_ip_reord_z1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e1 + + subroutine psb_ip_reord_z1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e2 + subroutine psb_ip_reord_z1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e3 + end module psb_z_ip_reord_mod diff --git a/base/modules/serial/psb_c_base_mat_mod.f90 b/base/modules/serial/psb_c_base_mat_mod.f90 index b2cf6e9e6..f320bd0e6 100644 --- a/base/modules/serial/psb_c_base_mat_mod.f90 +++ b/base/modules/serial/psb_c_base_mat_mod.f90 @@ -276,6 +276,9 @@ module psb_c_base_mat_mod procedure, pass(a) :: clone => psb_lc_base_clone procedure, pass(a) :: make_nonunit => psb_lc_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_lc_base_clean_zeros + procedure, pass(a) :: scals => psb_lc_base_scals + procedure, pass(a) :: scalv => psb_lc_base_scal + generic, public :: scal => scals, scalv ! ! Convert internal indices ! @@ -296,31 +299,6 @@ module psb_c_base_mat_mod procedure, pass(a) :: transc_1mat => psb_lc_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_lc_base_transc_2mat - ! - ! Computational methods: defined here but not implemented. - ! - procedure, pass(a) :: vect_mv => psb_lc_base_vect_mv - procedure, pass(a) :: csmv => psb_lc_base_csmv - procedure, pass(a) :: csmm => psb_lc_base_csmm - generic, public :: spmm => csmm, csmv, vect_mv - procedure, pass(a) :: in_vect_sv => psb_lc_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_lc_base_inner_cssv - procedure, pass(a) :: inner_cssm => psb_lc_base_inner_cssm - generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv - procedure, pass(a) :: vect_cssv => psb_lc_base_vect_cssv - procedure, pass(a) :: cssv => psb_lc_base_cssv - procedure, pass(a) :: cssm => psb_lc_base_cssm - generic, public :: spsm => cssm, cssv, vect_cssv - procedure, pass(a) :: scals => psb_lc_base_scals - procedure, pass(a) :: scalv => psb_lc_base_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: maxval => psb_lc_base_maxval - procedure, pass(a) :: spnmi => psb_lc_base_csnmi - procedure, pass(a) :: spnm1 => psb_lc_base_csnm1 - procedure, pass(a) :: rowsum => psb_lc_base_rowsum - procedure, pass(a) :: arwsum => psb_lc_base_arwsum - procedure, pass(a) :: colsum => psb_lc_base_colsum - procedure, pass(a) :: aclsum => psb_lc_base_aclsum end type psb_lc_base_sparse_mat private :: lc_base_mat_sync, lc_base_mat_is_host, lc_base_mat_is_dev, & @@ -388,6 +366,8 @@ module psb_c_base_mat_mod procedure, pass(a) :: set_by_cols => lc_coo_set_by_cols procedure, pass(a) :: set_sort_status => lc_coo_set_sort_status procedure, pass(a) :: get_sort_status => lc_coo_get_sort_status + procedure, pass(a) :: scals => psb_lc_coo_scals + procedure, pass(a) :: scalv => psb_lc_coo_scal ! ! This is COO specific @@ -402,22 +382,6 @@ module psb_c_base_mat_mod procedure, pass(a) :: transp_1mat => lc_coo_transp_1mat procedure, pass(a) :: transc_1mat => lc_coo_transc_1mat - ! - ! Computational methods. - ! - procedure, pass(a) :: csmm => psb_lc_coo_csmm - procedure, pass(a) :: csmv => psb_lc_coo_csmv - procedure, pass(a) :: inner_cssm => psb_lc_coo_cssm - procedure, pass(a) :: inner_cssv => psb_lc_coo_cssv - procedure, pass(a) :: scals => psb_lc_coo_scals - procedure, pass(a) :: scalv => psb_lc_coo_scal - procedure, pass(a) :: maxval => psb_lc_coo_maxval - procedure, pass(a) :: spnmi => psb_lc_coo_csnmi - procedure, pass(a) :: spnm1 => psb_lc_coo_csnm1 - procedure, pass(a) :: rowsum => psb_lc_coo_rowsum - procedure, pass(a) :: arwsum => psb_lc_coo_arwsum - procedure, pass(a) :: colsum => psb_lc_coo_colsum - procedure, pass(a) :: aclsum => psb_lc_coo_aclsum end type psb_lc_coo_sparse_mat @@ -2756,6 +2720,43 @@ module psb_c_base_mat_mod end subroutine psb_lc_base_clean_zeros end interface + ! + !> Function base_scals: + !! \memberof psb_lc_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_lc_base_scals(d,a,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_lc_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_lc_base_scal(d,a,info,side) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_base_scal + end interface + + ! !> Function transp: !! \memberof psb_lc_base_sparse_mat @@ -2816,554 +2817,119 @@ module psb_c_base_mat_mod end subroutine psb_lc_base_transc_1mat end interface + ! == =============== ! - !> Function csmm: - !! \memberof psb_lc_base_sparse_mat - !! \brief Product by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! COO interfaces ! - interface - subroutine psb_lc_base_csmm(alpha,a,x,beta,y,info,trans) + ! == =============== + + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_lc_coo_reallocate_nz(nz,a) import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_base_csmm + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lc_coo_reallocate_nz end interface - !> Function csmv: - !! \memberof psb_lc_base_sparse_mat - !! \brief Product by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit ! interface - subroutine psb_lc_base_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_lc_coo_reinit(a,clear) import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_base_csmv + class(psb_lc_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lc_coo_reinit end interface - - !> Function vect_mv: - !! \memberof psb_lc_base_sparse_mat - !! \brief Product by an encapsulated array type(psb_lc_vect_type) - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! Usually the unwrapping of the encapsulated vector is done - !! here, so that all the derived classes need only the - !! versions with the standard arrays. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input X - !! \param beta Scaling factor for y - !! \param y the input/output Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! ! - interface - subroutine psb_lc_base_vect_mv(alpha,a,x,beta,y,info,trans) + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_lc_coo_trim(a) import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - class(psb_c_base_vect_type), intent(inout) :: x - class(psb_c_base_vect_type), intent(inout) :: y + class(psb_lc_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lc_coo_trim + end interface + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros + ! + interface + subroutine psb_lc_coo_clean_zeros(a,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_base_vect_mv + end subroutine psb_lc_coo_clean_zeros end interface ! - !> Function cssm: - !! \memberof psb_lc_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssm. - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! + interface + subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lc_coo_allocate_mnnz + end interface + + + !> \memberof psb_lc_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface - subroutine psb_lc_base_inner_cssm(alpha,a,x,beta,y,info,trans) + subroutine psb_lc_coo_mold(a,b,info) import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_base_inner_cssm + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_coo_mold end interface ! - !> Function cssv: - !! \memberof psb_lc_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssv. + !> Function print. + !! \memberof psb_lc_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering !! ! - interface - subroutine psb_lc_base_inner_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_base_inner_cssv + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_coo_print end interface + + ! - !> Function inner_vect_cssv: - !! \memberof psb_lc_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_lc_vect_type) + !> Function get_nz_row. + !! \memberof psb_lc_coo_sparse_mat + !! \brief How many nonzeros in a row? !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by vect_cssv. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - ! - interface - subroutine psb_lc_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - class(psb_c_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_base_inner_vect_sv - end interface - - ! - !> Function cssm: - !! \memberof psb_lc_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_lc_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_lc_base_cssm - end interface - - ! - !> Function cssv: - !! \memberof psb_lc_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_lc_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_lc_base_cssv - end interface - - ! - !> Function vect_cssv: - !! \memberof psb_lc_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_lc_vect_type) - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_lc_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - class(psb_c_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_c_base_vect_type), optional, intent(inout) :: d - end subroutine psb_lc_base_vect_cssv - end interface - - ! - !> Function base_scals: - !! \memberof psb_lc_base_sparse_mat - !! \brief Scale a matrix by a single scalar value - !! - !! \param d Scaling factor - !! \param info return code - ! - interface - subroutine psb_lc_base_scals(d,a,info) - import - class(psb_lc_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lc_base_scals - end interface - - ! - !> Function base_scal: - !! \memberof psb_lc_base_sparse_mat - !! \brief Scale a matrix by a vector - !! - !! \param d(:) Scaling vector - !! \param info return code - !! \param side [L] Scale on the Left (rows) or on the Right (columns) - ! - interface - subroutine psb_lc_base_scal(d,a,info,side) - import - class(psb_lc_base_sparse_mat), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_lc_base_scal - end interface - - ! - !> Function base_maxval: - !! \memberof psb_lc_base_sparse_mat - !! \brief Maximum absolute value of all coefficients; - !! - ! - interface - function psb_lc_base_maxval(a) result(res) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_lc_base_maxval - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_lc_base_sparse_mat - !! \brief Operator infinity norm - !! - ! - interface - function psb_lc_base_csnmi(a) result(res) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_lc_base_csnmi - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_lc_base_sparse_mat - !! \brief Operator 1-norm - !! - ! - interface - function psb_lc_base_csnm1(a) result(res) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_lc_base_csnm1 - end interface - - ! - ! - !> Function base_rowsum: - !! \memberof psb_lc_base_sparse_mat - !! \brief Sum along the rows - !! \param d(:) The output row sums - !! - ! - interface - subroutine psb_lc_base_rowsum(d,a) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_base_rowsum - end interface - - ! - !> Function base_arwsum: - !! \memberof psb_lc_base_sparse_mat - !! \brief Absolute value sum along the rows - !! \param d(:) The output row sums - !! - interface - subroutine psb_lc_base_arwsum(d,a) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_base_arwsum - end interface - - ! - ! - !> Function base_colsum: - !! \memberof psb_lc_base_sparse_mat - !! \brief Sum along the columns - !! \param d(:) The output col sums - !! - ! - interface - subroutine psb_lc_base_colsum(d,a) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_base_colsum - end interface - - ! - !> Function base_aclsum: - !! \memberof psb_lc_base_sparse_mat - !! \brief Absolute value sum along the columns - !! \param d(:) The output col sums - !! - interface - subroutine psb_lc_base_aclsum(d,a) - import - class(psb_lc_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_base_aclsum - end interface - - - ! == =============== - ! - ! COO interfaces - ! - ! == =============== - - ! - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reallocate_nz - ! - interface - subroutine psb_lc_coo_reallocate_nz(nz,a) - import - integer(psb_lpk_), intent(in) :: nz - class(psb_lc_coo_sparse_mat), intent(inout) :: a - end subroutine psb_lc_coo_reallocate_nz - end interface - - ! - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reinit - ! - interface - subroutine psb_lc_coo_reinit(a,clear) - import - class(psb_lc_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_lc_coo_reinit - end interface - ! - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_trim - ! - interface - subroutine psb_lc_coo_trim(a) - import - class(psb_lc_coo_sparse_mat), intent(inout) :: a - end subroutine psb_lc_coo_trim - end interface - ! - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros - ! - interface - subroutine psb_lc_coo_clean_zeros(a,info) - import - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lc_coo_clean_zeros - end interface - - ! - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_allocate_mnnz - ! - interface - subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) - import - integer(psb_lpk_), intent(in) :: m,n - class(psb_lc_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_lc_coo_allocate_mnnz - end interface - - - !> \memberof psb_lc_coo_sparse_mat - !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lc_coo_mold(a,b,info) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lc_coo_mold - end interface - - - ! - !> Function print. - !! \memberof psb_lc_coo_sparse_mat - !! \brief Print the matrix to file in MatrixMarket format - !! - !! \param iout The unit to write to - !! \param iv [none] Renumbering for both rows and columns - !! \param head [none] Descriptive header for the file - !! \param ivr [none] Row renumbering - !! \param ivc [none] Col renumbering - !! - ! - interface - subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) - import - integer(psb_ipk_), intent(in) :: iout - class(psb_lc_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_lc_coo_print - end interface - - - - ! - !> Function get_nz_row. - !! \memberof psb_lc_coo_sparse_mat - !! \brief How many nonzeros in a row? - !! - !! \param idx The row to search. + !! \param idx The row to search. !! ! interface @@ -3627,138 +3193,6 @@ module psb_c_base_mat_mod end subroutine psb_lc_coo_csgetrow end interface - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_cssv - interface - subroutine psb_lc_coo_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_coo_cssv - end interface - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_cssm - interface - subroutine psb_lc_coo_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_coo_cssm - end interface - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_csmv - interface - subroutine psb_lc_coo_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_coo_csmv - end interface - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_csmm - interface - subroutine psb_lc_coo_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lc_coo_csmm - end interface - - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_maxval - interface - function psb_lc_coo_maxval(a) result(res) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_lc_coo_maxval - end interface - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_csnmi - interface - function psb_lc_coo_csnmi(a) result(res) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_lc_coo_csnmi - end interface - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_csnm1 - interface - function psb_lc_coo_csnm1(a) result(res) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_lc_coo_csnm1 - end interface - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_rowsum - interface - subroutine psb_lc_coo_rowsum(d,a) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_coo_rowsum - end interface - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_arwsum - interface - subroutine psb_lc_coo_arwsum(d,a) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_coo_arwsum - end interface - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_colsum - interface - subroutine psb_lc_coo_colsum(d,a) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - complex(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_coo_colsum - end interface - - !> - !! \memberof psb_lc_coo_sparse_mat - !! \see psb_lc_base_mat_mod::psb_lc_base_aclsum - interface - subroutine psb_lc_coo_aclsum(d,a) - import - class(psb_lc_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_lc_coo_aclsum - end interface - !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag @@ -3771,6 +3205,7 @@ module psb_c_base_mat_mod end subroutine psb_lc_coo_get_diag end interface + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scal @@ -3796,7 +3231,6 @@ module psb_c_base_mat_mod end subroutine psb_lc_coo_scals end interface - contains @@ -3818,7 +3252,7 @@ contains implicit none class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -4042,7 +3476,7 @@ contains implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_lp res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) diff --git a/base/modules/serial/psb_c_csr_mat_mod.f90 b/base/modules/serial/psb_c_csr_mat_mod.f90 index da161b388..30ddaefce 100644 --- a/base/modules/serial/psb_c_csr_mat_mod.f90 +++ b/base/modules/serial/psb_c_csr_mat_mod.f90 @@ -495,6 +495,334 @@ module psb_c_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_lc_csr_sparse_mat + !! \extends psb_lc_base_mat_mod::psb_lc_base_sparse_mat + !! + !! psb_lc_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_lc_base_sparse_mat) :: psb_lc_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + complex(psb_spk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => lc_csr_is_by_rows + procedure, pass(a) :: get_size => lc_csr_get_size + procedure, pass(a) :: get_nzeros => lc_csr_get_nzeros + procedure, nopass :: get_fmt => lc_csr_get_fmt + procedure, pass(a) :: sizeof => lc_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_lc_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lc_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_lc_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_lc_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lc_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lc_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lc_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_lc_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lc_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lc_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_lc_csr_csput_a + procedure, pass(a) :: get_diag => psb_lc_csr_get_diag + procedure, pass(a) :: csgetptn => psb_lc_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_lc_csr_csgetrow + procedure, pass(a) :: get_nz_row => lc_csr_get_nz_row + procedure, pass(a) :: reinit => psb_lc_csr_reinit + procedure, pass(a) :: trim => psb_lc_csr_trim + procedure, pass(a) :: print => psb_lc_csr_print + procedure, pass(a) :: free => lc_csr_free + procedure, pass(a) :: mold => psb_lc_csr_mold + procedure, pass(a) :: scals => psb_lc_csr_scals + procedure, pass(a) :: scalv => psb_lc_csr_scal + + end type psb_lc_csr_sparse_mat + + private :: lc_csr_get_nzeros, lc_csr_free, lc_csr_get_fmt, & + & lc_csr_get_size, lc_csr_sizeof, lc_csr_get_nz_row, & + & lc_csr_is_by_rows + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_lc_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lc_csr_reallocate_nz + end interface + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_lc_csr_reinit(a,clear) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lc_csr_reinit + end interface + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_lc_csr_trim(a) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lc_csr_trim + end interface + + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lc_csr_mold(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csr_mold + end interface + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lc_csr_allocate_mnnz + end interface + + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_print + interface + subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_csr_print + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo + interface + subroutine psb_lc_cp_csr_to_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_to_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo + interface + subroutine psb_lc_cp_csr_from_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_from_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_fmt + interface + subroutine psb_lc_cp_csr_to_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_to_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_fmt + interface + subroutine psb_lc_cp_csr_from_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_from_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_coo + interface + subroutine psb_lc_mv_csr_to_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_to_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_coo + interface + subroutine psb_lc_mv_csr_from_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_from_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_fmt + interface + subroutine psb_lc_mv_csr_to_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_to_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_fmt + interface + subroutine psb_lc_mv_csr_from_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_from_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from + interface + subroutine psb_lc_csr_cp_from(a,b) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + type(psb_lc_csr_sparse_mat), intent(in) :: b + end subroutine psb_lc_csr_cp_from + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from + interface + subroutine psb_lc_csr_mv_from(a,b) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + type(psb_lc_csr_sparse_mat), intent(inout) :: b + end subroutine psb_lc_csr_mv_from + end interface + + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csput_a + interface + subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_csr_csput_a + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csr_csgetptn + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csgetrow + interface + subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csr_csgetrow + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csgetblk + interface + subroutine psb_lc_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csr_csgetblk + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag + interface + subroutine psb_lc_csr_get_diag(a,d,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csr_get_diag + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scal + interface + subroutine psb_lc_csr_scal(d,a,info,side) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_csr_scal + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scals + interface + subroutine psb_lc_csr_scals(d,a,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csr_scals + end interface + + contains @@ -525,7 +853,7 @@ contains implicit none class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -614,4 +942,120 @@ contains end subroutine c_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function lc_csr_is_by_rows(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function lc_csr_is_by_rows + + + function lc_csr_sizeof(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + (2*psb_sizeof_sp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function lc_csr_sizeof + + function lc_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function lc_csr_get_fmt + + function lc_csr_get_nzeros(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function lc_csr_get_nzeros + + function lc_csr_get_size(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function lc_csr_get_size + + + + function lc_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function lc_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine lc_csr_free(a) + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine lc_csr_free + end module psb_c_csr_mat_mod diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index f2700d7c6..befc89c6a 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -72,8 +72,8 @@ module psb_c_mat_mod use psb_c_base_mat_mod - use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat - use psb_c_csc_mat_mod, only : psb_c_csc_sparse_mat + use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat, psb_lc_csr_sparse_mat + use psb_c_csc_mat_mod, only : psb_c_csc_sparse_mat type :: psb_cspmat_type diff --git a/base/modules/serial/psb_c_serial_mod.f90 b/base/modules/serial/psb_c_serial_mod.f90 index 1aef3e846..5e25a0354 100644 --- a/base/modules/serial/psb_c_serial_mod.f90 +++ b/base/modules/serial/psb_c_serial_mod.f90 @@ -203,6 +203,69 @@ module psb_c_serial_mod end subroutine psb_c_aspxpby end interface psb_aspxpby + interface psb_spspmm +!!$ subroutine psb_cspspmm(a,b,c,info) +!!$ use psb_c_mat_mod, only : psb_cspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_cspmat_type), intent(in) :: a,b +!!$ type(psb_cspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_cspspmm + subroutine psb_lccsrspspmm(a,b,c,info) + use psb_c_mat_mod, only : psb_lc_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lccsrspspmm +!!$ subroutine psb_ccscspspmm(a,b,c,info) +!!$ use psb_c_mat_mod, only : psb_c_csc_sparse_mat +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ class(psb_c_csc_sparse_mat), intent(in) :: a,b +!!$ type(psb_c_csc_sparse_mat), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_ccscspspmm + end interface psb_spspmm + + interface psb_symbmm +!!$ subroutine psb_csymbmm(a,b,c,info) +!!$ use psb_c_mat_mod, only : psb_cspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_cspmat_type), intent(in) :: a,b +!!$ type(psb_cspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_csymbmm + subroutine psb_lcbase_symbmm(a,b,c,info) + use psb_c_mat_mod, only : psb_lc_base_sparse_mat, psb_lc_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcbase_symbmm + end interface psb_symbmm + + interface psb_numbmm +!!$ subroutine psb_cnumbmm(a,b,c) +!!$ use psb_c_mat_mod, only : psb_cspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_cspmat_type), intent(in) :: a,b +!!$ type(psb_cspmat_type), intent(inout) :: c +!!$ end subroutine psb_cnumbmm + subroutine psb_lcbase_numbmm(a,b,c) + use psb_c_mat_mod, only : psb_lc_base_sparse_mat, psb_lc_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(inout) :: c + end subroutine psb_lcbase_numbmm + end interface psb_numbmm + contains subroutine psb_ccsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/modules/serial/psb_d_base_mat_mod.f90 b/base/modules/serial/psb_d_base_mat_mod.f90 index 47242f269..81f60c21c 100644 --- a/base/modules/serial/psb_d_base_mat_mod.f90 +++ b/base/modules/serial/psb_d_base_mat_mod.f90 @@ -276,6 +276,9 @@ module psb_d_base_mat_mod procedure, pass(a) :: clone => psb_ld_base_clone procedure, pass(a) :: make_nonunit => psb_ld_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_ld_base_clean_zeros + procedure, pass(a) :: scals => psb_ld_base_scals + procedure, pass(a) :: scalv => psb_ld_base_scal + generic, public :: scal => scals, scalv ! ! Convert internal indices ! @@ -296,31 +299,6 @@ module psb_d_base_mat_mod procedure, pass(a) :: transc_1mat => psb_ld_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_ld_base_transc_2mat - ! - ! Computational methods: defined here but not implemented. - ! - procedure, pass(a) :: vect_mv => psb_ld_base_vect_mv - procedure, pass(a) :: csmv => psb_ld_base_csmv - procedure, pass(a) :: csmm => psb_ld_base_csmm - generic, public :: spmm => csmm, csmv, vect_mv - procedure, pass(a) :: in_vect_sv => psb_ld_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_ld_base_inner_cssv - procedure, pass(a) :: inner_cssm => psb_ld_base_inner_cssm - generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv - procedure, pass(a) :: vect_cssv => psb_ld_base_vect_cssv - procedure, pass(a) :: cssv => psb_ld_base_cssv - procedure, pass(a) :: cssm => psb_ld_base_cssm - generic, public :: spsm => cssm, cssv, vect_cssv - procedure, pass(a) :: scals => psb_ld_base_scals - procedure, pass(a) :: scalv => psb_ld_base_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: maxval => psb_ld_base_maxval - procedure, pass(a) :: spnmi => psb_ld_base_csnmi - procedure, pass(a) :: spnm1 => psb_ld_base_csnm1 - procedure, pass(a) :: rowsum => psb_ld_base_rowsum - procedure, pass(a) :: arwsum => psb_ld_base_arwsum - procedure, pass(a) :: colsum => psb_ld_base_colsum - procedure, pass(a) :: aclsum => psb_ld_base_aclsum end type psb_ld_base_sparse_mat private :: ld_base_mat_sync, ld_base_mat_is_host, ld_base_mat_is_dev, & @@ -388,6 +366,8 @@ module psb_d_base_mat_mod procedure, pass(a) :: set_by_cols => ld_coo_set_by_cols procedure, pass(a) :: set_sort_status => ld_coo_set_sort_status procedure, pass(a) :: get_sort_status => ld_coo_get_sort_status + procedure, pass(a) :: scals => psb_ld_coo_scals + procedure, pass(a) :: scalv => psb_ld_coo_scal ! ! This is COO specific @@ -402,22 +382,6 @@ module psb_d_base_mat_mod procedure, pass(a) :: transp_1mat => ld_coo_transp_1mat procedure, pass(a) :: transc_1mat => ld_coo_transc_1mat - ! - ! Computational methods. - ! - procedure, pass(a) :: csmm => psb_ld_coo_csmm - procedure, pass(a) :: csmv => psb_ld_coo_csmv - procedure, pass(a) :: inner_cssm => psb_ld_coo_cssm - procedure, pass(a) :: inner_cssv => psb_ld_coo_cssv - procedure, pass(a) :: scals => psb_ld_coo_scals - procedure, pass(a) :: scalv => psb_ld_coo_scal - procedure, pass(a) :: maxval => psb_ld_coo_maxval - procedure, pass(a) :: spnmi => psb_ld_coo_csnmi - procedure, pass(a) :: spnm1 => psb_ld_coo_csnm1 - procedure, pass(a) :: rowsum => psb_ld_coo_rowsum - procedure, pass(a) :: arwsum => psb_ld_coo_arwsum - procedure, pass(a) :: colsum => psb_ld_coo_colsum - procedure, pass(a) :: aclsum => psb_ld_coo_aclsum end type psb_ld_coo_sparse_mat @@ -2756,6 +2720,43 @@ module psb_d_base_mat_mod end subroutine psb_ld_base_clean_zeros end interface + ! + !> Function base_scals: + !! \memberof psb_ld_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_ld_base_scals(d,a,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_ld_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_ld_base_scal(d,a,info,side) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_base_scal + end interface + + ! !> Function transp: !! \memberof psb_ld_base_sparse_mat @@ -2816,554 +2817,119 @@ module psb_d_base_mat_mod end subroutine psb_ld_base_transc_1mat end interface + ! == =============== ! - !> Function csmm: - !! \memberof psb_ld_base_sparse_mat - !! \brief Product by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! COO interfaces ! - interface - subroutine psb_ld_base_csmm(alpha,a,x,beta,y,info,trans) + ! == =============== + + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_ld_coo_reallocate_nz(nz,a) import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_csmm + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ld_coo_reallocate_nz end interface - !> Function csmv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Product by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit ! interface - subroutine psb_ld_base_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_ld_coo_reinit(a,clear) import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_csmv + class(psb_ld_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ld_coo_reinit end interface - - !> Function vect_mv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Product by an encapsulated array type(psb_ld_vect_type) - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! Usually the unwrapping of the encapsulated vector is done - !! here, so that all the derived classes need only the - !! versions with the standard arrays. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input X - !! \param beta Scaling factor for y - !! \param y the input/output Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! ! - interface - subroutine psb_ld_base_vect_mv(alpha,a,x,beta,y,info,trans) + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_ld_coo_trim(a) import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_d_base_vect_type), intent(inout) :: y + class(psb_ld_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ld_coo_trim + end interface + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros + ! + interface + subroutine psb_ld_coo_clean_zeros(a,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_vect_mv + end subroutine psb_ld_coo_clean_zeros end interface ! - !> Function cssm: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssm. - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! + interface + subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ld_coo_allocate_mnnz + end interface + + + !> \memberof psb_ld_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface - subroutine psb_ld_base_inner_cssm(alpha,a,x,beta,y,info,trans) + subroutine psb_ld_coo_mold(a,b,info) import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_inner_cssm + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_coo_mold end interface ! - !> Function cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssv. + !> Function print. + !! \memberof psb_ld_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering !! ! - interface - subroutine psb_ld_base_inner_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_inner_cssv + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_coo_print end interface + + ! - !> Function inner_vect_cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_ld_vect_type) + !> Function get_nz_row. + !! \memberof psb_ld_coo_sparse_mat + !! \brief How many nonzeros in a row? !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by vect_cssv. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - ! - interface - subroutine psb_ld_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_base_inner_vect_sv - end interface - - ! - !> Function cssm: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ld_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_ld_base_cssm - end interface - - ! - !> Function cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ld_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_ld_base_cssv - end interface - - ! - !> Function vect_cssv: - !! \memberof psb_ld_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_ld_vect_type) - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ld_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - class(psb_d_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_d_base_vect_type), optional, intent(inout) :: d - end subroutine psb_ld_base_vect_cssv - end interface - - ! - !> Function base_scals: - !! \memberof psb_ld_base_sparse_mat - !! \brief Scale a matrix by a single scalar value - !! - !! \param d Scaling factor - !! \param info return code - ! - interface - subroutine psb_ld_base_scals(d,a,info) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_base_scals - end interface - - ! - !> Function base_scal: - !! \memberof psb_ld_base_sparse_mat - !! \brief Scale a matrix by a vector - !! - !! \param d(:) Scaling vector - !! \param info return code - !! \param side [L] Scale on the Left (rows) or on the Right (columns) - ! - interface - subroutine psb_ld_base_scal(d,a,info,side) - import - class(psb_ld_base_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_ld_base_scal - end interface - - ! - !> Function base_maxval: - !! \memberof psb_ld_base_sparse_mat - !! \brief Maximum absolute value of all coefficients; - !! - ! - interface - function psb_ld_base_maxval(a) result(res) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_base_maxval - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_ld_base_sparse_mat - !! \brief Operator infinity norm - !! - ! - interface - function psb_ld_base_csnmi(a) result(res) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_base_csnmi - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_ld_base_sparse_mat - !! \brief Operator 1-norm - !! - ! - interface - function psb_ld_base_csnm1(a) result(res) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_base_csnm1 - end interface - - ! - ! - !> Function base_rowsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Sum along the rows - !! \param d(:) The output row sums - !! - ! - interface - subroutine psb_ld_base_rowsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_rowsum - end interface - - ! - !> Function base_arwsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Absolute value sum along the rows - !! \param d(:) The output row sums - !! - interface - subroutine psb_ld_base_arwsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_arwsum - end interface - - ! - ! - !> Function base_colsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Sum along the columns - !! \param d(:) The output col sums - !! - ! - interface - subroutine psb_ld_base_colsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_colsum - end interface - - ! - !> Function base_aclsum: - !! \memberof psb_ld_base_sparse_mat - !! \brief Absolute value sum along the columns - !! \param d(:) The output col sums - !! - interface - subroutine psb_ld_base_aclsum(d,a) - import - class(psb_ld_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_base_aclsum - end interface - - - ! == =============== - ! - ! COO interfaces - ! - ! == =============== - - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reallocate_nz - ! - interface - subroutine psb_ld_coo_reallocate_nz(nz,a) - import - integer(psb_lpk_), intent(in) :: nz - class(psb_ld_coo_sparse_mat), intent(inout) :: a - end subroutine psb_ld_coo_reallocate_nz - end interface - - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reinit - ! - interface - subroutine psb_ld_coo_reinit(a,clear) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_ld_coo_reinit - end interface - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_trim - ! - interface - subroutine psb_ld_coo_trim(a) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - end subroutine psb_ld_coo_trim - end interface - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros - ! - interface - subroutine psb_ld_coo_clean_zeros(a,info) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_coo_clean_zeros - end interface - - ! - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_allocate_mnnz - ! - interface - subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) - import - integer(psb_lpk_), intent(in) :: m,n - class(psb_ld_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_ld_coo_allocate_mnnz - end interface - - - !> \memberof psb_ld_coo_sparse_mat - !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ld_coo_mold(a,b,info) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ld_coo_mold - end interface - - - ! - !> Function print. - !! \memberof psb_ld_coo_sparse_mat - !! \brief Print the matrix to file in MatrixMarket format - !! - !! \param iout The unit to write to - !! \param iv [none] Renumbering for both rows and columns - !! \param head [none] Descriptive header for the file - !! \param ivr [none] Row renumbering - !! \param ivc [none] Col renumbering - !! - ! - interface - subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) - import - integer(psb_ipk_), intent(in) :: iout - class(psb_ld_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_ld_coo_print - end interface - - - - ! - !> Function get_nz_row. - !! \memberof psb_ld_coo_sparse_mat - !! \brief How many nonzeros in a row? - !! - !! \param idx The row to search. + !! \param idx The row to search. !! ! interface @@ -3627,138 +3193,6 @@ module psb_d_base_mat_mod end subroutine psb_ld_coo_csgetrow end interface - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssv - interface - subroutine psb_ld_coo_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_cssv - end interface - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_cssm - interface - subroutine psb_ld_coo_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_cssm - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmv - interface - subroutine psb_ld_coo_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_csmv - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csmm - interface - subroutine psb_ld_coo_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ld_coo_csmm - end interface - - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_maxval - interface - function psb_ld_coo_maxval(a) result(res) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_coo_maxval - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csnmi - interface - function psb_ld_coo_csnmi(a) result(res) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_coo_csnmi - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_csnm1 - interface - function psb_ld_coo_csnm1(a) result(res) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_ld_coo_csnm1 - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_rowsum - interface - subroutine psb_ld_coo_rowsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_rowsum - end interface - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_arwsum - interface - subroutine psb_ld_coo_arwsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_arwsum - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_colsum - interface - subroutine psb_ld_coo_colsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_colsum - end interface - - !> - !! \memberof psb_ld_coo_sparse_mat - !! \see psb_ld_base_mat_mod::psb_ld_base_aclsum - interface - subroutine psb_ld_coo_aclsum(d,a) - import - class(psb_ld_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_ld_coo_aclsum - end interface - !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag @@ -3771,6 +3205,7 @@ module psb_d_base_mat_mod end subroutine psb_ld_coo_get_diag end interface + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scal @@ -3796,7 +3231,6 @@ module psb_d_base_mat_mod end subroutine psb_ld_coo_scals end interface - contains @@ -3818,7 +3252,7 @@ contains implicit none class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -4042,7 +3476,7 @@ contains implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_lp res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) diff --git a/base/modules/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index 0e66c80b9..0bb90e0d8 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -495,6 +495,334 @@ module psb_d_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat + !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat + !! + !! psb_ld_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_ld_base_sparse_mat) :: psb_ld_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + real(psb_dpk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => ld_csr_is_by_rows + procedure, pass(a) :: get_size => ld_csr_get_size + procedure, pass(a) :: get_nzeros => ld_csr_get_nzeros + procedure, nopass :: get_fmt => ld_csr_get_fmt + procedure, pass(a) :: sizeof => ld_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_ld_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ld_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_ld_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_ld_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ld_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ld_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ld_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_ld_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ld_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ld_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_ld_csr_csput_a + procedure, pass(a) :: get_diag => psb_ld_csr_get_diag + procedure, pass(a) :: csgetptn => psb_ld_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_ld_csr_csgetrow + procedure, pass(a) :: get_nz_row => ld_csr_get_nz_row + procedure, pass(a) :: reinit => psb_ld_csr_reinit + procedure, pass(a) :: trim => psb_ld_csr_trim + procedure, pass(a) :: print => psb_ld_csr_print + procedure, pass(a) :: free => ld_csr_free + procedure, pass(a) :: mold => psb_ld_csr_mold + procedure, pass(a) :: scals => psb_ld_csr_scals + procedure, pass(a) :: scalv => psb_ld_csr_scal + + end type psb_ld_csr_sparse_mat + + private :: ld_csr_get_nzeros, ld_csr_free, ld_csr_get_fmt, & + & ld_csr_get_size, ld_csr_sizeof, ld_csr_get_nz_row, & + & ld_csr_is_by_rows + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_ld_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ld_csr_reallocate_nz + end interface + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_ld_csr_reinit(a,clear) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ld_csr_reinit + end interface + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_ld_csr_trim(a) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ld_csr_trim + end interface + + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ld_csr_mold(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csr_mold + end interface + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ld_csr_allocate_mnnz + end interface + + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_print + interface + subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_csr_print + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo + interface + subroutine psb_ld_cp_csr_to_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_to_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo + interface + subroutine psb_ld_cp_csr_from_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_from_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_fmt + interface + subroutine psb_ld_cp_csr_to_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_to_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt + interface + subroutine psb_ld_cp_csr_from_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_from_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo + interface + subroutine psb_ld_mv_csr_to_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_to_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo + interface + subroutine psb_ld_mv_csr_from_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_from_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt + interface + subroutine psb_ld_mv_csr_to_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_to_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt + interface + subroutine psb_ld_mv_csr_from_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_from_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from + interface + subroutine psb_ld_csr_cp_from(a,b) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + type(psb_ld_csr_sparse_mat), intent(in) :: b + end subroutine psb_ld_csr_cp_from + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from + interface + subroutine psb_ld_csr_mv_from(a,b) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + type(psb_ld_csr_sparse_mat), intent(inout) :: b + end subroutine psb_ld_csr_mv_from + end interface + + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a + interface + subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_csr_csput_a + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csr_csgetptn + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow + interface + subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csr_csgetrow + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csgetblk + interface + subroutine psb_ld_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csr_csgetblk + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag + interface + subroutine psb_ld_csr_get_diag(a,d,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csr_get_diag + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scal + interface + subroutine psb_ld_csr_scal(d,a,info,side) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_csr_scal + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scals + interface + subroutine psb_ld_csr_scals(d,a,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csr_scals + end interface + + contains @@ -525,7 +853,7 @@ contains implicit none class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + res = 2 * psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -614,4 +942,120 @@ contains end subroutine d_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function ld_csr_is_by_rows(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function ld_csr_is_by_rows + + + function ld_csr_sizeof(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + psb_sizeof_dp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function ld_csr_sizeof + + function ld_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function ld_csr_get_fmt + + function ld_csr_get_nzeros(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function ld_csr_get_nzeros + + function ld_csr_get_size(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function ld_csr_get_size + + + + function ld_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function ld_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine ld_csr_free(a) + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine ld_csr_free + end module psb_d_csr_mat_mod diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index cfca7fffa..fd0a48451 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -72,8 +72,8 @@ module psb_d_mat_mod use psb_d_base_mat_mod - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat - use psb_d_csc_mat_mod, only : psb_d_csc_sparse_mat + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat + use psb_d_csc_mat_mod, only : psb_d_csc_sparse_mat type :: psb_dspmat_type diff --git a/base/modules/serial/psb_d_serial_mod.f90 b/base/modules/serial/psb_d_serial_mod.f90 index b09260909..84b4781f0 100644 --- a/base/modules/serial/psb_d_serial_mod.f90 +++ b/base/modules/serial/psb_d_serial_mod.f90 @@ -203,6 +203,69 @@ module psb_d_serial_mod end subroutine psb_d_aspxpby end interface psb_aspxpby + interface psb_spspmm +!!$ subroutine psb_dspspmm(a,b,c,info) +!!$ use psb_d_mat_mod, only : psb_dspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_dspmat_type), intent(in) :: a,b +!!$ type(psb_dspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_dspspmm + subroutine psb_ldcsrspspmm(a,b,c,info) + use psb_d_mat_mod, only : psb_ld_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldcsrspspmm +!!$ subroutine psb_dcscspspmm(a,b,c,info) +!!$ use psb_d_mat_mod, only : psb_d_csc_sparse_mat +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ class(psb_d_csc_sparse_mat), intent(in) :: a,b +!!$ type(psb_d_csc_sparse_mat), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_dcscspspmm + end interface psb_spspmm + + interface psb_symbmm +!!$ subroutine psb_dsymbmm(a,b,c,info) +!!$ use psb_d_mat_mod, only : psb_dspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_dspmat_type), intent(in) :: a,b +!!$ type(psb_dspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_dsymbmm + subroutine psb_ldbase_symbmm(a,b,c,info) + use psb_d_mat_mod, only : psb_ld_base_sparse_mat, psb_ld_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldbase_symbmm + end interface psb_symbmm + + interface psb_numbmm +!!$ subroutine psb_dnumbmm(a,b,c) +!!$ use psb_d_mat_mod, only : psb_dspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_dspmat_type), intent(in) :: a,b +!!$ type(psb_dspmat_type), intent(inout) :: c +!!$ end subroutine psb_dnumbmm + subroutine psb_ldbase_numbmm(a,b,c) + use psb_d_mat_mod, only : psb_ld_base_sparse_mat, psb_ld_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(inout) :: c + end subroutine psb_ldbase_numbmm + end interface psb_numbmm + contains subroutine psb_dcsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/modules/serial/psb_ld_csr_mat_mod.f90 b/base/modules/serial/psb_ld_csr_mat_mod.f90 index 8d9848bf0..6aec5c3d2 100644 --- a/base/modules/serial/psb_ld_csr_mat_mod.f90 +++ b/base/modules/serial/psb_ld_csr_mat_mod.f90 @@ -43,7 +43,7 @@ ! module psb_ld_csr_mat_mod - use psb_ld_base_mat_mod + use psb_d_base_mat_mod !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat @@ -525,10 +525,10 @@ contains implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + res = 2 * psb_sizeof_lp res = res + psb_sizeof_dp * psb_size(a%val) - res = res + psb_sizeof_ip * psb_size(a%irp) - res = res + psb_sizeof_ip * psb_size(a%ja) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) end function ld_csr_sizeof diff --git a/base/modules/serial/psb_s_base_mat_mod.f90 b/base/modules/serial/psb_s_base_mat_mod.f90 index 939b1ba4d..a04665afa 100644 --- a/base/modules/serial/psb_s_base_mat_mod.f90 +++ b/base/modules/serial/psb_s_base_mat_mod.f90 @@ -276,6 +276,9 @@ module psb_s_base_mat_mod procedure, pass(a) :: clone => psb_ls_base_clone procedure, pass(a) :: make_nonunit => psb_ls_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_ls_base_clean_zeros + procedure, pass(a) :: scals => psb_ls_base_scals + procedure, pass(a) :: scalv => psb_ls_base_scal + generic, public :: scal => scals, scalv ! ! Convert internal indices ! @@ -296,31 +299,6 @@ module psb_s_base_mat_mod procedure, pass(a) :: transc_1mat => psb_ls_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_ls_base_transc_2mat - ! - ! Computational methods: defined here but not implemented. - ! - procedure, pass(a) :: vect_mv => psb_ls_base_vect_mv - procedure, pass(a) :: csmv => psb_ls_base_csmv - procedure, pass(a) :: csmm => psb_ls_base_csmm - generic, public :: spmm => csmm, csmv, vect_mv - procedure, pass(a) :: in_vect_sv => psb_ls_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_ls_base_inner_cssv - procedure, pass(a) :: inner_cssm => psb_ls_base_inner_cssm - generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv - procedure, pass(a) :: vect_cssv => psb_ls_base_vect_cssv - procedure, pass(a) :: cssv => psb_ls_base_cssv - procedure, pass(a) :: cssm => psb_ls_base_cssm - generic, public :: spsm => cssm, cssv, vect_cssv - procedure, pass(a) :: scals => psb_ls_base_scals - procedure, pass(a) :: scalv => psb_ls_base_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: maxval => psb_ls_base_maxval - procedure, pass(a) :: spnmi => psb_ls_base_csnmi - procedure, pass(a) :: spnm1 => psb_ls_base_csnm1 - procedure, pass(a) :: rowsum => psb_ls_base_rowsum - procedure, pass(a) :: arwsum => psb_ls_base_arwsum - procedure, pass(a) :: colsum => psb_ls_base_colsum - procedure, pass(a) :: aclsum => psb_ls_base_aclsum end type psb_ls_base_sparse_mat private :: ls_base_mat_sync, ls_base_mat_is_host, ls_base_mat_is_dev, & @@ -388,6 +366,8 @@ module psb_s_base_mat_mod procedure, pass(a) :: set_by_cols => ls_coo_set_by_cols procedure, pass(a) :: set_sort_status => ls_coo_set_sort_status procedure, pass(a) :: get_sort_status => ls_coo_get_sort_status + procedure, pass(a) :: scals => psb_ls_coo_scals + procedure, pass(a) :: scalv => psb_ls_coo_scal ! ! This is COO specific @@ -402,22 +382,6 @@ module psb_s_base_mat_mod procedure, pass(a) :: transp_1mat => ls_coo_transp_1mat procedure, pass(a) :: transc_1mat => ls_coo_transc_1mat - ! - ! Computational methods. - ! - procedure, pass(a) :: csmm => psb_ls_coo_csmm - procedure, pass(a) :: csmv => psb_ls_coo_csmv - procedure, pass(a) :: inner_cssm => psb_ls_coo_cssm - procedure, pass(a) :: inner_cssv => psb_ls_coo_cssv - procedure, pass(a) :: scals => psb_ls_coo_scals - procedure, pass(a) :: scalv => psb_ls_coo_scal - procedure, pass(a) :: maxval => psb_ls_coo_maxval - procedure, pass(a) :: spnmi => psb_ls_coo_csnmi - procedure, pass(a) :: spnm1 => psb_ls_coo_csnm1 - procedure, pass(a) :: rowsum => psb_ls_coo_rowsum - procedure, pass(a) :: arwsum => psb_ls_coo_arwsum - procedure, pass(a) :: colsum => psb_ls_coo_colsum - procedure, pass(a) :: aclsum => psb_ls_coo_aclsum end type psb_ls_coo_sparse_mat @@ -2756,6 +2720,43 @@ module psb_s_base_mat_mod end subroutine psb_ls_base_clean_zeros end interface + ! + !> Function base_scals: + !! \memberof psb_ls_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_ls_base_scals(d,a,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_ls_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_ls_base_scal(d,a,info,side) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_base_scal + end interface + + ! !> Function transp: !! \memberof psb_ls_base_sparse_mat @@ -2816,554 +2817,119 @@ module psb_s_base_mat_mod end subroutine psb_ls_base_transc_1mat end interface + ! == =============== ! - !> Function csmm: - !! \memberof psb_ls_base_sparse_mat - !! \brief Product by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! COO interfaces ! - interface - subroutine psb_ls_base_csmm(alpha,a,x,beta,y,info,trans) + ! == =============== + + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_ls_coo_reallocate_nz(nz,a) import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_base_csmm + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ls_coo_reallocate_nz end interface - !> Function csmv: - !! \memberof psb_ls_base_sparse_mat - !! \brief Product by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit ! interface - subroutine psb_ls_base_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_ls_coo_reinit(a,clear) import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_base_csmv + class(psb_ls_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ls_coo_reinit end interface - - !> Function vect_mv: - !! \memberof psb_ls_base_sparse_mat - !! \brief Product by an encapsulated array type(psb_ls_vect_type) - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! Usually the unwrapping of the encapsulated vector is done - !! here, so that all the derived classes need only the - !! versions with the standard arrays. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input X - !! \param beta Scaling factor for y - !! \param y the input/output Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! ! - interface - subroutine psb_ls_base_vect_mv(alpha,a,x,beta,y,info,trans) + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_ls_coo_trim(a) import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - class(psb_s_base_vect_type), intent(inout) :: x - class(psb_s_base_vect_type), intent(inout) :: y + class(psb_ls_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ls_coo_trim + end interface + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros + ! + interface + subroutine psb_ls_coo_clean_zeros(a,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_base_vect_mv + end subroutine psb_ls_coo_clean_zeros end interface ! - !> Function cssm: - !! \memberof psb_ls_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssm. - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! + interface + subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ls_coo_allocate_mnnz + end interface + + + !> \memberof psb_ls_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface - subroutine psb_ls_base_inner_cssm(alpha,a,x,beta,y,info,trans) + subroutine psb_ls_coo_mold(a,b,info) import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_base_inner_cssm + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_coo_mold end interface ! - !> Function cssv: - !! \memberof psb_ls_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssv. + !> Function print. + !! \memberof psb_ls_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering !! ! - interface - subroutine psb_ls_base_inner_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_base_inner_cssv + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_coo_print end interface + + ! - !> Function inner_vect_cssv: - !! \memberof psb_ls_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_ls_vect_type) + !> Function get_nz_row. + !! \memberof psb_ls_coo_sparse_mat + !! \brief How many nonzeros in a row? !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by vect_cssv. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - ! - interface - subroutine psb_ls_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - class(psb_s_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_base_inner_vect_sv - end interface - - ! - !> Function cssm: - !! \memberof psb_ls_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ls_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_ls_base_cssm - end interface - - ! - !> Function cssv: - !! \memberof psb_ls_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ls_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_ls_base_cssv - end interface - - ! - !> Function vect_cssv: - !! \memberof psb_ls_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_ls_vect_type) - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_ls_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - class(psb_s_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_s_base_vect_type), optional, intent(inout) :: d - end subroutine psb_ls_base_vect_cssv - end interface - - ! - !> Function base_scals: - !! \memberof psb_ls_base_sparse_mat - !! \brief Scale a matrix by a single scalar value - !! - !! \param d Scaling factor - !! \param info return code - ! - interface - subroutine psb_ls_base_scals(d,a,info) - import - class(psb_ls_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ls_base_scals - end interface - - ! - !> Function base_scal: - !! \memberof psb_ls_base_sparse_mat - !! \brief Scale a matrix by a vector - !! - !! \param d(:) Scaling vector - !! \param info return code - !! \param side [L] Scale on the Left (rows) or on the Right (columns) - ! - interface - subroutine psb_ls_base_scal(d,a,info,side) - import - class(psb_ls_base_sparse_mat), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_ls_base_scal - end interface - - ! - !> Function base_maxval: - !! \memberof psb_ls_base_sparse_mat - !! \brief Maximum absolute value of all coefficients; - !! - ! - interface - function psb_ls_base_maxval(a) result(res) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_ls_base_maxval - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_ls_base_sparse_mat - !! \brief Operator infinity norm - !! - ! - interface - function psb_ls_base_csnmi(a) result(res) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_ls_base_csnmi - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_ls_base_sparse_mat - !! \brief Operator 1-norm - !! - ! - interface - function psb_ls_base_csnm1(a) result(res) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_ls_base_csnm1 - end interface - - ! - ! - !> Function base_rowsum: - !! \memberof psb_ls_base_sparse_mat - !! \brief Sum along the rows - !! \param d(:) The output row sums - !! - ! - interface - subroutine psb_ls_base_rowsum(d,a) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_base_rowsum - end interface - - ! - !> Function base_arwsum: - !! \memberof psb_ls_base_sparse_mat - !! \brief Absolute value sum along the rows - !! \param d(:) The output row sums - !! - interface - subroutine psb_ls_base_arwsum(d,a) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_base_arwsum - end interface - - ! - ! - !> Function base_colsum: - !! \memberof psb_ls_base_sparse_mat - !! \brief Sum along the columns - !! \param d(:) The output col sums - !! - ! - interface - subroutine psb_ls_base_colsum(d,a) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_base_colsum - end interface - - ! - !> Function base_aclsum: - !! \memberof psb_ls_base_sparse_mat - !! \brief Absolute value sum along the columns - !! \param d(:) The output col sums - !! - interface - subroutine psb_ls_base_aclsum(d,a) - import - class(psb_ls_base_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_base_aclsum - end interface - - - ! == =============== - ! - ! COO interfaces - ! - ! == =============== - - ! - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reallocate_nz - ! - interface - subroutine psb_ls_coo_reallocate_nz(nz,a) - import - integer(psb_lpk_), intent(in) :: nz - class(psb_ls_coo_sparse_mat), intent(inout) :: a - end subroutine psb_ls_coo_reallocate_nz - end interface - - ! - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reinit - ! - interface - subroutine psb_ls_coo_reinit(a,clear) - import - class(psb_ls_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_ls_coo_reinit - end interface - ! - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_trim - ! - interface - subroutine psb_ls_coo_trim(a) - import - class(psb_ls_coo_sparse_mat), intent(inout) :: a - end subroutine psb_ls_coo_trim - end interface - ! - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros - ! - interface - subroutine psb_ls_coo_clean_zeros(a,info) - import - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ls_coo_clean_zeros - end interface - - ! - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_allocate_mnnz - ! - interface - subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) - import - integer(psb_lpk_), intent(in) :: m,n - class(psb_ls_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_ls_coo_allocate_mnnz - end interface - - - !> \memberof psb_ls_coo_sparse_mat - !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ls_coo_mold(a,b,info) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ls_coo_mold - end interface - - - ! - !> Function print. - !! \memberof psb_ls_coo_sparse_mat - !! \brief Print the matrix to file in MatrixMarket format - !! - !! \param iout The unit to write to - !! \param iv [none] Renumbering for both rows and columns - !! \param head [none] Descriptive header for the file - !! \param ivr [none] Row renumbering - !! \param ivc [none] Col renumbering - !! - ! - interface - subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) - import - integer(psb_ipk_), intent(in) :: iout - class(psb_ls_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_ls_coo_print - end interface - - - - ! - !> Function get_nz_row. - !! \memberof psb_ls_coo_sparse_mat - !! \brief How many nonzeros in a row? - !! - !! \param idx The row to search. + !! \param idx The row to search. !! ! interface @@ -3627,138 +3193,6 @@ module psb_s_base_mat_mod end subroutine psb_ls_coo_csgetrow end interface - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_cssv - interface - subroutine psb_ls_coo_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_coo_cssv - end interface - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_cssm - interface - subroutine psb_ls_coo_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_coo_cssm - end interface - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_csmv - interface - subroutine psb_ls_coo_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_coo_csmv - end interface - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_csmm - interface - subroutine psb_ls_coo_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_ls_coo_csmm - end interface - - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_maxval - interface - function psb_ls_coo_maxval(a) result(res) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_ls_coo_maxval - end interface - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_csnmi - interface - function psb_ls_coo_csnmi(a) result(res) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_ls_coo_csnmi - end interface - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_csnm1 - interface - function psb_ls_coo_csnm1(a) result(res) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_) :: res - end function psb_ls_coo_csnm1 - end interface - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_rowsum - interface - subroutine psb_ls_coo_rowsum(d,a) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_coo_rowsum - end interface - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_arwsum - interface - subroutine psb_ls_coo_arwsum(d,a) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_coo_arwsum - end interface - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_colsum - interface - subroutine psb_ls_coo_colsum(d,a) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_coo_colsum - end interface - - !> - !! \memberof psb_ls_coo_sparse_mat - !! \see psb_ls_base_mat_mod::psb_ls_base_aclsum - interface - subroutine psb_ls_coo_aclsum(d,a) - import - class(psb_ls_coo_sparse_mat), intent(in) :: a - real(psb_spk_), intent(out) :: d(:) - end subroutine psb_ls_coo_aclsum - end interface - !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag @@ -3771,6 +3205,7 @@ module psb_s_base_mat_mod end subroutine psb_ls_coo_get_diag end interface + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scal @@ -3796,7 +3231,6 @@ module psb_s_base_mat_mod end subroutine psb_ls_coo_scals end interface - contains @@ -3818,7 +3252,7 @@ contains implicit none class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -4042,7 +3476,7 @@ contains implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_lp res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) diff --git a/base/modules/serial/psb_s_csr_mat_mod.f90 b/base/modules/serial/psb_s_csr_mat_mod.f90 index c9c46de33..696b79330 100644 --- a/base/modules/serial/psb_s_csr_mat_mod.f90 +++ b/base/modules/serial/psb_s_csr_mat_mod.f90 @@ -495,6 +495,334 @@ module psb_s_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_ls_csr_sparse_mat + !! \extends psb_ls_base_mat_mod::psb_ls_base_sparse_mat + !! + !! psb_ls_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_ls_base_sparse_mat) :: psb_ls_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + real(psb_spk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => ls_csr_is_by_rows + procedure, pass(a) :: get_size => ls_csr_get_size + procedure, pass(a) :: get_nzeros => ls_csr_get_nzeros + procedure, nopass :: get_fmt => ls_csr_get_fmt + procedure, pass(a) :: sizeof => ls_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_ls_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ls_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_ls_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_ls_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ls_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ls_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ls_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_ls_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ls_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ls_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_ls_csr_csput_a + procedure, pass(a) :: get_diag => psb_ls_csr_get_diag + procedure, pass(a) :: csgetptn => psb_ls_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_ls_csr_csgetrow + procedure, pass(a) :: get_nz_row => ls_csr_get_nz_row + procedure, pass(a) :: reinit => psb_ls_csr_reinit + procedure, pass(a) :: trim => psb_ls_csr_trim + procedure, pass(a) :: print => psb_ls_csr_print + procedure, pass(a) :: free => ls_csr_free + procedure, pass(a) :: mold => psb_ls_csr_mold + procedure, pass(a) :: scals => psb_ls_csr_scals + procedure, pass(a) :: scalv => psb_ls_csr_scal + + end type psb_ls_csr_sparse_mat + + private :: ls_csr_get_nzeros, ls_csr_free, ls_csr_get_fmt, & + & ls_csr_get_size, ls_csr_sizeof, ls_csr_get_nz_row, & + & ls_csr_is_by_rows + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_ls_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ls_csr_reallocate_nz + end interface + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_ls_csr_reinit(a,clear) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ls_csr_reinit + end interface + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_ls_csr_trim(a) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ls_csr_trim + end interface + + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ls_csr_mold(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csr_mold + end interface + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ls_csr_allocate_mnnz + end interface + + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_print + interface + subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_csr_print + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo + interface + subroutine psb_ls_cp_csr_to_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_to_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo + interface + subroutine psb_ls_cp_csr_from_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_from_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_fmt + interface + subroutine psb_ls_cp_csr_to_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_to_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_fmt + interface + subroutine psb_ls_cp_csr_from_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_from_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_coo + interface + subroutine psb_ls_mv_csr_to_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_to_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_coo + interface + subroutine psb_ls_mv_csr_from_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_from_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_fmt + interface + subroutine psb_ls_mv_csr_to_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_to_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_fmt + interface + subroutine psb_ls_mv_csr_from_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_from_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from + interface + subroutine psb_ls_csr_cp_from(a,b) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + type(psb_ls_csr_sparse_mat), intent(in) :: b + end subroutine psb_ls_csr_cp_from + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from + interface + subroutine psb_ls_csr_mv_from(a,b) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + type(psb_ls_csr_sparse_mat), intent(inout) :: b + end subroutine psb_ls_csr_mv_from + end interface + + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csput_a + interface + subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_csr_csput_a + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csr_csgetptn + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csgetrow + interface + subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csr_csgetrow + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csgetblk + interface + subroutine psb_ls_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csr_csgetblk + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag + interface + subroutine psb_ls_csr_get_diag(a,d,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csr_get_diag + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scal + interface + subroutine psb_ls_csr_scal(d,a,info,side) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_csr_scal + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scals + interface + subroutine psb_ls_csr_scals(d,a,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csr_scals + end interface + + contains @@ -525,7 +853,7 @@ contains implicit none class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + res = 2 * psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -614,4 +942,120 @@ contains end subroutine s_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function ls_csr_is_by_rows(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function ls_csr_is_by_rows + + + function ls_csr_sizeof(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + psb_sizeof_sp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function ls_csr_sizeof + + function ls_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function ls_csr_get_fmt + + function ls_csr_get_nzeros(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function ls_csr_get_nzeros + + function ls_csr_get_size(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function ls_csr_get_size + + + + function ls_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function ls_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine ls_csr_free(a) + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine ls_csr_free + end module psb_s_csr_mat_mod diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 0444ea813..24eb523ae 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -72,8 +72,8 @@ module psb_s_mat_mod use psb_s_base_mat_mod - use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat - use psb_s_csc_mat_mod, only : psb_s_csc_sparse_mat + use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat, psb_ls_csr_sparse_mat + use psb_s_csc_mat_mod, only : psb_s_csc_sparse_mat type :: psb_sspmat_type diff --git a/base/modules/serial/psb_s_serial_mod.f90 b/base/modules/serial/psb_s_serial_mod.f90 index 902d06f94..09f4a0f7e 100644 --- a/base/modules/serial/psb_s_serial_mod.f90 +++ b/base/modules/serial/psb_s_serial_mod.f90 @@ -203,6 +203,69 @@ module psb_s_serial_mod end subroutine psb_s_aspxpby end interface psb_aspxpby + interface psb_spspmm +!!$ subroutine psb_sspspmm(a,b,c,info) +!!$ use psb_s_mat_mod, only : psb_sspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_sspmat_type), intent(in) :: a,b +!!$ type(psb_sspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_sspspmm + subroutine psb_lscsrspspmm(a,b,c,info) + use psb_s_mat_mod, only : psb_ls_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lscsrspspmm +!!$ subroutine psb_scscspspmm(a,b,c,info) +!!$ use psb_s_mat_mod, only : psb_s_csc_sparse_mat +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ class(psb_s_csc_sparse_mat), intent(in) :: a,b +!!$ type(psb_s_csc_sparse_mat), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_scscspspmm + end interface psb_spspmm + + interface psb_symbmm +!!$ subroutine psb_ssymbmm(a,b,c,info) +!!$ use psb_s_mat_mod, only : psb_sspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_sspmat_type), intent(in) :: a,b +!!$ type(psb_sspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_ssymbmm + subroutine psb_lsbase_symbmm(a,b,c,info) + use psb_s_mat_mod, only : psb_ls_base_sparse_mat, psb_ls_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lsbase_symbmm + end interface psb_symbmm + + interface psb_numbmm +!!$ subroutine psb_snumbmm(a,b,c) +!!$ use psb_s_mat_mod, only : psb_sspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_sspmat_type), intent(in) :: a,b +!!$ type(psb_sspmat_type), intent(inout) :: c +!!$ end subroutine psb_snumbmm + subroutine psb_lsbase_numbmm(a,b,c) + use psb_s_mat_mod, only : psb_ls_base_sparse_mat, psb_ls_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(inout) :: c + end subroutine psb_lsbase_numbmm + end interface psb_numbmm + contains subroutine psb_scsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/modules/serial/psb_z_base_mat_mod.f90 b/base/modules/serial/psb_z_base_mat_mod.f90 index 45f7a5990..cba195d2c 100644 --- a/base/modules/serial/psb_z_base_mat_mod.f90 +++ b/base/modules/serial/psb_z_base_mat_mod.f90 @@ -276,6 +276,9 @@ module psb_z_base_mat_mod procedure, pass(a) :: clone => psb_lz_base_clone procedure, pass(a) :: make_nonunit => psb_lz_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_lz_base_clean_zeros + procedure, pass(a) :: scals => psb_lz_base_scals + procedure, pass(a) :: scalv => psb_lz_base_scal + generic, public :: scal => scals, scalv ! ! Convert internal indices ! @@ -296,31 +299,6 @@ module psb_z_base_mat_mod procedure, pass(a) :: transc_1mat => psb_lz_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_lz_base_transc_2mat - ! - ! Computational methods: defined here but not implemented. - ! - procedure, pass(a) :: vect_mv => psb_lz_base_vect_mv - procedure, pass(a) :: csmv => psb_lz_base_csmv - procedure, pass(a) :: csmm => psb_lz_base_csmm - generic, public :: spmm => csmm, csmv, vect_mv - procedure, pass(a) :: in_vect_sv => psb_lz_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_lz_base_inner_cssv - procedure, pass(a) :: inner_cssm => psb_lz_base_inner_cssm - generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv - procedure, pass(a) :: vect_cssv => psb_lz_base_vect_cssv - procedure, pass(a) :: cssv => psb_lz_base_cssv - procedure, pass(a) :: cssm => psb_lz_base_cssm - generic, public :: spsm => cssm, cssv, vect_cssv - procedure, pass(a) :: scals => psb_lz_base_scals - procedure, pass(a) :: scalv => psb_lz_base_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: maxval => psb_lz_base_maxval - procedure, pass(a) :: spnmi => psb_lz_base_csnmi - procedure, pass(a) :: spnm1 => psb_lz_base_csnm1 - procedure, pass(a) :: rowsum => psb_lz_base_rowsum - procedure, pass(a) :: arwsum => psb_lz_base_arwsum - procedure, pass(a) :: colsum => psb_lz_base_colsum - procedure, pass(a) :: aclsum => psb_lz_base_aclsum end type psb_lz_base_sparse_mat private :: lz_base_mat_sync, lz_base_mat_is_host, lz_base_mat_is_dev, & @@ -388,6 +366,8 @@ module psb_z_base_mat_mod procedure, pass(a) :: set_by_cols => lz_coo_set_by_cols procedure, pass(a) :: set_sort_status => lz_coo_set_sort_status procedure, pass(a) :: get_sort_status => lz_coo_get_sort_status + procedure, pass(a) :: scals => psb_lz_coo_scals + procedure, pass(a) :: scalv => psb_lz_coo_scal ! ! This is COO specific @@ -402,22 +382,6 @@ module psb_z_base_mat_mod procedure, pass(a) :: transp_1mat => lz_coo_transp_1mat procedure, pass(a) :: transc_1mat => lz_coo_transc_1mat - ! - ! Computational methods. - ! - procedure, pass(a) :: csmm => psb_lz_coo_csmm - procedure, pass(a) :: csmv => psb_lz_coo_csmv - procedure, pass(a) :: inner_cssm => psb_lz_coo_cssm - procedure, pass(a) :: inner_cssv => psb_lz_coo_cssv - procedure, pass(a) :: scals => psb_lz_coo_scals - procedure, pass(a) :: scalv => psb_lz_coo_scal - procedure, pass(a) :: maxval => psb_lz_coo_maxval - procedure, pass(a) :: spnmi => psb_lz_coo_csnmi - procedure, pass(a) :: spnm1 => psb_lz_coo_csnm1 - procedure, pass(a) :: rowsum => psb_lz_coo_rowsum - procedure, pass(a) :: arwsum => psb_lz_coo_arwsum - procedure, pass(a) :: colsum => psb_lz_coo_colsum - procedure, pass(a) :: aclsum => psb_lz_coo_aclsum end type psb_lz_coo_sparse_mat @@ -2756,6 +2720,43 @@ module psb_z_base_mat_mod end subroutine psb_lz_base_clean_zeros end interface + ! + !> Function base_scals: + !! \memberof psb_lz_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_lz_base_scals(d,a,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_lz_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_lz_base_scal(d,a,info,side) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_base_scal + end interface + + ! !> Function transp: !! \memberof psb_lz_base_sparse_mat @@ -2816,554 +2817,119 @@ module psb_z_base_mat_mod end subroutine psb_lz_base_transc_1mat end interface + ! == =============== ! - !> Function csmm: - !! \memberof psb_lz_base_sparse_mat - !! \brief Product by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! COO interfaces ! - interface - subroutine psb_lz_base_csmm(alpha,a,x,beta,y,info,trans) + ! == =============== + + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_lz_coo_reallocate_nz(nz,a) import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_base_csmm + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lz_coo_reallocate_nz end interface - !> Function csmv: - !! \memberof psb_lz_base_sparse_mat - !! \brief Product by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit ! interface - subroutine psb_lz_base_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_lz_coo_reinit(a,clear) import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_base_csmv + class(psb_lz_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lz_coo_reinit end interface - - !> Function vect_mv: - !! \memberof psb_lz_base_sparse_mat - !! \brief Product by an encapsulated array type(psb_lz_vect_type) - !! - !! Compute - !! Y = alpha*op(A)*X + beta*Y - !! Usually the unwrapping of the encapsulated vector is done - !! here, so that all the derived classes need only the - !! versions with the standard arrays. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input X - !! \param beta Scaling factor for y - !! \param y the input/output Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! ! - interface - subroutine psb_lz_base_vect_mv(alpha,a,x,beta,y,info,trans) + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_lz_coo_trim(a) import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - class(psb_z_base_vect_type), intent(inout) :: x - class(psb_z_base_vect_type), intent(inout) :: y + class(psb_lz_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lz_coo_trim + end interface + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros + ! + interface + subroutine psb_lz_coo_clean_zeros(a,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_base_vect_mv + end subroutine psb_lz_coo_clean_zeros end interface ! - !> Function cssm: - !! \memberof psb_lz_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssm. - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! + interface + subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lz_coo_allocate_mnnz + end interface + + + !> \memberof psb_lz_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface - subroutine psb_lz_base_inner_cssm(alpha,a,x,beta,y,info,trans) + subroutine psb_lz_coo_mold(a,b,info) import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_base_inner_cssm + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_coo_mold end interface ! - !> Function cssv: - !! \memberof psb_lz_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by cssv. + !> Function print. + !! \memberof psb_lz_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering !! ! - interface - subroutine psb_lz_base_inner_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_base_inner_cssv + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_coo_print end interface + + ! - !> Function inner_vect_cssv: - !! \memberof psb_lz_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_lz_vect_type) + !> Function get_nz_row. + !! \memberof psb_lz_coo_sparse_mat + !! \brief How many nonzeros in a row? !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! Internal workhorse called by vect_cssv. - !! Must be overridden explicitly in case of non standard memory - !! management; an example would be external memory allocation - !! in attached processors such as GPUs. - !! - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - ! - interface - subroutine psb_lz_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - class(psb_z_base_vect_type), intent(inout) :: x, y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_base_inner_vect_sv - end interface - - ! - !> Function cssm: - !! \memberof psb_lz_base_sparse_mat - !! \brief Triangular system solve by a dense rank 2 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:,:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:,:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_lz_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_lz_base_cssm - end interface - - ! - !> Function cssv: - !! \memberof psb_lz_base_sparse_mat - !! \brief Triangular system solve by a dense rank 1 array. - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x(:) the input dense X - !! \param beta Scaling factor for y - !! \param y(:) the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_lz_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_lz_base_cssv - end interface - - ! - !> Function vect_cssv: - !! \memberof psb_lz_base_sparse_mat - !! \brief Triangular system solve by - !! an encapsulated array type(psb_lz_vect_type) - !! - !! Compute - !! Y = alpha*op(A^-1)*X + beta*Y - !! - !! \param alpha Scaling factor for Ax - !! \param A the input sparse matrix - !! \param x the input dense X - !! \param beta Scaling factor for y - !! \param y the input/output dense Y - !! \param info return code - !! \param trans [N] Whether to use A (N), its transpose (T) - !! or its conjugate transpose (C) - !! \param scale [N] Apply a scaling on Right (R) i.e. ADX - !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. - !! - ! - interface - subroutine psb_lz_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - class(psb_z_base_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - class(psb_z_base_vect_type), optional, intent(inout) :: d - end subroutine psb_lz_base_vect_cssv - end interface - - ! - !> Function base_scals: - !! \memberof psb_lz_base_sparse_mat - !! \brief Scale a matrix by a single scalar value - !! - !! \param d Scaling factor - !! \param info return code - ! - interface - subroutine psb_lz_base_scals(d,a,info) - import - class(psb_lz_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lz_base_scals - end interface - - ! - !> Function base_scal: - !! \memberof psb_lz_base_sparse_mat - !! \brief Scale a matrix by a vector - !! - !! \param d(:) Scaling vector - !! \param info return code - !! \param side [L] Scale on the Left (rows) or on the Right (columns) - ! - interface - subroutine psb_lz_base_scal(d,a,info,side) - import - class(psb_lz_base_sparse_mat), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_lz_base_scal - end interface - - ! - !> Function base_maxval: - !! \memberof psb_lz_base_sparse_mat - !! \brief Maximum absolute value of all coefficients; - !! - ! - interface - function psb_lz_base_maxval(a) result(res) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_lz_base_maxval - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_lz_base_sparse_mat - !! \brief Operator infinity norm - !! - ! - interface - function psb_lz_base_csnmi(a) result(res) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_lz_base_csnmi - end interface - - ! - ! - !> Function base_csnmi: - !! \memberof psb_lz_base_sparse_mat - !! \brief Operator 1-norm - !! - ! - interface - function psb_lz_base_csnm1(a) result(res) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_lz_base_csnm1 - end interface - - ! - ! - !> Function base_rowsum: - !! \memberof psb_lz_base_sparse_mat - !! \brief Sum along the rows - !! \param d(:) The output row sums - !! - ! - interface - subroutine psb_lz_base_rowsum(d,a) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_base_rowsum - end interface - - ! - !> Function base_arwsum: - !! \memberof psb_lz_base_sparse_mat - !! \brief Absolute value sum along the rows - !! \param d(:) The output row sums - !! - interface - subroutine psb_lz_base_arwsum(d,a) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_base_arwsum - end interface - - ! - ! - !> Function base_colsum: - !! \memberof psb_lz_base_sparse_mat - !! \brief Sum along the columns - !! \param d(:) The output col sums - !! - ! - interface - subroutine psb_lz_base_colsum(d,a) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_base_colsum - end interface - - ! - !> Function base_aclsum: - !! \memberof psb_lz_base_sparse_mat - !! \brief Absolute value sum along the columns - !! \param d(:) The output col sums - !! - interface - subroutine psb_lz_base_aclsum(d,a) - import - class(psb_lz_base_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_base_aclsum - end interface - - - ! == =============== - ! - ! COO interfaces - ! - ! == =============== - - ! - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reallocate_nz - ! - interface - subroutine psb_lz_coo_reallocate_nz(nz,a) - import - integer(psb_lpk_), intent(in) :: nz - class(psb_lz_coo_sparse_mat), intent(inout) :: a - end subroutine psb_lz_coo_reallocate_nz - end interface - - ! - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_reinit - ! - interface - subroutine psb_lz_coo_reinit(a,clear) - import - class(psb_lz_coo_sparse_mat), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_lz_coo_reinit - end interface - ! - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_trim - ! - interface - subroutine psb_lz_coo_trim(a) - import - class(psb_lz_coo_sparse_mat), intent(inout) :: a - end subroutine psb_lz_coo_trim - end interface - ! - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros - ! - interface - subroutine psb_lz_coo_clean_zeros(a,info) - import - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lz_coo_clean_zeros - end interface - - ! - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_base_mat_mod::psb_base_allocate_mnnz - ! - interface - subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) - import - integer(psb_lpk_), intent(in) :: m,n - class(psb_lz_coo_sparse_mat), intent(inout) :: a - integer(psb_lpk_), intent(in), optional :: nz - end subroutine psb_lz_coo_allocate_mnnz - end interface - - - !> \memberof psb_lz_coo_sparse_mat - !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lz_coo_mold(a,b,info) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lz_coo_mold - end interface - - - ! - !> Function print. - !! \memberof psb_lz_coo_sparse_mat - !! \brief Print the matrix to file in MatrixMarket format - !! - !! \param iout The unit to write to - !! \param iv [none] Renumbering for both rows and columns - !! \param head [none] Descriptive header for the file - !! \param ivr [none] Row renumbering - !! \param ivc [none] Col renumbering - !! - ! - interface - subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) - import - integer(psb_ipk_), intent(in) :: iout - class(psb_lz_coo_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_lz_coo_print - end interface - - - - ! - !> Function get_nz_row. - !! \memberof psb_lz_coo_sparse_mat - !! \brief How many nonzeros in a row? - !! - !! \param idx The row to search. + !! \param idx The row to search. !! ! interface @@ -3627,138 +3193,6 @@ module psb_z_base_mat_mod end subroutine psb_lz_coo_csgetrow end interface - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_cssv - interface - subroutine psb_lz_coo_cssv(alpha,a,x,beta,y,info,trans) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_coo_cssv - end interface - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_cssm - interface - subroutine psb_lz_coo_cssm(alpha,a,x,beta,y,info,trans) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_coo_cssm - end interface - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_csmv - interface - subroutine psb_lz_coo_csmv(alpha,a,x,beta,y,info,trans) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_coo_csmv - end interface - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_csmm - interface - subroutine psb_lz_coo_csmm(alpha,a,x,beta,y,info,trans) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_lz_coo_csmm - end interface - - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_maxval - interface - function psb_lz_coo_maxval(a) result(res) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_lz_coo_maxval - end interface - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_csnmi - interface - function psb_lz_coo_csnmi(a) result(res) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_lz_coo_csnmi - end interface - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_csnm1 - interface - function psb_lz_coo_csnm1(a) result(res) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_) :: res - end function psb_lz_coo_csnm1 - end interface - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_rowsum - interface - subroutine psb_lz_coo_rowsum(d,a) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_coo_rowsum - end interface - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_arwsum - interface - subroutine psb_lz_coo_arwsum(d,a) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_coo_arwsum - end interface - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_colsum - interface - subroutine psb_lz_coo_colsum(d,a) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - complex(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_coo_colsum - end interface - - !> - !! \memberof psb_lz_coo_sparse_mat - !! \see psb_lz_base_mat_mod::psb_lz_base_aclsum - interface - subroutine psb_lz_coo_aclsum(d,a) - import - class(psb_lz_coo_sparse_mat), intent(in) :: a - real(psb_dpk_), intent(out) :: d(:) - end subroutine psb_lz_coo_aclsum - end interface - !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag @@ -3771,6 +3205,7 @@ module psb_z_base_mat_mod end subroutine psb_lz_coo_get_diag end interface + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scal @@ -3796,7 +3231,6 @@ module psb_z_base_mat_mod end subroutine psb_lz_coo_scals end interface - contains @@ -3818,7 +3252,7 @@ contains implicit none class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -4042,7 +3476,7 @@ contains implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + 1 + res = 3*psb_sizeof_lp res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) diff --git a/base/modules/serial/psb_z_csr_mat_mod.f90 b/base/modules/serial/psb_z_csr_mat_mod.f90 index d098e8c28..d54cb9677 100644 --- a/base/modules/serial/psb_z_csr_mat_mod.f90 +++ b/base/modules/serial/psb_z_csr_mat_mod.f90 @@ -495,6 +495,334 @@ module psb_z_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_lz_csr_sparse_mat + !! \extends psb_lz_base_mat_mod::psb_lz_base_sparse_mat + !! + !! psb_lz_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_lz_base_sparse_mat) :: psb_lz_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + complex(psb_dpk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => lz_csr_is_by_rows + procedure, pass(a) :: get_size => lz_csr_get_size + procedure, pass(a) :: get_nzeros => lz_csr_get_nzeros + procedure, nopass :: get_fmt => lz_csr_get_fmt + procedure, pass(a) :: sizeof => lz_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_lz_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lz_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_lz_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_lz_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lz_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lz_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lz_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_lz_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lz_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lz_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_lz_csr_csput_a + procedure, pass(a) :: get_diag => psb_lz_csr_get_diag + procedure, pass(a) :: csgetptn => psb_lz_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_lz_csr_csgetrow + procedure, pass(a) :: get_nz_row => lz_csr_get_nz_row + procedure, pass(a) :: reinit => psb_lz_csr_reinit + procedure, pass(a) :: trim => psb_lz_csr_trim + procedure, pass(a) :: print => psb_lz_csr_print + procedure, pass(a) :: free => lz_csr_free + procedure, pass(a) :: mold => psb_lz_csr_mold + procedure, pass(a) :: scals => psb_lz_csr_scals + procedure, pass(a) :: scalv => psb_lz_csr_scal + + end type psb_lz_csr_sparse_mat + + private :: lz_csr_get_nzeros, lz_csr_free, lz_csr_get_fmt, & + & lz_csr_get_size, lz_csr_sizeof, lz_csr_get_nz_row, & + & lz_csr_is_by_rows + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_lz_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lz_csr_reallocate_nz + end interface + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_lz_csr_reinit(a,clear) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lz_csr_reinit + end interface + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_lz_csr_trim(a) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lz_csr_trim + end interface + + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lz_csr_mold(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csr_mold + end interface + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lz_csr_allocate_mnnz + end interface + + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_print + interface + subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_csr_print + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo + interface + subroutine psb_lz_cp_csr_to_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_to_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo + interface + subroutine psb_lz_cp_csr_from_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_from_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_fmt + interface + subroutine psb_lz_cp_csr_to_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_to_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_fmt + interface + subroutine psb_lz_cp_csr_from_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_from_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_coo + interface + subroutine psb_lz_mv_csr_to_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_to_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_coo + interface + subroutine psb_lz_mv_csr_from_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_from_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_fmt + interface + subroutine psb_lz_mv_csr_to_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_to_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_fmt + interface + subroutine psb_lz_mv_csr_from_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_from_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from + interface + subroutine psb_lz_csr_cp_from(a,b) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + type(psb_lz_csr_sparse_mat), intent(in) :: b + end subroutine psb_lz_csr_cp_from + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from + interface + subroutine psb_lz_csr_mv_from(a,b) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + type(psb_lz_csr_sparse_mat), intent(inout) :: b + end subroutine psb_lz_csr_mv_from + end interface + + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csput_a + interface + subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_csr_csput_a + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csr_csgetptn + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csgetrow + interface + subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csr_csgetrow + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csgetblk + interface + subroutine psb_lz_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csr_csgetblk + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag + interface + subroutine psb_lz_csr_get_diag(a,d,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csr_get_diag + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scal + interface + subroutine psb_lz_csr_scal(d,a,info,side) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_csr_scal + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scals + interface + subroutine psb_lz_csr_scals(d,a,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csr_scals + end interface + + contains @@ -525,7 +853,7 @@ contains implicit none class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 8 + res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) @@ -614,4 +942,120 @@ contains end subroutine z_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function lz_csr_is_by_rows(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function lz_csr_is_by_rows + + + function lz_csr_sizeof(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + (2*psb_sizeof_dp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function lz_csr_sizeof + + function lz_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function lz_csr_get_fmt + + function lz_csr_get_nzeros(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function lz_csr_get_nzeros + + function lz_csr_get_size(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function lz_csr_get_size + + + + function lz_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function lz_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine lz_csr_free(a) + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine lz_csr_free + end module psb_z_csr_mat_mod diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index 83a19482e..784ef3880 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -72,8 +72,8 @@ module psb_z_mat_mod use psb_z_base_mat_mod - use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat - use psb_z_csc_mat_mod, only : psb_z_csc_sparse_mat + use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat, psb_lz_csr_sparse_mat + use psb_z_csc_mat_mod, only : psb_z_csc_sparse_mat type :: psb_zspmat_type diff --git a/base/modules/serial/psb_z_serial_mod.f90 b/base/modules/serial/psb_z_serial_mod.f90 index fdefb0a82..fb6d3dad9 100644 --- a/base/modules/serial/psb_z_serial_mod.f90 +++ b/base/modules/serial/psb_z_serial_mod.f90 @@ -203,6 +203,69 @@ module psb_z_serial_mod end subroutine psb_z_aspxpby end interface psb_aspxpby + interface psb_spspmm +!!$ subroutine psb_zspspmm(a,b,c,info) +!!$ use psb_z_mat_mod, only : psb_zspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_zspmat_type), intent(in) :: a,b +!!$ type(psb_zspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_zspspmm + subroutine psb_lzcsrspspmm(a,b,c,info) + use psb_z_mat_mod, only : psb_lz_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzcsrspspmm +!!$ subroutine psb_zcscspspmm(a,b,c,info) +!!$ use psb_z_mat_mod, only : psb_z_csc_sparse_mat +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ class(psb_z_csc_sparse_mat), intent(in) :: a,b +!!$ type(psb_z_csc_sparse_mat), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_zcscspspmm + end interface psb_spspmm + + interface psb_symbmm +!!$ subroutine psb_zsymbmm(a,b,c,info) +!!$ use psb_z_mat_mod, only : psb_zspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_zspmat_type), intent(in) :: a,b +!!$ type(psb_zspmat_type), intent(out) :: c +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_zsymbmm + subroutine psb_lzbase_symbmm(a,b,c,info) + use psb_z_mat_mod, only : psb_lz_base_sparse_mat, psb_lz_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzbase_symbmm + end interface psb_symbmm + + interface psb_numbmm +!!$ subroutine psb_znumbmm(a,b,c) +!!$ use psb_z_mat_mod, only : psb_zspmat_type +!!$ import :: psb_ipk_ +!!$ implicit none +!!$ type(psb_zspmat_type), intent(in) :: a,b +!!$ type(psb_zspmat_type), intent(inout) :: c +!!$ end subroutine psb_znumbmm + subroutine psb_lzbase_numbmm(a,b,c) + use psb_z_mat_mod, only : psb_lz_base_sparse_mat, psb_lz_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(inout) :: c + end subroutine psb_lzbase_numbmm + end interface psb_numbmm + contains subroutine psb_zcsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index fb57abf9e..97662ba65 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -4,16 +4,21 @@ include ../../../Make.inc # The object files # BOBJS=psb_base_mat_impl.o \ - psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o \ + psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o +#\ psb_s_lbase_mat_impl.o psb_d_lbase_mat_impl.o psb_c_lbase_mat_impl.o psb_z_lbase_mat_impl.o -SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o \ - psb_s_lcoo_impl.o -DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o \ - psb_d_lcoo_impl.o -COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o \ - psb_c_lcoo_impl.o -ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o \ - psb_z_lcoo_impl.o +SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o +#\ + psb_s_lcoo_impl.o psb_s_lcsr_impl.o +DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o +#\ + psb_d_lcoo_impl.o psb_d_lcsr_impl.o +COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o +#\ + psb_c_lcoo_impl.o psb_c_lcsr_impl.o +ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o +#\ + psb_z_lcoo_impl.o psb_z_lcsr_impl.o OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) diff --git a/base/serial/impl/psb_base_mat_impl.f90 b/base/serial/impl/psb_base_mat_impl.f90 index 6cc9ff168..faa919791 100644 --- a/base/serial/impl/psb_base_mat_impl.f90 +++ b/base/serial/impl/psb_base_mat_impl.f90 @@ -293,3 +293,299 @@ subroutine psb_base_trim(a) end subroutine psb_base_trim +function psb_lbase_get_nz_row(idx,a) result(res) + use psb_error_mod + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_nz_row + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lbase_get_nz_row' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the lbase version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end function psb_lbase_get_nz_row + +function psb_lbase_get_nzeros(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_nzeros + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lbase_get_nzeros' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end function psb_lbase_get_nzeros + +function psb_lbase_get_size(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_size + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_size' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end function psb_lbase_get_size + +subroutine psb_lbase_reinit(a,clear) + use psb_base_mat_mod, psb_protect_name => psb_lbase_reinit + use psb_error_mod + implicit none + + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_err_missing_override_method_ + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_reinit + +subroutine psb_lbase_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_base_mat_mod, psb_protect_name => psb_lbase_sparse_print + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(in) :: iout + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_err_missing_override_method_ + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_sparse_print + +subroutine psb_lbase_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_base_mat_mod, psb_protect_name => psb_lbase_csgetptn + implicit none + + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_csgetptn + +subroutine psb_lbase_get_neigh(a,idx,neigh,n,info,lev) + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_neigh + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: lev_, i, nl, ifl,ill,& + & nn, nidx,ntl,ma, n1 + integer(psb_lpk_), allocatable :: ia(:), ja(:) + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if(present(lev)) then + lev_ = lev + else + lev_=1 + end if + ! Turns out we can write get_neigh at this + ! level + n = 0 + ma = a%get_nrows() + call a%csget(idx,idx,n,ia,ja,info) + if (info == psb_success_) call psb_realloc(n,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + neigh(1:n) = ja(1:n) + ifl = 1 + ill = n + do nl = 2, lev_ + n1 = ill - ifl + 1 + call psb_ensure_size(ill+n1*n1,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + ntl = 0 + do i=ifl,ill + nidx=neigh(i) + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= ma)) then + call a%csget(nidx,nidx,nn,ia,ja,info) + if (info == psb_success_) call psb_ensure_size(ill+ntl+nn,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) + ntl = ntl+nn + end if + end do + call psb_msort_unique(neigh(ill+1:ill+ntl),nn,dir=psb_sort_up_) + ifl = ill + 1 + ill = ill + nn + end do + call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_) + n = nn + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lbase_get_neigh + +subroutine psb_lbase_allocate_mnnz(m,n,a,nz) + use psb_base_mat_mod, psb_protect_name => psb_lbase_allocate_mnnz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_allocate_mnnz + +subroutine psb_lbase_reallocate_nz(nz,a) + use psb_base_mat_mod, psb_protect_name => psb_lbase_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_reallocate_nz + +subroutine psb_lbase_free(a) + use psb_base_mat_mod, psb_protect_name => psb_lbase_free + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_free + +subroutine psb_lbase_trim(a) + use psb_base_mat_mod, psb_protect_name => psb_lbase_trim + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + ! + ! This is the base version. + ! The correct action is: do nothing. + ! Indeed, the more complicated the data structure, the + ! more likely this is the only possible course. + ! + + return + +end subroutine psb_lbase_trim + diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 56a93fa6d..044f8055d 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -1999,3 +1999,1790 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_c_base_inner_vect_sv + + +subroutine psb_c_base_cp_to_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_to_lcoo + +subroutine psb_c_base_cp_from_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_from_lcoo + +subroutine psb_c_base_cp_to_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_to_lfmt + +subroutine psb_c_base_cp_from_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_from_lfmt + + +subroutine psb_c_base_mv_to_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_mv_to_lcoo + +subroutine psb_c_base_mv_from_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_mv_from_lcoo + + +subroutine psb_c_base_mv_to_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_c_base_mv_to_lfmt + +subroutine psb_c_base_mv_from_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_c_base_mv_from_lfmt + +! +! +! lc implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_lc_base_cp_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_cp_to_coo + +subroutine psb_lc_base_cp_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_cp_from_coo + + +subroutine psb_lc_base_cp_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_to_fmt + +subroutine psb_lc_base_cp_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_from_fmt + + +subroutine psb_lc_base_mv_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_to_coo + +subroutine psb_lc_base_mv_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_from_coo + + +subroutine psb_lc_base_mv_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_lc_base_mv_to_fmt + +subroutine psb_lc_base_mv_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_lc_base_mv_from_fmt + +subroutine psb_lc_base_clean_zeros(a, info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clean_zeros + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_lc_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_lc_base_clean_zeros + + +subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_a + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_csput_a + +subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_v + use psb_c_base_vect_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_csput_v + +subroutine psb_lc_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetrow + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetblk + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'lc_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_csgetblk + + +subroutine psb_lc_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csclip + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lc_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_tril + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_spk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_tril + +subroutine psb_lc_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_triu + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_spk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_triu + + + +subroutine psb_lc_base_clone(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clone + use psb_error_mod + implicit none + + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_lc_base_clone + +subroutine psb_lc_base_make_nonunit(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_make_nonunit + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = cone + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_lc_base_make_nonunit + +subroutine psb_lc_base_mold(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mold + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_mold + +subroutine psb_lc_base_transp_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lc_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_transp_2mat + +subroutine psb_lc_base_transc_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_2mat + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lc_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lc_base_transc_2mat + +subroutine psb_lc_base_transp_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_lc_base_sparse_mat), intent(inout) :: a + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_transp_1mat + +subroutine psb_lc_base_transc_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_1mat + implicit none + + class(psb_lc_base_sparse_mat), intent(inout) :: a + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_transc_1mat + +subroutine psb_lc_base_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scals + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_scals + + + +subroutine psb_lc_base_scal(d,a,info,side) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scal + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_scal + + +subroutine psb_lc_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_get_diag + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_get_diag + + + +subroutine psb_lc_base_cp_to_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_to_icoo + +subroutine psb_lc_base_cp_from_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_from_icoo + + +subroutine psb_lc_base_cp_to_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_to_ifmt + +subroutine psb_lc_base_cp_from_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_from_ifmt + + +subroutine psb_lc_base_mv_to_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_to_icoo + +subroutine psb_lc_base_mv_from_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_from_icoo + + +subroutine psb_lc_base_mv_to_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_c_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_lc_base_mv_to_ifmt + +subroutine psb_lc_base_mv_from_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_c_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_lc_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index 5a79b7e76..e697e9557 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -4019,3 +4019,2785 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_c_fix_coo_inner + +subroutine psb_c_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_lcoo + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_cp_coo_to_lcoo + +subroutine psb_c_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_lcoo + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_c_cp_coo_from_lcoo + + +! +! +! lc coo impl +! +! + +subroutine psb_lc_coo_get_diag(a,d,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = cone + else + d(1:mnm) = czero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_get_diag + + +subroutine psb_lc_coo_scal(d,a,info,side) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_scal + + +subroutine psb_lc_coo_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_scals + + +subroutine psb_lc_coo_reallocate_nz(nz,a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='lc_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_reallocate_nz + +subroutine psb_lc_coo_mold(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mold + use psb_error_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lc_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_mold + +subroutine psb_lc_coo_reinit(a,clear) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reinit + use psb_error_mod + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_reinit + + + +subroutine psb_lc_coo_trim(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_trim + +subroutine psb_lc_coo_clean_zeros(a, info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_zeros + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= czero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_lc_coo_clean_zeros + + + +subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_allocate_mnnz + + + +subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_lc_coo_print + + + + +function psb_lc_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_nz_row + implicit none + + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_lc_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csgetptn + implicit none + + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_lc_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csgetrow + implicit none + + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_lc_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_lc_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_lc_coo_csgetrow + + +subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csput_a + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call lc_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + 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 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine lc_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='lc_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + 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) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + 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 > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine lc_coo_srch_upd + +end subroutine psb_lc_coo_csput_a + + +subroutine psb_lc_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_to_coo + +subroutine psb_lc_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_from_coo + + +subroutine psb_lc_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_to_fmt + +subroutine psb_lc_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_from_fmt + + +subroutine psb_lc_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_to_coo + +subroutine psb_lc_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_from_coo + + +subroutine psb_lc_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_to_fmt + +subroutine psb_lc_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_from_fmt + +subroutine psb_lc_coo_cp_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cp_from + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_cp_from + +subroutine psb_lc_coo_mv_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mv_from + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_mv_from + + + +subroutine psb_lc_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_lc_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_fix_coo + + + +subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + complex(psb_spk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + complex(psb_spk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_fix_coo_inner + + +subroutine psb_lc_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_icoo + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_to_icoo + +subroutine psb_lc_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_icoo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index ab2874d49..92ffa2213 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -1268,7 +1268,8 @@ function psb_c_csr_maxval(a) result(res) class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='c_csr_maxval' logical, parameter :: debug=.false. @@ -3163,3 +3164,1667 @@ contains end subroutine csr_spspmm end subroutine psb_ccsrspspmm + + +! +! +! lc version +! +! +subroutine psb_lc_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_get_diag + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = cone + else + do i=1, mnm + d(i) = czero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = czero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_get_diag + + +subroutine psb_lc_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_scal + use psb_string_mod + implicit none + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_scal + + +subroutine psb_lc_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_scals + implicit none + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lc_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lc_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_reallocate_nz + +subroutine psb_lc_csr_mold(a,b,info) + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_mold + use psb_error_mod + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lc_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_mold + +subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_allocate_mnnz + + +subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csgetptn + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lc_csr_csgetrow + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lc_csr_csgetblk + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_csgetblk + + + +subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csput_a + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_lc_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_lc_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='lc_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_lc_csr_srch_upd + +end subroutine psb_lc_csr_csput_a + + +subroutine psb_lc_csr_reinit(a,clear) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_reinit + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_reinit + +subroutine psb_lc_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_trim + implicit none + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_trim + +subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_lc_csr_print + + +subroutine psb_lc_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_from_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='lc_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_lc_base_sparse_mat = tmp%psb_lc_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_lc_cp_csr_from_coo + + + +subroutine psb_lc_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_to_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lc_cp_csr_to_coo + + +subroutine psb_lc_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_to_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lc_mv_csr_to_coo + + + +subroutine psb_lc_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_from_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_lc_mv_csr_from_coo + + +subroutine psb_lc_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_to_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_lc_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_mv_csr_to_fmt + + +subroutine psb_lc_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_to_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_lc_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_cp_csr_to_fmt + + +subroutine psb_lc_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_from_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_lc_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_mv_csr_from_fmt + + + +subroutine psb_lc_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_from_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_lc_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_lc_cp_csr_from_fmt + +subroutine psb_lccsrspspmm(a,b,c,info) + use psb_c_mat_mod + use psb_serial_mod, psb_protect_name => psb_lccsrspspmm + + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + complex(psb_spk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_lccsrspspmm + diff --git a/base/serial/impl/psb_c_lbase_mat_impl.F90 b/base/serial/impl/psb_c_lbase_mat_impl.F90 index f022c1709..2457f7108 100644 --- a/base/serial/impl/psb_c_lbase_mat_impl.F90 +++ b/base/serial/impl/psb_c_lbase_mat_impl.F90 @@ -243,7 +243,7 @@ subroutine psb_lc_base_mv_from_coo(a,b,info) call psb_erractionrestore(err_act) return - +8 9999 call psb_error_handler(err_act) return @@ -2032,15 +2032,29 @@ subroutine psb_lc_base_cp_to_icoo(a,b,info) integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_lc_base_cp_to_icoo @@ -2054,17 +2068,31 @@ subroutine psb_lc_base_cp_from_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' + character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. - + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_lc_base_cp_from_icoo @@ -2290,7 +2318,3 @@ subroutine psb_lc_base_mv_from_ifmt(a,b,info) end subroutine psb_lc_base_mv_from_ifmt - - - - diff --git a/base/serial/impl/psb_c_lcoo_impl.f90 b/base/serial/impl/psb_c_lcoo_impl.f90 index 38fd1c38d..cbf1a6c73 100644 --- a/base/serial/impl/psb_c_lcoo_impl.f90 +++ b/base/serial/impl/psb_c_lcoo_impl.f90 @@ -3339,7 +3339,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) complex(psb_spk_), allocatable :: vs(:) integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' @@ -3617,10 +3617,11 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! ! If we did not have enough memory for buffers, ! let's try in place. - ! - call psi_msort_up(nzin,ia(1:),iaux(1:),iret) + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -3933,9 +3934,10 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -4045,7 +4047,7 @@ subroutine psb_lc_cp_coo_to_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz + integer(psb_ipk_) :: nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index e2141c803..b54808507 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -1999,3 +1999,1790 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_d_base_inner_vect_sv + + +subroutine psb_d_base_cp_to_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_to_lcoo + +subroutine psb_d_base_cp_from_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_from_lcoo + +subroutine psb_d_base_cp_to_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_to_lfmt + +subroutine psb_d_base_cp_from_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_from_lfmt + + +subroutine psb_d_base_mv_to_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_mv_to_lcoo + +subroutine psb_d_base_mv_from_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_mv_from_lcoo + + +subroutine psb_d_base_mv_to_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_d_base_mv_to_lfmt + +subroutine psb_d_base_mv_from_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_d_base_mv_from_lfmt + +! +! +! ld implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_ld_base_cp_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_cp_to_coo + +subroutine psb_ld_base_cp_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_cp_from_coo + + +subroutine psb_ld_base_cp_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_to_fmt + +subroutine psb_ld_base_cp_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_from_fmt + + +subroutine psb_ld_base_mv_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_to_coo + +subroutine psb_ld_base_mv_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_from_coo + + +subroutine psb_ld_base_mv_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_ld_base_mv_to_fmt + +subroutine psb_ld_base_mv_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_ld_base_mv_from_fmt + +subroutine psb_ld_base_clean_zeros(a, info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clean_zeros + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_ld_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_ld_base_clean_zeros + + +subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_a + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_csput_a + +subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_v + use psb_d_base_vect_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_csput_v + +subroutine psb_ld_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetrow + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetblk + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'ld_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_csgetblk + + +subroutine psb_ld_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csclip + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ld_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_tril + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_tril + +subroutine psb_ld_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_triu + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_triu + + + +subroutine psb_ld_base_clone(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clone + use psb_error_mod + implicit none + + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_ld_base_clone + +subroutine psb_ld_base_make_nonunit(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_make_nonunit + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = done + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_ld_base_make_nonunit + +subroutine psb_ld_base_mold(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mold + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_mold + +subroutine psb_ld_base_transp_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ld_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_transp_2mat + +subroutine psb_ld_base_transc_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_2mat + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ld_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ld_base_transc_2mat + +subroutine psb_ld_base_transp_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_ld_base_sparse_mat), intent(inout) :: a + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_transp_1mat + +subroutine psb_ld_base_transc_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_1mat + implicit none + + class(psb_ld_base_sparse_mat), intent(inout) :: a + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_transc_1mat + +subroutine psb_ld_base_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scals + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_scals + + + +subroutine psb_ld_base_scal(d,a,info,side) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scal + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_scal + + +subroutine psb_ld_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_get_diag + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_get_diag + + + +subroutine psb_ld_base_cp_to_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_to_icoo + +subroutine psb_ld_base_cp_from_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_from_icoo + + +subroutine psb_ld_base_cp_to_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_to_ifmt + +subroutine psb_ld_base_cp_from_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_from_ifmt + + +subroutine psb_ld_base_mv_to_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_to_icoo + +subroutine psb_ld_base_mv_from_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_from_icoo + + +subroutine psb_ld_base_mv_to_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_d_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_ld_base_mv_to_ifmt + +subroutine psb_ld_base_mv_from_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_d_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_ld_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 0ee30332f..93e4f594d 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -4019,3 +4019,2785 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_d_fix_coo_inner + +subroutine psb_d_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_lcoo + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_cp_coo_to_lcoo + +subroutine psb_d_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_lcoo + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_d_cp_coo_from_lcoo + + +! +! +! ld coo impl +! +! + +subroutine psb_ld_coo_get_diag(a,d,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = done + else + d(1:mnm) = dzero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_get_diag + + +subroutine psb_ld_coo_scal(d,a,info,side) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_scal + + +subroutine psb_ld_coo_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_scals + + +subroutine psb_ld_coo_reallocate_nz(nz,a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='ld_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_reallocate_nz + +subroutine psb_ld_coo_mold(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mold + use psb_error_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ld_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_mold + +subroutine psb_ld_coo_reinit(a,clear) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reinit + use psb_error_mod + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_reinit + + + +subroutine psb_ld_coo_trim(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_trim + +subroutine psb_ld_coo_clean_zeros(a, info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_zeros + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= dzero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_ld_coo_clean_zeros + + + +subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_allocate_mnnz + + + +subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_ld_coo_print + + + + +function psb_ld_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_nz_row + implicit none + + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_ld_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csgetptn + implicit none + + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_ld_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csgetrow + implicit none + + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_ld_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_ld_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_ld_coo_csgetrow + + +subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csput_a + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call ld_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + 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 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine ld_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='ld_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + 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) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + 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 > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine ld_coo_srch_upd + +end subroutine psb_ld_coo_csput_a + + +subroutine psb_ld_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_to_coo + +subroutine psb_ld_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_from_coo + + +subroutine psb_ld_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_to_fmt + +subroutine psb_ld_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_from_fmt + + +subroutine psb_ld_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_to_coo + +subroutine psb_ld_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_from_coo + + +subroutine psb_ld_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_to_fmt + +subroutine psb_ld_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_from_fmt + +subroutine psb_ld_coo_cp_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cp_from + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_cp_from + +subroutine psb_ld_coo_mv_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mv_from + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_mv_from + + + +subroutine psb_ld_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_ld_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_fix_coo + + + +subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + real(psb_dpk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + real(psb_dpk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_fix_coo_inner + + +subroutine psb_ld_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_icoo + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_to_icoo + +subroutine psb_ld_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_icoo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index cb0f1da07..2b3dcb262 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -1268,7 +1268,8 @@ function psb_d_csr_maxval(a) result(res) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='d_csr_maxval' logical, parameter :: debug=.false. @@ -3163,3 +3164,1667 @@ contains end subroutine csr_spspmm end subroutine psb_dcsrspspmm + + +! +! +! ld version +! +! +subroutine psb_ld_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_get_diag + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = done + else + do i=1, mnm + d(i) = dzero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = dzero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_get_diag + + +subroutine psb_ld_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_scal + use psb_string_mod + implicit none + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_scal + + +subroutine psb_ld_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_scals + implicit none + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ld_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ld_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_reallocate_nz + +subroutine psb_ld_csr_mold(a,b,info) + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_mold + use psb_error_mod + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ld_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_mold + +subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_allocate_mnnz + + +subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csgetptn + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ld_csr_csgetrow + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ld_csr_csgetblk + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_csgetblk + + + +subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csput_a + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_ld_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_ld_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='ld_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_ld_csr_srch_upd + +end subroutine psb_ld_csr_csput_a + + +subroutine psb_ld_csr_reinit(a,clear) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_reinit + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_reinit + +subroutine psb_ld_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_trim + implicit none + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_trim + +subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_ld_csr_print + + +subroutine psb_ld_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_from_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='ld_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_ld_base_sparse_mat = tmp%psb_ld_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_ld_cp_csr_from_coo + + + +subroutine psb_ld_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_to_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ld_cp_csr_to_coo + + +subroutine psb_ld_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_to_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ld_mv_csr_to_coo + + + +subroutine psb_ld_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_from_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_ld_mv_csr_from_coo + + +subroutine psb_ld_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_to_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_ld_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_mv_csr_to_fmt + + +subroutine psb_ld_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_to_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_ld_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_cp_csr_to_fmt + + +subroutine psb_ld_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_from_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_ld_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_mv_csr_from_fmt + + + +subroutine psb_ld_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_from_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_ld_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_ld_cp_csr_from_fmt + +subroutine psb_ldcsrspspmm(a,b,c,info) + use psb_d_mat_mod + use psb_serial_mod, psb_protect_name => psb_ldcsrspspmm + + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + real(psb_dpk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_ldcsrspspmm + diff --git a/base/serial/impl/psb_d_lbase_mat_impl.F90 b/base/serial/impl/psb_d_lbase_mat_impl.F90 index 44c0b4390..a592598c9 100644 --- a/base/serial/impl/psb_d_lbase_mat_impl.F90 +++ b/base/serial/impl/psb_d_lbase_mat_impl.F90 @@ -243,7 +243,7 @@ subroutine psb_ld_base_mv_from_coo(a,b,info) call psb_erractionrestore(err_act) return - +8 9999 call psb_error_handler(err_act) return @@ -2032,15 +2032,29 @@ subroutine psb_ld_base_cp_to_icoo(a,b,info) integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_ld_base_cp_to_icoo @@ -2054,17 +2068,31 @@ subroutine psb_ld_base_cp_from_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' + character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. - + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_ld_base_cp_from_icoo @@ -2290,7 +2318,3 @@ subroutine psb_ld_base_mv_from_ifmt(a,b,info) end subroutine psb_ld_base_mv_from_ifmt - - - - diff --git a/base/serial/impl/psb_d_lcoo_impl.f90 b/base/serial/impl/psb_d_lcoo_impl.f90 index 2d25eafcd..1ecaae17f 100644 --- a/base/serial/impl/psb_d_lcoo_impl.f90 +++ b/base/serial/impl/psb_d_lcoo_impl.f90 @@ -3339,7 +3339,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) real(psb_dpk_), allocatable :: vs(:) integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' @@ -3617,10 +3617,11 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! ! If we did not have enough memory for buffers, ! let's try in place. - ! - call psi_msort_up(nzin,ia(1:),iaux(1:),iret) + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -3933,9 +3934,10 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -4045,7 +4047,7 @@ subroutine psb_ld_cp_coo_to_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz + integer(psb_ipk_) :: nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 1e6dda4ca..7cc0237b0 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -1999,3 +1999,1790 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_s_base_inner_vect_sv + + +subroutine psb_s_base_cp_to_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_to_lcoo + +subroutine psb_s_base_cp_from_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_from_lcoo + +subroutine psb_s_base_cp_to_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_to_lfmt + +subroutine psb_s_base_cp_from_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_from_lfmt + + +subroutine psb_s_base_mv_to_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_mv_to_lcoo + +subroutine psb_s_base_mv_from_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_mv_from_lcoo + + +subroutine psb_s_base_mv_to_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_s_base_mv_to_lfmt + +subroutine psb_s_base_mv_from_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_s_base_mv_from_lfmt + +! +! +! ls implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_ls_base_cp_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_cp_to_coo + +subroutine psb_ls_base_cp_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_cp_from_coo + + +subroutine psb_ls_base_cp_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_to_fmt + +subroutine psb_ls_base_cp_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_from_fmt + + +subroutine psb_ls_base_mv_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_to_coo + +subroutine psb_ls_base_mv_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_from_coo + + +subroutine psb_ls_base_mv_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_ls_base_mv_to_fmt + +subroutine psb_ls_base_mv_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_ls_base_mv_from_fmt + +subroutine psb_ls_base_clean_zeros(a, info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clean_zeros + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_ls_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_ls_base_clean_zeros + + +subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_a + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_csput_a + +subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_v + use psb_s_base_vect_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_csput_v + +subroutine psb_ls_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetrow + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetblk + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'ls_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_csgetblk + + +subroutine psb_ls_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csclip + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ls_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_tril + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_spk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_tril + +subroutine psb_ls_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_triu + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_spk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_triu + + + +subroutine psb_ls_base_clone(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clone + use psb_error_mod + implicit none + + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_ls_base_clone + +subroutine psb_ls_base_make_nonunit(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_make_nonunit + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = sone + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_ls_base_make_nonunit + +subroutine psb_ls_base_mold(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mold + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_mold + +subroutine psb_ls_base_transp_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ls_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_transp_2mat + +subroutine psb_ls_base_transc_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_2mat + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ls_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ls_base_transc_2mat + +subroutine psb_ls_base_transp_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_ls_base_sparse_mat), intent(inout) :: a + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_transp_1mat + +subroutine psb_ls_base_transc_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_1mat + implicit none + + class(psb_ls_base_sparse_mat), intent(inout) :: a + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_transc_1mat + +subroutine psb_ls_base_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scals + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_scals + + + +subroutine psb_ls_base_scal(d,a,info,side) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scal + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_scal + + +subroutine psb_ls_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_get_diag + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_get_diag + + + +subroutine psb_ls_base_cp_to_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_to_icoo + +subroutine psb_ls_base_cp_from_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_from_icoo + + +subroutine psb_ls_base_cp_to_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_to_ifmt + +subroutine psb_ls_base_cp_from_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_from_ifmt + + +subroutine psb_ls_base_mv_to_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_to_icoo + +subroutine psb_ls_base_mv_from_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_from_icoo + + +subroutine psb_ls_base_mv_to_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_s_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_ls_base_mv_to_ifmt + +subroutine psb_ls_base_mv_from_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_s_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_ls_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index 254c91edc..8c7f50285 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -4019,3 +4019,2785 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_s_fix_coo_inner + +subroutine psb_s_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_lcoo + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_cp_coo_to_lcoo + +subroutine psb_s_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_lcoo + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_s_cp_coo_from_lcoo + + +! +! +! ls coo impl +! +! + +subroutine psb_ls_coo_get_diag(a,d,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = sone + else + d(1:mnm) = szero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_get_diag + + +subroutine psb_ls_coo_scal(d,a,info,side) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_scal + + +subroutine psb_ls_coo_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_scals + + +subroutine psb_ls_coo_reallocate_nz(nz,a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='ls_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_reallocate_nz + +subroutine psb_ls_coo_mold(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mold + use psb_error_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ls_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_mold + +subroutine psb_ls_coo_reinit(a,clear) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reinit + use psb_error_mod + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = szero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_reinit + + + +subroutine psb_ls_coo_trim(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_trim + +subroutine psb_ls_coo_clean_zeros(a, info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_zeros + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= szero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_ls_coo_clean_zeros + + + +subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_allocate_mnnz + + + +subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_ls_coo_print + + + + +function psb_ls_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_nz_row + implicit none + + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_ls_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csgetptn + implicit none + + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_ls_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csgetrow + implicit none + + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_ls_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_ls_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_ls_coo_csgetrow + + +subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csput_a + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call ls_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + 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 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine ls_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='ls_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + 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) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + 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 > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine ls_coo_srch_upd + +end subroutine psb_ls_coo_csput_a + + +subroutine psb_ls_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_to_coo + +subroutine psb_ls_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_from_coo + + +subroutine psb_ls_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_to_fmt + +subroutine psb_ls_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_from_fmt + + +subroutine psb_ls_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_to_coo + +subroutine psb_ls_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_from_coo + + +subroutine psb_ls_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_to_fmt + +subroutine psb_ls_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_from_fmt + +subroutine psb_ls_coo_cp_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cp_from + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_cp_from + +subroutine psb_ls_coo_mv_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mv_from + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_mv_from + + + +subroutine psb_ls_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_ls_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_fix_coo + + + +subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + real(psb_spk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + real(psb_spk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_fix_coo_inner + + +subroutine psb_ls_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_icoo + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_to_icoo + +subroutine psb_ls_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_icoo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index 1a3ebb9b8..0c5d6134b 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -1268,7 +1268,8 @@ function psb_s_csr_maxval(a) result(res) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='s_csr_maxval' logical, parameter :: debug=.false. @@ -3163,3 +3164,1667 @@ contains end subroutine csr_spspmm end subroutine psb_scsrspspmm + + +! +! +! ls version +! +! +subroutine psb_ls_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_get_diag + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = sone + else + do i=1, mnm + d(i) = szero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = szero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_get_diag + + +subroutine psb_ls_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_scal + use psb_string_mod + implicit none + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_scal + + +subroutine psb_ls_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_scals + implicit none + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ls_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ls_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_reallocate_nz + +subroutine psb_ls_csr_mold(a,b,info) + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_mold + use psb_error_mod + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ls_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_mold + +subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_allocate_mnnz + + +subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csgetptn + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ls_csr_csgetrow + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ls_csr_csgetblk + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_csgetblk + + + +subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csput_a + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_ls_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_ls_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='ls_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_ls_csr_srch_upd + +end subroutine psb_ls_csr_csput_a + + +subroutine psb_ls_csr_reinit(a,clear) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_reinit + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = szero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_reinit + +subroutine psb_ls_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_trim + implicit none + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_trim + +subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_ls_csr_print + + +subroutine psb_ls_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_from_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='ls_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_ls_base_sparse_mat = tmp%psb_ls_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_ls_cp_csr_from_coo + + + +subroutine psb_ls_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_to_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ls_cp_csr_to_coo + + +subroutine psb_ls_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_to_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ls_mv_csr_to_coo + + + +subroutine psb_ls_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_from_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_ls_mv_csr_from_coo + + +subroutine psb_ls_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_to_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_ls_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_mv_csr_to_fmt + + +subroutine psb_ls_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_to_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_ls_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_cp_csr_to_fmt + + +subroutine psb_ls_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_from_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_ls_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_mv_csr_from_fmt + + + +subroutine psb_ls_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_from_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_ls_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_ls_cp_csr_from_fmt + +subroutine psb_lscsrspspmm(a,b,c,info) + use psb_s_mat_mod + use psb_serial_mod, psb_protect_name => psb_lscsrspspmm + + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + real(psb_spk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_lscsrspspmm + diff --git a/base/serial/impl/psb_s_lbase_mat_impl.F90 b/base/serial/impl/psb_s_lbase_mat_impl.F90 index 9dc5006ea..8f0569f3a 100644 --- a/base/serial/impl/psb_s_lbase_mat_impl.F90 +++ b/base/serial/impl/psb_s_lbase_mat_impl.F90 @@ -243,7 +243,7 @@ subroutine psb_ls_base_mv_from_coo(a,b,info) call psb_erractionrestore(err_act) return - +8 9999 call psb_error_handler(err_act) return @@ -2032,15 +2032,29 @@ subroutine psb_ls_base_cp_to_icoo(a,b,info) integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_ls_base_cp_to_icoo @@ -2054,17 +2068,31 @@ subroutine psb_ls_base_cp_from_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' + character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. - + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_ls_base_cp_from_icoo @@ -2290,7 +2318,3 @@ subroutine psb_ls_base_mv_from_ifmt(a,b,info) end subroutine psb_ls_base_mv_from_ifmt - - - - diff --git a/base/serial/impl/psb_s_lcoo_impl.f90 b/base/serial/impl/psb_s_lcoo_impl.f90 index e1ae1c093..ca02aee1e 100644 --- a/base/serial/impl/psb_s_lcoo_impl.f90 +++ b/base/serial/impl/psb_s_lcoo_impl.f90 @@ -3339,7 +3339,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) real(psb_spk_), allocatable :: vs(:) integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' @@ -3617,10 +3617,11 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! ! If we did not have enough memory for buffers, ! let's try in place. - ! - call psi_msort_up(nzin,ia(1:),iaux(1:),iret) + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -3933,9 +3934,10 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -4045,7 +4047,7 @@ subroutine psb_ls_cp_coo_to_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz + integer(psb_ipk_) :: nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index b1d78d7bc..765ff0db7 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -1999,3 +1999,1790 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_z_base_inner_vect_sv + + +subroutine psb_z_base_cp_to_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_to_lcoo + +subroutine psb_z_base_cp_from_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_from_lcoo + +subroutine psb_z_base_cp_to_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_to_lfmt + +subroutine psb_z_base_cp_from_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_from_lfmt + + +subroutine psb_z_base_mv_to_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_mv_to_lcoo + +subroutine psb_z_base_mv_from_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_mv_from_lcoo + + +subroutine psb_z_base_mv_to_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_lcoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_z_base_mv_to_lfmt + +subroutine psb_z_base_mv_from_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_icoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_z_base_mv_from_lfmt + +! +! +! lz implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_lz_base_cp_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_cp_to_coo + +subroutine psb_lz_base_cp_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_cp_from_coo + + +subroutine psb_lz_base_cp_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_to_fmt + +subroutine psb_lz_base_cp_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_from_fmt + + +subroutine psb_lz_base_mv_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_to_coo + +subroutine psb_lz_base_mv_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_from_coo + + +subroutine psb_lz_base_mv_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_lz_base_mv_to_fmt + +subroutine psb_lz_base_mv_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_lz_base_mv_from_fmt + +subroutine psb_lz_base_clean_zeros(a, info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clean_zeros + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_lz_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_lz_base_clean_zeros + + +subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_a + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_csput_a + +subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_v + use psb_z_base_vect_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_csput_v + +subroutine psb_lz_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetrow + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetblk + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'lz_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_csgetblk + + +subroutine psb_lz_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csclip + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lz_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_tril + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_tril + +subroutine psb_lz_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_triu + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_ + call a%csget(i,i,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + j = ja(k) + if (j-i= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_triu + + + +subroutine psb_lz_base_clone(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clone + use psb_error_mod + implicit none + + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_lz_base_clone + +subroutine psb_lz_base_make_nonunit(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_make_nonunit + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = zone + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_lz_base_make_nonunit + +subroutine psb_lz_base_mold(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mold + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_mold + +subroutine psb_lz_base_transp_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lz_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_transp_2mat + +subroutine psb_lz_base_transc_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_2mat + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lz_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lz_base_transc_2mat + +subroutine psb_lz_base_transp_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_lz_base_sparse_mat), intent(inout) :: a + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_transp_1mat + +subroutine psb_lz_base_transc_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_1mat + implicit none + + class(psb_lz_base_sparse_mat), intent(inout) :: a + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_transc_1mat + +subroutine psb_lz_base_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scals + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_scals + + + +subroutine psb_lz_base_scal(d,a,info,side) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scal + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_scal + + +subroutine psb_lz_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_get_diag + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_get_diag + + + +subroutine psb_lz_base_cp_to_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_to_icoo + +subroutine psb_lz_base_cp_from_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_from_icoo + + +subroutine psb_lz_base_cp_to_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_to_ifmt + +subroutine psb_lz_base_cp_from_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_from_ifmt + + +subroutine psb_lz_base_mv_to_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_to_icoo + +subroutine psb_lz_base_mv_from_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_from_icoo + + +subroutine psb_lz_base_mv_to_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_z_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_icoo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_lz_base_mv_to_ifmt + +subroutine psb_lz_base_mv_from_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_z_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_lcoo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_lz_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index 6a54a022f..cad045405 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -4019,3 +4019,2785 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_z_fix_coo_inner + +subroutine psb_z_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_lcoo + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_cp_coo_to_lcoo + +subroutine psb_z_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_lcoo + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_z_cp_coo_from_lcoo + + +! +! +! lz coo impl +! +! + +subroutine psb_lz_coo_get_diag(a,d,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = zone + else + d(1:mnm) = zzero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_get_diag + + +subroutine psb_lz_coo_scal(d,a,info,side) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_scal + + +subroutine psb_lz_coo_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_scals + + +subroutine psb_lz_coo_reallocate_nz(nz,a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='lz_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_reallocate_nz + +subroutine psb_lz_coo_mold(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mold + use psb_error_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lz_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_mold + +subroutine psb_lz_coo_reinit(a,clear) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reinit + use psb_error_mod + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_reinit + + + +subroutine psb_lz_coo_trim(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_trim + +subroutine psb_lz_coo_clean_zeros(a, info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_clean_zeros + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= zzero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_lz_coo_clean_zeros + + + +subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_allocate_mnnz + + + +subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_lz_coo_print + + + + +function psb_lz_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_nz_row + implicit none + + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_lz_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csgetptn + implicit none + + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_lz_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csgetrow + implicit none + + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_lz_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_lz_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_lz_coo_csgetrow + + +subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csput_a + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call lz_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + 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 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine lz_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='lz_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + 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) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + 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 > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine lz_coo_srch_upd + +end subroutine psb_lz_coo_csput_a + + +subroutine psb_lz_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_to_coo + +subroutine psb_lz_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_from_coo + + +subroutine psb_lz_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_to_fmt + +subroutine psb_lz_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_from_fmt + + +subroutine psb_lz_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_to_coo + +subroutine psb_lz_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_from_coo + + +subroutine psb_lz_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_to_fmt + +subroutine psb_lz_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_from_fmt + +subroutine psb_lz_coo_cp_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cp_from + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_cp_from + +subroutine psb_lz_coo_mv_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mv_from + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_mv_from + + + +subroutine psb_lz_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_lz_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_fix_coo + + + +subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + complex(psb_dpk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_fix_coo_inner + + +subroutine psb_lz_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_icoo + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_to_icoo + +subroutine psb_lz_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_icoo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index e9aee0523..3c8335b23 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -1268,7 +1268,8 @@ function psb_z_csr_maxval(a) result(res) class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='z_csr_maxval' logical, parameter :: debug=.false. @@ -3163,3 +3164,1667 @@ contains end subroutine csr_spspmm end subroutine psb_zcsrspspmm + + +! +! +! lz version +! +! +subroutine psb_lz_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_get_diag + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = zone + else + do i=1, mnm + d(i) = zzero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = zzero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_get_diag + + +subroutine psb_lz_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_scal + use psb_string_mod + implicit none + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_scal + + +subroutine psb_lz_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_scals + implicit none + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lz_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lz_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_reallocate_nz + +subroutine psb_lz_csr_mold(a,b,info) + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_mold + use psb_error_mod + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lz_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_mold + +subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_allocate_mnnz + + +subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csgetptn + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lz_csr_csgetrow + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lz_csr_csgetblk + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_csgetblk + + + +subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csput_a + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_lz_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_lz_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='lz_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + 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 > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_lz_csr_srch_upd + +end subroutine psb_lz_csr_csput_a + + +subroutine psb_lz_csr_reinit(a,clear) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_reinit + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_reinit + +subroutine psb_lz_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_trim + implicit none + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_trim + +subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_lz_csr_print + + +subroutine psb_lz_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_from_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='lz_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_lz_base_sparse_mat = tmp%psb_lz_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_lz_cp_csr_from_coo + + + +subroutine psb_lz_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_to_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lz_cp_csr_to_coo + + +subroutine psb_lz_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_to_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lz_mv_csr_to_coo + + + +subroutine psb_lz_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_from_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_lz_mv_csr_from_coo + + +subroutine psb_lz_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_to_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_lz_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_mv_csr_to_fmt + + +subroutine psb_lz_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_to_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_lz_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_cp_csr_to_fmt + + +subroutine psb_lz_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_from_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_lz_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_mv_csr_from_fmt + + + +subroutine psb_lz_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_from_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_lz_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_lz_cp_csr_from_fmt + +subroutine psb_lzcsrspspmm(a,b,c,info) + use psb_z_mat_mod + use psb_serial_mod, psb_protect_name => psb_lzcsrspspmm + + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + complex(psb_dpk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_lzcsrspspmm + diff --git a/base/serial/impl/psb_z_lbase_mat_impl.F90 b/base/serial/impl/psb_z_lbase_mat_impl.F90 index 927620dbe..e78f3f874 100644 --- a/base/serial/impl/psb_z_lbase_mat_impl.F90 +++ b/base/serial/impl/psb_z_lbase_mat_impl.F90 @@ -243,7 +243,7 @@ subroutine psb_lz_base_mv_from_coo(a,b,info) call psb_erractionrestore(err_act) return - +8 9999 call psb_error_handler(err_act) return @@ -2032,15 +2032,29 @@ subroutine psb_lz_base_cp_to_icoo(a,b,info) integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_lz_base_cp_to_icoo @@ -2054,17 +2068,31 @@ subroutine psb_lz_base_cp_from_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - character(len=20) :: name='from_coo' + character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. - + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=a%get_fmt()) - call psb_error_handler(err_act) + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return end subroutine psb_lz_base_cp_from_icoo @@ -2290,7 +2318,3 @@ subroutine psb_lz_base_mv_from_ifmt(a,b,info) end subroutine psb_lz_base_mv_from_ifmt - - - - diff --git a/base/serial/impl/psb_z_lcoo_impl.f90 b/base/serial/impl/psb_z_lcoo_impl.f90 index c033f90f3..9c512e730 100644 --- a/base/serial/impl/psb_z_lcoo_impl.f90 +++ b/base/serial/impl/psb_z_lcoo_impl.f90 @@ -3339,7 +3339,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) complex(psb_dpk_), allocatable :: vs(:) integer(psb_lpk_) :: nza - integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' @@ -3617,10 +3617,11 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! ! If we did not have enough memory for buffers, ! let's try in place. - ! - call psi_msort_up(nzin,ia(1:),iaux(1:),iret) + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -3933,9 +3934,10 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_msort_up(nzin,ja(1:),iaux(1:),iret) + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) if (iret == 0) & - & call psb_ip_reord(nzin,val,ia,ja,iaux) + & call psb_ip_reord(inzin,val,ia,ja,iaux) i = 1 j = i do while (i <= nzin) @@ -4045,7 +4047,7 @@ subroutine psb_lz_cp_coo_to_icoo(a,b,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nz + integer(psb_ipk_) :: nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false.