fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas2:

Browse Source 
test/fileread/cf_sample.f90
 test/fileread/df_sample.f90
 test/fileread/sf_sample.f90
 test/fileread/zf_sample.f90
 util/Makefile
 util/psb_hbio_mod.f90
 util/psb_mmio_mod.f90
 util/psb_read_mat_mod.f90

First step to fixing MM/HB I/O: fixed MM_VET_READ.
psblas3-type-indexed
Salvatore Filippone 17 years ago
parent 929dba43a0
commit e8f6804783
8 changed files with 310 additions and 257 deletions
Show Stats Download Patch File Download Diff File

2
test/fileread/cf_sample.f90
Unescape Escape View File

@ -108,7 +108,7 @@ program cf_sample
if(rhs_file /= 'NONE') then
! reading an rhs
call read_rhs(rhs_file,aux_b,ictxt)
call read_rhs(rhs_file,aux_b,info,ictxt)
end if
if (psb_size(aux_b,dim=1)==m_problem) then

2
test/fileread/df_sample.f90
Unescape Escape View File

@ -108,7 +108,7 @@ program df_sample
if(rhs_file /= 'NONE') then
! reading an rhs
call read_rhs(rhs_file,aux_b,ictxt)
call read_rhs(rhs_file,aux_b,info,ictxt)
end if
if (psb_size(aux_b,dim=1)==m_problem) then

2
test/fileread/sf_sample.f90
Unescape Escape View File

@ -108,7 +108,7 @@ program sf_sample
if(rhs_file /= 'NONE') then
! reading an rhs
call read_rhs(rhs_file,aux_b,ictxt)
call read_rhs(rhs_file,aux_b,info,ictxt)
end if
if (psb_size(aux_b,dim=1)==m_problem) then

2
test/fileread/zf_sample.f90
Unescape Escape View File

@ -108,7 +108,7 @@ program zf_sample
if(rhs_file /= 'NONE') then
! reading an rhs
call read_rhs(rhs_file,aux_b,ictxt)
call read_rhs(rhs_file,aux_b,info,ictxt)
end if
if (psb_size(aux_b,dim=1)==m_problem) then

1
util/Makefile
Unescape Escape View File

@ -24,6 +24,7 @@ lib: $(OBJS)
psb_util_mod.o: $(BASEOBJS)
psb_read_mat_mod.o: psb_mmio_mod.o
veryclean: clean
/bin/rm -f $(HERE)/$(LIBNAME)

120
util/psb_hbio_mod.f90
Unescape Escape View File

@ -106,27 +106,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = szero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = szero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = szero
endif
endif
@ -140,27 +134,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = szero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = szero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = szero
endif
endif
@ -399,27 +387,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = dzero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = dzero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = dzero
endif
endif
@ -434,27 +416,21 @@ contains
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = dzero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = dzero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = dzero
endif
endif
@ -697,27 +673,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = czero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = czero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = czero
endif
endif
@ -741,27 +711,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = czero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = czero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = czero
endif
endif
@ -816,27 +780,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = czero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = czero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = czero
endif
endif
@ -1085,27 +1043,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = zzero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = zzero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = zzero
endif
endif
@ -1129,27 +1081,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = zzero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = zzero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = zzero
endif
endif
@ -1204,27 +1150,21 @@ contains
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
if (present(b)) then
call psb_ensure_size(nrow,b,info)
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,b,info)
read (infile,fmt=rhsfmt) (b(i),i=1,nrow)
else
b = zzero
endif
endif
if (present(g)) then
call psb_ensure_size(nrow,g,info)
if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,g,info)
read (infile,fmt=rhsfmt) (g(i),i=1,nrow)
else
g = zzero
endif
endif
if (present(x)) then
call psb_ensure_size(nrow,x,info)
if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then
call psb_ensure_size(nrow,x,info)
read (infile,fmt=rhsfmt) (x(i),i=1,nrow)
else
x = zzero
endif
endif
call psb_spcnv(a,ircode,afmt='coo')

226
util/psb_mmio_mod.f90
Unescape Escape View File

@ -31,16 +31,240 @@
!!$
module psb_mmio_mod
public mm_mat_read, mm_mat_write
public mm_mat_read, mm_mat_write, mm_vet_read
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
contains
subroutine mm_svet_read(filename, b, info)
use psb_base_mod
implicit none
character :: filename*(*)
real(psb_spk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
info = 0
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
info = -3
return
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol)
end if ! read right hand sides
return
! open failed
901 write(0,*) 'mm_vet_read: could not open file ',&
& infile,' for input'
info = -1
return
902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,&
& ' during input'
info = -2
return
993 write(0,*) 'mm_vet_read: memory allocation failure'
info = -3
return
end subroutine mm_svet_read
subroutine mm_dvet_read(filename, b, info)
use psb_base_mod
implicit none
character :: filename*(*)
real(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
info = 0
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
info = -3
return
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol)
end if ! read right hand sides
return
! open failed
901 write(0,*) 'mm_vet_read: could not open file ',&
& infile,' for input'
info = -1
return
902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,&
& ' during input'
info = -2
return
993 write(0,*) 'mm_vet_read: memory allocation failure'
info = -3
return
end subroutine mm_dvet_read
subroutine mm_cvet_read(filename, b, info)
use psb_base_mod
implicit none
character :: filename*(*)
complex(psb_spk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
real(psb_spk_) :: bre, bim
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
info = 0
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
info = -3
return
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
do j=1, ncol
do i=1, nrow
read(infile,fmt=*,end=902) bre,bim
b(i,j) = cmplx(bre,bim)
end do
end do
end if ! read right hand sides
return
! open failed
901 write(0,*) 'mm_vet_read: could not open file ',&
& infile,' for input'
info = -1
return
902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,&
& ' during input'
info = -2
return
993 write(0,*) 'mm_vet_read: memory allocation failure'
info = -3
return
end subroutine mm_cvet_read
subroutine mm_zvet_read(filename, b, info)
use psb_base_mod
implicit none
character :: filename*(*)
complex(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
real(psb_dpk_) :: bre, bim
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
info = 0
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
info = -3
return
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
do j=1, ncol
do i=1, nrow
read(infile,fmt=*,end=902) bre,bim
b(i,j) = cmplx(bre,bim)
end do
end do
end if ! read right hand sides
return
! open failed
901 write(0,*) 'mm_vet_read: could not open file ',&
& infile,' for input'
info = -1
return
902 write(0,*) 'mmv_vet_read: unexpected end of file ',infile,&
& ' during input'
info = -2
return
993 write(0,*) 'mm_vet_read: memory allocation failure'
info = -3
return
end subroutine mm_zvet_read
subroutine smm_mat_read(a, iret, iunit, filename)
use psb_base_mod
implicit none

200
util/psb_read_mat_mod.f90
Unescape Escape View File

@ -99,61 +99,36 @@ contains
end subroutine sreadmat
subroutine sread_rhs (filename, b, ictxt, inroot)
subroutine sread_rhs (filename, b, info,ictxt, inroot)
use psb_base_mod
use psb_mmio_mod
implicit none
integer :: ictxt
character :: filename*(*)
real(psb_spk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, optional :: inroot
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
real(psb_spk_), allocatable :: b(:,:)
if (present(inroot)) then
root = inroot
else
root = psb_root_
end if
info = 0
call psb_info(ictxt, me, np)
if (me == root) then
write(*, '("Reading rhs...")') ! open input file
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
write(0,*)'obj fmt',object, fmt
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
call psb_abort(ictxt)
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol)
else
write(0,*) 'read_rhs: rhs type not yet supported'
call psb_abort(ictxt)
call mm_vet_read(filename,b,info)
if (info /= 0) then
write(0,*) 'read_rhs: something went wrong.'
return
end if ! read right hand sides
write(*,*) 'end read_rhs'
end if
return
! open failed
901 write(0,*) 'read_rhs: could not open file ',&
& infile,' for input'
call psb_abort(ictxt) ! unexpected end of file
902 write(0,*) 'read_rhs: unexpected end of file ',infile,&
& ' during input'
call psb_abort(ictxt) ! allocation failed
993 write(0,*) 'read_rhs: memory allocation failure'
call psb_abort(ictxt)
end subroutine sread_rhs
@ -187,63 +162,37 @@ contains
end subroutine dreadmat
subroutine dread_rhs (filename, b, ictxt, inroot)
subroutine dread_rhs (filename, b, info,ictxt, inroot)
use psb_base_mod
use psb_mmio_mod
implicit none
integer :: ictxt
character :: filename*(*)
real(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, optional :: inroot
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
real(psb_dpk_), allocatable :: b(:,:)
if (present(inroot)) then
root = inroot
else
root = psb_root_
end if
info = 0
call psb_info(ictxt, me, np)
if (me == root) then
write(*, '("Reading rhs...")') ! open input file
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
write(0,*)'obj fmt',object, fmt
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
call psb_abort(ictxt)
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol)
else
write(0,*) 'read_rhs: rhs type not yet supported'
call psb_abort(ictxt)
call mm_vet_read(filename,b,info)
if (info /= 0) then
write(0,*) 'read_rhs: something went wrong.'
return
end if ! read right hand sides
write(*,*) 'end read_rhs'
end if
return
! open failed
901 write(0,*) 'read_rhs: could not open file ',&
& infile,' for input'
call psb_abort(ictxt) ! unexpected end of file
902 write(0,*) 'read_rhs: unexpected end of file ',infile,&
& ' during input'
call psb_abort(ictxt) ! allocation failed
993 write(0,*) 'read_rhs: memory allocation failure'
call psb_abort(ictxt)
end subroutine dread_rhs
end subroutine dread_rhs
subroutine creadmat (filename, a, ictxt, inroot)
use psb_base_mod
@ -275,66 +224,36 @@ contains
end subroutine creadmat
subroutine cread_rhs (filename, b, ictxt, inroot)
subroutine cread_rhs (filename, b, info,ictxt, inroot)
use psb_base_mod
use psb_mmio_mod
implicit none
integer :: ictxt
character :: filename*(*)
complex(psb_spk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, optional :: inroot
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
real(psb_spk_) :: bre, bim
complex(psb_spk_), allocatable :: b(:,:)
if (present(inroot)) then
root = inroot
else
root = psb_root_
end if
info = 0
call psb_info(ictxt, me, np)
if (me == root) then
write(*, '("Reading rhs...")') ! open input file
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
!!$ write(0,*)'obj fmt',object, fmt
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
call psb_abort(ictxt)
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
do j=1, ncol
do i=1, nrow
read(infile,fmt=*,end=902) bre,bim
b(i,j) = cmplx(bre,bim)
end do
end do
else
write(0,*) 'read_rhs: rhs type not yet supported'
call psb_abort(ictxt)
call mm_vet_read(filename,b,info)
if (info /= 0) then
write(0,*) 'read_rhs: something went wrong.'
return
end if ! read right hand sides
write(*,*) 'end read_rhs'
end if
return
! open failed
901 write(0,*) 'read_rhs: could not open file ',&
& infile,' for input'
call psb_abort(ictxt) ! unexpected end of file
902 write(0,*) 'read_rhs: unexpected end of file ',infile,&
& ' during input'
call psb_abort(ictxt) ! allocation failed
993 write(0,*) 'read_rhs: memory allocation failure'
call psb_abort(ictxt)
end subroutine cread_rhs
@ -368,67 +287,36 @@ contains
end subroutine zreadmat
subroutine zread_rhs (filename, b, ictxt, inroot)
subroutine zread_rhs (filename, b, info,ictxt, inroot)
use psb_base_mod
use psb_mmio_mod
implicit none
integer :: ictxt
character :: filename*(*)
complex(psb_dpk_), allocatable, intent(out) :: b(:,:)
integer, intent(out) :: info
integer, optional :: inroot
integer, parameter :: infile = 2
integer :: nrow, ncol, i,root, np, me, ircode, j
character :: mmheader*15, fmt*15, object*10, type*10, sym*15,&
& line*1024
real(psb_dpk_) :: bre, bim
complex(psb_dpk_), allocatable :: b(:,:)
if (present(inroot)) then
root = inroot
else
root = psb_root_
end if
info = 0
call psb_info(ictxt, me, np)
if (me == root) then
write(*, '("Reading rhs...")') ! open input file
open(infile,file=filename, status='old', err=901, action="read")
read(infile,fmt=*, end=902) mmheader, object, fmt, type, sym
!!$ write(0,*)'obj fmt',object, fmt
if ( (object /= 'matrix').or.(fmt /= 'array')) then
write(0,*) 'read_rhs: input file type not yet supported'
call psb_abort(ictxt)
end if
do
read(infile,fmt='(a)') line
if (line(1:1) /= '%') exit
end do
read(line,fmt=*)nrow,ncol
if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then
allocate(b(nrow,ncol),stat = ircode)
if (ircode /= 0) goto 993
do j=1, ncol
do i=1, nrow
read(infile,fmt=*,end=902) bre,bim
b(i,j) = cmplx(bre,bim)
end do
end do
else
write(0,*) 'read_rhs: rhs type not yet supported'
call psb_abort(ictxt)
call mm_vet_read(filename,b,info)
if (info /= 0) then
write(0,*) 'read_rhs: something went wrong.'
return
end if ! read right hand sides
write(*,*) 'end read_rhs'
end if
return
! open failed
901 write(0,*) 'read_rhs: could not open file ',&
& infile,' for input'
call psb_abort(ictxt) ! unexpected end of file
902 write(0,*) 'read_rhs: unexpected end of file ',infile,&
& ' during input'
call psb_abort(ictxt) ! allocation failed
993 write(0,*) 'read_rhs: memory allocation failure'
call psb_abort(ictxt)
end subroutine zread_rhs
end subroutine zread_rhs
end module psb_read_mat_mod

Write Preview
Loading…
Cancel
Save