New changes from l2g
w
This commit is contained in:
@@ -0,0 +1,39 @@
|
||||
SUBROUTINE svdfit(x,y,sig,ndata,a,ma,u,v,w,mp,np,chisq,funcs)
|
||||
INTEGER ma,mp,ndata,np,NMAX,MMAX
|
||||
double precision chisq,a(ma),sig(ndata),u(mp,np),v(np,np),w(np),
|
||||
*x(ndata),y(ndata),TOL
|
||||
c mp>=ndata, np>=ma. ma is the number of coefficients
|
||||
EXTERNAL funcs
|
||||
PARAMETER (NMAX=1000,MMAX=50,TOL=1.0d-10)
|
||||
CU USES svbksb,svdcmp
|
||||
INTEGER i,j
|
||||
double precision sumup,thresh,tmp,wmax,afunc(MMAX),b(NMAX)
|
||||
do 12 i=1,ndata
|
||||
call funcs(x(i),afunc,ma,i)
|
||||
tmp=1.0d0/sig(i)
|
||||
do 11 j=1,ma
|
||||
u(i,j)=afunc(j)*tmp
|
||||
11 continue
|
||||
b(i)=y(i)*tmp
|
||||
12 continue
|
||||
call svdcmp(u,ndata,ma,mp,np,w,v)
|
||||
wmax=0.0d0
|
||||
do 13 j=1,ma
|
||||
if(w(j).gt.wmax)wmax=w(j)
|
||||
13 continue
|
||||
thresh=TOL*wmax
|
||||
do 14 j=1,ma
|
||||
if(w(j).lt.thresh)w(j)=0.0d0
|
||||
14 continue
|
||||
call svbksb(u,w,v,ndata,ma,mp,np,b,a)
|
||||
chisq=0.0d0
|
||||
do 16 i=1,ndata
|
||||
call funcs(x(i),afunc,ma,i)
|
||||
sumup=0.0d0
|
||||
do 15 j=1,ma
|
||||
sumup=sumup+a(j)*afunc(j)
|
||||
15 continue
|
||||
chisq=chisq+((y(i)-sumup)/sig(i))**2
|
||||
16 continue
|
||||
return
|
||||
END
|
||||
@@ -0,0 +1,22 @@
|
||||
SUBROUTINE svdvar(v,ma,np,w,cvm,ncvm)
|
||||
INTEGER ma,ncvm,np,MMAX
|
||||
double precision cvm(ncvm,ncvm),v(np,np),w(np)
|
||||
PARAMETER (MMAX=20)
|
||||
INTEGER i,j,k
|
||||
double precision sumup,wti(MMAX)
|
||||
do 11 i=1,ma
|
||||
wti(i)=0.
|
||||
if(w(i).ne.0.) wti(i)=1./(w(i)*w(i))
|
||||
11 continue
|
||||
do 14 i=1,ma
|
||||
do 13 j=1,i
|
||||
sumup=0.0d0
|
||||
do 12 k=1,ma
|
||||
sumup=sumup+v(i,k)*v(j,k)*wti(k)
|
||||
12 continue
|
||||
cvm(i,j)=sumup
|
||||
cvm(j,i)=sumup
|
||||
13 continue
|
||||
14 continue
|
||||
return
|
||||
END
|
||||
@@ -0,0 +1,111 @@
|
||||
SUBROUTINE EIGEN(NM,N,A,WR,WI,Z)
|
||||
COMMON/CSTAK/DSTAK(500)
|
||||
C
|
||||
REAL A(NM,N),WR(N),WI(N),Z(NM,N)
|
||||
REAL RSTAK(1000)
|
||||
C
|
||||
EQUIVALENCE (DSTAK(1),RSTAK(1))
|
||||
C
|
||||
C EIGEN FINDS THE EIGENVALUES AND EIGENVECTORS
|
||||
C OF A REAL MATRIX (NOT IMAGINARY) BY
|
||||
C CALLING THE SEQUENCE OF SUBROUTINES
|
||||
C ORTHE,ORTRA, AND HQR2, WHICH, IN TURN, ARE
|
||||
C THE EISPACK ROUTINES ORTHES, ORTRAN, AND HQR2,
|
||||
C ADJUSTED FOR USE IN THE PORT LIBRARY.
|
||||
C
|
||||
C ON INPUT -
|
||||
C
|
||||
C NM - AN INTEGER INPUT VARIABLE SET EQUAL TO
|
||||
C THE ROW DIMENSION OF THE TWO-DIMENSIONAL ARRAYS
|
||||
C A AND Z AS SPECIFIED IN THE DIMENSION STATEMENTS
|
||||
C FOR A AND Z IN THE CALLING PROGRAM.
|
||||
C
|
||||
C N - AN INTEGER INPUT VARIABLE SET EQUAL TO THE
|
||||
C ORDER OF THE MATRIX A.
|
||||
C
|
||||
C N MUST NOT BE GREATER THAN NM.
|
||||
C
|
||||
C A - THE MATRIX, A REAL TWO-DIMENSIONAL
|
||||
C ARRAY WITH ROW DIMENSION NM AND COLUMN
|
||||
C DIMENSION AT LEAST N.
|
||||
C
|
||||
C A IS OVERWRITTEN.
|
||||
C
|
||||
C
|
||||
C
|
||||
C ON OUTPUT -
|
||||
C
|
||||
C WR - A REAL ARRAY OF DIMENSION
|
||||
C AT LEAST N CONTAINING THE REAL PARTS OF THE EIGENVALUES
|
||||
C
|
||||
C WI - A REAL ARRAY OF DIMENSION
|
||||
C AT LEAST N CONTAINING THE IMAGINARY PARTS OF THE EIGENVALUES.
|
||||
C
|
||||
C THE EIGENVALUES ARE UNORDERED EXCEPT THAT
|
||||
C COMPLEX CONJUGATE PAIRS OF EIGENVALUES
|
||||
C APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING
|
||||
C THE POSITIVE IMAGINARY PART FIRST.
|
||||
C
|
||||
C Z - A REAL TWO-DIMENSIONAL ARRAY
|
||||
C WITH ROW DIMENSION NM AND COLUMN DIMENSION
|
||||
C AT LEAST N CONTAINING THE REAL AND IMAGINARY PARTS
|
||||
C OF THE EIGENVECTORS.
|
||||
C
|
||||
C IF THE J-TH EIGENVALUE IS REAL, THE J-TH
|
||||
C COLUMN OF Z CONTAINS ITS EIGENVECTOR.
|
||||
C
|
||||
C IF THE J-TH EIGENVALUE IS COMPLEX WITH
|
||||
C POSITIVE REAL PART, THE J-TH AND (J+1)-TH
|
||||
C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY
|
||||
C PARTS OF ITS EIGENVECTOR.
|
||||
C
|
||||
C THE CONJUGATE OF THIS VECTOR IS THE
|
||||
C EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
|
||||
C THE EIGENVECTORS ARE NOT NORMALIZED.
|
||||
C
|
||||
C
|
||||
C ERROR STATES -
|
||||
C
|
||||
C 1 - N IS GREATER THAN NM
|
||||
C
|
||||
C K - THE K-TH EIGENVALUE COULD NOT BE COMPUTED
|
||||
C WITHIN 30 ITERATIONS.
|
||||
C
|
||||
C THE EIGENVALUES IN THE WR AND WRI ARRAYS
|
||||
C SHOULD BE CORRECT FOR INDICES
|
||||
C K+1, K+2,...,N, BUT NO EIGENVECTORS ARE COMPUTED.
|
||||
C
|
||||
C
|
||||
C
|
||||
C
|
||||
C CHECK FOR INPUT ERROR IN N
|
||||
C
|
||||
C/6S
|
||||
C IF (N .GT. NM) CALL SETERR(
|
||||
C 1 29H EIGEN - N IS GREATER THAN NM,29,1,2)
|
||||
C/7S
|
||||
IF (N .GT. NM) CALL SETERR(
|
||||
1 ' EIGEN - N IS GREATER THAN NM',29,1,2)
|
||||
C/
|
||||
C
|
||||
C ALLOCATE A SCRATCH VECTOR
|
||||
IORT = ISTKGT(N,3)
|
||||
C
|
||||
CALL ORTHE (NM,N,1,N,A,RSTAK(IORT))
|
||||
CALL ORTRA (NM,N,1,N,A,RSTAK(IORT),Z)
|
||||
CALL HQR2 (NM,N,1,N,A,WR,WI,Z,IERR)
|
||||
C
|
||||
IF (IERR .NE. 0) GO TO 10
|
||||
CALL ISTKRL(1)
|
||||
RETURN
|
||||
C/6S
|
||||
C 10 CALL SETERR(
|
||||
C 1 34H EIGEN - FAILED ON THAT EIGENVALUE,34,IERR,1)
|
||||
C/7S
|
||||
10 CALL SETERR(
|
||||
1 ' EIGEN - FAILED ON THAT EIGENVALUE',34,IERR,1)
|
||||
C/
|
||||
C
|
||||
CALL ISTKRL(1)
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,205 @@
|
||||
SUBROUTINE EIGEN (NVEC,NA,N,A,EVR,EVI,VECS,SCR1,SCR2,IERR)
|
||||
INTEGER NVEC,NA,N,IERR
|
||||
DOUBLE PRECISION A(NA,N),EVR(N),EVI(N),VECS(NA,N),SCR1(N),SCR2(N)
|
||||
C
|
||||
C ***** PURPOSE:
|
||||
C THIS SUBROUTINE COMPUTES THE EIGENVALUES AND EIGENVECTORS
|
||||
C (IF DESIRED) OF A REAL GENERAL MATRIX A BY THE DOUBLE FRANCIS
|
||||
C QR ALGORITHM AS IMPLEMENTED IN EISPACK.
|
||||
C REFERENCE: SMITH, B.T., ET. AL., MATRIX EIGENSYSTEM ROUTINES--
|
||||
C EISPACK GUIDE, SECOND EDITION, LECTURE NOTES IN
|
||||
C COMPUTER SCIENCE, VOL. 6, SPRINGER-VERLAG, 1976.
|
||||
C
|
||||
C ON ENTRY:
|
||||
C
|
||||
C NVEC INTEGER
|
||||
C SET = 0 IF NO EIGENVECTORS ARE DESIRED, I.E., TO
|
||||
C COMPUTE EIGENVALUES ONLY; OTHERWISE SET TO ANY
|
||||
C NONZERO INTEGER IF BOTH EIGENVALUES AND EIGENVECTORS
|
||||
C ARE DESIRED.
|
||||
C
|
||||
C NA INTEGER
|
||||
C ROW DIMENSION OF THE ARRAYS CONTAINING A AND VECS
|
||||
C AS DECLARED IN THE MAIN CALLING PROGRAM.
|
||||
C
|
||||
C N INTEGER
|
||||
C THE ORDER OF THE MATRIX A.
|
||||
C
|
||||
C A DOUBLE PRECISION(NA,N)
|
||||
C A REAL GENERAL MATRIX WHOSE EIGENVALUES AND EIGEN-
|
||||
C VECTORS (IF DESIRED) ARE TO BE COMPUTED.
|
||||
C
|
||||
C ON RETURN:
|
||||
C
|
||||
C EVR DOUBLE PRECISION(N)
|
||||
C THE REAL PARTS OF THE EIGENVALUES OF A.
|
||||
C
|
||||
C EVI DOUBLE PRECISION(N)
|
||||
C THE CORRESPONDING IMAGINARY PARTS OF THE EIGENVALUES
|
||||
C OF A. NOTE THAT COMPLEX CONJUGATE PAIRS OF EIGENVALUES
|
||||
C APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING THE
|
||||
C POSITIVE IMAGINARY PART FIRST.
|
||||
C
|
||||
C VECS DOUBLE PRECISION(NA,N)
|
||||
C IF NVEC IS NONZERO, THIS ARRAY CONTAINS THE REAL AND
|
||||
C IMAGINARY PARTS OF THE EIGENVECTORS OF A. IF THE J-TH
|
||||
C EIGENVALUE IS REAL, THE J-TH COLUMN OF VECS CONTAINS
|
||||
C THE CORRESPONDING EIGENVECTOR (NORMALIZED TO HAVE
|
||||
C EUCLIDEAN OR 2- NORM = 1 AND POSITIVE MAXIMUM COMP-
|
||||
C ONENT). IF THE J-THE EIGENVALUE IS COMPLEX WITH
|
||||
C POSITIVE IMAGINARY PART, THE J-TH AND (J+1)-TH
|
||||
C COLUMNS OF VECS CONTAIN THE REAL AND IMAGINARY
|
||||
C PARTS OF THE CORRESPONDING COMPLEX EIGENVECTOR
|
||||
C (NORMALIZED TO HAVE COMPLEX EUCLIDEAN OR 2- NORM
|
||||
C =1 AND REAL, POSITIVE MAXIMUM COMPONENT). THE CONJ-
|
||||
C UGATE OF THIS VECTOR IS THE EIGENVECTOR FOR THE
|
||||
C CONJUGATE EIGENVALUE.
|
||||
C
|
||||
C SCR1 DOUBLE PRECISION(N)
|
||||
C THE I-TH COMPONENT OF THIS VECTOR CONTAINS THE
|
||||
C UNDAMPED NATURAL FREQUENCY (MODULUS) OF THE I-TH
|
||||
C EIGENVALUE; SCR1 IS ALSO USED INTERNALLY
|
||||
C AS A SCRATCH VECTOR FOR THE EISPACK SUBROUTINE
|
||||
C BALANC.
|
||||
C
|
||||
C SCR2 DOUBLE PRECISION(N)
|
||||
C THE I-TH COMPONENT OF THIS VECTOR CONTAINS THE
|
||||
C DAMPING RATIO OF THE I-TH EIGENVALUE; SCR2 IS ALSO
|
||||
C USED INTERNALLY AS A SCRATCH VECTOR FOR THE
|
||||
C EISPACK SUBROUTINE ORTHES.
|
||||
C
|
||||
C IERR INTEGER
|
||||
C ERROR COMPLETION CODE RETURNED BY EISPACK SUBROUTINE
|
||||
C HQR OR HQR2. NORMAL RETURN VALUE IS ZERO. SEE THE
|
||||
C EISPACK GUIDE, P. 331, FOR A DISCUSSION OF NONZERO
|
||||
C VALUES OF IERR.
|
||||
C
|
||||
C PROGRAM WRITTEN BY ALAN J. LAUB, DEP'T. OF ELEC. AND COMP.ENGRG.,
|
||||
C UNIVERSITY OF CALIFORNIA, SANTA BARBARA, CA 93106,
|
||||
C PH.: (805) 961-3616.
|
||||
C JUNE 1981.
|
||||
C MOST RECENT MODIFICATION: JAN. 2, 1985
|
||||
C
|
||||
C INTERNAL VARIABLES:
|
||||
C
|
||||
INTEGER I,IGH,J,JM1,K,LOW
|
||||
DOUBLE PRECISION ANORM,EI,EPS,EPSP1,ER,T,TIM,TRE,T1,T2
|
||||
C
|
||||
C FORTRAN FUNCTIONS CALLED:
|
||||
C
|
||||
DOUBLE PRECISION DABS,DSQRT
|
||||
C
|
||||
C SUBROUTINES AND FUNCTIONS CALLED:
|
||||
C
|
||||
C BALANC,BALBAK,HQR,HQR2,ORTHES,ORTRAN (ALL FROM EISPACK)
|
||||
C
|
||||
C ------------------------------------------------------------------
|
||||
C
|
||||
C DETERMINE MACHINE PRECISION
|
||||
C
|
||||
EPS = 1.0D0
|
||||
10 CONTINUE
|
||||
EPS = EPS/2.0D0
|
||||
EPSP1 = EPS+1.0D0
|
||||
IF (EPSP1 .GT. 1.0D0) GO TO 10
|
||||
EPS = 2.0D0*EPS
|
||||
C
|
||||
C BALANCE A
|
||||
C
|
||||
CALL BALANC (NA,N,A,LOW,IGH,SCR1)
|
||||
C
|
||||
C COMPUTE 1-NORM OF THE BALANCED A
|
||||
C
|
||||
ANORM = 0.0D0
|
||||
DO 30 J = 1,N
|
||||
T = 0.0D0
|
||||
DO 20 I = 1,N
|
||||
T = T+DABS(A(I,J))
|
||||
20 CONTINUE
|
||||
IF (T .GT. ANORM) ANORM = T
|
||||
30 CONTINUE
|
||||
C
|
||||
C REDUCE A TO UPPER HESSENBERG FORM
|
||||
C
|
||||
CALL ORTHES (NA,N,LOW,IGH,A,SCR2)
|
||||
IF (NVEC .NE. 0) GO TO 40
|
||||
C
|
||||
C COMPUTE EIGENVALUES USING QR ALGORITHM
|
||||
C
|
||||
CALL HQR (NA,N,LOW,IGH,A,EVR,EVI,IERR)
|
||||
IF (IERR .NE. 0) RETURN
|
||||
GO TO 110
|
||||
40 CONTINUE
|
||||
C
|
||||
C COMPUTE EIGENVALUES AND EIGENVECTORS USING QR ALGORITHM
|
||||
C
|
||||
CALL ORTRAN (NA,N,LOW,IGH,A,SCR2,VECS)
|
||||
CALL HQR2 (NA,N,LOW,IGH,A,EVR,EVI,VECS,IERR)
|
||||
IF (IERR .NE. 0) RETURN
|
||||
CALL BALBAK (NA,N,LOW,IGH,SCR1,N,VECS)
|
||||
C
|
||||
C NORMALIZE EIGENVECTORS TO HAVE EUCLIDEAN OR 2- NORM EQUAL TO 1
|
||||
C
|
||||
DO 100 J = 1,N
|
||||
IF (EVI(J) .NE. 0.0D0) GO TO 70
|
||||
T = 0.0D0
|
||||
T1 = 0.0D0
|
||||
DO 50 I = 1,N
|
||||
T2 = VECS(I,J)**2
|
||||
IF (T2 .LE. T1) GO TO 45
|
||||
K = I
|
||||
T1 = T2
|
||||
45 CONTINUE
|
||||
T = T+T2
|
||||
50 CONTINUE
|
||||
T = DSIGN(DSQRT(T),VECS(K,J))
|
||||
DO 60 I = 1,N
|
||||
VECS(I,J) = VECS(I,J)/T
|
||||
60 CONTINUE
|
||||
GO TO 100
|
||||
70 CONTINUE
|
||||
IF (EVI(J) .GT. 0.0D0) GO TO 100
|
||||
JM1 = J-1
|
||||
T = 0.0D0
|
||||
T1 = 0.0D0
|
||||
DO 80 I = 1,N
|
||||
T2 = VECS(I,JM1)**2 + VECS(I,J)**2
|
||||
IF (T2 .LE. T1) GO TO 75
|
||||
K = I
|
||||
T1 = T2
|
||||
75 CONTINUE
|
||||
T = T+T2
|
||||
80 CONTINUE
|
||||
T = DSQRT(T)
|
||||
T1 = DSQRT(T1)
|
||||
DO 90 I = 1,N
|
||||
TRE = VECS(I,JM1)*VECS(K,JM1) + VECS(I,J)*VECS(K,J)
|
||||
TIM = VECS(I,J)*VECS(K,JM1) - VECS(I,JM1)*VECS(K,J)
|
||||
VECS(I,JM1) = (TRE/T1)/T
|
||||
VECS(I,J) = (TIM/T1)/T
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
C
|
||||
C COMPUTE NATURAL FREQUENCIES AND DAMPING RATIOS. SET
|
||||
C EIGENVALUES WITH NORM LESS THAN EPS*ANORM TO (0.0D0,0.0D0)
|
||||
C
|
||||
EPS = EPS*ANORM
|
||||
DO 130 I = 1,N
|
||||
T = DABS(EVR(I))+DABS(EVI(I))
|
||||
IF (T .GT. EPS) GO TO 120
|
||||
EVR(I) = 0.0D0
|
||||
EVI(I) = 0.0D0
|
||||
SCR1(I) = 0.0D0
|
||||
SCR2(I) = 1.0D0
|
||||
GO TO 130
|
||||
120 CONTINUE
|
||||
ER = EVR(I)/T
|
||||
EI = EVI(I)/T
|
||||
SCR1(I) = DSQRT(ER**2 + EI**2)
|
||||
SCR2(I) = -ER/SCR1(I)
|
||||
SCR1(I) = T*SCR1(I)
|
||||
IF (DABS(EVI(I)) .LT. EPS) EVI(I) = 0.0D0
|
||||
130 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
@@ -48,4 +48,4 @@
|
||||
enddo
|
||||
!---------------------------------------------
|
||||
return
|
||||
end
|
||||
end
|
||||
|
||||
@@ -17,7 +17,6 @@ CU USES covsrt,gaussj
|
||||
ia(j)=1
|
||||
if(ia(j).ne.0) mfit=mfit+1
|
||||
11 continue
|
||||
if(mfit.eq.0) pause 'lfit: no parameters to be fitted'
|
||||
do 13 j=1,mfit
|
||||
do 12 k=1,mfit
|
||||
covar(j,k)=0.0d0
|
||||
|
||||
+252
-252
@@ -255,282 +255,282 @@
|
||||
end
|
||||
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x)
|
||||
SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x)
|
||||
implicit none
|
||||
INTEGER m,mp,n,np,NMAX
|
||||
double precision b(mp),u(mp,np),v(np,np),w(np),x(np)
|
||||
PARAMETER (NMAX=1500)
|
||||
INTEGER i,j,jj
|
||||
double precision s,tmp(NMAX)
|
||||
do 12 j=1,n
|
||||
INTEGER m,mp,n,np,NMAX
|
||||
double precision b(mp),u(mp,np),v(np,np),w(np),x(np)
|
||||
PARAMETER (NMAX=1500)
|
||||
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
|
||||
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
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
do 13 jj=1,n
|
||||
s=s+v(j,jj)*tmp(jj)
|
||||
13 continue
|
||||
x(j)=s
|
||||
14 continue
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
|
||||
SUBROUTINE svdcmp(a,m,n,mp,np,w,v,ierr)
|
||||
SUBROUTINE svdcmp(a,m,n,mp,np,w,v,ierr)
|
||||
implicit none
|
||||
INTEGER m,mp,n,np,NMAX␍,ierr
|
||||
double precision a(mp,np),v(np,np),w(np)
|
||||
PARAMETER (NMAX=1500)
|
||||
CU USES pythag
|
||||
INTEGER i,its,j,jj,k,l,nm
|
||||
double precision anorm,c,f,g,h,s,scale,x,y,z,
|
||||
& rv1(NMAX),pythag
|
||||
INTEGER m,mp,n,np,NMAX,ierr
|
||||
double precision a(mp,np),v(np,np),w(np)
|
||||
PARAMETER (NMAX=1500)
|
||||
CU USES pythag
|
||||
INTEGER i,its,j,jj,k,l,nm
|
||||
double precision anorm,c,f,g,h,s,scaling,x,y,z,
|
||||
& rv1(NMAX),pythag
|
||||
g=0.0d0
|
||||
scale=0.0d0
|
||||
scaling=0.0d0
|
||||
anorm=0.0d0
|
||||
do 25 i=1,n
|
||||
l=i+1
|
||||
rv1(i)=scale*g
|
||||
do 25 i=1,n
|
||||
l=i+1
|
||||
rv1(i)=scaling*g
|
||||
g=0.0d0
|
||||
s=0.0d0
|
||||
scale=0.0d0
|
||||
if(i.le.m)then
|
||||
do 11 k=i,m
|
||||
scale=scale+dabs(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=-dsign(dsqrt(s),f)
|
||||
h=f*g-s
|
||||
a(i,i)=f-g
|
||||
do 15 j=l,n
|
||||
scaling=0.0d0
|
||||
if(i.le.m)then
|
||||
do 11 k=i,m
|
||||
scaling=scaling+dabs(a(k,i))
|
||||
11 continue
|
||||
if(scaling.ne.0.0d0)then
|
||||
do 12 k=i,m
|
||||
a(k,i)=a(k,i)/scaling
|
||||
s=s+a(k,i)*a(k,i)
|
||||
12 continue
|
||||
f=a(i,i)
|
||||
g=-dsign(dsqrt(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
|
||||
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)=scaling*a(k,i)
|
||||
16 continue
|
||||
endif
|
||||
endif
|
||||
w(i)=scaling*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+dabs(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=-dsign(dsqrt(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
|
||||
scaling=0.0d0
|
||||
if((i.le.m).and.(i.ne.n))then
|
||||
do 17 k=l,n
|
||||
scaling=scaling+dabs(a(i,k))
|
||||
17 continue
|
||||
if(scaling.ne.0.0d0)then
|
||||
do 18 k=l,n
|
||||
a(i,k)=a(i,k)/scaling
|
||||
s=s+a(i,k)*a(i,k)
|
||||
18 continue
|
||||
f=a(i,l)
|
||||
g=-dsign(dsqrt(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=dmax1(anorm,(dabs(w(i))+dabs(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
|
||||
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)=scaling*a(i,k)
|
||||
24 continue
|
||||
endif
|
||||
endif
|
||||
anorm=dmax1(anorm,(dabs(w(i))+dabs(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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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((dabs(rv1(l))+anorm).eq.anorm) goto 2
|
||||
if((dabs(w(nm))+anorm).eq.anorm) goto 1
|
||||
41 continue
|
||||
39 continue
|
||||
do 49 k=n,1,-1
|
||||
do 48 its=1,30
|
||||
do 41 l=k,1,-1
|
||||
nm=l-1
|
||||
if((dabs(rv1(l))+anorm).eq.anorm) goto 2
|
||||
if((dabs(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((dabs(f)+anorm).eq.anorm) goto 2
|
||||
g=w(i)
|
||||
h=pythag(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
|
||||
do 43 i=l,k
|
||||
f=s*rv1(i)
|
||||
rv1(i)=c*rv1(i)
|
||||
if((dabs(f)+anorm).eq.anorm) goto 2
|
||||
g=w(i)
|
||||
h=pythag(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)then
|
||||
ierr=0
|
||||
return
|
||||
endif
|
||||
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=pythag(f,1.0d0)
|
||||
f=((x-z)*(x+z)+h*((y/(f+dsign(g,f)))-h))/x
|
||||
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=pythag(f,1.0d0)
|
||||
f=((x-z)*(x+z)+h*((y/(f+dsign(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=pythag(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=pythag(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
|
||||
do 47 j=l,nm
|
||||
i=j+1
|
||||
g=rv1(i)
|
||||
y=w(i)
|
||||
h=s*g
|
||||
g=c*g
|
||||
z=pythag(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=pythag(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
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
rv1(k)=f
|
||||
w(k)=x
|
||||
48 continue
|
||||
3 continue
|
||||
49 continue
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
|
||||
double precision FUNCTION pythag(a,b)
|
||||
double precision FUNCTION pythag(a,b)
|
||||
double precision a,b
|
||||
double precision absa,absb
|
||||
absa=dabs(a)
|
||||
absb=dabs(b)
|
||||
if(absa.gt.absb)then
|
||||
pythag=absa*dsqrt(1.0d0+(absb/absa)**2)
|
||||
else
|
||||
if(absb.eq.0.0d0)then
|
||||
double precision absa,absb
|
||||
absa=dabs(a)
|
||||
absb=dabs(b)
|
||||
if(absa.gt.absb)then
|
||||
pythag=absa*dsqrt(1.0d0+(absb/absa)**2)
|
||||
else
|
||||
if(absb.eq.0.0d0)then
|
||||
pythag=0.0d0
|
||||
else
|
||||
pythag=absb*dsqrt(1.0d0+(absa/absb)**2)
|
||||
endif
|
||||
endif
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
else
|
||||
pythag=absb*dsqrt(1.0d0+(absa/absb)**2)
|
||||
endif
|
||||
endif
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
|
||||
|
||||
subroutine xmprove(N,NP,a,b,x,mark)
|
||||
@@ -687,7 +687,7 @@ CU USES lubksb
|
||||
u(i,j)=a(i,j)
|
||||
enddo
|
||||
enddo
|
||||
call svdcmp(u(1:n,1:n),n,n,np,np,w,v(1:n,1:n),ierr)
|
||||
call svdcmp(u(1:n,1:n),n,n,np,np,w,v(1:n,1:n),ierr)
|
||||
wmax=0.0d0
|
||||
do j=1,n
|
||||
if(w(j).gt.wmax)wmax=w(j)
|
||||
@@ -696,7 +696,7 @@ CU USES lubksb
|
||||
do j=1,n
|
||||
if(w(j).lt.wmin)w(j)=0.0d0
|
||||
enddo
|
||||
call svbksb(u(1:n,1:n),w,v(1:n,1:n),n,n,np,np,b,x)
|
||||
call svbksb(u(1:n,1:n),w,v(1:n,1:n),n,n,np,np,b,x)
|
||||
return
|
||||
end
|
||||
|
||||
@@ -708,20 +708,20 @@ CU USES lubksb
|
||||
DOUBLE PRECISION a(np,np),c(n),d(n)
|
||||
LOGICAL sing
|
||||
INTEGER i,j,k
|
||||
DOUBLE PRECISION scale,sigma,sum,tau
|
||||
DOUBLE PRECISION scaling,sigma,sum,tau
|
||||
sing=.false.
|
||||
do 17 k=1,n-1
|
||||
scale=0.0d0
|
||||
scaling=0.0d0
|
||||
do 11 i=k,n
|
||||
scale=dmax1(scale,dabs(a(i,k)))
|
||||
scaling=dmax1(scaling,dabs(a(i,k)))
|
||||
11 continue
|
||||
if(scale.eq.0.0d0)then
|
||||
if(scaling.eq.0.0d0)then
|
||||
sing=.true.
|
||||
c(k)=0.0d0
|
||||
d(k)=0.0d0
|
||||
else
|
||||
do 12 i=k,n
|
||||
a(i,k)=a(i,k)/scale
|
||||
a(i,k)=a(i,k)/scaling
|
||||
12 continue
|
||||
sum=0.0d0
|
||||
do 13 i=k,n
|
||||
@@ -730,7 +730,7 @@ CU USES lubksb
|
||||
sigma=dsign(dsqrt(sum),a(k,k))
|
||||
a(k,k)=a(k,k)+sigma
|
||||
c(k)=sigma*a(k,k)
|
||||
d(k)=-scale*sigma
|
||||
d(k)=-scaling*sigma
|
||||
do 16 j=k+1,n
|
||||
sum=0.0d0
|
||||
do 14 i=k,n
|
||||
@@ -997,4 +997,4 @@ c
|
||||
endif
|
||||
goto 10
|
||||
end
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
|
||||
@@ -0,0 +1,74 @@
|
||||
program main
|
||||
implicit none
|
||||
double precision lamta(100),fmeas(100),sigma(100),chisq,
|
||||
&u(100,10),v(10,10),w(10),beta(10),fmod(100)
|
||||
integer i,ma,mp,np,ndata,nsifparams
|
||||
double precision solar(100)
|
||||
Common /irradiance/solar,nsifparams
|
||||
external getsifbasisfunc
|
||||
!u(mp,np),v(np,np),w(np),x(ndata),y(ndata),TOL
|
||||
|
||||
lamta(1)=730.0d0
|
||||
ndata=90
|
||||
do i= 2,ndata
|
||||
lamta(i)=lamta(i-1)+1.0d0
|
||||
enddo
|
||||
do i=1,ndata
|
||||
solar(i)=100.0d0*dabs(dsin(dble(i)*6.28d0/5.0d0))
|
||||
sigma(i)=1.0d0
|
||||
enddo
|
||||
beta(1)=3.20d0
|
||||
beta(2)=-10.23d0
|
||||
beta(3)=-99.9d0
|
||||
beta(4)=25.0d0
|
||||
beta(5)=-200.0d0
|
||||
beta(6)=157.0d0
|
||||
ma=6
|
||||
nsifparams=3
|
||||
c mp>=ndata, np>=ma. ma is the number of coefficients
|
||||
mp=ndata
|
||||
np=ma
|
||||
|
||||
do i=1,ndata
|
||||
call SIFforwardmodel(lamta(i),i,fmeas(i),beta,ma)
|
||||
enddo
|
||||
call svdfit(lamta,fmeas,sigma,ndata,beta,ma,u(1:mp,1:np),
|
||||
*v(1:np,1:np),w,mp,np,chisq,getsifbasisfunc)
|
||||
do i=1,ma
|
||||
write(*,*)beta(i),w(i)
|
||||
enddo
|
||||
do i=1,ndata
|
||||
call SIFforwardmodel(lamta(i),i,fmod(i),beta,ma)
|
||||
write(*,*)lamta(i),fmeas(i),fmod(i)
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine SIFforwardmodel(lamta,ipos,irradmeas,beta,ma)
|
||||
implicit none
|
||||
integer ma,ipos,i
|
||||
double precision lamta,irradmeas,beta(ma),basisfunc(ma)
|
||||
call getsifbasisfunc(lamta,basisfunc,ma,ipos)
|
||||
irradmeas=0.0d0
|
||||
do i=1,ma
|
||||
irradmeas=irradmeas+beta(i)*basisfunc(i)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine getsifbasisfunc(x,basisfunc,ma,ipos)
|
||||
implicit none
|
||||
double precision x,basisfunc(ma)
|
||||
integer ma,ipos,i
|
||||
integer nsifparams
|
||||
double precision solar(100)
|
||||
Common /irradiance/solar,nsifparams
|
||||
basisfunc(1)=1.0d0
|
||||
do i=2,nsifparams
|
||||
basisfunc(i)=basisfunc(i-1)*x
|
||||
enddo
|
||||
basisfunc(nsifparams+1)=solar(ipos)
|
||||
do i=nsifparams+2,ma
|
||||
basisfunc(i)=basisfunc(i-1)*x
|
||||
enddo
|
||||
return
|
||||
end
|
||||
Reference in New Issue
Block a user