add files for public distribution
based on internal repository 0a462b6 2017-11-22 14:41:39 +0100
This commit is contained in:
206
pmsco/loess/supp.f
Normal file
206
pmsco/loess/supp.f
Normal file
@ -0,0 +1,206 @@
|
||||
subroutine ehg182(i)
|
||||
integer i
|
||||
if(i.eq.100) print *,'wrong version number in lowesd. Probably ty
|
||||
+po in caller.'
|
||||
if(i.eq.101) print *,'d>dMAX in ehg131. Need to recompile with in
|
||||
+creased dimensions.'
|
||||
if(i.eq.102) print *,'liv too small. (Discovered by lowesd)'
|
||||
if(i.eq.103) print *,'lv too small. (Discovered by lowesd)'
|
||||
if(i.eq.104) print *,'alpha too small. fewer data values than deg
|
||||
+rees of freedom.'
|
||||
if(i.eq.105) print *,'k>d2MAX in ehg136. Need to recompile with i
|
||||
+ncreased dimensions.'
|
||||
if(i.eq.106) print *,'lwork too small'
|
||||
if(i.eq.107) print *,'invalid value for kernel'
|
||||
if(i.eq.108) print *,'invalid value for ideg'
|
||||
if(i.eq.109) print *,'lowstt only applies when kernel=1.'
|
||||
if(i.eq.110) print *,'not enough extra workspace for robustness ca
|
||||
+lculation'
|
||||
if(i.eq.120) print *,'zero-width neighborhood. make alpha bigger'
|
||||
if(i.eq.121) print *,'all data on boundary of neighborhood. make a
|
||||
+lpha bigger'
|
||||
if(i.eq.122) print *,'extrapolation not allowed with blending'
|
||||
if(i.eq.123) print *,'ihat=1 (diag L) in l2fit only makes sense if
|
||||
+ z=x (eval=data).'
|
||||
if(i.eq.171) print *,'lowesd must be called first.'
|
||||
if(i.eq.172) print *,'lowesf must not come between lowesb and lowe
|
||||
+se, lowesr, or lowesl.'
|
||||
if(i.eq.173) print *,'lowesb must come before lowese, lowesr, or l
|
||||
+owesl.'
|
||||
if(i.eq.174) print *,'lowesb need not be called twice.'
|
||||
if(i.eq.180) print *,'nv>nvmax in cpvert.'
|
||||
if(i.eq.181) print *,'nt>20 in eval.'
|
||||
if(i.eq.182) print *,'svddc failed in l2fit.'
|
||||
if(i.eq.183) print *,'didnt find edge in vleaf.'
|
||||
if(i.eq.184) print *,'zero-width cell found in vleaf.'
|
||||
if(i.eq.185) print *,'trouble descending to leaf in vleaf.'
|
||||
if(i.eq.186) print *,'insufficient workspace for lowesf.'
|
||||
if(i.eq.187) print *,'insufficient stack space'
|
||||
if(i.eq.188) print *,'lv too small for computing explicit L'
|
||||
if(i.eq.191) print *,'computed trace L was negative; something is
|
||||
+wrong!'
|
||||
if(i.eq.192) print *,'computed delta was negative; something is wr
|
||||
+ong!'
|
||||
if(i.eq.193) print *,'workspace in loread appears to be corrupted'
|
||||
if(i.eq.194) print *,'trouble in l2fit/l2tr'
|
||||
if(i.eq.195) print *,'only constant, linear, or quadratic local mo
|
||||
+dels allowed'
|
||||
if(i.eq.196) print *,'degree must be at least 1 for vertex influen
|
||||
+ce matrix'
|
||||
if(i.eq.999) print *,'not yet implemented'
|
||||
print *,'Assert failed, error code ',i
|
||||
stop
|
||||
end
|
||||
subroutine ehg183(s,i,n,inc)
|
||||
character*(*) s
|
||||
integer n, inc, i(inc,n), j
|
||||
print *,s,(i(1,j),j=1,n)
|
||||
end
|
||||
subroutine ehg184(s,x,n,inc)
|
||||
character*(*) s
|
||||
integer n, inc, j
|
||||
double precision x(inc,n)
|
||||
print *,s,(x(1,j),j=1,n)
|
||||
end
|
||||
subroutine losave(iunit,iv,liv,lv,v)
|
||||
integer execnt,iunit,liv,lv
|
||||
integer iv(liv)
|
||||
DOUBLE PRECISION v(lv)
|
||||
external ehg167
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
call ehg167(iunit,iv(2),iv(4),iv(5),iv(6),iv(14),v(iv(11)),iv(iv(7
|
||||
+)),v(iv(12)),v(iv(13)))
|
||||
return
|
||||
end
|
||||
subroutine ehg167(iunit,d,vc,nc,nv,nvmax,v,a,xi,vval)
|
||||
integer iunit,d,vc,nc,nv,a(nc),magic,i,j
|
||||
DOUBLE PRECISION v(nvmax,d),xi(nc),vval(0:d,nv)
|
||||
write(iunit,*)d,nc,nv
|
||||
do 10 i=1,d
|
||||
10 write(iunit,*)v(1,i),v(vc,i)
|
||||
j = 0
|
||||
do 20 i=1,nc
|
||||
if(a(i).ne.0)then
|
||||
write(iunit,*)a(i),xi(i)
|
||||
else
|
||||
write(iunit,*)a(i),j
|
||||
end if
|
||||
20 continue
|
||||
do 30 i=1,nv
|
||||
30 write(iunit,*)(vval(j,i),j=0,d)
|
||||
end
|
||||
subroutine lohead(iunit,d,vc,nc,nv)
|
||||
integer iunit,d,vc,nc,nv
|
||||
read(iunit,*)d,nc,nv
|
||||
vc = 2**d
|
||||
end
|
||||
subroutine loread(iunit,d,vc,nc,nv,iv,liv,lv,v)
|
||||
integer bound,d,execnt,iunit,liv,lv,nc,nv,vc
|
||||
integer iv(liv)
|
||||
DOUBLE PRECISION v(lv)
|
||||
external ehg168,ehg169,ehg182
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
iv(28)=173
|
||||
iv(2)=d
|
||||
iv(4)=vc
|
||||
iv(14)=nv
|
||||
iv(17)=nc
|
||||
iv(7)=50
|
||||
iv(8)=iv(7)+nc
|
||||
iv(9)=iv(8)+vc*nc
|
||||
iv(10)=iv(9)+nc
|
||||
bound=iv(10)+nc
|
||||
if(.not.(bound-1.le.liv))then
|
||||
call ehg182(102)
|
||||
end if
|
||||
iv(11)=50
|
||||
iv(13)=iv(11)+nv*d
|
||||
iv(12)=iv(13)+(d+1)*nv
|
||||
bound=iv(12)+nc
|
||||
if(.not.(bound-1.le.lv))then
|
||||
call ehg182(103)
|
||||
end if
|
||||
call ehg168(iunit,d,vc,nc,nv,nv,v(iv(11)),iv(iv(7)),v(iv(12)),v(iv
|
||||
+(13)))
|
||||
call ehg169(d,vc,nc,nc,nv,nv,v(iv(11)),iv(iv(7)),v(iv(12)),iv(iv(8
|
||||
+)),iv(iv(9)),iv(iv(10)))
|
||||
return
|
||||
end
|
||||
subroutine ehg168(iunit,d,vc,nc,nv,nvmax,v,a,xi,vval)
|
||||
integer iunit,d,vc,nc,nv,a(nc),magic,i,j
|
||||
DOUBLE PRECISION v(nvmax,d),xi(nc),vval(0:d,nv)
|
||||
do 10 i=1,d
|
||||
10 read(iunit,*)v(1,i),v(vc,i)
|
||||
do 20 i=1,nc
|
||||
20 read(iunit,*)a(i),xi(i)
|
||||
do 30 i=1,nv
|
||||
30 read(iunit,*)(vval(j,i),j=0,d)
|
||||
end
|
||||
subroutine ehg170(k,d,vc,nv,nvmax,nc,ncmax,a,c,hi,lo,v,vval,xi)
|
||||
integer d,execnt,i,j,nc,ncmax,nv,nvmax,vc
|
||||
integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax)
|
||||
double precision v(nvmax,d),vval(0:d,nvmax),xi(ncmax)
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
write(k,*)' double precision function loeval(z)'
|
||||
write(k,50)d
|
||||
write(k,*)' integer d,vc,nv,nc'
|
||||
write(k,51)nc,vc,nc
|
||||
write(k,52)nc,nc
|
||||
write(k,53)nv,d
|
||||
write(k,54)d,nv
|
||||
write(k,55)nc
|
||||
write(k,56)
|
||||
write(k,57)d,vc,nv,nc
|
||||
50 format(' double precision z(',i2,')')
|
||||
51 format(' integer a(',i5,'), c(',i3,',',i5,')')
|
||||
52 format(' integer hi(',i5,'), lo(',i5,')')
|
||||
53 format(' double precision v(',i5,',',i2,')')
|
||||
54 format(' double precision vval(0:',i2,',',i5,')')
|
||||
55 format(' double precision xi(',i5,')')
|
||||
56 format(' double precision ehg128')
|
||||
57 format(' data d,vc,nv,nc /',i2,',',i3,',',i5,',',i5,'/')
|
||||
do 3 i=1,nc
|
||||
write(k,58)i,a(i)
|
||||
58 format(' data a(',i5,') /',i5,'/')
|
||||
if(a(i).ne.0)then
|
||||
write(k,59)i,i,i,hi(i),lo(i),xi(i)
|
||||
59 format(' data hi(',i5,'),lo(',i5,'),xi(',i5,') /',
|
||||
$ i5,',',i5,',',1pe15.6,'/')
|
||||
end if
|
||||
do 4 j=1,vc
|
||||
write(k,60)j,i,c(j,i)
|
||||
60 format(' data c(',i3,',',i5,') /',i5,'/')
|
||||
4 continue
|
||||
3 continue
|
||||
do 5 i=1,nv
|
||||
write(k,61)i,vval(0,i)
|
||||
61 format(' data vval(0,',i5,') /',1pe15.6,'/')
|
||||
do 6 j=1,d
|
||||
write(k,62)i,j,v(i,j)
|
||||
62 format(' data v(',i5,',',i2,') /',1pe15.6,'/')
|
||||
write(k,63)j,i,vval(j,i)
|
||||
63 format(' data vval(',i2,',',i5,') /',1pe15.6,'/')
|
||||
6 continue
|
||||
5 continue
|
||||
write(k,*)' loeval=ehg128(z,d,nc,vc,a,xi,lo,hi,c,v,nv,vval)'
|
||||
write(k,*)' end'
|
||||
return
|
||||
end
|
||||
subroutine lofort(iunit,iv,liv,lv,wv)
|
||||
integer execnt,iunit
|
||||
integer iv(*)
|
||||
DOUBLE PRECISION wv(*)
|
||||
external ehg170
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
call ehg170(iunit,iv(2),iv(4),iv(6),iv(14),iv(5),iv(17),iv(iv(7)),
|
||||
+iv(iv(8)),iv(iv(9)),iv(iv(10)),wv(iv(11)),wv(iv(13)),wv(iv(12)))
|
||||
return
|
||||
end
|
||||
Reference in New Issue
Block a user