diff --git a/util/psb_hbio_mod.f90 b/util/psb_hbio_mod.f90 index df165879..7f2fa485 100644 --- a/util/psb_hbio_mod.f90 +++ b/util/psb_hbio_mod.f90 @@ -56,7 +56,7 @@ contains character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 integer :: indcrd, ptrcrd, totcrd,& & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_s_csr_sparse_mat) :: acsr + type(psb_s_csc_sparse_mat) :: acsc type(psb_s_coo_sparse_mat) :: acoo integer :: ircode, i,nzr,infile, info character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' @@ -88,7 +88,7 @@ contains & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - call acsr%allocate(nrow,ncol,nnzero) + call acsc%allocate(nrow,ncol,nnzero) if (ircode /= 0 ) then write(0,*) 'Memory allocation failed' goto 993 @@ -101,11 +101,11 @@ contains if (psb_tolower(type(2:2)) == 'u') then - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - call a%mv_from(acsr) + call a%mv_from(acsc) if (present(b)) then if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then @@ -131,9 +131,9 @@ contains ! we are generally working with non-symmetric matrices, so ! we de-symmetrize what we are about to read - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) if (present(b)) then @@ -156,7 +156,7 @@ contains endif - call acoo%mv_from_fmt(acsr,info) + call acoo%mv_from_fmt(acsc,info) call acoo%reallocate(2*nnzero) ! A is now in COO format nzr = nnzero @@ -171,7 +171,6 @@ contains call acoo%set_nzeros(nzr) call acoo%fix(ircode) if (ircode==0) call a%mv_from(acoo) - if (ircode==0) call a%cscnv(ircode,type='csr') if (ircode/=0) goto 993 else @@ -182,6 +181,8 @@ contains write(0,*) 'read_matrix: matrix type not yet supported' iret=904 end if + + call a%cscnv(ircode,type='csr') if (infile/=5) close(infile) return @@ -201,7 +202,7 @@ contains subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) use psb_base_mod implicit none - type(psb_s_sparse_mat), intent(in) :: a + type(psb_s_sparse_mat), intent(in), target :: a integer, intent(out) :: iret character(len=*), optional, intent(in) :: mtitle integer, optional, intent(in) :: iunit @@ -217,7 +218,9 @@ contains character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - + + type(psb_s_csc_sparse_mat), target :: acsc + type(psb_s_csc_sparse_mat), pointer :: acpnt character(len=72) :: mtitle_ character(len=8) :: key_ @@ -246,7 +249,7 @@ contains iout=6 endif endif - + if (present(mtitle)) then mtitle_ = mtitle else @@ -258,65 +261,72 @@ contains key_ = 'PSBMAT00' endif - + select type(aa=>a%a) - type is (psb_s_csr_sparse_mat) - - nrow = aa%get_nrows() - ncol = aa%get_ncols() - nnzero = aa%get_nzeros() - - neltvl = 0 - - ptrcrd = (nrow+1)/jptr - if (mod(nrow+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'RUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (aa%irp(i),i=1,nrow+1) - write (iout,fmt=indfmt) (aa%ja(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (aa%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + type is (psb_s_csc_sparse_mat) + acpnt => aa class default - write(0,*) 'format: ',a%get_fmt(),' not yet implemented' + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc end select + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'RUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + if (iout /= 6) close(iout) @@ -329,10 +339,11 @@ contains end subroutine shb_write + subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle) use psb_base_mod implicit none - type(psb_d_sparse_mat), intent(out) :: a + type(psb_d_sparse_mat), intent(out) :: a integer, intent(out) :: iret integer, optional, intent(in) :: iunit character(len=*), optional, intent(in) :: filename @@ -344,7 +355,7 @@ contains character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 integer :: indcrd, ptrcrd, totcrd,& & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_d_csr_sparse_mat) :: acsr + type(psb_d_csc_sparse_mat) :: acsc type(psb_d_coo_sparse_mat) :: acoo integer :: ircode, i,nzr,infile, info character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' @@ -376,7 +387,7 @@ contains & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - call acsr%allocate(nrow,ncol,nnzero) + call acsc%allocate(nrow,ncol,nnzero) if (ircode /= 0 ) then write(0,*) 'Memory allocation failed' goto 993 @@ -389,11 +400,11 @@ contains if (psb_tolower(type(2:2)) == 'u') then - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - call a%mv_from(acsr) + call a%mv_from(acsc) if (present(b)) then if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then @@ -419,9 +430,9 @@ contains ! we are generally working with non-symmetric matrices, so ! we de-symmetrize what we are about to read - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) if (present(b)) then @@ -444,7 +455,7 @@ contains endif - call acoo%mv_from_fmt(acsr,info) + call acoo%mv_from_fmt(acsc,info) call acoo%reallocate(2*nnzero) ! A is now in COO format nzr = nnzero @@ -459,7 +470,6 @@ contains call acoo%set_nzeros(nzr) call acoo%fix(ircode) if (ircode==0) call a%mv_from(acoo) - if (ircode==0) call a%cscnv(ircode,type='csr') if (ircode/=0) goto 993 else @@ -470,6 +480,8 @@ contains write(0,*) 'read_matrix: matrix type not yet supported' iret=904 end if + + call a%cscnv(ircode,type='csr') if (infile/=5) close(infile) return @@ -489,7 +501,7 @@ contains subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) use psb_base_mod implicit none - type(psb_d_sparse_mat), intent(in) :: a + type(psb_d_sparse_mat), intent(in), target :: a integer, intent(out) :: iret character(len=*), optional, intent(in) :: mtitle integer, optional, intent(in) :: iunit @@ -505,7 +517,9 @@ contains character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - + + type(psb_d_csc_sparse_mat), target :: acsc + type(psb_d_csc_sparse_mat), pointer :: acpnt character(len=72) :: mtitle_ character(len=8) :: key_ @@ -534,7 +548,7 @@ contains iout=6 endif endif - + if (present(mtitle)) then mtitle_ = mtitle else @@ -546,65 +560,72 @@ contains key_ = 'PSBMAT00' endif - + select type(aa=>a%a) - type is (psb_d_csr_sparse_mat) - - nrow = aa%get_nrows() - ncol = aa%get_ncols() - nnzero = aa%get_nzeros() - - neltvl = 0 - - ptrcrd = (nrow+1)/jptr - if (mod(nrow+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'RUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (aa%irp(i),i=1,nrow+1) - write (iout,fmt=indfmt) (aa%ja(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (aa%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + type is (psb_s_csc_sparse_mat) + acpnt => aa class default - write(0,*) 'format: ',a%get_fmt(),' not yet implemented' + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc end select + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'RUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + if (iout /= 6) close(iout) @@ -616,6 +637,9 @@ contains return end subroutine dhb_write + + + subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) use psb_base_mod implicit none @@ -631,7 +655,7 @@ contains character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 integer :: indcrd, ptrcrd, totcrd,& & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_c_csr_sparse_mat) :: acsr + type(psb_c_csc_sparse_mat) :: acsc type(psb_c_coo_sparse_mat) :: acoo integer :: ircode, i,nzr,infile, info character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' @@ -663,7 +687,7 @@ contains & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - call acsr%allocate(nrow,ncol,nnzero) + call acsc%allocate(nrow,ncol,nnzero) if (ircode /= 0 ) then write(0,*) 'Memory allocation failed' goto 993 @@ -672,15 +696,15 @@ contains if (present(mtitle)) mtitle=mtitle_ - if (psb_tolower(type(1:1)) == 'r') then + if (psb_tolower(type(1:1)) == 'c') then if (psb_tolower(type(2:2)) == 'u') then - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - call a%mv_from(acsr) + call a%mv_from(acsc) if (present(b)) then if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then @@ -706,9 +730,9 @@ contains ! we are generally working with non-symmetric matrices, so ! we de-symmetrize what we are about to read - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) if (present(b)) then @@ -731,7 +755,7 @@ contains endif - call acoo%mv_from_fmt(acsr,info) + call acoo%mv_from_fmt(acsc,info) call acoo%reallocate(2*nnzero) ! A is now in COO format nzr = nnzero @@ -746,7 +770,6 @@ contains call acoo%set_nzeros(nzr) call acoo%fix(ircode) if (ircode==0) call a%mv_from(acoo) - if (ircode==0) call a%cscnv(ircode,type='csr') if (ircode/=0) goto 993 else if (psb_tolower(type(2:2)) == 'h') then @@ -754,9 +777,9 @@ contains ! we are generally working with non-symmetric matrices, so ! we de-symmetrize what we are about to read - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) if (present(b)) then @@ -779,7 +802,7 @@ contains endif - call acoo%mv_from_fmt(acsr,info) + call acoo%mv_from_fmt(acsc,info) call acoo%reallocate(2*nnzero) ! A is now in COO format nzr = nnzero @@ -794,7 +817,6 @@ contains call acoo%set_nzeros(nzr) call acoo%fix(ircode) if (ircode==0) call a%mv_from(acoo) - if (ircode==0) call a%cscnv(ircode,type='csr') if (ircode/=0) goto 993 else @@ -805,6 +827,8 @@ contains write(0,*) 'read_matrix: matrix type not yet supported' iret=904 end if + + call a%cscnv(ircode,type='csr') if (infile/=5) close(infile) return @@ -824,7 +848,7 @@ contains subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) use psb_base_mod implicit none - type(psb_c_sparse_mat), intent(in) :: a + type(psb_c_sparse_mat), intent(in), target :: a integer, intent(out) :: iret character(len=*), optional, intent(in) :: mtitle integer, optional, intent(in) :: iunit @@ -836,11 +860,13 @@ contains character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' integer, parameter :: jptr=10,jind=10 character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' - integer, parameter :: jval=4,jrhs=4 + integer, parameter :: jval=2,jrhs=2 character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - + + type(psb_c_csc_sparse_mat), target :: acsc + type(psb_c_csc_sparse_mat), pointer :: acpnt character(len=72) :: mtitle_ character(len=8) :: key_ @@ -869,7 +895,7 @@ contains iout=6 endif endif - + if (present(mtitle)) then mtitle_ = mtitle else @@ -881,65 +907,72 @@ contains key_ = 'PSBMAT00' endif - + select type(aa=>a%a) - type is (psb_c_csr_sparse_mat) - - nrow = aa%get_nrows() - ncol = aa%get_ncols() - nnzero = aa%get_nzeros() - - neltvl = 0 - - ptrcrd = (nrow+1)/jptr - if (mod(nrow+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'RUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (aa%irp(i),i=1,nrow+1) - write (iout,fmt=indfmt) (aa%ja(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (aa%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + type is (psb_s_csc_sparse_mat) + acpnt => aa class default - write(0,*) 'format: ',a%get_fmt(),' not yet implemented' + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc end select + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'CUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + if (iout /= 6) close(iout) @@ -968,7 +1001,7 @@ contains character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 integer :: indcrd, ptrcrd, totcrd,& & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix - type(psb_z_csr_sparse_mat) :: acsr + type(psb_z_csc_sparse_mat) :: acsc type(psb_z_coo_sparse_mat) :: acoo integer :: ircode, i,nzr,infile, info character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' @@ -1000,7 +1033,7 @@ contains & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix - call acsr%allocate(nrow,ncol,nnzero) + call acsc%allocate(nrow,ncol,nnzero) if (ircode /= 0 ) then write(0,*) 'Memory allocation failed' goto 993 @@ -1009,15 +1042,15 @@ contains if (present(mtitle)) mtitle=mtitle_ - if (psb_tolower(type(1:1)) == 'r') then + if (psb_tolower(type(1:1)) == 'c') then if (psb_tolower(type(2:2)) == 'u') then - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) - call a%mv_from(acsr) + call a%mv_from(acsc) if (present(b)) then if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then @@ -1043,9 +1076,9 @@ contains ! we are generally working with non-symmetric matrices, so ! we de-symmetrize what we are about to read - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) if (present(b)) then @@ -1068,7 +1101,7 @@ contains endif - call acoo%mv_from_fmt(acsr,info) + call acoo%mv_from_fmt(acsc,info) call acoo%reallocate(2*nnzero) ! A is now in COO format nzr = nnzero @@ -1083,7 +1116,6 @@ contains call acoo%set_nzeros(nzr) call acoo%fix(ircode) if (ircode==0) call a%mv_from(acoo) - if (ircode==0) call a%cscnv(ircode,type='csr') if (ircode/=0) goto 993 else if (psb_tolower(type(2:2)) == 'h') then @@ -1091,9 +1123,9 @@ contains ! we are generally working with non-symmetric matrices, so ! we de-symmetrize what we are about to read - read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1) - read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero) - if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero) + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) if (present(b)) then @@ -1116,7 +1148,7 @@ contains endif - call acoo%mv_from_fmt(acsr,info) + call acoo%mv_from_fmt(acsc,info) call acoo%reallocate(2*nnzero) ! A is now in COO format nzr = nnzero @@ -1131,7 +1163,6 @@ contains call acoo%set_nzeros(nzr) call acoo%fix(ircode) if (ircode==0) call a%mv_from(acoo) - if (ircode==0) call a%cscnv(ircode,type='csr') if (ircode/=0) goto 993 else @@ -1142,6 +1173,8 @@ contains write(0,*) 'read_matrix: matrix type not yet supported' iret=904 end if + + call a%cscnv(ircode,type='csr') if (infile/=5) close(infile) return @@ -1161,7 +1194,7 @@ contains subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) use psb_base_mod implicit none - type(psb_z_sparse_mat), intent(in) :: a + type(psb_z_sparse_mat), intent(in), target :: a integer, intent(out) :: iret character(len=*), optional, intent(in) :: mtitle integer, optional, intent(in) :: iunit @@ -1173,11 +1206,13 @@ contains character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' integer, parameter :: jptr=10,jind=10 character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' - integer, parameter :: jval=4,jrhs=4 + integer, parameter :: jval=2,jrhs=2 character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' character(len=*), parameter :: fmt11='(a3,11x,2i14)' character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' - + + type(psb_z_csc_sparse_mat), target :: acsc + type(psb_z_csc_sparse_mat), pointer :: acpnt character(len=72) :: mtitle_ character(len=8) :: key_ @@ -1206,7 +1241,7 @@ contains iout=6 endif endif - + if (present(mtitle)) then mtitle_ = mtitle else @@ -1218,65 +1253,72 @@ contains key_ = 'PSBMAT00' endif - + select type(aa=>a%a) - type is (psb_z_csr_sparse_mat) - - nrow = aa%get_nrows() - ncol = aa%get_ncols() - nnzero = aa%get_nzeros() - - neltvl = 0 - - ptrcrd = (nrow+1)/jptr - if (mod(nrow+1,jptr) > 0) ptrcrd = ptrcrd + 1 - indcrd = nnzero/jind - if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 - valcrd = nnzero/jval - if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 - rhstype = '' - if (present(rhs)) then - if (size(rhs) 0) rhscrd = rhscrd + 1 - endif - nrhs = 1 - rhstype(1:1) = 'F' - else - rhscrd = 0 - nrhs = 0 - end if - totcrd = ptrcrd + indcrd + valcrd + rhscrd - - nrhsix = nrhs*nrow - - if (present(g)) then - rhstype(2:2) = 'G' - end if - if (present(x)) then - rhstype(3:3) = 'X' - end if - type = 'RUA' - - write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& - & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt - if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix - write (iout,fmt=ptrfmt) (aa%irp(i),i=1,nrow+1) - write (iout,fmt=indfmt) (aa%ja(i),i=1,nnzero) - if (valcrd > 0) write (iout,fmt=valfmt) (aa%val(i),i=1,nnzero) - if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) - if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) - if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + type is (psb_s_csc_sparse_mat) + acpnt => aa class default - write(0,*) 'format: ',a%get_fmt(),' not yet implemented' + call acsc%cp_from_fmt(aa, iret) + if (iret/=0) return + acpnt => acsc end select + + nrow = acpnt%get_nrows() + ncol = acpnt%get_ncols() + nnzero = acpnt%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'CUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acpnt%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acpnt%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acpnt%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + if (iout /= 6) close(iout) diff --git a/util/psb_mmio_mod.f90 b/util/psb_mmio_mod.f90 index 6a14587f..b0bcd4d0 100644 --- a/util/psb_mmio_mod.f90 +++ b/util/psb_mmio_mod.f90 @@ -31,17 +31,25 @@ !!$ module psb_mmio_mod - public mm_mat_read, mm_mat_write, mm_vet_read + public mm_mat_read, mm_mat_write, mm_vet_read, mm_vet_write + interface mm_mat_read module procedure smm_mat_read, dmm_mat_read, cmm_mat_read, zmm_mat_read end interface + interface mm_mat_write module procedure smm_mat_write, dmm_mat_write, cmm_mat_write, zmm_mat_write end interface + interface mm_vet_read module procedure mm_svet_read, mm_dvet_read, mm_cvet_read, mm_zvet_read end interface + interface mm_vet_write + module procedure mm_svet2_write, mm_svet1_write, mm_dvet2_write, mm_dvet1_write,& + & mm_cvet2_write, mm_cvet1_write, mm_zvet2_write, mm_zvet1_write + end interface + contains subroutine mm_svet_read(b, info, iunit, filename) @@ -340,6 +348,456 @@ contains return end subroutine mm_zvet_read + subroutine mm_svet2_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + real(psb_spk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_svet2_write + + subroutine mm_svet1_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + real(psb_spk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_svet1_write + + + subroutine mm_dvet2_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + real(psb_dpk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_dvet2_write + + subroutine mm_dvet1_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + real(psb_dpk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i3.3,a)') '(',ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_dvet1_write + + + subroutine mm_cvet2_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + complex(psb_spk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_cvet2_write + + subroutine mm_cvet1_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + complex(psb_spk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_cvet1_write + + subroutine mm_zvet2_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + complex(psb_dpk_), intent(in) :: b(:,:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = size(b,2) + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i,1:ncol) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_zvet2_write + + subroutine mm_zvet1_write(b, header, info, iunit, filename) + use psb_base_mod + implicit none + complex(psb_dpk_), intent(in) :: b(:) + character(len=*), intent(in) :: header + integer, intent(out) :: info + integer, optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer :: nrow, ncol, i,root, np, me, ircode, j, outfile + + character(len=80) :: frmtv + + info = 0 + if (present(filename)) then + if (filename=='-') then + outfile=6 + else + if (present(iunit)) then + outfile=iunit + else + outfile=99 + endif + open(outfile,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + outfile=iunit + else + outfile=6 + endif + endif + + write(outfile,'(a)') '%%MatrixMarket matrix array real general' + write(outfile,'(a)') '% '//trim(header) + write(outfile,'(a)') '% ' + nrow = size(b,1) + ncol = 1 + write(outfile,*) nrow,ncol + + write(frmtv,'(a,i5.5,a)') '(',2*ncol,'(es26.18,1x))' + + do i=1,size(b,1) + write(outfile,frmtv) b(i) + end do + + if (outfile /= 6) close(outfile) + + return + ! open failed +901 write(0,*) 'mm_vet_write: could not open file ',& + & outfile,' for output' + info = -1 + return + + end subroutine mm_zvet1_write + subroutine smm_mat_read(a, info, iunit, filename) use psb_base_mod @@ -431,8 +889,6 @@ contains if (infile/=5) close(infile) - - return ! open failed @@ -492,8 +948,6 @@ contains write(0,*) 'Error while opening ',filename return end subroutine smm_mat_write - - subroutine dmm_mat_read(a, info, iunit, filename) use psb_base_mod @@ -582,11 +1036,7 @@ contains write(0,*) 'read_matrix: matrix type not yet supported' info=904 end if - - if (infile/=5) close(infile) - - return ! open failed @@ -759,11 +1209,7 @@ contains write(0,*) 'read_matrix: matrix type not yet supported' info=904 end if - - if (infile/=5) close(infile) - - return ! open failed @@ -936,11 +1382,7 @@ contains write(0,*) 'read_matrix: matrix type not yet supported' info=904 end if - - if (infile/=5) close(infile) - - return ! open failed