1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
|
subroutine readf(flag,nevprt,t,xd,x,nx,z,nz,tvec,ntvec,
& rpar,nrpar,ipar,nipar,u,nu,y,ny)
c Copyright INRIA
c Scicos block simulator
c write read from a binary or formatted file
include '../stack.h'
c ipar(1) = lfil : file name length
c ipar(2) = lfmt : format length (0) if binary file
c ipar(3) = ievt : 1 if each data have a an associated time
c ipar(4) = N : buffer length
c ipar(5:4+lfil) = character codes for file name
c ipar(5+lfil:4+lfil+lfmt) = character codes for format if any
c ipar(5+lfil+lfmt:5+lfil+lfmt+ny+ievt) = reading mask
c
double precision t,xd(*),x(*),z(*),tvec(*),rpar(*),u(*),y(*)
integer flag,nevprt,nx,nz,ntvec,nrpar,ipar(*)
integer nipar,nu,ny
c
c
integer n
integer mode(2)
c
if(flag.eq.1) then
c discrete state
n=ipar(4)
k=int(z(1))
ievt=ipar(3)
kmax=int(z(2))
lunit=int(z(3))
if(k+1.gt.kmax.and.kmax.eq.n) then
c output
call dcopy(ny,z(3+n*ievt+k),n,y,1)
c . read a new buffer
no=(nz-3)/N
call bfrdr(lunit,ipar,z(4),no,kmax,ierr)
if(ierr.ne.0) goto 110
z(1)=1.0d0
z(2)=kmax
elseif(k.lt.kmax) then
c output
call dcopy(ny,z(3+n*ievt+k),n,y,1)
z(1)=z(1)+1.0d0
endif
c
elseif(flag.eq.3) then
n=ipar(4)
k=int(z(1))
kmax=int(z(2))
if(k.gt.kmax.and.kmax.lt.n) then
tvec(1)=t-1.0d0
else
tvec(1)=z(3+k)
endif
elseif(flag.eq.4) then
c file opening
lfil=ipar(1)
ievt=ipar(3)
N=ipar(4)
call cvstr(lfil,ipar(5),buf,1)
lfmt=ipar(2)
lunit=0
if(lfmt.gt.0) then
mode(1)=001
mode(2)=0
call clunit(lunit,buf(1:lfil),mode)
if(err.gt.0) goto 100
else
mode(1)=101
mode(2)=0
call clunit(lunit,buf(1:lfil),mode)
if(err.gt.0) goto 100
endif
z(3)=lunit
c buffer initialisation
no=(nz-3)/N
call bfrdr(lunit,ipar,z(4),no,kmax,ierr)
if(ierr.ne.0) goto 110
z(1)=1.0d0
z(2)=kmax
elseif(flag.eq.5) then
lfil=ipar(1)
N=ipar(4)
K=int(z(1))
lunit=int(z(3))
if(lunit.eq.0) then
return
endif
call clunit(-lunit,buf(1:lfil),mode)
if(err.gt.0) goto 100
z(3)=0.0d0
endif
return
100 continue
err=0
lfil=ipar(1)
call basout(io,wte,'File '//buf(1:lfil)//' Cannot be opened')
flag=-1
return
110 continue
lfil=ipar(1)
call cvstr(lfil,ipar(5),buf,1)
call clunit(-lunit,buf(1:lfil),mode)
call basout(io,wte,'Read error on file '//buf(1:lfil))
flag=-1
return
end
subroutine bfrdr(lunit,ipar,z,no,kmax,ierr)
c buffered and masked read
include '../stack.h'
integer lunit,ipar(*),ierr
double precision z(*)
double precision tmp(100)
c
ievt=ipar(3)
N=ipar(4)
c no=(nz-3)/N
c maximum number of value to read
imask=5+ipar(1)+ipar(2)
if(ievt.eq.0) imask=imask+1
mm=0
do 10 i=0,no-1
mm=max(mm,ipar(imask+i))
10 continue
c
lfmt=ipar(2)
kmax=0
if(lfmt.eq.0) then
c unformatted read
do 12 i=1,N
read(lunit,err=100,end=20) (tmp(j),j=1,mm)
do 11 j=0,no-1
z(j*N+i)=tmp(ipar(imask+j))
11 continue
kmax=kmax+1
12 continue
else
c formatted read
call cvstr(ipar(2),ipar(5+ipar(1)),buf,1)
do 14 i=1,N
read(lunit,buf(1:lfmt),err=100,end=20) (tmp(j),j=1,mm)
do 13 j=0,no-1
z(j*N+i)=tmp(ipar(imask+j))
13 continue
kmax=kmax+1
14 continue
endif
20 continue
ierr=0
return
100 ierr=1
return
end
|