From 241f90a13c0e503a19a10fd6d47f0b76c6237658 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 27 Feb 2011 16:33:27 +0000 Subject: [PATCH] psblas3: base/modules/psb_serial_mod.f90 base/serial/Makefile base/serial/impl/psb_c_coo_impl.f90 base/serial/impl/psb_c_csc_impl.f90 base/serial/impl/psb_c_csr_impl.f90 base/serial/impl/psb_z_coo_impl.f90 base/serial/impl/psb_z_csc_impl.f90 base/serial/impl/psb_z_csr_impl.f90 base/serial/psb_cgeprt.f90 base/serial/psb_sgeprt.f90 base/serial/psb_zgeprt.f90 Methods for GEPRT in all variants. Fixed print for complex sparse matrices. --- base/modules/psb_serial_mod.f90 | 72 +++++++++++ base/serial/Makefile | 2 +- base/serial/impl/psb_c_coo_impl.f90 | 4 +- base/serial/impl/psb_c_csc_impl.f90 | 4 +- base/serial/impl/psb_c_csr_impl.f90 | 4 +- base/serial/impl/psb_z_coo_impl.f90 | 4 +- base/serial/impl/psb_z_csc_impl.f90 | 4 +- base/serial/impl/psb_z_csr_impl.f90 | 4 +- base/serial/psb_cgeprt.f90 | 179 ++++++++++++++++++++++++++++ base/serial/psb_sgeprt.f90 | 179 ++++++++++++++++++++++++++++ base/serial/psb_zgeprt.f90 | 179 ++++++++++++++++++++++++++++ 11 files changed, 622 insertions(+), 13 deletions(-) create mode 100644 base/serial/psb_cgeprt.f90 create mode 100644 base/serial/psb_sgeprt.f90 create mode 100644 base/serial/psb_zgeprt.f90 diff --git a/base/modules/psb_serial_mod.f90 b/base/modules/psb_serial_mod.f90 index ad14fb1a..df535d72 100644 --- a/base/modules/psb_serial_mod.f90 +++ b/base/modules/psb_serial_mod.f90 @@ -228,6 +228,30 @@ module psb_serial_mod interface psb_geprt + subroutine psb_sgeprtn2(fname,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + character(len=*), intent(in) :: fname + real(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + end subroutine psb_sgeprtn2 + subroutine psb_sgeprtn1(fname,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + character(len=*), intent(in) :: fname + real(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + end subroutine psb_sgeprtn1 + subroutine psb_sgeprt2(iout,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + integer, intent(in) :: iout + real(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + end subroutine psb_sgeprt2 + subroutine psb_sgeprt1(iout,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + integer, intent(in) :: iout + real(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + end subroutine psb_sgeprt1 subroutine psb_dgeprtn2(fname,a,head) use psb_const_mod, only : psb_spk_, psb_dpk_ character(len=*), intent(in) :: fname @@ -252,6 +276,54 @@ module psb_serial_mod real(psb_dpk_), intent(in) :: a(:) character(len=*), optional :: head end subroutine psb_dgeprt1 + subroutine psb_cgeprtn2(fname,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + character(len=*), intent(in) :: fname + complex(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + end subroutine psb_cgeprtn2 + subroutine psb_cgeprtn1(fname,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + character(len=*), intent(in) :: fname + complex(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + end subroutine psb_cgeprtn1 + subroutine psb_cgeprt2(iout,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + integer, intent(in) :: iout + complex(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + end subroutine psb_cgeprt2 + subroutine psb_cgeprt1(iout,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + integer, intent(in) :: iout + complex(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + end subroutine psb_cgeprt1 + subroutine psb_zgeprtn2(fname,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + character(len=*), intent(in) :: fname + complex(psb_dpk_), intent(in) :: a(:,:) + character(len=*), optional :: head + end subroutine psb_zgeprtn2 + subroutine psb_zgeprtn1(fname,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + character(len=*), intent(in) :: fname + complex(psb_dpk_), intent(in) :: a(:) + character(len=*), optional :: head + end subroutine psb_zgeprtn1 + subroutine psb_zgeprt2(iout,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + integer, intent(in) :: iout + complex(psb_dpk_), intent(in) :: a(:,:) + character(len=*), optional :: head + end subroutine psb_zgeprt2 + subroutine psb_zgeprt1(iout,a,head) + use psb_const_mod, only : psb_spk_, psb_dpk_ + integer, intent(in) :: iout + complex(psb_dpk_), intent(in) :: a(:) + character(len=*), optional :: head + end subroutine psb_zgeprt1 end interface diff --git a/base/serial/Makefile b/base/serial/Makefile index cd20e8cd..1e226e52 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -5,7 +5,7 @@ FOBJS = psb_lsame.o psi_serial_impl.o psb_sort_impl.o \ psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o \ psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \ psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o \ - psb_dgeprt.o + psb_sgeprt.o psb_dgeprt.o psb_cgeprt.o psb_zgeprt.o LIBDIR=.. MODDIR=../modules diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index 61158f65..02a72f71 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -366,7 +366,7 @@ subroutine psb_c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) endif if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' write(iout,'(a,a)') '% ',head write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' @@ -378,7 +378,7 @@ subroutine psb_c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) nmx = max(nr,nc,1) ni = floor(log10(1.0*nmx)) + 1 - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' write(iout,*) nr, nc, nz if(present(iv)) then do j=1,a%get_nzeros() diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index 257aaadc..261e2709 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -2909,7 +2909,7 @@ subroutine psb_c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) endif if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' write(iout,'(a,a)') '% ',head write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' @@ -2921,7 +2921,7 @@ subroutine psb_c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) nmx = max(nr,nc,1) ni = floor(log10(1.0*nmx)) + 1 - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' write(iout,*) nr, nc, nz if(present(iv)) then do i=1, nr diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index 3e83f3fa..aa194d92 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -2356,7 +2356,7 @@ subroutine psb_c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) endif if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' write(iout,'(a,a)') '% ',head write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' @@ -2368,7 +2368,7 @@ subroutine psb_c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) nmx = max(nr,nc,1) ni = floor(log10(1.0*nmx)) + 1 - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' write(iout,*) nr, nc, nz if(present(iv)) then do i=1, nr diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index b8139250..1a9ae21e 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -366,7 +366,7 @@ subroutine psb_z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) endif if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' write(iout,'(a,a)') '% ',head write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' @@ -378,7 +378,7 @@ subroutine psb_z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) nmx = max(nr,nc,1) ni = floor(log10(1.0*nmx)) + 1 - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' write(iout,*) nr, nc, nz if(present(iv)) then do j=1,a%get_nzeros() diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index d0c7ad66..6eca9d88 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -2909,7 +2909,7 @@ subroutine psb_z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) endif if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' write(iout,'(a,a)') '% ',head write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' @@ -2921,7 +2921,7 @@ subroutine psb_z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) nmx = max(nr,nc,1) ni = floor(log10(1.0*nmx)) + 1 - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' write(iout,*) nr, nc, nz if(present(iv)) then do i=1, nr diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index 39b32d81..a0d9b02f 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -2355,7 +2355,7 @@ subroutine psb_z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) endif if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' write(iout,'(a,a)') '% ',head write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' @@ -2367,7 +2367,7 @@ subroutine psb_z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) nmx = max(nr,nc,1) ni = floor(log10(1.0*nmx)) + 1 - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' write(iout,*) nr, nc, nz if(present(iv)) then do i=1, nr diff --git a/base/serial/psb_cgeprt.f90 b/base/serial/psb_cgeprt.f90 new file mode 100644 index 00000000..eeb8e9be --- /dev/null +++ b/base/serial/psb_cgeprt.f90 @@ -0,0 +1,179 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_scsprt.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* Print out a matrix. * +!* Should really align with the F77 version under the SERIAL dir, which * +!* does a nice printout in MatrixMarket format; this would be a quick job. * +!* * +!* Handles both a shift in the row/col indices and a fuctional transform * +!* on the indices. * +!* * +!* * +!* * +!* * +!***************************************************************************** +subroutine psb_cgeprtn2(fname,a,head) + use psb_serial_mod, psb_protect_name => psb_cgeprtn2 + implicit none + + character(len=*), intent(in) :: fname + complex(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + + ! + integer :: iout, info + logical :: isopen + + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call psb_geprt(iout,a,head) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + +end subroutine psb_cgeprtn2 + +subroutine psb_cgeprtn1(fname,a,head) + use psb_serial_mod, psb_protect_name => psb_cgeprtn1 + implicit none + + character(len=*), intent(in) :: fname + complex(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + + ! + integer :: iout, info + logical :: isopen + + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call psb_geprt(iout,a,head) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + +end subroutine psb_cgeprtn1 + +subroutine psb_cgeprt2(iout,a,head) + use psb_serial_mod, psb_protect_name => psb_cgeprt2 + implicit none + + integer, intent(in) :: iout + complex(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nrow, ncol + + write(iout,'(a)') '%%MatrixMarket matrix array complex general' + write(iout,'(a)') '% '//trim(head) + write(iout,'(a)') '% ' + nrow = size(a,1) + ncol = size(a,2) + write(iout,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'2(es26.18,1x))' + + do i=1,nrow + write(iout,frmtv) a(i,1:ncol) + end do + + if (iout /= 6) close(iout) + + return + ! open failed +901 write(psb_err_unit,*) 'geprt: could not open file ',& + & iout,' for output' + return +end subroutine psb_cgeprt2 + +subroutine psb_cgeprt1(iout,a,head) + use psb_serial_mod, psb_protect_name => psb_cgeprt1 + implicit none + + integer, intent(in) :: iout + complex(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nrow, ncol + + write(iout,'(a)') '%%MatrixMarket matrix array complex general' + write(iout,'(a)') '% '//trim(head) + write(iout,'(a)') '% ' + nrow = size(a,1) + ncol = 1 + write(iout,*) nrow + + write(frmtv,'(a,i3.3,a)') '(',ncol,'2(es26.18,1x))' + + do i=1,nrow + write(iout,frmtv) a(i) + end do + + if (iout /= 6) close(iout) + + return + ! open failed +901 write(psb_err_unit,*) 'geprt: could not open file ',& + & iout,' for output' + return +end subroutine psb_cgeprt1 diff --git a/base/serial/psb_sgeprt.f90 b/base/serial/psb_sgeprt.f90 new file mode 100644 index 00000000..2f2c4187 --- /dev/null +++ b/base/serial/psb_sgeprt.f90 @@ -0,0 +1,179 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_scsprt.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* Print out a matrix. * +!* Should really align with the F77 version under the SERIAL dir, which * +!* does a nice printout in MatrixMarket format; this would be a quick job. * +!* * +!* Handles both a shift in the row/col indices and a fuctional transform * +!* on the indices. * +!* * +!* * +!* * +!* * +!***************************************************************************** +subroutine psb_sgeprtn2(fname,a,head) + use psb_serial_mod, psb_protect_name => psb_sgeprtn2 + implicit none + + character(len=*), intent(in) :: fname + real(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + + ! + integer :: iout, info + logical :: isopen + + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call psb_geprt(iout,a,head) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + +end subroutine psb_sgeprtn2 + +subroutine psb_sgeprtn1(fname,a,head) + use psb_serial_mod, psb_protect_name => psb_sgeprtn1 + implicit none + + character(len=*), intent(in) :: fname + real(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + + ! + integer :: iout, info + logical :: isopen + + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call psb_geprt(iout,a,head) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + +end subroutine psb_sgeprtn1 + +subroutine psb_sgeprt2(iout,a,head) + use psb_serial_mod, psb_protect_name => psb_sgeprt2 + implicit none + + integer, intent(in) :: iout + real(psb_spk_), intent(in) :: a(:,:) + character(len=*), optional :: head + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nrow, ncol + + write(iout,'(a)') '%%MatrixMarket matrix array real general' + write(iout,'(a)') '% '//trim(head) + write(iout,'(a)') '% ' + nrow = size(a,1) + ncol = size(a,2) + write(iout,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,nrow + write(iout,frmtv) a(i,1:ncol) + end do + + if (iout /= 6) close(iout) + + return + ! open failed +901 write(psb_err_unit,*) 'geprt: could not open file ',& + & iout,' for output' + return +end subroutine psb_sgeprt2 + +subroutine psb_sgeprt1(iout,a,head) + use psb_serial_mod, psb_protect_name => psb_sgeprt1 + implicit none + + integer, intent(in) :: iout + real(psb_spk_), intent(in) :: a(:) + character(len=*), optional :: head + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nrow, ncol + + write(iout,'(a)') '%%MatrixMarket matrix array real general' + write(iout,'(a)') '% '//trim(head) + write(iout,'(a)') '% ' + nrow = size(a,1) + ncol = 1 + write(iout,*) nrow + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,nrow + write(iout,frmtv) a(i) + end do + + if (iout /= 6) close(iout) + + return + ! open failed +901 write(psb_err_unit,*) 'geprt: could not open file ',& + & iout,' for output' + return +end subroutine psb_sgeprt1 diff --git a/base/serial/psb_zgeprt.f90 b/base/serial/psb_zgeprt.f90 new file mode 100644 index 00000000..015e0d5f --- /dev/null +++ b/base/serial/psb_zgeprt.f90 @@ -0,0 +1,179 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_scsprt.f90 +! Subroutine: +! Arguments: + +!***************************************************************************** +!* * +!* Print out a matrix. * +!* Should really align with the F77 version under the SERIAL dir, which * +!* does a nice printout in MatrixMarket format; this would be a quick job. * +!* * +!* Handles both a shift in the row/col indices and a fuctional transform * +!* on the indices. * +!* * +!* * +!* * +!* * +!***************************************************************************** +subroutine psb_zgeprtn2(fname,a,head) + use psb_serial_mod, psb_protect_name => psb_zgeprtn2 + implicit none + + character(len=*), intent(in) :: fname + complex(psb_dpk_), intent(in) :: a(:,:) + character(len=*), optional :: head + + ! + integer :: iout, info + logical :: isopen + + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call psb_geprt(iout,a,head) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + +end subroutine psb_zgeprtn2 + +subroutine psb_zgeprtn1(fname,a,head) + use psb_serial_mod, psb_protect_name => psb_zgeprtn1 + implicit none + + character(len=*), intent(in) :: fname + complex(psb_dpk_), intent(in) :: a(:) + character(len=*), optional :: head + + ! + integer :: iout, info + logical :: isopen + + ! Search for an unused unit to write + iout = 7 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call psb_geprt(iout,a,head) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + +end subroutine psb_zgeprtn1 + +subroutine psb_zgeprt2(iout,a,head) + use psb_serial_mod, psb_protect_name => psb_zgeprt2 + implicit none + + integer, intent(in) :: iout + complex(psb_dpk_), intent(in) :: a(:,:) + character(len=*), optional :: head + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nrow, ncol + + write(iout,'(a)') '%%MatrixMarket matrix array complex general' + write(iout,'(a)') '% '//trim(head) + write(iout,'(a)') '% ' + nrow = size(a,1) + ncol = size(a,2) + write(iout,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'2(es26.18,1x))' + + do i=1,nrow + write(iout,frmtv) a(i,1:ncol) + end do + + if (iout /= 6) close(iout) + + return + ! open failed +901 write(psb_err_unit,*) 'geprt: could not open file ',& + & iout,' for output' + return +end subroutine psb_zgeprt2 + +subroutine psb_zgeprt1(iout,a,head) + use psb_serial_mod, psb_protect_name => psb_zgeprt1 + implicit none + + integer, intent(in) :: iout + complex(psb_dpk_), intent(in) :: a(:) + character(len=*), optional :: head + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nrow, ncol + + write(iout,'(a)') '%%MatrixMarket matrix array complex general' + write(iout,'(a)') '% '//trim(head) + write(iout,'(a)') '% ' + nrow = size(a,1) + ncol = 1 + write(iout,*) nrow + + write(frmtv,'(a,i3.3,a)') '(',ncol,'2(es26.18,1x))' + + do i=1,nrow + write(iout,frmtv) a(i) + end do + + if (iout /= 6) close(iout) + + return + ! open failed +901 write(psb_err_unit,*) 'geprt: could not open file ',& + & iout,' for output' + return +end subroutine psb_zgeprt1