Kolpack-Software-Consulting/piscal
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
poprhythm
2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dataassim/math/numrec/f77_sources/addint.for
+13
View File
@@ -0,0 +1,13 @@
SUBROUTINE addint(uf,uc,res,nf)
INTEGER nf
DOUBLE PRECISION res(nf,nf),uc(nf/2+1,nf/2+1),uf(nf,nf)
CU USES interp
INTEGER i,j
call interp(res,uc,nf)
do 12 j=1,nf
do 11 i=1,nf
uf(i,j)=uf(i,j)+res(i,j)
11 continue
12 continue
return
END
dataassim/math/numrec/f77_sources/airy.for
+32
View File
@@ -0,0 +1,32 @@
SUBROUTINE airy(x,ai,bi,aip,bip)
REAL ai,aip,bi,bip,x
CU USES bessik,bessjy
REAL absx,ri,rip,rj,rjp,rk,rkp,rootx,ry,ryp,z,PI,THIRD,TWOTHR,
*ONOVRT
PARAMETER (PI=3.1415927,THIRD=1./3.,TWOTHR=2.*THIRD,
*ONOVRT=.57735027)
absx=abs(x)
rootx=sqrt(absx)
z=TWOTHR*absx*rootx
if(x.gt.0.)then
call bessik(z,THIRD,ri,rk,rip,rkp)
ai=rootx*ONOVRT*rk/PI
bi=rootx*(rk/PI+2.*ONOVRT*ri)
call bessik(z,TWOTHR,ri,rk,rip,rkp)
aip=-x*ONOVRT*rk/PI
bip=x*(rk/PI+2.*ONOVRT*ri)
else if(x.lt.0.)then
call bessjy(z,THIRD,rj,ry,rjp,ryp)
ai=.5*rootx*(rj-ONOVRT*ry)
bi=-.5*rootx*(ry+ONOVRT*rj)
call bessjy(z,TWOTHR,rj,ry,rjp,ryp)
aip=.5*absx*(ONOVRT*ry+rj)
bip=.5*absx*(ONOVRT*rj-ry)
else
ai=.35502805
bi=ai/ONOVRT
aip=-.25881940
bip=-aip/ONOVRT
endif
return
END
dataassim/math/numrec/f77_sources/amebsa.for
+85
View File
@@ -0,0 +1,85 @@
SUBROUTINE amebsa(p,y,mp,np,ndim,pb,yb,ftol,funk,iter,temptr)
INTEGER iter,mp,ndim,np,NMAX
REAL ftol,temptr,yb,p(mp,np),pb(np),y(mp),funk
PARAMETER (NMAX=200)
EXTERNAL funk
CU USES amotsa,funk,ran1
INTEGER i,idum,ihi,ilo,inhi,j,m,n
REAL rtol,sum,swap,tt,yhi,ylo,ynhi,ysave,yt,ytry,psum(NMAX),
*amotsa,ran1
COMMON /ambsa/ tt,idum
tt=-temptr
1 do 12 n=1,ndim
sum=0.
do 11 m=1,ndim+1
sum=sum+p(m,n)
11 continue
psum(n)=sum
12 continue
2 ilo=1
inhi=1
ihi=2
ylo=y(1)+tt*log(ran1(idum))
ynhi=ylo
yhi=y(2)+tt*log(ran1(idum))
if (ylo.gt.yhi) then
ihi=1
inhi=2
ilo=2
ynhi=yhi
yhi=ylo
ylo=ynhi
endif
do 13 i=3,ndim+1
yt=y(i)+tt*log(ran1(idum))
if(yt.le.ylo) then
ilo=i
ylo=yt
endif
if(yt.gt.yhi) then
inhi=ihi
ynhi=yhi
ihi=i
yhi=yt
else if(yt.gt.ynhi) then
inhi=i
ynhi=yt
endif
13 continue
rtol=2.*abs(yhi-ylo)/(abs(yhi)+abs(ylo))
if (rtol.lt.ftol.or.iter.lt.0) then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do 14 n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
14 continue
return
endif
iter=iter-2
ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,-1.0)
if (ytry.le.ylo) then
ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,2.0)
else if (ytry.ge.ynhi) then
ysave=yhi
ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,0.5)
if (ytry.ge.ysave) then
do 16 i=1,ndim+1
if(i.ne.ilo)then
do 15 j=1,ndim
psum(j)=0.5*(p(i,j)+p(ilo,j))
p(i,j)=psum(j)
15 continue
y(i)=funk(psum)
endif
16 continue
iter=iter-ndim
goto 1
endif
else
iter=iter+1
endif
goto 2
END
dataassim/math/numrec/f77_sources/amoeba.for
+71
View File
@@ -0,0 +1,71 @@
SUBROUTINE amoeba(p,y,mp,np,ndim,ftol,funk,iter)
INTEGER iter,mp,ndim,np,NMAX,ITMAX
REAL ftol,p(mp,np),y(mp),funk
PARAMETER (NMAX=20,ITMAX=5000)
EXTERNAL funk
CU USES amotry,funk
INTEGER i,ihi,ilo,inhi,j,m,n
REAL rtol,sum,swap,ysave,ytry,psum(NMAX),amotry
iter=0
1 do 12 n=1,ndim
sum=0.
do 11 m=1,ndim+1
sum=sum+p(m,n)
11 continue
psum(n)=sum
12 continue
2 ilo=1
if (y(1).gt.y(2)) then
ihi=1
inhi=2
else
ihi=2
inhi=1
endif
do 13 i=1,ndim+1
if(y(i).le.y(ilo)) ilo=i
if(y(i).gt.y(ihi)) then
inhi=ihi
ihi=i
else if(y(i).gt.y(inhi)) then
if(i.ne.ihi) inhi=i
endif
13 continue
rtol=2.*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo)))
if (rtol.lt.ftol) then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do 14 n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
14 continue
return
endif
if (iter.ge.ITMAX) pause 'ITMAX exceeded in amoeba'
iter=iter+2
ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,-1.0)
if (ytry.le.y(ilo)) then
ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,2.0)
else if (ytry.ge.y(inhi)) then
ysave=y(ihi)
ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,0.5)
if (ytry.ge.ysave) then
do 16 i=1,ndim+1
if(i.ne.ilo)then
do 15 j=1,ndim
psum(j)=0.5*(p(i,j)+p(ilo,j))
p(i,j)=psum(j)
15 continue
y(i)=funk(psum)
endif
16 continue
iter=iter+ndim
goto 1
endif
else
iter=iter-1
endif
goto 2
END
dataassim/math/numrec/f77_sources/amotry.for
+24
View File
@@ -0,0 +1,24 @@
FUNCTION amotry(p,y,psum,mp,np,ndim,funk,ihi,fac)
INTEGER ihi,mp,ndim,np,NMAX
REAL amotry,fac,p(mp,np),psum(np),y(mp),funk
PARAMETER (NMAX=20)
EXTERNAL funk
CU USES funk
INTEGER j
REAL fac1,fac2,ytry,ptry(NMAX)
fac1=(1.-fac)/ndim
fac2=fac1-fac
do 11 j=1,ndim
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11 continue
ytry=funk(ptry)
if (ytry.lt.y(ihi)) then
y(ihi)=ytry
do 12 j=1,ndim
psum(j)=psum(j)-p(ihi,j)+ptry(j)
p(ihi,j)=ptry(j)
12 continue
endif
amotry=ytry
return
END
dataassim/math/numrec/f77_sources/amotsa.for
+33
View File
@@ -0,0 +1,33 @@
FUNCTION amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,fac)
INTEGER ihi,mp,ndim,np,NMAX
REAL amotsa,fac,yb,yhi,p(mp,np),pb(np),psum(np),y(mp),funk
PARAMETER (NMAX=200)
EXTERNAL funk
CU USES funk,ran1
INTEGER idum,j
REAL fac1,fac2,tt,yflu,ytry,ptry(NMAX),ran1
COMMON /ambsa/ tt,idum
fac1=(1.-fac)/ndim
fac2=fac1-fac
do 11 j=1,ndim
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11 continue
ytry=funk(ptry)
if (ytry.le.yb) then
do 12 j=1,ndim
pb(j)=ptry(j)
12 continue
yb=ytry
endif
yflu=ytry-tt*log(ran1(idum))
if (yflu.lt.yhi) then
y(ihi)=ytry
yhi=yflu
do 13 j=1,ndim
psum(j)=psum(j)-p(ihi,j)+ptry(j)
p(ihi,j)=ptry(j)
13 continue
endif
amotsa=yflu
return
END
dataassim/math/numrec/f77_sources/anneal.for
+62
View File
@@ -0,0 +1,62 @@
SUBROUTINE anneal(x,y,iorder,ncity)
INTEGER ncity,iorder(ncity)
REAL x(ncity),y(ncity)
CU USES irbit1,metrop,ran3,revcst,revers,trncst,trnspt
INTEGER i,i1,i2,idec,idum,iseed,j,k,nlimit,nn,nover,nsucc,n(6),
*irbit1
REAL de,path,t,tfactr,ran3,alen,x1,x2,y1,y2
LOGICAL ans
alen(x1,x2,y1,y2)=sqrt((x2-x1)**2+(y2-y1)**2)
nover=100*ncity
nlimit=10*ncity
tfactr=0.9
path=0.0
t=0.5
do 11 i=1,ncity-1
i1=iorder(i)
i2=iorder(i+1)
path=path+alen(x(i1),x(i2),y(i1),y(i2))
11 continue
i1=iorder(ncity)
i2=iorder(1)
path=path+alen(x(i1),x(i2),y(i1),y(i2))
idum=-1
iseed=111
do 13 j=1,100
nsucc=0
do 12 k=1,nover
1 n(1)=1+int(ncity*ran3(idum))
n(2)=1+int((ncity-1)*ran3(idum))
if (n(2).ge.n(1)) n(2)=n(2)+1
nn=1+mod((n(1)-n(2)+ncity-1),ncity)
if (nn.lt.3) goto 1
idec=irbit1(iseed)
if (idec.eq.0) then
n(3)=n(2)+int(abs(nn-2)*ran3(idum))+1
n(3)=1+mod(n(3)-1,ncity)
call trncst(x,y,iorder,ncity,n,de)
call metrop(de,t,ans)
if (ans) then
nsucc=nsucc+1
path=path+de
call trnspt(iorder,ncity,n)
endif
else
call revcst(x,y,iorder,ncity,n,de)
call metrop(de,t,ans)
if (ans) then
nsucc=nsucc+1
path=path+de
call revers(iorder,ncity,n)
endif
endif
if (nsucc.ge.nlimit) goto 2
12 continue
2 write(*,*)
write(*,*) 'T =',t,' Path Length =',path
write(*,*) 'Successful Moves: ',nsucc
t=t*tfactr
if (nsucc.eq.0) return
13 continue
return
END
dataassim/math/numrec/f77_sources/anorm2.for
+14
View File
@@ -0,0 +1,14 @@
DOUBLE PRECISION FUNCTION anorm2(a,n)
INTEGER n
DOUBLE PRECISION a(n,n)
INTEGER i,j
DOUBLE PRECISION sum
sum=0.d0
do 12 j=1,n
do 11 i=1,n
sum=sum+a(i,j)**2
11 continue
12 continue
anorm2=sqrt(sum)/n
return
END
dataassim/math/numrec/f77_sources/arcmak.for
+20
View File
@@ -0,0 +1,20 @@
SUBROUTINE arcmak(nfreq,nchh,nradd)
INTEGER nchh,nradd,nfreq(nchh),MC,NWK,MAXINT
PARAMETER (MC=512,NWK=20,MAXINT=2147483647)
INTEGER j,jdif,minint,nc,nch,nrad,ncum,ncumfq(MC+2),ilob(NWK),
*iupb(NWK)
COMMON /arccom/ ncumfq,iupb,ilob,nch,nrad,minint,jdif,nc,ncum
SAVE /arccom/
if(nchh.gt.MC)pause 'MC too small in arcmak'
if(nradd.gt.256)pause 'nradd may not exceed 256 in arcmak'
minint=MAXINT/nradd
nch=nchh
nrad=nradd
ncumfq(1)=0
do 11 j=2,nch+1
ncumfq(j)=ncumfq(j-1)+max(nfreq(j-1),1)
11 continue
ncumfq(nch+2)=ncumfq(nch+1)+1
ncum=ncumfq(nch+2)
return
END
dataassim/math/numrec/f77_sources/arcode.for
+75
View File
@@ -0,0 +1,75 @@
SUBROUTINE arcode(ich,code,lcode,lcd,isign)
INTEGER ich,isign,lcd,lcode,MC,NWK
CHARACTER*1 code(lcode)
PARAMETER (MC=512,NWK=20)
CU USES arcsum
INTEGER ihi,j,ja,jdif,jh,jl,k,m,minint,nc,nch,nrad,ilob(NWK),
*iupb(NWK),ncumfq(MC+2),ncum,JTRY
COMMON /arccom/ ncumfq,iupb,ilob,nch,nrad,minint,jdif,nc,ncum
SAVE /arccom/
JTRY(j,k,m)=int((dble(k)*dble(j))/dble(m))
if (isign.eq.0) then
jdif=nrad-1
do 11 j=NWK,1,-1
iupb(j)=nrad-1
ilob(j)=0
nc=j
if(jdif.gt.minint)return
jdif=(jdif+1)*nrad-1
11 continue
pause 'NWK too small in arcode'
else
if (isign.gt.0) then
if(ich.gt.nch.or.ich.lt.0)pause 'bad ich in arcode'
else
ja=ichar(code(lcd))-ilob(nc)
do 12 j=nc+1,NWK
ja=ja*nrad+(ichar(code(j+lcd-nc))-ilob(j))
12 continue
ich=0
ihi=nch+1
1 if(ihi-ich.gt.1) then
m=(ich+ihi)/2
if (ja.ge.JTRY(jdif,ncumfq(m+1),ncum)) then
ich=m
else
ihi=m
endif
goto 1
endif
if(ich.eq.nch)return
endif
jh=JTRY(jdif,ncumfq(ich+2),ncum)
jl=JTRY(jdif,ncumfq(ich+1),ncum)
jdif=jh-jl
call arcsum(ilob,iupb,jh,NWK,nrad,nc)
call arcsum(ilob,ilob,jl,NWK,nrad,nc)
do 13 j=nc,NWK
if(ich.ne.nch.and.iupb(j).ne.ilob(j))goto 2
if(lcd.gt.lcode)pause 'lcode too small in arcode'
if(isign.gt.0) code(lcd)=char(ilob(j))
lcd=lcd+1
13 continue
return
2 nc=j
j=0
3 if (jdif.lt.minint) then
j=j+1
jdif=jdif*nrad
goto 3
endif
if (nc-j.lt.1) pause 'NWK too small in arcode'
if(j.ne.0)then
do 14 k=nc,NWK
iupb(k-j)=iupb(k)
ilob(k-j)=ilob(k)
14 continue
endif
nc=nc-j
do 15 k=NWK-j+1,NWK
iupb(k)=0
ilob(k)=0
15 continue
endif
return
END
dataassim/math/numrec/f77_sources/arcsum.for
+18
View File
@@ -0,0 +1,18 @@
SUBROUTINE arcsum(iin,iout,ja,nwk,nrad,nc)
INTEGER ja,nc,nrad,nwk,iin(*),iout(*)
INTEGER j,jtmp,karry
karry=0
do 11 j=nwk,nc+1,-1
jtmp=ja
ja=ja/nrad
iout(j)=iin(j)+(jtmp-ja*nrad)+karry
if (iout(j).ge.nrad) then
iout(j)=iout(j)-nrad
karry=1
else
karry=0
endif
11 continue
iout(nc)=iin(nc)+ja+karry
return
END
dataassim/math/numrec/f77_sources/asolve.for
+10
View File
@@ -0,0 +1,10 @@
SUBROUTINE asolve(n,b,x,itrnsp)
INTEGER n,itrnsp,ija,NMAX,i
DOUBLE PRECISION x(n),b(n),sa
PARAMETER (NMAX=1000)
COMMON /mat/ sa(NMAX),ija(NMAX)
do 11 i=1,n
x(i)=b(i)/sa(i)
11 continue
return
END
dataassim/math/numrec/f77_sources/atimes.for
+13
View File
@@ -0,0 +1,13 @@
SUBROUTINE atimes(n,x,r,itrnsp)
INTEGER n,itrnsp,ija,NMAX
DOUBLE PRECISION x(n),r(n),sa
PARAMETER (NMAX=1000)
COMMON /mat/ sa(NMAX),ija(NMAX)
CU USES dsprsax,dsprstx
if (itrnsp.eq.0) then
call dsprsax(sa,ija,x,r,n)
else
call dsprstx(sa,ija,x,r,n)
endif
return
END
dataassim/math/numrec/f77_sources/avevar.for
+20
View File
@@ -0,0 +1,20 @@
SUBROUTINE avevar(data,n,ave,var)
INTEGER n
REAL ave,var,data(n)
INTEGER j
REAL s,ep
ave=0.0
do 11 j=1,n
ave=ave+data(j)
11 continue
ave=ave/n
var=0.0
ep=0.0
do 12 j=1,n
s=data(j)-ave
ep=ep+s
var=var+s*s
12 continue
var=(var-ep**2/n)/(n-1)
return
END
dataassim/math/numrec/f77_sources/badluk.for
+44
View File
@@ -0,0 +1,44 @@
PROGRAM badluk
INTEGER ic,icon,idwk,ifrac,im,iybeg,iyend,iyyy,jd,jday,n,julday
REAL TIMZON,frac
PARAMETER (TIMZON=-5./24.)
DATA iybeg,iyend /1900,2000/
CU USES flmoon,julday
write (*,'(1x,a,i5,a,i5)') 'Full moons on Friday the 13th from',
*iybeg,' to',iyend
do 12 iyyy=iybeg,iyend
do 11 im=1,12
jday=julday(im,13,iyyy)
idwk=mod(jday+1,7)
if(idwk.eq.5) then
n=12.37*(iyyy-1900+(im-0.5)/12.)
icon=0
1 call flmoon(n,2,jd,frac)
ifrac=nint(24.*(frac+TIMZON))
if(ifrac.lt.0)then
jd=jd-1
ifrac=ifrac+24
endif
if(ifrac.gt.12)then
jd=jd+1
ifrac=ifrac-12
else
ifrac=ifrac+12
endif
if(jd.eq.jday)then
write (*,'(/1x,i2,a,i2,a,i4)') im,'/',13,'/',iyyy
write (*,'(1x,a,i2,a)') 'Full moon ',ifrac,
*' hrs after midnight (EST).'
goto 2
else
ic=isign(1,jday-jd)
if(ic.eq.-icon) goto 2
icon=ic
n=n+ic
endif
goto 1
2 continue
endif
11 continue
12 continue
END
dataassim/math/numrec/f77_sources/balanc.for
+47
View File
@@ -0,0 +1,47 @@
SUBROUTINE balanc(a,n,np)
INTEGER n,np
REAL a(np,np),RADIX,SQRDX
PARAMETER (RADIX=2.,SQRDX=RADIX**2)
INTEGER i,j,last
REAL c,f,g,r,s
1 continue
last=1
do 14 i=1,n
c=0.
r=0.
do 11 j=1,n
if(j.ne.i)then
c=c+abs(a(j,i))
r=r+abs(a(i,j))
endif
11 continue
if(c.ne.0..and.r.ne.0.)then
g=r/RADIX
f=1.
s=c+r
2 if(c.lt.g)then
f=f*RADIX
c=c*SQRDX
goto 2
endif
g=r*RADIX
3 if(c.gt.g)then
f=f/RADIX
c=c/SQRDX
goto 3
endif
if((c+r)/f.lt.0.95*s)then
last=0
g=1./f
do 12 j=1,n
a(i,j)=a(i,j)*g
12 continue
do 13 j=1,n
a(j,i)=a(j,i)*f
13 continue
endif
endif
14 continue
if(last.eq.0)goto 1
return
END
dataassim/math/numrec/f77_sources/banbks.for
+31
View File
@@ -0,0 +1,31 @@
SUBROUTINE banbks(a,n,m1,m2,np,mp,al,mpl,indx,b)
INTEGER m1,m2,mp,mpl,n,np,indx(n)
REAL a(np,mp),al(np,mpl),b(n)
INTEGER i,k,l,mm
REAL dum
mm=m1+m2+1
if(mm.gt.mp.or.m1.gt.mpl.or.n.gt.np) pause 'bad args in banbks'
l=m1
do 12 k=1,n
i=indx(k)
if(i.ne.k)then
dum=b(k)
b(k)=b(i)
b(i)=dum
endif
if(l.lt.n)l=l+1
do 11 i=k+1,l
b(i)=b(i)-al(k,i-k)*b(k)
11 continue
12 continue
l=1
do 14 i=n,1,-1
dum=b(i)
do 13 k=2,l
dum=dum-a(i,k)*b(k+i-1)
13 continue
b(i)=dum/a(i,1)
if(l.lt.mm) l=l+1
14 continue
return
END
dataassim/math/numrec/f77_sources/bandec.for
+51
View File
@@ -0,0 +1,51 @@
SUBROUTINE bandec(a,n,m1,m2,np,mp,al,mpl,indx,d)
INTEGER m1,m2,mp,mpl,n,np,indx(n)
REAL d,a(np,mp),al(np,mpl),TINY
PARAMETER (TINY=1.e-20)
INTEGER i,j,k,l,mm
REAL dum
mm=m1+m2+1
if(mm.gt.mp.or.m1.gt.mpl.or.n.gt.np) pause 'bad args in bandec'
l=m1
do 13 i=1,m1
do 11 j=m1+2-i,mm
a(i,j-l)=a(i,j)
11 continue
l=l-1
do 12 j=mm-l,mm
a(i,j)=0.
12 continue
13 continue
d=1.
l=m1
do 18 k=1,n
dum=a(k,1)
i=k
if(l.lt.n)l=l+1
do 14 j=k+1,l
if(abs(a(j,1)).gt.abs(dum))then
dum=a(j,1)
i=j
endif
14 continue
indx(k)=i
if(dum.eq.0.) a(k,1)=TINY
if(i.ne.k)then
d=-d
do 15 j=1,mm
dum=a(k,j)
a(k,j)=a(i,j)
a(i,j)=dum
15 continue
endif
do 17 i=k+1,l
dum=a(i,1)/a(k,1)
al(k,i-k)=dum
do 16 j=2,mm
a(i,j-1)=a(i,j)-dum*a(k,j)
16 continue
a(i,mm)=0.
17 continue
18 continue
return
END
dataassim/math/numrec/f77_sources/banmul.for
+13
View File
@@ -0,0 +1,13 @@
SUBROUTINE banmul(a,n,m1,m2,np,mp,x,b)
INTEGER m1,m2,mp,n,np
REAL a(np,mp),b(n),x(n)
INTEGER i,j,k
do 12 i=1,n
b(i)=0.
k=i-m1-1
do 11 j=max(1,1-k),min(m1+m2+1,n-k)
b(i)=b(i)+a(i,j)*x(j+k)
11 continue
12 continue
return
END
dataassim/math/numrec/f77_sources/bcucof.for
+35
View File
@@ -0,0 +1,35 @@
SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c)
REAL d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4)
INTEGER i,j,k,l
REAL d1d2,xx,cl(16),wt(16,16),x(16)
SAVE wt
DATA wt/1,0,-3,2,4*0,-3,0,9,-6,2,0,-6,4,8*0,3,0,-9,6,-2,0,6,-4,10*
*0,9,-6,2*0,-6,4,2*0,3,-2,6*0,-9,6,2*0,6,-4,4*0,1,0,-3,2,-2,0,6,-4,
*1,0,-3,2,8*0,-1,0,3,-2,1,0,-3,2,10*0,-3,2,2*0,3,-2,6*0,3,-2,2*0,
*-6,4,2*0,3,-2,0,1,-2,1,5*0,-3,6,-3,0,2,-4,2,9*0,3,-6,3,0,-2,4,-2,
*10*0,-3,3,2*0,2,-2,2*0,-1,1,6*0,3,-3,2*0,-2,2,5*0,1,-2,1,0,-2,4,
*-2,0,1,-2,1,9*0,-1,2,-1,0,1,-2,1,10*0,1,-1,2*0,-1,1,6*0,-1,1,2*0,
*2,-2,2*0,-1,1/
d1d2=d1*d2
do 11 i=1,4
x(i)=y(i)
x(i+4)=y1(i)*d1
x(i+8)=y2(i)*d2
x(i+12)=y12(i)*d1d2
11 continue
do 13 i=1,16
xx=0.
do 12 k=1,16
xx=xx+wt(i,k)*x(k)
12 continue
cl(i)=xx
13 continue
l=0
do 15 i=1,4
do 14 j=1,4
l=l+1
c(i,j)=cl(l)
14 continue
15 continue
return
END
dataassim/math/numrec/f77_sources/bcuint.for
+23
View File
@@ -0,0 +1,23 @@
SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,ansy1,
*ansy2)
REAL ansy,ansy1,ansy2,x1,x1l,x1u,x2,x2l,x2u,y(4),y1(4),y12(4),
*y2(4)
CU USES bcucof
INTEGER i
REAL t,u,c(4,4)
call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c)
if(x1u.eq.x1l.or.x2u.eq.x2l)pause 'bad input in bcuint'
t=(x1-x1l)/(x1u-x1l)
u=(x2-x2l)/(x2u-x2l)
ansy=0.
ansy2=0.
ansy1=0.
do 11 i=4,1,-1
ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1)
ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2)
ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i)
11 continue
ansy1=ansy1/(x1u-x1l)
ansy2=ansy2/(x2u-x2l)
return
END
dataassim/math/numrec/f77_sources/beschb.for
+19
View File
@@ -0,0 +1,19 @@
SUBROUTINE beschb(x,gam1,gam2,gampl,gammi)
INTEGER NUSE1,NUSE2
DOUBLE PRECISION gam1,gam2,gammi,gampl,x
PARAMETER (NUSE1=5,NUSE2=5)
CU USES chebev
REAL xx,c1(7),c2(8),chebev
SAVE c1,c2
DATA c1/-1.142022680371168d0,6.5165112670737d-3,3.087090173086d-4,
*-3.4706269649d-6,6.9437664d-9,3.67795d-11,-1.356d-13/
DATA c2/1.843740587300905d0,-7.68528408447867d-2,
*1.2719271366546d-3,-4.9717367042d-6,-3.31261198d-8,2.423096d-10,
*-1.702d-13,-1.49d-15/
xx=8.d0*x*x-1.d0
gam1=chebev(-1.,1.,c1,NUSE1,xx)
gam2=chebev(-1.,1.,c2,NUSE2,xx)
gampl=gam2-x*gam1
gammi=gam2+x*gam1
return
END
dataassim/math/numrec/f77_sources/bessi.for
+32
View File
@@ -0,0 +1,32 @@
FUNCTION bessi(n,x)
INTEGER n,IACC
REAL bessi,x,BIGNO,BIGNI
PARAMETER (IACC=40,BIGNO=1.0e10,BIGNI=1.0e-10)
CU USES bessi0
INTEGER j,m
REAL bi,bim,bip,tox,bessi0
if (n.lt.2) pause 'bad argument n in bessi'
if (x.eq.0.) then
bessi=0.
else
tox=2.0/abs(x)
bip=0.0
bi=1.0
bessi=0.
m=2*((n+int(sqrt(float(IACC*n)))))
do 11 j=m,1,-1
bim=bip+float(j)*tox*bi
bip=bi
bi=bim
if (abs(bi).gt.BIGNO) then
bessi=bessi*BIGNI
bi=bi*BIGNI
bip=bip*BIGNI
endif
if (j.eq.n) bessi=bip
11 continue
bessi=bessi*bessi0(x)/bi
if (x.lt.0..and.mod(n,2).eq.1) bessi=-bessi
endif
return
END
dataassim/math/numrec/f77_sources/bessi0.for
+21
View File
@@ -0,0 +1,21 @@
FUNCTION bessi0(x)
REAL bessi0,x
REAL ax
DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0,
*1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/
DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1,
*0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,0.2635537d-1,
*-0.1647633d-1,0.392377d-2/
if (abs(x).lt.3.75) then
y=(x/3.75)**2
bessi0=p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7)))))
else
ax=abs(x)
y=3.75/ax
bessi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
*(q7+y*(q8+y*q9))))))))
endif
return
END
dataassim/math/numrec/f77_sources/bessi1.for
+22
View File
@@ -0,0 +1,22 @@
FUNCTION bessi1(x)
REAL bessi1,x
REAL ax
DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,
*0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1,
*-0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,-0.2895312d-1,
*0.1787654d-1,-0.420059d-2/
if (abs(x).lt.3.75) then
y=(x/3.75)**2
bessi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
else
ax=abs(x)
y=3.75/ax
bessi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
*(q7+y*(q8+y*q9))))))))
if(x.lt.0.)bessi1=-bessi1
endif
return
END
dataassim/math/numrec/f77_sources/bessik.for
+129
View File
@@ -0,0 +1,129 @@
SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp)
INTEGER MAXIT
REAL ri,rip,rk,rkp,x,xnu,XMIN
DOUBLE PRECISION EPS,FPMIN,PI
PARAMETER (EPS=1.e-10,FPMIN=1.e-30,MAXIT=10000,XMIN=2.,
*PI=3.141592653589793d0)
CU USES beschb
INTEGER i,l,nl
DOUBLE PRECISION a,a1,b,c,d,del,del1,delh,dels,e,f,fact,fact2,ff,
*gam1,gam2,gammi,gampl,h,p,pimu,q,q1,q2,qnew,ril,ril1,rimu,rip1,
*ripl,ritemp,rk1,rkmu,rkmup,rktemp,s,sum,sum1,x2,xi,xi2,xmu,xmu2
if(x.le.0..or.xnu.lt.0.) pause 'bad arguments in bessik'
nl=int(xnu+.5d0)
xmu=xnu-nl
xmu2=xmu*xmu
xi=1.d0/x
xi2=2.d0*xi
h=xnu*xi
if(h.lt.FPMIN)h=FPMIN
b=xi2*xnu
d=0.d0
c=h
do 11 i=1,MAXIT
b=b+xi2
d=1.d0/(b+d)
c=b+1.d0/c
del=c*d
h=del*h
if(abs(del-1.d0).lt.EPS)goto 1
11 continue
pause 'x too large in bessik; try asymptotic expansion'
1 continue
ril=FPMIN
ripl=h*ril
ril1=ril
rip1=ripl
fact=xnu*xi
do 12 l=nl,1,-1
ritemp=fact*ril+ripl
fact=fact-xi
ripl=fact*ritemp+ril
ril=ritemp
12 continue
f=ripl/ril
if(x.lt.XMIN) then
x2=.5d0*x
pimu=PI*xmu
if(abs(pimu).lt.EPS)then
fact=1.d0
else
fact=pimu/sin(pimu)
endif
d=-log(x2)
e=xmu*d
if(abs(e).lt.EPS)then
fact2=1.d0
else
fact2=sinh(e)/e
endif
call beschb(xmu,gam1,gam2,gampl,gammi)
ff=fact*(gam1*cosh(e)+gam2*fact2*d)
sum=ff
e=exp(e)
p=0.5d0*e/gampl
q=0.5d0/(e*gammi)
c=1.d0
d=x2*x2
sum1=p
do 13 i=1,MAXIT
ff=(i*ff+p+q)/(i*i-xmu2)
c=c*d/i
p=p/(i-xmu)
q=q/(i+xmu)
del=c*ff
sum=sum+del
del1=c*(p-i*ff)
sum1=sum1+del1
if(abs(del).lt.abs(sum)*EPS)goto 2
13 continue
pause 'bessk series failed to converge'
2 continue
rkmu=sum
rk1=sum1*xi2
else
b=2.d0*(1.d0+x)
d=1.d0/b
delh=d
h=delh
q1=0.d0
q2=1.d0
a1=.25d0-xmu2
c=a1
q=c
a=-a1
s=1.d0+q*delh
do 14 i=2,MAXIT
a=a-2*(i-1)
c=-a*c/i
qnew=(q1-b*q2)/a
q1=q2
q2=qnew
q=q+c*qnew
b=b+2.d0
d=1.d0/(b+a*d)
delh=(b*d-1.d0)*delh
h=h+delh
dels=q*delh
s=s+dels
if(abs(dels/s).lt.EPS)goto 3
14 continue
pause 'bessik: failure to converge in cf2'
3 continue
h=a1*h
rkmu=sqrt(PI/(2.d0*x))*exp(-x)/s
rk1=rkmu*(xmu+x+.5d0-h)*xi
endif
rkmup=xmu*xi*rkmu-rk1
rimu=xi/(f*rkmu-rkmup)
ri=(rimu*ril1)/ril
rip=(rimu*rip1)/ril
do 15 i=1,nl
rktemp=(xmu+i)*xi2*rk1+rkmu
rkmu=rk1
rk1=rktemp
15 continue
rk=rkmu
rkp=xnu*xi*rkmu-rk1
return
END
dataassim/math/numrec/f77_sources/bessj.for
+49
View File
@@ -0,0 +1,49 @@
FUNCTION bessj(n,x)
INTEGER n,IACC
REAL bessj,x,BIGNO,BIGNI
PARAMETER (IACC=40,BIGNO=1.e10,BIGNI=1.e-10)
CU USES bessj0,bessj1
INTEGER j,jsum,m
REAL ax,bj,bjm,bjp,sum,tox,bessj0,bessj1
if(n.lt.2)pause 'bad argument n in bessj'
ax=abs(x)
if(ax.eq.0.)then
bessj=0.
else if(ax.gt.float(n))then
tox=2./ax
bjm=bessj0(ax)
bj=bessj1(ax)
do 11 j=1,n-1
bjp=j*tox*bj-bjm
bjm=bj
bj=bjp
11 continue
bessj=bj
else
tox=2./ax
m=2*((n+int(sqrt(float(IACC*n))))/2)
bessj=0.
jsum=0
sum=0.
bjp=0.
bj=1.
do 12 j=m,1,-1
bjm=j*tox*bj-bjp
bjp=bj
bj=bjm
if(abs(bj).gt.BIGNO)then
bj=bj*BIGNI
bjp=bjp*BIGNI
bessj=bessj*BIGNI
sum=sum*BIGNI
endif
if(jsum.ne.0)sum=sum+bj
jsum=1-jsum
if(j.eq.n)bessj=bjp
12 continue
sum=2.*sum-bj
bessj=bessj/sum
endif
if(x.lt.0..and.mod(n,2).eq.1)bessj=-bessj
return
END
dataassim/math/numrec/f77_sources/bessj0.for
+28
View File
@@ -0,0 +1,28 @@
FUNCTION bessj0(x)
REAL bessj0,x
REAL ax,xx,z
DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
*s1,s2,s3,s4,s5,s6,y
SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
*s5,s6
DATA p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4,
*-.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1,
*.1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/
DATA r1,r2,r3,r4,r5,r6/57568490574.d0,-13362590354.d0,
*651619640.7d0,-11214424.18d0,77392.33017d0,-184.9052456d0/,s1,s2,
*s3,s4,s5,s6/57568490411.d0,1029532985.d0,9494680.718d0,
*59272.64853d0,267.8532712d0,1.d0/
if(abs(x).lt.8.)then
y=x**2
bessj0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y*
*(s4+y*(s5+y*s6)))))
else
ax=abs(x)
z=8./ax
y=z**2
xx=ax-.785398164
bessj0=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
*p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
endif
return
END
dataassim/math/numrec/f77_sources/bessj1.for
+28
View File
@@ -0,0 +1,28 @@
FUNCTION bessj1(x)
REAL bessj1,x
REAL ax,xx,z
DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
*s1,s2,s3,s4,s5,s6,y
SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
*s5,s6
DATA r1,r2,r3,r4,r5,r6/72362614232.d0,-7895059235.d0,
*242396853.1d0,-2972611.439d0,15704.48260d0,-30.16036606d0/,s1,s2,
*s3,s4,s5,s6/144725228442.d0,2300535178.d0,18583304.74d0,
*99447.43394d0,376.9991397d0,1.d0/
DATA p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4,
*.2457520174d-5,-.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0,
*-.2002690873d-3,.8449199096d-5,-.88228987d-6,.105787412d-6/
if(abs(x).lt.8.)then
y=x**2
bessj1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+
*y*(s4+y*(s5+y*s6)))))
else
ax=abs(x)
z=8./ax
y=z**2
xx=ax-2.356194491
bessj1=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
*p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))*sign(1.,x)
endif
return
END
dataassim/math/numrec/f77_sources/bessjy.for
+162
View File
@@ -0,0 +1,162 @@
SUBROUTINE bessjy(x,xnu,rj,ry,rjp,ryp)
INTEGER MAXIT
REAL rj,rjp,ry,ryp,x,xnu,XMIN
DOUBLE PRECISION EPS,FPMIN,PI
PARAMETER (EPS=1.e-10,FPMIN=1.e-30,MAXIT=10000,XMIN=2.,
*PI=3.141592653589793d0)
CU USES beschb
INTEGER i,isign,l,nl
DOUBLE PRECISION a,b,br,bi,c,cr,ci,d,del,del1,den,di,dlr,dli,dr,e,
*f,fact,fact2,fact3,ff,gam,gam1,gam2,gammi,gampl,h,p,pimu,pimu2,q,
*r,rjl,rjl1,rjmu,rjp1,rjpl,rjtemp,ry1,rymu,rymup,rytemp,sum,sum1,
*temp,w,x2,xi,xi2,xmu,xmu2
if(x.le.0..or.xnu.lt.0.) pause 'bad arguments in bessjy'
if(x.lt.XMIN)then
nl=int(xnu+.5d0)
else
nl=max(0,int(xnu-x+1.5d0))
endif
xmu=xnu-nl
xmu2=xmu*xmu
xi=1.d0/x
xi2=2.d0*xi
w=xi2/PI
isign=1
h=xnu*xi
if(h.lt.FPMIN)h=FPMIN
b=xi2*xnu
d=0.d0
c=h
do 11 i=1,MAXIT
b=b+xi2
d=b-d
if(abs(d).lt.FPMIN)d=FPMIN
c=b-1.d0/c
if(abs(c).lt.FPMIN)c=FPMIN
d=1.d0/d
del=c*d
h=del*h
if(d.lt.0.d0)isign=-isign
if(abs(del-1.d0).lt.EPS)goto 1
11 continue
pause 'x too large in bessjy; try asymptotic expansion'
1 continue
rjl=isign*FPMIN
rjpl=h*rjl
rjl1=rjl
rjp1=rjpl
fact=xnu*xi
do 12 l=nl,1,-1
rjtemp=fact*rjl+rjpl
fact=fact-xi
rjpl=fact*rjtemp-rjl
rjl=rjtemp
12 continue
if(rjl.eq.0.d0)rjl=EPS
f=rjpl/rjl
if(x.lt.XMIN) then
x2=.5d0*x
pimu=PI*xmu
if(abs(pimu).lt.EPS)then
fact=1.d0
else
fact=pimu/sin(pimu)
endif
d=-log(x2)
e=xmu*d
if(abs(e).lt.EPS)then
fact2=1.d0
else
fact2=sinh(e)/e
endif
call beschb(xmu,gam1,gam2,gampl,gammi)
ff=2.d0/PI*fact*(gam1*cosh(e)+gam2*fact2*d)
e=exp(e)
p=e/(gampl*PI)
q=1.d0/(e*PI*gammi)
pimu2=0.5d0*pimu
if(abs(pimu2).lt.EPS)then
fact3=1.d0
else
fact3=sin(pimu2)/pimu2
endif
r=PI*pimu2*fact3*fact3
c=1.d0
d=-x2*x2
sum=ff+r*q
sum1=p
do 13 i=1,MAXIT
ff=(i*ff+p+q)/(i*i-xmu2)
c=c*d/i
p=p/(i-xmu)
q=q/(i+xmu)
del=c*(ff+r*q)
sum=sum+del
del1=c*p-i*del
sum1=sum1+del1
if(abs(del).lt.(1.d0+abs(sum))*EPS)goto 2
13 continue
pause 'bessy series failed to converge'
2 continue
rymu=-sum
ry1=-sum1*xi2
rymup=xmu*xi*rymu-ry1
rjmu=w/(rymup-f*rymu)
else
a=.25d0-xmu2
p=-.5d0*xi
q=1.d0
br=2.d0*x
bi=2.d0
fact=a*xi/(p*p+q*q)
cr=br+q*fact
ci=bi+p*fact
den=br*br+bi*bi
dr=br/den
di=-bi/den
dlr=cr*dr-ci*di
dli=cr*di+ci*dr
temp=p*dlr-q*dli
q=p*dli+q*dlr
p=temp
do 14 i=2,MAXIT
a=a+2*(i-1)
bi=bi+2.d0
dr=a*dr+br
di=a*di+bi
if(abs(dr)+abs(di).lt.FPMIN)dr=FPMIN
fact=a/(cr*cr+ci*ci)
cr=br+cr*fact
ci=bi-ci*fact
if(abs(cr)+abs(ci).lt.FPMIN)cr=FPMIN
den=dr*dr+di*di
dr=dr/den
di=-di/den
dlr=cr*dr-ci*di
dli=cr*di+ci*dr
temp=p*dlr-q*dli
q=p*dli+q*dlr
p=temp
if(abs(dlr-1.d0)+abs(dli).lt.EPS)goto 3
14 continue
pause 'cf2 failed in bessjy'
3 continue
gam=(p-f)/q
rjmu=sqrt(w/((p-f)*gam+q))
rjmu=sign(rjmu,rjl)
rymu=rjmu*gam
rymup=rymu*(p+q/gam)
ry1=xmu*xi*rymu-rymup
endif
fact=rjmu/rjl
rj=rjl1*fact
rjp=rjp1*fact
do 15 i=1,nl
rytemp=(xmu+i)*xi2*ry1-rymu
rymu=ry1
ry1=rytemp
15 continue
ry=rymu
ryp=xnu*xi*rymu-ry1
return
END
dataassim/math/numrec/f77_sources/bessk.for
+18
View File
@@ -0,0 +1,18 @@
FUNCTION bessk(n,x)
INTEGER n
REAL bessk,x
CU USES bessk0,bessk1
INTEGER j
REAL bk,bkm,bkp,tox,bessk0,bessk1
if (n.lt.2) pause 'bad argument n in bessk'
tox=2.0/x
bkm=bessk0(x)
bk=bessk1(x)
do 11 j=1,n-1
bkp=bkm+j*tox*bk
bkm=bk
bk=bkp
11 continue
bessk=bk
return
END
dataassim/math/numrec/f77_sources/bessk0.for
+21
View File
@@ -0,0 +1,21 @@
FUNCTION bessk0(x)
REAL bessk0,x
CU USES bessi0
REAL bessi0
DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566d0,0.42278420d0,0.23069756d0,
*0.3488590d-1,0.262698d-2,0.10750d-3,0.74d-5/
DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-0.7832358d-1,0.2189568d-1,
*-0.1062446d-1,0.587872d-2,-0.251540d-2,0.53208d-3/
if (x.le.2.0) then
y=x*x/4.0
bessk0=(-log(x/2.0)*bessi0(x))+(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*
*(p6+y*p7))))))
else
y=(2.0/x)
bessk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
*q7))))))
endif
return
END
dataassim/math/numrec/f77_sources/bessk1.for
+21
View File
@@ -0,0 +1,21 @@
FUNCTION bessk1(x)
REAL bessk1,x
CU USES bessi1
REAL bessi1
DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,0.15443144d0,-0.67278579d0,
*-0.18156897d0,-0.1919402d-1,-0.110404d-2,-0.4686d-4/
DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,0.23498619d0,-0.3655620d-1,
*0.1504268d-1,-0.780353d-2,0.325614d-2,-0.68245d-3/
if (x.le.2.0) then
y=x*x/4.0
bessk1=(log(x/2.0)*bessi1(x))+(1.0/x)*(p1+y*(p2+y*(p3+y*(p4+y*
*(p5+y*(p6+y*p7))))))
else
y=2.0/x
bessk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
*q7))))))
endif
return
END
dataassim/math/numrec/f77_sources/bessy.for
+18
View File
@@ -0,0 +1,18 @@
FUNCTION bessy(n,x)
INTEGER n
REAL bessy,x
CU USES bessy0,bessy1
INTEGER j
REAL by,bym,byp,tox,bessy0,bessy1
if(n.lt.2)pause 'bad argument n in bessy'
tox=2./x
by=bessy1(x)
bym=bessy0(x)
do 11 j=1,n-1
byp=j*tox*by-bym
bym=by
by=byp
11 continue
bessy=by
return
END
dataassim/math/numrec/f77_sources/bessy0.for
+28
View File
@@ -0,0 +1,28 @@
FUNCTION bessy0(x)
REAL bessy0,x
CU USES bessj0
REAL xx,z,bessj0
DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
*s1,s2,s3,s4,s5,s6,y
SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
*s5,s6
DATA p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4,
*-.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1,
*.1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/
DATA r1,r2,r3,r4,r5,r6/-2957821389.d0,7062834065.d0,
*-512359803.6d0,10879881.29d0,-86327.92757d0,228.4622733d0/,s1,s2,
*s3,s4,s5,s6/40076544269.d0,745249964.8d0,7189466.438d0,
*47447.26470d0,226.1030244d0,1.d0/
if(x.lt.8.)then
y=x**2
bessy0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y*
*(s4+y*(s5+y*s6)))))+.636619772*bessj0(x)*log(x)
else
z=8./x
y=z**2
xx=x-.785398164
bessy0=sqrt(.636619772/x)*(sin(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
*p5))))+z*cos(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
endif
return
END
dataassim/math/numrec/f77_sources/bessy1.for
+28
View File
@@ -0,0 +1,28 @@
FUNCTION bessy1(x)
REAL bessy1,x
CU USES bessj1
REAL xx,z,bessj1
DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
*s1,s2,s3,s4,s5,s6,s7,y
SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
*s5,s6,s7
DATA p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4,
*.2457520174d-5,-.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0,
*-.2002690873d-3,.8449199096d-5,-.88228987d-6,.105787412d-6/
DATA r1,r2,r3,r4,r5,r6/-.4900604943d13,.1275274390d13,
*-.5153438139d11,.7349264551d9,-.4237922726d7,.8511937935d4/,s1,s2,
*s3,s4,s5,s6,s7/.2499580570d14,.4244419664d12,.3733650367d10,
*.2245904002d8,.1020426050d6,.3549632885d3,1.d0/
if(x.lt.8.)then
y=x**2
bessy1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+
*y*(s4+y*(s5+y*(s6+y*s7))))))+.636619772*(bessj1(x)*log(x)-1./x)
else
z=8./x
y=z**2
xx=x-2.356194491
bessy1=sqrt(.636619772/x)*(sin(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
*p5))))+z*cos(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
endif
return
END
dataassim/math/numrec/f77_sources/beta.for
+7
View File
@@ -0,0 +1,7 @@
FUNCTION beta(z,w)
REAL beta,w,z
CU USES gammln
REAL gammln
beta=exp(gammln(z)+gammln(w)-gammln(z+w))
return
END
dataassim/math/numrec/f77_sources/betacf.for
+37
View File
@@ -0,0 +1,37 @@
FUNCTION betacf(a,b,x)
INTEGER MAXIT
REAL betacf,a,b,x,EPS,FPMIN
PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30)
INTEGER m,m2
REAL aa,c,d,del,h,qab,qam,qap
qab=a+b
qap=a+1.
qam=a-1.
c=1.
d=1.-qab*x/qap
if(abs(d).lt.FPMIN)d=FPMIN
d=1./d
h=d
do 11 m=1,MAXIT
m2=2*m
aa=m*(b-m)*x/((qam+m2)*(a+m2))
d=1.+aa*d
if(abs(d).lt.FPMIN)d=FPMIN
c=1.+aa/c
if(abs(c).lt.FPMIN)c=FPMIN
d=1./d
h=h*d*c
aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2))
d=1.+aa*d
if(abs(d).lt.FPMIN)d=FPMIN
c=1.+aa/c
if(abs(c).lt.FPMIN)c=FPMIN
d=1./d
del=d*c
h=h*del
if(abs(del-1.).lt.EPS)goto 1
11 continue
pause 'a or b too big, or MAXIT too small in betacf'
1 betacf=h
return
END
dataassim/math/numrec/f77_sources/betai.for
+18
View File
@@ -0,0 +1,18 @@
FUNCTION betai(a,b,x)
REAL betai,a,b,x
CU USES betacf,gammln
REAL bt,betacf,gammln
if(x.lt.0..or.x.gt.1.)pause 'bad argument x in betai'
if(x.eq.0..or.x.eq.1.)then
bt=0.
else
bt=exp(gammln(a+b)-gammln(a)-gammln(b)+a*log(x)+b*log(1.-x))
endif
if(x.lt.(a+1.)/(a+b+2.))then
betai=bt*betacf(a,b,x)/a
return
else
betai=1.-bt*betacf(b,a,1.-x)/b
return
endif
END
dataassim/math/numrec/f77_sources/bico.for
+8
View File
@@ -0,0 +1,8 @@
FUNCTION bico(n,k)
INTEGER k,n
REAL bico
CU USES factln
REAL factln
bico=nint(exp(factln(n)-factln(k)-factln(n-k)))
return
END
dataassim/math/numrec/f77_sources/bksub.for
+28
View File
@@ -0,0 +1,28 @@
SUBROUTINE bksub(ne,nb,jf,k1,k2,c,nci,ncj,nck)
INTEGER jf,k1,k2,nb,nci,ncj,nck,ne
REAL c(nci,ncj,nck)
INTEGER i,im,j,k,kp,nbf
REAL xx
nbf=ne-nb
im=1
do 13 k=k2,k1,-1
if (k.eq.k1) im=nbf+1
kp=k+1
do 12 j=1,nbf
xx=c(j,jf,kp)
do 11 i=im,ne
c(i,jf,k)=c(i,jf,k)-c(i,j,k)*xx
11 continue
12 continue
13 continue
do 16 k=k1,k2
kp=k+1
do 14 i=1,nb
c(i,1,k)=c(i+nbf,jf,k)
14 continue
do 15 i=1,nbf
c(i+nb,1,k)=c(i,jf,kp)
15 continue
16 continue
return
END
dataassim/math/numrec/f77_sources/bnldev.for
+54
View File
@@ -0,0 +1,54 @@
FUNCTION bnldev(pp,n,idum)
INTEGER idum,n
REAL bnldev,pp,PI
CU USES gammln,ran1
PARAMETER (PI=3.141592654)
INTEGER j,nold
REAL am,em,en,g,oldg,p,pc,pclog,plog,pold,sq,t,y,gammln,ran1
SAVE nold,pold,pc,plog,pclog,en,oldg
DATA nold /-1/, pold /-1./
if(pp.le.0.5)then
p=pp
else
p=1.-pp
endif
am=n*p
if (n.lt.25)then
bnldev=0.
do 11 j=1,n
if(ran1(idum).lt.p)bnldev=bnldev+1.
11 continue
else if (am.lt.1.) then
g=exp(-am)
t=1.
do 12 j=0,n
t=t*ran1(idum)
if (t.lt.g) goto 1
12 continue
j=n
1 bnldev=j
else
if (n.ne.nold) then
en=n
oldg=gammln(en+1.)
nold=n
endif
if (p.ne.pold) then
pc=1.-p
plog=log(p)
pclog=log(pc)
pold=p
endif
sq=sqrt(2.*am*pc)
2 y=tan(PI*ran1(idum))
em=sq*y+am
if (em.lt.0..or.em.ge.en+1.) goto 2
em=int(em)
t=1.2*sq*(1.+y**2)*exp(oldg-gammln(em+1.)-gammln(en-em+1.)+em*
*plog+(en-em)*pclog)
if (ran1(idum).gt.t) goto 2
bnldev=em
endif
if (p.ne.pp) bnldev=n-bnldev
return
END
dataassim/math/numrec/f77_sources/brent.for
+83
View File
@@ -0,0 +1,83 @@
FUNCTION brent(ax,bx,cx,f,tol,xmin)
INTEGER ITMAX
REAL brent,ax,bx,cx,tol,xmin,f,CGOLD,ZEPS
EXTERNAL f
PARAMETER (ITMAX=100,CGOLD=.3819660,ZEPS=1.0e-10)
INTEGER iter
REAL a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm
a=min(ax,cx)
b=max(ax,cx)
v=bx
w=v
x=v
e=0.
fx=f(x)
fv=fx
fw=fx
do 11 iter=1,ITMAX
xm=0.5*(a+b)
tol1=tol*abs(x)+ZEPS
tol2=2.*tol1
if(abs(x-xm).le.(tol2-.5*(b-a))) goto 3
if(abs(e).gt.tol1) then
r=(x-w)*(fx-fv)
q=(x-v)*(fx-fw)
p=(x-v)*q-(x-w)*r
q=2.*(q-r)
if(q.gt.0.) p=-p
q=abs(q)
etemp=e
e=d
if(abs(p).ge.abs(.5*q*etemp).or.p.le.q*(a-x).or.p.ge.q*(b-x))
*goto 1
d=p/q
u=x+d
if(u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x)
goto 2
endif
1 if(x.ge.xm) then
e=a-x
else
e=b-x
endif
d=CGOLD*e
2 if(abs(d).ge.tol1) then
u=x+d
else
u=x+sign(tol1,d)
endif
fu=f(u)
if(fu.le.fx) then
if(u.ge.x) then
a=x
else
b=x
endif
v=w
fv=fw
w=x
fw=fx
x=u
fx=fu
else
if(u.lt.x) then
a=u
else
b=u
endif
if(fu.le.fw .or. w.eq.x) then
v=w
fv=fw
w=u
fw=fu
else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then
v=u
fv=fu
endif
endif
11 continue
pause 'brent exceed maximum iterations'
3 xmin=x
brent=fx
return
END
dataassim/math/numrec/f77_sources/broydn.for
+170
View File
@@ -0,0 +1,170 @@
SUBROUTINE broydn(x,n,check)
INTEGER n,nn,NP,MAXITS
REAL x(n),fvec,EPS,TOLF,TOLMIN,TOLX,STPMX
LOGICAL check
PARAMETER (NP=40,MAXITS=200,EPS=1.e-7,TOLF=1.e-4,TOLMIN=1.e-6,
*TOLX=EPS,STPMX=100.)
COMMON /newtv/ fvec(NP),nn
CU USES fdjac,fmin,lnsrch,qrdcmp,qrupdt,rsolv
INTEGER i,its,j,k
REAL den,f,fold,stpmax,sum,temp,test,c(NP),d(NP),fvcold(NP),g(NP),
*p(NP),qt(NP,NP),r(NP,NP),s(NP),t(NP),w(NP),xold(NP),fmin
LOGICAL restrt,sing,skip
EXTERNAL fmin
nn=n
f=fmin(x)
test=0.
do 11 i=1,n
if(abs(fvec(i)).gt.test)test=abs(fvec(i))
11 continue
if(test.lt..01*TOLF)then
check=.false.
return
endif
sum=0.
do 12 i=1,n
sum=sum+x(i)**2
12 continue
stpmax=STPMX*max(sqrt(sum),float(n))
restrt=.true.
do 44 its=1,MAXITS
if(restrt)then
call fdjac(n,x,fvec,NP,r)
call qrdcmp(r,n,NP,c,d,sing)
if(sing) pause 'singular Jacobian in broydn'
do 14 i=1,n
do 13 j=1,n
qt(i,j)=0.
13 continue
qt(i,i)=1.
14 continue
do 18 k=1,n-1
if(c(k).ne.0.)then
do 17 j=1,n
sum=0.
do 15 i=k,n
sum=sum+r(i,k)*qt(i,j)
15 continue
sum=sum/c(k)
do 16 i=k,n
qt(i,j)=qt(i,j)-sum*r(i,k)
16 continue
17 continue
endif
18 continue
do 21 i=1,n
r(i,i)=d(i)
do 19 j=1,i-1
r(i,j)=0.
19 continue
21 continue
else
do 22 i=1,n
s(i)=x(i)-xold(i)
22 continue
do 24 i=1,n
sum=0.
do 23 j=i,n
sum=sum+r(i,j)*s(j)
23 continue
t(i)=sum
24 continue
skip=.true.
do 26 i=1,n
sum=0.
do 25 j=1,n
sum=sum+qt(j,i)*t(j)
25 continue
w(i)=fvec(i)-fvcold(i)-sum
if(abs(w(i)).ge.EPS*(abs(fvec(i))+abs(fvcold(i))))then
skip=.false.
else
w(i)=0.
endif
26 continue
if(.not.skip)then
do 28 i=1,n
sum=0.
do 27 j=1,n
sum=sum+qt(i,j)*w(j)
27 continue
t(i)=sum
28 continue
den=0.
do 29 i=1,n
den=den+s(i)**2
29 continue
do 31 i=1,n
s(i)=s(i)/den
31 continue
call qrupdt(r,qt,n,NP,t,s)
do 32 i=1,n
if(r(i,i).eq.0.) pause 'r singular in broydn'
d(i)=r(i,i)
32 continue
endif
endif
do 34 i=1,n
sum=0.
do 33 j=1,n
sum=sum+qt(i,j)*fvec(j)
33 continue
g(i)=sum
34 continue
do 36 i=n,1,-1
sum=0.
do 35 j=1,i
sum=sum+r(j,i)*g(j)
35 continue
g(i)=sum
36 continue
do 37 i=1,n
xold(i)=x(i)
fvcold(i)=fvec(i)
37 continue
fold=f
do 39 i=1,n
sum=0.
do 38 j=1,n
sum=sum+qt(i,j)*fvec(j)
38 continue
p(i)=-sum
39 continue
call rsolv(r,n,NP,d,p)
call lnsrch(n,xold,fold,g,p,x,f,stpmax,check,fmin)
test=0.
do 41 i=1,n
if(abs(fvec(i)).gt.test)test=abs(fvec(i))
41 continue
if(test.lt.TOLF)then
check=.false.
return
endif
if(check)then
if(restrt)then
return
else
test=0.
den=max(f,.5*n)
do 42 i=1,n
temp=abs(g(i))*max(abs(x(i)),1.)/den
if(temp.gt.test)test=temp
42 continue
if(test.lt.TOLMIN)then
return
else
restrt=.true.
endif
endif
else
restrt=.false.
test=0.
do 43 i=1,n
temp=(abs(x(i)-xold(i)))/max(abs(x(i)),1.)
if(temp.gt.test)test=temp
43 continue
if(test.lt.TOLX)return
endif
44 continue
pause 'MAXITS exceeded in broydn'
END
dataassim/math/numrec/f77_sources/bsstep.for
+109
View File
@@ -0,0 +1,109 @@
SUBROUTINE bsstep(y,dydx,nv,x,htry,eps,yscal,hdid,hnext,derivs)
INTEGER nv,NMAX,KMAXX,IMAX
REAL eps,hdid,hnext,htry,x,dydx(nv),y(nv),yscal(nv),SAFE1,SAFE2,
*REDMAX,REDMIN,TINY,SCALMX
PARAMETER (NMAX=50,KMAXX=8,IMAX=KMAXX+1,SAFE1=.25,SAFE2=.7,
*REDMAX=1.e-5,REDMIN=.7,TINY=1.e-30,SCALMX=.1)
CU USES derivs,mmid,pzextr
INTEGER i,iq,k,kk,km,kmax,kopt,nseq(IMAX)
REAL eps1,epsold,errmax,fact,h,red,scale,work,wrkmin,xest,xnew,
*a(IMAX),alf(KMAXX,KMAXX),err(KMAXX),yerr(NMAX),ysav(NMAX),
*yseq(NMAX)
LOGICAL first,reduct
SAVE a,alf,epsold,first,kmax,kopt,nseq,xnew
EXTERNAL derivs
DATA first/.true./,epsold/-1./
DATA nseq /2,4,6,8,10,12,14,16,18/
if(eps.ne.epsold)then
hnext=-1.e29
xnew=-1.e29
eps1=SAFE1*eps
a(1)=nseq(1)+1
do 11 k=1,KMAXX
a(k+1)=a(k)+nseq(k+1)
11 continue
do 13 iq=2,KMAXX
do 12 k=1,iq-1
alf(k,iq)=eps1**((a(k+1)-a(iq+1))/((a(iq+1)-a(1)+1.)*(2*k+
*1)))
12 continue
13 continue
epsold=eps
do 14 kopt=2,KMAXX-1
if(a(kopt+1).gt.a(kopt)*alf(kopt-1,kopt))goto 1
14 continue
1 kmax=kopt
endif
h=htry
do 15 i=1,nv
ysav(i)=y(i)
15 continue
if(h.ne.hnext.or.x.ne.xnew)then
first=.true.
kopt=kmax
endif
reduct=.false.
2 do 17 k=1,kmax
xnew=x+h
if(xnew.eq.x)pause 'step size underflow in bsstep'
call mmid(ysav,dydx,nv,x,h,nseq(k),yseq,derivs)
xest=(h/nseq(k))**2
call pzextr(k,xest,yseq,y,yerr,nv)
if(k.ne.1)then
errmax=TINY
do 16 i=1,nv
errmax=max(errmax,abs(yerr(i)/yscal(i)))
16 continue
errmax=errmax/eps
km=k-1
err(km)=(errmax/SAFE1)**(1./(2*km+1))
endif
if(k.ne.1.and.(k.ge.kopt-1.or.first))then
if(errmax.lt.1.)goto 4
if(k.eq.kmax.or.k.eq.kopt+1)then
red=SAFE2/err(km)
goto 3
else if(k.eq.kopt)then
if(alf(kopt-1,kopt).lt.err(km))then
red=1./err(km)
goto 3
endif
else if(kopt.eq.kmax)then
if(alf(km,kmax-1).lt.err(km))then
red=alf(km,kmax-1)*SAFE2/err(km)
goto 3
endif
else if(alf(km,kopt).lt.err(km))then
red=alf(km,kopt-1)/err(km)
goto 3
endif
endif
17 continue
3 red=min(red,REDMIN)
red=max(red,REDMAX)
h=h*red
reduct=.true.
goto 2
4 x=xnew
hdid=h
first=.false.
wrkmin=1.e35
do 18 kk=1,km
fact=max(err(kk),SCALMX)
work=fact*a(kk+1)
if(work.lt.wrkmin)then
scale=fact
wrkmin=work
kopt=kk+1
endif
18 continue
hnext=h/scale
if(kopt.ge.k.and.kopt.ne.kmax.and..not.reduct)then
fact=max(scale/alf(kopt-1,kopt),SCALMX)
if(a(kopt+1)*fact.le.wrkmin)then
hnext=h/fact
kopt=kopt+1
endif
endif
return
END
dataassim/math/numrec/f77_sources/caldat.for
+22
View File
@@ -0,0 +1,22 @@
SUBROUTINE caldat(julian,mm,id,iyyy)
INTEGER id,iyyy,julian,mm,IGREG
PARAMETER (IGREG=2299161)
INTEGER ja,jalpha,jb,jc,jd,je
if(julian.ge.IGREG)then
jalpha=int(((julian-1867216)-0.25)/36524.25)
ja=julian+1+jalpha-int(0.25*jalpha)
else
ja=julian
endif
jb=ja+1524
jc=int(6680.+((jb-2439870)-122.1)/365.25)
jd=365*jc+int(0.25*jc)
je=int((jb-jd)/30.6001)
id=jb-jd-int(30.6001*je)
mm=je-1
if(mm.gt.12)mm=mm-12
iyyy=jc-4715
if(mm.gt.2)iyyy=iyyy-1
if(iyyy.le.0)iyyy=iyyy-1
return
END
dataassim/math/numrec/f77_sources/chder.for
+16
View File
@@ -0,0 +1,16 @@
SUBROUTINE chder(a,b,c,cder,n)
INTEGER n
REAL a,b,c(n),cder(n)
INTEGER j
REAL con
cder(n)=0.
cder(n-1)=2*(n-1)*c(n)
do 11 j=n-2,1,-1
cder(j)=cder(j+2)+2*j*c(j+1)
11 continue
con=2./(b-a)
do 12 j=1,n
cder(j)=cder(j)*con
12 continue
return
END
dataassim/math/numrec/f77_sources/chebev.for
+18
View File
@@ -0,0 +1,18 @@
FUNCTION chebev(a,b,c,m,x)
INTEGER m
REAL chebev,a,b,x,c(m)
INTEGER j
REAL d,dd,sv,y,y2
if ((x-a)*(x-b).gt.0.) pause 'x not in range in chebev'
d=0.
dd=0.
y=(2.*x-a-b)/(b-a)
y2=2.*y
do 11 j=m,2,-1
sv=d
d=y2*d-dd+c(j)
dd=sv
11 continue
chebev=y*d-dd+0.5*c(1)
return
END
dataassim/math/numrec/f77_sources/chebft.for
+24
View File
@@ -0,0 +1,24 @@
SUBROUTINE chebft(a,b,c,n,func)
INTEGER n,NMAX
REAL a,b,c(n),func,PI
EXTERNAL func
PARAMETER (NMAX=50, PI=3.141592653589793d0)
INTEGER j,k
REAL bma,bpa,fac,y,f(NMAX)
DOUBLE PRECISION sum
bma=0.5*(b-a)
bpa=0.5*(b+a)
do 11 k=1,n
y=cos(PI*(k-0.5)/n)
f(k)=func(y*bma+bpa)
11 continue
fac=2./n
do 13 j=1,n
sum=0.d0
do 12 k=1,n
sum=sum+f(k)*cos((PI*(j-1))*((k-0.5d0)/n))
12 continue
c(j)=fac*sum
13 continue
return
END
dataassim/math/numrec/f77_sources/chebpc.for
+27
View File
@@ -0,0 +1,27 @@
SUBROUTINE chebpc(c,d,n)
INTEGER n,NMAX
REAL c(n),d(n)
PARAMETER (NMAX=50)
INTEGER j,k
REAL sv,dd(NMAX)
do 11 j=1,n
d(j)=0.
dd(j)=0.
11 continue
d(1)=c(n)
do 13 j=n-1,2,-1
do 12 k=n-j+1,2,-1
sv=d(k)
d(k)=2.*d(k-1)-dd(k)
dd(k)=sv
12 continue
sv=d(1)
d(1)=-dd(1)+c(j)
dd(1)=sv
13 continue
do 14 j=n,2,-1
d(j)=d(j-1)-dd(j)
14 continue
d(1)=-dd(1)+0.5*c(1)
return
END
dataassim/math/numrec/f77_sources/chint.for
+18
View File
@@ -0,0 +1,18 @@
SUBROUTINE chint(a,b,c,cint,n)
INTEGER n
REAL a,b,c(n),cint(n)
INTEGER j
REAL con,fac,sum
con=0.25*(b-a)
sum=0.
fac=1.
do 11 j=2,n-1
cint(j)=con*(c(j-1)-c(j+1))/(j-1)
sum=sum+fac*cint(j)
fac=-fac
11 continue
cint(n)=con*c(n-1)/(n-1)
sum=sum+fac*cint(n)
cint(1)=2.*sum
return
END
dataassim/math/numrec/f77_sources/chixy.for
+32
View File
@@ -0,0 +1,32 @@
FUNCTION chixy(bang)
REAL chixy,bang,BIG
INTEGER NMAX
PARAMETER (NMAX=1000,BIG=1.E30)
INTEGER nn,j
REAL xx(NMAX),yy(NMAX),sx(NMAX),sy(NMAX),ww(NMAX),aa,offs,avex,
*avey,sumw,b
COMMON /fitxyc/ xx,yy,sx,sy,ww,aa,offs,nn
b=tan(bang)
avex=0.
avey=0.
sumw=0.
do 11 j=1,nn
ww(j)=(b*sx(j))**2+sy(j)**2
if(ww(j).lt.1./BIG) then
ww(j)=BIG
else
ww(j)=1./ww(j)
endif
sumw=sumw+ww(j)
avex=avex+ww(j)*xx(j)
avey=avey+ww(j)*yy(j)
11 continue
avex=avex/sumw
avey=avey/sumw
aa=avey-b*avex
chixy=-offs
do 12 j=1,nn
chixy=chixy+ww(j)*(yy(j)-aa-b*xx(j))**2
12 continue
return
END
dataassim/math/numrec/f77_sources/choldc.for
+21
View File
@@ -0,0 +1,21 @@
SUBROUTINE choldc(a,n,np,p)
INTEGER n,np
REAL a(np,np),p(n)
INTEGER i,j,k
REAL sum
do 13 i=1,n
do 12 j=i,n
sum=a(i,j)
do 11 k=i-1,1,-1
sum=sum-a(i,k)*a(j,k)
11 continue
if(i.eq.j)then
if(sum.le.0.)pause 'choldc failed'
p(i)=sqrt(sum)
else
a(j,i)=sum/p(i)
endif
12 continue
13 continue
return
END
dataassim/math/numrec/f77_sources/cholsl.for
+21
View File
@@ -0,0 +1,21 @@
SUBROUTINE cholsl(a,n,np,p,b,x)
INTEGER n,np
REAL a(np,np),b(n),p(n),x(n)
INTEGER i,k
REAL sum
do 12 i=1,n
sum=b(i)
do 11 k=i-1,1,-1
sum=sum-a(i,k)*x(k)
11 continue
x(i)=sum/p(i)
12 continue
do 14 i=n,1,-1
sum=x(i)
do 13 k=i+1,n
sum=sum-a(k,i)*x(k)
13 continue
x(i)=sum/p(i)
14 continue
return
END
dataassim/math/numrec/f77_sources/chsone.for
+15
View File
@@ -0,0 +1,15 @@
SUBROUTINE chsone(bins,ebins,nbins,knstrn,df,chsq,prob)
INTEGER knstrn,nbins
REAL chsq,df,prob,bins(nbins),ebins(nbins)
CU USES gammq
INTEGER j
REAL gammq
df=nbins-knstrn
chsq=0.
do 11 j=1,nbins
if(ebins(j).le.0.)pause 'bad expected number in chsone'
chsq=chsq+(bins(j)-ebins(j))**2/ebins(j)
11 continue
prob=gammq(0.5*df,0.5*chsq)
return
END
dataassim/math/numrec/f77_sources/chstwo.for
+18
View File
@@ -0,0 +1,18 @@
SUBROUTINE chstwo(bins1,bins2,nbins,knstrn,df,chsq,prob)
INTEGER knstrn,nbins
REAL chsq,df,prob,bins1(nbins),bins2(nbins)
CU USES gammq
INTEGER j
REAL gammq
df=nbins-knstrn
chsq=0.
do 11 j=1,nbins
if(bins1(j).eq.0..and.bins2(j).eq.0.)then
df=df-1.
else
chsq=chsq+(bins1(j)-bins2(j))**2/(bins1(j)+bins2(j))
endif
11 continue
prob=gammq(0.5*df,0.5*chsq)
return
END
dataassim/math/numrec/f77_sources/cisi.for
+70
View File
@@ -0,0 +1,70 @@
SUBROUTINE cisi(x,ci,si)
INTEGER MAXIT
REAL ci,si,x,EPS,EULER,PIBY2,FPMIN,TMIN
PARAMETER (EPS=6.e-8,EULER=.57721566,MAXIT=100,PIBY2=1.5707963,
*FPMIN=1.e-30,TMIN=2.)
INTEGER i,k
REAL a,err,fact,sign,sum,sumc,sums,t,term,absc
COMPLEX h,b,c,d,del
LOGICAL odd
absc(h)=abs(real(h))+abs(aimag(h))
t=abs(x)
if(t.eq.0.)then
si=0.
ci=-1./FPMIN
return
endif
if(t.gt.TMIN)then
b=cmplx(1.,t)
c=1./FPMIN
d=1./b
h=d
do 11 i=2,MAXIT
a=-(i-1)**2
b=b+2.
d=1./(a*d+b)
c=b+a/c
del=c*d
h=h*del
if(absc(del-1.).lt.EPS)goto 1
11 continue
pause 'cf failed in cisi'
1 continue
h=cmplx(cos(t),-sin(t))*h
ci=-real(h)
si=PIBY2+aimag(h)
else
if(t.lt.sqrt(FPMIN))then
sumc=0.
sums=t
else
sum=0.
sums=0.
sumc=0.
sign=1.
fact=1.
odd=.true.
do 12 k=1,MAXIT
fact=fact*t/k
term=fact/k
sum=sum+sign*term
err=term/abs(sum)
if(odd)then
sign=-sign
sums=sum
sum=sumc
else
sumc=sum
sum=sums
endif
if(err.lt.EPS)goto 2
odd=.not.odd
12 continue
pause 'maxits exceeded in cisi'
endif
2 si=sums
ci=sumc+log(t)+EULER
endif
if(x.lt.0.)si=-si
return
END
dataassim/math/numrec/f77_sources/cntab1.for
+38
View File
@@ -0,0 +1,38 @@
SUBROUTINE cntab1(nn,ni,nj,chisq,df,prob,cramrv,ccc)
INTEGER ni,nj,nn(ni,nj),MAXI,MAXJ
REAL ccc,chisq,cramrv,df,prob,TINY
PARAMETER (MAXI=100,MAXJ=100,TINY=1.e-30)
CU USES gammq
INTEGER i,j,nni,nnj
REAL expctd,sum,sumi(MAXI),sumj(MAXJ),gammq
sum=0
nni=ni
nnj=nj
do 12 i=1,ni
sumi(i)=0.
do 11 j=1,nj
sumi(i)=sumi(i)+nn(i,j)
sum=sum+nn(i,j)
11 continue
if(sumi(i).eq.0.)nni=nni-1
12 continue
do 14 j=1,nj
sumj(j)=0.
do 13 i=1,ni
sumj(j)=sumj(j)+nn(i,j)
13 continue
if(sumj(j).eq.0.)nnj=nnj-1
14 continue
df=nni*nnj-nni-nnj+1
chisq=0.
do 16 i=1,ni
do 15 j=1,nj
expctd=sumj(j)*sumi(i)/sum
chisq=chisq+(nn(i,j)-expctd)**2/(expctd+TINY)
15 continue
16 continue
prob=gammq(0.5*df,0.5*chisq)
cramrv=sqrt(chisq/(sum*min(nni-1,nnj-1)))
ccc=sqrt(chisq/(chisq+sum))
return
END
dataassim/math/numrec/f77_sources/cntab2.for
+50
View File
@@ -0,0 +1,50 @@
SUBROUTINE cntab2(nn,ni,nj,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy)
INTEGER ni,nj,nn(ni,nj),MAXI,MAXJ
REAL h,hx,hxgy,hy,hygx,uxgy,uxy,uygx,TINY
PARAMETER (MAXI=100,MAXJ=100,TINY=1.e-30)
INTEGER i,j
REAL p,sum,sumi(MAXI),sumj(MAXJ)
sum=0
do 12 i=1,ni
sumi(i)=0.0
do 11 j=1,nj
sumi(i)=sumi(i)+nn(i,j)
sum=sum+nn(i,j)
11 continue
12 continue
do 14 j=1,nj
sumj(j)=0.
do 13 i=1,ni
sumj(j)=sumj(j)+nn(i,j)
13 continue
14 continue
hx=0.
do 15 i=1,ni
if(sumi(i).ne.0.)then
p=sumi(i)/sum
hx=hx-p*log(p)
endif
15 continue
hy=0.
do 16 j=1,nj
if(sumj(j).ne.0.)then
p=sumj(j)/sum
hy=hy-p*log(p)
endif
16 continue
h=0.
do 18 i=1,ni
do 17 j=1,nj
if(nn(i,j).ne.0)then
p=nn(i,j)/sum
h=h-p*log(p)
endif
17 continue
18 continue
hygx=h-hx
hxgy=h-hy
uygx=(hy-hygx)/(hy+TINY)
uxgy=(hx-hxgy)/(hx+TINY)
uxy=2.*(hx+hy-h)/(hx+hy+TINY)
return
END
dataassim/math/numrec/f77_sources/convlv.for
+31
View File
@@ -0,0 +1,31 @@
SUBROUTINE convlv(data,n,respns,m,isign,ans)
INTEGER isign,m,n,NMAX
REAL data(n),respns(n)
COMPLEX ans(n)
PARAMETER (NMAX=4096)
CU USES realft,twofft
INTEGER i,no2
COMPLEX fft(NMAX)
do 11 i=1,(m-1)/2
respns(n+1-i)=respns(m+1-i)
11 continue
do 12 i=(m+3)/2,n-(m-1)/2
respns(i)=0.0
12 continue
call twofft(data,respns,fft,ans,n)
no2=n/2
do 13 i=1,no2+1
if (isign.eq.1) then
ans(i)=fft(i)*ans(i)/no2
else if (isign.eq.-1) then
if (abs(ans(i)).eq.0.0) pause
*'deconvolving at response zero in convlv'
ans(i)=fft(i)/ans(i)/no2
else
pause 'no meaning for isign in convlv'
endif
13 continue
ans(1)=cmplx(real(ans(1)),real(ans(no2+1)))
call realft(ans,n,-1)
return
END
dataassim/math/numrec/f77_sources/copy.for
+11
View File
@@ -0,0 +1,11 @@
SUBROUTINE copy(aout,ain,n)
INTEGER n
DOUBLE PRECISION ain(n,n),aout(n,n)
INTEGER i,j
do 12 i=1,n
do 11 j=1,n
aout(j,i)=ain(j,i)
11 continue
12 continue
return
END
dataassim/math/numrec/f77_sources/correl.for
+17
View File
@@ -0,0 +1,17 @@
SUBROUTINE correl(data1,data2,n,ans)
INTEGER n,NMAX
REAL data1(n),data2(n)
COMPLEX ans(n)
PARAMETER (NMAX=4096)
CU USES realft,twofft
INTEGER i,no2
COMPLEX fft(NMAX)
call twofft(data1,data2,fft,ans,n)
no2=n/2
do 11 i=1,no2+1
ans(i)=fft(i)*conjg(ans(i))/float(no2)
11 continue
ans(1)=cmplx(real(ans(1)),real(ans(no2+1)))
call realft(ans,n,-1)
return
END
dataassim/math/numrec/f77_sources/cosft1.for
+33
View File
@@ -0,0 +1,33 @@
SUBROUTINE cosft1(y,n)
INTEGER n
REAL y(n+1)
CU USES realft
INTEGER j
REAL sum,y1,y2
DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
theta=3.141592653589793d0/n
wr=1.0d0
wi=0.0d0
wpr=-2.0d0*sin(0.5d0*theta)**2
wpi=sin(theta)
sum=0.5*(y(1)-y(n+1))
y(1)=0.5*(y(1)+y(n+1))
do 11 j=1,n/2-1
wtemp=wr
wr=wr*wpr-wi*wpi+wr
wi=wi*wpr+wtemp*wpi+wi
y1=0.5*(y(j+1)+y(n-j+1))
y2=(y(j+1)-y(n-j+1))
y(j+1)=y1-wi*y2
y(n-j+1)=y1+wi*y2
sum=sum+wr*y2
11 continue
call realft(y,n,+1)
y(n+1)=y(2)
y(2)=sum
do 12 j=4,n,2
sum=sum+y(j)
y(j)=sum
12 continue
return
END
dataassim/math/numrec/f77_sources/cosft2.for
+69
View File
@@ -0,0 +1,69 @@
SUBROUTINE cosft2(y,n,isign)
INTEGER isign,n
REAL y(n)
CU USES realft
INTEGER i
REAL sum,sum1,y1,y2,ytemp
DOUBLE PRECISION theta,wi,wi1,wpi,wpr,wr,wr1,wtemp,PI
PARAMETER (PI=3.141592653589793d0)
theta=0.5d0*PI/n
wr=1.0d0
wi=0.0d0
wr1=cos(theta)
wi1=sin(theta)
wpr=-2.0d0*wi1**2
wpi=sin(2.d0*theta)
if(isign.eq.1)then
do 11 i=1,n/2
y1=0.5*(y(i)+y(n-i+1))
y2=wi1*(y(i)-y(n-i+1))
y(i)=y1+y2
y(n-i+1)=y1-y2
wtemp=wr1
wr1=wr1*wpr-wi1*wpi+wr1
wi1=wi1*wpr+wtemp*wpi+wi1
11 continue
call realft(y,n,1)
do 12 i=3,n,2
wtemp=wr
wr=wr*wpr-wi*wpi+wr
wi=wi*wpr+wtemp*wpi+wi
y1=y(i)*wr-y(i+1)*wi
y2=y(i+1)*wr+y(i)*wi
y(i)=y1
y(i+1)=y2
12 continue
sum=0.5*y(2)
do 13 i=n,2,-2
sum1=sum
sum=sum+y(i)
y(i)=sum1
13 continue
else if(isign.eq.-1)then
ytemp=y(n)
do 14 i=n,4,-2
y(i)=y(i-2)-y(i)
14 continue
y(2)=2.0*ytemp
do 15 i=3,n,2
wtemp=wr
wr=wr*wpr-wi*wpi+wr
wi=wi*wpr+wtemp*wpi+wi
y1=y(i)*wr+y(i+1)*wi
y2=y(i+1)*wr-y(i)*wi
y(i)=y1
y(i+1)=y2
15 continue
call realft(y,n,-1)
do 16 i=1,n/2
y1=y(i)+y(n-i+1)
y2=(0.5/wi1)*(y(i)-y(n-i+1))
y(i)=0.5*(y1+y2)
y(n-i+1)=0.5*(y1-y2)
wtemp=wr1
wr1=wr1*wpr-wi1*wpi+wr1
wi1=wi1*wpr+wtemp*wpi+wi1
16 continue
endif
return
END
dataassim/math/numrec/f77_sources/covsrt.for
+29
View File
@@ -0,0 +1,29 @@
SUBROUTINE covsrt(covar,npc,ma,ia,mfit)
INTEGER ma,mfit,npc,ia(ma)
REAL covar(npc,npc)
INTEGER i,j,k
REAL swap
do 12 i=mfit+1,ma
do 11 j=1,i
covar(i,j)=0.
covar(j,i)=0.
11 continue
12 continue
k=mfit
do 15 j=ma,1,-1
if(ia(j).ne.0)then
do 13 i=1,ma
swap=covar(i,k)
covar(i,k)=covar(i,j)
covar(i,j)=swap
13 continue
do 14 i=1,ma
swap=covar(k,i)
covar(k,i)=covar(j,i)
covar(j,i)=swap
14 continue
k=k-1
endif
15 continue
return
END
dataassim/math/numrec/f77_sources/crank.for
+29
View File
@@ -0,0 +1,29 @@
SUBROUTINE crank(n,w,s)
INTEGER n
REAL s,w(n)
INTEGER j,ji,jt
REAL rank,t
s=0.
j=1
1 if(j.lt.n)then
if(w(j+1).ne.w(j))then
w(j)=j
j=j+1
else
do 11 jt=j+1,n
if(w(jt).ne.w(j))goto 2
11 continue
jt=n+1
2 rank=0.5*(j+jt-1)
do 12 ji=j,jt-1
w(ji)=rank
12 continue
t=jt-j
s=s+t**3-t
j=jt
endif
goto 1
endif
if(j.eq.n)w(n)=n
return
END
dataassim/math/numrec/f77_sources/cyclic.for
+28
View File
@@ -0,0 +1,28 @@
SUBROUTINE cyclic(a,b,c,alpha,beta,r,x,n)
INTEGER n,NMAX
REAL alpha,beta,a(n),b(n),c(n),r(n),x(n)
PARAMETER (NMAX=500)
CU USES tridag
INTEGER i
REAL fact,gamma,bb(NMAX),u(NMAX),z(NMAX)
if(n.le.2)pause 'n too small in cyclic'
if(n.gt.NMAX)pause 'NMAX too small in cyclic'
gamma=-b(1)
bb(1)=b(1)-gamma
bb(n)=b(n)-alpha*beta/gamma
do 11 i=2,n-1
bb(i)=b(i)
11 continue
call tridag(a,bb,c,r,x,n)
u(1)=gamma
u(n)=alpha
do 12 i=2,n-1
u(i)=0.
12 continue
call tridag(a,bb,c,u,z,n)
fact=(x(1)+beta*x(n)/gamma)/(1.+z(1)+beta*z(n)/gamma)
do 13 i=1,n
x(i)=x(i)-fact*z(i)
13 continue
return
END
dataassim/math/numrec/f77_sources/daub4.for
+35
View File
@@ -0,0 +1,35 @@
SUBROUTINE daub4(a,n,isign)
INTEGER n,isign,NMAX
REAL a(n),C3,C2,C1,C0
PARAMETER (C0=0.4829629131445341,C1=0.8365163037378079,
*C2=0.2241438680420134,C3=-0.1294095225512604,NMAX=1024)
REAL wksp(NMAX)
INTEGER nh,nh1,i,j
if(n.lt.4)return
if(n.gt.NMAX) pause 'wksp too small in daub4'
nh=n/2
nh1=nh+1
if (isign.ge.0) then
i=1
do 11 j=1,n-3,2
wksp(i)=C0*a(j)+C1*a(j+1)+C2*a(j+2)+C3*a(j+3)
wksp(i+nh)=C3*a(j)-C2*a(j+1)+C1*a(j+2)-C0*a(j+3)
i=i+1
11 continue
wksp(i)=C0*a(n-1)+C1*a(n)+C2*a(1)+C3*a(2)
wksp(i+nh)=C3*a(n-1)-C2*a(n)+C1*a(1)-C0*a(2)
else
wksp(1)=C2*a(nh)+C1*a(n)+C0*a(1)+C3*a(nh1)
wksp(2)=C3*a(nh)-C0*a(n)+C1*a(1)-C2*a(nh1)
j=3
do 12 i=1,nh-1
wksp(j)=C2*a(i)+C1*a(i+nh)+C0*a(i+1)+C3*a(i+nh1)
wksp(j+1)=C3*a(i)-C0*a(i+nh)+C1*a(i+1)-C2*a(i+nh1)
j=j+2
12 continue
endif
do 13 i=1,n
a(i)=wksp(i)
13 continue
return
END
dataassim/math/numrec/f77_sources/dawson.for
+36
View File
@@ -0,0 +1,36 @@
FUNCTION dawson(x)
INTEGER NMAX
REAL dawson,x,H,A1,A2,A3
PARAMETER (NMAX=6,H=0.4,A1=2./3.,A2=0.4,A3=2./7.)
INTEGER i,init,n0
REAL d1,d2,e1,e2,sum,x2,xp,xx,c(NMAX)
SAVE init,c
DATA init/0/
if(init.eq.0)then
init=1
do 11 i=1,NMAX
c(i)=exp(-((2.*float(i)-1.)*H)**2)
11 continue
endif
if(abs(x).lt.0.2)then
x2=x**2
dawson=x*(1.-A1*x2*(1.-A2*x2*(1.-A3*x2)))
else
xx=abs(x)
n0=2*nint(0.5*xx/H)
xp=xx-float(n0)*H
e1=exp(2.*xp*H)
e2=e1**2
d1=float(n0+1)
d2=d1-2.
sum=0.
do 12 i=1,NMAX
sum=sum+c(i)*(e1/d1+1./(d2*e1))
d1=d1+2.
d2=d2-2.
e1=e2*e1
12 continue
dawson=0.5641895835*sign(exp(-xp**2),x)*sum
endif
return
END
dataassim/math/numrec/f77_sources/dbrent.for
+110
View File
@@ -0,0 +1,110 @@
FUNCTION dbrent(ax,bx,cx,f,df,tol,xmin)
INTEGER ITMAX
REAL dbrent,ax,bx,cx,tol,xmin,df,f,ZEPS
EXTERNAL df,f
PARAMETER (ITMAX=100,ZEPS=1.0e-10)
INTEGER iter
REAL a,b,d,d1,d2,du,dv,dw,dx,e,fu,fv,fw,fx,olde,tol1,tol2,u,u1,u2,
*v,w,x,xm
LOGICAL ok1,ok2
a=min(ax,cx)
b=max(ax,cx)
v=bx
w=v
x=v
e=0.
fx=f(x)
fv=fx
fw=fx
dx=df(x)
dv=dx
dw=dx
do 11 iter=1,ITMAX
xm=0.5*(a+b)
tol1=tol*abs(x)+ZEPS
tol2=2.*tol1
if(abs(x-xm).le.(tol2-.5*(b-a))) goto 3
if(abs(e).gt.tol1) then
d1=2.*(b-a)
d2=d1
if(dw.ne.dx) d1=(w-x)*dx/(dx-dw)
if(dv.ne.dx) d2=(v-x)*dx/(dx-dv)
u1=x+d1
u2=x+d2
ok1=((a-u1)*(u1-b).gt.0.).and.(dx*d1.le.0.)
ok2=((a-u2)*(u2-b).gt.0.).and.(dx*d2.le.0.)
olde=e
e=d
if(.not.(ok1.or.ok2))then
goto 1
else if (ok1.and.ok2)then
if(abs(d1).lt.abs(d2))then
d=d1
else
d=d2
endif
else if (ok1)then
d=d1
else
d=d2
endif
if(abs(d).gt.abs(0.5*olde))goto 1
u=x+d
if(u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x)
goto 2
endif
1 if(dx.ge.0.) then
e=a-x
else
e=b-x
endif
d=0.5*e
2 if(abs(d).ge.tol1) then
u=x+d
fu=f(u)
else
u=x+sign(tol1,d)
fu=f(u)
if(fu.gt.fx)goto 3
endif
du=df(u)
if(fu.le.fx) then
if(u.ge.x) then
a=x
else
b=x
endif
v=w
fv=fw
dv=dw
w=x
fw=fx
dw=dx
x=u
fx=fu
dx=du
else
if(u.lt.x) then
a=u
else
b=u
endif
if(fu.le.fw .or. w.eq.x) then
v=w
fv=fw
dv=dw
w=u
fw=fu
dw=du
else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then
v=u
fv=fu
dv=du
endif
endif
11 continue
pause 'dbrent exceeded maximum iterations'
3 xmin=x
dbrent=fx
return
END
dataassim/math/numrec/f77_sources/ddpoly.for
+23
View File
@@ -0,0 +1,23 @@
SUBROUTINE ddpoly(c,nc,x,pd,nd)
INTEGER nc,nd
REAL x,c(nc),pd(nd)
INTEGER i,j,nnd
REAL const
pd(1)=c(nc)
do 11 j=2,nd
pd(j)=0.
11 continue
do 13 i=nc-1,1,-1
nnd=min(nd,nc+1-i)
do 12 j=nnd,2,-1
pd(j)=pd(j)*x+pd(j-1)
12 continue
pd(1)=pd(1)*x+c(i)
13 continue
const=2.
do 14 i=3,nd
pd(i)=const*pd(i)
const=const*i
14 continue
return
END
dataassim/math/numrec/f77_sources/decchk.for
+27
View File
@@ -0,0 +1,27 @@
LOGICAL FUNCTION decchk(string,n,ch)
INTEGER n
CHARACTER string*(*),ch*1
INTEGER ij(10,10),ip(10,8),i,j,k,m
SAVE ij,ip
DATA ip/0,1,2,3,4,5,6,7,8,9,1,5,7,6,2,8,3,0,9,4,5,8,0,3,7,9,6,1,4,
*2,8,9,1,6,0,4,3,5,2,7,9,4,5,3,1,2,6,8,7,0,4,2,8,6,5,7,3,9,0,1,2,7,
*9,3,8,0,6,4,1,5,7,0,4,6,9,1,3,2,5,8/,ij/0,1,2,3,4,5,6,7,8,9,1,2,3,
*4,0,9,5,6,7,8,2,3,4,0,1,8,9,5,6,7,3,4,0,1,2,7,8,9,5,6,4,0,1,2,3,6,
*7,8,9,5,5,6,7,8,9,0,1,2,3,4,6,7,8,9,5,4,0,1,2,3,7,8,9,5,6,3,4,0,1,
*2,8,9,5,6,7,2,3,4,0,1,9,5,6,7,8,1,2,3,4,0/
k=0
m=0
do 11 j=1,n
i=ichar(string(j:j))
if (i.ge.48.and.i.le.57)then
k=ij(k+1,ip(mod(i+2,10)+1,mod(m,8)+1)+1)
m=m+1
endif
11 continue
decchk=(k.eq.0)
do 12 i=0,9
if (ij(k+1,ip(i+1,mod(m,8)+1)+1).eq.0) goto 1
12 continue
1 ch=char(i+48)
return
end
dataassim/math/numrec/f77_sources/df1dim.for
+18
View File
@@ -0,0 +1,18 @@
FUNCTION df1dim(x)
INTEGER NMAX
REAL df1dim,x
PARAMETER (NMAX=50)
CU USES dfunc
INTEGER j,ncom
REAL df(NMAX),pcom(NMAX),xicom(NMAX),xt(NMAX)
COMMON /f1com/ pcom,xicom,ncom
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call dfunc(xt,df)
df1dim=0.
do 12 j=1,ncom
df1dim=df1dim+df(j)*xicom(j)
12 continue
return
END
dataassim/math/numrec/f77_sources/dfour1.for
+52
View File
@@ -0,0 +1,52 @@
SUBROUTINE dfour1(data,nn,isign)
INTEGER isign,nn
DOUBLE PRECISION data(2*nn)
INTEGER i,istep,j,m,mmax,n
DOUBLE PRECISION tempi,tempr
DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
n=2*nn
j=1
do 11 i=1,n,2
if(j.gt.i)then
tempr=data(j)
tempi=data(j+1)
data(j)=data(i)
data(j+1)=data(i+1)
data(i)=tempr
data(i+1)=tempi
endif
m=n/2
1 if ((m.ge.2).and.(j.gt.m)) then
j=j-m
m=m/2
goto 1
endif
j=j+m
11 continue
mmax=2
2 if (n.gt.mmax) then
istep=2*mmax
theta=6.28318530717959d0/(isign*mmax)
wpr=-2.d0*sin(0.5d0*theta)**2
wpi=sin(theta)
wr=1.d0
wi=0.d0
do 13 m=1,mmax,2
do 12 i=m,n,istep
j=i+mmax
tempr=wr*data(j)-wi*data(j+1)
tempi=wr*data(j+1)+wi*data(j)
data(j)=data(i)-tempr
data(j+1)=data(i+1)-tempi
data(i)=data(i)+tempr
data(i+1)=data(i+1)+tempi
12 continue
wtemp=wr
wr=wr*wpr-wi*wpi+wr
wi=wi*wpr+wtemp*wpi+wi
13 continue
mmax=istep
goto 2
endif
return
END
dataassim/math/numrec/f77_sources/dfpmin.for
+89
View File
@@ -0,0 +1,89 @@
SUBROUTINE dfpmin(p,n,gtol,iter,fret,func,dfunc)
INTEGER iter,n,NMAX,ITMAX
REAL fret,gtol,p(n),func,EPS,STPMX,TOLX
PARAMETER (NMAX=50,ITMAX=200,STPMX=100.,EPS=3.e-8,TOLX=4.*EPS)
EXTERNAL dfunc,func
CU USES dfunc,func,lnsrch
INTEGER i,its,j
LOGICAL check
REAL den,fac,fad,fae,fp,stpmax,sum,sumdg,sumxi,temp,test,dg(NMAX),
*g(NMAX),hdg(NMAX),hessin(NMAX,NMAX),pnew(NMAX),xi(NMAX)
fp=func(p)
call dfunc(p,g)
sum=0.
do 12 i=1,n
do 11 j=1,n
hessin(i,j)=0.
11 continue
hessin(i,i)=1.
xi(i)=-g(i)
sum=sum+p(i)**2
12 continue
stpmax=STPMX*max(sqrt(sum),float(n))
do 27 its=1,ITMAX
iter=its
call lnsrch(n,p,fp,g,xi,pnew,fret,stpmax,check,func)
fp=fret
do 13 i=1,n
xi(i)=pnew(i)-p(i)
p(i)=pnew(i)
13 continue
test=0.
do 14 i=1,n
temp=abs(xi(i))/max(abs(p(i)),1.)
if(temp.gt.test)test=temp
14 continue
if(test.lt.TOLX)return
do 15 i=1,n
dg(i)=g(i)
15 continue
call dfunc(p,g)
test=0.
den=max(fret,1.)
do 16 i=1,n
temp=abs(g(i))*max(abs(p(i)),1.)/den
if(temp.gt.test)test=temp
16 continue
if(test.lt.gtol)return
do 17 i=1,n
dg(i)=g(i)-dg(i)
17 continue
do 19 i=1,n
hdg(i)=0.
do 18 j=1,n
hdg(i)=hdg(i)+hessin(i,j)*dg(j)
18 continue
19 continue
fac=0.
fae=0.
sumdg=0.
sumxi=0.
do 21 i=1,n
fac=fac+dg(i)*xi(i)
fae=fae+dg(i)*hdg(i)
sumdg=sumdg+dg(i)**2
sumxi=sumxi+xi(i)**2
21 continue
if(fac**2.gt.EPS*sumdg*sumxi)then
fac=1./fac
fad=1./fae
do 22 i=1,n
dg(i)=fac*xi(i)-fad*hdg(i)
22 continue
do 24 i=1,n
do 23 j=1,n
hessin(i,j)=hessin(i,j)+fac*xi(i)*xi(j)-fad*hdg(i)*hdg(j)+
*fae*dg(i)*dg(j)
23 continue
24 continue
endif
do 26 i=1,n
xi(i)=0.
do 25 j=1,n
xi(i)=xi(i)-hessin(i,j)*g(j)
25 continue
26 continue
27 continue
pause 'too many iterations in dfpmin'
return
END
dataassim/math/numrec/f77_sources/dfridr.for
+29
View File
@@ -0,0 +1,29 @@
FUNCTION dfridr(func,x,h,err)
INTEGER NTAB
REAL dfridr,err,h,x,func,CON,CON2,BIG,SAFE
PARAMETER (CON=1.4,CON2=CON*CON,BIG=1.E30,NTAB=10,SAFE=2.)
EXTERNAL func
CU USES func
INTEGER i,j
REAL errt,fac,hh,a(NTAB,NTAB)
if(h.eq.0.) pause 'h must be nonzero in dfridr'
hh=h
a(1,1)=(func(x+hh)-func(x-hh))/(2.0*hh)
err=BIG
do 12 i=2,NTAB
hh=hh/CON
a(1,i)=(func(x+hh)-func(x-hh))/(2.0*hh)
fac=CON2
do 11 j=2,i
a(j,i)=(a(j-1,i)*fac-a(j-1,i-1))/(fac-1.)
fac=CON2*fac
errt=max(abs(a(j,i)-a(j-1,i)),abs(a(j,i)-a(j-1,i-1)))
if (errt.le.err) then
err=errt
dfridr=a(j,i)
endif
11 continue
if(abs(a(i,i)-a(i-1,i-1)).ge.SAFE*err)return
12 continue
return
END
dataassim/math/numrec/f77_sources/dftcor.for
+55
View File
@@ -0,0 +1,55 @@
SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac)
REAL a,b,corfac,corim,corre,delta,w,endpts(8)
REAL a0i,a0r,a1i,a1r,a2i,a2r,a3i,a3r,arg,c,cl,cr,s,sl,sr,t,t2,t4,
*t6
DOUBLE PRECISION cth,ctth,spth2,sth,sth4i,stth,th,th2,th4,tmth2,
*tth4i
th=w*delta
if (a.ge.b.or.th.lt.0.d0.or.th.gt.3.1416d0)pause
*'bad arguments to dftcor'
if(abs(th).lt.5.d-2)then
t=th
t2=t*t
t4=t2*t2
t6=t4*t2
corfac=1.-(11./720.)*t4+(23./15120.)*t6
a0r=(-2./3.)+t2/45.+(103./15120.)*t4-(169./226800.)*t6
a1r=(7./24.)-(7./180.)*t2+(5./3456.)*t4-(7./259200.)*t6
a2r=(-1./6.)+t2/45.-(5./6048.)*t4+t6/64800.
a3r=(1./24.)-t2/180.+(5./24192.)*t4-t6/259200.
a0i=t*(2./45.+(2./105.)*t2-(8./2835.)*t4+(86./467775.)*t6)
a1i=t*(7./72.-t2/168.+(11./72576.)*t4-(13./5987520.)*t6)
a2i=t*(-7./90.+t2/210.-(11./90720.)*t4+(13./7484400.)*t6)
a3i=t*(7./360.-t2/840.+(11./362880.)*t4-(13./29937600.)*t6)
else
cth=cos(th)
sth=sin(th)
ctth=cth**2-sth**2
stth=2.d0*sth*cth
th2=th*th
th4=th2*th2
tmth2=3.d0-th2
spth2=6.d0+th2
sth4i=1./(6.d0*th4)
tth4i=2.d0*sth4i
corfac=tth4i*spth2*(3.d0-4.d0*cth+ctth)
a0r=sth4i*(-42.d0+5.d0*th2+spth2*(8.d0*cth-ctth))
a0i=sth4i*(th*(-12.d0+6.d0*th2)+spth2*stth)
a1r=sth4i*(14.d0*tmth2-7.d0*spth2*cth)
a1i=sth4i*(30.d0*th-5.d0*spth2*sth)
a2r=tth4i*(-4.d0*tmth2+2.d0*spth2*cth)
a2i=tth4i*(-12.d0*th+2.d0*spth2*sth)
a3r=sth4i*(2.d0*tmth2-spth2*cth)
a3i=sth4i*(6.d0*th-spth2*sth)
endif
cl=a0r*endpts(1)+a1r*endpts(2)+a2r*endpts(3)+a3r*endpts(4)
sl=a0i*endpts(1)+a1i*endpts(2)+a2i*endpts(3)+a3i*endpts(4)
cr=a0r*endpts(8)+a1r*endpts(7)+a2r*endpts(6)+a3r*endpts(5)
sr=-a0i*endpts(8)-a1i*endpts(7)-a2i*endpts(6)-a3i*endpts(5)
arg=w*(b-a)
c=cos(arg)
s=sin(arg)
corre=cl+c*cr-s*sr
corim=sl+s*cr+c*sr
return
END
dataassim/math/numrec/f77_sources/dftint.for
+48
View File
@@ -0,0 +1,48 @@
SUBROUTINE dftint(func,a,b,w,cosint,sinint)
INTEGER M,NDFT,MPOL
REAL a,b,cosint,sinint,w,func,TWOPI
PARAMETER (M=64,NDFT=1024,MPOL=6,TWOPI=2.*3.14159265)
EXTERNAL func
CU USES dftcor,func,polint,realft
INTEGER init,j,nn
REAL aold,bold,c,cdft,cerr,corfac,corim,corre,delta,en,s,sdft,
*serr,cpol(MPOL),data(NDFT),endpts(8),spol(MPOL),xpol(MPOL)
SAVE init,aold,bold,delta,data,endpts
DATA init/0/,aold/-1.e30/,bold/-1.e30/
if (init.ne.1.or.a.ne.aold.or.b.ne.bold) then
init=1
aold=a
bold=b
delta=(b-a)/M
do 11 j=1,M+1
data(j)=func(a+(j-1)*delta)
11 continue
do 12 j=M+2,NDFT
data(j)=0.
12 continue
do 13 j=1,4
endpts(j)=data(j)
endpts(j+4)=data(M-3+j)
13 continue
call realft(data,NDFT,1)
data(2)=0.
endif
en=w*delta*NDFT/TWOPI+1.
nn=min(max(int(en-0.5*MPOL+1.),1),NDFT/2-MPOL+1)
do 14 j=1,MPOL
cpol(j)=data(2*nn-1)
spol(j)=data(2*nn)
xpol(j)=nn
nn=nn+1
14 continue
call polint(xpol,cpol,MPOL,en,cdft,cerr)
call polint(xpol,spol,MPOL,en,sdft,serr)
call dftcor(w,delta,a,b,endpts,corre,corim,corfac)
cdft=cdft*corfac+corre
sdft=sdft*corfac+corim
c=delta*cos(w*a)
s=delta*sin(w*a)
cosint=c*cdft-s*sdft
sinint=s*cdft+c*sdft
return
END
dataassim/math/numrec/f77_sources/difeq.for
+57
View File
@@ -0,0 +1,57 @@
SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,ne,s,nsi,nsj,y,nyj,
*nyk)
INTEGER is1,isf,jsf,k,k1,k2,ne,nsi,nsj,nyj,nyk,indexv(nyj),M
REAL s(nsi,nsj),y(nyj,nyk)
COMMON /sfrcom/ x,h,mm,n,c2,anorm
PARAMETER (M=41)
INTEGER mm,n
REAL anorm,c2,h,temp,temp2,x(M)
if(k.eq.k1) then
if(mod(n+mm,2).eq.1)then
s(3,3+indexv(1))=1.
s(3,3+indexv(2))=0.
s(3,3+indexv(3))=0.
s(3,jsf)=y(1,1)
else
s(3,3+indexv(1))=0.
s(3,3+indexv(2))=1.
s(3,3+indexv(3))=0.
s(3,jsf)=y(2,1)
endif
else if(k.gt.k2) then
s(1,3+indexv(1))=-(y(3,M)-c2)/(2.*(mm+1.))
s(1,3+indexv(2))=1.
s(1,3+indexv(3))=-y(1,M)/(2.*(mm+1.))
s(1,jsf)=y(2,M)-(y(3,M)-c2)*y(1,M)/(2.*(mm+1.))
s(2,3+indexv(1))=1.
s(2,3+indexv(2))=0.
s(2,3+indexv(3))=0.
s(2,jsf)=y(1,M)-anorm
else
s(1,indexv(1))=-1.
s(1,indexv(2))=-.5*h
s(1,indexv(3))=0.
s(1,3+indexv(1))=1.
s(1,3+indexv(2))=-.5*h
s(1,3+indexv(3))=0.
temp=h/(1.-(x(k)+x(k-1))**2*.25)
temp2=.5*(y(3,k)+y(3,k-1))-c2*.25*(x(k)+x(k-1))**2
s(2,indexv(1))=temp*temp2*.5
s(2,indexv(2))=-1.-.5*temp*(mm+1.)*(x(k)+x(k-1))
s(2,indexv(3))=.25*temp*(y(1,k)+y(1,k-1))
s(2,3+indexv(1))=s(2,indexv(1))
s(2,3+indexv(2))=2.+s(2,indexv(2))
s(2,3+indexv(3))=s(2,indexv(3))
s(3,indexv(1))=0.
s(3,indexv(2))=0.
s(3,indexv(3))=-1.
s(3,3+indexv(1))=0.
s(3,3+indexv(2))=0.
s(3,3+indexv(3))=1.
s(1,jsf)=y(1,k)-y(1,k-1)-.5*h*(y(2,k)+y(2,k-1))
s(2,jsf)=y(2,k)-y(2,k-1)-temp*((x(k)+x(k-1))*.5*(mm+1.)*(y(2,k)+
*y(2,k-1))-temp2*.5*(y(1,k)+y(1,k-1)))
s(3,jsf)=y(3,k)-y(3,k-1)
endif
return
END
dataassim/math/numrec/f77_sources/dpythag.for
+16
View File
@@ -0,0 +1,16 @@
FUNCTION dpythag(a,b)
DOUBLE PRECISION a,b,dpythag
DOUBLE PRECISION absa,absb
absa=abs(a)
absb=abs(b)
if(absa.gt.absb)then
dpythag=absa*sqrt(1.0d0+(absb/absa)**2)
else
if(absb.eq.0.0d0)then
dpythag=0.0d0
else
dpythag=absb*sqrt(1.0d0+(absa/absb)**2)
endif
endif
return
END
dataassim/math/numrec/f77_sources/drealft.for
+52
View File
@@ -0,0 +1,52 @@
SUBROUTINE drealft(data,n,isign)
INTEGER isign,n
DOUBLE PRECISION data(n)
CU USES dfour1
INTEGER i,i1,i2,i3,i4,n2p3
DOUBLE PRECISION c1,c2,h1i,h1r,h2i,h2r,wis,wrs
DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
theta=3.141592653589793d0/dble(n/2)
c1=0.5d0
if (isign.eq.1) then
c2=-0.5d0
call dfour1(data,n/2,+1)
else
c2=0.5d0
theta=-theta
endif
wpr=-2.0d0*sin(0.5d0*theta)**2
wpi=sin(theta)
wr=1.0d0+wpr
wi=wpi
n2p3=n+3
do 11 i=2,n/4
i1=2*i-1
i2=i1+1
i3=n2p3-i2
i4=i3+1
wrs=wr
wis=wi
h1r=c1*(data(i1)+data(i3))
h1i=c1*(data(i2)-data(i4))
h2r=-c2*(data(i2)+data(i4))
h2i=c2*(data(i1)-data(i3))
data(i1)=h1r+wrs*h2r-wis*h2i
data(i2)=h1i+wrs*h2i+wis*h2r
data(i3)=h1r-wrs*h2r+wis*h2i
data(i4)=-h1i+wrs*h2i+wis*h2r
wtemp=wr
wr=wr*wpr-wi*wpi+wr
wi=wi*wpr+wtemp*wpi+wi
11 continue
if (isign.eq.1) then
h1r=data(1)
data(1)=h1r+data(2)
data(2)=h1r-data(2)
else
h1r=data(1)
data(1)=c1*(h1r+data(2))
data(2)=c1*(h1r-data(2))
call dfour1(data,n/2,-1)
endif
return
END
dataassim/math/numrec/f77_sources/dsprsax.for
+13
View File
@@ -0,0 +1,13 @@
SUBROUTINE dsprsax(sa,ija,x,b,n)
INTEGER n,ija(*)
DOUBLE PRECISION b(n),sa(*),x(n)
INTEGER i,k
if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprsax'
do 12 i=1,n
b(i)=sa(i)*x(i)
do 11 k=ija(i),ija(i+1)-1
b(i)=b(i)+sa(k)*x(ija(k))
11 continue
12 continue
return
END
dataassim/math/numrec/f77_sources/dsprstx.for
+16
View File
@@ -0,0 +1,16 @@
SUBROUTINE dsprstx(sa,ija,x,b,n)
INTEGER n,ija(*)
DOUBLE PRECISION b(n),sa(*),x(n)
INTEGER i,j,k
if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprstx'
do 11 i=1,n
b(i)=sa(i)*x(i)
11 continue
do 13 i=1,n
do 12 k=ija(i),ija(i+1)-1
j=ija(k)
b(j)=b(j)+sa(k)*x(i)
12 continue
13 continue
return
END
dataassim/math/numrec/f77_sources/dsvbksb.for
+25
View File
@@ -0,0 +1,25 @@
SUBROUTINE dsvbksb(u,w,v,m,n,mp,np,b,x)
INTEGER m,mp,n,np,NMAX
DOUBLE PRECISION b(mp),u(mp,np),v(np,np),w(np),x(np)
PARAMETER (NMAX=500)
INTEGER i,j,jj
DOUBLE PRECISION s,tmp(NMAX)
do 12 j=1,n
s=0.0d0
if(w(j).ne.0.0d0)then
do 11 i=1,m
s=s+u(i,j)*b(i)
11 continue
s=s/w(j)
endif
tmp(j)=s
12 continue
do 14 j=1,n
s=0.0d0
do 13 jj=1,n
s=s+v(j,jj)*tmp(jj)
13 continue
x(j)=s
14 continue
return
END
dataassim/math/numrec/f77_sources/dsvdcmp.for
+224
View File
@@ -0,0 +1,224 @@
SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v)
INTEGER m,mp,n,np,NMAX
DOUBLE PRECISION a(mp,np),v(np,np),w(np)
PARAMETER (NMAX=500)
CU USES dpythag
INTEGER i,its,j,jj,k,l,nm
DOUBLE PRECISION anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX),dpythag
g=0.0d0
scale=0.0d0
anorm=0.0d0
do 25 i=1,n
l=i+1
rv1(i)=scale*g
g=0.0d0
s=0.0d0
scale=0.0d0
if(i.le.m)then
do 11 k=i,m
scale=scale+abs(a(k,i))
11 continue
if(scale.ne.0.0d0)then
do 12 k=i,m
a(k,i)=a(k,i)/scale
s=s+a(k,i)*a(k,i)
12 continue
f=a(i,i)
g=-sign(sqrt(s),f)
h=f*g-s
a(i,i)=f-g
do 15 j=l,n
s=0.0d0
do 13 k=i,m
s=s+a(k,i)*a(k,j)
13 continue
f=s/h
do 14 k=i,m
a(k,j)=a(k,j)+f*a(k,i)
14 continue
15 continue
do 16 k=i,m
a(k,i)=scale*a(k,i)
16 continue
endif
endif
w(i)=scale *g
g=0.0d0
s=0.0d0
scale=0.0d0
if((i.le.m).and.(i.ne.n))then
do 17 k=l,n
scale=scale+abs(a(i,k))
17 continue
if(scale.ne.0.0d0)then
do 18 k=l,n
a(i,k)=a(i,k)/scale
s=s+a(i,k)*a(i,k)
18 continue
f=a(i,l)
g=-sign(sqrt(s),f)
h=f*g-s
a(i,l)=f-g
do 19 k=l,n
rv1(k)=a(i,k)/h
19 continue
do 23 j=l,m
s=0.0d0
do 21 k=l,n
s=s+a(j,k)*a(i,k)
21 continue
do 22 k=l,n
a(j,k)=a(j,k)+s*rv1(k)
22 continue
23 continue
do 24 k=l,n
a(i,k)=scale*a(i,k)
24 continue
endif
endif
anorm=max(anorm,(abs(w(i))+abs(rv1(i))))
25 continue
do 32 i=n,1,-1
if(i.lt.n)then
if(g.ne.0.0d0)then
do 26 j=l,n
v(j,i)=(a(i,j)/a(i,l))/g
26 continue
do 29 j=l,n
s=0.0d0
do 27 k=l,n
s=s+a(i,k)*v(k,j)
27 continue
do 28 k=l,n
v(k,j)=v(k,j)+s*v(k,i)
28 continue
29 continue
endif
do 31 j=l,n
v(i,j)=0.0d0
v(j,i)=0.0d0
31 continue
endif
v(i,i)=1.0d0
g=rv1(i)
l=i
32 continue
do 39 i=min(m,n),1,-1
l=i+1
g=w(i)
do 33 j=l,n
a(i,j)=0.0d0
33 continue
if(g.ne.0.0d0)then
g=1.0d0/g
do 36 j=l,n
s=0.0d0
do 34 k=l,m
s=s+a(k,i)*a(k,j)
34 continue
f=(s/a(i,i))*g
do 35 k=i,m
a(k,j)=a(k,j)+f*a(k,i)
35 continue
36 continue
do 37 j=i,m
a(j,i)=a(j,i)*g
37 continue
else
do 38 j= i,m
a(j,i)=0.0d0
38 continue
endif
a(i,i)=a(i,i)+1.0d0
39 continue
do 49 k=n,1,-1
do 48 its=1,30
do 41 l=k,1,-1
nm=l-1
if((abs(rv1(l))+anorm).eq.anorm) goto 2
if((abs(w(nm))+anorm).eq.anorm) goto 1
41 continue
1 c=0.0d0
s=1.0d0
do 43 i=l,k
f=s*rv1(i)
rv1(i)=c*rv1(i)
if((abs(f)+anorm).eq.anorm) goto 2
g=w(i)
h=dpythag(f,g)
w(i)=h
h=1.0d0/h
c= (g*h)
s=-(f*h)
do 42 j=1,m
y=a(j,nm)
z=a(j,i)
a(j,nm)=(y*c)+(z*s)
a(j,i)=-(y*s)+(z*c)
42 continue
43 continue
2 z=w(k)
if(l.eq.k)then
if(z.lt.0.0d0)then
w(k)=-z
do 44 j=1,n
v(j,k)=-v(j,k)
44 continue
endif
goto 3
endif
if(its.eq.30) pause 'no convergence in svdcmp'
x=w(l)
nm=k-1
y=w(nm)
g=rv1(nm)
h=rv1(k)
f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y)
g=dpythag(f,1.0d0)
f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
c=1.0d0
s=1.0d0
do 47 j=l,nm
i=j+1
g=rv1(i)
y=w(i)
h=s*g
g=c*g
z=dpythag(f,h)
rv1(j)=z
c=f/z
s=h/z
f= (x*c)+(g*s)
g=-(x*s)+(g*c)
h=y*s
y=y*c
do 45 jj=1,n
x=v(jj,j)
z=v(jj,i)
v(jj,j)= (x*c)+(z*s)
v(jj,i)=-(x*s)+(z*c)
45 continue
z=dpythag(f,h)
w(j)=z
if(z.ne.0.0d0)then
z=1.0d0/z
c=f*z
s=h*z
endif
f= (c*g)+(s*y)
x=-(s*g)+(c*y)
do 46 jj=1,m
y=a(jj,j)
z=a(jj,i)
a(jj,j)= (y*c)+(z*s)
a(jj,i)=-(y*s)+(z*c)
46 continue
47 continue
rv1(l)=0.0d0
rv1(k)=f
w(k)=x
48 continue
3 continue
49 continue
return
END
dataassim/math/numrec/f77_sources/eclass.for
+27
View File
@@ -0,0 +1,27 @@
SUBROUTINE eclass(nf,n,lista,listb,m)
INTEGER m,n,lista(m),listb(m),nf(n)
INTEGER j,k,l
do 11 k=1,n
nf(k)=k
11 continue
do 12 l=1,m
j=lista(l)
1 if(nf(j).ne.j)then
j=nf(j)
goto 1
endif
k=listb(l)
2 if(nf(k).ne.k)then
k=nf(k)
goto 2
endif
if(j.ne.k)nf(j)=k
12 continue
do 13 j=1,n
3 if(nf(j).ne.nf(nf(j)))then
nf(j)=nf(nf(j))
goto 3
endif
13 continue
return
END
dataassim/math/numrec/f77_sources/eclazz.for
+18
View File
@@ -0,0 +1,18 @@
SUBROUTINE eclazz(nf,n,equiv)
INTEGER n,nf(n)
LOGICAL equiv
EXTERNAL equiv
INTEGER jj,kk
nf(1)=1
do 12 jj=2,n
nf(jj)=jj
do 11 kk=1,jj-1
nf(kk)=nf(nf(kk))
if (equiv(jj,kk)) nf(nf(nf(kk)))=jj
11 continue
12 continue
do 13 jj=1,n
nf(jj)=nf(nf(jj))
13 continue
return
END
dataassim/math/numrec/f77_sources/ei.for
+38
View File
@@ -0,0 +1,38 @@
FUNCTION ei(x)
INTEGER MAXIT
REAL ei,x,EPS,EULER,FPMIN
PARAMETER (EPS=6.e-8,EULER=.57721566,MAXIT=100,FPMIN=1.e-30)
INTEGER k
REAL fact,prev,sum,term
if(x.le.0.) pause 'bad argument in ei'
if(x.lt.FPMIN)then
ei=log(x)+EULER
else if(x.le.-log(EPS))then
sum=0.
fact=1.
do 11 k=1,MAXIT
fact=fact*x/k
term=fact/k
sum=sum+term
if(term.lt.EPS*sum)goto 1
11 continue
pause 'series failed in ei'
1 ei=sum+log(x)+EULER
else
sum=0.
term=1.
do 12 k=1,MAXIT
prev=term
term=term*k/x
if(term.lt.EPS)goto 2
if(term.lt.prev)then
sum=sum+term
else
sum=sum-prev
goto 2
endif
12 continue
2 ei=exp(x)*(1.+sum)/x
endif
return
END
dataassim/math/numrec/f77_sources/eigsrt.for
+26
View File
@@ -0,0 +1,26 @@
SUBROUTINE eigsrt(d,v,n,np)
INTEGER n,np
REAL d(np),v(np,np)
INTEGER i,j,k
REAL p
do 13 i=1,n-1
k=i
p=d(i)
do 11 j=i+1,n
if(d(j).ge.p)then
k=j
p=d(j)
endif
11 continue
if(k.ne.i)then
d(k)=d(i)
d(i)=p
do 12 j=1,n
p=v(j,i)
v(j,i)=v(j,k)
v(j,k)=p
12 continue
endif
13 continue
return
END
dataassim/math/numrec/f77_sources/elle.for
+10
View File
@@ -0,0 +1,10 @@
FUNCTION elle(phi,ak)
REAL elle,ak,phi
CU USES rd,rf
REAL cc,q,s,rd,rf
s=sin(phi)
cc=cos(phi)**2
q=(1.-s*ak)*(1.+s*ak)
elle=s*(rf(cc,q,1.)-((s*ak)**2)*rd(cc,q,1.)/3.)
return
END
dataassim/math/numrec/f77_sources/ellf.for
+8
View File
@@ -0,0 +1,8 @@
FUNCTION ellf(phi,ak)
REAL ellf,ak,phi
CU USES rf
REAL s,rf
s=sin(phi)
ellf=s*rf(cos(phi)**2,(1.-s*ak)*(1.+s*ak),1.)
return
END
dataassim/math/numrec/f77_sources/ellpi.for
+11
View File
@@ -0,0 +1,11 @@
FUNCTION ellpi(phi,en,ak)
REAL ellpi,ak,en,phi
CU USES rf,rj
REAL cc,enss,q,s,rf,rj
s=sin(phi)
enss=en*s*s
cc=cos(phi)**2
q=(1.-s*ak)*(1.+s*ak)
ellpi=s*(rf(cc,q,1.)-enss*rj(cc,q,1.,1.+enss)/3.)
return
END
dataassim/math/numrec/f77_sources/elmhes.for
+44
View File
@@ -0,0 +1,44 @@
SUBROUTINE elmhes(a,n,np)
INTEGER n,np
REAL a(np,np)
INTEGER i,j,m
REAL x,y
do 17 m=2,n-1
x=0.
i=m
do 11 j=m,n
if(abs(a(j,m-1)).gt.abs(x))then
x=a(j,m-1)
i=j
endif
11 continue
if(i.ne.m)then
do 12 j=m-1,n
y=a(i,j)
a(i,j)=a(m,j)
a(m,j)=y
12 continue
do 13 j=1,n
y=a(j,i)
a(j,i)=a(j,m)
a(j,m)=y
13 continue
endif
if(x.ne.0.)then
do 16 i=m+1,n
y=a(i,m-1)
if(y.ne.0.)then
y=y/x
a(i,m-1)=y
do 14 j=m,n
a(i,j)=a(i,j)-y*a(m,j)
14 continue
do 15 j=1,n
a(j,m)=a(j,m)+y*a(j,i)
15 continue
endif
16 continue
endif
17 continue
return
END
dataassim/math/numrec/f77_sources/erf.for
+11
View File
@@ -0,0 +1,11 @@
FUNCTION erf(x)
REAL erf,x
CU USES gammp
REAL gammp
if(x.lt.0.)then
erf=-gammp(.5,x**2)
else
erf=gammp(.5,x**2)
endif
return
END
dataassim/math/numrec/f77_sources/erfc.for
+11
View File
@@ -0,0 +1,11 @@
FUNCTION erfc(x)
REAL erfc,x
CU USES gammp,gammq
REAL gammp,gammq
if(x.lt.0.)then
erfc=1.+gammp(.5,x**2)
else
erfc=gammq(.5,x**2)
endif
return
END
dataassim/math/numrec/f77_sources/erfcc.for
+11
View File
@@ -0,0 +1,11 @@
FUNCTION erfcc(x)
REAL erfcc,x
REAL t,z
z=abs(x)
t=1./(1.+0.5*z)
erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+t*
*(.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+t*
*(1.48851587+t*(-.82215223+t*.17087277)))))))))
if (x.lt.0.) erfcc=2.-erfcc
return
END
dataassim/math/numrec/f77_sources/eulsum.for
+28
View File
@@ -0,0 +1,28 @@
SUBROUTINE eulsum(sum,term,jterm,wksp)
INTEGER jterm
REAL sum,term,wksp(jterm)
INTEGER j,nterm
REAL dum,tmp
SAVE nterm
if(jterm.eq.1)then
nterm=1
wksp(1)=term
sum=0.5*term
else
tmp=wksp(1)
wksp(1)=term
do 11 j=1,nterm-1
dum=wksp(j+1)
wksp(j+1)=0.5*(wksp(j)+tmp)
tmp=dum
11 continue
wksp(nterm+1)=0.5*(wksp(nterm)+tmp)
if(abs(wksp(nterm+1)).le.abs(wksp(nterm)))then
sum=sum+0.5*wksp(nterm+1)
nterm=nterm+1
else
sum=sum+wksp(nterm+1)
endif
endif
return
END
dataassim/math/numrec/f77_sources/evlmem.for
+23
View File
@@ -0,0 +1,23 @@
FUNCTION evlmem(fdt,d,m,xms)
INTEGER m
REAL evlmem,fdt,xms,d(m)
INTEGER i
REAL sumi,sumr
DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
theta=6.28318530717959d0*fdt
wpr=cos(theta)
wpi=sin(theta)
wr=1.d0
wi=0.d0
sumr=1.
sumi=0.
do 11 i=1,m
wtemp=wr
wr=wr*wpr-wi*wpi
wi=wi*wpr+wtemp*wpi
sumr=sumr-d(i)*sngl(wr)
sumi=sumi-d(i)*sngl(wi)
11 continue
evlmem=xms/(sumr**2+sumi**2)
return
END
dataassim/math/numrec/f77_sources/expdev.for
+10
View File
@@ -0,0 +1,10 @@
FUNCTION expdev(idum)
INTEGER idum
REAL expdev
CU USES ran1
REAL dum,ran1
1 dum=ran1(idum)
if(dum.eq.0.)goto 1
expdev=-log(dum)
return
END
dataassim/math/numrec/f77_sources/expint.for
+56
View File
@@ -0,0 +1,56 @@
FUNCTION expint(n,x)
INTEGER n,MAXIT
REAL expint,x,EPS,FPMIN,EULER
PARAMETER (MAXIT=100,EPS=1.e-7,FPMIN=1.e-30,EULER=.5772156649)
INTEGER i,ii,nm1
REAL a,b,c,d,del,fact,h,psi
nm1=n-1
if(n.lt.0.or.x.lt.0..or.(x.eq.0..and.(n.eq.0.or.n.eq.1)))then
pause 'bad arguments in expint'
else if(n.eq.0)then
expint=exp(-x)/x
else if(x.eq.0.)then
expint=1./nm1
else if(x.gt.1.)then
b=x+n
c=1./FPMIN
d=1./b
h=d
do 11 i=1,MAXIT
a=-i*(nm1+i)
b=b+2.
d=1./(a*d+b)
c=b+a/c
del=c*d
h=h*del
if(abs(del-1.).lt.EPS)then
expint=h*exp(-x)
return
endif
11 continue
pause 'continued fraction failed in expint'
else
if(nm1.ne.0)then
expint=1./nm1
else
expint=-log(x)-EULER
endif
fact=1.
do 13 i=1,MAXIT
fact=-fact*x/i
if(i.ne.nm1)then
del=-fact/(i-nm1)
else
psi=-EULER
do 12 ii=1,nm1
psi=psi+1./ii
12 continue
del=fact*(-log(x)+psi)
endif
expint=expint+del
if(abs(del).lt.abs(expint)*EPS) return
13 continue
pause 'series failed in expint'
endif
return
END

Some files were not shown because too many files have changed in this diff Show More