Initial commit
This commit is contained in:
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,520 @@
|
||||
C[BA*)
|
||||
C[KA{F 5}
|
||||
C[ {Iterative Methods for Linear Systems}
|
||||
C[ {Iterative Methods for Linear Systems}*)
|
||||
C[FE{F 5.4}
|
||||
C[ {The Gau"s-Seidel Iteration}
|
||||
C[ {The Gau"s-Seidel Iteration}*)
|
||||
C[LE*)
|
||||
c SUBROUTINE ADSOR(A,N,IA,B,X,KADAPT,EPS,KMAX,IMETH,ISWITC,
|
||||
C[IX{ADSOR}*)
|
||||
c * OMEGA,WORK,RES,ITNUMB,IERR)
|
||||
SUBROUTINE ADSOR(A,N,IA,B,X,IERR)
|
||||
C
|
||||
C*****************************************************************
|
||||
C *
|
||||
C This program solves an inhomogeneous linear system AX = B of *
|
||||
C equations with a nonsingular system matrix A. The method of *
|
||||
C Jacobi is used jointly with relaxation, where the relaxation *
|
||||
C parameter OMEGA is adjusted during the iteration (adaptive *
|
||||
C SOR method). *
|
||||
C[BE*)
|
||||
C For a suitable choice of parameters (refer to the remark *
|
||||
C below), this program can perform the Gauá-Seidel method or *
|
||||
C a non-adaptive SOR method. *
|
||||
C *
|
||||
C *
|
||||
C INPUT PARAMETERS: *
|
||||
C ================= *
|
||||
C A : 2-dimensional array A(1:IA,1:N), containing the *
|
||||
C system matrix for the linear equations *
|
||||
C N : size of the linear system *
|
||||
C IA : leading dimension of A, as specified in the calling *
|
||||
C program *
|
||||
C B : N-vector B(1:N), the right hand side of the system *
|
||||
C X : N-vector X(1:N) containing the starting value for *
|
||||
C iteration *
|
||||
C KADAPT : Number of iterations, after which the relaxation *
|
||||
C parameter is to be redefined *
|
||||
C EPS : desired accuracy; the iteration is stopped when the *
|
||||
C maximum norm of the relative error does not exceed *
|
||||
C EPS *
|
||||
C KMAX : Maximal number of iterations allowed *
|
||||
C IMETH : parameter that determines the method used: *
|
||||
C = 0, adaptive SOR method *
|
||||
C = 1, SOR method for a given relaxation parameter *
|
||||
C = 2, Gauá-Seidel method *
|
||||
C ISWITC : parameter that determines the convergence criterion *
|
||||
C to be used: *
|
||||
C = 0, none *
|
||||
C = 1, row sum criterion *
|
||||
C = 2, column sum criterion *
|
||||
C = 3, criterion of Schmidt and v. Mises *
|
||||
C OMEGA : in case IMETH=1, the optimal relaxation parameter *
|
||||
C must be part of the input; otherwise only the name *
|
||||
C must be declared in the callimng program. *
|
||||
C *
|
||||
C *
|
||||
C REMARKS: *
|
||||
C ======== *
|
||||
C For the adaptive SOR method (IMETH=0) we recommend to set *
|
||||
C KADAPT=4 or KADAPT=5. *
|
||||
C If the optimal relaxationcoefficient Wopt is known for A, then*
|
||||
C one should set IMETH=1 and OMEGA = Wopt, i.e., the SOR method *
|
||||
C with given optimal relaxation coefficient should be used. *
|
||||
C If IMETH=2, then the program performs the Gauá-Seidel method. *
|
||||
C *
|
||||
C *
|
||||
C AUXILIARY PARAMETERS: *
|
||||
C ===================== *
|
||||
C WORK : 2-dim. array WORK(1:N,1:3) *
|
||||
C *
|
||||
C *
|
||||
C OUTPUT PARAMETERS: *
|
||||
C ================== *
|
||||
C A : 2-dim. array A(1:IA,1:N), the input matrix A is over-*
|
||||
C written by: A(I,J)=A(I,J)/A(I,I) for I,J=1, ..., N *
|
||||
C B : N-vector B(1:N), the right hand side is replaced by *
|
||||
C B(I)=B(I)/A(I,I); I=1,N *
|
||||
C OMEGA : - if IMETH = 0, the program returns the adaptively *
|
||||
C computed relaxations parameter. *
|
||||
C - if IMETH = 1, the optimal relaxation parameter *
|
||||
C is returned as put in externally. *
|
||||
C - if IMETH = 2, then on output OMEGA = 1. *
|
||||
C X : N-vector X(1:N) that contains the solution vector *
|
||||
C RES : N-vector RES(1:N) containing the residuum B - AX; *
|
||||
C the residuum is available even if the desired *
|
||||
C accuracy EPS could not be achieved with the given *
|
||||
C maximum number of iterations. *
|
||||
C ITNUMB : num,bert of iterations actually performed *
|
||||
C IERR : error parameter: *
|
||||
C = 0, the desired convergence criterium has not been *
|
||||
C met *
|
||||
C = 1, the solution X has been found *
|
||||
C = 2, the desired accuracy has not been achieved after*
|
||||
C KMAX iterations *
|
||||
C = 3, input data incorrect *
|
||||
C = 4, system matrix A is numerically singular *
|
||||
C *
|
||||
C----------------------------------------------------------------*
|
||||
C *
|
||||
C Required subroutines: GAUSEI, MNORM, CONV, RESID, MACHPD *
|
||||
C *
|
||||
C*****************************************************************
|
||||
C *
|
||||
C Author : Gisela Engeln-M�llges *
|
||||
C Date : 06.09.1992 *
|
||||
C Source : FORTRAN 77 *
|
||||
C *
|
||||
C[BA*)
|
||||
C*****************************************************************
|
||||
C[BE*)
|
||||
C
|
||||
C Declarations
|
||||
C
|
||||
DOUBLE PRECISION A(1:IA,1:N),B(1:N),X(1:N),WORK(1:N,1:3),
|
||||
* RES(1:N),EPS,OMEGA,FMACHP,HELP,DIFFN,Q,
|
||||
* RELERR,SUM,XN
|
||||
C
|
||||
c The following 5 lines is added by GU
|
||||
EPS=1.0D-06
|
||||
KADAPT=4
|
||||
KMAX=2000
|
||||
IMETH=2
|
||||
ISWITC=0
|
||||
OMEGA=1.0d0
|
||||
c
|
||||
C Checking the inputs EPS, KMAX, IMETH and ISWITC
|
||||
C
|
||||
IF(EPS .LE. 0.0D0 .OR. KMAX .LT. 1 .OR. ISWITC .LT. 0 .OR.
|
||||
* ISWITC .GT. 3 .OR. IMETH .LT. 0 .OR. IMETH .GT. 2) THEN
|
||||
IERR=3
|
||||
RETURN
|
||||
ENDIF
|
||||
C
|
||||
C Initialize the parameters KADAPT and OMEGA depending on the method
|
||||
C
|
||||
IF(IMETH .EQ. 0) THEN
|
||||
OMEGA=1.0D0
|
||||
ELSE IF(IMETH .EQ. 1) THEN
|
||||
KADAPT=KMAX
|
||||
ELSE IF(IMETH .EQ. 2) THEN
|
||||
KADAPT=KMAX
|
||||
OMEGA=1.0D0
|
||||
ENDIF
|
||||
C
|
||||
C Compute the machine constant and initialize the relative error bound
|
||||
C
|
||||
FMACHP=1.0D0
|
||||
10 FMACHP=0.5D0*FMACHP
|
||||
IF(MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 10
|
||||
RELERR=FMACHP*8.0D0
|
||||
C
|
||||
C Initialize
|
||||
C
|
||||
Q=1.0D0
|
||||
ITNUMB=0
|
||||
C
|
||||
C Check whether A is singular; if so, set IERR = 4.
|
||||
C
|
||||
DO 20 I=1,N
|
||||
SUM=DABS(A(I,1))
|
||||
DO 30 K=2,N
|
||||
SUM=SUM+DABS(A(I,K))
|
||||
30 CONTINUE
|
||||
IF(SUM .EQ. 0.0D0) THEN
|
||||
IERR=4
|
||||
RETURN
|
||||
ELSE IF(DABS(A(I,I))/SUM .LT. RELERR) THEN
|
||||
IERR=4
|
||||
RETURN
|
||||
ENDIF
|
||||
20 CONTINUE
|
||||
C
|
||||
C Redefine the entries in A and B: A(I,J) := A(I,J)/A(I,I)
|
||||
C and B(I) := B(I)/A(I,I) .
|
||||
C
|
||||
DO 40 I=1,N
|
||||
HELP=1.0D0/A(I,I)
|
||||
DO 50 J=1,N
|
||||
A(I,J)=A(I,J)*HELP
|
||||
50 CONTINUE
|
||||
B(I)=B(I)*HELP
|
||||
40 CONTINUE
|
||||
C
|
||||
C Check for convergence
|
||||
C
|
||||
IF(ISWITC .NE. 0) THEN
|
||||
CALL CONV(ISWITC,A,N,IA,IERR)
|
||||
IF(IERR .EQ. 0) RETURN
|
||||
ENDIF
|
||||
C
|
||||
C The vector RES serves as auxiliary storage for the previous solution
|
||||
C vektor. Initially RES contains the staring vector.
|
||||
C
|
||||
DO 60 I=1,N
|
||||
RES(I)=X(I)
|
||||
60 CONTINUE
|
||||
C
|
||||
C One iteration with the Gauá-Seidel method gives the first iterate X
|
||||
C
|
||||
CALL GAUSEI(A,N,IA,B,OMEGA,X)
|
||||
C
|
||||
C Up the iteration counter
|
||||
C
|
||||
ITNUMB=ITNUMB+1
|
||||
C
|
||||
C Compute the difference of the last two iterates
|
||||
C
|
||||
DO 70 I=1,N
|
||||
WORK(I,1)=X(I)-RES(I)
|
||||
70 CONTINUE
|
||||
C
|
||||
C Iteration loop for the chosen method
|
||||
C
|
||||
DO 80 K=1,KMAX-1
|
||||
C
|
||||
C Check break-off criterion
|
||||
C
|
||||
CALL MNORM(WORK(1,1),N,DIFFN)
|
||||
CALL MNORM(X,N,XN)
|
||||
IF(DIFFN .LE. EPS*XN) THEN
|
||||
IERR=1
|
||||
ITNUMB=K
|
||||
CALL RESID(A,N,IA,B,X,RES)
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(K .EQ. KMAX-1) THEN
|
||||
ITNUMB=KMAX
|
||||
IERR=2
|
||||
CALL RESID(A,N,IA,B,X,RES)
|
||||
RETURN
|
||||
ENDIF
|
||||
C
|
||||
C RES contains the previous iterate
|
||||
C
|
||||
DO 90 I=1,N
|
||||
RES(I)=X(I)
|
||||
90 CONTINUE
|
||||
C
|
||||
C One iteration step using Gauá-Seidel for a fixed OMEGA
|
||||
C
|
||||
CALL GAUSEI(A,N,IA,B,OMEGA,X)
|
||||
C
|
||||
C Compute the difference of the last two iterates
|
||||
C
|
||||
DO 100 I=1,N
|
||||
WORK(I,2)=X(I)-RES(I)
|
||||
100 CONTINUE
|
||||
C
|
||||
C If the number of performed iterations K is divisible by KADAPT,
|
||||
C then we compute Q in order to adjust the relaxation parameter;
|
||||
C Q is an estimate of the spectral radius of the iteration matrix.
|
||||
C
|
||||
IF(MOD(K,KADAPT) .EQ. 0) THEN
|
||||
DO 110 I=1,N
|
||||
IF(DABS(WORK(I,1)) .LT. FMACHP) THEN
|
||||
WORK(I,3)=1.0D0
|
||||
ELSE
|
||||
WORK(I,3)=WORK(I,2)/WORK(I,1)
|
||||
ENDIF
|
||||
110 CONTINUE
|
||||
CALL MNORM(WORK(1,3),N,Q)
|
||||
C
|
||||
C If Q > 1, then the iteration counter is upped by one and
|
||||
C the next Gauá-Seidel step is executed; otherwise a new
|
||||
C relaxation parameter is calculated.
|
||||
C
|
||||
IF(Q .LE. 1.0D0) THEN
|
||||
Q=MAX(Q,OMEGA-1.0D0)
|
||||
OMEGA=2.0D0/(1.0D0+DSQRT(1.0D0-((Q+OMEGA-1.0D0)
|
||||
* /OMEGA)**2/Q))
|
||||
ENDIF
|
||||
ENDIF
|
||||
C
|
||||
C The difference vector of the last two iterations is replaced
|
||||
C by the one of the previous two iterations for the approximate solution
|
||||
C
|
||||
DO 120 I=1,N
|
||||
WORK(I,1)=WORK(I,2)
|
||||
120 CONTINUE
|
||||
80 CONTINUE
|
||||
END
|
||||
C
|
||||
C
|
||||
C[BA*)
|
||||
C[LE*)
|
||||
SUBROUTINE GAUSEI(A,N,IA,B,OMEGA,X)
|
||||
C[IX{GAUSEI}*)
|
||||
C
|
||||
C*****************************************************************
|
||||
C *
|
||||
C This subroutine performs one iteration with the Gauá-Seidel *
|
||||
C method for a given relaxation parameter. *
|
||||
C[BE*)
|
||||
C *
|
||||
C *
|
||||
C INPUT PARAMETERS: *
|
||||
C ================= *
|
||||
C A : 2-dim. array A(1:IA, 1:N), that contains the *
|
||||
C modified system matrix A : A(I,J)=A(I,J)/A(I,I) for *
|
||||
C I,J=1, ..., N *
|
||||
C N : order of the system *
|
||||
C IA : leading dimension of A, as specified in the calling *
|
||||
C program *
|
||||
C B : N-vector B(1:N) with the modified right hand side: *
|
||||
C B(I)=B(I)/A(I,I); I=1, ..., N *
|
||||
C OMEGA : relaxation parameter *
|
||||
C X : N-vector X(1:N) containing the starting vector for *
|
||||
C the iteration *
|
||||
C *
|
||||
C *
|
||||
C OUTPUT PARAMETERS: *
|
||||
C ================== *
|
||||
C X : N-vector X(1:N) containing the next iteration vector *
|
||||
C *
|
||||
C----------------------------------------------------------------*
|
||||
C *
|
||||
C Required subroutines: none *
|
||||
C *
|
||||
C*****************************************************************
|
||||
C *
|
||||
C Author : Gisela Engeln-M�llges *
|
||||
C Date : 06.09.1992 *
|
||||
C Source : FORTRAN 77 *
|
||||
C *
|
||||
C[BA*)
|
||||
C*****************************************************************
|
||||
C[BE*)
|
||||
C
|
||||
DOUBLE PRECISION A(1:IA,1:N),B(1:N),X(1:N),OMEGA,S
|
||||
C
|
||||
DO 10 I=1,N
|
||||
S=B(I)
|
||||
DO 20 J=1,N
|
||||
S=S-A(I,J)*X(J)
|
||||
20 CONTINUE
|
||||
X(I)=X(I)+OMEGA*S
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
C
|
||||
C
|
||||
C[BA*)
|
||||
C[LE*)
|
||||
SUBROUTINE MNORM(X,N,XNORM)
|
||||
C[IX{MNORM}*)
|
||||
C
|
||||
C*****************************************************************
|
||||
C *
|
||||
C This subroutine calculates the maximum norm XNORM of an *
|
||||
C N-vector X. *
|
||||
C *
|
||||
C----------------------------------------------------------------*
|
||||
C[BE*)
|
||||
C *
|
||||
C Required subroutines: none *
|
||||
C *
|
||||
C*****************************************************************
|
||||
C *
|
||||
C Author : Gisela Engeln-M�llges *
|
||||
C Date : 06.09.1992 *
|
||||
C Source : FORTRAN 77 *
|
||||
C *
|
||||
C*****************************************************************
|
||||
C
|
||||
DOUBLE PRECISION X(1:N),XNORM
|
||||
C
|
||||
XNORM=DABS(X(1))
|
||||
DO 10 I=2,N
|
||||
XNORM=DMAX1(XNORM,DABS(X(I)))
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
C
|
||||
C
|
||||
C[BA*)
|
||||
C[LE*)
|
||||
SUBROUTINE CONV(ISWITC,A,N,IA,IERR)
|
||||
C[IX{CONV}*)
|
||||
C
|
||||
C*****************************************************************
|
||||
C *
|
||||
C This subroutine helps check convergence. *
|
||||
C[BE*)
|
||||
C *
|
||||
C *
|
||||
C INPUT PARAMETERS: *
|
||||
C ================= *
|
||||
C ISWITC : Parameter that determines the convergence criterion *
|
||||
C to be checked: *
|
||||
C = 0, none *
|
||||
C = 1, row sum criterion *
|
||||
C = 2, column sum criterion *
|
||||
C = 3, criterion of Schmidt and v. Mises *
|
||||
C A : 2-dim. array A(1:IA, 1:N), containing the matrix for *
|
||||
C which we want to check convergence of the iterates *
|
||||
C from the various SOR algorithms *
|
||||
C N : order of the matrix A *
|
||||
C IA : leading dimension of A, as prescribed in the calling *
|
||||
C program *
|
||||
C *
|
||||
C *
|
||||
C OUTPUT PARAMETERS: *
|
||||
C ================== *
|
||||
C IERR : error parameter: *
|
||||
C = 0, the desired convergence criterion has not been *
|
||||
C met *
|
||||
C = 1, the desired criterion is satified *
|
||||
C *
|
||||
C----------------------------------------------------------------*
|
||||
C *
|
||||
C Required subroutines: none *
|
||||
C *
|
||||
C*****************************************************************
|
||||
C *
|
||||
C Author : Gisela Engeln-M�llges *
|
||||
C Date : 06.09.1992 *
|
||||
C Source : FORTRAN 77 *
|
||||
C *
|
||||
C[BA*)
|
||||
C*****************************************************************
|
||||
C[BE*)
|
||||
C
|
||||
DOUBLE PRECISION A(1:IA,1:N),SUM
|
||||
C
|
||||
C Row sum criterion
|
||||
C
|
||||
IF(ISWITC .EQ. 1) THEN
|
||||
DO 10 I=1,N
|
||||
SUM=-1.0D0
|
||||
DO 20 J=1,N
|
||||
SUM=SUM+DABS(A(I,J))
|
||||
20 CONTINUE
|
||||
IF(SUM .LT. 1.0D0) THEN
|
||||
IERR=1
|
||||
ELSE
|
||||
IERR=0
|
||||
RETURN
|
||||
ENDIF
|
||||
10 CONTINUE
|
||||
C
|
||||
C Column sum criterion
|
||||
C
|
||||
ELSE IF(ISWITC .EQ. 2) THEN
|
||||
DO 30 J=1,N
|
||||
SUM=-1.0D0
|
||||
DO 40 I=1,N
|
||||
SUM=SUM+DABS(A(I,J))
|
||||
40 CONTINUE
|
||||
IF(SUM .LT. 1.0D0) THEN
|
||||
IERR=1
|
||||
ELSE
|
||||
IERR=0
|
||||
RETURN
|
||||
ENDIF
|
||||
30 CONTINUE
|
||||
C
|
||||
C Criterion of Schmidt and v. Mises
|
||||
C
|
||||
ELSE IF(ISWITC .EQ. 3) THEN
|
||||
SUM=-N
|
||||
DO 50 I=1,N
|
||||
DO 60 J=1,N
|
||||
SUM=SUM+A(I,J)*A(I,J)
|
||||
60 CONTINUE
|
||||
50 CONTINUE
|
||||
SUM=DSQRT(SUM)
|
||||
IF(SUM .LT. 1.0D0) THEN
|
||||
IERR=1
|
||||
ELSE
|
||||
IERR=0
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
END
|
||||
C
|
||||
C
|
||||
C[BA*)
|
||||
C[LE*)
|
||||
SUBROUTINE RESID(A,N,IA,B,X,RES)
|
||||
C[IX{RESID}*)
|
||||
C
|
||||
C*****************************************************************
|
||||
C *
|
||||
C This subroutine computes the residuum RES = B - AX, where *
|
||||
C both A and B are given in modified form. *
|
||||
C *
|
||||
C----------------------------------------------------------------*
|
||||
C[BE*)
|
||||
C *
|
||||
C Required subroutines: none *
|
||||
C *
|
||||
C*****************************************************************
|
||||
C *
|
||||
C Author : Gisela Engeln-M�llges *
|
||||
C Date : 09.06.1992 *
|
||||
C Source : FORTRAN 77 *
|
||||
C *
|
||||
C*****************************************************************
|
||||
C
|
||||
DOUBLE PRECISION A(1:IA,1:N), B(1:N), X(1:N), RES(1:N),DSUM
|
||||
C
|
||||
DO 10 I=1,N
|
||||
DSUM=B(I)
|
||||
DO 20 J=1,N
|
||||
DSUM=DSUM-A(I,J)*X(J)
|
||||
20 CONTINUE
|
||||
RES(I)=DSUM
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
c
|
||||
C[KA{F 0}{Auxiliary Library}{Auxiliary Library}*)
|
||||
INTEGER FUNCTION MACHPD(X)
|
||||
C[IX{MACHPD}*)
|
||||
DOUBLE PRECISION X
|
||||
MACHPD=0
|
||||
IF (1.0D0 .LT. X) MACHPD=1
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,51 @@
|
||||
subroutine eigen_sym_up(N,A,W)
|
||||
implicit none
|
||||
!
|
||||
!compute the eigenvalues and eigenvectors of a symmetrical matrix.
|
||||
!A: On entry, A is a symmetrical matrix with its upper triangle filled.
|
||||
! on exit, A contains the normalized eigenvectors in its columns.
|
||||
!W: contains the eigenvalues in descending order.
|
||||
|
||||
CHARACTER JOBZ, UPLO
|
||||
INTEGER INFO, LDA, LWORK, N
|
||||
DOUBLE PRECISION A(N, N), W( N ), WORK(3*N-1)
|
||||
double precision p
|
||||
integer i,j
|
||||
|
||||
JOBZ='V'
|
||||
UPLO='U'
|
||||
LWORK=3*N-1
|
||||
LDA=N
|
||||
call DSYEV(JOBZ,UPLO,N,A(1:N,1:N),LDA,W,WORK,LWORK,INFO)
|
||||
* INFO (output) INTEGER
|
||||
* = 0: successful exit
|
||||
* < 0: if INFO = -i, the i-th argument had an illegal value
|
||||
* > 0: if INFO = i, the algorithm failed to converge; i
|
||||
* off-diagonal elements of an intermediate tridiagonal
|
||||
* form did not converge to zero.
|
||||
if(INFO.lt.0)then
|
||||
write(*,*)'The ',-INFO,
|
||||
& 'th argument in DSYEV has an illegal value'
|
||||
stop
|
||||
endif
|
||||
if(INFO.gt.0)then
|
||||
write(*,*)'The algorithm failed to converge'
|
||||
stop
|
||||
endif
|
||||
|
||||
! Change the eigenvalue array from ascending to descending order and rearrange
|
||||
! the eigen vectors accordingly.
|
||||
!---------------------------------------------
|
||||
do i=1,N/2
|
||||
p=W(i)
|
||||
W(i)=W(N-i+1)
|
||||
W(N-i+1)=p
|
||||
do j=1,N
|
||||
p=A(j,i)
|
||||
A(j,i)=A(j,N-i+1)
|
||||
A(j,N-i+1)=p
|
||||
enddo
|
||||
enddo
|
||||
!---------------------------------------------
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,201 @@
|
||||
SUBROUTINE lfit(x,y,sig,ndat,a,ma,npc,funcs,ierr)
|
||||
implicit none
|
||||
|
||||
! ierr = 1, ok; =0 singular matrix
|
||||
|
||||
INTEGER ma,ia(ma),npc,ndat,MMAX,ierr
|
||||
double precision chisq,a(ma),covar(npc,npc),
|
||||
& sig(ndat),x(ndat),y(ndat)
|
||||
EXTERNAL funcs
|
||||
PARAMETER (MMAX=10000)
|
||||
CU USES covsrt,gaussj
|
||||
INTEGER i,j,k,l,m,mfit
|
||||
double precision sig2i,sum,wt,ym,afunc(MMAX),beta(MMAX)
|
||||
mfit=0
|
||||
ierr=1
|
||||
do 11 j=1,ma
|
||||
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
|
||||
12 continue
|
||||
beta(j)=0.0d0
|
||||
13 continue
|
||||
do 17 i=1,ndat
|
||||
|
||||
call funcs(x(i),afunc,ma)
|
||||
|
||||
ym=y(i)
|
||||
if(mfit.lt.ma) then
|
||||
do 14 j=1,ma
|
||||
if(ia(j).eq.0) ym=ym-a(j)*afunc(j)
|
||||
14 continue
|
||||
endif
|
||||
sig2i=1.0d0/sig(i)**2
|
||||
j=0
|
||||
do 16 l=1,ma
|
||||
if (ia(l).ne.0) then
|
||||
j=j+1
|
||||
wt=afunc(l)*sig2i
|
||||
k=0
|
||||
do 15 m=1,l
|
||||
if (ia(m).ne.0) then
|
||||
k=k+1
|
||||
covar(j,k)=covar(j,k)+wt*afunc(m)
|
||||
endif
|
||||
15 continue
|
||||
beta(j)=beta(j)+ym*wt
|
||||
endif
|
||||
16 continue
|
||||
17 continue
|
||||
do 19 j=2,mfit
|
||||
do 18 k=1,j-1
|
||||
covar(k,j)=covar(j,k)
|
||||
18 continue
|
||||
19 continue
|
||||
call gaussj(covar,mfit,npc,beta,1,1,ierr)
|
||||
if(ierr.eq.0)then
|
||||
! singular matrix
|
||||
return
|
||||
endif
|
||||
|
||||
j=0
|
||||
do 21 l=1,ma
|
||||
if(ia(l).ne.0) then
|
||||
j=j+1
|
||||
a(l)=beta(j)
|
||||
endif
|
||||
21 continue
|
||||
chisq=0.0d0
|
||||
do 23 i=1,ndat
|
||||
call funcs(x(i),afunc,ma)
|
||||
sum=0.0d0
|
||||
do 22 j=1,ma
|
||||
sum=sum+a(j)*afunc(j)
|
||||
22 continue
|
||||
chisq=chisq+((y(i)-sum)/sig(i))**2
|
||||
23 continue
|
||||
call covsrt(covar,npc,ma,ia,mfit)
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
|
||||
SUBROUTINE covsrt(covar,npc,ma,ia,mfit)
|
||||
implicit none
|
||||
INTEGER ma,mfit,npc,ia(ma)
|
||||
double precision covar(npc,npc)
|
||||
INTEGER i,j,k
|
||||
double precision swap
|
||||
do 12 i=mfit+1,ma
|
||||
do 11 j=1,i
|
||||
covar(i,j)=0.0d0
|
||||
covar(j,i)=0.0d0
|
||||
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
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
|
||||
SUBROUTINE gaussj(a,n,np,b,m,mp,ierr)
|
||||
implicit none
|
||||
INTEGER m,mp,n,np,NMAX,ierr
|
||||
double precision a(np,np),b(np,mp)
|
||||
PARAMETER (NMAX=10000)
|
||||
INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX),
|
||||
& ipiv(NMAX)
|
||||
double precision big,dum,pivinv
|
||||
ierr=1
|
||||
do 11 j=1,n
|
||||
ipiv(j)=0
|
||||
11 continue
|
||||
do 22 i=1,n
|
||||
big=0.0d0
|
||||
do 13 j=1,n
|
||||
if(ipiv(j).ne.1)then
|
||||
do 12 k=1,n
|
||||
if (ipiv(k).eq.0) then
|
||||
if (dabs(a(j,k)).ge.big)then
|
||||
big=dabs(a(j,k))
|
||||
irow=j
|
||||
icol=k
|
||||
endif
|
||||
else if (ipiv(k).gt.1) then
|
||||
! pause 'singular matrix in gaussj'
|
||||
ierr=0
|
||||
return
|
||||
endif
|
||||
12 continue
|
||||
endif
|
||||
13 continue
|
||||
ipiv(icol)=ipiv(icol)+1
|
||||
if (irow.ne.icol) then
|
||||
do 14 l=1,n
|
||||
dum=a(irow,l)
|
||||
a(irow,l)=a(icol,l)
|
||||
a(icol,l)=dum
|
||||
14 continue
|
||||
do 15 l=1,m
|
||||
dum=b(irow,l)
|
||||
b(irow,l)=b(icol,l)
|
||||
b(icol,l)=dum
|
||||
15 continue
|
||||
endif
|
||||
indxr(i)=irow
|
||||
indxc(i)=icol
|
||||
if (a(icol,icol).eq.0.0d0)then
|
||||
! pause 'singular matrix in gaussj'
|
||||
ierr=0
|
||||
return
|
||||
endif
|
||||
pivinv=1.0d0/a(icol,icol)
|
||||
a(icol,icol)=1.0d0
|
||||
do 16 l=1,n
|
||||
a(icol,l)=a(icol,l)*pivinv
|
||||
16 continue
|
||||
do 17 l=1,m
|
||||
b(icol,l)=b(icol,l)*pivinv
|
||||
17 continue
|
||||
do 21 ll=1,n
|
||||
if(ll.ne.icol)then
|
||||
dum=a(ll,icol)
|
||||
a(ll,icol)=0.0d0
|
||||
do 18 l=1,n
|
||||
a(ll,l)=a(ll,l)-a(icol,l)*dum
|
||||
18 continue
|
||||
do 19 l=1,m
|
||||
b(ll,l)=b(ll,l)-b(icol,l)*dum
|
||||
19 continue
|
||||
endif
|
||||
21 continue
|
||||
22 continue
|
||||
do 24 l=n,1,-1
|
||||
if(indxr(l).ne.indxc(l))then
|
||||
do 23 k=1,n
|
||||
dum=a(k,indxr(l))
|
||||
a(k,indxr(l))=a(k,indxc(l))
|
||||
a(k,indxc(l))=dum
|
||||
23 continue
|
||||
endif
|
||||
24 continue
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,19 @@
|
||||
subroutine matrixsquare_up(m,n,A,B)
|
||||
implicit none
|
||||
|
||||
! compute B=AA^T. B is symmetrical so only its upper triangle is computed.
|
||||
integer m,n
|
||||
double precision A(m,n),B(m,m)
|
||||
|
||||
integer i,j,k
|
||||
do i=1,m
|
||||
do j=i,m
|
||||
B(i,j)=0.0d0
|
||||
do k=1,n
|
||||
B(i,j)=B(i,j)+A(i,k)*A(j,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
@@ -0,0 +1,428 @@
|
||||
|
||||
program main
|
||||
implicit none
|
||||
double precision x(1000),y(1000),dx(1000),dy(1000),
|
||||
* slope,fintcpt,rtmnsquare,xoutliers(100),youtliers(1000),
|
||||
* x1(1000),y1(1000),k,b,sum1,sum2
|
||||
integer nsamp,i,numoutliers,nsamp1
|
||||
|
||||
open(unit=1,file='testdata.txt')
|
||||
i=1
|
||||
10 read(1,*,end=100)x(i),y(i)
|
||||
i=i+1
|
||||
goto 10
|
||||
100 nsamp=i-1
|
||||
|
||||
goto 200
|
||||
|
||||
|
||||
nsamp=13
|
||||
x(1)=-1.0d0
|
||||
y(1)=3.0d0
|
||||
x(2)=-3.0d0
|
||||
y(2)=4.0d0
|
||||
x(3)=-5.0d0
|
||||
y(3)=5.0d0
|
||||
x(4)=-7.0d0
|
||||
y(4)=6.0d0
|
||||
x(5)=-9.0d0
|
||||
y(5)=7.0d0
|
||||
x(6)=-11.0d0
|
||||
y(6)=8.0d0
|
||||
x(7)=-3.0d0
|
||||
y(7)=1.0d0
|
||||
x(8)=-5.0d0
|
||||
y(8)=2.0d0
|
||||
x(9)=-7.0d0
|
||||
y(9)=3.0d0
|
||||
x(10)=-9.0d0
|
||||
y(10)=4.0d0
|
||||
x(11)=-11.0d0
|
||||
y(11)=5.0d0
|
||||
x(12)=-4.0d0
|
||||
y(12)=7.0d0
|
||||
x(13)=-12.0d0
|
||||
y(13)=1.0d0
|
||||
|
||||
200 slope=-2.0d0
|
||||
fintcpt=0.0d0
|
||||
|
||||
call OrthSoilRespRegres(nsamp,x,y,slope,fintcpt)
|
||||
write(*,*)slope,fintcpt
|
||||
pause
|
||||
|
||||
slope=-2.0d0
|
||||
fintcpt=0.0d0
|
||||
|
||||
call orthlinreg_outlier(nsamp,x,y,slope,
|
||||
& fintcpt,dx,dy,rtmnsquare,xoutliers,youtliers,
|
||||
& numoutliers)
|
||||
write(*,*)slope/2.0d0,fintcpt,numoutliers
|
||||
do i=1,numoutliers
|
||||
write(*,*)xoutliers(i),youtliers(i)
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine orthlinreg_outlier(nsamp0,x0,y0,slope,
|
||||
& fintcpt,dx,dy,rtmnsquare,xoutliers,youtliers,
|
||||
& numoutliers)
|
||||
implicit none
|
||||
integer nsamp0,numoutliers
|
||||
double precision x0(nsamp0),y0(nsamp0),slope,
|
||||
& fintcpt,dx(nsamp0),dy(nsamp0),rtmnsquare,
|
||||
& xoutliers(nsamp0),youtliers(nsamp0),xtest(nsamp0),
|
||||
& ytest(nsamp0),slopetest,fintcpttest,dxtest(nsamp0),
|
||||
& dytest(nsamp0),rtmnsquaretest,testmeasure(nsamp0),
|
||||
& x(nsamp0),y(nsamp0)
|
||||
|
||||
integer iwhichside,nsamptest,isitoutlier,
|
||||
& isoutlier_1side,i,j,nsamp
|
||||
parameter (iwhichside=1)
|
||||
|
||||
numoutliers=0
|
||||
nsamp=nsamp0
|
||||
do i=1,nsamp
|
||||
x(i)=x0(i)
|
||||
y(i)=y0(i)
|
||||
enddo
|
||||
|
||||
50 call orthlinreg(nsamp,x,y,slope,fintcpt,
|
||||
& dx,dy,rtmnsquare)
|
||||
|
||||
write(*,*)slope,fintcpt,rtmnsquare
|
||||
stop
|
||||
nsamptest=nsamp-1
|
||||
do i=1,nsamp
|
||||
do j=1,nsamp
|
||||
xtest(j)=x(j)
|
||||
ytest(j)=y(j)
|
||||
enddo
|
||||
xtest(i)=x(nsamp)
|
||||
ytest(i)=y(nsamp)
|
||||
call orthlinreg(nsamptest,xtest,ytest,slopetest,
|
||||
& fintcpttest,dxtest,dytest,rtmnsquaretest)
|
||||
! write(*,*)i,slopetest,fintcpttest
|
||||
|
||||
! testmeasure(i)=(slopetest-slope)**2+
|
||||
! & (fintcpttest-fintcpt)**2
|
||||
|
||||
testmeasure(i)=100.0d0*dabs(rtmnsquaretest-rtmnsquare)/
|
||||
& rtmnsquare
|
||||
! write(*,*)i,testmeasure(i)
|
||||
enddo
|
||||
|
||||
isitoutlier=isoutlier_1side(nsamp,testmeasure,iwhichside)
|
||||
if(isitoutlier.lt.1.or.isitoutlier.gt.nsamp)return
|
||||
! outlier detected
|
||||
numoutliers=numoutliers+1
|
||||
xoutliers(numoutliers)=x(isitoutlier)
|
||||
youtliers(numoutliers)=y(isitoutlier)
|
||||
x(isitoutlier)=x(nsamp)
|
||||
y(isitoutlier)=y(nsamp)
|
||||
nsamp=nsamp-1
|
||||
if(nsamp.le.2)then
|
||||
write(*,*)'No enough good data left'
|
||||
stop
|
||||
endif
|
||||
goto 50
|
||||
return
|
||||
end
|
||||
|
||||
! orthogonal linear regression
|
||||
subroutine orthlinreg(nsamp,x,y,slope0,fintcpt0,
|
||||
& dx,dy,rtmnsquare)
|
||||
implicit none
|
||||
integer nsamp
|
||||
double precision x(nsamp),y(nsamp),dx1(nsamp),
|
||||
& dy1(nsamp),slope(2),fintcpt(2),dx2(nsamp),
|
||||
& dy2(nsamp),slope0,fintcpt0,dx(nsamp),dy(nsamp)
|
||||
integer i,j
|
||||
double precision w,u,v,xbar,ybar,root1,root2,
|
||||
& a,b,c,rtmnsquare1,rtmnsquare2,rtmnsquare
|
||||
|
||||
|
||||
|
||||
xbar=0.0d0
|
||||
ybar=0.0d0
|
||||
w=0.0d0
|
||||
u=0.0d0
|
||||
v=0.0d0
|
||||
do i=1,nsamp
|
||||
xbar=xbar+x(i)
|
||||
ybar=ybar+y(i)
|
||||
w=w+x(i)*x(i)
|
||||
u=u+y(i)*y(i)
|
||||
v=v+x(i)*y(i)
|
||||
enddo
|
||||
xbar=xbar/dble(nsamp)
|
||||
ybar=ybar/dble(nsamp)
|
||||
w=w/dble(nsamp)
|
||||
u=u/dble(nsamp)
|
||||
v=v/dble(nsamp)
|
||||
a=v-xbar*ybar
|
||||
b=w-u-xbar*xbar+ybar*ybar
|
||||
c=xbar*ybar-v
|
||||
call quadraticroots(a,b,c,root1,root2)
|
||||
slope(1)=root1
|
||||
slope(2)=root2
|
||||
fintcpt(1)=ybar-slope(1)*xbar
|
||||
fintcpt(2)=ybar-slope(2)*xbar
|
||||
rtmnsquare1=0.0d0
|
||||
rtmnsquare2=0.0d0
|
||||
do i=1,nsamp
|
||||
dx1(i)=(y(i)-fintcpt(1)-x(i)*slope(1))*
|
||||
& slope(1)/(1.0d0+slope(1)*slope(1))
|
||||
dy1(i)=-(y(i)-fintcpt(1)-x(i)*slope(1))/
|
||||
& (1.0d0+slope(1)*slope(1))
|
||||
rtmnsquare1=rtmnsquare1+dx1(i)**2+dy1(i)**2
|
||||
|
||||
dx2(i)=(y(i)-fintcpt(2)-x(i)*slope(2))*
|
||||
& slope(2)/(1.0d0+slope(2)*slope(2))
|
||||
dy2(i)=-(y(i)-fintcpt(2)-x(i)*slope(2))/
|
||||
& (1.0d0+slope(2)*slope(2))
|
||||
rtmnsquare2=rtmnsquare2+dx2(i)**2+dy2(i)**2
|
||||
enddo
|
||||
rtmnsquare1=dsqrt(rtmnsquare1/dble(nsamp))
|
||||
rtmnsquare2=dsqrt(rtmnsquare2/dble(nsamp))
|
||||
if(rtmnsquare1.gt.rtmnsquare2)then
|
||||
rtmnsquare=rtmnsquare2
|
||||
slope0=slope(2)
|
||||
fintcpt0=fintcpt(2)
|
||||
do i=1,nsamp
|
||||
dx(i)=dx2(i)
|
||||
dy(i)=dy2(i)
|
||||
enddo
|
||||
else
|
||||
rtmnsquare=rtmnsquare1
|
||||
slope0=slope(1)
|
||||
fintcpt0=fintcpt(1)
|
||||
do i=1,nsamp
|
||||
dx(i)=dx1(i)
|
||||
dy(i)=dy1(i)
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
!
|
||||
subroutine OrthSoilRespRegres(npoints,x0,y0,slope,fintcpt)
|
||||
implicit none
|
||||
c
|
||||
C ODRPACK ARGUMENT DEFINITIONS
|
||||
C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE
|
||||
C ==> N NUMBER OF OBSERVATIONS
|
||||
C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE
|
||||
C ==> NP NUMBER OF PARAMETERS
|
||||
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
|
||||
C <==> BETA FUNCTION PARAMETERS
|
||||
C ==> Y RESPONSE VARIABLE
|
||||
C ==> LDY LEADING DIMENSION OF ARRAY Y
|
||||
C ==> X EXPLANATORY VARIABLE
|
||||
C ==> LDX LEADING DIMENSION OF ARRAY X
|
||||
C ==> WE "EPSILON" WEIGHTS
|
||||
C ==> LDWE LEADING DIMENSION OF ARRAY WE
|
||||
C ==> LD2WE SECOND DIMENSION OF ARRAY WE
|
||||
C ==> WD "DELTA" WEIGHTS
|
||||
C ==> LDWD LEADING DIMENSION OF ARRAY WD
|
||||
C ==> LD2WD SECOND DIMENSION OF ARRAY WD
|
||||
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
|
||||
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
|
||||
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
|
||||
C ==> JOB TASK TO BE PERFORMED
|
||||
C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS
|
||||
C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR
|
||||
C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION
|
||||
C ==> PARTOL PARAMETER CONVERGENCE CRITERION
|
||||
C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS
|
||||
C ==> IPRINT PRINT CONTROL
|
||||
C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS
|
||||
C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS
|
||||
C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA
|
||||
C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA
|
||||
C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD
|
||||
C ==> SCLB SCALE VALUES FOR PARAMETERS BETA
|
||||
C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE
|
||||
C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD
|
||||
C <==> WORK DOUBLE PRECISION WORK VECTOR
|
||||
C ==> LWORK DIMENSION OF VECTOR WORK
|
||||
C <== IWORK INTEGER WORK VECTOR
|
||||
C ==> LIWORK DIMENSION OF VECTOR IWORK
|
||||
C <== INFO STOPPING CONDITION
|
||||
|
||||
C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER
|
||||
C MAXN MAXIMUM NUMBER OF OBSERVATIONS
|
||||
C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
|
||||
C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS
|
||||
C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION
|
||||
|
||||
C PARAMETER DECLARATIONS AND SPECIFICATIONS
|
||||
INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
||||
+ LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
||||
PARAMETER (MAXM=25,MAXN=50000,MAXNP=30,MAXNQ=1,
|
||||
+ LDY=MAXN,LDX=MAXN,
|
||||
+ LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
|
||||
+ LDIFX=MAXN,LDSTPD=1,LDSCLD=1,
|
||||
+ LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 +
|
||||
+ 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +
|
||||
+ 2*MAXN*MAXNQ*MAXM + MAXNQ**2 +
|
||||
+ 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
|
||||
+ LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
|
||||
C VARIABLE DECLARATIONS
|
||||
INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
|
||||
+ NDIGIT,NP,NQ
|
||||
INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)
|
||||
DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
|
||||
DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
|
||||
+ STPB(MAXNP),STPD(LDSTPD,MAXM),
|
||||
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
c
|
||||
integer npoints,i1
|
||||
double precision x0(npoints),y0(npoints),slope,fintcpt
|
||||
|
||||
|
||||
|
||||
EXTERNAL OrthRespFCN
|
||||
c
|
||||
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
|
||||
WE(1,1,1) = -1.0D0
|
||||
WD(1,1,1) = -1.0D0
|
||||
IFIXB(1) = -1
|
||||
! IFIXX(1,1) = -1
|
||||
! JOB = 00023
|
||||
JOB=20
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0D0
|
||||
SSTOL = -1.0D0
|
||||
PARTOL = -1.0D0
|
||||
MAXIT = -1
|
||||
! IPRINT = -1
|
||||
! IPRINT=0
|
||||
IPRINT=-1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0D0
|
||||
STPD(1,1) = -1.0D0
|
||||
SCLB(1) = -1.0D0
|
||||
SCLD(1,1) = -1.0D0
|
||||
|
||||
MAXIT = 200000
|
||||
C SET UP ODRPACK REPORT FILES
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
c
|
||||
N=npoints
|
||||
M=1
|
||||
NP=2
|
||||
NQ=1
|
||||
|
||||
|
||||
do I=1,N
|
||||
do i1=1,M
|
||||
X(I,i1)=x0(I)
|
||||
enddo
|
||||
Y(I,1)=y0(I)
|
||||
enddo
|
||||
BETA(1)=slope
|
||||
BETA(2)=fintcpt
|
||||
|
||||
C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
|
||||
DO 10 I=1,N
|
||||
DO 15 J=1, M
|
||||
IFIXX(I,J) = 1
|
||||
15 CONTINUE
|
||||
10 CONTINUE
|
||||
60 CALL DODRC(OrthRespFCN,
|
||||
+ N,M,NP,NQ,
|
||||
+ BETA,
|
||||
+ Y,LDY,X,LDX,
|
||||
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ JOB,NDIGIT,TAUFAC,
|
||||
+ SSTOL,PARTOL,MAXIT,
|
||||
+ IPRINT,LUNERR,LUNRPT,
|
||||
+ STPB,STPD,LDSTPD,
|
||||
+ SCLB,SCLD,LDSCLD,
|
||||
+ WORK,LWORK,IWORK,LIWORK,
|
||||
+ INFO)
|
||||
|
||||
slope=BETA(1)
|
||||
fintcpt=BETA(2)
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE OrthRespFCN(N,M,NP,NQ,
|
||||
+ LDN,LDM,LDNP,
|
||||
+ BETA,XPLUSD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ IDEVAL,F,FJACB,FJACD,
|
||||
+ ISTOP)
|
||||
implicit none
|
||||
C SUBROUTINE ARGUMENTS
|
||||
C ==> N NUMBER OF OBSERVATIONS
|
||||
C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
|
||||
C ==> NP NUMBER OF PARAMETERS
|
||||
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
|
||||
C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
|
||||
C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
|
||||
C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
|
||||
C ==> BETA CURRENT VALUES OF PARAMETERS
|
||||
C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
|
||||
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
|
||||
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
|
||||
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
|
||||
C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
|
||||
C <== F PREDICTED FUNCTION VALUES
|
||||
C <== FJACB JACOBIAN WITH RESPECT TO BETA
|
||||
C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA
|
||||
C <== ISTOP STOPPING CONDITION, WHERE
|
||||
C 0 MEANS CURRENT BETA AND X+DELTA WERE
|
||||
C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
|
||||
C 1 MEANS CURRENT BETA AND X+DELTA ARE
|
||||
C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES
|
||||
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
|
||||
C -1 MEANS CURRENT BETA AND X+DELTA ARE
|
||||
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
|
||||
|
||||
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
|
||||
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
||||
C OUTPUT ARGUMENTS:
|
||||
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
||||
|
||||
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
|
||||
c
|
||||
!
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 110 L = 1,NQ
|
||||
DO 100 I = 1,N
|
||||
F(I,L)=BETA(2)+BETA(1)*XPLUSD(I,1)
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
END IF
|
||||
|
||||
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
|
||||
IF (MOD(IDEVAL/10,10).GE.1) THEN
|
||||
DO 210 L = 1,NQ
|
||||
DO 200 I = 1,N
|
||||
FJACB(I,1,L)=XPLUSD(I,1)
|
||||
FJACB(I,2,L)=1.0d0
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ENDIF
|
||||
|
||||
C COMPUTE DERIVATIVES WITH RESPECT TO DELTA
|
||||
IF (MOD(IDEVAL/100,10).GE.1) THEN
|
||||
DO 310 L = 1,NQ
|
||||
DO 300 I = 1,N
|
||||
FJACD(I,1,L)=BETA(1)
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,111 @@
|
||||
-0.21875 0.2
|
||||
-0.205 0.44263776
|
||||
-0.19555556 0.10590558
|
||||
-0.18666667 0.36658142
|
||||
-0.1765 0.06329114
|
||||
-0.176 0.12291351
|
||||
-0.17368421 0.22368421
|
||||
-0.17142857 0.36669213
|
||||
-0.16789474 0.09287926
|
||||
-0.1675 0.12742718
|
||||
-0.1573913 0.08733624
|
||||
-0.15692308 0.11617673
|
||||
-0.15 0.22163511
|
||||
-0.149 -0.09330629
|
||||
-0.14875 0.234375
|
||||
-0.1475 0.23972603
|
||||
-0.14714286 0.34413766
|
||||
-0.14625 -0.0308642
|
||||
-0.14125 0.27777778
|
||||
-0.14 0.24025974
|
||||
-0.13863636 0.08765339
|
||||
-0.1375 0.29329609
|
||||
-0.1355 0.27157895
|
||||
-0.1337037 0.05646903
|
||||
-0.13291667 0.01709402
|
||||
-0.13090909 -0.08833272
|
||||
-0.13074074 0.00829962
|
||||
-0.13 0.31606027
|
||||
-0.13 0.15448604
|
||||
-0.13 0.10471204
|
||||
-0.12888889 0.11695906
|
||||
-0.12555556 0.14814815
|
||||
-0.12545455 0.01196172
|
||||
-0.12518519 0.05713427
|
||||
-0.12444444 0.20643594
|
||||
-0.12392857 0.08314967
|
||||
-0.12344828 0.07705644
|
||||
-0.121 0.10019268
|
||||
-0.11652174 0.23768116
|
||||
-0.11375 0.10877581
|
||||
-0.1115625 0.08479021
|
||||
-0.10757576 0.05117845
|
||||
-0.10733333 0.2659176
|
||||
-0.10647059 0.09332991
|
||||
-0.105 0.0976423
|
||||
-0.10441176 0.07311399
|
||||
-0.10294118 0.04956306
|
||||
-0.10285714 0.07193372
|
||||
-0.10269231 0.25865701
|
||||
-0.10269231 0.24972856
|
||||
-0.09722222 0.12745539
|
||||
-0.095 -0.00529661
|
||||
-0.09466667 0.09460738
|
||||
-0.09210526 0.14687882
|
||||
-0.08705882 -0.05602241
|
||||
-0.08541667 -0.03205128
|
||||
-0.0821875 0.21426616
|
||||
-0.08105263 0.00903546
|
||||
-0.07888889 0.06196581
|
||||
-0.07888889 -0.03878622
|
||||
-0.075 0.17806268
|
||||
-0.07315789 -0.02300236
|
||||
-0.07166667 0.19302153
|
||||
-0.07 0.33347404
|
||||
-0.06736842 0.16951037
|
||||
-0.06333333 0.20434227
|
||||
-0.06219512 0.16561277
|
||||
-0.06219512 0.17213638
|
||||
-0.06071429 0.16789396
|
||||
-0.05906977 0.15890265
|
||||
-0.0575 0.16435011
|
||||
-0.05678571 0.17027201
|
||||
-0.05208333 0.1582618
|
||||
-0.05194444 0.19674797
|
||||
-0.05166667 0.01883239
|
||||
-0.05148148 0.2589273
|
||||
-0.0498 0.15882353
|
||||
-0.04891892 0.1733227
|
||||
-0.04833333 0.15214385
|
||||
-0.04647059 0.17944798
|
||||
-0.0462 0.14204426
|
||||
-0.04588235 0.05317065
|
||||
-0.0440625 0.23542945
|
||||
-0.04358491 0.16895538
|
||||
-0.04339623 0.13951771
|
||||
-0.04285714 -0.08354219
|
||||
-0.04243243 0.17635673
|
||||
-0.04203704 0.14302166
|
||||
-0.04132075 0.16332383
|
||||
-0.0412963 0.15429157
|
||||
-0.04109091 0.14965035
|
||||
-0.04051282 0.10450334
|
||||
-0.03738095 0.13354616
|
||||
-0.03488372 0.17941003
|
||||
-0.0347619 0.16658253
|
||||
-0.0344186 0.19873627
|
||||
-0.03352941 0.11351909
|
||||
-0.03333333 0.00316106
|
||||
-0.03275 0.16699411
|
||||
-0.031 -0.03697479
|
||||
-0.03090909 0.14141414
|
||||
-0.03 0
|
||||
-0.029375 0.12665198
|
||||
-0.02823529 0.14436343
|
||||
-0.02571429 0.26308866
|
||||
-0.025 0.14719848
|
||||
-0.02428571 0.1073493
|
||||
-0.02384615 0.00624122
|
||||
-0.02333333 0.10115891
|
||||
-0.02136364 0.14080196
|
||||
-0.02076923 0.19122664
|
||||
Reference in New Issue
Block a user