------- Additional Comments From dir at lanl dot gov 2005-08-11 19:54 -------
Here is the slightly revised version that I tried on 9 compilers on four
different system - "gfortran -O" on linux is the only place that it failed.
program main
implicit real*8 (a-h,o-z)
save
common /prcon/ idatwr,ipric,npb,idc,ivc,iac,ipc,ipnode(3,15)
common /sol/ numnp,neq,nwk,nwm,nwc,numest,midest,maxest,nste,ma
common/const/ dt,dta,acoef(21),dtod,iope
common a(1000)
n1=1
dt=0.1d0
dta=0.1d0
nste=10
itwo=2
idatwr=0
read (5,1010) ntfn,nptm
write (6,2250) ntfn,nptm
c
if (ntfn.eq.0) go to 15
m2=n1 + ntfn
m3=m2 + ntfn*nptm*itwo
m4=m3 + ntfn*nptm*itwo
m5=m4 + ntfn*nste*itwo
m6=m5 + ntfn*itwo - 1
c
call timfun (a(m5),a(n1),a(m2),a(m3),a(m4),ntfn,nptm)
15 continue
stop
1010 format (16i5)
2250 format (1h1,35ht i m e f u n c t i o n d a t a /4x,
148h number of time functions (ntfn) =,i5/4x,
248h max number of points in time functions (nptm) =,i5)
end
subroutine timfun (rgst,ipnt,timv,rv,rg,ntfn,nptm)
c
c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c . .
c . subroutine to calculate time function values at all time points .
c . the time function values are stored in rg .
c . .
c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
implicit real*8 (a-h,o-z)
save
c
common /isubst/ isub,nsubst,nsub,ntuse,negls,negnls,numnps,
1 nodcon,nodret,idofs(6),ndofs,neqs,nwks,maxes,
2 mas,nstape,iloa(9),krsizm,neqc
common /sol/ numnp,neq,nwk,nwm,nwc,numest,midest,maxest,nste,ma
common /var/ ng,modex,iupdt,kstep,itemax,ieqref,ite,kpri,
1 iref,iequit,ipri,kplotn,kplote
common/const/ dt,dta,acoef(21),dtod,iope
common /adinai/ opvar(7),tstart,irint,istote
common /prcon/ idatwr,ipric,npb,idc,ivc,iac,ipc,ipnode(3,15)
c
dimension rg(ntfn,1),timv(nptm,1),rv(nptm,1),ipnt(1),rgst(1)
c
c write(6,*)tstart,dt,dta,nptm,ntfn,nste
do 100 l=1,ntfn
read (5,1000) ll,npts
if (ll - l) 80,90,80
80 write (6,2000)
stop
c
90 if (idatwr.le.1) write (6,2002) l,npts
ipnt(ll)=npts
read (5,1020) (timv(i,ll),rv(i,ll),i=1,npts)
if (idatwr.gt.1) go to 95
write (6,2004) (timv(i,ll),rv(i,ll),i=1,npts)
95 if (npts.le.nptm) go to 100
write (6,2100) l,npts,nptm
stop
100 continue
c
nt=13
rewind nt
do 200 l=1,ntfn
rgst(l)=rv(1,l)
npts=ipnt(l)
time=tstart + dt
timep=tstart + dta
i=0
k=1
120 i=i + 1
if (i-npts) 190,130,130
130 write (6,2010)
write(6,*)i,npts,ntfn,l,time,timep
stop
c
190 ddr=rv(i+1,l) - rv(i,l)
ddt=timv(i+1,l) - timv(i,l)
if (ddt) 110,120,150
110 write (6,2020)
stop
150 slope=ddr/ddt
180 if (timv(i+1,l)-time) 120,140,140
140 rg(l,k)=rv(i,l) + slope*(timep-timv(i,l))
timep=time + dta
time=time + dt
k=k + 1
if (nste-k) 195,180,180
195 write (nt) rgst(l),(rg(l,k),k=1,nste),npts,
1 (rv(j,l),timv(j,l),j=1,npts)
200 continue
c
return
c
1000 format (2i5)
1020 format (8f10.0)
2000 format (43h "" error time functions out of order )
2002 format (/25h time function number =,i5/
1 25h number of time points =,i5/4x,
2 25h time value function)
2004 format (3x,f12.5,2x,e15.7)
2010 format (53h "" error time is larger than in the time function)
2020 format (42h "" error time points are out of order )
2100 format (///28h *** i n p u t e r r o r -//
1 30h detected by subroutine timfun/
2 30h while reading time functions //
3 5x,23h time function number =,i5/
4 5x,36h number of points in this function =,i5,
5 17h is greater than/
6 5x,36h the max number of points requested=,i5,
7 49h as specified on the time function control card. //
4 12h *** s t o p)
c
end
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=23318
