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,
|
||||
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
|
||||
g=0.0d0
|
||||
scaling=0.0d0
|
||||
anorm=0.0d0
|
||||
anorm=0.0d0
|
||||
do 25 i=1,n
|
||||
l=i+1
|
||||
do 25 i=1,n
|
||||
l=i+1
|
||||
rv1(i)=scaling*g
|
||||
g=0.0d0
|
||||
s=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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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 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
|
||||
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 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
|
||||
v(j,i)=0.0d0
|
||||
31 continue
|
||||
31 continue
|
||||
endif
|
||||
v(i,i)=1.0d0
|
||||
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)
|
||||
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
|
||||
a(i,j)=0.0d0
|
||||
33 continue
|
||||
if(g.ne.0.0d0)then
|
||||
g=1.0d0/g
|
||||
33 continue
|
||||
if(g.ne.0.0d0)then
|
||||
g=1.0d0/g
|
||||
do 36 j=l,n
|
||||
s=0.0d0
|
||||
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 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
|
||||
a(j,i)=0.0d0
|
||||
38 continue
|
||||
38 continue
|
||||
endif
|
||||
a(i,i)=a(i,i)+1.0d0
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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)
|
||||
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
|
||||
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
|
||||
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(l)=0.0d0
|
||||
rv1(k)=f
|
||||
w(k)=x
|
||||
48 continue
|
||||
3 continue
|
||||
49 continue
|
||||
return
|
||||
END
|
||||
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 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
|
||||
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
|
||||
pythag=0.0d0
|
||||
else
|
||||
pythag=absb*dsqrt(1.0d0+(absa/absb)**2)
|
||||
endif
|
||||
endif
|
||||
return
|
||||
END
|
||||
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
|
||||
enddo
|
||||
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
|
||||
enddo
|
||||
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
|
||||
INTEGER i,j,k
|
||||
DOUBLE PRECISION scaling,sigma,sum,tau
|
||||
sing=.false.
|
||||
do 17 k=1,n-1
|
||||
do 17 k=1,n-1
|
||||
scaling=0.0d0
|
||||
do 11 i=k,n
|
||||
do 11 i=k,n
|
||||
scaling=dmax1(scaling,dabs(a(i,k)))
|
||||
11 continue
|
||||
11 continue
|
||||
if(scaling.eq.0.0d0)then
|
||||
sing=.true.
|
||||
c(k)=0.0d0
|
||||
d(k)=0.0d0
|
||||
else
|
||||
do 12 i=k,n
|
||||
do 12 i=k,n
|
||||
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)
|
||||
c(k)=sigma*a(k,k)
|
||||
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
|
||||
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
|
||||
@@ -258,7 +258,7 @@
|
||||
call cplnsrch(nunknowns,xpold,fsqsumold,
|
||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||
& check,funcnleq1,fequ)
|
||||
if(check.eq..true..or.check.eq..TRUE.)then
|
||||
if(check.eqv..true..or.check.eqv..TRUE.)then
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),xpold(i),
|
||||
& x0max(i),xp(i),6678)
|
||||
|
||||
@@ -0,0 +1,209 @@
|
||||
DOUBLE PRECISION FUNCTION D1MACH(I)
|
||||
INTEGER I
|
||||
C
|
||||
C DOUBLE-PRECISION MACHINE CONSTANTS
|
||||
C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
|
||||
C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
|
||||
C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
|
||||
C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
|
||||
C D1MACH( 5) = LOG10(B)
|
||||
C
|
||||
INTEGER SMALL(2)
|
||||
INTEGER LARGE(2)
|
||||
INTEGER RIGHT(2)
|
||||
INTEGER DIVER(2)
|
||||
INTEGER LOG10(2)
|
||||
INTEGER SC, CRAY1(38), J
|
||||
COMMON /D9MACH/ CRAY1
|
||||
SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
|
||||
DOUBLE PRECISION DMACH(5)
|
||||
EQUIVALENCE (DMACH(1),SMALL(1))
|
||||
EQUIVALENCE (DMACH(2),LARGE(1))
|
||||
EQUIVALENCE (DMACH(3),RIGHT(1))
|
||||
EQUIVALENCE (DMACH(4),DIVER(1))
|
||||
EQUIVALENCE (DMACH(5),LOG10(1))
|
||||
C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
|
||||
C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
|
||||
C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
|
||||
C MANY MACHINES YET.
|
||||
C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
|
||||
C ON THE NEXT LINE
|
||||
DATA SC/0/
|
||||
C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
|
||||
C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
|
||||
C mail netlib@research.bell-labs.com
|
||||
C send old1mach from blas
|
||||
C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
|
||||
C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
|
||||
C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
|
||||
C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
|
||||
C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
|
||||
C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
|
||||
C
|
||||
C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
|
||||
C 32-BIT INTEGERS.
|
||||
C DATA SMALL(1),SMALL(2) / 8388608, 0 /
|
||||
C DATA LARGE(1),LARGE(2) / 2147483647, -1 /
|
||||
C DATA RIGHT(1),RIGHT(2) / 612368384, 0 /
|
||||
C DATA DIVER(1),DIVER(2) / 620756992, 0 /
|
||||
C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
|
||||
C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
|
||||
C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
|
||||
C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
|
||||
C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
|
||||
C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
|
||||
C
|
||||
C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
|
||||
IF (SC .NE. 987) THEN
|
||||
DMACH(1) = 1.D13
|
||||
IF ( SMALL(1) .EQ. 1117925532
|
||||
* .AND. SMALL(2) .EQ. -448790528) THEN
|
||||
* *** IEEE BIG ENDIAN ***
|
||||
SMALL(1) = 1048576
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = 2146435071
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 1017118720
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 1018167296
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1070810131
|
||||
LOG10(2) = 1352628735
|
||||
ELSE IF ( SMALL(2) .EQ. 1117925532
|
||||
* .AND. SMALL(1) .EQ. -448790528) THEN
|
||||
* *** IEEE LITTLE ENDIAN ***
|
||||
SMALL(2) = 1048576
|
||||
SMALL(1) = 0
|
||||
LARGE(2) = 2146435071
|
||||
LARGE(1) = -1
|
||||
RIGHT(2) = 1017118720
|
||||
RIGHT(1) = 0
|
||||
DIVER(2) = 1018167296
|
||||
DIVER(1) = 0
|
||||
LOG10(2) = 1070810131
|
||||
LOG10(1) = 1352628735
|
||||
ELSE IF ( SMALL(1) .EQ. -2065213935
|
||||
* .AND. SMALL(2) .EQ. 10752) THEN
|
||||
* *** VAX WITH D_FLOATING ***
|
||||
SMALL(1) = 128
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = -32769
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 9344
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 9472
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 546979738
|
||||
LOG10(2) = -805796613
|
||||
ELSE IF ( SMALL(1) .EQ. 1267827943
|
||||
* .AND. SMALL(2) .EQ. 704643072) THEN
|
||||
* *** IBM MAINFRAME ***
|
||||
SMALL(1) = 1048576
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = 2147483647
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 856686592
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 873463808
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1091781651
|
||||
LOG10(2) = 1352628735
|
||||
ELSE IF ( SMALL(1) .EQ. 1120022684
|
||||
* .AND. SMALL(2) .EQ. -448790528) THEN
|
||||
* *** CONVEX C-1 ***
|
||||
SMALL(1) = 1048576
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = 2147483647
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 1019215872
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 1020264448
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1072907283
|
||||
LOG10(2) = 1352628735
|
||||
ELSE IF ( SMALL(1) .EQ. 815547074
|
||||
* .AND. SMALL(2) .EQ. 58688) THEN
|
||||
* *** VAX G-FLOATING ***
|
||||
SMALL(1) = 16
|
||||
SMALL(2) = 0
|
||||
LARGE(1) = -32769
|
||||
LARGE(2) = -1
|
||||
RIGHT(1) = 15552
|
||||
RIGHT(2) = 0
|
||||
DIVER(1) = 15568
|
||||
DIVER(2) = 0
|
||||
LOG10(1) = 1142112243
|
||||
LOG10(2) = 2046775455
|
||||
ELSE
|
||||
DMACH(2) = 1.D27 + 1
|
||||
DMACH(3) = 1.D27
|
||||
LARGE(2) = LARGE(2) - RIGHT(2)
|
||||
IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
|
||||
CRAY1(1) = 67291416
|
||||
DO 10 J = 1, 20
|
||||
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
|
||||
10 CONTINUE
|
||||
CRAY1(22) = CRAY1(21) + 321322
|
||||
DO 20 J = 22, 37
|
||||
CRAY1(J+1) = CRAY1(J) + CRAY1(J)
|
||||
20 CONTINUE
|
||||
IF (CRAY1(38) .EQ. SMALL(1)) THEN
|
||||
* *** CRAY ***
|
||||
CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
|
||||
SMALL(2) = 0
|
||||
CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
|
||||
CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
|
||||
CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
|
||||
RIGHT(2) = 0
|
||||
CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
|
||||
DIVER(2) = 0
|
||||
CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
|
||||
CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
|
||||
ELSE
|
||||
WRITE(*,9000)
|
||||
STOP 779
|
||||
END IF
|
||||
ELSE
|
||||
WRITE(*,9000)
|
||||
STOP 779
|
||||
END IF
|
||||
END IF
|
||||
SC = 987
|
||||
END IF
|
||||
* SANITY CHECK
|
||||
IF (DMACH(4) .GE. 1.0D0) STOP 778
|
||||
IF (I .LT. 1 .OR. I .GT. 5) THEN
|
||||
WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
|
||||
STOP
|
||||
END IF
|
||||
D1MACH = DMACH(I)
|
||||
RETURN
|
||||
9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
|
||||
*' appropriate for your machine.')
|
||||
* /* Standard C source for D1MACH -- remove the * in column 1 */
|
||||
*#include <stdio.h>
|
||||
*#include <float.h>
|
||||
*#include <math.h>
|
||||
*double d1mach_(long *i)
|
||||
*{
|
||||
* switch(*i){
|
||||
* case 1: return DBL_MIN;
|
||||
* case 2: return DBL_MAX;
|
||||
* case 3: return DBL_EPSILON/FLT_RADIX;
|
||||
* case 4: return DBL_EPSILON;
|
||||
* case 5: return log10((double)FLT_RADIX);
|
||||
* }
|
||||
* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
|
||||
* exit(1); return 0; /* some compilers demand return values */
|
||||
*}
|
||||
END
|
||||
SUBROUTINE I1MCRY(A, A1, B, C, D)
|
||||
**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
|
||||
INTEGER A, A1, B, C, D
|
||||
A1 = 16777216*B + C
|
||||
A = 16777216*A1 + D
|
||||
END
|
||||
@@ -0,0 +1,34 @@
|
||||
SUBROUTINE DERV1(LABEL,VALUE,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
C>> 1994-10-20 DERV1 Krogh Changes to use M77CON
|
||||
C>> 1994-04-20 DERV1 CLL Edited to make DP & SP files similar.
|
||||
C>> 1985-09-20 DERV1 Lawson Initial code.
|
||||
c--D replaces "?": ?ERV1
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C SUBROUTINE ARGUMENTS
|
||||
C --------------------
|
||||
C LABEL An identifing name to be printed with VALUE.
|
||||
C
|
||||
C VALUE A floating point number to be printed.
|
||||
C
|
||||
C FLAG See write up for FLAG in ERMSG.
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C
|
||||
COMMON/M77ERR/IDELTA,IALPHA
|
||||
INTEGER IDELTA,IALPHA
|
||||
DOUBLE PRECISION VALUE
|
||||
CHARACTER*(*) LABEL
|
||||
CHARACTER*1 FLAG
|
||||
SAVE /M77ERR/
|
||||
C
|
||||
IF (IALPHA.GE.-1) THEN
|
||||
WRITE (*,*) ' ',LABEL,' = ',VALUE
|
||||
IF (FLAG.EQ.'.') CALL ERFIN
|
||||
ENDIF
|
||||
RETURN
|
||||
C
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,67 @@
|
||||
DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DNRM2 returns the euclidean norm of a vector via the function
|
||||
* name, so that
|
||||
*
|
||||
* DNRM2 := sqrt( x'*x )
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* -- This version written on 25-October-1982.
|
||||
* Modified on 14-October-1993 to inline the call to DLASSQ.
|
||||
* Sven Hammarling, Nag Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE IF (N.EQ.1) THEN
|
||||
NORM = ABS(X(1))
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (X(IX).NE.ZERO) THEN
|
||||
ABSXI = ABS(X(IX))
|
||||
IF (SCALE.LT.ABSXI) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/ABSXI)**2
|
||||
SCALE = ABSXI
|
||||
ELSE
|
||||
SSQ = SSQ + (ABSXI/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
DNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DNRM2.
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,16 @@
|
||||
SUBROUTINE ERFIN
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
C>> 1994-11-11 CLL Typing all variables.
|
||||
C>> 1985-09-23 ERFIN Lawson Initial code.
|
||||
C
|
||||
integer idelta, ialpha
|
||||
COMMON/M77ERR/IDELTA,IALPHA
|
||||
SAVE /M77ERR/
|
||||
C
|
||||
1003 FORMAT(1X,72('$')/' ')
|
||||
PRINT 1003
|
||||
IF (IALPHA.GE.2) STOP
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,89 @@
|
||||
SUBROUTINE ERMSG(SUBNAM,INDIC,LEVEL,MSG,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
c>> 1995-11-22 ERMSG Krogh Got rid of multiple entries.
|
||||
c>> 1995-09-15 ERMSG Krogh Remove '0' in format.
|
||||
C>> 1994-11-11 ERMSG Krogh Declared all vars.
|
||||
C>> 1992-10-20 ERMSG WV Snyder added ERLSET, ERLGET
|
||||
C>> 1985-09-25 ERMSG Lawson Initial code.
|
||||
C
|
||||
C --------------------------------------------------------------
|
||||
C
|
||||
C Four entries: ERMSG, ERMSET, ERLGET, ERLSET
|
||||
C ERMSG initiates an error message. This subr also manages the
|
||||
C saved value IDELOC and the saved COMMON block M77ERR to
|
||||
C control the level of action. This is intended to be the
|
||||
C only subr that assigns a value to IALPHA in COMMON.
|
||||
C ERMSET resets IDELOC & IDELTA. ERLGET returns the last value
|
||||
C of LEVEL passed to ERMSG. ERLSET sets the last value of LEVEL.
|
||||
C ERLSET and ERLGET may be used together to determine the level
|
||||
C of error that occurs during execution of a routine that uses
|
||||
C ERMSG.
|
||||
C
|
||||
C --------------------------------------------------------------
|
||||
C SUBROUTINE ARGUMENTS
|
||||
C --------------------
|
||||
C SUBNAM A name that identifies the subprogram in which
|
||||
C the error occurs.
|
||||
C
|
||||
C INDIC An integer printed as part of the mininal error
|
||||
C message. It together with SUBNAM can be used to
|
||||
C uniquely identify an error.
|
||||
C
|
||||
C LEVEL The user sets LEVEL=2,0,or -2 to specify the
|
||||
C nominal action to be taken by ERMSG. The
|
||||
C subroutine ERMSG contains an internal variable
|
||||
C IDELTA, whose nominal value is zero. The
|
||||
C subroutine will compute IALPHA = LEVEL + IDELTA
|
||||
C and proceed as follows:
|
||||
C If (IALPHA.GE.2) Print message and STOP.
|
||||
C If (IALPHA=-1,0,1) Print message and return.
|
||||
C If (IALPHA.LE.-2) Just RETURN.
|
||||
C
|
||||
C MSG Message to be printed as part of the diagnostic.
|
||||
C
|
||||
C FLAG A single character,which when set to '.' will
|
||||
C call the subroutine ERFIN and will just RETURN
|
||||
C when set to any other character.
|
||||
C
|
||||
C --------------------------------------------------------------
|
||||
C
|
||||
C C.Lawson & S.Chan, JPL, 1983 Nov
|
||||
C
|
||||
C ------------------------------------------------------------------
|
||||
INTEGER IDELOC, LEVEL, IDELTA, IALPHA, INDIC
|
||||
COMMON /M77ERR/ IDELTA,IALPHA
|
||||
CHARACTER*(*) SUBNAM,MSG
|
||||
CHARACTER*1 FLAG
|
||||
SAVE /M77ERR/, IDELOC
|
||||
DATA IDELOC / 0 /
|
||||
1001 FORMAT(1X/' ',72('$')/' SUBPROGRAM ',A,' REPORTS ERROR NO. ',I4)
|
||||
c
|
||||
if (LEVEL .lt. -1000) then
|
||||
c Setting a new IDELOC.
|
||||
IDELTA = LEVEL + 10000
|
||||
IDELOC = IDELTA
|
||||
return
|
||||
end if
|
||||
IDELTA = IDELOC
|
||||
IALPHA = LEVEL + IDELTA
|
||||
IF (IALPHA.GE.-1) THEN
|
||||
c
|
||||
c Setting FILE = 'CON' works for MS/DOS systems.
|
||||
c
|
||||
c
|
||||
WRITE (*,1001) SUBNAM,INDIC
|
||||
WRITE (*,*) MSG
|
||||
IF (FLAG.EQ.'.') CALL ERFIN
|
||||
END IF
|
||||
RETURN
|
||||
C
|
||||
end
|
||||
C
|
||||
subroutine ERMSET(IDEL)
|
||||
integer IDEL
|
||||
c Call ERMSG to set IDELTA and IDELOC
|
||||
call ERMSG(' ', 0,IDEL-10000,' ',' ')
|
||||
RETURN
|
||||
END
|
||||
@@ -311,7 +311,7 @@
|
||||
call lnsrch(nunknowns,xpold,fsqsumold,
|
||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||
& check,funcnleq1,fequ)
|
||||
if(check.eq..true..or.check.eq..TRUE.)then
|
||||
if(check.eqv..true..or.check.eqv..TRUE.)then
|
||||
do i=1,nunknowns
|
||||
call reinitialization(x0min(i),xpold(i),
|
||||
& x0max(i),xp(i),6678)
|
||||
|
||||
@@ -0,0 +1,15 @@
|
||||
subroutine IERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
C>> 1990-01-18 CLL Added Integer stmt for VALUE. Typed all variables.
|
||||
C>> 1985-08-02 IERM1 Lawson Initial code.
|
||||
C
|
||||
integer INDIC, LEVEL, VALUE
|
||||
character*(*) SUBNAM,MSG,LABEL
|
||||
character*1 FLAG
|
||||
call ERMSG(SUBNAM,INDIC,LEVEL,MSG,',')
|
||||
call IERV1(LABEL,VALUE,FLAG)
|
||||
C
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,32 @@
|
||||
SUBROUTINE IERV1(LABEL,VALUE,FLAG)
|
||||
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
||||
c ALL RIGHTS RESERVED.
|
||||
c Based on Government Sponsored Research NAS7-03001.
|
||||
c>> 1995-11-15 IERV1 Krogh Moved format up for C conversion.
|
||||
C>> 1985-09-20 IERV1 Lawson Initial code.
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C SUBROUTINE ARGUMENTS
|
||||
C --------------------
|
||||
C LABEL An identifing name to be printed with VALUE.
|
||||
C
|
||||
C VALUE A integer to be printed.
|
||||
C
|
||||
C FLAG See write up for FLAG in ERMSG.
|
||||
C
|
||||
C ------------------------------------------------------------
|
||||
C
|
||||
COMMON/M77ERR/IDELTA,IALPHA
|
||||
INTEGER IDELTA,IALPHA,VALUE
|
||||
CHARACTER*(*) LABEL
|
||||
CHARACTER*1 FLAG
|
||||
SAVE /M77ERR/
|
||||
1002 FORMAT(3X,A,' = ',I5)
|
||||
C
|
||||
IF (IALPHA.GE.-1) THEN
|
||||
WRITE (*,1002) LABEL,VALUE
|
||||
IF (FLAG .EQ. '.') CALL ERFIN
|
||||
ENDIF
|
||||
RETURN
|
||||
C
|
||||
END
|
||||
Binary file not shown.
@@ -1,6 +1,6 @@
|
||||
subroutine nonsyssolver(funcnleq1,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
||||
& nunknowns,iwhichsolver)
|
||||
&f1dim_funcnleq1,DNQFJ_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
||||
&nunknowns,iwhichsolver)
|
||||
implicit none
|
||||
integer nunknowns,iwhichsolver
|
||||
double precision x0min(nunknowns),x0ori(nunknowns),
|
||||
@@ -27,30 +27,48 @@
|
||||
! =4 solved by fixed point method 4
|
||||
! =6 solved by broydn
|
||||
! =7 Solved by multiobjective minimization.
|
||||
! =8 Solved by DNQSOL
|
||||
! =-9999 Best approximation returned. Solution may not be accurate.
|
||||
! --------- Local variables ---------------------------------------
|
||||
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,
|
||||
& sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,
|
||||
& f1dim_funcnleq1
|
||||
integer i,irepeat,maxrepeats,IERR,notfound
|
||||
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,ran2,
|
||||
&sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,f1dim_funcnleq1,
|
||||
&D1MACH,Warray(3+(15*nunknowns+3*nunknowns*nunknowns)/2+1)
|
||||
integer i,irepeat,maxrepeats,IERR,notfound,IOPT(5),IDIMW
|
||||
intrinsic dble
|
||||
parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-7)
|
||||
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1
|
||||
parameter(maxrepeats=100,notfound=-9999)
|
||||
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
&DNQFJ_funcnleq1
|
||||
!-------------------------------------------------------------------
|
||||
stpmax=0.0d0
|
||||
sum=0.0d0
|
||||
do i=1, nunknowns
|
||||
x0(i)=x0ori(i)
|
||||
sum=sum+x0ori(i)*x0ori(i)
|
||||
stpmax=stpmax+
|
||||
& (x0min(i)-x0max(i))*(x0min(i)-x0max(i))
|
||||
xp(i)=x0ori(i)
|
||||
enddo
|
||||
stpmax=dsqrt(stpmax)/4.0d0
|
||||
scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
|
||||
! In Numerical Recipes, scldstpmax (STPMX) is 100
|
||||
scldstpmax=dmax1(100.0d0,scldstpmax)
|
||||
iwhichsolver=notfound
|
||||
TOLF=dsqrt(D1MACH(4))
|
||||
do irepeat=1,maxrepeats
|
||||
IDIMW=3+(15*nunknowns+3*nunknowns*nunknowns)/2+1
|
||||
do i=1,5
|
||||
IOPT(i)=0
|
||||
enddo
|
||||
IOPT(4)=1
|
||||
call DNQSOL(DNQFJ_funcnleq1,nunknowns,xp,fp,TOLF,
|
||||
&IOPT,Warray,IDIMW)
|
||||
if(IOPT(1).eq.0)then
|
||||
iwhichsolver=8
|
||||
return
|
||||
endif
|
||||
do i=1,nunknowns
|
||||
x0(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
|
||||
enddo
|
||||
stpmax=0.0d0
|
||||
sum=0.0d0
|
||||
do i=1, nunknowns
|
||||
sum=sum+x0(i)*x0(i)
|
||||
stpmax=stpmax+(x0min(i)-x0max(i))*(x0min(i)-x0max(i))
|
||||
enddo
|
||||
stpmax=dsqrt(stpmax)/4.0d0
|
||||
scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
|
||||
! In Numerical Recipes, scldstpmax (STPMX) is 100
|
||||
scldstpmax=dmax1(100.0d0,scldstpmax)
|
||||
call fixedpoint(funcnleq1,x0min,x0,xp,
|
||||
& x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
|
||||
if(iwhichsolver.ne.notfound)return
|
||||
@@ -82,6 +100,11 @@
|
||||
return
|
||||
endif
|
||||
endif
|
||||
|
||||
do i=1,nunknowns
|
||||
xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
|
||||
enddo
|
||||
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
fsqsum=0.0d0
|
||||
do i=1,nunknowns
|
||||
fsqsum=fsqsum+fp(i)*fp(i)
|
||||
@@ -89,11 +112,11 @@
|
||||
tp=fsqsum
|
||||
call nongradopt(nunknowns,fmin_funcnleq1,
|
||||
& f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
|
||||
! if(dabs(tp-fsqsum).gt.TOLF)then
|
||||
! call RepeatCompassSearch(nunknowns,xp,fsqsum,
|
||||
! & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
! & TOLF)
|
||||
! endif
|
||||
if(dabs(tp-fsqsum).gt.TOLF)then
|
||||
call RepeatCompassSearch(nunknowns,xp,fsqsum,
|
||||
& x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
||||
& TOLF)
|
||||
endif
|
||||
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||
tp=dabs(fp(1))
|
||||
do i=2,nunknowns
|
||||
@@ -109,7 +132,7 @@
|
||||
enddo
|
||||
if(IERR.eq.0)return
|
||||
do i=1,nunknowns
|
||||
x0(i)=xp(i)
|
||||
xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
|
||||
enddo
|
||||
enddo
|
||||
end subroutine nonsyssolver
|
||||
|
||||
@@ -0,0 +1,110 @@
|
||||
program main
|
||||
implicit none
|
||||
integer nsamp,mdim,mpc
|
||||
double precision sample(100,100),princomp(100,100),transdata(100,100)
|
||||
integer i,j,k
|
||||
sample(1,1)=2.5d0
|
||||
sample(2,1)=0.5d0
|
||||
sample(3,1)=2.2d0
|
||||
sample(4,1)=1.9d0
|
||||
sample(5,1)=3.1d0
|
||||
sample(6,1)=2.3d0
|
||||
sample(7,1)=2.0d0
|
||||
sample(8,1)=1.0d0
|
||||
sample(9,1)=1.5d0
|
||||
sample(10,1)=1.1d0
|
||||
sample(1,2)=2.4d0
|
||||
sample(2,2)=0.7d0
|
||||
sample(3,2)=2.9d0
|
||||
sample(4,2)=2.2d0
|
||||
sample(5,2)=3.0d0
|
||||
sample(6,2)=2.7d0
|
||||
sample(7,2)=1.6d0
|
||||
sample(8,2)=1.1d0
|
||||
sample(9,2)=1.6d0
|
||||
sample(10,2)=0.9d0
|
||||
nsamp=10
|
||||
mdim=2
|
||||
mpc=2
|
||||
call princompana(nsamp,mdim,sample,mpc,princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim))
|
||||
do i=1,mpc
|
||||
do j=1,nsamp
|
||||
write(*,*)j,princomp(j,1)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mdim
|
||||
do j=1,nsamp
|
||||
write(*,*)j,transdata(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine princompana(nsamp,mdim,sample,mpc,princomp,transdata)
|
||||
implicit none
|
||||
!-----------Inputs----------------------------------------
|
||||
!mpc is the number of principal components to keep
|
||||
integer nsamp,mdim,mpc
|
||||
double precision sample(nsamp,mdim)
|
||||
!-----------Outputs---------------------------------------
|
||||
!princomp is the projection of a sample on the principal axes
|
||||
!transdata is the data of the orginal sample filtered with mpc principal components
|
||||
double precision eigenvalue(mdim),eigenvector(mdim,mdim),sampmean(mdim),princomp(nsamp,mpc),transdata(nsamp,mdim)
|
||||
!---------------------------------------------------------
|
||||
integer i,j,k
|
||||
call geteigen(nsamp,mdim,sample(1:nsamp,1:mdim),eigenvalue,eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
do i=1,mpc
|
||||
do j=1,nsamp
|
||||
princomp(j,i)=0.0d0
|
||||
do k=1,mdim
|
||||
princomp(j,i)=princomp(j,i)+eigenvector(k,i)*sampadj(j,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do j=1,mdim
|
||||
do i=1,nsamp
|
||||
transdata(i,j)=sampmean(j)
|
||||
do k=1,mpc
|
||||
transdata(i,j)=transdata(i,j)+eigenvector(j,k)*princomp(i,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine geteigen(nsamp,mdim,sample,eigenvalue,eigenvector,sampmean,sampadj)
|
||||
integer nsamp,mdim
|
||||
double precision sample(nsamp,mdim),eigenvalue(mdim),eigenvector(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
|
||||
!Each column is an eigenvector. The first column corresponds to the largest eigenvalue and the last column corresponds
|
||||
!to the smallest eigenvalue
|
||||
call covariancematrix(nsamp,mdim,sample(1:nsamp,1:mdim),covarmatrix(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
call eigensystem
|
||||
return
|
||||
end
|
||||
|
||||
subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,sampmean,sampadj)
|
||||
implicit none
|
||||
integer nsamp, mdim
|
||||
double precision sample(nsamp,mdim),covarmatrix(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
|
||||
integer i,j,k
|
||||
do j=1,mdim
|
||||
sampmean(j)=0.0d0
|
||||
do i=1,nsamp
|
||||
sampmean(j)=sampmean(j)+sample(i,j)
|
||||
enddo
|
||||
sampmean(j)=sampmean(j)/dble(nsamp)
|
||||
do i=1,nsamp
|
||||
sampadj(i,j)=sample(i,j)-sampmean(j)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mdim
|
||||
do j=i,mdim
|
||||
covarmatrix(i,j)=0.0d0
|
||||
do k=1,nsamp
|
||||
covarmatrix(i,j)=covarmatrix(i,j)+sampadj(k,i)*sampadj(k,j)
|
||||
enddo
|
||||
enddo
|
||||
covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,112 @@
|
||||
! program main
|
||||
! implicit none
|
||||
! integer nsamp,mdim,mpc
|
||||
! double precision sample(100,100),princomp(100,100),
|
||||
! &transdata(100,100),x(100),eigenvector(100,100),eigenvalue(100)
|
||||
! integer i,j,k
|
||||
! open(unit=1,file='Table8.3.txt')
|
||||
! read(1,*)
|
||||
! nsamp=0
|
||||
!10 read(1,*,end=100)i,(x(j),j=1,6)
|
||||
! if(i.le.1)goto 10
|
||||
! nsamp=nsamp+1
|
||||
! do j=1,6
|
||||
! sample(nsamp,j)=x(j)
|
||||
! enddo
|
||||
! goto 10
|
||||
!100 close(1)
|
||||
! mdim=6
|
||||
! mpc=2
|
||||
! call princompana(nsamp,mdim,sample(1:nsamp,1:mdim),mpc,
|
||||
! &princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim),
|
||||
! &eigenvector(1:mdim,1:mdim),eigenvalue)
|
||||
! do i=1,mpc
|
||||
! do j=1,nsamp
|
||||
! write(*,*)j,princomp(j,i)
|
||||
! enddo
|
||||
! enddo
|
||||
! do i=1,mdim
|
||||
! do j=1,nsamp
|
||||
! write(*,*)j,transdata(j,i)
|
||||
! enddo
|
||||
! enddo
|
||||
! end
|
||||
|
||||
subroutine princompana(nsamp,mdim,sample,mpc,princomp,transdata,
|
||||
&eigenvector,eigenvalue)
|
||||
implicit none
|
||||
!-----------Inputs----------------------------------------
|
||||
!mpc is the number of principal components to keep
|
||||
integer nsamp,mdim,mpc
|
||||
double precision sample(nsamp,mdim)
|
||||
!-----------Outputs---------------------------------------
|
||||
!princomp is the projection of a sample on the principal axes
|
||||
!transdata is the data of the orginal sample filtered with mpc principal components
|
||||
double precision eigenvalue(mdim),eigenvector(mdim,mdim),
|
||||
&sampmean(mdim),princomp(nsamp,mpc),transdata(nsamp,mdim),
|
||||
&sampadj(nsamp,mdim)
|
||||
!---------------------------------------------------------
|
||||
integer i,j,k
|
||||
call geteigen(nsamp,mdim,sample(1:nsamp,1:mdim),eigenvalue,
|
||||
&eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
do i=1,mpc
|
||||
do j=1,nsamp
|
||||
princomp(j,i)=0.0d0
|
||||
do k=1,mdim
|
||||
princomp(j,i)=princomp(j,i)+eigenvector(k,i)*sampadj(j,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do j=1,mdim
|
||||
do i=1,nsamp
|
||||
transdata(i,j)=sampmean(j)
|
||||
do k=1,mpc
|
||||
transdata(i,j)=transdata(i,j)+eigenvector(j,k)*princomp(i,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine geteigen(nsamp,mdim,sample,eigenvalue,eigenvector,
|
||||
&sampmean,sampadj)
|
||||
integer nsamp,mdim
|
||||
double precision sample(nsamp,mdim),eigenvalue(mdim),
|
||||
&eigenvector(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
|
||||
!Each column is an eigenvector. The first column corresponds to the largest eigenvalue and the last column corresponds
|
||||
!to the smallest eigenvalue
|
||||
call covariancematrix(nsamp,mdim,sample(1:nsamp,1:mdim),
|
||||
&eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
|
||||
call eigen_sym_up(mdim,eigenvector(1:mdim,1:mdim),eigenvalue)
|
||||
return
|
||||
end
|
||||
|
||||
subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,
|
||||
&sampmean,sampadj)
|
||||
implicit none
|
||||
!covarmatrix is an upper trangle
|
||||
integer nsamp,mdim
|
||||
double precision sample(nsamp,mdim),covarmatrix(mdim,mdim),
|
||||
&sampmean(mdim),sampadj(nsamp,mdim)
|
||||
integer i,j,k
|
||||
do j=1,mdim
|
||||
sampmean(j)=0.0d0
|
||||
do i=1,nsamp
|
||||
sampmean(j)=sampmean(j)+sample(i,j)
|
||||
enddo
|
||||
sampmean(j)=sampmean(j)/dble(nsamp)
|
||||
do i=1,nsamp
|
||||
sampadj(i,j)=sample(i,j)-sampmean(j)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mdim
|
||||
do j=i,mdim
|
||||
covarmatrix(i,j)=0.0d0
|
||||
do k=1,nsamp
|
||||
covarmatrix(i,j)=covarmatrix(i,j)+sampadj(k,i)*sampadj(k,j)
|
||||
enddo
|
||||
covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,91 @@
|
||||
Group WDIM CIRCUM FBEYE EYEHD EARHD JAW
|
||||
1 13.5 57.2 19.5 12.5 14.0 11.0
|
||||
1 15.5 58.4 21.0 12.0 16.0 12.0
|
||||
1 14.5 55.9 19.0 10.0 13.0 12.0
|
||||
1 15.5 58.4 20.0 13.5 15.0 12.0
|
||||
1 14.5 58.4 20.0 13.0 15.5 12.0
|
||||
1 14.0 61.0 21.0 12.0 14.0 13.0
|
||||
1 15.0 58.4 19.5 13.5 15.5 13.0
|
||||
1 15.0 58.4 21.0 13.0 14.0 13.0
|
||||
1 15.5 59.7 20.5 13.5 14.5 12.5
|
||||
1 15.5 59.7 20.5 13.0 15.0 13.0
|
||||
1 15.0 57.2 19.0 14.0 14.5 11.5
|
||||
1 15.5 59.7 21.0 13.0 16.0 12.5
|
||||
1 16.0 57.2 19.0 14.0 14.5 12.0
|
||||
1 15.5 62.2 21.5 14.0 16.0 12.0
|
||||
1 15.5 57.2 19.5 13.5 15.0 12.0
|
||||
1 14.0 61.0 20.0 15.0 15.0 12.0
|
||||
1 14.5 58.4 20.0 12.0 14.5 12.0
|
||||
1 15.0 56.9 19.0 13.0 14.0 12.5
|
||||
1 15.5 59.7 20.0 12.5 14.0 12.5
|
||||
1 15.0 57.2 19.5 12.0 14.0 11.0
|
||||
1 15.0 56.9 19.0 12.0 13.0 12.0
|
||||
1 15.5 56.9 19.5 14.5 14.5 13.0
|
||||
1 17.5 63.5 21.5 14.0 15.5 13.5
|
||||
1 15.5 57.2 19.0 13.0 15.5 12.5
|
||||
1 15.5 61.0 20.5 12.0 13.0 12.5
|
||||
1 15.5 61.0 21.0 14.5 15.5 12.5
|
||||
1 15.5 63.5 21.8 14.5 16.5 13.5
|
||||
1 14.5 58.4 20.5 13.0 16.0 10.5
|
||||
1 15.5 56.9 20.0 13.5 14.0 12.0
|
||||
1 16.0 61.0 20.0 12.5 14.5 12.5
|
||||
2 15.5 60.0 21.1 10.3 13.4 12.4
|
||||
2 15.4 59.7 20.0 12.8 14.5 11.3
|
||||
2 15.1 59.7 20.2 11.4 14.1 12.1
|
||||
2 14.3 56.9 18.9 11.0 13.4 11.0
|
||||
2 14.8 58.0 20.1 9.6 11.1 11.7
|
||||
2 15.2 57.5 18.5 9.9 12.8 11.4
|
||||
2 15.4 58.0 20.8 10.2 12.8 11.9
|
||||
2 16.3 58.0 20.1 8.8 13.0 12.9
|
||||
2 15.5 57.0 19.6 10.5 13.9 11.8
|
||||
2 15.0 56.5 19.6 10.4 14.5 12.0
|
||||
2 15.5 57.2 20.0 11.2 13.4 12.4
|
||||
2 15.5 56.5 19.8 9.2 12.8 12.2
|
||||
2 15.7 57.5 19.8 11.8 12.6 12.5
|
||||
2 14.4 57.0 20.4 10.2 12.7 12.3
|
||||
2 14.9 54.8 18.5 11.2 13.8 11.3
|
||||
2 16.5 59.8 20.2 9.4 14.3 12.2
|
||||
2 15.5 56.1 18.8 9.8 13.8 12.6
|
||||
2 15.3 55.0 19.0 10.1 14.2 11.6
|
||||
2 14.5 55.6 19.3 12.0 12.6 11.6
|
||||
2 15.5 56.5 20.0 9.9 13.4 11.5
|
||||
2 15.2 55.0 19.3 9.9 14.4 11.9
|
||||
2 15.3 56.5 19.3 9.1 12.8 11.7
|
||||
2 15.3 56.8 20.2 8.6 14.2 11.5
|
||||
2 15.8 55.5 19.2 8.2 13.0 12.6
|
||||
2 14.8 57.0 20.2 9.8 13.8 10.5
|
||||
2 15.2 56.9 19.1 9.6 13.0 11.2
|
||||
2 15.9 58.8 21.0 8.6 13.5 11.8
|
||||
2 15.5 57.3 20.1 9.6 14.1 12.3
|
||||
2 16.5 58.0 19.5 9.0 13.9 13.3
|
||||
2 17.3 62.6 21.5 10.3 13.8 12.8
|
||||
3 14.9 56.5 20.4 7.4 13.0 12.0
|
||||
3 15.4 57.5 19.5 10.5 13.8 11.5
|
||||
3 15.3 55.4 19.2 9.7 13.3 11.5
|
||||
3 14.6 56.0 19.8 8.5 12.0 11.5
|
||||
3 16.2 56.5 19.5 11.5 14.5 11.8
|
||||
3 14.6 58.0 19.9 13.0 13.4 11.5
|
||||
3 15.9 56.7 18.7 10.8 12.8 12.6
|
||||
3 14.7 55.8 18.7 11.1 13.9 11.2
|
||||
3 15.5 58.5 19.4 11.5 13.4 11.9
|
||||
3 16.1 60.0 20.3 10.6 13.7 12.2
|
||||
3 15.2 57.8 19.9 10.4 13.5 11.4
|
||||
3 15.1 56.0 19.4 10.0 13.1 10.9
|
||||
3 15.9 59.8 20.5 12.0 13.6 11.5
|
||||
3 16.1 57.7 19.7 10.2 13.6 11.5
|
||||
3 15.7 58.7 20.7 11.3 13.6 11.3
|
||||
3 15.3 56.9 19.6 10.5 13.5 12.1
|
||||
3 15.3 56.9 19.5 9.9 14.0 12.1
|
||||
3 15.2 58.0 20.6 11.0 15.1 11.7
|
||||
3 16.6 59.3 19.9 12.1 14.6 12.1
|
||||
3 15.5 58.2 19.7 11.7 13.8 12.1
|
||||
3 15.8 57.5 18.9 11.8 14.7 11.8
|
||||
3 16.0 57.2 19.8 10.8 13.9 12.0
|
||||
3 15.4 57.0 19.8 11.3 14.0 11.4
|
||||
3 16.0 59.2 20.8 10.4 13.8 12.2
|
||||
3 15.4 57.6 19.6 10.2 13.9 11.7
|
||||
3 15.8 60.3 20.8 12.4 13.4 12.1
|
||||
3 15.4 55.0 18.8 10.7 14.2 10.8
|
||||
3 15.5 58.4 19.8 13.1 14.5 11.7
|
||||
3 15.7 59.0 20.4 12.1 13.0 12.7
|
||||
3 17.3 61.7 20.7 11.9 13.3 13.3
|
||||
@@ -0,0 +1,69 @@
|
||||
SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DA
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DAXPY constant times a vector plus a vector.
|
||||
* uses unrolled loops for increments equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (DA.EQ.0.0d0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,4)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DY(I) = DY(I) + DA*DX(I)
|
||||
END DO
|
||||
END IF
|
||||
IF (N.LT.4) RETURN
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,4
|
||||
DY(I) = DY(I) + DA*DX(I)
|
||||
DY(I+1) = DY(I+1) + DA*DX(I+1)
|
||||
DY(I+2) = DY(I+2) + DA*DX(I+2)
|
||||
DY(I+3) = DY(I+3) + DA*DX(I+3)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DY(IY) = DY(IY) + DA*DX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,70 @@
|
||||
SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DCOPY copies a vector, x, to a vector, y.
|
||||
* uses unrolled loops for increments equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,7)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DY(I) = DX(I)
|
||||
END DO
|
||||
IF (N.LT.7) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,7
|
||||
DY(I) = DX(I)
|
||||
DY(I+1) = DX(I+1)
|
||||
DY(I+2) = DX(I+2)
|
||||
DY(I+3) = DX(I+3)
|
||||
DY(I+4) = DX(I+4)
|
||||
DY(I+5) = DX(I+5)
|
||||
DY(I+6) = DX(I+6)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DY(IY) = DX(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,72 @@
|
||||
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DDOT forms the dot product of two vectors.
|
||||
* uses unrolled loops for increments equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
DDOT = 0.0d0
|
||||
DTEMP = 0.0d0
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DTEMP = DTEMP + DX(I)*DY(I)
|
||||
END DO
|
||||
IF (N.LT.5) THEN
|
||||
DDOT=DTEMP
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,5
|
||||
DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
|
||||
$ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments
|
||||
* not equal to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DTEMP = DTEMP + DX(IX)*DY(IY)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
DDOT = DTEMP
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,316 @@
|
||||
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,M,N
|
||||
CHARACTER TRANSA,TRANSB
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DGEMM performs one of the matrix-matrix operations
|
||||
*
|
||||
* C := alpha*op( A )*op( B ) + beta*C,
|
||||
*
|
||||
* where op( X ) is one of
|
||||
*
|
||||
* op( X ) = X or op( X ) = X**T,
|
||||
*
|
||||
* alpha and beta are scalars, and A, B and C are matrices, with op( A )
|
||||
* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* TRANSA - CHARACTER*1.
|
||||
* On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
* the matrix multiplication as follows:
|
||||
*
|
||||
* TRANSA = 'N' or 'n', op( A ) = A.
|
||||
*
|
||||
* TRANSA = 'T' or 't', op( A ) = A**T.
|
||||
*
|
||||
* TRANSA = 'C' or 'c', op( A ) = A**T.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANSB - CHARACTER*1.
|
||||
* On entry, TRANSB specifies the form of op( B ) to be used in
|
||||
* the matrix multiplication as follows:
|
||||
*
|
||||
* TRANSB = 'N' or 'n', op( B ) = B.
|
||||
*
|
||||
* TRANSB = 'T' or 't', op( B ) = B**T.
|
||||
*
|
||||
* TRANSB = 'C' or 'c', op( B ) = B**T.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of the matrix
|
||||
* op( A ) and of the matrix C. M must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of the matrix
|
||||
* op( B ) and the number of columns of the matrix C. N must be
|
||||
* at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* K - INTEGER.
|
||||
* On entry, K specifies the number of columns of the matrix
|
||||
* op( A ) and the number of rows of the matrix op( B ). K must
|
||||
* be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
* k when TRANSA = 'N' or 'n', and is m otherwise.
|
||||
* Before entry with TRANSA = 'N' or 'n', the leading m by k
|
||||
* part of the array A must contain the matrix A, otherwise
|
||||
* the leading k by m part of the array A must contain the
|
||||
* matrix A.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. When TRANSA = 'N' or 'n' then
|
||||
* LDA must be at least max( 1, m ), otherwise LDA must be at
|
||||
* least max( 1, k ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
|
||||
* n when TRANSB = 'N' or 'n', and is k otherwise.
|
||||
* Before entry with TRANSB = 'N' or 'n', the leading k by n
|
||||
* part of the array B must contain the matrix B, otherwise
|
||||
* the leading n by k part of the array B must contain the
|
||||
* matrix B.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDB - INTEGER.
|
||||
* On entry, LDB specifies the first dimension of B as declared
|
||||
* in the calling (sub) program. When TRANSB = 'N' or 'n' then
|
||||
* LDB must be at least max( 1, k ), otherwise LDB must be at
|
||||
* least max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then C need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
* Before entry, the leading m by n part of the array C must
|
||||
* contain the matrix C, except when beta is zero, in which
|
||||
* case C need not be set on entry.
|
||||
* On exit, the array C is overwritten by the m by n matrix
|
||||
* ( alpha*op( A )*op( B ) + beta*C ).
|
||||
*
|
||||
* LDC - INTEGER.
|
||||
* On entry, LDC specifies the first dimension of C as declared
|
||||
* in the calling (sub) program. LDC must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 3 Blas routine.
|
||||
*
|
||||
* -- Written on 8-February-1989.
|
||||
* Jack Dongarra, Argonne National Laboratory.
|
||||
* Iain Duff, AERE Harwell.
|
||||
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
* Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
|
||||
LOGICAL NOTA,NOTB
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Set NOTA and NOTB as true if A and B respectively are not
|
||||
* transposed and set NROWA, NCOLA and NROWB as the number of rows
|
||||
* and columns of A and the number of rows of B respectively.
|
||||
*
|
||||
NOTA = LSAME(TRANSA,'N')
|
||||
NOTB = LSAME(TRANSB,'N')
|
||||
IF (NOTA) THEN
|
||||
NROWA = M
|
||||
NCOLA = K
|
||||
ELSE
|
||||
NROWA = K
|
||||
NCOLA = M
|
||||
END IF
|
||||
IF (NOTB) THEN
|
||||
NROWB = K
|
||||
ELSE
|
||||
NROWB = N
|
||||
END IF
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
|
||||
+ (.NOT.LSAME(TRANSB,'T'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 8
|
||||
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
|
||||
INFO = 10
|
||||
ELSE IF (LDC.LT.MAX(1,M)) THEN
|
||||
INFO = 13
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGEMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And if alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (NOTB) THEN
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B + beta*C.
|
||||
*
|
||||
DO 90 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 50 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 60 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
DO 80 L = 1,K
|
||||
IF (B(L,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(L,J)
|
||||
DO 70 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
70 CONTINUE
|
||||
END IF
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + beta*C
|
||||
*
|
||||
DO 120 J = 1,N
|
||||
DO 110 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 100 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(L,J)
|
||||
100 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
110 CONTINUE
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (NOTA) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + beta*C
|
||||
*
|
||||
DO 170 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 130 I = 1,M
|
||||
C(I,J) = ZERO
|
||||
130 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 140 I = 1,M
|
||||
C(I,J) = BETA*C(I,J)
|
||||
140 CONTINUE
|
||||
END IF
|
||||
DO 160 L = 1,K
|
||||
IF (B(J,L).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(J,L)
|
||||
DO 150 I = 1,M
|
||||
C(I,J) = C(I,J) + TEMP*A(I,L)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
160 CONTINUE
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B**T + beta*C
|
||||
*
|
||||
DO 200 J = 1,N
|
||||
DO 190 I = 1,M
|
||||
TEMP = ZERO
|
||||
DO 180 L = 1,K
|
||||
TEMP = TEMP + A(L,I)*B(J,L)
|
||||
180 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP
|
||||
ELSE
|
||||
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
|
||||
END IF
|
||||
190 CONTINUE
|
||||
200 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGEMM .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,265 @@
|
||||
SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
CHARACTER TRANS
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DGEMV performs one of the matrix-vector operations
|
||||
*
|
||||
* y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are vectors and A is an
|
||||
* m by n matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* TRANS - CHARACTER*1.
|
||||
* On entry, TRANS specifies the operation to be performed as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
|
||||
*
|
||||
* TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
|
||||
*
|
||||
* TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of the matrix A.
|
||||
* M must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry, the leading m by n part of the array A must
|
||||
* contain the matrix of coefficients.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
|
||||
* and at least
|
||||
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
|
||||
* Before entry, the incremented array X must contain the
|
||||
* vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then Y need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of DIMENSION at least
|
||||
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
|
||||
* and at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
|
||||
* Before entry with BETA non-zero, the incremented array Y
|
||||
* must contain the vector y. On exit, Y is overwritten by the
|
||||
* updated vector y.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
* The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGEMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
|
||||
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set LENX and LENY, the lengths of the vectors x and y, and set
|
||||
* up the start points in X and Y.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
LENX = N
|
||||
LENY = M
|
||||
ELSE
|
||||
LENX = M
|
||||
LENY = N
|
||||
END IF
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (LENX-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (LENY-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,LENY
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,LENY
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,LENY
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,LENY
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form y := alpha*A*x + y.
|
||||
*
|
||||
JX = KX
|
||||
IF (INCY.EQ.1) THEN
|
||||
DO 60 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
DO 50 I = 1,M
|
||||
Y(I) = Y(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = ALPHA*X(JX)
|
||||
IY = KY
|
||||
DO 70 I = 1,M
|
||||
Y(IY) = Y(IY) + TEMP*A(I,J)
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y := alpha*A**T*x + y.
|
||||
*
|
||||
JY = KY
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP = ZERO
|
||||
DO 90 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
DO 120 J = 1,N
|
||||
TEMP = ZERO
|
||||
IX = KX
|
||||
DO 110 I = 1,M
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGEMV .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,162 @@
|
||||
SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,INCY,LDA,M,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DGER performs the rank 1 operation
|
||||
*
|
||||
* A := alpha*x*y**T + A,
|
||||
*
|
||||
* where alpha is a scalar, x is an m element vector, y is an n element
|
||||
* vector and A is an m by n matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of the matrix A.
|
||||
* M must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( m - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the m
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry, the leading m by n part of the array A must
|
||||
* contain the matrix of coefficients. On exit, A is
|
||||
* overwritten by the updated matrix.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JY,KX
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (M.LT.0) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,M)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DGER ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (INCY.GT.0) THEN
|
||||
JY = 1
|
||||
ELSE
|
||||
JY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
DO 10 I = 1,M
|
||||
A(I,J) = A(I,J) + X(I)*TEMP
|
||||
10 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (M-1)*INCX
|
||||
END IF
|
||||
DO 40 J = 1,N
|
||||
IF (Y(JY).NE.ZERO) THEN
|
||||
TEMP = ALPHA*Y(JY)
|
||||
IX = KX
|
||||
DO 30 I = 1,M
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DGER .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,67 @@
|
||||
DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DNRM2 returns the euclidean norm of a vector via the function
|
||||
* name, so that
|
||||
*
|
||||
* DNRM2 := sqrt( x'*x )
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* -- This version written on 25-October-1982.
|
||||
* Modified on 14-October-1993 to inline the call to DLASSQ.
|
||||
* Sven Hammarling, Nag Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
|
||||
INTEGER IX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS,SQRT
|
||||
* ..
|
||||
IF (N.LT.1 .OR. INCX.LT.1) THEN
|
||||
NORM = ZERO
|
||||
ELSE IF (N.EQ.1) THEN
|
||||
NORM = ABS(X(1))
|
||||
ELSE
|
||||
SCALE = ZERO
|
||||
SSQ = ONE
|
||||
* The following loop is equivalent to this call to the LAPACK
|
||||
* auxiliary routine:
|
||||
* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
|
||||
*
|
||||
DO 10 IX = 1,1 + (N-1)*INCX,INCX
|
||||
IF (X(IX).NE.ZERO) THEN
|
||||
ABSXI = ABS(X(IX))
|
||||
IF (SCALE.LT.ABSXI) THEN
|
||||
SSQ = ONE + SSQ* (SCALE/ABSXI)**2
|
||||
SCALE = ABSXI
|
||||
ELSE
|
||||
SSQ = SSQ + (ABSXI/SCALE)**2
|
||||
END IF
|
||||
END IF
|
||||
10 CONTINUE
|
||||
NORM = SCALE*SQRT(SSQ)
|
||||
END IF
|
||||
*
|
||||
DNRM2 = NORM
|
||||
RETURN
|
||||
*
|
||||
* End of DNRM2.
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,64 @@
|
||||
SUBROUTINE DSCAL(N,DA,DX,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION DA
|
||||
INTEGER INCX,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSCAL scales a vector by a constant.
|
||||
* uses unrolled loops for increment equal to one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 3/93 to return if incx .le. 0.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
INTEGER I,M,MP1,NINCX
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0 .OR. INCX.LE.0) RETURN
|
||||
IF (INCX.EQ.1) THEN
|
||||
*
|
||||
* code for increment equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,5)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DX(I) = DA*DX(I)
|
||||
END DO
|
||||
IF (N.LT.5) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,5
|
||||
DX(I) = DA*DX(I)
|
||||
DX(I+1) = DA*DX(I+1)
|
||||
DX(I+2) = DA*DX(I+2)
|
||||
DX(I+3) = DA*DX(I+3)
|
||||
DX(I+4) = DA*DX(I+4)
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for increment not equal to 1
|
||||
*
|
||||
NINCX = N*INCX
|
||||
DO I = 1,NINCX,INCX
|
||||
DX(I) = DA*DX(I)
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,77 @@
|
||||
SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,INCY,N
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION DX(*),DY(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* interchanges two vectors.
|
||||
* uses unrolled loops for increments equal one.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* jack dongarra, linpack, 3/11/78.
|
||||
* modified 12/3/93, array(1) declarations changed to array(*)
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION DTEMP
|
||||
INTEGER I,IX,IY,M,MP1
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MOD
|
||||
* ..
|
||||
IF (N.LE.0) RETURN
|
||||
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
|
||||
*
|
||||
* code for both increments equal to 1
|
||||
*
|
||||
*
|
||||
* clean-up loop
|
||||
*
|
||||
M = MOD(N,3)
|
||||
IF (M.NE.0) THEN
|
||||
DO I = 1,M
|
||||
DTEMP = DX(I)
|
||||
DX(I) = DY(I)
|
||||
DY(I) = DTEMP
|
||||
END DO
|
||||
IF (N.LT.3) RETURN
|
||||
END IF
|
||||
MP1 = M + 1
|
||||
DO I = MP1,N,3
|
||||
DTEMP = DX(I)
|
||||
DX(I) = DY(I)
|
||||
DY(I) = DTEMP
|
||||
DTEMP = DX(I+1)
|
||||
DX(I+1) = DY(I+1)
|
||||
DY(I+1) = DTEMP
|
||||
DTEMP = DX(I+2)
|
||||
DX(I+2) = DY(I+2)
|
||||
DY(I+2) = DTEMP
|
||||
END DO
|
||||
ELSE
|
||||
*
|
||||
* code for unequal increments or equal increments not equal
|
||||
* to 1
|
||||
*
|
||||
IX = 1
|
||||
IY = 1
|
||||
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
|
||||
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
|
||||
DO I = 1,N
|
||||
DTEMP = DX(IX)
|
||||
DX(IX) = DY(IY)
|
||||
DY(IY) = DTEMP
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
END DO
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,266 @@
|
||||
SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYMV performs the matrix-vector operation
|
||||
*
|
||||
* y := alpha*A*x + beta*y,
|
||||
*
|
||||
* where alpha and beta are scalars, x and y are n element vectors and
|
||||
* A is an n by n symmetric matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the array A is to be referenced as
|
||||
* follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* lower triangular part of A is not referenced.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* upper triangular part of A is not referenced.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta. When BETA is
|
||||
* supplied as zero then Y need not be set on input.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y. On exit, Y is overwritten by the updated
|
||||
* vector y.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
* The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 10
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y.
|
||||
*
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
* First form y := beta*y.
|
||||
*
|
||||
IF (BETA.NE.ONE) THEN
|
||||
IF (INCY.EQ.1) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 10 I = 1,N
|
||||
Y(I) = ZERO
|
||||
10 CONTINUE
|
||||
ELSE
|
||||
DO 20 I = 1,N
|
||||
Y(I) = BETA*Y(I)
|
||||
20 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IY = KY
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 30 I = 1,N
|
||||
Y(IY) = ZERO
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
ELSE
|
||||
DO 40 I = 1,N
|
||||
Y(IY) = BETA*Y(IY)
|
||||
IY = IY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
IF (ALPHA.EQ.ZERO) RETURN
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form y when A is stored in upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
DO 50 I = 1,J - 1
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(I)
|
||||
50 CONTINUE
|
||||
Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 80 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 70 I = 1,J - 1
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(IX)
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form y when A is stored in lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 100 J = 1,N
|
||||
TEMP1 = ALPHA*X(J)
|
||||
TEMP2 = ZERO
|
||||
Y(J) = Y(J) + TEMP1*A(J,J)
|
||||
DO 90 I = J + 1,N
|
||||
Y(I) = Y(I) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
Y(J) = Y(J) + ALPHA*TEMP2
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
JY = KY
|
||||
DO 120 J = 1,N
|
||||
TEMP1 = ALPHA*X(JX)
|
||||
TEMP2 = ZERO
|
||||
Y(JY) = Y(JY) + TEMP1*A(J,J)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 110 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
Y(IY) = Y(IY) + TEMP1*A(I,J)
|
||||
TEMP2 = TEMP2 + A(I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
Y(JY) = Y(JY) + ALPHA*TEMP2
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
120 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYMV .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,233 @@
|
||||
SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER INCX,INCY,LDA,N
|
||||
CHARACTER UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYR2 performs the symmetric rank 2 operation
|
||||
*
|
||||
* A := alpha*x*y**T + alpha*y*x**T + A,
|
||||
*
|
||||
* where alpha is a scalar, x and y are n element vectors and A is an n
|
||||
* by n symmetric matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the array A is to be referenced as
|
||||
* follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' Only the upper triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* UPLO = 'L' or 'l' Only the lower triangular part of A
|
||||
* is to be referenced.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Y - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCY ) ).
|
||||
* Before entry, the incremented array Y must contain the n
|
||||
* element vector y.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* INCY - INTEGER.
|
||||
* On entry, INCY specifies the increment for the elements of
|
||||
* Y. INCY must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* lower triangular part of A is not referenced. On exit, the
|
||||
* upper triangular part of the array A is overwritten by the
|
||||
* upper triangular part of the updated matrix.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* upper triangular part of A is not referenced. On exit, the
|
||||
* lower triangular part of the array A is overwritten by the
|
||||
* lower triangular part of the updated matrix.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 2
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (INCY.EQ.0) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 9
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYR2 ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
|
||||
*
|
||||
* Set up the start points in X and Y if the increments are not both
|
||||
* unity.
|
||||
*
|
||||
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
|
||||
IF (INCX.GT.0) THEN
|
||||
KX = 1
|
||||
ELSE
|
||||
KX = 1 - (N-1)*INCX
|
||||
END IF
|
||||
IF (INCY.GT.0) THEN
|
||||
KY = 1
|
||||
ELSE
|
||||
KY = 1 - (N-1)*INCY
|
||||
END IF
|
||||
JX = KX
|
||||
JY = KY
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through the triangular part
|
||||
* of A.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
*
|
||||
* Form A when A is stored in the upper triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 20 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
DO 10 I = 1,J
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
10 CONTINUE
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = KX
|
||||
IY = KY
|
||||
DO 30 I = 1,J
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
30 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form A when A is stored in the lower triangle.
|
||||
*
|
||||
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
|
||||
DO 60 J = 1,N
|
||||
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(J)
|
||||
TEMP2 = ALPHA*X(J)
|
||||
DO 50 I = J,N
|
||||
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
|
||||
50 CONTINUE
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*Y(JY)
|
||||
TEMP2 = ALPHA*X(JX)
|
||||
IX = JX
|
||||
IY = JY
|
||||
DO 70 I = J,N
|
||||
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
|
||||
IX = IX + INCX
|
||||
IY = IY + INCY
|
||||
70 CONTINUE
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
JY = JY + INCY
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR2 .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,329 @@
|
||||
SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA,BETA
|
||||
INTEGER K,LDA,LDB,LDC,N
|
||||
CHARACTER TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DSYR2K performs one of the symmetric rank 2k operations
|
||||
*
|
||||
* C := alpha*A*B**T + alpha*B*A**T + beta*C,
|
||||
*
|
||||
* or
|
||||
*
|
||||
* C := alpha*A**T*B + alpha*B**T*A + beta*C,
|
||||
*
|
||||
* where alpha and beta are scalars, C is an n by n symmetric matrix
|
||||
* and A and B are n by k matrices in the first case and k by n
|
||||
* matrices in the second case.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the upper or lower
|
||||
* triangular part of the array C is to be referenced as
|
||||
* follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' Only the upper triangular part of C
|
||||
* is to be referenced.
|
||||
*
|
||||
* UPLO = 'L' or 'l' Only the lower triangular part of C
|
||||
* is to be referenced.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANS - CHARACTER*1.
|
||||
* On entry, TRANS specifies the operation to be performed as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T +
|
||||
* beta*C.
|
||||
*
|
||||
* TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
|
||||
* beta*C.
|
||||
*
|
||||
* TRANS = 'C' or 'c' C := alpha*A**T*B + alpha*B**T*A +
|
||||
* beta*C.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix C. N must be
|
||||
* at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* K - INTEGER.
|
||||
* On entry with TRANS = 'N' or 'n', K specifies the number
|
||||
* of columns of the matrices A and B, and on entry with
|
||||
* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
|
||||
* of rows of the matrices A and B. K must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
|
||||
* k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
* Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
* part of the array A must contain the matrix A, otherwise
|
||||
* the leading k by n part of the array A must contain the
|
||||
* matrix A.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
* then LDA must be at least max( 1, n ), otherwise LDA must
|
||||
* be at least max( 1, k ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
|
||||
* k when TRANS = 'N' or 'n', and is n otherwise.
|
||||
* Before entry with TRANS = 'N' or 'n', the leading n by k
|
||||
* part of the array B must contain the matrix B, otherwise
|
||||
* the leading k by n part of the array B must contain the
|
||||
* matrix B.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDB - INTEGER.
|
||||
* On entry, LDB specifies the first dimension of B as declared
|
||||
* in the calling (sub) program. When TRANS = 'N' or 'n'
|
||||
* then LDB must be at least max( 1, n ), otherwise LDB must
|
||||
* be at least max( 1, k ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* BETA - DOUBLE PRECISION.
|
||||
* On entry, BETA specifies the scalar beta.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array C must contain the upper
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* lower triangular part of C is not referenced. On exit, the
|
||||
* upper triangular part of the array C is overwritten by the
|
||||
* upper triangular part of the updated matrix.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array C must contain the lower
|
||||
* triangular part of the symmetric matrix and the strictly
|
||||
* upper triangular part of C is not referenced. On exit, the
|
||||
* lower triangular part of the array C is overwritten by the
|
||||
* lower triangular part of the updated matrix.
|
||||
*
|
||||
* LDC - INTEGER.
|
||||
* On entry, LDC specifies the first dimension of C as declared
|
||||
* in the calling (sub) program. LDC must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 3 Blas routine.
|
||||
*
|
||||
*
|
||||
* -- Written on 8-February-1989.
|
||||
* Jack Dongarra, Argonne National Laboratory.
|
||||
* Iain Duff, AERE Harwell.
|
||||
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
* Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP1,TEMP2
|
||||
INTEGER I,INFO,J,L,NROWA
|
||||
LOGICAL UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
NROWA = N
|
||||
ELSE
|
||||
NROWA = K
|
||||
END IF
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANS,'C'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 3
|
||||
ELSE IF (K.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 7
|
||||
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDC.LT.MAX(1,N)) THEN
|
||||
INFO = 12
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DSYR2K',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
|
||||
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
IF (UPPER) THEN
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
DO 40 J = 1,N
|
||||
DO 30 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 60 J = 1,N
|
||||
DO 50 I = J,N
|
||||
C(I,J) = ZERO
|
||||
50 CONTINUE
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form C := alpha*A*B**T + alpha*B*A**T + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 130 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 90 I = 1,J
|
||||
C(I,J) = ZERO
|
||||
90 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 100 I = 1,J
|
||||
C(I,J) = BETA*C(I,J)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
DO 120 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 110 I = 1,J
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
110 CONTINUE
|
||||
END IF
|
||||
120 CONTINUE
|
||||
130 CONTINUE
|
||||
ELSE
|
||||
DO 180 J = 1,N
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
DO 140 I = J,N
|
||||
C(I,J) = ZERO
|
||||
140 CONTINUE
|
||||
ELSE IF (BETA.NE.ONE) THEN
|
||||
DO 150 I = J,N
|
||||
C(I,J) = BETA*C(I,J)
|
||||
150 CONTINUE
|
||||
END IF
|
||||
DO 170 L = 1,K
|
||||
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
|
||||
TEMP1 = ALPHA*B(J,L)
|
||||
TEMP2 = ALPHA*A(J,L)
|
||||
DO 160 I = J,N
|
||||
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
|
||||
+ B(I,L)*TEMP2
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form C := alpha*A**T*B + alpha*B**T*A + C.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 210 J = 1,N
|
||||
DO 200 I = 1,J
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 190 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
190 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ELSE
|
||||
DO 240 J = 1,N
|
||||
DO 230 I = J,N
|
||||
TEMP1 = ZERO
|
||||
TEMP2 = ZERO
|
||||
DO 220 L = 1,K
|
||||
TEMP1 = TEMP1 + A(L,I)*B(L,J)
|
||||
TEMP2 = TEMP2 + B(L,I)*A(L,J)
|
||||
220 CONTINUE
|
||||
IF (BETA.EQ.ZERO) THEN
|
||||
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
|
||||
ELSE
|
||||
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
|
||||
+ ALPHA*TEMP2
|
||||
END IF
|
||||
230 CONTINUE
|
||||
240 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DSYR2K.
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,349 @@
|
||||
SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
|
||||
* .. Scalar Arguments ..
|
||||
DOUBLE PRECISION ALPHA
|
||||
INTEGER LDA,LDB,M,N
|
||||
CHARACTER DIAG,SIDE,TRANSA,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),B(LDB,*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTRMM performs one of the matrix-matrix operations
|
||||
*
|
||||
* B := alpha*op( A )*B, or B := alpha*B*op( A ),
|
||||
*
|
||||
* where alpha is a scalar, B is an m by n matrix, A is a unit, or
|
||||
* non-unit, upper or lower triangular matrix and op( A ) is one of
|
||||
*
|
||||
* op( A ) = A or op( A ) = A**T.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* SIDE - CHARACTER*1.
|
||||
* On entry, SIDE specifies whether op( A ) multiplies B from
|
||||
* the left or right as follows:
|
||||
*
|
||||
* SIDE = 'L' or 'l' B := alpha*op( A )*B.
|
||||
*
|
||||
* SIDE = 'R' or 'r' B := alpha*B*op( A ).
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the matrix A is an upper or
|
||||
* lower triangular matrix as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*
|
||||
* UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANSA - CHARACTER*1.
|
||||
* On entry, TRANSA specifies the form of op( A ) to be used in
|
||||
* the matrix multiplication as follows:
|
||||
*
|
||||
* TRANSA = 'N' or 'n' op( A ) = A.
|
||||
*
|
||||
* TRANSA = 'T' or 't' op( A ) = A**T.
|
||||
*
|
||||
* TRANSA = 'C' or 'c' op( A ) = A**T.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* DIAG - CHARACTER*1.
|
||||
* On entry, DIAG specifies whether or not A is unit triangular
|
||||
* as follows:
|
||||
*
|
||||
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*
|
||||
* DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
* triangular.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* M - INTEGER.
|
||||
* On entry, M specifies the number of rows of B. M must be at
|
||||
* least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the number of columns of B. N must be
|
||||
* at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* ALPHA - DOUBLE PRECISION.
|
||||
* On entry, ALPHA specifies the scalar alpha. When alpha is
|
||||
* zero then A is not referenced and B need not be set before
|
||||
* entry.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
|
||||
* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
|
||||
* Before entry with UPLO = 'U' or 'u', the leading k by k
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular matrix and the strictly lower triangular part of
|
||||
* A is not referenced.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading k by k
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular matrix and the strictly upper triangular part of
|
||||
* A is not referenced.
|
||||
* Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
* A are not referenced either, but are assumed to be unity.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. When SIDE = 'L' or 'l' then
|
||||
* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
|
||||
* then LDA must be at least max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
|
||||
* Before entry, the leading m by n part of the array B must
|
||||
* contain the matrix B, and on exit is overwritten by the
|
||||
* transformed matrix.
|
||||
*
|
||||
* LDB - INTEGER.
|
||||
* On entry, LDB specifies the first dimension of B as declared
|
||||
* in the calling (sub) program. LDB must be at least
|
||||
* max( 1, m ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 3 Blas routine.
|
||||
*
|
||||
* -- Written on 8-February-1989.
|
||||
* Jack Dongarra, Argonne National Laboratory.
|
||||
* Iain Duff, AERE Harwell.
|
||||
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
|
||||
* Sven Hammarling, Numerical Algorithms Group Ltd.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,J,K,NROWA
|
||||
LOGICAL LSIDE,NOUNIT,UPPER
|
||||
* ..
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ONE,ZERO
|
||||
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
LSIDE = LSAME(SIDE,'L')
|
||||
IF (LSIDE) THEN
|
||||
NROWA = M
|
||||
ELSE
|
||||
NROWA = N
|
||||
END IF
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
UPPER = LSAME(UPLO,'U')
|
||||
*
|
||||
INFO = 0
|
||||
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
|
||||
INFO = 1
|
||||
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
|
||||
INFO = 2
|
||||
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'T')) .AND.
|
||||
+ (.NOT.LSAME(TRANSA,'C'))) THEN
|
||||
INFO = 3
|
||||
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
|
||||
INFO = 4
|
||||
ELSE IF (M.LT.0) THEN
|
||||
INFO = 5
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 6
|
||||
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
|
||||
INFO = 9
|
||||
ELSE IF (LDB.LT.MAX(1,M)) THEN
|
||||
INFO = 11
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRMM ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (M.EQ.0 .OR. N.EQ.0) RETURN
|
||||
*
|
||||
* And when alpha.eq.zero.
|
||||
*
|
||||
IF (ALPHA.EQ.ZERO) THEN
|
||||
DO 20 J = 1,N
|
||||
DO 10 I = 1,M
|
||||
B(I,J) = ZERO
|
||||
10 CONTINUE
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Start the operations.
|
||||
*
|
||||
IF (LSIDE) THEN
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*A*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 50 J = 1,N
|
||||
DO 40 K = 1,M
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
DO 30 I = 1,K - 1
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
B(K,J) = TEMP
|
||||
END IF
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
ELSE
|
||||
DO 80 J = 1,N
|
||||
DO 70 K = M,1,-1
|
||||
IF (B(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*B(K,J)
|
||||
B(K,J) = TEMP
|
||||
IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
|
||||
DO 60 I = K + 1,M
|
||||
B(I,J) = B(I,J) + TEMP*A(I,K)
|
||||
60 CONTINUE
|
||||
END IF
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*A**T*B.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 110 J = 1,N
|
||||
DO 100 I = M,1,-1
|
||||
TEMP = B(I,J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 90 K = 1,I - 1
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
90 CONTINUE
|
||||
B(I,J) = ALPHA*TEMP
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
ELSE
|
||||
DO 140 J = 1,N
|
||||
DO 130 I = 1,M
|
||||
TEMP = B(I,J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(I,I)
|
||||
DO 120 K = I + 1,M
|
||||
TEMP = TEMP + A(K,I)*B(K,J)
|
||||
120 CONTINUE
|
||||
B(I,J) = ALPHA*TEMP
|
||||
130 CONTINUE
|
||||
140 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
IF (LSAME(TRANSA,'N')) THEN
|
||||
*
|
||||
* Form B := alpha*B*A.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 180 J = N,1,-1
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
150 CONTINUE
|
||||
DO 170 K = 1,J - 1
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 160 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
160 CONTINUE
|
||||
END IF
|
||||
170 CONTINUE
|
||||
180 CONTINUE
|
||||
ELSE
|
||||
DO 220 J = 1,N
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 190 I = 1,M
|
||||
B(I,J) = TEMP*B(I,J)
|
||||
190 CONTINUE
|
||||
DO 210 K = J + 1,N
|
||||
IF (A(K,J).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(K,J)
|
||||
DO 200 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
200 CONTINUE
|
||||
END IF
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form B := alpha*B*A**T.
|
||||
*
|
||||
IF (UPPER) THEN
|
||||
DO 260 K = 1,N
|
||||
DO 240 J = 1,K - 1
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
DO 230 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
230 CONTINUE
|
||||
END IF
|
||||
240 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 250 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
250 CONTINUE
|
||||
END IF
|
||||
260 CONTINUE
|
||||
ELSE
|
||||
DO 300 K = N,1,-1
|
||||
DO 280 J = K + 1,N
|
||||
IF (A(J,K).NE.ZERO) THEN
|
||||
TEMP = ALPHA*A(J,K)
|
||||
DO 270 I = 1,M
|
||||
B(I,J) = B(I,J) + TEMP*B(I,K)
|
||||
270 CONTINUE
|
||||
END IF
|
||||
280 CONTINUE
|
||||
TEMP = ALPHA
|
||||
IF (NOUNIT) TEMP = TEMP*A(K,K)
|
||||
IF (TEMP.NE.ONE) THEN
|
||||
DO 290 I = 1,M
|
||||
B(I,K) = TEMP*B(I,K)
|
||||
290 CONTINUE
|
||||
END IF
|
||||
300 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRMM .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,282 @@
|
||||
SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INCX,LDA,N
|
||||
CHARACTER DIAG,TRANS,UPLO
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
DOUBLE PRECISION A(LDA,*),X(*)
|
||||
* ..
|
||||
*
|
||||
* Purpose
|
||||
* =======
|
||||
*
|
||||
* DTRMV performs one of the matrix-vector operations
|
||||
*
|
||||
* x := A*x, or x := A**T*x,
|
||||
*
|
||||
* where x is an n element vector and A is an n by n unit, or non-unit,
|
||||
* upper or lower triangular matrix.
|
||||
*
|
||||
* Arguments
|
||||
* ==========
|
||||
*
|
||||
* UPLO - CHARACTER*1.
|
||||
* On entry, UPLO specifies whether the matrix is an upper or
|
||||
* lower triangular matrix as follows:
|
||||
*
|
||||
* UPLO = 'U' or 'u' A is an upper triangular matrix.
|
||||
*
|
||||
* UPLO = 'L' or 'l' A is a lower triangular matrix.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* TRANS - CHARACTER*1.
|
||||
* On entry, TRANS specifies the operation to be performed as
|
||||
* follows:
|
||||
*
|
||||
* TRANS = 'N' or 'n' x := A*x.
|
||||
*
|
||||
* TRANS = 'T' or 't' x := A**T*x.
|
||||
*
|
||||
* TRANS = 'C' or 'c' x := A**T*x.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* DIAG - CHARACTER*1.
|
||||
* On entry, DIAG specifies whether or not A is unit
|
||||
* triangular as follows:
|
||||
*
|
||||
* DIAG = 'U' or 'u' A is assumed to be unit triangular.
|
||||
*
|
||||
* DIAG = 'N' or 'n' A is not assumed to be unit
|
||||
* triangular.
|
||||
*
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* N - INTEGER.
|
||||
* On entry, N specifies the order of the matrix A.
|
||||
* N must be at least zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
|
||||
* Before entry with UPLO = 'U' or 'u', the leading n by n
|
||||
* upper triangular part of the array A must contain the upper
|
||||
* triangular matrix and the strictly lower triangular part of
|
||||
* A is not referenced.
|
||||
* Before entry with UPLO = 'L' or 'l', the leading n by n
|
||||
* lower triangular part of the array A must contain the lower
|
||||
* triangular matrix and the strictly upper triangular part of
|
||||
* A is not referenced.
|
||||
* Note that when DIAG = 'U' or 'u', the diagonal elements of
|
||||
* A are not referenced either, but are assumed to be unity.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* LDA - INTEGER.
|
||||
* On entry, LDA specifies the first dimension of A as declared
|
||||
* in the calling (sub) program. LDA must be at least
|
||||
* max( 1, n ).
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* X - DOUBLE PRECISION array of dimension at least
|
||||
* ( 1 + ( n - 1 )*abs( INCX ) ).
|
||||
* Before entry, the incremented array X must contain the n
|
||||
* element vector x. On exit, X is overwritten with the
|
||||
* tranformed vector x.
|
||||
*
|
||||
* INCX - INTEGER.
|
||||
* On entry, INCX specifies the increment for the elements of
|
||||
* X. INCX must not be zero.
|
||||
* Unchanged on exit.
|
||||
*
|
||||
* Further Details
|
||||
* ===============
|
||||
*
|
||||
* Level 2 Blas routine.
|
||||
* The vector and matrix arguments are not referenced when N = 0, or M = 0
|
||||
*
|
||||
* -- Written on 22-October-1986.
|
||||
* Jack Dongarra, Argonne National Lab.
|
||||
* Jeremy Du Croz, Nag Central Office.
|
||||
* Sven Hammarling, Nag Central Office.
|
||||
* Richard Hanson, Sandia National Labs.
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
DOUBLE PRECISION ZERO
|
||||
PARAMETER (ZERO=0.0D+0)
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
DOUBLE PRECISION TEMP
|
||||
INTEGER I,INFO,IX,J,JX,KX
|
||||
LOGICAL NOUNIT
|
||||
* ..
|
||||
* .. External Functions ..
|
||||
LOGICAL LSAME
|
||||
EXTERNAL LSAME
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC MAX
|
||||
* ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
|
||||
INFO = 1
|
||||
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
|
||||
+ .NOT.LSAME(TRANS,'C')) THEN
|
||||
INFO = 2
|
||||
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
|
||||
INFO = 3
|
||||
ELSE IF (N.LT.0) THEN
|
||||
INFO = 4
|
||||
ELSE IF (LDA.LT.MAX(1,N)) THEN
|
||||
INFO = 6
|
||||
ELSE IF (INCX.EQ.0) THEN
|
||||
INFO = 8
|
||||
END IF
|
||||
IF (INFO.NE.0) THEN
|
||||
CALL XERBLA('DTRMV ',INFO)
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Quick return if possible.
|
||||
*
|
||||
IF (N.EQ.0) RETURN
|
||||
*
|
||||
NOUNIT = LSAME(DIAG,'N')
|
||||
*
|
||||
* Set up the start point in X if the increment is not unity. This
|
||||
* will be ( N - 1 )*INCX too small for descending loops.
|
||||
*
|
||||
IF (INCX.LE.0) THEN
|
||||
KX = 1 - (N-1)*INCX
|
||||
ELSE IF (INCX.NE.1) THEN
|
||||
KX = 1
|
||||
END IF
|
||||
*
|
||||
* Start the operations. In this version the elements of A are
|
||||
* accessed sequentially with one pass through A.
|
||||
*
|
||||
IF (LSAME(TRANS,'N')) THEN
|
||||
*
|
||||
* Form x := A*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 20 J = 1,N
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 10 I = 1,J - 1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
10 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
20 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 40 J = 1,N
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 30 I = 1,J - 1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX + INCX
|
||||
30 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX + INCX
|
||||
40 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 60 J = N,1,-1
|
||||
IF (X(J).NE.ZERO) THEN
|
||||
TEMP = X(J)
|
||||
DO 50 I = N,J + 1,-1
|
||||
X(I) = X(I) + TEMP*A(I,J)
|
||||
50 CONTINUE
|
||||
IF (NOUNIT) X(J) = X(J)*A(J,J)
|
||||
END IF
|
||||
60 CONTINUE
|
||||
ELSE
|
||||
KX = KX + (N-1)*INCX
|
||||
JX = KX
|
||||
DO 80 J = N,1,-1
|
||||
IF (X(JX).NE.ZERO) THEN
|
||||
TEMP = X(JX)
|
||||
IX = KX
|
||||
DO 70 I = N,J + 1,-1
|
||||
X(IX) = X(IX) + TEMP*A(I,J)
|
||||
IX = IX - INCX
|
||||
70 CONTINUE
|
||||
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
|
||||
END IF
|
||||
JX = JX - INCX
|
||||
80 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
ELSE
|
||||
*
|
||||
* Form x := A**T*x.
|
||||
*
|
||||
IF (LSAME(UPLO,'U')) THEN
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 100 J = N,1,-1
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 90 I = J - 1,1,-1
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
90 CONTINUE
|
||||
X(J) = TEMP
|
||||
100 CONTINUE
|
||||
ELSE
|
||||
JX = KX + (N-1)*INCX
|
||||
DO 120 J = N,1,-1
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 110 I = J - 1,1,-1
|
||||
IX = IX - INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
110 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX - INCX
|
||||
120 CONTINUE
|
||||
END IF
|
||||
ELSE
|
||||
IF (INCX.EQ.1) THEN
|
||||
DO 140 J = 1,N
|
||||
TEMP = X(J)
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 130 I = J + 1,N
|
||||
TEMP = TEMP + A(I,J)*X(I)
|
||||
130 CONTINUE
|
||||
X(J) = TEMP
|
||||
140 CONTINUE
|
||||
ELSE
|
||||
JX = KX
|
||||
DO 160 J = 1,N
|
||||
TEMP = X(JX)
|
||||
IX = JX
|
||||
IF (NOUNIT) TEMP = TEMP*A(J,J)
|
||||
DO 150 I = J + 1,N
|
||||
IX = IX + INCX
|
||||
TEMP = TEMP + A(I,J)*X(IX)
|
||||
150 CONTINUE
|
||||
X(JX) = TEMP
|
||||
JX = JX + INCX
|
||||
160 CONTINUE
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of DTRMV .
|
||||
*
|
||||
END
|
||||
@@ -0,0 +1,38 @@
|
||||
SUBROUTINE svdfit(x,y,sig,ndata,a,ma,u,v,w,mp,np,chisq,funcs)
|
||||
INTEGER ma,mp,ndata,np,NMAX,MMAX
|
||||
REAL chisq,a(ma),sig(ndata),u(mp,np),v(np,np),w(np),x(ndata),
|
||||
*y(ndata),TOL
|
||||
EXTERNAL funcs
|
||||
PARAMETER (NMAX=1000,MMAX=50,TOL=1.e-5)
|
||||
CU USES svbksb,svdcmp
|
||||
INTEGER i,j
|
||||
REAL sum,thresh,tmp,wmax,afunc(MMAX),b(NMAX)
|
||||
do 12 i=1,ndata
|
||||
call funcs(x(i),afunc,ma)
|
||||
tmp=1./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.
|
||||
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.
|
||||
14 continue
|
||||
call svbksb(u,w,v,ndata,ma,mp,np,b,a)
|
||||
chisq=0.
|
||||
do 16 i=1,ndata
|
||||
call funcs(x(i),afunc,ma)
|
||||
sum=0.
|
||||
do 15 j=1,ma
|
||||
sum=sum+a(j)*afunc(j)
|
||||
15 continue
|
||||
chisq=chisq+((y(i)-sum)/sig(i))**2
|
||||
16 continue
|
||||
return
|
||||
END
|
||||
@@ -3,7 +3,7 @@
|
||||
implicit none
|
||||
integer ndim
|
||||
double precision xbest(1:ndim),fbest,
|
||||
& bmin(1:ndim),bmax(1:ndim),xtol
|
||||
& bmin(1:ndim),bmax(1:ndim),xtol,f1dim
|
||||
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
|
||||
integer i,n
|
||||
logical resetran2
|
||||
@@ -62,7 +62,7 @@
|
||||
! =1 convergence criterion reached (minimum found)
|
||||
!
|
||||
integer ndim
|
||||
double precision xbest(1:ndim),fbest,
|
||||
double precision xbest(1:ndim),fbest,f1dim,
|
||||
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
|
||||
external funkmin,f1dim
|
||||
!------------------------------- Locals -----------------------------------------------------------
|
||||
@@ -71,10 +71,10 @@
|
||||
& xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink,
|
||||
& direction(ndim),dmax,fcent0,ran2_reset,ran2
|
||||
integer i,j,k,iter
|
||||
parameter(shrink=0.618d0)
|
||||
parameter(shrink=0.95d0)
|
||||
!
|
||||
diftol=xtol
|
||||
delta=0.618d0
|
||||
delta=0.95d0
|
||||
do i=1,ndim
|
||||
xcent(i)=xbest(i)
|
||||
enddo
|
||||
|
||||
@@ -0,0 +1,35 @@
|
||||
subroutine GenericOptim(FuncToMinimize,f1dim_FuncToMinimize,
|
||||
&ndim,beta,betamin,betamax,fatbeta)
|
||||
implicit none
|
||||
integer ndim,i
|
||||
double precision beta(ndim),betamin(ndim),betamax(ndim),
|
||||
&fatbeta
|
||||
!
|
||||
double precision ftol,fatbeta0,beta0(ndim)
|
||||
parameter(ftol=1.0d-10)
|
||||
external FuncToMinimize,f1dim_FuncToMinimize
|
||||
call FuncToMinimize(ndim,beta,fatbeta)
|
||||
10 fatbeta0=fatbeta
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
enddo
|
||||
call nongradopt(ndim,FuncToMinimize,f1dim_FuncToMinimize,beta,
|
||||
&betamin,betamax,ftol,fatbeta)
|
||||
call FuncToMinimize(ndim,beta,fatbeta)
|
||||
write(*,*)fatbeta
|
||||
call RepeatCompassSearch(ndim,beta,fatbeta,betamin,betamax,
|
||||
&FuncToMinimize,f1dim_FuncToMinimize,ftol)
|
||||
call FuncToMinimize(ndim,beta,fatbeta)
|
||||
write(*,*)fatbeta
|
||||
write(*,*)
|
||||
|
||||
if((fatbeta0-fatbeta).gt.ftol)goto 10
|
||||
if(fatbeta0.lt.fatbeta)then
|
||||
fatbeta=fatbeta0
|
||||
do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
end subroutine GenericOptim
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
@@ -17,10 +17,11 @@
|
||||
&beta_in_out(ndim0),betamin0(ndim0),betamax0(ndim0),
|
||||
&shorty0(npoints,ny),shortx0(npoints,nx),fatbeta
|
||||
!
|
||||
integer i,j,INFO,ndim,k
|
||||
integer i,j,INFO,ndim,k,n,i2,icompete,isitnaninf,nave
|
||||
double precision xtol,beta(ndim0+nx*npoints),
|
||||
&betacp(ndim0+nx*npoints),fatbetacp,beta0(ndim0+nx*npoints),
|
||||
&fatbeta0,ftol,gacontrol(12),ran2,ftol_relax
|
||||
&fatbeta0,ftol,gacontrol(12),ran2,ftol_relax,term1,term2,discount,
|
||||
&history(2000,ndim0+3),upper,lower,f1dim_generic,generic_pikaia
|
||||
parameter(xtol=1.0d-7,ftol=1.0d-7)
|
||||
external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia
|
||||
!-----------------------------------------------------
|
||||
@@ -97,26 +98,124 @@ c (default is 0)
|
||||
10 call funkmin_generic(ndim,beta,fatbeta)
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
history(1,i)=beta(i)
|
||||
enddo
|
||||
fatbeta0=fatbeta
|
||||
history(1,ndim+1)=fatbeta
|
||||
!entrance counter
|
||||
history(1,ndim+2)=1.0d0
|
||||
!failure counter
|
||||
history(1,ndim+3)=0.0d0
|
||||
!Is it a competition among different initial guesses?
|
||||
icompete=0
|
||||
!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
|
||||
!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
|
||||
!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
|
||||
!from calls to nongradopt if they are significantly different from the current best.
|
||||
j=0
|
||||
k=0
|
||||
ftol_relax=ftol*100.0d0
|
||||
30 call nongradopt(ndim,funkmin_generic,
|
||||
&f1dim_generic,beta,betamin,betamax,ftol_relax,fatbeta)
|
||||
n=1
|
||||
nave=1
|
||||
ftol_relax=ftol*1000.0d0
|
||||
discount=2.0d0
|
||||
!relax the convergence criterion for scouting
|
||||
30 fatbetacp=fatbeta
|
||||
do i=1,ndim
|
||||
betacp(i)=beta(i)
|
||||
enddo
|
||||
INFO=iregrestype
|
||||
call odr_leastsquare(ndim,FCN_generic,beta,nobs,
|
||||
&xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
|
||||
&nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
|
||||
&iderivative,shortx(1:nobs,1:nxvars),
|
||||
&shorty(1:nobs,1:nyvars),fatbeta,INFO)
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
|
||||
if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then
|
||||
fatbeta=fatbetacp
|
||||
do i=1,ndim
|
||||
beta(i)=betacp(i)
|
||||
enddo
|
||||
else
|
||||
fatbetacp=fatbeta
|
||||
do i=1,ndim
|
||||
betacp(i)=beta(i)
|
||||
enddo
|
||||
endif
|
||||
call nongradopt(ndim,funkmin_generic,f1dim_generic,
|
||||
&beta,betamin,betamax,ftol_relax,fatbeta)
|
||||
if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then
|
||||
fatbeta=fatbetacp
|
||||
do i=1,ndim
|
||||
beta(i)=betacp(i)
|
||||
enddo
|
||||
endif
|
||||
if(fatbeta.gt.1.0d0)then
|
||||
term1=fatbeta*ftol_relax
|
||||
else
|
||||
term1=ftol_relax*10.0d0
|
||||
endif
|
||||
if(fatbeta.gt.fatbeta0)then
|
||||
!failure
|
||||
if((fatbeta-fatbeta0).gt.term1)then
|
||||
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
|
||||
!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so
|
||||
!include it in the set if it has not already been included in the set.
|
||||
i=1
|
||||
i2=1
|
||||
40 if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
|
||||
if(dabs(history(i2,ndim+1)-fatbeta).lt.term1)then
|
||||
history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
|
||||
goto 60
|
||||
endif
|
||||
if(i2.ge.n)goto 50
|
||||
i2=i2+1
|
||||
i=1
|
||||
goto 40
|
||||
else
|
||||
if(i.ge.ndim)goto 60
|
||||
i=i+1
|
||||
goto 40
|
||||
endif
|
||||
50 n=n+1
|
||||
do i=1,ndim
|
||||
history(n,i)=beta(i)
|
||||
enddo
|
||||
history(n,ndim+1)=fatbeta
|
||||
history(n,ndim+2)=0.0d0
|
||||
history(n,ndim+3)=0.0d0
|
||||
!use average only when there is imporvement
|
||||
nave=n
|
||||
else
|
||||
!the difference is minimal even though fatbeta is larger than fatbeta0.
|
||||
!Increment the counter for arriving at the same minimum.
|
||||
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
|
||||
k=k+1
|
||||
endif
|
||||
60 do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
enddo
|
||||
fatbeta=fatbeta0
|
||||
else
|
||||
if((fatbeta0-fatbeta).lt.ftol_relax)then
|
||||
!increment the counter for arriving at the same minimum
|
||||
!success
|
||||
if((fatbeta0-fatbeta).lt.term1)then
|
||||
!negligible improvement. Increment the counter for arriving at the same minimum.
|
||||
!no increment for the set of central initial guesses
|
||||
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.5d0
|
||||
k=k+1
|
||||
else
|
||||
!reset the counter for arriving at a better minimum
|
||||
!reset the counter for arriving at a better minimum.
|
||||
!Increment the set of central initial guesses
|
||||
if(dabs(discount-2.0d0).lt.ftol)then
|
||||
discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0)
|
||||
endif
|
||||
k=0
|
||||
n=n+1
|
||||
do i=1,ndim
|
||||
history(n,i)=beta(i)
|
||||
enddo
|
||||
history(n,ndim+1)=fatbeta
|
||||
history(n,ndim+2)=0.0d0
|
||||
history(n,ndim+3)=0.0d0
|
||||
endif
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
@@ -124,54 +223,125 @@ c (default is 0)
|
||||
fatbeta0=fatbeta
|
||||
endif
|
||||
j=j+1
|
||||
!try different initial guesses
|
||||
if(j.lt.100.and.k.lt.5)then
|
||||
if(ran2().gt.0.3d0)then
|
||||
if(j.lt.20.and.k.lt.2)then
|
||||
if(j.lt.10)then
|
||||
term1=0.01d0+dmin1(history(1,ndim+3)*0.025d0,0.9d0)
|
||||
history(1,ndim+2)=history(1,ndim+2)+1.0d0
|
||||
do i=1,ndim
|
||||
if(ran2().gt.0.5d0)then
|
||||
beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))*
|
||||
&(betamax(i)-beta(i))
|
||||
else
|
||||
beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))*
|
||||
&(beta(i)-betamin(i))
|
||||
lower=history(1,i)-term1*(history(1,i)-betamin(i))
|
||||
upper=history(1,i)+term1*(betamax(i)-history(1,i))
|
||||
beta(i)=lower+ran2()*(upper-lower)
|
||||
enddo
|
||||
icompete=1
|
||||
goto 70
|
||||
endif
|
||||
!try average
|
||||
if(n.gt.nave)then
|
||||
term1=1.0d0/(history(1,ndim+1)+1.0d-5)
|
||||
do i=2,n
|
||||
term1=term1+1.0d0/(history(i,ndim+1)+1.0d-5)
|
||||
enddo
|
||||
do i=1,ndim
|
||||
beta(i)=history(1,i)/(term1*(history(1,ndim+1)+1.0d-5))
|
||||
do icompete=2,n
|
||||
beta(i)=beta(i)+history(icompete,i)/
|
||||
&(term1*(history(icompete,ndim+1)+1.0d-5))
|
||||
enddo
|
||||
enddo
|
||||
nave=n
|
||||
icompete=0
|
||||
goto 70
|
||||
endif
|
||||
!try different initial guesses
|
||||
if(ran2().gt.0.2d0)then
|
||||
!guess around the best
|
||||
icompete=1
|
||||
term1=history(1,ndim+1)+
|
||||
&discount*history(1,ndim+2)*history(1,ndim+3)
|
||||
do i=2,n
|
||||
term2=history(i,ndim+1)+
|
||||
&discount*history(i,ndim+2)*history(i,ndim+3)
|
||||
if(term2.le.term1)then
|
||||
term1=term2
|
||||
do i2=1,ndim+3
|
||||
history(n+1,i2)=history(i,i2)
|
||||
history(i,i2)=history(1,i2)
|
||||
history(1,i2)=history(n+1,i2)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
term1=0.01d0+dmin1(history(1,ndim+2)*history(1,ndim+3)*
|
||||
&0.015d0,0.9d0)
|
||||
history(1,ndim+2)=history(1,ndim+2)+1.0d0
|
||||
do i=1,ndim
|
||||
lower=history(1,i)-term1*(history(1,i)-betamin(i))
|
||||
upper=history(1,i)+term1*(betamax(i)-history(1,i))
|
||||
beta(i)=lower+ran2()*(upper-lower)
|
||||
enddo
|
||||
else
|
||||
!completely random guess
|
||||
do i=1,ndim
|
||||
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
|
||||
enddo
|
||||
icompete=0
|
||||
endif
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
70 call funkmin_generic(ndim,beta,fatbeta)
|
||||
goto 30
|
||||
else
|
||||
if((ftol_relax-ftol).gt.ftol)then
|
||||
if(k.le.1)then
|
||||
n=n+1
|
||||
do i=1,ndim+3
|
||||
history(n,i)=history(1,i)
|
||||
enddo
|
||||
do i=1,ndim
|
||||
history(1,i)=beta(i)
|
||||
enddo
|
||||
history(1,ndim+1)=fatbeta
|
||||
history(1,ndim+2)=0.0d0
|
||||
history(1,ndim+3)=0.0d0
|
||||
do i=1,n
|
||||
do icompete=1,ndim
|
||||
betacp(icompete)=history(i,icompete)
|
||||
enddo
|
||||
fatbetacp=history(i,ndim+1)
|
||||
call RepeatCompassSearch(ndim,betacp,fatbetacp,
|
||||
&betamin,betamax,funkmin_generic,f1dim_generic,ftol_relax)
|
||||
call funkmin_generic(ndim,betacp,fatbetacp)
|
||||
if(isitnaninf(fatbetacp).eq.0.and.fatbetacp.lt.
|
||||
&fatbeta)then
|
||||
do icompete=1,ndim
|
||||
beta(icompete)=betacp(icompete)
|
||||
enddo
|
||||
fatbeta=fatbetacp
|
||||
endif
|
||||
enddo
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
enddo
|
||||
fatbeta0=fatbeta
|
||||
icompete=1
|
||||
j=0
|
||||
else
|
||||
icompete=0
|
||||
endif
|
||||
ftol_relax=ftol
|
||||
goto 30
|
||||
endif
|
||||
endif
|
||||
|
||||
goto 110
|
||||
|
||||
call RepeatCompassSearch(ndim,beta,fatbeta,
|
||||
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
k=0
|
||||
if((fatbeta+1.0d0).eq.fatbeta)k=1
|
||||
do i=1,ndim
|
||||
if((beta(i)+1.0d0).eq.beta(i))k=1
|
||||
enddo
|
||||
if(k.eq.1)then
|
||||
do i=1,ndim
|
||||
beta(i)=betamin(i)+(betamax(i)-betamin(i))*ran2()
|
||||
enddo
|
||||
goto 10
|
||||
endif
|
||||
if(fatbeta.ge.fatbeta0)then
|
||||
if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then
|
||||
!if RepeatCompassSearch cannot improve, we end the search
|
||||
do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
enddo
|
||||
fatbeta=fatbeta0
|
||||
goto 110
|
||||
else
|
||||
if((fatbeta0-fatbeta).lt.ftol)goto 40
|
||||
endif
|
||||
do i=1,12
|
||||
gacontrol(i)=-1.0d0
|
||||
@@ -182,65 +352,40 @@ c (default is 0)
|
||||
do i=1,ndim
|
||||
beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
|
||||
enddo
|
||||
idobounded=0
|
||||
fatbeta0=fatbeta
|
||||
call pikaia(generic_pikaia,ndim,gacontrol,beta0,fatbeta0,j)
|
||||
fatbeta0=1.0d+100
|
||||
if(j.eq.0)then
|
||||
do i=1,ndim
|
||||
beta0(i)=betamin(i)+beta0(i)*(betamax(i)-betamin(i))
|
||||
enddo
|
||||
idobounded=1
|
||||
call funkmin_generic(ndim,beta0,fatbeta0)
|
||||
k=0
|
||||
if((fatbeta0+1.0d0).eq.fatbeta0)k=1
|
||||
do i=1,ndim
|
||||
if((beta0(i)+1.0d0).eq.beta0(i))k=1
|
||||
enddo
|
||||
if(k.eq.1)fatbeta0=1.0d+100
|
||||
endif
|
||||
|
||||
40 if(fatbeta0.gt.fatbeta)then
|
||||
80 if(isitnaninf(fatbeta0).eq.1.or.fatbeta0.gt.fatbeta)then
|
||||
fatbeta0=fatbeta
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
enddo
|
||||
endif
|
||||
do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
enddo
|
||||
fatbeta=fatbeta0
|
||||
!
|
||||
INFO=iregrestype
|
||||
idobounded=0
|
||||
call odr_leastsquare(ndim,FCN_generic,beta,nobs,
|
||||
&xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
|
||||
&nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
|
||||
&iderivative,shortx(1:nobs,1:nxvars),
|
||||
&shorty(1:nobs,1:nyvars),fatbeta,INFO)
|
||||
idobounded=1
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
k=0
|
||||
if((fatbeta+1.0d0).eq.fatbeta)k=1
|
||||
do i=1,ndim
|
||||
if((beta(i)+1.0d0).eq.beta(i))k=1
|
||||
enddo
|
||||
if(k.eq.1)fatbeta=1.0d+100
|
||||
if(dabs(fatbeta).le.dabs(fatbeta0))then
|
||||
else
|
||||
do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
enddo
|
||||
fatbeta=fatbeta0
|
||||
endif
|
||||
do i=1,ndim
|
||||
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
|
||||
do j=1,ndim
|
||||
beta(j)=beta0(j)
|
||||
enddo
|
||||
fatbeta=fatbeta0
|
||||
endif
|
||||
enddo
|
||||
fatbeta0=fatbeta
|
||||
!
|
||||
INFO=iregrestype
|
||||
call odr_leastsquare(ndim,FCN_generic,beta,nobs,
|
||||
&xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
|
||||
&nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
|
||||
&iderivative,shortx(1:nobs,1:nxvars),
|
||||
&shorty(1:nobs,1:nyvars),fatbeta,INFO)
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbeta0)then
|
||||
do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
enddo
|
||||
fatbeta=fatbeta0
|
||||
endif
|
||||
iregrestype=iregrestype0
|
||||
if(iregrestype.eq.2)then
|
||||
do i=1,npoints
|
||||
@@ -266,13 +411,7 @@ c (default is 0)
|
||||
call nongradopt(ndim,funkmin_generic,
|
||||
&f1dim_generic,beta,betamin,betamax,ftol,fatbeta)
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
k=0
|
||||
if((fatbeta+1.0d0).eq.fatbeta)k=1
|
||||
do i=1,ndim
|
||||
if((beta(i)+1.0d0).eq.beta(i))k=1
|
||||
enddo
|
||||
if(k.eq.1)fatbeta=1.0d+100
|
||||
if(dabs(fatbeta).ge.dabs(fatbeta0))then
|
||||
if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then
|
||||
fatbeta=fatbeta0
|
||||
do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
@@ -286,19 +425,13 @@ c (default is 0)
|
||||
call RepeatCompassSearch(ndim,betacp,fatbetacp,
|
||||
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
|
||||
call funkmin_generic(ndim,betacp,fatbetacp)
|
||||
k=0
|
||||
if((fatbetacp+1.0d0).eq.fatbetacp)k=1
|
||||
do i=1,ndim
|
||||
if((betacp(i)+1.0d0).eq.betacp(i))k=1
|
||||
enddo
|
||||
if(k.eq.1)fatbetacp=1.0d+100
|
||||
if(dabs(fatbetacp).lt.dabs(fatbeta))then
|
||||
if(isitnaninf(fatbetacp).eq.1.or.fatbetacp.ge.fatbeta)then
|
||||
goto 110
|
||||
else
|
||||
fatbeta=fatbetacp
|
||||
do i=1,ndim
|
||||
beta(i)=betacp(i)
|
||||
enddo
|
||||
else
|
||||
goto 110
|
||||
endif
|
||||
if(j.ge.2.or.fatbeta.eq.fatbeta0)goto 110
|
||||
if(dabs(fatbeta0-fatbeta).gt.ftol)then
|
||||
@@ -310,7 +443,7 @@ c (default is 0)
|
||||
call linmin(beta,betamin,betamax,betacp,ndim,
|
||||
&f1dim_generic,fatbeta)
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
if(dabs(fatbeta).lt.dabs(fatbeta0))goto 100
|
||||
if(isitnaninf(fatbeta).eq.0.and.fatbeta.lt.fatbeta0)goto 100
|
||||
fatbeta=fatbeta0
|
||||
do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
|
||||
@@ -3,7 +3,7 @@
|
||||
implicit none
|
||||
integer ndim
|
||||
double precision xbest(1:ndim),fbest,
|
||||
& bmin(1:ndim),bmax(1:ndim),xtol
|
||||
& bmin(1:ndim),bmax(1:ndim),xtol,f1dim
|
||||
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
|
||||
parameter(ftol=1.0d-7)
|
||||
integer i,n
|
||||
@@ -62,7 +62,7 @@
|
||||
! =1 convergence criterion reached (minimum found)
|
||||
!
|
||||
integer ndim
|
||||
double precision xbest(1:ndim),fbest,
|
||||
double precision xbest(1:ndim),fbest,f1dim,
|
||||
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
|
||||
external funkmin,f1dim
|
||||
!------------------------------- Locals -----------------------------------------------------------
|
||||
|
||||
@@ -7,7 +7,7 @@
|
||||
!
|
||||
integer ndim
|
||||
double precision beta(1:ndim),bmin(1:ndim),
|
||||
& bmax(1:ndim),ftol,fatbeta
|
||||
&bmax(1:ndim),ftol,fatbeta,f1dim
|
||||
!
|
||||
! ------------------ Inputs -----------------------------
|
||||
! ndim: the total number of parameters to be estimated
|
||||
|
||||
@@ -4,7 +4,7 @@
|
||||
implicit none
|
||||
INTEGER iter,n,np,NMAX,ITMAX
|
||||
double precision fret,ftol,p(np),xi(np,np),TINY,
|
||||
& pmin(np),pmax(np)
|
||||
& pmin(np),pmax(np),f1dim
|
||||
PARAMETER (NMAX=1000,TINY=1.0d-25)
|
||||
CU USES funkmin,linmin
|
||||
INTEGER i,ibig,j
|
||||
@@ -57,7 +57,7 @@ C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
SUBROUTINE cplinmin(p,pmin,pmax,xi,n,f1dim,fret)
|
||||
implicit none
|
||||
INTEGER n
|
||||
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n)
|
||||
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim
|
||||
PARAMETER (TOL=1.0d-8)
|
||||
CU USES brent,f1dim,mnbrak
|
||||
INTEGER j,k,ierr
|
||||
|
||||
@@ -192,7 +192,7 @@ c ************
|
||||
|
||||
integer l1,l2,l3,lws,lr,lz,lt,ld,lwa,lwy,lsy,lss,lwt,lwn,lsnd
|
||||
|
||||
if (task .eq. 'START') then
|
||||
if (task .eqv. 'START') then
|
||||
isave(1) = m*n
|
||||
isave(2) = m**2
|
||||
isave(3) = 4*m**2
|
||||
@@ -442,7 +442,7 @@ c ************
|
||||
double precision one,zero
|
||||
parameter (one=1.0d0,zero=0.0d0)
|
||||
|
||||
if (task .eq. 'START') then
|
||||
if (task .eqv. 'START') then
|
||||
|
||||
call timer(time1)
|
||||
|
||||
@@ -508,7 +508,7 @@ c open a summary file 'iterate.dat'
|
||||
c Check the input arguments for errors.
|
||||
|
||||
call errclb(n,m,factr,l,u,nbd,task,info,k)
|
||||
if (task(1:5) .eq. 'ERROR') then
|
||||
if (task(1:5) .eqv. 'ERROR') then
|
||||
call prn3lb(n,x,f,task,iprint,info,itfile,
|
||||
+ iter,nfgv,nintol,nskip,nact,sbgnrm,
|
||||
+ zero,nint,word,iback,stp,xstep,k,
|
||||
@@ -571,11 +571,11 @@ c restore local variables.
|
||||
c After returning from the driver go to the point where execution
|
||||
c is to resume.
|
||||
|
||||
if (task(1:5) .eq. 'FG_LN') goto 666
|
||||
if (task(1:5) .eq. 'NEW_X') goto 777
|
||||
if (task(1:5) .eq. 'FG_ST') goto 111
|
||||
if (task(1:4) .eq. 'STOP') then
|
||||
if (task(7:9) .eq. 'CPU') then
|
||||
if (task(1:5) .eqv. 'FG_LN') goto 666
|
||||
if (task(1:5) .eqv. 'NEW_X') goto 777
|
||||
if (task(1:5) .eqv. 'FG_ST') goto 111
|
||||
if (task(1:4) .eqv. 'STOP') then
|
||||
if (task(7:9) .eqv. 'CPU') then
|
||||
c restore the previous iterate.
|
||||
call dcopy(n,t,1,x,1)
|
||||
call dcopy(n,r,1,g,1)
|
||||
@@ -771,7 +771,7 @@ c refresh the lbfgs memory and restart the iteration.
|
||||
lnscht = lnscht + cpu2 - cpu1
|
||||
goto 222
|
||||
endif
|
||||
else if (task(1:5) .eq. 'FG_LN') then
|
||||
else if (task(1:5) .eqv. 'FG_LN') then
|
||||
c return to the driver for calculating f and g; reenter at 666.
|
||||
goto 1000
|
||||
else
|
||||
@@ -2444,7 +2444,7 @@ c **********
|
||||
double precision ftol,gtol,xtol
|
||||
parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0)
|
||||
|
||||
if (task(1:5) .eq. 'FG_LN') goto 556
|
||||
if (task(1:5) .eqv. 'FG_LN') goto 556
|
||||
|
||||
dtd = ddot(n,d,1,d,1)
|
||||
dnorm = sqrt(dtd)
|
||||
@@ -2789,7 +2789,7 @@ c ************
|
||||
|
||||
integer i
|
||||
|
||||
if (task(1:5) .eq. 'ERROR') goto 999
|
||||
if (task(1:5) .eqv. 'ERROR') goto 999
|
||||
|
||||
if (iprint .ge. 0) then
|
||||
write (6,3003)
|
||||
@@ -3271,7 +3271,7 @@ c
|
||||
c task = 'START'
|
||||
c 10 continue
|
||||
c call dcsrch( ... )
|
||||
c if (task .eq. 'FG') then
|
||||
c if (task .eqv. 'FG') then
|
||||
c Evaluate the function and the gradient at stp
|
||||
c goto 10
|
||||
c end if
|
||||
@@ -3377,7 +3377,7 @@ c **********
|
||||
|
||||
c Initialization block.
|
||||
|
||||
if (task(1:5) .eq. 'START') then
|
||||
if (task(1:5) .eqv. 'START') then
|
||||
|
||||
c Check the input arguments for errors.
|
||||
|
||||
@@ -3392,7 +3392,7 @@ c Check the input arguments for errors.
|
||||
|
||||
c Exit if there are errors on input.
|
||||
|
||||
if (task(1:5) .eq. 'ERROR') return
|
||||
if (task(1:5) .eqv. 'ERROR') return
|
||||
|
||||
c Initialize local variables.
|
||||
|
||||
@@ -3479,7 +3479,7 @@ c Test for convergence.
|
||||
|
||||
c Test for termination.
|
||||
|
||||
if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000
|
||||
if (task(1:4) .eqv. 'WARN' .or. task(1:4) .eqv. 'CONV') goto 1000
|
||||
|
||||
c A modified function is used to predict the step during the
|
||||
c first stage if a lower function value has been obtained but
|
||||
|
||||
@@ -0,0 +1,173 @@
|
||||
Subroutine mctsglobalmin(ndim,funkmin_nongrad,f1dim_nongrad,
|
||||
&beta,betamin,betamax,ftol,fatbeta)
|
||||
implicit none
|
||||
integer ndim
|
||||
double precision beta(ndim),betamin(ndim),betamax(ndim),
|
||||
&ftol,fatbeta
|
||||
!
|
||||
integer i,j,k,n,i2,icompete
|
||||
double precision ran2,ftol_relax,term1,term2,beta0(ndim),
|
||||
&fatbeta0,history(2000,ndim+3),discount
|
||||
external funkmin_nongrad,f1dim_nongrad
|
||||
!-----------------------------------------------------
|
||||
!the cost funcation value for the first initial guess must be provided!
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
history(1,i)=beta(i)
|
||||
enddo
|
||||
fatbeta0=fatbeta
|
||||
history(1,ndim+1)=fatbeta
|
||||
!entrance counter
|
||||
history(1,ndim+2)=1.0d0
|
||||
!failure counter
|
||||
history(1,ndim+3)=0.0d0
|
||||
!Is it a competition among different initial guesses?
|
||||
icompete=0
|
||||
!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
|
||||
!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
|
||||
!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
|
||||
!from calls to nongradopt if they are significantly different from the current best.
|
||||
j=0
|
||||
k=0
|
||||
n=1
|
||||
ftol_relax=ftol*1000.0d0
|
||||
discount=2.0d0
|
||||
!relax the convergence criterion for scouting
|
||||
30 call nongradopt(ndim,funkmin_nongrad,f1dim_nongrad,
|
||||
&beta,betamin,betamax,ftol_relax,fatbeta)
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
|
||||
!failure
|
||||
if((fatbeta+1.0d0).ne.fatbeta)then
|
||||
if((fatbeta-fatbeta0).gt.10.0d0*ftol_relax)then
|
||||
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
|
||||
!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so
|
||||
!include it in the set if it has not already been included in the set.
|
||||
i=1
|
||||
i2=1
|
||||
40 if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
|
||||
if(dabs(history(i2,ndim+1)-fatbeta).lt.ftol_relax)then
|
||||
history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
|
||||
goto 60
|
||||
endif
|
||||
if(i2.ge.n)goto 50
|
||||
i2=i2+1
|
||||
i=1
|
||||
goto 40
|
||||
else
|
||||
if(i.ge.ndim)goto 60
|
||||
i=i+1
|
||||
goto 40
|
||||
endif
|
||||
50 n=n+1
|
||||
do i=1,ndim
|
||||
history(n,i)=beta(i)
|
||||
enddo
|
||||
history(n,ndim+1)=fatbeta
|
||||
history(n,ndim+2)=0.0d0
|
||||
history(n,ndim+3)=0.0d0
|
||||
else
|
||||
!the difference is minimal even though fatbeta is larger than fatbeta0.
|
||||
!Increment the counter for arriving at the same minimum.
|
||||
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
|
||||
k=k+1
|
||||
endif
|
||||
else
|
||||
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+2.0d0
|
||||
endif
|
||||
60 do i=1,ndim
|
||||
beta(i)=beta0(i)
|
||||
enddo
|
||||
fatbeta=fatbeta0
|
||||
else
|
||||
!success
|
||||
if((fatbeta0-fatbeta).lt.10.0d0*ftol_relax)then
|
||||
!negligible improvement. Increment the counter for arriving at the same minimum.
|
||||
!no increment for the set of central initial guesses
|
||||
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.1d0
|
||||
k=k+1
|
||||
else
|
||||
!reset the counter for arriving at a better minimum.
|
||||
!Increment the set of central initial guesses
|
||||
if(dabs(discount-2.0d0).lt.ftol)then
|
||||
discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0)
|
||||
endif
|
||||
k=0
|
||||
n=n+1
|
||||
do i=1,ndim+3
|
||||
history(n,i)=history(1,i)
|
||||
enddo
|
||||
do i=1,ndim
|
||||
history(1,i)=beta(i)
|
||||
enddo
|
||||
history(1,ndim+1)=fatbeta
|
||||
history(1,ndim+2)=0.0d0
|
||||
history(1,ndim+3)=0.0d0
|
||||
endif
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
enddo
|
||||
fatbeta0=fatbeta
|
||||
endif
|
||||
j=j+1
|
||||
if(j.lt.990.and.k.lt.3)then
|
||||
!try different initial guesses
|
||||
if(ran2().gt.0.1d0)then
|
||||
!guess around the best
|
||||
icompete=1
|
||||
term1=history(1,ndim+1)+
|
||||
&discount*history(1,ndim+2)*history(1,ndim+3)
|
||||
do i=2,n
|
||||
term2=history(i,ndim+1)+
|
||||
&discount*history(i,ndim+2)*history(i,ndim+3)
|
||||
if(term2.le.term1)then
|
||||
term1=term2
|
||||
do i2=1,ndim+3
|
||||
history(n+1,i2)=history(i,i2)
|
||||
history(i,i2)=history(1,i2)
|
||||
history(1,i2)=history(n+1,i2)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
term1=0.5d0*history(i,ndim+2)*history(i,ndim+3)
|
||||
history(1,ndim+2)=history(1,ndim+2)+1.0d0
|
||||
do i=1,ndim
|
||||
if(ran2().gt.0.5d0)then
|
||||
if((betamax(i)-history(1,i)).gt.
|
||||
&(betamax(i)-betamin(i))*1.0d-5)then
|
||||
beta(i)=history(1,i)+(ran2()**(4.0d0/(term1+1.0d0)))*
|
||||
&(betamax(i)-history(1,i))
|
||||
else
|
||||
beta(i)=betamax(i)-
|
||||
&(ran2()**4.0d0)*(betamax(i)-betamin(i))
|
||||
endif
|
||||
else
|
||||
if((history(1,i)-betamin(i)).gt.
|
||||
&(betamax(i)-betamin(i))*1.0d-5)then
|
||||
beta(i)=history(1,i)-(ran2()**(4.0d0/(term1+1.0d0)))*
|
||||
&(history(1,i)-betamin(i))
|
||||
else
|
||||
beta(i)=betamin(i)+
|
||||
&(ran2()**4.0d0)*(betamax(i)-betamin(i))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
!completely random guess
|
||||
icompete=0
|
||||
do i=1,ndim
|
||||
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
|
||||
enddo
|
||||
endif
|
||||
call funkmin_generic(ndim,beta,fatbeta)
|
||||
goto 30
|
||||
else
|
||||
if((ftol_relax-ftol).gt.ftol)then
|
||||
ftol_relax=ftol
|
||||
if(k.le.1)j=0
|
||||
goto 30
|
||||
endif
|
||||
endif
|
||||
return
|
||||
end subroutine mctsglobalmin
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
@@ -6,7 +6,7 @@
|
||||
!
|
||||
integer ndim
|
||||
double precision beta(1:ndim),bmin(1:ndim),
|
||||
& bmax(1:ndim),ftol,fatbeta
|
||||
&bmax(1:ndim),ftol,fatbeta,f1dim
|
||||
!
|
||||
! ------------------ Inputs -----------------------------
|
||||
! ndim: the total number of parameters to be estimated
|
||||
@@ -24,7 +24,7 @@
|
||||
|
||||
integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
|
||||
& icycle
|
||||
parameter(maxredo=10,ITMAX=10000)
|
||||
parameter(maxredo=5,ITMAX=50000)
|
||||
double precision fbest,xbest(1:ndim),term,
|
||||
& xinidir(1:ndim,1:ndim),xbest0(1:ndim),
|
||||
& pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1)
|
||||
@@ -50,7 +50,7 @@
|
||||
fatbeta=fbest
|
||||
goto 10
|
||||
endif
|
||||
if((fbest-fatbeta).gt.ftol)then
|
||||
if((fbest-fatbeta).gt.100.0d0*ftol)then
|
||||
if(iredo.gt.maxredo)goto 10
|
||||
iredo=iredo+1
|
||||
goto 3
|
||||
@@ -92,6 +92,9 @@
|
||||
if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then
|
||||
term=term/3.0d0
|
||||
fbest=fatbeta
|
||||
do n=1,ndim
|
||||
xbest(n)=beta(n)
|
||||
enddo
|
||||
goto 30
|
||||
endif
|
||||
do n=1,ndim
|
||||
@@ -144,7 +147,7 @@
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
if((fbest-fatbeta).gt.ftol)then
|
||||
if((fbest-fatbeta).gt.ftol*100.0d0)then
|
||||
if(iredo.gt.maxredo)then
|
||||
if(icycle.lt.maxredo)then
|
||||
icycle=icycle+1
|
||||
@@ -167,15 +170,15 @@
|
||||
external funkmin
|
||||
CU USES guamotry,funkmin
|
||||
INTEGER i,ihi,ilo,inhi,j,m,n
|
||||
double precision rtol,sum,swap,ysave,ytry,psum(ndim),
|
||||
double precision rtol,cumx,swap,ysave,ytry,pcumx(ndim),
|
||||
& guamotry,degen
|
||||
iter=0
|
||||
1 do 12 n=1,ndim
|
||||
sum=0.0d0
|
||||
cumx=0.0d0
|
||||
do 11 m=1,ndim+1
|
||||
sum=sum+p(m,n)
|
||||
cumx=cumx+p(m,n)
|
||||
11 continue
|
||||
psum(n)=sum
|
||||
pcumx(n)=cumx
|
||||
12 continue
|
||||
2 ilo=1
|
||||
if (y(1).gt.y(2)) then
|
||||
@@ -232,20 +235,20 @@ CU USES guamotry,funkmin
|
||||
endif
|
||||
if(iter.ge.ITMAX)return
|
||||
iter=iter+2
|
||||
ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0)
|
||||
ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,-1.0d0)
|
||||
if (ytry.le.y(ilo))then
|
||||
ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,2.0d0)
|
||||
ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,2.0d0)
|
||||
else if (ytry.ge.y(inhi)) then
|
||||
ysave=y(ihi)
|
||||
ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,0.5d0)
|
||||
ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,0.5d0)
|
||||
if (ytry.ge.ysave) then
|
||||
do 16 i=1,ndim+1
|
||||
if(i.ne.ilo)then
|
||||
do 15 j=1,ndim
|
||||
psum(j)=0.5d0*(p(i,j)+p(ilo,j))
|
||||
p(i,j)=psum(j)
|
||||
pcumx(j)=0.5d0*(p(i,j)+p(ilo,j))
|
||||
p(i,j)=pcumx(j)
|
||||
15 continue
|
||||
call funkmin(ndim,psum,y(i))
|
||||
call funkmin(ndim,pcumx,y(i))
|
||||
endif
|
||||
16 continue
|
||||
iter=iter+ndim
|
||||
|
||||
@@ -24,7 +24,6 @@ C VARIABLE DECLARATIONS
|
||||
double precision weity(N,NQ),weitx(N,M),shorty(N,NQ),
|
||||
&shortx(N,M),fvalue,BETA(NP),X(N,M),Y(N,NQ)
|
||||
EXTERNAL FCN
|
||||
|
||||
LWORK=18+11*NP+NP**2+M+M**2+4*N*NQ+6*N*M+2*N*NQ*NP+
|
||||
&2*N*NQ*M+NQ**2+5*NQ+NQ*(NP+M)+N*1*NQ
|
||||
LIWORK=20+NP+NQ*(NP+M)
|
||||
@@ -96,7 +95,7 @@ C VARIABLE DECLARATIONS
|
||||
+ WORK(LWORK),X(N,M),Y(N,NQ)
|
||||
!------------For using information in WORK----------------------------
|
||||
LOGICAL
|
||||
+ ISODR
|
||||
+ISODR
|
||||
INTEGER
|
||||
+ DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
|
||||
+ RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
|
||||
@@ -105,7 +104,7 @@ C VARIABLE DECLARATIONS
|
||||
+ BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
|
||||
+ FSI,FJACBI,WE1I,DIFFI,
|
||||
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||
+ LWKMN
|
||||
c
|
||||
integer i1,i2,i3,i4,i5,iderivative
|
||||
@@ -230,7 +229,7 @@ C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
|
||||
+ BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
|
||||
+ FSI,FJACBI,WE1I,DIFFI,
|
||||
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||
+ LWKMN)
|
||||
fvalue=0.0d0
|
||||
do I=1,N
|
||||
|
||||
@@ -6,7 +6,7 @@
|
||||
*DMPREC
|
||||
DOUBLE PRECISION FUNCTION DMPREC()
|
||||
implicit none
|
||||
integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
|
||||
integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
|
||||
*maxexp
|
||||
double precision eps,epsneg,xmin,xmax
|
||||
|
||||
@@ -209,146 +209,146 @@ c TD = I1MACH(14)
|
||||
c DMPREC = B ** (1-TD)
|
||||
|
||||
call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp,
|
||||
*minexp,
maxexp,eps,epsneg,xmin,xmax)
|
||||
*minexp,maxexp,eps,epsneg,xmin,xmax)
|
||||
DMPREC=eps
|
||||
RETURN
|
||||
|
||||
END
|
||||
|
||||
SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep,
|
||||
*iexp,minexp,
maxexp,eps,epsneg,xmin,xmax)
|
||||
*iexp,minexp,maxexp,eps,epsneg,xmin,xmax)
|
||||
implicit none
|
||||
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
|
||||
double precision eps,epsneg,xmax,xmin
|
||||
INTEGER i,itemp,iz,j,k,mx,nxres
|
||||
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
|
||||
double precision eps,epsneg,xmax,xmin
|
||||
INTEGER i,itemp,iz,j,k,mx,nxres
|
||||
double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa,
|
||||
&two,y,z,zero,
CONV
|
||||
CONV(i)=dble(i)
|
||||
one=CONV(1)
|
||||
two=one+one
|
||||
zero=one-one
|
||||
a=one
|
||||
1 continue
|
||||
a=a+a
|
||||
temp=a+one
|
||||
temp1=temp-a
|
||||
if (temp1-one.eq.zero) goto 1
|
||||
b=one
|
||||
2 continue
|
||||
b=b+b
|
||||
temp=a+b
|
||||
itemp=int(temp-a)
|
||||
if (itemp.eq.0) goto 2
|
||||
ibeta=itemp
|
||||
beta=CONV(ibeta)
|
||||
it=0
|
||||
b=one
|
||||
3 continue
|
||||
it=it+1
|
||||
b=b*beta
|
||||
temp=b+one
|
||||
temp1=temp-b
|
||||
if (temp1-one.eq.zero) goto 3
|
||||
irnd=0
|
||||
betah=beta/two
|
||||
temp=a+betah
|
||||
if (temp-a.ne.zero) irnd=1
|
||||
tempa=a+beta
|
||||
temp=tempa+betah
|
||||
if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2
|
||||
negep=it+3
|
||||
betain=one/beta
|
||||
a=one
|
||||
do 11 i=1, negep
|
||||
a=a*betain
|
||||
11 continue
|
||||
b=a
|
||||
4 continue
|
||||
temp=one-a
|
||||
if (temp-one.ne.zero) goto 5
|
||||
a=a*beta
|
||||
negep=negep-1
|
||||
goto 4
|
||||
5 negep=-negep
|
||||
epsneg=a
|
||||
machep=-it-3
|
||||
a=b
|
||||
6 continue
|
||||
temp=one+a
|
||||
if (temp-one.ne.zero) goto 7
|
||||
a=a*beta
|
||||
machep=machep+1
|
||||
goto 6
|
||||
7 eps=a
|
||||
ngrd=0
|
||||
temp=one+eps
|
||||
if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1
|
||||
i=0
|
||||
k=1
|
||||
z=betain
|
||||
t=one+eps
|
||||
nxres=0
|
||||
8 continue
|
||||
y=z
|
||||
z=y*y
|
||||
a=z*one
|
||||
temp=z*t
|
||||
if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9
|
||||
temp1=temp*betain
|
||||
if (temp1*beta.eq.z) goto 9
|
||||
i=i+1
|
||||
k=k+k
|
||||
goto 8
|
||||
9 if (ibeta.ne.10) then
|
||||
iexp=i+1
|
||||
mx=k+k
|
||||
else
|
||||
iexp=2
|
||||
iz=ibeta
|
||||
10 if (k.ge.iz) then
|
||||
iz=iz*ibeta
|
||||
iexp=iexp+1
|
||||
goto 10
|
||||
endif
|
||||
mx=iz+iz-1
|
||||
endif
|
||||
20 xmin=y
|
||||
y=y*betain
|
||||
a=y*one
|
||||
temp=y*t
|
||||
if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then
|
||||
k=k+1
|
||||
temp1=temp*betain
|
||||
if ((temp1*beta.ne.y).or.(temp.eq.y)) then
|
||||
goto 20
|
||||
else
|
||||
nxres=3
|
||||
xmin=y
|
||||
endif
|
||||
endif
|
||||
minexp=-k
|
||||
if ((mx.le.k+k-3).and.(ibeta.ne.10)) then
|
||||
mx=mx+mx
|
||||
iexp=iexp+1
|
||||
endif
|
||||
maxexp=mx+minexp
|
||||
irnd=irnd+nxres
|
||||
if (irnd.ge.2) maxexp=maxexp-2
|
||||
i=maxexp+minexp
|
||||
if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1
|
||||
if (i.gt.20) maxexp=maxexp-1
|
||||
if (a.ne.y) maxexp=maxexp-2
|
||||
xmax=one-epsneg
|
||||
if (xmax*one.ne.xmax) xmax=one-beta*epsneg
|
||||
xmax=xmax/(beta*beta*beta*xmin)
|
||||
i=maxexp+minexp+3
|
||||
do 12 j=1,i
|
||||
if (ibeta.eq.2) xmax=xmax+xmax
|
||||
if (ibeta.ne.2) xmax=xmax*beta
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
&two,y,z,zero,CONV
|
||||
CONV(i)=dble(i)
|
||||
one=CONV(1)
|
||||
two=one+one
|
||||
zero=one-one
|
||||
a=one
|
||||
1 continue
|
||||
a=a+a
|
||||
temp=a+one
|
||||
temp1=temp-a
|
||||
if (temp1-one.eq.zero) goto 1
|
||||
b=one
|
||||
2 continue
|
||||
b=b+b
|
||||
temp=a+b
|
||||
itemp=int(temp-a)
|
||||
if (itemp.eq.0) goto 2
|
||||
ibeta=itemp
|
||||
beta=CONV(ibeta)
|
||||
it=0
|
||||
b=one
|
||||
3 continue
|
||||
it=it+1
|
||||
b=b*beta
|
||||
temp=b+one
|
||||
temp1=temp-b
|
||||
if (temp1-one.eq.zero) goto 3
|
||||
irnd=0
|
||||
betah=beta/two
|
||||
temp=a+betah
|
||||
if (temp-a.ne.zero) irnd=1
|
||||
tempa=a+beta
|
||||
temp=tempa+betah
|
||||
if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2
|
||||
negep=it+3
|
||||
betain=one/beta
|
||||
a=one
|
||||
do 11 i=1, negep
|
||||
a=a*betain
|
||||
11 continue
|
||||
b=a
|
||||
4 continue
|
||||
temp=one-a
|
||||
if (temp-one.ne.zero) goto 5
|
||||
a=a*beta
|
||||
negep=negep-1
|
||||
goto 4
|
||||
5 negep=-negep
|
||||
epsneg=a
|
||||
machep=-it-3
|
||||
a=b
|
||||
6 continue
|
||||
temp=one+a
|
||||
if (temp-one.ne.zero) goto 7
|
||||
a=a*beta
|
||||
machep=machep+1
|
||||
goto 6
|
||||
7 eps=a
|
||||
ngrd=0
|
||||
temp=one+eps
|
||||
if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1
|
||||
i=0
|
||||
k=1
|
||||
z=betain
|
||||
t=one+eps
|
||||
nxres=0
|
||||
8 continue
|
||||
y=z
|
||||
z=y*y
|
||||
a=z*one
|
||||
temp=z*t
|
||||
if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9
|
||||
temp1=temp*betain
|
||||
if (temp1*beta.eq.z) goto 9
|
||||
i=i+1
|
||||
k=k+k
|
||||
goto 8
|
||||
9 if (ibeta.ne.10) then
|
||||
iexp=i+1
|
||||
mx=k+k
|
||||
else
|
||||
iexp=2
|
||||
iz=ibeta
|
||||
10 if (k.ge.iz) then
|
||||
iz=iz*ibeta
|
||||
iexp=iexp+1
|
||||
goto 10
|
||||
endif
|
||||
mx=iz+iz-1
|
||||
endif
|
||||
20 xmin=y
|
||||
y=y*betain
|
||||
a=y*one
|
||||
temp=y*t
|
||||
if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then
|
||||
k=k+1
|
||||
temp1=temp*betain
|
||||
if ((temp1*beta.ne.y).or.(temp.eq.y)) then
|
||||
goto 20
|
||||
else
|
||||
nxres=3
|
||||
xmin=y
|
||||
endif
|
||||
endif
|
||||
minexp=-k
|
||||
if ((mx.le.k+k-3).and.(ibeta.ne.10)) then
|
||||
mx=mx+mx
|
||||
iexp=iexp+1
|
||||
endif
|
||||
maxexp=mx+minexp
|
||||
irnd=irnd+nxres
|
||||
if (irnd.ge.2) maxexp=maxexp-2
|
||||
i=maxexp+minexp
|
||||
if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1
|
||||
if (i.gt.20) maxexp=maxexp-1
|
||||
if (a.ne.y) maxexp=maxexp-2
|
||||
xmax=one-epsneg
|
||||
if (xmax*one.ne.xmax) xmax=one-beta*epsneg
|
||||
xmax=xmax/(beta*beta*beta*xmin)
|
||||
i=maxexp+minexp+3
|
||||
do 12 j=1,i
|
||||
if (ibeta.eq.2) xmax=xmax+xmax
|
||||
if (ibeta.ne.2) xmax=xmax*beta
|
||||
12 continue
|
||||
return
|
||||
END
|
||||
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
|
||||
*DODR
|
||||
SUBROUTINE DODR
|
||||
@@ -966,7 +966,6 @@ C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
|
||||
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||
+ LWKMN)
|
||||
|
||||
IF (ACCESS) THEN
|
||||
|
||||
C SET STARTING LOCATIONS FOR WORK VECTORS
|
||||
@@ -1050,9 +1049,8 @@ C STORE VALUES INTO THE WORK VECTORS
|
||||
IWORK(NITERI) = NITER
|
||||
IWORK(NJEVI) = NJEV
|
||||
IWORK(IDFI) = IDF
|
||||
IWORK(INT2I) = INT2
|
||||
IWORK(INT2I) = INT2
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
*DESUBI
|
||||
@@ -5916,7 +5914,6 @@ C***FIRST EXECUTABLE STATEMENT DODMN
|
||||
|
||||
|
||||
C INITIALIZE NECESSARY VARIABLES
|
||||
|
||||
CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
|
||||
+ ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
|
||||
ACCESS = .TRUE.
|
||||
@@ -5936,7 +5933,6 @@ C INITIALIZE NECESSARY VARIABLES
|
||||
DIDVCV = .FALSE.
|
||||
INTDBL = .FALSE.
|
||||
LSTEP = .TRUE.
|
||||
|
||||
C PRINT INITIAL SUMMARY IF DESIRED
|
||||
|
||||
IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
|
||||
@@ -6295,7 +6291,6 @@ C PRINT ITERATION REPORT
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
|
||||
C CHECK IF FINISHED
|
||||
|
||||
IF (INFO.EQ.0) THEN
|
||||
@@ -6315,9 +6310,7 @@ C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET
|
||||
GO TO 110
|
||||
END IF
|
||||
END IF
|
||||
|
||||
150 CONTINUE
|
||||
|
||||
IF (ISTOP.GT.0) INFO = INFO + 100
|
||||
|
||||
C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
|
||||
@@ -6329,12 +6322,9 @@ C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
|
||||
END IF
|
||||
CALL DUNPAC(NP,BETAC,BETA,IFIXB)
|
||||
CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)
|
||||
|
||||
C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
|
||||
C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED
|
||||
|
||||
IF (DOVCV .AND. ISTOP.EQ.0) THEN
|
||||
|
||||
IF (DOVCV .AND. ISTOP.EQ.0) THEN
|
||||
C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED
|
||||
C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
|
||||
C TO COMPUTE COVARIANCE MATRIX
|
||||
@@ -6350,8 +6340,6 @@ C TO COMPUTE COVARIANCE MATRIX
|
||||
+ T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
|
||||
+ FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
|
||||
+ NJEV,NFEV,ISTOP,INFO)
|
||||
|
||||
|
||||
IF (ISTOP.NE.0) THEN
|
||||
INFO = 51000
|
||||
GO TO 200
|
||||
@@ -6359,7 +6347,6 @@ C TO COMPUTE COVARIANCE MATRIX
|
||||
GO TO 200
|
||||
END IF
|
||||
END IF
|
||||
|
||||
IF (IMPLCT) THEN
|
||||
CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
|
||||
RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1)
|
||||
@@ -6383,9 +6370,7 @@ C TO COMPUTE COVARIANCE MATRIX
|
||||
END IF
|
||||
DIDVCV = .TRUE.
|
||||
END IF
|
||||
|
||||
END IF
|
||||
|
||||
C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS
|
||||
|
||||
200 DO 210 I=0,NP-1
|
||||
@@ -12072,15 +12057,23 @@ C***FIRST EXECUTABLE STATEMENT DNRM2_odr
|
||||
DNRM2_odr = ZERO
|
||||
GO TO 300
|
||||
|
||||
10 ASSIGN 30 TO NEXT
|
||||
! 10 ASSIGN 30 TO NEXT
|
||||
10 NEXT=30
|
||||
SUM = ZERO
|
||||
NN = N * INCX
|
||||
C BEGIN MAIN LOOP
|
||||
I = 1
|
||||
C 20 GO TO NEXT,(30, 50, 70, 110)
|
||||
20 GO TO NEXT
|
||||
! 20 GO TO NEXT
|
||||
!------------------------------
|
||||
20 IF(NEXT.EQ.30) goto 30
|
||||
IF(NEXT.EQ.50) goto 50
|
||||
IF(NEXT.EQ.70) goto 70
|
||||
IF(NEXT.EQ.110) goto 110
|
||||
|
||||
30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
|
||||
ASSIGN 50 TO NEXT
|
||||
! ASSIGN 50 TO NEXT
|
||||
NEXT=50
|
||||
XMAX = ZERO
|
||||
|
||||
C PHASE 1. SUM IS ZERO
|
||||
@@ -12089,13 +12082,15 @@ C PHASE 1. SUM IS ZERO
|
||||
IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
|
||||
|
||||
C PREPARE FOR PHASE 2.
|
||||
ASSIGN 70 TO NEXT
|
||||
! ASSIGN 70 TO NEXT
|
||||
NEXT=70
|
||||
GO TO 105
|
||||
|
||||
C PREPARE FOR PHASE 4.
|
||||
|
||||
100 I = J
|
||||
ASSIGN 110 TO NEXT
|
||||
! ASSIGN 110 TO NEXT
|
||||
NEXT=110
|
||||
SUM = (SUM / DX(I)) / DX(I)
|
||||
105 XMAX = DABS(DX(I))
|
||||
GO TO 115
|
||||
|
||||
@@ -0,0 +1,226 @@
|
||||
PROGRAM SAMPLE
|
||||
|
||||
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=5,MAXN=25,MAXNP=5,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)
|
||||
EXTERNAL FCN
|
||||
|
||||
|
||||
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 = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0D0
|
||||
SSTOL = -1.0D0
|
||||
PARTOL = -1.0D0
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0D0
|
||||
STPD(1,1) = -1.0D0
|
||||
SCLB(1) = -1.0D0
|
||||
SCLD(1,1) = -1.0D0
|
||||
|
||||
C SET UP ODRPACK REPORT FILES
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT1')
|
||||
|
||||
C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
|
||||
OPEN (UNIT=5,FILE='DATA1')
|
||||
READ (5,FMT=*) N,M,NP,NQ
|
||||
READ (5,FMT=*) (BETA(I),I=1,NP)
|
||||
DO 10 I=1,N
|
||||
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
|
||||
IF (X(I,1).EQ.0.0D0 .OR. X(I,1).EQ.100.0D0) THEN
|
||||
IFIXX(I,1) = 0
|
||||
ELSE
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
10 CONTINUE
|
||||
|
||||
C SPECIFY TASK: EXPLICIT ORTHOGONAL DISTANCE REGRESSION
|
||||
C WITH USER SUPPLIED DERIVATIVES (CHECKED)
|
||||
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
|
||||
C DELTA INITIALIZED TO ZERO
|
||||
C NOT A RESTART
|
||||
C AND INDICATE SHORT INITIAL REPORT
|
||||
C SHORT ITERATION REPORTS EVERY ITERATION, AND
|
||||
C LONG FINAL REPORT
|
||||
JOB = 00020
|
||||
IPRINT = 1112
|
||||
|
||||
C COMPUTE SOLUTION
|
||||
CALL DODRC(FCN,
|
||||
+ 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)
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,
|
||||
+ LDN,LDM,LDNP,
|
||||
+ BETA,XPLUSD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ IDEVAL,F,FJACB,FJACD,
|
||||
+ ISTOP)
|
||||
|
||||
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 LOCAL VARIABLES
|
||||
INTRINSIC EXP
|
||||
|
||||
|
||||
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
|
||||
IF (BETA(1) .LT. 0.0D0) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
ELSE
|
||||
ISTOP = 0
|
||||
END IF
|
||||
|
||||
C COMPUTE PREDICTED VALUES
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 110 L = 1,NQ
|
||||
DO 100 I = 1,N
|
||||
F(I,L) = BETA(1) +
|
||||
+ BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
|
||||
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) = 1.0D0
|
||||
FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
|
||||
FJACB(I,3,L) = BETA(2)*2*
|
||||
+ (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
|
||||
+ EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
END IF
|
||||
|
||||
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(2)*2*
|
||||
+ (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
|
||||
+ EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,160 @@
|
||||
PROGRAM SAMPLE
|
||||
|
||||
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 (UNUSED WHEN MODEL IS IMPLICIT)
|
||||
C ==> LDY LEADING DIMENSION OF ARRAY Y
|
||||
C ==> X EXPLANATORY VARIABLE
|
||||
C ==> LDX LEADING DIMENSION OF ARRAY X
|
||||
C ==> WE INITIAL PENALTY PARAMETER FOR IMPLICIT MODEL
|
||||
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 ==> JOB TASK TO BE PERFORMED
|
||||
C ==> IPRINT PRINT CONTROL
|
||||
C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS
|
||||
C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS
|
||||
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 LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
||||
+ LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
||||
PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=2,
|
||||
+ LDY=MAXN,LDX=MAXN,
|
||||
+ LDWE=1,LD2WE=1,LDWD=1,LD2WD=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,LUNERR,LUNRPT,M,N,NP,NQ
|
||||
INTEGER IWORK(LIWORK)
|
||||
DOUBLE PRECISION BETA(MAXNP),
|
||||
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
|
||||
|
||||
C SPECIFY DEFAULT VALUES FOR DODR ARGUMENTS
|
||||
WE(1,1,1) = -1.0D0
|
||||
WD(1,1,1) = -1.0D0
|
||||
JOB = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
|
||||
C SET UP ODRPACK REPORT FILES
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT2')
|
||||
|
||||
C READ PROBLEM DATA
|
||||
OPEN (UNIT=5,FILE='DATA2')
|
||||
READ (5,FMT=*) N,M,NP,NQ
|
||||
READ (5,FMT=*) (BETA(I),I=1,NP)
|
||||
DO 10 I=1,N
|
||||
READ (5,FMT=*) (X(I,J),J=1,M)
|
||||
10 CONTINUE
|
||||
|
||||
C SPECIFY TASK: IMPLICIT ORTHOGONAL DISTANCE REGRESSION
|
||||
C WITH FORWARD FINITE DIFFERENCE DERIVATIVES
|
||||
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
|
||||
C DELTA INITIALIZED TO ZERO
|
||||
C NOT A RESTART
|
||||
JOB = 00001
|
||||
|
||||
C COMPUTE SOLUTION
|
||||
CALL DODR(FCN,
|
||||
+ N,M,NP,NQ,
|
||||
+ BETA,
|
||||
+ Y,LDY,X,LDX,
|
||||
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
|
||||
+ JOB,
|
||||
+ IPRINT,LUNERR,LUNRPT,
|
||||
+ WORK,LWORK,IWORK,LIWORK,
|
||||
+ INFO)
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,
|
||||
+ LDN,LDM,LDNP,
|
||||
+ BETA,XPLUSD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ IDEVAL,F,FJACB,FJACD,
|
||||
+ ISTOP)
|
||||
|
||||
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
|
||||
IF (BETA(1) .GT. 0.0D0) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
ELSE
|
||||
ISTOP = 0
|
||||
END IF
|
||||
|
||||
C COMPUTE PREDICTED VALUES
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 110 L = 1,NQ
|
||||
DO 100 I = 1,N
|
||||
F(I,L) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 +
|
||||
+ 2*BETA(4)*(XPLUSD(I,1)-BETA(1))*
|
||||
+ (XPLUSD(I,2)-BETA(2)) +
|
||||
+ BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0D0
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,248 @@
|
||||
PROGRAM SAMPLE
|
||||
|
||||
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 FCN 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=5,MAXN=100,MAXNP=25,MAXNQ=5,
|
||||
+ LDY=MAXN,LDX=MAXN,
|
||||
+ LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
|
||||
+ LDIFX=MAXN,LDSCLD=1,LDSTPD=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)
|
||||
EXTERNAL FCN
|
||||
|
||||
|
||||
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 = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0D0
|
||||
SSTOL = -1.0D0
|
||||
PARTOL = -1.0D0
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0D0
|
||||
STPD(1,1) = -1.0D0
|
||||
SCLB(1) = -1.0D0
|
||||
SCLD(1,1) = -1.0D0
|
||||
|
||||
C SET UP ODRPACK REPORT FILES
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT3')
|
||||
|
||||
C READ PROBLEM DATA
|
||||
OPEN (UNIT=5,FILE='DATA3')
|
||||
READ (5,FMT=*) N,M,NP,NQ
|
||||
READ (5,FMT=*) (BETA(I),I=1,NP)
|
||||
DO 10 I=1,N
|
||||
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
|
||||
10 CONTINUE
|
||||
|
||||
C SPECIFY TASK AS EXPLICIT ORTHOGONAL DISTANCE REGRESSION
|
||||
C WITH CENTRAL DIFFERENCE DERIVATIVES
|
||||
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
|
||||
C DELTA INITIALIZED BY USER
|
||||
C NOT A RESTART
|
||||
C AND INDICATE LONG INITIAL REPORT
|
||||
C NO ITERATION REPORTS
|
||||
C LONG FINAL REPORT
|
||||
JOB = 01010
|
||||
IPRINT = 2002
|
||||
|
||||
C INITIALIZE DELTA, AND SPECIFY FIRST DECADE OF FREQUENCIES AS FIXED
|
||||
DO 20 I=1,N
|
||||
IF (X(I,1).LT.100.0D0) THEN
|
||||
WORK(I) = 0.0D0
|
||||
IFIXX(I,1) = 0
|
||||
ELSE IF (X(I,1).LE.150.0D0) THEN
|
||||
WORK(I) = 0.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.1000.0D0) THEN
|
||||
WORK(I) = 25.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.10000.0D0) THEN
|
||||
WORK(I) = 560.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.100000.0D0) THEN
|
||||
WORK(I) = 9500.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE
|
||||
WORK(I) = 144000.0D0
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
20 CONTINUE
|
||||
|
||||
C SET WEIGHTS
|
||||
DO 30 I=1,N
|
||||
IF (X(I,1).EQ.100.0D0 .OR. X(I,1).EQ.150.0D0) THEN
|
||||
WE(I,1,1) = 0.0D0
|
||||
WE(I,1,2) = 0.0D0
|
||||
WE(I,2,1) = 0.0D0
|
||||
WE(I,2,2) = 0.0D0
|
||||
ELSE
|
||||
WE(I,1,1) = 559.6D0
|
||||
WE(I,1,2) = -1634.0D0
|
||||
WE(I,2,1) = -1634.0D0
|
||||
WE(I,2,2) = 8397.0D0
|
||||
END IF
|
||||
WD(I,1,1) = (1.0D-4)/(X(I,1)**2)
|
||||
30 CONTINUE
|
||||
|
||||
C COMPUTE SOLUTION
|
||||
CALL DODRC(FCN,
|
||||
+ 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)
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,
|
||||
+ LDN,LDM,LDNP,
|
||||
+ BETA,XPLUSD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ IDEVAL,F,FJACB,FJACD,
|
||||
+ ISTOP)
|
||||
|
||||
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,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 LOCAL VARIABLES
|
||||
DOUBLE PRECISION FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
|
||||
INTRINSIC ATAN2,EXP,SQRT
|
||||
|
||||
|
||||
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
|
||||
DO 10 I=1,N
|
||||
IF (XPLUSD(I,1).LT.0.0D0) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
END IF
|
||||
10 CONTINUE
|
||||
ISTOP = 0
|
||||
|
||||
PI = 3.141592653589793238462643383279D0
|
||||
|
||||
THETA = PI*BETA(4)*0.5D0
|
||||
CTHETA = COS(THETA)
|
||||
STHETA = SIN(THETA)
|
||||
|
||||
C COMPUTE PREDICTED VALUES
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 100 I = 1,N
|
||||
FREQ = XPLUSD(I,1)
|
||||
OMEGA = (2.0D0*PI*FREQ*EXP(-BETA(3)))**BETA(4)
|
||||
PHI = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
|
||||
R = (BETA(1)-BETA(2)) *
|
||||
+ SQRT((1+OMEGA*CTHETA)**2+
|
||||
+ (OMEGA*STHETA)**2)**(-BETA(5))
|
||||
F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
|
||||
F(I,2) = R*SIN(BETA(5)*PHI)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,203 @@
|
||||
*DMPREC
|
||||
DOUBLE PRECISION FUNCTION DMPREC()
|
||||
C***BEGIN PROLOGUE DPREC
|
||||
C***REFER TO DODR,DODRC
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***DATE WRITTEN 860529 (YYMMDD)
|
||||
C***REVISION DATE 920304 (YYMMDD)
|
||||
C***PURPOSE DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER
|
||||
C ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE
|
||||
C T-DIGIT, BASE-B FORM
|
||||
C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
|
||||
C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND
|
||||
C 0 .LT. X(1).
|
||||
C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE,
|
||||
C EITHER
|
||||
C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY
|
||||
C REMOVING THE C FROM COLUMN 1
|
||||
C OR
|
||||
C SET B, TD AND TS USING I1MACH BY ACTIVATING
|
||||
C THE DECLARATION STATEMENTS FOR I1MACH
|
||||
C AND THE STATEMENTS PRECEEDING THE FIRST
|
||||
C EXECUTABLE STATEMENT BELOW.
|
||||
C***END PROLOGUE DPREC
|
||||
|
||||
C...LOCAL SCALARS
|
||||
DOUBLE PRECISION
|
||||
+ B
|
||||
INTEGER
|
||||
+ TD,TS
|
||||
|
||||
C...EXTERNAL FUNCTIONS
|
||||
C INTEGER
|
||||
C + I1MACH
|
||||
C EXTERNAL
|
||||
C + I1MACH
|
||||
|
||||
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
|
||||
|
||||
C DOUBLE PRECISION B
|
||||
C THE BASE OF THE TARGET MACHINE.
|
||||
C (MAY BE DEFINED USING I1MACH(10).)
|
||||
C INTEGER TD
|
||||
C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION.
|
||||
C (MAY BE DEFINED USING I1MACH(14).)
|
||||
C INTEGER TS
|
||||
C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION.
|
||||
C (MAY BE DEFINED USING I1MACH(11).)
|
||||
|
||||
|
||||
C MACHINE CONSTANTS FOR COMPUTERS FOLLOWING IEEE ARITHMETIC STANDARD
|
||||
C (E.G., MOTOROLA 68000 BASED MACHINES SUCH AS SUN AND SPARC
|
||||
C WORKSTATIONS, AND AT&T PC 7300; AND 8087 BASED MICROS SUCH AS THE
|
||||
C IBM PC AND THE AT&T 6300).
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 60 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
|
||||
C THE BURROUGHS 6700/7700 SYSTEMS
|
||||
C DATA B / 8 /
|
||||
C DATA TS / 13 /
|
||||
C DATA TD / 26 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER)
|
||||
C THE CYBER 170/180 SERIES UNDER NOS
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 48 /
|
||||
C DATA TD / 96 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER)
|
||||
C THE CYBER 170/180 SERIES UNDER NOS/VE
|
||||
C THE CYBER 200 SERIES
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 47 /
|
||||
C DATA TD / 94 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE CRAY
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 47 /
|
||||
C DATA TD / 94 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HARRIS COMPUTER
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 38 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70
|
||||
C THE HONEYWELL 600/6000 SERIES
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 63 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C (3 WORD DOUBLE PRECISION OPTION WITH FTN4)
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 39 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C (4 WORD DOUBLE PRECISION OPTION WITH FTN4)
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 55 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE IBM PC
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32
|
||||
C INTERDATA (PERKIN ELMER) 8/32
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 54 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 62 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 56 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 47 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR SUN AND SPARC WORKSTATIONS
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 60 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 56 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 56 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT DMPREC
|
||||
|
||||
|
||||
C B = I1MACH(10)
|
||||
C TS = I1MACH(11)
|
||||
C TD = I1MACH(14)
|
||||
|
||||
DMPREC = B ** (1-TD)
|
||||
|
||||
RETURN
|
||||
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,14 @@
|
||||
12 1 3 1
|
||||
1500.0 -50.0 -0.1
|
||||
0.0 1265.0
|
||||
0.0 1263.6
|
||||
5.0 1258.0
|
||||
7.0 1254.0
|
||||
7.5 1253.0
|
||||
10.0 1249.8
|
||||
16.0 1237.0
|
||||
26.0 1218.0
|
||||
30.0 1220.6
|
||||
34.0 1213.8
|
||||
34.5 1215.5
|
||||
100.0 1212.0
|
||||
@@ -0,0 +1,22 @@
|
||||
20 2 5 1
|
||||
-1.0 -3.0 0.09 0.02 0.08
|
||||
0.50 -0.12
|
||||
1.20 -0.60
|
||||
1.60 -1.00
|
||||
1.86 -1.40
|
||||
2.12 -2.54
|
||||
2.36 -3.36
|
||||
2.44 -4.00
|
||||
2.36 -4.75
|
||||
2.06 -5.25
|
||||
1.74 -5.64
|
||||
1.34 -5.97
|
||||
0.90 -6.32
|
||||
-0.28 -6.44
|
||||
-0.78 -6.44
|
||||
-1.36 -6.41
|
||||
-1.90 -6.25
|
||||
-2.50 -5.88
|
||||
-2.88 -5.50
|
||||
-3.18 -5.24
|
||||
-3.44 -4.86
|
||||
@@ -0,0 +1,25 @@
|
||||
23 1 5 2
|
||||
4.0 2.0 7.0 0.40 0.50
|
||||
30.0 4.220 0.136
|
||||
50.0 4.167 0.167
|
||||
70.0 4.132 0.188
|
||||
100.0 4.038 0.212
|
||||
150.0 4.019 0.236
|
||||
200.0 3.956 0.257
|
||||
300.0 3.884 0.276
|
||||
500.0 3.784 0.297
|
||||
700.0 3.713 0.309
|
||||
1000.0 3.633 0.311
|
||||
1500.0 3.540 0.314
|
||||
2000.0 3.433 0.311
|
||||
3000.0 3.358 0.305
|
||||
5000.0 3.258 0.289
|
||||
7000.0 3.193 0.277
|
||||
10000.0 3.128 0.255
|
||||
15000.0 3.059 0.240
|
||||
20000.0 2.984 0.218
|
||||
30000.0 2.934 0.202
|
||||
50000.0 2.876 0.182
|
||||
70000.0 2.838 0.168
|
||||
100000.0 2.798 0.153
|
||||
150000.0 2.759 0.139
|
||||
@@ -0,0 +1,236 @@
|
||||
|
||||
PROGRAM SAMPLE
|
||||
USE ODRPACK95
|
||||
USE REAL_PRECISION
|
||||
|
||||
C ODRPACK95 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 ==> X Explanatory variable
|
||||
C ==> WE "Epsilon" weights
|
||||
C ==> WD "Delta" weights
|
||||
C ==> IFIXB Indicators for "fixing" parameters (BETA)
|
||||
C ==> IFIXX Indicators for "fixing" explanatory variable (X)
|
||||
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 ==> SCLB Scale values for parameters BETA
|
||||
C ==> SCLD Scale values for errors delta in explanatory variable
|
||||
C <==> WORK REAL (KIND=R8) work vector
|
||||
C <== IWORK Integer work vector
|
||||
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=5,MAXN=25,MAXNP=5,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(:)
|
||||
REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
|
||||
REAL (KIND=R8) BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
|
||||
& STPB(MAXNP),STPD(LDSTPD,MAXM),
|
||||
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
POINTER IWORK,WORK
|
||||
|
||||
|
||||
C Allocate work arrays
|
||||
ALLOCATE(IWORK(LIWORK),WORK(LWORK))
|
||||
|
||||
C Specify default values for ODR arguments
|
||||
WE(1,1,1) = -1.0E0_R8
|
||||
WD(1,1,1) = -1.0E0_R8
|
||||
IFIXB(1) = -1
|
||||
IFIXX(1,1) = -1
|
||||
JOB = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0E0_R8
|
||||
SSTOL = -1.0E0_R8
|
||||
PARTOL = -1.0E0_R8
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0E0_R8
|
||||
STPD(1,1) = -1.0E0_R8
|
||||
SCLB(1) = -1.0E0_R8
|
||||
SCLD(1,1) = -1.0E0_R8
|
||||
|
||||
C Set up ODRPACK95 report files
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT1')
|
||||
|
||||
C Read problem data, and set nondefault value for argument IFIXX
|
||||
OPEN (UNIT=5,FILE='DATA1')
|
||||
READ (5,FMT=*) N,M,NP,NQ
|
||||
READ (5,FMT=*) (BETA(I),I=1,NP)
|
||||
DO 10 I=1,N
|
||||
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
|
||||
IF (X(I,1).EQ.0.0E0_R8 .OR. X(I,1).EQ.100.0E0_R8) THEN
|
||||
IFIXX(I,1) = 0
|
||||
ELSE
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
10 CONTINUE
|
||||
|
||||
C Specify task: Explicit orthogonal distance regression
|
||||
C With user supplied derivatives (checked)
|
||||
C Covariance matrix constructed with recomputed derivatives
|
||||
C Delta initialized to zero
|
||||
C Not a restart
|
||||
C And indicate short initial report
|
||||
C Short iteration reports every iteration, and
|
||||
C Long final report
|
||||
JOB = 00020
|
||||
IPRINT = 1112
|
||||
|
||||
C Compute solution
|
||||
CALL ODR(FCN=FCN,
|
||||
& N=N,M=M,NP=NP,NQ=NQ,
|
||||
& BETA=BETA,
|
||||
& Y=Y,X=X,
|
||||
& WE=WE,WD=WD,
|
||||
& IFIXB=IFIXB,IFIXX=IFIXX,
|
||||
& JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
|
||||
& SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
|
||||
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
|
||||
& STPB=STPB,STPD=STPD,
|
||||
& SCLB=SCLB,SCLD=SCLD,
|
||||
& WORK=WORK,IWORK=IWORK,
|
||||
& INFO=INFO)
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,
|
||||
& LDN,LDM,LDNP,
|
||||
& BETA,XPLUSD,
|
||||
& IFIXB,IFIXX,LDIFX,
|
||||
& IDEVAL,F,FJACB,FJACD,
|
||||
& ISTOP)
|
||||
|
||||
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; ODRPACK95 should select values
|
||||
C closer to most recently used values if possible
|
||||
C -1 means current BETA and X+DELTA are
|
||||
C not acceptable; ODRPACK95 should stop
|
||||
|
||||
C Used modules
|
||||
USE REAL_PRECISION
|
||||
|
||||
C Input arguments, not to be changed by this routine:
|
||||
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
||||
C Output arguments:
|
||||
REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
||||
C Local variables
|
||||
INTRINSIC EXP
|
||||
|
||||
|
||||
C Do something with IFIXB and IFIXX to avoid warnings that they are not being
|
||||
C used. This is simply not to worry users that the example program is failing.
|
||||
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0 ) THEN
|
||||
C Do nothing.
|
||||
END IF
|
||||
|
||||
|
||||
C Check for unacceptable values for this problem
|
||||
IF (BETA(1) .LT. 0.0E0_R8) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
ELSE
|
||||
ISTOP = 0
|
||||
END IF
|
||||
|
||||
C Compute predicted values
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 110 L = 1,NQ
|
||||
DO 100 I = 1,N
|
||||
F(I,L) = BETA(1) +
|
||||
& BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
|
||||
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) = 1.0E0_R8
|
||||
FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
|
||||
FJACB(I,3,L) = BETA(2)*2*
|
||||
& (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
|
||||
& EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
END IF
|
||||
|
||||
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(2)*2*
|
||||
& (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
|
||||
& EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,170 @@
|
||||
PROGRAM SAMPLE
|
||||
USE ODRPACK95
|
||||
USE REAL_PRECISION
|
||||
|
||||
C ODRPACK95 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 (unused when model is implicit)
|
||||
C ==> X Explanatory variable
|
||||
C ==> WE Initial penalty parameter for implicit model
|
||||
C ==> WD "Delta" weights
|
||||
C ==> JOB Task to be performed
|
||||
C ==> IPRINT Print control
|
||||
C ==> LUNERR Logical unit for error reports
|
||||
C ==> LUNRPT Logical unit for computation reports
|
||||
C <==> WORK REAL (KIND=R8) work vector
|
||||
C <== IWORK Integer work vector
|
||||
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 LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
||||
& LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
||||
PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=2,
|
||||
& LDY=MAXN,LDX=MAXN,
|
||||
& LDWE=1,LD2WE=1,LDWD=1,LD2WD=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,LUNERR,LUNRPT,M,N,NP,NQ
|
||||
INTEGER IWORK(:)
|
||||
REAL (KIND=R8) BETA(MAXNP),
|
||||
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
POINTER IWORK,WORK
|
||||
|
||||
|
||||
C Allocate work arrays
|
||||
ALLOCATE(IWORK(LIWORK),WORK(LWORK))
|
||||
|
||||
C Specify default values for DODR arguments
|
||||
WE(1,1,1) = -1.0E0_R8
|
||||
WD(1,1,1) = -1.0E0_R8
|
||||
JOB = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
|
||||
C Set up ODRPACK95 report files
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT2')
|
||||
|
||||
C Read problem data
|
||||
OPEN (UNIT=5,FILE='DATA2')
|
||||
READ (5,FMT=*) N,M,NP,NQ
|
||||
READ (5,FMT=*) (BETA(I),I=1,NP)
|
||||
DO 10 I=1,N
|
||||
READ (5,FMT=*) (X(I,J),J=1,M)
|
||||
10 CONTINUE
|
||||
|
||||
C Specify task: Implicit orthogonal distance regression
|
||||
C With forward finite difference derivatives
|
||||
C Covariance matrix constructed with recomputed derivatives
|
||||
C DELTA initialized to zero
|
||||
C Not a restart
|
||||
JOB = 00001
|
||||
|
||||
C Compute solution
|
||||
CALL ODR(FCN=FCN,
|
||||
& N=N,M=M,NP=NP,NQ=NQ,
|
||||
& BETA=BETA,
|
||||
& Y=Y,X=X,
|
||||
& WE=WE,WD=WD,
|
||||
& JOB=JOB,
|
||||
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
|
||||
& WORK=WORK,IWORK=IWORK,
|
||||
& INFO=INFO)
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,
|
||||
& LDN,LDM,LDNP,
|
||||
& BETA,XPLUSD,
|
||||
& IFIXB,IFIXX,LDIFX,
|
||||
& IDEVAL,F,FJACB,FJACD,
|
||||
& ISTOP)
|
||||
|
||||
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; ODRPACK95 should select values
|
||||
C closer to most recently used values if possible
|
||||
C -1 Means current BETA and X+DELTA are
|
||||
C not acceptable; ODRPACK95 should stop
|
||||
|
||||
C Used Modules
|
||||
USE REAL_PRECISION
|
||||
|
||||
C Input arguments, not to be changed by this routine:
|
||||
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
||||
C Output arguments:
|
||||
REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
||||
|
||||
|
||||
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
|
||||
C are not being used. This is simply not to worry users that the example
|
||||
C program is failing.
|
||||
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
|
||||
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
|
||||
C Do nothing.
|
||||
END IF
|
||||
|
||||
|
||||
C Check for unacceptable values for this problem
|
||||
IF (BETA(1) .GT. 0.0E0_R8) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
ELSE
|
||||
ISTOP = 0
|
||||
END IF
|
||||
|
||||
C Compute predicted values
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 110 L = 1,NQ
|
||||
DO 100 I = 1,N
|
||||
F(I,L) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 +
|
||||
& 2*BETA(4)*(XPLUSD(I,1)-BETA(1))*
|
||||
& (XPLUSD(I,2)-BETA(2)) +
|
||||
& BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0E0_R8
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,301 @@
|
||||
PROGRAM SAMPLE
|
||||
USE ODRPACK95
|
||||
USE REAL_PRECISION
|
||||
|
||||
C ODRPACK95 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 ==> X Explanatory variable
|
||||
C ==> WE "Epsilon" weights
|
||||
C ==> WD "Delta" weights
|
||||
C ==> IFIXB Indicators for "fixing" parameters (BETA)
|
||||
C ==> IFIXX Indicators for "fixing" explanatory variable (X)
|
||||
C ==> JOB Task to be performed
|
||||
C ==> NDIGIT Good digits in subroutine fcn 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 ==> SCLB Scale values for parameters BETA
|
||||
C ==> SCLD Scale values for errors DELTA in explanatory variable
|
||||
C <==> WORK REAL (KIND=R8) work vector
|
||||
C <== IWORK Integer work vector
|
||||
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=5,MAXN=100,MAXNP=25,MAXNQ=5,
|
||||
& LDY=MAXN,LDX=MAXN,
|
||||
& LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
|
||||
& LDIFX=MAXN,LDSCLD=1,LDSTPD=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(:)
|
||||
REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
|
||||
REAL (KIND=R8) BETA(MAXNP),DELTA(:,:),
|
||||
& SCLB(MAXNP),SCLD(LDSCLD,MAXM),
|
||||
& STPB(MAXNP),STPD(LDSTPD,MAXM),
|
||||
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
POINTER DELTA,IWORK,WORK
|
||||
|
||||
|
||||
C Specify default values for DODRC arguments
|
||||
WE(1,1,1) = -1.0E0_R8
|
||||
WD(1,1,1) = -1.0E0_R8
|
||||
IFIXB(1) = -1
|
||||
IFIXX(1,1) = -1
|
||||
JOB = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0E0_R8
|
||||
SSTOL = -1.0E0_R8
|
||||
PARTOL = -1.0E0_R8
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0E0_R8
|
||||
STPD(1,1) = -1.0E0_R8
|
||||
SCLB(1) = -1.0E0_R8
|
||||
SCLD(1,1) = -1.0E0_R8
|
||||
|
||||
C Set up ODRPACK95 report files
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT3')
|
||||
|
||||
C Read problem data
|
||||
OPEN (UNIT=5,FILE='DATA3')
|
||||
READ (5,FMT=*) N,M,NP,NQ
|
||||
READ (5,FMT=*) (BETA(I),I=1,NP)
|
||||
DO 10 I=1,N
|
||||
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
|
||||
10 CONTINUE
|
||||
|
||||
C Allocate work arrays
|
||||
ALLOCATE(DELTA(N,M),IWORK(LIWORK),WORK(LWORK))
|
||||
|
||||
C Specify task as explicit orthogonal distance regression
|
||||
C With central difference derivatives
|
||||
C Covariance matrix constructed with recomputed derivatives
|
||||
C DELTA initialized by user
|
||||
C Not a restart
|
||||
C And indicate long initial report
|
||||
C No iteration reports
|
||||
C Long final report
|
||||
JOB = 01010
|
||||
IPRINT = 2002
|
||||
|
||||
C Initialize DELTA, and specify first decade of frequencies as fixed
|
||||
DO 20 I=1,N
|
||||
IF (X(I,1).LT.100.0E0_R8) THEN
|
||||
DELTA(I,1) = 0.0E0_R8
|
||||
IFIXX(I,1) = 0
|
||||
ELSE IF (X(I,1).LE.150.0E0_R8) THEN
|
||||
DELTA(I,1) = 0.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.1000.0E0_R8) THEN
|
||||
DELTA(I,1) = 25.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.10000.0E0_R8) THEN
|
||||
DELTA(I,1) = 560.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.100000.0E0_R8) THEN
|
||||
DELTA(I,1) = 9500.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE
|
||||
DELTA(I,1) = 144000.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
20 CONTINUE
|
||||
|
||||
C Set weights
|
||||
DO 30 I=1,N
|
||||
IF (X(I,1).EQ.100.0E0_R8 .OR. X(I,1).EQ.150.0E0_R8) THEN
|
||||
WE(I,1,1) = 0.0E0_R8
|
||||
WE(I,1,2) = 0.0E0_R8
|
||||
WE(I,2,1) = 0.0E0_R8
|
||||
WE(I,2,2) = 0.0E0_R8
|
||||
ELSE
|
||||
WE(I,1,1) = 559.6E0_R8
|
||||
WE(I,1,2) = -1634.0E0_R8
|
||||
WE(I,2,1) = -1634.0E0_R8
|
||||
WE(I,2,2) = 8397.0E0_R8
|
||||
END IF
|
||||
WD(I,1,1) = (1.0E-4_R8)/(X(I,1)**2)
|
||||
30 CONTINUE
|
||||
|
||||
C Compute solution
|
||||
CALL ODR(FCN=FCN,
|
||||
& N=N,M=M,NP=NP,NQ=NQ,
|
||||
& BETA=BETA,
|
||||
& Y=Y,X=X,
|
||||
& DELTA=DELTA,
|
||||
& WE=WE,WD=WD,
|
||||
& IFIXB=IFIXB,IFIXX=IFIXX,
|
||||
& JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
|
||||
& SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
|
||||
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
|
||||
& STPB=STPB,STPD=STPD,
|
||||
& SCLB=SCLB,SCLD=SCLD,
|
||||
& WORK=WORK,IWORK=IWORK,
|
||||
& INFO=INFO)
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,
|
||||
& LDN,LDM,LDNP,
|
||||
& BETA,XPLUSD,
|
||||
& IFIXB,IFIXX,LDIFX,
|
||||
& IDEVAL,F,FJACB,FJACD,
|
||||
& ISTOP)
|
||||
|
||||
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; ODRPACK95 should select values
|
||||
C closer to most recently used values if possible
|
||||
C -1 Means current BETA and X+DELTA are
|
||||
C not acceptable; ODRPACK95 should stop
|
||||
|
||||
C Used modules
|
||||
USE REAL_PRECISION
|
||||
|
||||
C Input arguments, not to be changed by this routine:
|
||||
INTEGER I,IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
||||
C Output arguments:
|
||||
REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
||||
C Local variables
|
||||
REAL (KIND=R8) FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
|
||||
INTRINSIC ATAN2,EXP,SQRT
|
||||
|
||||
|
||||
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
|
||||
C are not being used. This is simply not to worry users that the example
|
||||
C program is failing.
|
||||
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
|
||||
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
|
||||
C Do nothing.
|
||||
END IF
|
||||
|
||||
|
||||
C Check for unacceptable values for this problem
|
||||
DO 10 I=1,N
|
||||
IF (XPLUSD(I,1).LT.0.0E0_R8) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
END IF
|
||||
10 CONTINUE
|
||||
ISTOP = 0
|
||||
|
||||
PI = 3.141592653589793238462643383279E0_R8
|
||||
|
||||
THETA = PI*BETA(4)*0.5E0_R8
|
||||
CTHETA = COS(THETA)
|
||||
STHETA = SIN(THETA)
|
||||
|
||||
C Compute predicted values
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 100 I = 1,N
|
||||
FREQ = XPLUSD(I,1)
|
||||
OMEGA = (2.0E0_R8*PI*FREQ*EXP(-BETA(3)))**BETA(4)
|
||||
PHI = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
|
||||
R = (BETA(1)-BETA(2)) *
|
||||
& SQRT((1+OMEGA*CTHETA)**2+
|
||||
& (OMEGA*STHETA)**2)**(-BETA(5))
|
||||
F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
|
||||
F(I,2) = R*SIN(BETA(5)*PHI)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,151 @@
|
||||
C This sample problem comes from Zwolak et al. 2001 (High Performance Computing
|
||||
C Symposium, "Estimating rate constants in cell cycle models"). The call to
|
||||
C ODRPACK95 is modified from the call the authors make to ODRPACK. This is
|
||||
C done to illustrate the need for bounds. The authors could just have easily
|
||||
C used the call statement here to solve their problem.
|
||||
C
|
||||
C Curious users are encouraged to remove the bounds in the call statement,
|
||||
C run the code, and compare the results to the current call statement.
|
||||
PROGRAM SAMPLE
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
IMPLICIT NONE
|
||||
C INTEGER :: I
|
||||
C REAL (KIND=R8) :: C, M, TOUT
|
||||
INTERFACE
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
END SUBROUTINE FCN
|
||||
END INTERFACE
|
||||
REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
|
||||
OPEN(9,FILE="REPORT4")
|
||||
CALL ODR(
|
||||
+ FCN,
|
||||
+ N = 5, M = 1, NP = 3, NQ = 1,
|
||||
+ BETA = BETA,
|
||||
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
|
||||
+ UPPER = (/ 1000.0_R8, 1000.0_R8, 1000.0_R8 /),
|
||||
+ IPRINT = 2122,
|
||||
+ LUNRPT = 9,
|
||||
+ MAXIT = 20
|
||||
+)
|
||||
CLOSE(9)
|
||||
C The following code will reproduce the plot in Figure 2 of Zwolak et
|
||||
C al. 2001.
|
||||
C DO I = 0, 100
|
||||
C C = 0.05+(0.7-0.05)*I/100
|
||||
C TOUT = 1440.0D0
|
||||
C !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
|
||||
C CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8,
|
||||
C + 9.23138811E+00_R8,0.0D0,TOUT,C/2)
|
||||
C WRITE(*,*) C, TOUT
|
||||
C END DO
|
||||
END PROGRAM
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
IMPLICIT NONE
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
! Local variables
|
||||
REAL(KIND=R8) :: MOUT
|
||||
INTEGER :: I
|
||||
ISTOP = 0
|
||||
FJACB(:,:,:) = 0.0E0_R8
|
||||
FJACD(:,:,:) = 0.0E0_R8
|
||||
IF ( MOD(IDEVAL,10).GE.1 ) THEN
|
||||
DO I = 1, N
|
||||
F(I,1) = 1440.0_R8
|
||||
CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
|
||||
+ F(I,1),XPLUSD(I,1)/2)
|
||||
END DO
|
||||
END IF
|
||||
END SUBROUTINE FCN
|
||||
|
||||
C-------------------------------------------------------------------------------
|
||||
C
|
||||
C MPF
|
||||
C
|
||||
C If ROOT is not zero then returns value of time when M==ROOT in TOUT. Else,
|
||||
C runs until TOUT and returns value in M. If PRINT_EVERY is non-zero then
|
||||
C the solution is printed every PRINT_EVERY time units or every H (which ever
|
||||
C is greater).
|
||||
C
|
||||
C This routine is not meant to be precise, it is only intended to be good
|
||||
C enough for providing a working example of ODRPACK95 with bounds. 4th order
|
||||
C Runge Kutta and linear interpolation are used for numerical integration and
|
||||
C root finding, respectively.
|
||||
C
|
||||
C M - MPF
|
||||
C C - Total Cyclin
|
||||
C KWEE, K25, K25P - Model parameters (BETA(1:3))
|
||||
C
|
||||
SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8), INTENT(OUT) :: M
|
||||
REAL (KIND=R8), INTENT(IN) :: C, KWEE, K25, K25P,
|
||||
+ PRINT_EVERY, ROOT
|
||||
REAL (KIND=R8), INTENT(INOUT) :: TOUT
|
||||
! Local variables
|
||||
REAL (KIND=R8), PARAMETER :: H = 1.0D-1
|
||||
REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
|
||||
REAL (KIND=R8) :: K1, K2, K3, K4
|
||||
INTERFACE
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
END FUNCTION
|
||||
END INTERFACE
|
||||
M = 0.0D0
|
||||
T = 0.0D0
|
||||
LAST_PRINT = 0.0D0
|
||||
IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
|
||||
WRITE(*,*) T, M
|
||||
END IF
|
||||
DO WHILE ( T .LT. TOUT )
|
||||
LAST_T = T
|
||||
LAST_M = M
|
||||
K1 = H*DMDT(M,C,KWEE,K25,K25P)
|
||||
K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
|
||||
K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
|
||||
K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
|
||||
M = M+(K1+2*K2+2*K3+K4)/6
|
||||
T = T + H
|
||||
IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND.
|
||||
+ PRINT_EVERY .GT. 0.0D0 )
|
||||
+ THEN
|
||||
WRITE(*,*) T, M
|
||||
LAST_PRINT = T
|
||||
END IF
|
||||
IF ( ROOT .GT. 0.0D0 ) THEN
|
||||
IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
|
||||
TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
END SUBROUTINE MPF
|
||||
|
||||
|
||||
C Equation from Zwolak et al. 2001.
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
RES = KWEE*M+(K25+K25P*M**2)*(C-M)
|
||||
END FUNCTION DMDT
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,108 @@
|
||||
# This makefile creates a library >> odrpack.a << comprised of both the single
|
||||
# and double precision versions of ODRPACK. It also runs each of the test
|
||||
# problems for both versions. Change S_SOURCE (D_SOURCE) and S_TESTS (D_TESTS)
|
||||
# as approprite if only the double precision (single precision) version is to
|
||||
# be installed.
|
||||
|
||||
# NB: This makefile creates a temporary subdirectory, >> ZodrpackZ <<, for
|
||||
# splitting and compiling the individual subprograms in each of the
|
||||
# release files. The makefile will fail if such a subdirectory already
|
||||
# exists. The subdirectory is automatically removed upon completion.
|
||||
|
||||
# Note also that some systems need to invoke ranlib, while others do not:
|
||||
# if your system lacks ranlib, simply comment out the ranlib invocation
|
||||
# below. Also, compiler names and options, and/or names of data files may
|
||||
# have to be modified for some systems.
|
||||
|
||||
|
||||
.SUFFIXES: .f .o .a .out
|
||||
F77 = f77 # specify compiler name as appropriate
|
||||
F77OPT = -u -O # specify desired compiler options here
|
||||
LIB = odrpack.a # specify ODRPACK library name
|
||||
DIR = ZodrpackZ # specify temporary subdirectory name
|
||||
L = # specify directory for library files
|
||||
|
||||
# Specify what files are to be installed, where
|
||||
# D_SOURCE = double-precision non-test source files
|
||||
# = d_odr.f d_lpkbls.f d_mprec.f
|
||||
# S_SOURCE = single-precision non-test source files
|
||||
# = s_odr.f s_lpkbls.f s_mprec.f
|
||||
D_SOURCE = d_odr.f d_lpkbls.f d_mprec.f
|
||||
S_SOURCE = s_odr.f s_lpkbls.f s_mprec.f
|
||||
|
||||
|
||||
|
||||
# Test installation...
|
||||
|
||||
tests: D_TESTS S_TESTS
|
||||
D_TESTS: d_drive1.out d_drive2.out d_drive3.out d_test.out
|
||||
S_TESTS: s_drive1.out s_drive2.out s_drive3.out s_test.out
|
||||
|
||||
|
||||
# Create ODRPACK library...
|
||||
|
||||
$(LIB): $(D_SOURCE) $(S_SOURCE)
|
||||
mkdir $(DIR)
|
||||
cd $(DIR) ;\
|
||||
for i in $? ;\
|
||||
do fsplit ../$$i ;\
|
||||
$(F77) -c $(F77OPT) *.f ;\
|
||||
ar ruv ../$@ *.o ;\
|
||||
rm *.f *.o ;\
|
||||
done ;\
|
||||
cd ..
|
||||
rm -rf $(DIR)
|
||||
ranlib $(LIB)
|
||||
|
||||
d_mprec.f: d_mprec0.f
|
||||
true # Obtain d_mprec.f from d_mprec0.f by activating the statements
|
||||
false # appropriate to your machine
|
||||
|
||||
s_mprec.f: s_mprec0.f
|
||||
true # Obtain s_mprec.f from s_mprec0.f by activating the statements
|
||||
false # appropriate to your machine
|
||||
|
||||
|
||||
# Run double-precision test problems...
|
||||
|
||||
d_drive1.out: d_drive1.f $(LIB) data1.dat
|
||||
cp data1.dat DATA1
|
||||
$(F77) d_drive1.f $(LIB) $L; a.out
|
||||
mv REPORT1 $@; rm -f DATA1 d_drive1.o a.out
|
||||
|
||||
d_drive2.out: d_drive2.f $(LIB) data2.dat
|
||||
cp data2.dat DATA2
|
||||
$(F77) d_drive2.f $(LIB) $L; a.out
|
||||
mv REPORT2 $@; rm -f DATA2 d_drive2.o a.out
|
||||
|
||||
d_drive3.out: d_drive3.f $(LIB) data3.dat
|
||||
cp data3.dat DATA3
|
||||
$(F77) d_drive3.f $(LIB) $L; a.out
|
||||
mv REPORT3 $@; rm -f DATA3 d_drive3.o a.out
|
||||
|
||||
d_test.out: d_test.f $(LIB)
|
||||
$(F77) d_test.f $(LIB) $L; a.out
|
||||
mv REPORT $@; cat SUMMARY >> $@; rm -f d_test.o a.out SUMMARY
|
||||
|
||||
|
||||
# Run single-precision test problems...
|
||||
|
||||
s_drive1.out: s_drive1.f $(LIB) data1.dat
|
||||
cp data1.dat DATA1
|
||||
$(F77) s_drive1.f $(LIB) $L; a.out
|
||||
mv REPORT1 $@; rm -f DATA1 s_drive1.o a.out
|
||||
|
||||
s_drive2.out: s_drive2.f $(LIB) data2.dat
|
||||
cp data2.dat DATA2
|
||||
$(F77) s_drive2.f $(LIB) $L; a.out
|
||||
mv REPORT2 $@; rm -f DATA2 s_drive2.o a.out
|
||||
|
||||
s_drive3.out: s_drive3.f $(LIB) data3.dat
|
||||
cp data3.dat DATA3
|
||||
$(F77) s_drive3.f $(LIB) $L; a.out
|
||||
mv REPORT3 $@; rm -f DATA3 s_drive3.o a.out
|
||||
|
||||
s_test.out: s_test.f $(LIB)
|
||||
$(F77) s_test.f $(LIB) $L; a.out
|
||||
mv REPORT $@; cat SUMMARY >> $@; rm -f s_test.o a.out SUMMARY
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,5 @@
|
||||
C From HOMPACK90.
|
||||
MODULE REAL_PRECISION
|
||||
C This is for 64-bit arithmetic.
|
||||
INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13)
|
||||
END MODULE REAL_PRECISION
|
||||
@@ -0,0 +1,172 @@
|
||||
C
|
||||
C This example takes drive4.f and modifies it to stop ODRPACK95 and use the
|
||||
C restart facility. Run diff to see what additions were made.
|
||||
C
|
||||
|
||||
C This sample problem comes from Zwolak et al. 2001 (High Performance Computing
|
||||
C Symposium, "Estimating rate constants in cell cycle models"). The call to
|
||||
C ODRPACK95 is modified from the call the authors make to ODRPACK. This is
|
||||
C done to illustrate the need for bounds. The authors could just have easily
|
||||
C used the call statement here to solve their problem.
|
||||
C
|
||||
C Curious users are encouraged to remove the bounds in the call statement,
|
||||
C run the code, and compare the results to the current call statement.
|
||||
PROGRAM SAMPLE
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
IMPLICIT NONE
|
||||
INTEGER :: I
|
||||
REAL (KIND=R8) :: C, M, TOUT
|
||||
INTERFACE
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
END SUBROUTINE FCN
|
||||
END INTERFACE
|
||||
REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
|
||||
REAL(KIND=R8), POINTER :: WORK(:)
|
||||
INTEGER, POINTER :: IWORK(:)
|
||||
OPEN(9,FILE="REPORT_RESTART")
|
||||
WORK => NULL()
|
||||
IWORK => NULL()
|
||||
CALL ODR(
|
||||
+ FCN,
|
||||
+ N = 5, M = 1, NP = 3, NQ = 1,
|
||||
+ BETA = BETA,
|
||||
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
|
||||
+ IPRINT = 6666,
|
||||
+ LUNRPT = 9,
|
||||
+ MAXIT = 20,
|
||||
+ WORK = WORK,
|
||||
+ IWORK = IWORK
|
||||
+)
|
||||
WRITE(*,*) "Restarting ----------------------------------------"
|
||||
CALL ODR(
|
||||
+ FCN,
|
||||
+ N = 5, M = 1, NP = 3, NQ = 1,
|
||||
+ BETA = BETA,
|
||||
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
|
||||
+ IPRINT = 6666,
|
||||
+ LUNRPT = 9,
|
||||
+ MAXIT = 20,
|
||||
+ WORK = WORK,
|
||||
+ IWORK = IWORK,
|
||||
+ JOB = 10000
|
||||
+)
|
||||
CLOSE(9)
|
||||
C The following code will reproduce the plot in Figure 2 of Zwolak et
|
||||
C al. 2001.
|
||||
C DO I = 0, 100
|
||||
C C = 0.05+(0.7-0.05)*I/100
|
||||
C TOUT = 1440.0D0
|
||||
C !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
|
||||
C CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8,
|
||||
C + 9.23138811E+00_R8,0.0D0,TOUT,C/2)
|
||||
C WRITE(*,*) C, TOUT
|
||||
C END DO
|
||||
END PROGRAM
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
IMPLICIT NONE
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
! Local variables
|
||||
REAL(KIND=R8) :: MOUT
|
||||
INTEGER :: I
|
||||
ISTOP = 0
|
||||
FJACB(:,:,:) = 0.0E0_R8
|
||||
FJACD(:,:,:) = 0.0E0_R8
|
||||
IF ( MOD(IDEVAL,10).GE.1 ) THEN
|
||||
DO I = 1, N
|
||||
F(I,1) = 1440.0_R8
|
||||
CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
|
||||
+ F(I,1),XPLUSD(I,1)/2)
|
||||
END DO
|
||||
END IF
|
||||
END SUBROUTINE FCN
|
||||
|
||||
C-------------------------------------------------------------------------------
|
||||
C
|
||||
C MPF
|
||||
C
|
||||
C If ROOT is not zero then returns value of time when M==ROOT in TOUT. Else,
|
||||
C runs until TOUT and returns value in M. If PRINT_EVERY is non-zero then
|
||||
C the solution is printed every PRINT_EVERY time units or every H (which ever
|
||||
C is greater).
|
||||
C
|
||||
C This routine is not meant to be precise, it is only intended to be good
|
||||
C enough for providing a working example of ODRPACK95 with bounds. 4th order
|
||||
C Runge Kutta and linear interpolation are used for numerical integration and
|
||||
C root finding, respectively.
|
||||
C
|
||||
C M - MPF
|
||||
C C - Total Cyclin
|
||||
C KWEE, K25, K25P - Model parameters (BETA(1:3))
|
||||
C
|
||||
SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8), INTENT(OUT) :: M
|
||||
REAL (KIND=R8), INTENT(IN) :: C, KWEE, K25, K25P,
|
||||
+ PRINT_EVERY, ROOT
|
||||
REAL (KIND=R8), INTENT(INOUT) :: TOUT
|
||||
! Local variables
|
||||
REAL (KIND=R8), PARAMETER :: H = 1.0D-1
|
||||
REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
|
||||
REAL (KIND=R8) :: K1, K2, K3, K4, DMDT
|
||||
M = 0.0D0
|
||||
T = 0.0D0
|
||||
LAST_PRINT = 0
|
||||
IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
|
||||
WRITE(*,*) T, M
|
||||
END IF
|
||||
DO WHILE ( T .LT. TOUT )
|
||||
LAST_T = T
|
||||
LAST_M = M
|
||||
K1 = H*DMDT(M,C,KWEE,K25,K25P)
|
||||
K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
|
||||
K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
|
||||
K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
|
||||
M = M+(K1+2*K2+2*K3+K4)/6
|
||||
T = T + H
|
||||
IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND.
|
||||
+ PRINT_EVERY .GT. 0.0D0 )
|
||||
+ THEN
|
||||
WRITE(*,*) T, M
|
||||
LAST_PRINT = LAST_PRINT + PRINT_EVERY
|
||||
END IF
|
||||
IF ( ROOT .GT. 0.0D0 ) THEN
|
||||
IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
|
||||
TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
END SUBROUTINE MPF
|
||||
|
||||
|
||||
C Equation from Zwolak et al. 2001.
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
RES = KWEE*M+(K25+K25P*M**2)*(C-M)
|
||||
END FUNCTION DMDT
|
||||
@@ -0,0 +1,66 @@
|
||||
PROGRAM ODRPACK95_EXAMPLE
|
||||
USE ODRPACK95
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8), ALLOCATABLE :: BETA(:),L(:),U(:),X(:,:),Y(:,:)
|
||||
INTEGER :: NP,N,M,NQ
|
||||
INTERFACE
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
|
||||
IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
|
||||
FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
|
||||
INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
END SUBROUTINE FCN
|
||||
END INTERFACE
|
||||
|
||||
NP = 2
|
||||
N = 4
|
||||
M = 1
|
||||
NQ = 1
|
||||
ALLOCATE(BETA(NP),L(NP),U(NP),X(N,M),Y(N,NQ))
|
||||
BETA(1:2) = (/ 2.0_R8, 0.5_R8 /)
|
||||
L(1:2) = (/ 0.0_R8, 0.0_R8 /)
|
||||
U(1:2) = (/ 10.0_R8, 0.9_R8 /)
|
||||
X(1:4,1) = (/ 0.982_R8, 1.998_R8, 4.978_R8, 6.01_R8 /)
|
||||
Y(1:4,1) = (/ 2.7_R8, 7.4_R8, 148.0_R8, 403.0_R8 /)
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,LOWER=L,UPPER=U)
|
||||
END PROGRAM ODRPACK95_EXAMPLE
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
|
||||
IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
|
||||
USE REAL_PRECISION
|
||||
|
||||
INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ, I
|
||||
REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
|
||||
FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
|
||||
INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
|
||||
ISTOP = 0
|
||||
|
||||
! Calculate model.
|
||||
IF (MOD(IDEVAL,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
! Calculate model partials with respect to BETA.
|
||||
IF (MOD(IDEVAL/10,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
|
||||
FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
! Calculate model partials with respect to DELTA.
|
||||
IF (MOD(IDEVAL/100,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
|
||||
END SUBROUTINE FCN
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,241 @@
|
||||
*TESTER
|
||||
PROGRAM TESTER
|
||||
C***BEGIN PROLOGUE TESTER
|
||||
C***REFER TO ODR
|
||||
C***ROUTINES CALLED ODR
|
||||
C***DATE WRITTEN 20040322 (YYYYMMDD)
|
||||
C***REVISION DATE 20040322 (YYYYMMDD)
|
||||
C***PURPOSE EXCERCISE ERROR REPORTING OF THE F90 VERSION OF ODRPACK95
|
||||
C***END PROLOGUE TESTER
|
||||
|
||||
C...USED MODULES
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
|
||||
C...LOCAL SCALARS
|
||||
INTEGER N, M, NQ, NP, INFO, LUN
|
||||
C STAT
|
||||
|
||||
C...LOCAL ARRAYS
|
||||
REAL (KIND=R8)
|
||||
& BETA(:),Y(:,:),X(:,:),UPPER(2),LOWER(2)
|
||||
|
||||
C...ALLOCATABLE ARRAYS
|
||||
ALLOCATABLE BETA,Y,X
|
||||
|
||||
C...EXTERNAL SUBPROGRAMS
|
||||
EXTERNAL FCN
|
||||
|
||||
COMMON /BOUNDS/ UPPER,LOWER
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT TESTER
|
||||
|
||||
OPEN(UNIT=8,FILE="SUMMARY")
|
||||
WRITE(8,*) "NO SUMMARY AVAILABLE"
|
||||
CLOSE(8)
|
||||
|
||||
LUN = 9
|
||||
OPEN(UNIT=LUN,FILE="REPORT")
|
||||
|
||||
C ERROR IN PROBLEM SIZE
|
||||
|
||||
N = 0
|
||||
M = 0
|
||||
NQ = 0
|
||||
NP = 0
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN JOB SPECIFICATION WITH WORK AND IWORK
|
||||
|
||||
N = 1
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 1
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=10000,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN JOB SPECIFICATION WITH DELTA
|
||||
|
||||
N = 1
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 1
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=1000,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C BOUNDS TOO SMALL FOR DERIVATIVE CHECKER WHEN DERIVATIVES DON'T AGREE.
|
||||
|
||||
N = 4
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 2
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
BETA(:) = (/ -200.0_R8, -5.0_R8 /)
|
||||
UPPER(1:2) = (/ -200.0_R8, 0.0_R8 /)
|
||||
LOWER(1:2) = (/ -200.000029802322_R8, -5.0_R8 /)
|
||||
Y(:,1) = (/ 2.718281828459045_R8, 7.389056098930650_R8,
|
||||
&148.4131591025766_R8, 403.4287934927353_R8 /)
|
||||
X(:,1) = (/ 1.0_R8, 2.0_R8, 5.0_R8, 6.0_R8 /)
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=0020,
|
||||
& LUNRPT=LUN,LUNERR=LUN,LOWER=LOWER,UPPER=UPPER)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN ARRAY ALLOCATION
|
||||
C The following code is intended to force memory allocation failure. An
|
||||
C appropriate N for your machine must be chosen to ensure memory allocation
|
||||
C will fail within ODRPACK95. A value of about 1/4 the total memory available
|
||||
C to a process should do the trick. However, most modern operating systems and
|
||||
C Fortran compilers will not likely deny ODRPACK95 memory before they fail for
|
||||
C another reason. Therefore, the memory allocation checks in ODRPACK95 are not
|
||||
C easy to provoke. An operating system may return successfull memory
|
||||
C allocation but fail to guarantee the memory causing a segfault when some
|
||||
C memory locations are accessed. A Fortran compiler or operating system may
|
||||
C allow limited sized stacks during subroutine invocation causing the ODRPACK95
|
||||
C call to fail before ODRPACK95 executes its first line.
|
||||
C
|
||||
C N = 032000000
|
||||
C M = 1
|
||||
C NQ = 1
|
||||
C NP = 1
|
||||
C DEALLOCATE(BETA,Y,X)
|
||||
C ALLOCATE(BETA(NP),Y(N,NQ),X(N,M),STAT=STAT)
|
||||
C IF (STAT.NE.0) THEN
|
||||
C WRITE(0,*)
|
||||
C & "SYSTEM ERROR: COULD NOT ALLOCATE MEMORY, TESTER ",
|
||||
C & "FAILED TO RUN."
|
||||
C STOP
|
||||
C END IF
|
||||
C Y(:,:) = 0.0_R8
|
||||
C X(:,:) = 0.0_R8
|
||||
C BETA(:) = 0.0_R8
|
||||
C
|
||||
C CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
|
||||
C & LUNRPT=LUN,LUNERR=LUN)
|
||||
C
|
||||
C WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
CLOSE(LUN)
|
||||
|
||||
END PROGRAM
|
||||
*FCN
|
||||
SUBROUTINE FCN
|
||||
& (N,M,NP,NQ,
|
||||
& LDN,LDM,LDNP,
|
||||
& BETA,XPLUSD,
|
||||
& IFIXB,IFIXX,LDIFX,
|
||||
& IDEVAL,F,FJACB,FJACD,
|
||||
& ISTOP)
|
||||
C***BEGIN PROLOGUE FCN
|
||||
C***REFER TO ODR
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***DATE WRITTEN 20040322 (YYYYMMDD)
|
||||
C***REVISION DATE 20040322 (YYYYMMDD)
|
||||
C***PURPOSE DUMMY ROUTINE FOR ODRPACK95 ERROR EXERCISER
|
||||
C***END PROLOGUE FCN
|
||||
|
||||
C...USED MODULES
|
||||
USE REAL_PRECISION
|
||||
|
||||
C...SCALAR ARGUMENTS
|
||||
INTEGER
|
||||
& IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
|
||||
C...ARRAY ARGUMENTS
|
||||
REAL (KIND=R8)
|
||||
& BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ),
|
||||
& XPLUSD(LDN,M)
|
||||
INTEGER
|
||||
& IFIXB(NP),IFIXX(LDIFX,M)
|
||||
|
||||
C...ARRAYS IN COMMON
|
||||
REAL (KIND=R8)
|
||||
& LOWER(2),UPPER(2)
|
||||
|
||||
C...LOCAL SCALARS
|
||||
INTEGER
|
||||
& I
|
||||
|
||||
COMMON /BOUNDS/ UPPER,LOWER
|
||||
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT
|
||||
|
||||
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
|
||||
C are not being used. This is simply not to worry users that the example
|
||||
C program is failing.
|
||||
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
|
||||
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
|
||||
C Do nothing.
|
||||
END IF
|
||||
|
||||
|
||||
IF (ANY(LOWER(1:NP).GT.BETA(1:NP))) THEN
|
||||
WRITE(0,*) "LOWER BOUNDS VIOLATED"
|
||||
DO I=1,NP
|
||||
IF (LOWER(I).GT.BETA(I)) THEN
|
||||
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
|
||||
& "<", LOWER(I)
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (ANY(UPPER(1:NP).LT.BETA(1:NP))) THEN
|
||||
WRITE(0,*) "UPPER BOUNDS VIOLATED"
|
||||
DO I=1,NP
|
||||
IF (UPPER(I).LT.BETA(I)) THEN
|
||||
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
|
||||
& ">", UPPER(I)
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
ISTOP = 0
|
||||
|
||||
IF (MOD(IDEVAL,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (MOD(IDEVAL/10,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
|
||||
FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*
|
||||
& XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (MOD(IDEVAL/100,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
END SUBROUTINE
|
||||
File diff suppressed because it is too large
Load Diff
@@ -4,7 +4,7 @@
|
||||
implicit none
|
||||
INTEGER iter,n,np,NMAX,ITMAX
|
||||
double precision fret,ftol,p(np),xi(np,np),TINY,
|
||||
& pmin(np),pmax(np)
|
||||
& pmin(np),pmax(np),f1dim
|
||||
PARAMETER (NMAX=1000,TINY=1.0d-25)
|
||||
CU USES funkmin,linmin
|
||||
INTEGER i,ibig,j
|
||||
@@ -58,7 +58,7 @@ C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
|
||||
SUBROUTINE linmin(p,pmin,pmax,xi,n,f1dim,fret)
|
||||
implicit none
|
||||
INTEGER n
|
||||
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n)
|
||||
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim
|
||||
PARAMETER (TOL=1.0d-8)
|
||||
CU USES brent,f1dim,mnbrak
|
||||
INTEGER j,k,ierr
|
||||
|
||||
@@ -0,0 +1,291 @@
|
||||
program qpso
|
||||
|
||||
implicit none
|
||||
include "mpif.h"
|
||||
|
||||
integer maxiter, maxpop, maxparms
|
||||
parameter (maxiter = 10000)
|
||||
parameter (maxpop = 2048)
|
||||
parameter (maxparms = 512)
|
||||
|
||||
integer i, j,k, npop, nparms, niter, gInx, nfunc(maxpop)
|
||||
integer nfuncall(maxpop)
|
||||
integer ntries, np, myid, ierr, start_iter
|
||||
integer pft(maxparms)
|
||||
double precision gbest(maxparms)
|
||||
double precision mbest(maxparms)
|
||||
double precision feval, beta_l, beta_u, beta
|
||||
double precision betapro(maxparms), pupdate(maxparms)
|
||||
double precision pbest(maxpop, maxparms)
|
||||
double precision pbestall(maxpop, maxparms)
|
||||
double precision f_x(maxpop), x(maxpop, maxparms)
|
||||
double precision xall(maxpop, maxparms)
|
||||
double precision f_pbest(maxpop), f_pbestall(maxpop), f_gbest
|
||||
double precision gpar(maxiter,maxparms)
|
||||
double precision gobj(maxiter)
|
||||
double precision pmin(maxparms), pmax(maxparms)
|
||||
double precision fi(maxparms), u(maxparms), v(maxparms)
|
||||
logical isvalid, restart
|
||||
character(len=4) popst
|
||||
character(len=100) mymachine, dummy, parm_name(maxparms), case_name, thisfmt
|
||||
character(len=100) parm_list, constraints, qpso_in(4)
|
||||
|
||||
!------- user-tunable QPSO algorithm parameters ----------------
|
||||
|
||||
open(unit = 8, file='qpso_input.txt')
|
||||
do i = 1,100
|
||||
read(8,*, end=5), qpso_in
|
||||
if (trim(qpso_in(1)) == 'npop') read(qpso_in(3),*) npop
|
||||
if (trim(qpso_in(1)) == 'niter') read(qpso_in(3),*) niter
|
||||
if (trim(qpso_in(1)) == 'beta_l') read(qpso_in(3),*) beta_l
|
||||
if (trim(qpso_in(1)) == 'beta_u') read(qpso_in(3),*) beta_u
|
||||
if (trim(qpso_in(1)) == 'restart') read(qpso_in(3),*) restart
|
||||
if (trim(qpso_in(1)) == 'machine') mymachine=trim(qpso_in(3))
|
||||
if (trim(qpso_in(1)) == 'case') case_name=trim(qpso_in(3))
|
||||
if (trim(qpso_in(1)) == 'parm_list') parm_list=trim(qpso_in(3))
|
||||
if (trim(qpso_in(1)) == 'constraints') constraints=trim(qpso_in(3))
|
||||
end do
|
||||
|
||||
5 continue
|
||||
close(8)
|
||||
print*, '# of particles: ', npop
|
||||
print*, '# of iterations: ', niter
|
||||
print*, 'beta_l: ', beta_l
|
||||
print*, 'beta_u: ', beta_u
|
||||
print*, 'Is a restart run:', restart
|
||||
print*, 'Machine: ', mymachine
|
||||
print*, 'Case: ', case_name
|
||||
print*, 'Parameter file: ', parm_list
|
||||
print*, 'Constraints dir: ', constraints
|
||||
!---------------------------------------------------------------
|
||||
|
||||
call mpi_init(ierr)
|
||||
call mpi_comm_size(mpi_comm_world, np, ierr)
|
||||
call mpi_comm_rank(mpi_comm_world, myid, ierr)
|
||||
|
||||
!get parameter information from the parm_list file
|
||||
if (myid .eq. 0) then
|
||||
open(unit = 8, status='old', file = trim(parm_list))
|
||||
nparms=0
|
||||
do i=1,maxparms
|
||||
read(8,*, end=10) parm_name(i), pft(i), pmin(i), pmax(i)
|
||||
nparms = nparms+1
|
||||
end do
|
||||
end if
|
||||
|
||||
10 continue
|
||||
if (myid .eq. 0) then
|
||||
close(8)
|
||||
print*, nparms, ' Parameters optimized'
|
||||
end if
|
||||
|
||||
!broadcast parameter info to other procs
|
||||
call mpi_bcast(nparms, 1, mpi_integer, 0, mpi_comm_world, ierr)
|
||||
call mpi_bcast(pmin, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
||||
call mpi_bcast(pmax, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
||||
|
||||
|
||||
nfunc(:) = 0 !keep track of total function evaluations
|
||||
|
||||
x(:,:) = 0d0
|
||||
f_x(:) = 0d0
|
||||
f_pbest(:) = 0d0
|
||||
|
||||
if (restart .eqv. .false.) then
|
||||
do i=myid+1,npop,np
|
||||
!randomize starting locations
|
||||
call init_random_seed
|
||||
call random_number(u)
|
||||
x(i,:) = pmin + (pmax-pmin) * u
|
||||
f_x(i) = feval(x(i,:), nparms, i, mymachine, parm_list, constraints, &
|
||||
case_name)
|
||||
nfunc(i) = nfunc(i)+1
|
||||
f_pbest(i) = f_x(i)
|
||||
end do
|
||||
|
||||
call mpi_allreduce(x, xall, maxparms*maxpop, mpi_double, mpi_sum, &
|
||||
mpi_comm_world, ierr)
|
||||
call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
|
||||
mpi_comm_world, ierr)
|
||||
pbestall = xall
|
||||
|
||||
!initialize pbest and gbest
|
||||
if (myid .eq. 0) then
|
||||
gInx = 1
|
||||
do i=2,npop
|
||||
if (f_pbestall(i) .lt. f_pbestall(gInx)) gInx = i
|
||||
end do
|
||||
gbest = pbestall(gInx,:)
|
||||
f_gbest = f_pbestall(gInx)
|
||||
end if
|
||||
call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
||||
call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
|
||||
start_iter = 1
|
||||
else
|
||||
!load restart information
|
||||
if (myid .eq. 0) then
|
||||
open(unit=8, file='./qpso_restart_' // trim(case_name) // '.txt')
|
||||
read(8,*) start_iter
|
||||
do j=1,npop
|
||||
read(8,*) xall(j,1:nparms)
|
||||
read(8,*) pbestall(j,1:nparms)
|
||||
read(8,*) f_pbestall(j)
|
||||
end do
|
||||
read(8,*) gbest(1:nparms)
|
||||
read(8,*) f_gbest
|
||||
end if
|
||||
xall=pbestall
|
||||
call mpi_bcast(xall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
|
||||
call mpi_bcast(pbestall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
|
||||
call mpi_bcast(f_pbestall, maxpop, mpi_double, 0, mpi_comm_world, ierr)
|
||||
call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
||||
call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
|
||||
end if
|
||||
|
||||
|
||||
|
||||
!QPSO algorithm
|
||||
do i=start_iter,niter
|
||||
if (myid .eq. 0) print*, 'Iteration', i
|
||||
beta = beta_u - (beta_u-beta_l)*i/niter
|
||||
!compute mean of best parameters (all procs)
|
||||
do k=1, nparms
|
||||
mbest(k) = sum(pbestall(1:npop,k))/npop
|
||||
end do
|
||||
!print*, mbest(1:nparms)
|
||||
!MPI over population
|
||||
x(:,:) = 0d0
|
||||
pbest(:,:) = 0d0
|
||||
f_pbest(:) = 0d0
|
||||
do j = myid+1,npop,np
|
||||
isvalid = .false.
|
||||
ntries = 0
|
||||
do while (isvalid .eqv. .false.)
|
||||
call random_number(fi)
|
||||
call random_number(u)
|
||||
call random_number(v)
|
||||
|
||||
isvalid=.true.
|
||||
do k=1,nparms
|
||||
pupdate = fi(k)*pbestall(j,k) + (1-fi(k))*gbest(k)
|
||||
betapro = beta * abs(mbest(k)-xall(j,k))
|
||||
|
||||
x(j,k) = pupdate(k)+((-1d0)**ceiling(0.5+v(k)))*betapro(k)*(-log(u(k)))
|
||||
|
||||
if (ntries .le. 1e5) then
|
||||
if (x(j,k) .lt. pmin(k) .or. x(j,k) .gt. pmax(k)) isvalid=.false.
|
||||
else
|
||||
if (x(j,k) .lt. pmin(k)) x(j,k) = pmin(k)
|
||||
if (x(j,k) .gt. pmax(k)) x(j,k) = pmax(k)
|
||||
end if
|
||||
end do
|
||||
ntries = ntries+1
|
||||
end do
|
||||
|
||||
!run the model to get the cost function
|
||||
f_x(j) = feval(x(j,:),nparms, j, mymachine, parm_list, constraints, case_name)
|
||||
nfunc(j) = nfunc(j)+1
|
||||
|
||||
if (f_x(j) .lt. f_pbestall(j)) then
|
||||
pbest(j,:) = x(j,:)
|
||||
f_pbest(j) = f_x(j)
|
||||
else
|
||||
pbest(j,:) = pbestall(j,:)
|
||||
f_pbest(j) = f_pbestall(j)
|
||||
end if
|
||||
end do
|
||||
|
||||
call mpi_allreduce(pbest, pbestall, maxparms*maxpop, mpi_double, mpi_sum, &
|
||||
mpi_comm_world, ierr)
|
||||
call mpi_allreduce(x, xall, maxpop, mpi_double, mpi_sum, &
|
||||
mpi_comm_world, ierr)
|
||||
call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
|
||||
mpi_comm_world, ierr)
|
||||
|
||||
!update overall best (all procs)
|
||||
do j=1,npop
|
||||
if (f_pbestall(j) .lt. f_gbest) then
|
||||
gbest = pbestall(j,:)
|
||||
f_gbest = f_pbestall(j)
|
||||
end if
|
||||
end do
|
||||
|
||||
!save info from this iteration
|
||||
gpar(i,:) = gbest
|
||||
gobj(i) = f_gbest
|
||||
call mpi_allreduce(nfunc,nfuncall, maxpop, mpi_integer, mpi_sum, &
|
||||
mpi_comm_world, ierr)
|
||||
if (myid .eq. 0) then
|
||||
open(unit=8, file='qpso_best_' // trim(case_name) // '.txt')
|
||||
write(8,*), 'Iteration', i
|
||||
write(8,*), 'Objective function:', gobj(i)
|
||||
do k=1,nparms
|
||||
write(8,'(A,1x,I2,1x,g13.6)') trim(parm_name(k)), pft(k), gpar(i,k)
|
||||
end do
|
||||
close(8)
|
||||
if (i .eq. 1) then
|
||||
open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt')
|
||||
else
|
||||
open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt', &
|
||||
status='old', position='append', action='write')
|
||||
end if
|
||||
write(10,*) i, sum(nfuncall) , gobj(i)
|
||||
close(10)
|
||||
|
||||
!write the restart file
|
||||
write(popst, '(I4)') nparms
|
||||
thisfmt = '(' // trim(popst) // '(g13.6,1x))'
|
||||
open(unit=11, file = 'qpso_restart_' // trim(case_name) // '.txt')
|
||||
write(11,'(I4)') i !current iteration number
|
||||
do j=1,npop
|
||||
write(11,fmt=trim(thisfmt)) xall(j,1:nparms) !current parameters for each population
|
||||
write(11,fmt=trim(thisfmt)) pbestall(j,1:nparms) !best parameters for each population
|
||||
write(11,'(g13.6)') f_pbestall(j) !best objective function for each population
|
||||
end do
|
||||
write(11,fmt=trim(thisfmt)) gbest(1:nparms) !overall best parameters
|
||||
write(11,'(g13.6)') f_gbest !overall best objectivefunction
|
||||
close(11)
|
||||
end if
|
||||
end do
|
||||
call mpi_finalize(ierr)
|
||||
|
||||
end program qpso
|
||||
|
||||
|
||||
!Function to evaluate the CLM/ALM model
|
||||
double precision function feval(parms, nparms, thispop, mymachine, parm_list, &
|
||||
constraints, case_name)
|
||||
|
||||
integer nparms, i, thispop
|
||||
double precision parms(500), trueparms(4)
|
||||
double precision mydata(1000), model(1000), sse(1000)
|
||||
double precision temp(1000), par(1000)
|
||||
character(len=6) thispopst
|
||||
character(len=100) mymachine, parm_list, constraints, case_name, thisline
|
||||
|
||||
|
||||
write(thispopst, '(I6)') 100000+thispop
|
||||
|
||||
!write the parameters to file
|
||||
open(unit=9, file='./parm_data_files/parm_data_' // thispopst(2:6))
|
||||
do i=1,nparms
|
||||
write(9,*) parms(i)
|
||||
end do
|
||||
close(9)
|
||||
|
||||
!Call python workflow to set up and launch model simulation
|
||||
call system('sleep ' // thispopst(2:6)) !do not start all at once
|
||||
call system('python UQ_runens.py --ens_num ' // thispopst(2:6) // &
|
||||
' --parm_list ' // trim(parm_list) // ' --parm_data ./parm_data_files/' // &
|
||||
'parm_data_' // thispopst(2:6) // ' --constraints ' // trim(constraints) // &
|
||||
' --machine ' // trim(mymachine) // ' --case ' // trim(case_name))
|
||||
|
||||
!get the sum of squared errors
|
||||
open(unit=9, file='./ssedata/mysse_' // thispopst(2:6) // '.txt')
|
||||
read(9,*) feval
|
||||
close(9)
|
||||
call system('sleep 20')
|
||||
|
||||
return
|
||||
|
||||
end function feval
|
||||
@@ -0,0 +1,99 @@
|
||||
subroutine charfloatlineparser(longchar,nmax,charvars,
|
||||
&nchars,floatvars,nfloats)
|
||||
implicit none
|
||||
!7 Sept 2013, revised version
|
||||
!parse a long line of chars into char and/or float variables with the following assumptions:
|
||||
!1. Each cell is separated by a separating character which can be either a ',', blank space(s) or anything
|
||||
!with the ASCII code less than and including 032 or larger than and including 127
|
||||
!2. Any separating characters at the end of the line are discarded, i.e.
|
||||
! '1,2,3,4,a,b,c,,,,,,,,,, ,'='1,2,3,4,a,b,c'
|
||||
!3. If there is no entry between two non-comma separating characters,these two separating characters are treated as one.
|
||||
! i.e. '1 2 3 4 a b c'='1,2,3,4,a,b,c'
|
||||
!4. If there is no entry between two commas that are not positioned in the end of the line, a missing value is assumed to
|
||||
!exist between these two commas and this missing value is denoted with -9999, i.e.
|
||||
! i.e. '1,,3,4,a,b,c'='1,-9999,3,4,a,b,c'
|
||||
!5. Comma has priotity as a separating characer. E.g commas and blank spaces are not used simultaneously as
|
||||
! separating characters in a single line. When both commas and blank spaces appear in the line, comma is
|
||||
! the saparating character and blank spaces are repalced with '_'
|
||||
integer nmax,nchars,nfloats
|
||||
character(*)::longchar
|
||||
character charvars(nmax+100)*50,achar*50,stringvars(nmax+100)*50
|
||||
double precision floatvars(nmax)
|
||||
integer i,j,k,m,n,ndot,nplus,nminus,nd,ne,nCapD,nCapE,leng
|
||||
!
|
||||
call charlineparser(longchar,nmax,stringvars,n)
|
||||
nchars=0
|
||||
nfloats=0
|
||||
do j=1,n
|
||||
ndot=0
|
||||
nplus=0
|
||||
nminus=0
|
||||
nd=0
|
||||
ne=0
|
||||
nCapD=0
|
||||
nCapE=0
|
||||
leng=LEN_TRIM(stringvars(j))
|
||||
achar=stringvars(j)(1:leng)
|
||||
i=leng
|
||||
5 k=ichar(achar(i:i))
|
||||
if(k.le.47.or.k.ge.58)then
|
||||
m=0
|
||||
if(k.eq.46)then
|
||||
ndot=ndot+1
|
||||
m=1
|
||||
endif
|
||||
if(k.eq.43)then
|
||||
nplus=nplus+1
|
||||
m=1
|
||||
endif
|
||||
if(k.eq.45)then
|
||||
nminus=nminus+1
|
||||
m=1
|
||||
endif
|
||||
if(k.eq.100)then
|
||||
nd=nd+1
|
||||
m=1
|
||||
endif
|
||||
if(k.eq.101)then
|
||||
ne=ne+1
|
||||
m=1
|
||||
endif
|
||||
if(k.eq.68)then
|
||||
nCapD=nCapD+1
|
||||
m=1
|
||||
endif
|
||||
if(k.eq.69)then
|
||||
nCapE=nCapE+1
|
||||
m=1
|
||||
endif
|
||||
if(m.eq.0)then
|
||||
nchars=nchars+1
|
||||
charvars(nchars)=achar(1:leng)
|
||||
goto 10
|
||||
endif
|
||||
endif
|
||||
i=i-1
|
||||
if(i.ge.1)goto 5
|
||||
m=0
|
||||
if(ndot.gt.1)m=1
|
||||
if(nplus.gt.1)m=1
|
||||
if(nminus.gt.1)m=1
|
||||
if(nd.gt.1)m=1
|
||||
if(ne.gt.1)m=1
|
||||
if(nCapD.gt.1)m=1
|
||||
if(nCapE.gt.1)m=1
|
||||
if((nplus*nminus).gt.0)m=1
|
||||
if((nd+ne+nCapD+nCapE).gt.1)m=1
|
||||
if((nd+ne+nCapD+nCapE).eq.leng)m=1
|
||||
if(m.eq.1)then
|
||||
nchars=nchars+1
|
||||
charvars(nchars)=achar(1:leng)
|
||||
else
|
||||
nfloats=nfloats+1
|
||||
m=len(trim(achar))
|
||||
call extCharToFloatNum(m,achar,floatvars(nfloats),k)
|
||||
endif
|
||||
10 continue
|
||||
enddo
|
||||
return
|
||||
end subroutine charfloatlineparser
|
||||
@@ -15,7 +15,8 @@
|
||||
! separating characters in a single line. When both commas and blank spaces appear in the line, comma is
|
||||
! the saparating character and blank spaces are repalced with '_'
|
||||
integer nmax,n
|
||||
character longchar*(*),charvars(nmax+100)*50
|
||||
character(*)::longchar
|
||||
character charvars(nmax+100)*50
|
||||
integer i,k,pos1,pos2,leng,posindex(0:nmax+100),itiscomma
|
||||
!
|
||||
leng=LEN_TRIM(longchar)
|
||||
@@ -35,6 +36,10 @@
|
||||
do i=1,leng
|
||||
if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1
|
||||
enddo
|
||||
if(itiscomma.ge.nmax)then
|
||||
n=0
|
||||
return
|
||||
endif
|
||||
if(itiscomma.gt.0)then
|
||||
!If the line contains at least one comma, it is assumed a comma separated line
|
||||
n=0
|
||||
|
||||
@@ -0,0 +1,147 @@
|
||||
subroutine doytotime(dayfract,fday,fhour,fmin,fsecond)
|
||||
implicit none
|
||||
double precision dayfract,fday,fhour,fmin,fsecond,term
|
||||
fday=dint(dayfract)
|
||||
term=(dayfract-fday)*24.0d0
|
||||
fhour=dint(term)
|
||||
term=(term-fhour)*60.0d0
|
||||
fmin=dint(term)
|
||||
fsecond=(term-fmin)*60.0d0
|
||||
if(dabs(fsecond-60.0d0).lt.1.0d-8)then
|
||||
fsecond=0.0d0
|
||||
fmin=fmin+1.0d0
|
||||
endif
|
||||
if(dabs(fmin-60.0d0).lt.(1.0d-8/60.0d0))then
|
||||
fmin=0.0d0
|
||||
fhour=fhour+1.0d0
|
||||
endif
|
||||
if(dabs(fhour).lt.1.0d-8.and.dabs(fmin).lt.1.0d-8.and.
|
||||
&dabs(fsecond).lt.1.0d-8)then
|
||||
if(dabs(fday-1.0d0).gt.1.0d-8)then
|
||||
fday=fday-1.0d0
|
||||
fhour=24.0d0
|
||||
fmin=0.0d0
|
||||
fsecond=0.0d0
|
||||
endif
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
subroutine doy_to_monthday(month,monthday,year,idoy)
|
||||
!extract month,day of month from year and day of year
|
||||
implicit none
|
||||
integer month,monthday,year,idoy,isitaleapyear,
|
||||
&i,j,k,ndays(12)
|
||||
ndays(1)=31
|
||||
ndays(2)=28+isitaleapyear(year)
|
||||
ndays(3)=31
|
||||
ndays(4)=30
|
||||
ndays(5)=31
|
||||
ndays(6)=30
|
||||
ndays(7)=31
|
||||
ndays(8)=31
|
||||
ndays(9)=30
|
||||
ndays(10)=31
|
||||
ndays(11)=30
|
||||
ndays(12)=31
|
||||
k=0
|
||||
do i=1,12
|
||||
do j=1,ndays(i)
|
||||
k=k+1
|
||||
if(k.eq.idoy)then
|
||||
month=i
|
||||
monthday=j
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
month=99
|
||||
monthday=99
|
||||
return
|
||||
end
|
||||
|
||||
subroutine timestamp(iyear,dayfract,month,monthday,idoy,ihour,
|
||||
&imin,isecond,chartimestamp)
|
||||
implicit none
|
||||
integer iyear,month,monthday,idoy,ihour,imin,isecond,itimestamp
|
||||
double precision dayfract,fday,fhour,fmin,fsecond
|
||||
character charyear*4,charmonth*2,charmonthday*2,charhour*2,
|
||||
&charmin*2,charsecond*2,chartimestamp*14
|
||||
if(dayfract.lt.1.0d0)dayfract=1.0d0
|
||||
call doytotime(dayfract,fday,fhour,fmin,fsecond)
|
||||
idoy=idnint(fday)
|
||||
ihour=idnint(fhour)
|
||||
imin=idnint(fmin)
|
||||
isecond=idnint(fsecond)
|
||||
call doy_to_monthday(month,monthday,iyear,idoy)
|
||||
call NumberToChar(iyear,4,charyear)
|
||||
call NumberToChar(month,2,charmonth)
|
||||
call NumberToChar(monthday,2,charmonthday)
|
||||
call NumberToChar(ihour,2,charhour)
|
||||
call NumberToChar(imin,2,charmin)
|
||||
call NumberToChar(isecond,2,charsecond)
|
||||
chartimestamp=
|
||||
&charyear//charmonth//charmonthday//charhour//charmin//charsecond
|
||||
return
|
||||
end
|
||||
|
||||
subroutine mnmdyeardoy(tenletters,month,monthday,
|
||||
&year,idoy,yearfract)
|
||||
!extract month,day of month, year, day of year, and year fraction (e.g. 2007.15) from
|
||||
!a string of 10 characters in the exact form as 08-21-2010 (mn-md-year)
|
||||
implicit none
|
||||
character tenletters*(*),c*1
|
||||
integer month,monthday,year,idoy,izero,isitaleapyear,
|
||||
& i,j,k,n,ndays(12),ntotdays,itime(3)
|
||||
double precision yearfract
|
||||
|
||||
do j=1,3
|
||||
itime(j)=0
|
||||
enddo
|
||||
n=len(tenletters)
|
||||
k=0
|
||||
j=1
|
||||
do i=n,1,-1
|
||||
c=tenletters(i:i)
|
||||
if(ichar(c).ge.48.and.ichar(c).le.57)then
|
||||
itime(j)=itime(j)+(ichar(c)-48)*(10**k)
|
||||
k=k+1
|
||||
else
|
||||
if(k.ne.0)j=j+1
|
||||
k=0
|
||||
endif
|
||||
enddo
|
||||
year=itime(1)
|
||||
monthday=itime(2)
|
||||
month=itime(3)
|
||||
|
||||
! izero=48
|
||||
! month=(ichar(tenletters(1:1))-izero)*10
|
||||
! month=month+(ichar(tenletters(2:2))-izero)
|
||||
! monthday=(ichar(tenletters(4:4))-izero)*10
|
||||
! monthday=monthday+(ichar(tenletters(5:5))-izero)
|
||||
! year=(ichar(tenletters(7:7))-izero)*1000
|
||||
! year=year+(ichar(tenletters(8:8))-izero)*100
|
||||
! year=year+(ichar(tenletters(9:9))-izero)*10
|
||||
! year=year+(ichar(tenletters(10:10))-izero)
|
||||
|
||||
ndays(1)=31
|
||||
ndays(2)=28+isitaleapyear(year)
|
||||
ndays(3)=31
|
||||
ndays(4)=30
|
||||
ndays(5)=31
|
||||
ndays(6)=30
|
||||
ndays(7)=31
|
||||
ndays(8)=31
|
||||
ndays(9)=30
|
||||
ndays(10)=31
|
||||
ndays(11)=30
|
||||
ndays(12)=31
|
||||
ntotdays=365+isitaleapyear(year)
|
||||
idoy=monthday
|
||||
do i=1,month-1
|
||||
idoy=idoy+ndays(i)
|
||||
enddo
|
||||
yearfract=dble(year)+dble(idoy)/dble(ntotdays)
|
||||
return
|
||||
end
|
||||
@@ -5,7 +5,8 @@
|
||||
!number.
|
||||
!ierr=0, successful conversion
|
||||
! =1, conversion failed
|
||||
character astring*50,cpastring*(*),c*1,d*1
|
||||
character(*)::cpastring
|
||||
character astring*50,c*1,d*1
|
||||
double precision f,fsign,factor
|
||||
integer ipos1,ipos2,ideci,k,j,i,m,numchar0,
|
||||
& numchar,ierr,ispartnum,nlength
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -71,13 +71,13 @@
|
||||
return
|
||||
end
|
||||
|
||||
double precision function ran1(idum)
|
||||
implicit none
|
||||
integer idum,IA,IM,IQ,IR,NTAB,NDIV
|
||||
double precision AM,EPS,RNMX
|
||||
PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
|
||||
& IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
|
||||
& RNMX=1.0d0-EPS)
|
||||
! double precision function ran1(idum)
|
||||
! implicit none
|
||||
! integer idum,IA,IM,IQ,IR,NTAB,NDIV
|
||||
! double precision AM,EPS,RNMX
|
||||
! PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
|
||||
! & IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
|
||||
! & RNMX=1.0d0-EPS)
|
||||
!
|
||||
! Minimal random number generator of Park and Miller with Bays-Durham shuffle and
|
||||
! added safegaurds. Return a uniform random deviate between 0.0 and 1.0, exclusive
|
||||
@@ -85,25 +85,25 @@
|
||||
! thereafter, do not alter idum between successive deviates in a sequence. RNMX
|
||||
! should approximate the largest floating value that is less than 1.
|
||||
!
|
||||
integer j,k,iv(NTAB),iy
|
||||
save iv,iy
|
||||
data iv /NTAB*0/,iy /0/
|
||||
if(idum.le.0.or.iy.eq.0)then
|
||||
idum=max(-idum,1)
|
||||
do j=NTAB+8,1,-1
|
||||
k=idum/IQ
|
||||
idum=IA*(idum-k*IQ)-IR*k
|
||||
if(idum.lt.0)idum=idum+IM
|
||||
if(j.le.NTAB)iv(j)=idum
|
||||
enddo
|
||||
iy=iv(1)
|
||||
endif
|
||||
k=idum/IQ
|
||||
idum=IA*(idum-k*IQ)-IR*k
|
||||
if(idum.lt.0)idum=idum+IM
|
||||
j=1+iy/NDIV
|
||||
iy=iv(j)
|
||||
iv(j)=idum
|
||||
ran1=dmin1(AM*iy,RNMX)
|
||||
return
|
||||
end
|
||||
! integer j,k,iv(NTAB),iy
|
||||
! save iv,iy
|
||||
! data iv /NTAB*0/,iy /0/
|
||||
! if(idum.le.0.or.iy.eq.0)then
|
||||
! idum=max(-idum,1)
|
||||
! do j=NTAB+8,1,-1
|
||||
! k=idum/IQ
|
||||
! idum=IA*(idum-k*IQ)-IR*k
|
||||
! if(idum.lt.0)idum=idum+IM
|
||||
! if(j.le.NTAB)iv(j)=idum
|
||||
! enddo
|
||||
! iy=iv(1)
|
||||
! endif
|
||||
! k=idum/IQ
|
||||
! idum=IA*(idum-k*IQ)-IR*k
|
||||
! if(idum.lt.0)idum=idum+IM
|
||||
! j=1+iy/NDIV
|
||||
! iy=iv(j)
|
||||
! iv(j)=idum
|
||||
! ran1=dmin1(AM*iy,RNMX)
|
||||
! return
|
||||
! end
|
||||
|
||||
@@ -73,7 +73,7 @@
|
||||
do i=1,6
|
||||
grad(i)=grad6(i)
|
||||
enddo
|
||||
call gradsigmoidfunc(0.0,a2,b2,c2,x02,x,grad6)
|
||||
call gradsigmoidfunc(0.0d0,a2,b2,c2,x02,x,grad6)
|
||||
grad(6)=grad(6)-grad6(6)
|
||||
do i=1,4
|
||||
grad(6+i)=-grad6(i)
|
||||
|
||||
@@ -1,3 +1,54 @@
|
||||
subroutine fgetmaxmin(n,x,xmin,imin,xmax,imax)
|
||||
implicit none
|
||||
integer n,imin,imax,i
|
||||
double precision x(n),xmin,xmax
|
||||
imin=1
|
||||
xmin=x(1)
|
||||
imax=1
|
||||
xmax=x(1)
|
||||
do i=2,n
|
||||
if(x(i).lt.xmin)then
|
||||
imin=i
|
||||
xmin=x(i)
|
||||
endif
|
||||
if(x(i).gt.xmax)then
|
||||
imax=i
|
||||
xmax=x(i)
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
double precision function fdotsec(idotsec)
|
||||
implicit none
|
||||
integer idotsec,i,k,j(100),n
|
||||
k=idotsec
|
||||
i=1
|
||||
10 j(i)=mod(k,10)
|
||||
k=k/10
|
||||
if(k.gt.0)then
|
||||
i=i+1
|
||||
goto 10
|
||||
endif
|
||||
fdotsec=0.0d0
|
||||
do k=1,i
|
||||
n=10**(i-k+1)
|
||||
fdotsec=fdotsec+dble(j(k))/dble(n)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
integer function isitnaninf(x)
|
||||
!If x is NaN or INF, isitnaninf=1. Otherwise, isitnaninf=0
|
||||
implicit none
|
||||
double precision x
|
||||
isitnaninf=1
|
||||
if((x+1.0d0).gt.x)isitnaninf=0
|
||||
if((x+1.0d0).lt.x)isitnaninf=1
|
||||
if((x+1.0d0).eq.x)isitnaninf=1
|
||||
return
|
||||
end
|
||||
|
||||
subroutine sort_shell(n,a,iorder)
|
||||
!sort array a with the Shell method (from smallest to largest).
|
||||
!iorder records the original position of each member.
|
||||
@@ -66,6 +117,41 @@ c: x^3+p*x^2+q*x+r=0
|
||||
cubicroot=root2
|
||||
return
|
||||
end
|
||||
|
||||
subroutine getcubicroot(p,q,r,root1,root2,root3)
|
||||
c
|
||||
implicit double precision(a-h,l,o-z)
|
||||
|
||||
c: x^3+p*x^2+q*x+r=0
|
||||
root1=-9999.0d0
|
||||
root2=-9999.0d0
|
||||
root3=-9999.0d0
|
||||
|
||||
capq=(p*p-3.0d0*q)/9.0d0
|
||||
capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0
|
||||
if (capr*capr .lt. capq*capq*capq) then
|
||||
rtta=dacos(capr/(dsqrt(capq*capq*capq)))
|
||||
root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0
|
||||
|
||||
root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
|
||||
& dsqrt(3.0d0))-p/3.0d0
|
||||
root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
|
||||
& dsqrt(3.0d0))-p/3.0d0
|
||||
else
|
||||
capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr-
|
||||
& capq*capq*capq))**(1.0d0/3.0d0)
|
||||
if (dabs(capa) .lt. 1.0d-6) then
|
||||
capb=0.0
|
||||
else
|
||||
capb=capq/capa
|
||||
end if
|
||||
root2 =(capa+capb)-p/3.0d0
|
||||
end if
|
||||
cubicroot=root2
|
||||
return
|
||||
end
|
||||
|
||||
|
||||
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
subroutine quadraticroots(a,b,c,root1,root2)
|
||||
implicit none
|
||||
@@ -531,7 +617,31 @@ c####################################################################
|
||||
do j=1,nsamp
|
||||
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
|
||||
enddo
|
||||
std=dsqrt(std/dble(nsamp-1))
|
||||
std=dsqrt(std/dble(nsamp-1))
|
||||
end
|
||||
|
||||
subroutine stdmeancv(nsamp0,xvar0,std,fmean,cv)
|
||||
implicit none
|
||||
integer nsamp0,nsamp,j
|
||||
double precision xvar0(nsamp0),xvar(nsamp0),std,fmean,cv
|
||||
nsamp=0
|
||||
do j=1,nsamp0
|
||||
if(dabs(xvar0(j)+9999.0d0).gt.1.0d-7)then
|
||||
nsamp=nsamp+1
|
||||
xvar(nsamp)=xvar0(j)
|
||||
endif
|
||||
enddo
|
||||
fmean=0.0d0
|
||||
do j=1,nsamp
|
||||
fmean=fmean+xvar(j)
|
||||
enddo
|
||||
fmean=fmean/dble(nsamp)
|
||||
std=0.0d0
|
||||
do j=1,nsamp
|
||||
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
|
||||
enddo
|
||||
std=dsqrt(std/dble(nsamp-1))
|
||||
cv=std/fmean
|
||||
end
|
||||
c#######################################################################
|
||||
subroutine reinitialization(x0min,x0likely,
|
||||
|
||||
@@ -4,7 +4,8 @@
|
||||
implicit none
|
||||
integer nmax,n
|
||||
double precision vars(nmax+100)
|
||||
character longchar*(*),astring*50,c*1
|
||||
character(*)::longchar
|
||||
character astring*50,c*1
|
||||
integer i,pos1,pos2,ispartnum,leng,numchar,ierr
|
||||
!
|
||||
n=0
|
||||
|
||||
@@ -0,0 +1,44 @@
|
||||
subroutine y_aPLUSbx(npoints0,x0,y0,a,b)
|
||||
implicit none
|
||||
!fit for y=a+bx
|
||||
integer npoints0
|
||||
double precision x0(npoints0),y0(npoints0),a,b
|
||||
integer i,npoints
|
||||
double precision xmean,ymean,lxx,lyy,lxy,fn9999,tiny,
|
||||
&x(npoints0),y(npoints0)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
|
||||
|
||||
npoints=0
|
||||
do i=1,npoints0
|
||||
if(dabs(x0(i)-fn9999).gt.tiny.and.
|
||||
&dabs(y0(i)-fn9999).gt.tiny)then
|
||||
npoints=npoints+1
|
||||
x(npoints)=x0(i)
|
||||
y(npoints)=y0(i)
|
||||
endif
|
||||
enddo
|
||||
xmean=0.0d0
|
||||
ymean=0.0d0
|
||||
do i=1,npoints
|
||||
xmean=xmean+x(i)
|
||||
ymean=ymean+y(i)
|
||||
enddo
|
||||
xmean=xmean/dble(npoints)
|
||||
ymean=ymean/dble(npoints)
|
||||
lxx=0.0d0
|
||||
lyy=0.0d0
|
||||
lxy=0.0d0
|
||||
do i=1,npoints
|
||||
lxx=lxx+(x(i)-xmean)**2
|
||||
lyy=lyy+(y(i)-ymean)**2
|
||||
lxy=lxy+(x(i)-xmean)*(y(i)-ymean)
|
||||
enddo
|
||||
if(lxx.ne.0.0d0)then
|
||||
b=lxy/lxx
|
||||
a=ymean-b*xmean
|
||||
else
|
||||
b=-9999.0d0
|
||||
a=-9999.0d0
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,33 @@
|
||||
# This is the makefile for the optimization of leaf A curves
|
||||
# name of executable
|
||||
ALL = mathtest
|
||||
|
||||
# compiler options
|
||||
ifeq ($(COMPILER),INTEL) # if compiler is Intel
|
||||
FF = ifort
|
||||
FOPTS = -g
|
||||
else
|
||||
# Default to PGI Compilers
|
||||
FF = pgf90
|
||||
FOPTS = -g -Mbounds
|
||||
endif
|
||||
|
||||
|
||||
VPATH = ../math/othersupmath:../math/algebra:../math/optimization:../math/nonlinsystems
|
||||
|
||||
|
||||
# Define objects
|
||||
|
||||
OBJS = testexample.o fixedpoint.o nonsyssolver.o supmath.o adsor.o\
|
||||
bookkeeping.o broydn.o nongradopt.o CompassSearch.o powell.o\
|
||||
|
||||
|
||||
|
||||
$(ALL): $(OBJS)
|
||||
$(FF) $(FOPTS) $(OBJS) -o $@
|
||||
|
||||
.f.o:
|
||||
$(FF) -c $(FOPTS) $<
|
||||
|
||||
depend:
|
||||
/usr/bin/X11/makedepend -- $(CFLAGS) -- $(SRCS)
|
||||
@@ -0,0 +1,14 @@
|
||||
-0.218750000000000 0.200000000000000
|
||||
-0.195555560000000 0.105905580000000
|
||||
-0.205000000000000 0.442637760000000
|
||||
-0.176500000000000 6.329114000000000E-002
|
||||
-0.176000000000000 0.122913510000000
|
||||
-0.186666670000000 0.366581420000000
|
||||
-0.173684210000000 0.223684210000000
|
||||
-0.171428570000000 0.366692130000000
|
||||
-0.167894740000000 9.287926000000001E-002
|
||||
-0.167500000000000 0.127427180000000
|
||||
-0.157391300000000 8.733624000000000E-002
|
||||
-0.156923080000000 0.116176730000000
|
||||
-0.149000000000000 -9.330629000000000E-002
|
||||
-0.146250000000000 -3.086420000000000E-002
|
||||
@@ -0,0 +1,117 @@
|
||||
*******************************************************
|
||||
* ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) *
|
||||
*******************************************************
|
||||
|
||||
|
||||
|
||||
*** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ODR ***
|
||||
|
||||
|
||||
FOR RESPONSE 1 OF OBSERVATION 1
|
||||
|
||||
USER
|
||||
SUPPLIED RELATIVE DERIVATIVE
|
||||
DERIVATIVE WRT VALUE DIFFERENCE ASSESSMENT
|
||||
|
||||
BETA( 1) -2.19D-01 4.26D-08 VERIFIED
|
||||
BETA( 2) 1.00D+00 2.24D-08 VERIFIED
|
||||
DELTA( 1, 1) -2.00D+00 0.00D+00 VERIFIED
|
||||
|
||||
NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS 16
|
||||
(ESTIMATED BY ODRPACK)
|
||||
|
||||
NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN
|
||||
USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR
|
||||
USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED 4
|
||||
|
||||
ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED 1
|
||||
|
||||
-VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW
|
||||
|
||||
X( 1, 1) -2.18750000D-01
|
||||
*******************************************************
|
||||
* ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) *
|
||||
*******************************************************
|
||||
|
||||
|
||||
*** INITIAL SUMMARY FOR FIT BY METHOD OF ODR ***
|
||||
|
||||
--- PROBLEM SIZE:
|
||||
N = 111 (NUMBER WITH NONZERO WEIGHT = 111)
|
||||
NQ = 1
|
||||
M = 1
|
||||
NP = 2 (NUMBER UNFIXED = 2)
|
||||
|
||||
--- CONTROL VALUES:
|
||||
JOB = 00020
|
||||
= ABCDE, WHERE
|
||||
A=0 ==> FIT IS NOT A RESTART.
|
||||
B=0 ==> DELTAS ARE INITIALIZED TO ZERO.
|
||||
C=0 ==> COVARIANCE MATRIX WILL BE COMPUTED USING
|
||||
DERIVATIVES RE-EVALUATED AT THE SOLUTION.
|
||||
D=2 ==> DERIVATIVES ARE SUPPLIED BY USER.
|
||||
DERIVATIVES WERE CHECKED.
|
||||
RESULTS APPEAR CORRECT.
|
||||
E=0 ==> METHOD IS EXPLICIT ODR.
|
||||
NDIGIT = 16 (ESTIMATED BY ODRPACK)
|
||||
TAUFAC = 1.00D+00
|
||||
|
||||
--- STOPPING CRITERIA:
|
||||
SSTOL = 1.49D-08 (SUM OF SQUARES STOPPING TOLERANCE)
|
||||
PARTOL = 3.67D-11 (PARAMETER STOPPING TOLERANCE)
|
||||
MAXIT = ***** (MAXIMUM NUMBER OF ITERATIONS)
|
||||
|
||||
--- INITIAL WEIGHTED SUM OF SQUARES = 2.13555053D+00
|
||||
SUM OF SQUARED WEIGHTED DELTAS = 0.00000000D+00
|
||||
SUM OF SQUARED WEIGHTED EPSILONS = 2.13555053D+00
|
||||
|
||||
--- FUNCTION PARAMETER SUMMARY:
|
||||
|
||||
INDEX BETA(K) FIXED SCALE
|
||||
|
||||
(K) (IFIXB) (SCLB)
|
||||
|
||||
1 -2.00000000D+00 NO 5.00000000D-01
|
||||
2 0.00000000D+00 NO 5.00000000D+00
|
||||
|
||||
--- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:
|
||||
|
||||
INDEX X(I,J) DELTA(I,J) FIXED SCALE WEIGHT
|
||||
|
||||
(I,J) (IFIXX) (SCLD) (WD)
|
||||
|
||||
1,1 -2.188D-01 0.000D+00 NO 4.57D+00 1.00D+00
|
||||
N,1 -2.077D-02 0.000D+00 NO 4.81D+01 1.00D+00
|
||||
|
||||
--- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT SUMMARY:
|
||||
|
||||
INDEX Y(I,L) WEIGHT
|
||||
(I,L) (WE)
|
||||
|
||||
1,1 2.000D-01 1.000D+00
|
||||
N,1 1.912D-01 1.000D+00
|
||||
|
||||
*** FINAL SUMMARY FOR FIT BY METHOD OF ODR ***
|
||||
|
||||
--- STOPPING CONDITIONS:
|
||||
INFO = 1 ==> SUM OF SQUARES CONVERGENCE.
|
||||
NITER = 21 (NUMBER OF ITERATIONS)
|
||||
NFEV = 45 (NUMBER OF FUNCTION EVALUATIONS)
|
||||
NJEV = 22 (NUMBER OF JACOBIAN EVALUATIONS)
|
||||
IRANK = 0 (RANK DEFICIENCY)
|
||||
RCOND = 5.25D-02 (INVERSE CONDITION NUMBER)
|
||||
ISTOP = 0 (RETURNED BY USER FROM SUBROUTINE FCN)
|
||||
|
||||
--- FINAL WEIGHTED SUMS OF SQUARES = 2.68079707D-01
|
||||
SUM OF SQUARED WEIGHTED DELTAS = 2.65699278D-01
|
||||
SUM OF SQUARED WEIGHTED EPSILONS = 2.38042850D-03
|
||||
|
||||
--- RESIDUAL STANDARD DEVIATION = 4.95928105D-02
|
||||
DEGREES OF FREEDOM = 109
|
||||
|
||||
--- ESTIMATED BETA(J), J = 1, ..., NP:
|
||||
|
||||
BETA S.D. BETA ---- 95% CONFIDENCE INTERVAL ----
|
||||
|
||||
1 -1.05684671D+01 5.2232D+00 -2.09206418D+01 TO -2.16292352D-01
|
||||
2 -8.21207083D-01 4.7585D-01 -1.76432329D+00 TO 1.21909125D-01
|
||||
Binary file not shown.
Binary file not shown.
@@ -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
|
||||
@@ -0,0 +1,75 @@
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
subroutine C4PhotoFit()
|
||||
implicit none
|
||||
include '../testarea/LeafGasParams.h'
|
||||
include '../testarea/LeafGasHybridFit.h'
|
||||
integer i,ndim,k,j,iderivative,iwrong,jnon,n,icompete,isame,i2,
|
||||
&isitnaninf,nave
|
||||
double precision beta(20),sumsquare0,beta0(20),sumsquarecp,
|
||||
&betacp(20),ftol,xtol,shortx(maxobs,10),shorty(maxobs,5),
|
||||
&ftol_relax,term1,term2,ran2,history(2000,25),discount,upper,lower,
|
||||
&f1dim_C4Fit,ff_pikaia
|
||||
parameter(ftol=1.0d-7,xtol=1.0d-7)
|
||||
external funkmin_C4Fit,f1dim_C4Fit,FCN_C4Fit,ff_pikaia
|
||||
ndim=3
|
||||
beta(1)=vcmax25_ori
|
||||
beta(2)=c4aparslope_ori
|
||||
beta(3)=c4kp25_ori
|
||||
betamin(1)=0.0d0
|
||||
betamax(1)=500.0d0
|
||||
betamin(2)=0.0d0
|
||||
betamax(2)=10.0d0
|
||||
betamin(3)=0.0d0
|
||||
betamax(3)=200000.0d0*betamax(1)
|
||||
if(idord.eq.1)then
|
||||
ndim=4
|
||||
beta(ndim)=rdlight25_ori
|
||||
betamin(ndim)=0.0d0
|
||||
betamax(ndim)=15.0d0
|
||||
endif
|
||||
isitbounded=1
|
||||
call funkmin_C4Fit(ndim,beta,sumsquare)
|
||||
do i=1,ndim
|
||||
beta0(i)=beta(i)
|
||||
enddo
|
||||
sumsquare0=sumsquare
|
||||
do i=1,ntotsamples
|
||||
responses(i,1)=anet_obs(i)
|
||||
forcings(i,1)=pco2i(i)
|
||||
forcings(i,2)=aPPFDlf(i)
|
||||
forcings(i,3)=templeaf(i)
|
||||
forcings(i,4)=pres_air(i)
|
||||
do j=1,4
|
||||
weitforcings(i,j)=1.0d0
|
||||
enddo
|
||||
weitresponses(i,1)=1.0d0
|
||||
enddo
|
||||
j=4
|
||||
i=1
|
||||
iderivative=0
|
||||
iwrong=0
|
||||
call odr_leastsquare(ndim,FCN_C4Fit,beta,ntotsamples,
|
||||
&forcings(1:ntotsamples,1:j),j,responses(1:ntotsamples,1:i),i,
|
||||
&weitforcings(1:ntotsamples,1:j),weitresponses(1:ntotsamples,1:i),
|
||||
&iderivative,shortx(1:ntotsamples,1:j),shorty(1:ntotsamples,1:i),
|
||||
&sumsquare,iwrong)
|
||||
!after odr_leastsquare, forcing variables are destroyed. restore to the origninals
|
||||
do i=1,ntotsamples
|
||||
pco2i(i)=pco2i_ori(i)
|
||||
aPPFDlf(i)=aPPFDlf_ori(i)
|
||||
templeaf(i)=templeaf_ori(i)
|
||||
pres_air(i)=pres_air_ori(i)
|
||||
enddo
|
||||
call funkmin_C4Fit(ndim,beta,sumsquare)
|
||||
do i=1,10
|
||||
call nongradopt(ndim,funkmin_C4Fit,f1dim_C4Fit,beta,betamin,
|
||||
&betamax,ftol,sumsquare)
|
||||
call funkmin_C4Fit(ndim,beta,sumsquare)
|
||||
call RepeatCompassSearch(ndim,beta,sumsquare,
|
||||
&betamin,betamax,funkmin_C4Fit,f1dim_C4Fit,ftol)
|
||||
call funkmin_C4Fit(ndim,beta,sumsquare)
|
||||
enddo
|
||||
call ilimittypestats(ntotsamples,Postiphotolimit,
|
||||
&bestilimittype,bestnumrubis,bestnumrubp,bestnumtpu)
|
||||
return
|
||||
END subroutine C4PhotoFit
|
||||
File diff suppressed because it is too large
Load Diff
@@ -233,7 +233,7 @@
|
||||
2001 continue
|
||||
enddo
|
||||
|
||||
! goto 1000
|
||||
goto 1000
|
||||
|
||||
gacontrol(1)=200.0d0
|
||||
gacontrol(2)=2000.0d0
|
||||
|
||||
@@ -596,8 +596,8 @@
|
||||
do j=1,npoints
|
||||
write(unitwuecicacomp,380)curveno,trim(curvename),co2a_ppm(j),
|
||||
&vpdl(j),wue(j),wuemod(j),cicameas(j),cicamod(j),wue_intrin(j),
|
||||
&wue_intrinmod(j),((cccimeas(k,j),cccimod(k,j)),k=1,4),
|
||||
&((co2recycleratio(k,j),recycmod(k,j)),k=1,6)
|
||||
&wue_intrinmod(j),(cccimeas(k,j),cccimod(k,j),k=1,4),
|
||||
&(co2recycleratio(k,j),recycmod(k,j),k=1,6)
|
||||
enddo
|
||||
write(unitparamsout,390)curveno,trim(curvename),npoints_stom,
|
||||
&co2threshold,co2current,vpdl_ref,ballintersurf,ballslopesurf,
|
||||
@@ -608,10 +608,10 @@
|
||||
&dewarrsqgsw,wueref,der_wueref,rsqwue,(alfit(i),i=1,5),
|
||||
&wueref_intrin,der_wueref_intrin,rsqwue_intrin,(blfit(i),i=1,5),
|
||||
&cicaref,der_cicaref,rsqcica,(cicafit(i),i=1,5),
|
||||
&avetleaf,avetair,avevpdl,avepari,((ccciref(i),der_ccciref(i),
|
||||
&rsqccci(i),(cccifit(i,j),j=1,6)),i=1,4),
|
||||
&((recycref(i),der_recycref(i),
|
||||
&rsqrecyc(i),(recycfit(i,j),j=1,5)),i=1,6),
|
||||
&avetleaf,avetair,avevpdl,avepari,(ccciref(i),der_ccciref(i),
|
||||
&rsqccci(i),(cccifit(i,j),j=1,6),i=1,4),
|
||||
&(recycref(i),der_recycref(i),
|
||||
&rsqrecyc(i),(recycfit(i,j),j=1,5),i=1,6),
|
||||
!
|
||||
&trim(siteID),Latitude,Longitude,Elevation,yearsampled,
|
||||
&sampledoy,GrowingSeasonStart,GrowingSeasonEnd,
|
||||
|
||||
@@ -17,7 +17,7 @@
|
||||
integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2,
|
||||
&ntotfiles,noutputfiles,i,j,k,rank_mpi,numproc_mpi,numproc,
|
||||
&ierror_mpi,nshare,nmod,npartfiles,istartno,iendno,indexunit(20),
|
||||
&numchar,needheader(20),rootprocess
|
||||
&numchar,needheader(20),rootprocess,ic3c4cam
|
||||
character rundate*8,runtime*10,runzone*5,longchar*5000,achar*5,
|
||||
&longchar1*5000
|
||||
character*100 datapath,outpath,storein,storeout,ACidata(8000)
|
||||
@@ -26,12 +26,13 @@
|
||||
! Set input / output directory
|
||||
parameter(
|
||||
& datapath=
|
||||
&'../input/',
|
||||
! &'/home/l2g/ngeetropics/gamboa/curves/',
|
||||
! &'/home/l2g/ngeetropics/metropolitano/curves/',
|
||||
! &'/home/l2g/ngeetropics/fortsherman/curves/',
|
||||
! & '/home/l2g/ngeetropics/kelsey/curves/',
|
||||
! & '/home/l2g/leafres/hybriddata/Berner/',
|
||||
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/',
|
||||
|
||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
|
||||
@@ -61,12 +62,13 @@
|
||||
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
|
||||
! & '/home/l2g/GEMSiS/curves/',
|
||||
& outpath=
|
||||
&'../output/fitresult/touser/',
|
||||
! &'/home/l2g/ngeetropics/gamboa/results/',
|
||||
! &'/home/l2g/ngeetropics/metropolitano/results/',
|
||||
! &'/home/l2g/ngeetropics/fortsherman/',
|
||||
! &'/home/l2g/ngeetropics/kelsey/results/',
|
||||
! & '/home/l2g/leafres/hybriddata/Berner/',
|
||||
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/',
|
||||
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
|
||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
|
||||
@@ -100,23 +102,50 @@
|
||||
! &storein='/home/l2g/leafweb/users/curves/',
|
||||
! &storeout='/home/l2g/leafweb/users/results/',
|
||||
|
||||
&storein='/home/l2g/clm/results/',
|
||||
&storeout='/home/l2g/clm/results/',
|
||||
&storein='../output/clninput/',
|
||||
&storeout='../output/fitresult/nottouser/',
|
||||
|
||||
! &storein='/home/l2g/junk/',
|
||||
! &storeout='/home/l2g/junk/',
|
||||
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
||||
! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
||||
|
||||
& AllACiFiles='AllLeafGasFiles')
|
||||
& AllACiFiles='../piscal.cfg')
|
||||
!---------------End of variable declaration----------------
|
||||
rootprocess=0
|
||||
dataunit=1
|
||||
spareunit=3
|
||||
! if(rank_mpi.ne.rootprocess)goto 25
|
||||
!read A/Ci curve names stored in AllACiFiles
|
||||
open(unit=2,file=trim(datapath)//trim(AllACiFiles))
|
||||
open(unit=2,file=trim(AllACiFiles))
|
||||
ntotfiles=1
|
||||
ic3c4cam=-9999
|
||||
10 read(2,fmt=300,end=20)longchar
|
||||
if(longchar.eq.''.or.longchar.eq.' ')goto 10
|
||||
if(ntotfiles.eq.1.and.ic3c4cam.lt.0)then
|
||||
i=0
|
||||
if(index(longchar,'_photosynthesis_leafweb').gt.0)then
|
||||
i=index(longchar,'c3')+index(longchar,'C3')
|
||||
if(i.gt.0)then
|
||||
ic3c4cam=1
|
||||
else
|
||||
i=index(longchar,'c4')+index(longchar,'C4')
|
||||
if(i.gt.0)then
|
||||
ic3c4cam=2
|
||||
else
|
||||
i=index(longchar,'cam')+index(longchar,'caM')+
|
||||
&index(longchar,'cAm')+index(longchar,'cAM')+
|
||||
&index(longchar,'Cam')+index(longchar,'CaM')+
|
||||
&index(longchar,'CAm')+index(longchar,'CAM')
|
||||
if(i.gt.0)ic3c4cam=3
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
if(i.gt.0)goto 10
|
||||
!if no indication is provided, c3 photosynthesis is assumed and the first line
|
||||
!contains the name of the first data file
|
||||
ic3c4cam=1
|
||||
endif
|
||||
i=len(longchar)
|
||||
j=0
|
||||
15 j=j+1
|
||||
@@ -153,6 +182,9 @@
|
||||
noutputfiles=11
|
||||
!10 to 20 are used for file units for output files
|
||||
do i=1,noutputfiles
|
||||
if(ic3c4cam.eq.1)outputfile(i)='C3_'//outputfile(i)
|
||||
if(ic3c4cam.eq.2)outputfile(i)='C4_'//outputfile(i)
|
||||
if(ic3c4cam.eq.3)outputfile(i)='CAM_'//outputfile(i)
|
||||
indexunit(i)=i+9
|
||||
enddo
|
||||
call MPI_INIT(ierror_mpi)
|
||||
@@ -190,82 +222,16 @@
|
||||
numchar=numchar+1
|
||||
goto 30
|
||||
40 call NumberToChar(rank_mpi,numchar,achar)
|
||||
do i=1,noutputfiles-1
|
||||
do i=1,noutputfiles
|
||||
open(unit=indexunit(i),
|
||||
&file=trim(outpath)//trim(outputfile(i))//trim(achar))
|
||||
enddo
|
||||
call ToLeafGasOptimization(npartfiles,ACidata(istartno:iendno),
|
||||
&dataunit,spareunit,datapath,indexunit,ierr)
|
||||
do i=1,noutputfiles-1
|
||||
call ToLeafGasOptimization(ic3c4cam,npartfiles,
|
||||
&ACidata(istartno:iendno),dataunit,spareunit,datapath,indexunit,
|
||||
&ierr)
|
||||
do i=1,noutputfiles
|
||||
close(indexunit(i))
|
||||
enddo
|
||||
if(ierr(1).ne.0)then
|
||||
i=indexunit(noutputfiles)
|
||||
open(unit=i,
|
||||
&file=trim(outpath)//trim(outputfile(noutputfiles))//trim(achar))
|
||||
write(i,*)'Input data error in ',ACidata(ierr(2)+istartno-1)
|
||||
write(i,*)
|
||||
&'Please resubmit the data after correcting the following error:'
|
||||
if(ierr(1).eq.1)then
|
||||
write(i,*)'Photosynthesis (umol/m2/s) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.2)then
|
||||
write(i,*)'Intercellular CO2(ppm) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.3)then
|
||||
write(i,*)'Leaf temperature (oC) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.4)then
|
||||
write(i,*)'Chamber PAR (umol/m2/s) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.5)then
|
||||
write(i,*)'Atmospheric pressure (Pa) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.13)then
|
||||
write(i,*)'Check line 13 for data entry error'
|
||||
endif
|
||||
if(ierr(1).eq.14)then
|
||||
write(i,*)'Specified chloroplastic CO2 compensation point',
|
||||
&'(Pa) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.15)then
|
||||
write(i,*)'Specified Michaelis-Menten constant for the',
|
||||
&'carboxylase (Kc) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.16)then
|
||||
write(i,*)'Specified Michaelis-Menten constant for the',
|
||||
&'oxygenase (Ko) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.17)then
|
||||
write(i,*)'Specified fraction of nonreturned glycolate',
|
||||
&'carbon(alpha) out of range 0~1'
|
||||
endif
|
||||
if(ierr(1).eq.18)then
|
||||
write(i,*)'Specified dark respiration rate Rd out of range >0'
|
||||
endif
|
||||
if(ierr(1).eq.19)then
|
||||
write(i,*)'Specified mesophyll) resistance rch or rwp out of',
|
||||
&'of range >0'
|
||||
endif
|
||||
if(ierr(1).eq.34)then
|
||||
write(i,*)'Check Column 33 or 34. Mixing area- and mass-based
|
||||
&measurements is not allowed'
|
||||
endif
|
||||
if(ierr(1).eq.36)then
|
||||
write(i,*)'Check line 16 for data entry error'
|
||||
endif
|
||||
if(ierr(1).eq.39)then
|
||||
write(i,*)
|
||||
&'Check the main body of data for data entry error, starting from
|
||||
&line 19'
|
||||
endif
|
||||
if(ierr(1).eq.40)then
|
||||
write(i,*)
|
||||
&'Data file format cannot be recognized'
|
||||
endif
|
||||
|
||||
close(i)
|
||||
endif
|
||||
!make sure everyone is done before wrapping up.
|
||||
45 call MPI_BARRIER(MPI_COMM_WORLD,ierror_mpi)
|
||||
if(rank_mpi.eq.rootprocess)then
|
||||
@@ -326,29 +292,41 @@
|
||||
enddo
|
||||
!----------------------------------------------------------
|
||||
!intercept the data
|
||||
goto 450
|
||||
399 call date_and_time(rundate,runtime,runzone,runvalues)
|
||||
if(needheader(noutputfiles).eq.2)then
|
||||
!if there is error in any input files, donot store the data
|
||||
do i=1,ntotfiles
|
||||
open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i)))
|
||||
close(1,status='delete')
|
||||
enddo
|
||||
goto 450
|
||||
endif
|
||||
call date_and_time(rundate,runtime,runzone,runvalues)
|
||||
do i=1,ntotfiles
|
||||
open(unit=1,file=trim(datapath)//trim(ACidata(i)))
|
||||
open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i)))
|
||||
open(unit=2,file=
|
||||
&trim(storein)//rundate//runtime(1:6)//trim(ACidata(i)))
|
||||
&trim(storein)//rundate//runtime(1:6)//'clean'//trim(ACidata(i)))
|
||||
400 read(1,fmt=300,end=410)longchar
|
||||
write(2,310)trim(longchar)
|
||||
goto 400
|
||||
410 close(1)
|
||||
410 close(1,status='delete')
|
||||
close(2)
|
||||
enddo
|
||||
do i=1,6
|
||||
do i=1,noutputfiles
|
||||
k=0
|
||||
open(unit=1,file=trim(outpath)//trim(outputfile(i)))
|
||||
open(unit=2,file=
|
||||
if(i.ge.3.and.i.le.5)then
|
||||
open(unit=2,file=
|
||||
&trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i)))
|
||||
else
|
||||
open(unit=2,file=
|
||||
&trim(outpath)//rundate//runtime(1:6)//trim(outputfile(i)))
|
||||
endif
|
||||
420 read(1,fmt=300,end=430)longchar
|
||||
write(2,310)trim(longchar)
|
||||
k=1
|
||||
goto 420
|
||||
430 if(k.eq.1)then
|
||||
close(1)
|
||||
close(1,status='delete')
|
||||
close(2)
|
||||
else
|
||||
close(1,status='delete')
|
||||
|
||||
@@ -15,7 +15,7 @@
|
||||
program main
|
||||
implicit none
|
||||
integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2,
|
||||
&ntotfiles,noutputfiles,i,j,k,indexunit(20)
|
||||
&ntotfiles,noutputfiles,i,j,k,indexunit(20),ic3c4cam
|
||||
character rundate*8,runtime*10,runzone*5,longchar*5000
|
||||
character*100 datapath,outpath,storein,storeout,
|
||||
&ACidata(8000)
|
||||
@@ -23,11 +23,14 @@
|
||||
|
||||
! Set input / output directory
|
||||
parameter(datapath=
|
||||
! &'../input/',
|
||||
&'/home/l2g/jimei/',
|
||||
! &'/home/l2g/ngeetropics/gamboa/curves/',
|
||||
! &'/home/l2g/ngeetropics/metropolitano/curves/',
|
||||
! &'/home/l2g/ngeetropics/fortsherman/curves/',
|
||||
! &'/home/l2g/ngeetropics/kelsey/curves/',
|
||||
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! &'/home/l2g/leafres/hybriddata/nicksmith/data/',
|
||||
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/',
|
||||
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
|
||||
! &'/home/l2g/leafres/hybriddata/hanjimei/',
|
||||
@@ -59,6 +62,8 @@
|
||||
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
|
||||
! & '/home/l2g/GEMSiS/curves/',
|
||||
& outpath=
|
||||
! &'../output/fitresult/touser/',
|
||||
&'/home/l2g/jimei/',
|
||||
! &'/home/l2g/ngeetropics/gamboa/results/',
|
||||
! &'/home/l2g/ngeetropics/metropolitano/results/',
|
||||
! &'/home/l2g/ngeetropics/fortsherman/results/',
|
||||
@@ -69,7 +74,9 @@
|
||||
! &'/home/l2g/leafres/hybriddata/hanjimei/',
|
||||
!
|
||||
! & '/home/l2g/leafres/hybriddata/Berner/',
|
||||
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
|
||||
! & '/home/l2g/leafres/hybriddata/nicksmith/results/',
|
||||
|
||||
! & '/home/l2g/leafres/hybriddata/huidafeng/',
|
||||
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/
|
||||
! &',
|
||||
@@ -99,43 +106,28 @@
|
||||
! &storein='/home/l2g/leafweb/users/curves/',
|
||||
! &storeout='/home/l2g/leafweb/users/results/',
|
||||
|
||||
&storein='/home/l2g/leafres/testdata/',
|
||||
&storeout='/home/l2g/leafres/testdata/',
|
||||
! &storein='/home/l2g/junk/',
|
||||
! &storeout='/home/l2g/junk/',
|
||||
! &storein='../output/clninput/',
|
||||
! &storeout='../output/fitresult/nottouser/',
|
||||
|
||||
&storein='/home/l2g/jimei/',
|
||||
&storeout='/home/l2g/jimei/',
|
||||
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
||||
! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
||||
|
||||
& AllACiFiles='AllLeafGasFiles')
|
||||
! & AllACiFiles='../piscal.cfg')
|
||||
&AllACiFiles='/home/l2g/jimei/piscal.cfg')
|
||||
!---------------End of variable declaration----------------
|
||||
ierr(1)=-1
|
||||
ierr(2)=-1
|
||||
outputfile(1)='leafgasparameters.csv'
|
||||
outputfile(2)='leafgascomparison.csv'
|
||||
outputfile(3)='stomwuecicaparameters.csv'
|
||||
outputfile(4)='stomcomparison.csv'
|
||||
outputfile(5)='wuecicacomparison.csv'
|
||||
outputfile(6)='fluorescencefit.csv'
|
||||
outputfile(7)='fluoresparameters.csv'
|
||||
outputfile(8)='aciempfitparameters.csv'
|
||||
outputfile(9)='alightempfitparameters.csv'
|
||||
outputfile(10)='warningmessage'
|
||||
outputfile(11)='errormessage'
|
||||
noutputfiles=11
|
||||
do i=1,noutputfiles
|
||||
indexunit(i)=i+9
|
||||
enddo
|
||||
do i=1,noutputfiles-1
|
||||
open(unit=indexunit(i),file=trim(outpath)//trim(outputfile(i)))
|
||||
enddo
|
||||
!read A/Ci curve names stored in AllACiFiles
|
||||
dataunit=1
|
||||
spareunit=3
|
||||
open(unit=dataunit,status='scratch')
|
||||
open(unit=spareunit,file=trim(datapath)//trim(AllACiFiles))
|
||||
read(spareunit,fmt=300,err=40,end=40)longchar
|
||||
open(unit=spareunit,file=trim(AllACiFiles))
|
||||
read(spareunit,fmt=300,err=90,end=90)longchar
|
||||
rewind(spareunit)
|
||||
2 read(spareunit,fmt=300,err=40,end=5)longchar
|
||||
2 read(spareunit,fmt=300,err=90,end=5)longchar
|
||||
if(longchar.eq.''.or.longchar.eq.' ')goto 2
|
||||
3 k=index(longchar,char(13))
|
||||
if(k.gt.0)then
|
||||
!DOS text format, convert it to unix format
|
||||
@@ -147,7 +139,34 @@
|
||||
5 close(spareunit)
|
||||
rewind(dataunit)
|
||||
ntotfiles=1
|
||||
ic3c4cam=-9999
|
||||
10 read(dataunit,fmt=300,end=20)longchar
|
||||
if(ntotfiles.eq.1.and.ic3c4cam.lt.0)then
|
||||
i=0
|
||||
if((index(longchar,'_photosynthesis_leafweb')+
|
||||
&index(longchar,'_Photosynthesis_leafweb')+
|
||||
&index(longchar,'_Photosynthesis_LeafWeb')).gt.0)then
|
||||
i=index(longchar,'c3')+index(longchar,'C3')
|
||||
if(i.gt.0)then
|
||||
ic3c4cam=1
|
||||
else
|
||||
i=index(longchar,'c4')+index(longchar,'C4')
|
||||
if(i.gt.0)then
|
||||
ic3c4cam=2
|
||||
else
|
||||
i=index(longchar,'cam')+index(longchar,'caM')+
|
||||
&index(longchar,'cAm')+index(longchar,'cAM')+
|
||||
&index(longchar,'Cam')+index(longchar,'CaM')+
|
||||
&index(longchar,'CAm')+index(longchar,'CAM')
|
||||
if(i.gt.0)ic3c4cam=3
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
if(i.gt.0)goto 10
|
||||
!if no indication is provided, c3 photosynthesis is assumed and the first line
|
||||
!contains the name of the first data file
|
||||
ic3c4cam=1
|
||||
endif
|
||||
i=len(longchar)
|
||||
j=0
|
||||
15 j=j+1
|
||||
@@ -170,83 +189,32 @@
|
||||
goto 10
|
||||
20 ntotfiles=ntotfiles-1
|
||||
close(dataunit)
|
||||
call ToLeafGasOptimization(ntotfiles,ACidata,dataunit,spareunit,
|
||||
&datapath,indexunit,ierr)
|
||||
40 do i=1,noutputfiles-1
|
||||
outputfile(1)='leafgasparameters.csv'
|
||||
outputfile(2)='leafgascomparison.csv'
|
||||
outputfile(3)='stomwuecicaparameters.csv'
|
||||
outputfile(4)='stomcomparison.csv'
|
||||
outputfile(5)='wuecicacomparison.csv'
|
||||
outputfile(6)='fluorescencefit.csv'
|
||||
outputfile(7)='fluoresparameters.csv'
|
||||
outputfile(8)='aciempfitparameters.csv'
|
||||
outputfile(9)='alightempfitparameters.csv'
|
||||
outputfile(10)='warningmessage'
|
||||
outputfile(11)='errormessage'
|
||||
noutputfiles=11
|
||||
do i=1,noutputfiles
|
||||
if(ic3c4cam.eq.1)outputfile(i)='C3_'//outputfile(i)
|
||||
if(ic3c4cam.eq.2)outputfile(i)='C4_'//outputfile(i)
|
||||
if(ic3c4cam.eq.3)outputfile(i)='CAM_'//outputfile(i)
|
||||
indexunit(i)=i+9
|
||||
enddo
|
||||
do i=1,noutputfiles
|
||||
open(unit=indexunit(i),file=trim(outpath)//trim(outputfile(i)))
|
||||
enddo
|
||||
call ToLeafGasOptimization(ic3c4cam,ntotfiles,ACidata,dataunit,
|
||||
&spareunit,datapath,indexunit,ierr)
|
||||
do i=1,noutputfiles
|
||||
close(indexunit(i))
|
||||
enddo
|
||||
if(ierr(1).ne.0)then
|
||||
i=indexunit(noutputfiles)
|
||||
open(unit=i,file=trim(outpath)//trim(outputfile(noutputfiles)))
|
||||
if(ierr(1).eq.-1)then
|
||||
close(spareunit)
|
||||
write(i,*)
|
||||
&'No data files to analyze or incorrect file name format'
|
||||
else
|
||||
write(i,*)'Input data error in ',trim(ACidata(ierr(2)))
|
||||
write(i,*)
|
||||
&'Please resubmit the data after correcting the following error:'
|
||||
endif
|
||||
if(ierr(1).eq.1)then
|
||||
write(i,*)'Photosynthesis (umol/m2/s) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.2)then
|
||||
write(i,*)'Intercellular CO2(ppm) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.3)then
|
||||
write(i,*)'Leaf temperature (oC) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.4)then
|
||||
write(i,*)'Chamber PAR (umol/m2/s) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.5)then
|
||||
write(i,*)'Atmospheric pressure (Pa) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.13)then
|
||||
write(i,*)'Check line 13 for data entry error'
|
||||
endif
|
||||
if(ierr(1).eq.14)then
|
||||
write(i,*)'Specified chloroplastic CO2 compensation point',
|
||||
&'(Pa) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.15)then
|
||||
write(i,*)'Specified Michaelis-Menten constant for the',
|
||||
&'carboxylase (Kc) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.16)then
|
||||
write(i,*)'Specified Michaelis-Menten constant for the',
|
||||
&'oxygenase (Ko) out of range'
|
||||
endif
|
||||
if(ierr(1).eq.17)then
|
||||
write(i,*)'Specified fraction of nonreturned glycolate',
|
||||
&'carbon(alpha) out of range 0~1'
|
||||
endif
|
||||
if(ierr(1).eq.18)then
|
||||
write(i,*)'Specified dark respiration rate Rd out of range >0'
|
||||
endif
|
||||
if(ierr(1).eq.19)then
|
||||
write(i,*)'Specified internal (mesophyll) conductance gi out',
|
||||
&'of range >0'
|
||||
endif
|
||||
if(ierr(1).eq.34)then
|
||||
write(i,*)'Check Column 33 or 34. Mixing area- and mass-based
|
||||
&measurements is not allowed'
|
||||
endif
|
||||
if(ierr(1).eq.36)then
|
||||
write(i,*)'Check line 16 for data entry error'
|
||||
endif
|
||||
if(ierr(1).eq.39)then
|
||||
write(i,*)
|
||||
&'Check the main body of data for data entry error, starting from
|
||||
&line 19'
|
||||
endif
|
||||
if(ierr(1).eq.40)then
|
||||
write(i,*)
|
||||
&'Data file format cannot be recognized'
|
||||
endif
|
||||
|
||||
close(i)
|
||||
endif
|
||||
do j=1,noutputfiles
|
||||
open(unit=2,file=trim(outpath)//trim(outputfile(j)))
|
||||
read(2,*,end=70)
|
||||
@@ -260,29 +228,47 @@
|
||||
80 enddo
|
||||
!----------------------------------------------------------
|
||||
!intercept the data
|
||||
goto 450
|
||||
399 call date_and_time(rundate,runtime,runzone,runvalues)
|
||||
90 if(ierr(1).ne.0)then
|
||||
if(ierr(1).eq.-1)then
|
||||
close(spareunit)
|
||||
open(unit=spareunit,file=trim(outpath)//'errormessage')
|
||||
write(spareunit,*)'No data files to analyze'
|
||||
close(spareunit)
|
||||
goto 450
|
||||
endif
|
||||
do i=1,ntotfiles
|
||||
open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i)))
|
||||
close(1,status='delete')
|
||||
enddo
|
||||
goto 450
|
||||
endif
|
||||
call date_and_time(rundate,runtime,runzone,runvalues)
|
||||
do i=1,ntotfiles
|
||||
open(unit=1,file=trim(datapath)//trim(ACidata(i)))
|
||||
open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i)))
|
||||
open(unit=2,file=
|
||||
&trim(storein)//rundate//runtime(1:6)//trim(ACidata(i)))
|
||||
&trim(storein)//rundate//runtime(1:6)//'clean'//trim(ACidata(i)))
|
||||
400 read(1,fmt=300,end=410)longchar
|
||||
write(2,310)trim(longchar)
|
||||
goto 400
|
||||
410 close(1)
|
||||
410 close(1,status='delete')
|
||||
close(2)
|
||||
enddo
|
||||
do i=1,6
|
||||
do i=1,noutputfiles
|
||||
k=0
|
||||
open(unit=1,file=trim(outpath)//trim(outputfile(i)))
|
||||
open(unit=2,file=
|
||||
if(i.ge.3.and.i.le.5)then
|
||||
open(unit=2,file=
|
||||
&trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i)))
|
||||
else
|
||||
open(unit=2,file=
|
||||
&trim(outpath)//rundate//runtime(1:6)//trim(outputfile(i)))
|
||||
endif
|
||||
420 read(1,fmt=300,end=430)longchar
|
||||
write(2,310)trim(longchar)
|
||||
k=1
|
||||
goto 420
|
||||
430 if(k.eq.1)then
|
||||
close(1)
|
||||
close(1,status='delete')
|
||||
close(2)
|
||||
else
|
||||
close(1,status='delete')
|
||||
|
||||
@@ -58,7 +58,7 @@
|
||||
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
|
||||
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
|
||||
&ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax,
|
||||
&ha_gmeso_ori
|
||||
&ha_gmeso_ori,c4aparslope,c4aparslope_ori,c4kp25,c4kp25_ori
|
||||
|
||||
integer minimumrubis,minimumfj,minimumvt,idorwp,idorch,idord,
|
||||
&idostargamma,idoalpha,idokc,idoko,ifixunivparams(maxpsnparam),
|
||||
@@ -84,7 +84,7 @@
|
||||
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
|
||||
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
|
||||
&ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax,
|
||||
&ha_gmeso_ori
|
||||
&ha_gmeso_ori,c4aparslope,c4aparslope_ori,c4kp25,c4kp25_ori
|
||||
|
||||
common /intleafparams/minimumrubis,minimumfj,minimumvt,idorwp,
|
||||
&idorch,idord,idostargamma,idoalpha,idokc,idoko,ifixunivparams,
|
||||
|
||||
@@ -1,8 +1,9 @@
|
||||
subroutine LeafGasPrintToFiles(isitmassbased,indexunit)
|
||||
subroutine LeafGasPrintToFiles(isitmassbased,indexunit,
|
||||
&ic3c4cam)
|
||||
implicit none
|
||||
integer isitmassbased,indexunit(20),paramunit,compareunit,
|
||||
&stomwuecicaoutunit,stomcompunit,wuecicacompunit,fluorescenceunit,
|
||||
&fluoresparamunit,aciempfitunit,alightempfitunit
|
||||
&fluoresparamunit,aciempfitunit,alightempfitunit,ic3c4cam
|
||||
character *25,
|
||||
& sitevars(50),unitsitevars(50),
|
||||
& paramsvar(0:50),unitparamsvar(0:50),
|
||||
@@ -363,7 +364,7 @@
|
||||
unitparamsvar(41)='umolkg-1s-1'
|
||||
unitparamsvar(42)='umolkg-1s-1'
|
||||
endif
|
||||
|
||||
|
||||
sitevars(1)='siteID'
|
||||
sitevars(2)='Latitude'
|
||||
sitevars(3)='Longitude'
|
||||
@@ -411,15 +412,25 @@
|
||||
unitsitevars(21)='ring/diffuse'
|
||||
unitsitevars(22)='g/cm3'
|
||||
unitsitevars(23)='Unitless'
|
||||
|
||||
write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9),
|
||||
if(ic3c4cam.eq.1)then
|
||||
write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9),
|
||||
&(trim(paramsvar(i)),',',i=0,34),(trim(paramsvar(i)),',',i=39,42),
|
||||
&(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
|
||||
write(paramunit,'(2000A)')(trim(unitunivcomvars(i)),',',i=1,9),
|
||||
write(paramunit,'(2000A)')(trim(unitunivcomvars(i)),',',i=1,9),
|
||||
&(trim(unitparamsvar(i)),',',i=0,34),
|
||||
&(trim(unitparamsvar(i)),',',i=39,42),
|
||||
&(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23))
|
||||
|
||||
endif
|
||||
if(ic3c4cam.eq.2)then
|
||||
write(paramunit,'(2000A)')trim(univcomvars(1)),',',
|
||||
&'Model,Vcmax25,c4aparslope,c4kp25,rdlight25,',
|
||||
&(trim(paramsvar(i)),',',i=30,34),
|
||||
&(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
|
||||
write(paramunit,'(2000A)')trim(unitunivcomvars(1)),',',
|
||||
&'NA,umolm-2s-1,CO2/photon,umolm-2s-1,umolm-2s-1,',
|
||||
&(trim(unitparamsvar(i)),',',i=30,34),
|
||||
&(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23))
|
||||
endif
|
||||
write(fluorescenceunit,'(1000A)')trim(univcomvars(1)),',',
|
||||
&(trim(univcomvars(i)),',',i=10,14),
|
||||
&(trim(univcomvars(i)),',',i=17,27),
|
||||
@@ -514,9 +525,9 @@
|
||||
unitstomwuecica(16)='umolkg-1s-1'
|
||||
endif
|
||||
|
||||
write(stomcompunit,'(100A)')((trim(stomwuecica(i)),','),
|
||||
write(stomcompunit,'(100A)')(trim(stomwuecica(i)),',',
|
||||
&i=1,15),trim(stomwuecica(16))
|
||||
write(stomcompunit,'(100A)')((trim(unitstomwuecica(i)),','),
|
||||
write(stomcompunit,'(100A)')(trim(unitstomwuecica(i)),',',
|
||||
&i=1,15),trim(unitstomwuecica(16))
|
||||
!------------------------------------------------------------
|
||||
stomwuecica(1)='curveno'
|
||||
@@ -581,9 +592,9 @@
|
||||
unitstomwuecica(29)='NA'
|
||||
unitstomwuecica(30)='NA'
|
||||
|
||||
write(wuecicacompunit,'(200A)')((trim(stomwuecica(i)),','),
|
||||
write(wuecicacompunit,'(200A)')(trim(stomwuecica(i)),',',
|
||||
&i=1,29),trim(stomwuecica(30))
|
||||
write(wuecicacompunit,'(200A)')((trim(unitstomwuecica(i)),','),
|
||||
write(wuecicacompunit,'(200A)')(trim(unitstomwuecica(i)),',',
|
||||
&i=1,29),trim(stomwuecica(30))
|
||||
|
||||
stomwuecica(1)='curveno'
|
||||
@@ -875,10 +886,10 @@
|
||||
unitstomwuecica(55)='umolkg-1s-1'
|
||||
endif
|
||||
|
||||
write(stomwuecicaoutunit,'(2000A)')((trim(stomwuecica(i)),','),
|
||||
&i=1,139),((trim(sitevars(i)),','),i=1,22),trim(sitevars(23))
|
||||
write(stomwuecicaoutunit,'(2000A)')((trim(unitstomwuecica(i)),
|
||||
&','),i=1,139),((trim(unitsitevars(i)),','),i=1,22),
|
||||
write(stomwuecicaoutunit,'(2000A)')(trim(stomwuecica(i)),',',
|
||||
&i=1,139),(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
|
||||
write(stomwuecicaoutunit,'(2000A)')(trim(unitstomwuecica(i)),
|
||||
&',',i=1,139),(trim(unitsitevars(i)),',',i=1,22),
|
||||
&trim(unitsitevars(23))
|
||||
return
|
||||
end
|
||||
|
||||
@@ -685,7 +685,7 @@
|
||||
else
|
||||
betamin(1)=0.5d0*amaxave
|
||||
endif
|
||||
betamax(1)=200.0d0
|
||||
betamax(1)=1000.0d0
|
||||
beta(2)=1.5d0
|
||||
betamin(2)=1.0d-5
|
||||
betamax(2)=1000.0d0
|
||||
@@ -696,8 +696,8 @@
|
||||
betamin(4)=0.0d0
|
||||
betamax(4)=5000.0d0
|
||||
beta(5)=-10.0d0
|
||||
betamin(5)=-100.0d0
|
||||
betamax(5)=100.0d0
|
||||
betamin(5)=-1000.0d0
|
||||
betamax(5)=1000.0d0
|
||||
k=0
|
||||
n=0
|
||||
do j=1,nACiPoints(i)
|
||||
@@ -717,6 +717,7 @@
|
||||
wvector(n)=ACipco2ambient(j,i)
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
call GenericRegres(nACiPoints(i),1,
|
||||
&ACianet_obs(1:nACiPoints(i),i:i),1,ACipco2i(1:nACiPoints(i),i:i),
|
||||
&weity,weitx,5,beta,betamin,betamax,xmin,xmax,iderivative,INFO,
|
||||
@@ -726,13 +727,24 @@
|
||||
&ACipco2i(nACiPoints(i):nACiPoints(i),i:i),der_ACiend(i),term,
|
||||
&ACipco2i(1:1,i:i),ACipco2i(nACiPoints(i):nACiPoints(i),i:i),
|
||||
&ACimaxcurvature(i),ACimaxcurvpco2i(i))
|
||||
call GenericRegres(n,1,zvector,1,wvector,weity,weitx,5,beta,
|
||||
if(n.ge.5)then
|
||||
call GenericRegres(n,1,zvector,1,wvector,weity,weitx,5,beta,
|
||||
&betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector,
|
||||
&sumsquare)
|
||||
call properties_surffunc(5,beta,starco2a(i),der_starco2a(i),
|
||||
call properties_surffunc(5,beta,starco2a(i),der_starco2a(i),
|
||||
&Amax_ACa(i),ACainter(i),der_ACainter(i),40.0d0,der_ACa400ppm(i),
|
||||
&anet_ACa400ppm(i),wvector(1),wvector(n),ACamaxcurvature(i),
|
||||
&ACamaxcurvpco2a(i))
|
||||
else
|
||||
der_starco2a(i)=-9999.0d0
|
||||
Amax_ACa(i)=-9999.0d0
|
||||
ACainter(i)=-9999.0d0
|
||||
der_ACainter(i)=-9999.0d0
|
||||
der_ACa400ppm(i)=-9999.0d0
|
||||
anet_ACa400ppm(i)=-9999.0d0
|
||||
ACamaxcurvature(i)=-9999.0d0
|
||||
ACamaxcurvpco2a(i)=-9999.0d0
|
||||
endif
|
||||
if(Amax_ACi(i).lt.50.0d0)amaxave=Amax_ACi(i)
|
||||
j=min0(5,nACiPoints(i))
|
||||
call y_aPLUSbx(j,ACipco2i(1:j,i:i),ACianet_obs(1:j,i:i),ac,at)
|
||||
@@ -1268,7 +1280,7 @@
|
||||
endif
|
||||
enddo
|
||||
idotempcoeff=0
|
||||
if((term2-term1).gt.2.0d0)idotempcoeff=1
|
||||
if((term2-term1).gt.5.0d0)idotempcoeff=1
|
||||
!If temperature variation in the dataset is larger enough, try to estimate parameters in temperature response functions
|
||||
!All variables are now in the right order. All ACi curves are ordered and All ALight curves are ordered.
|
||||
!-------------------------------------------------------------------------------------------------------
|
||||
@@ -1283,7 +1295,7 @@
|
||||
pco2c_pco2i_flu(i)=-9999.0d0
|
||||
enddo
|
||||
if(ntotphips2.gt.5)then
|
||||
do idorch=1,1
|
||||
do idorch=0,0
|
||||
!we do a fluorescence only fit
|
||||
Prioriknowlimit=-1
|
||||
ifitmode=1
|
||||
@@ -1291,7 +1303,7 @@
|
||||
!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i
|
||||
!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i
|
||||
!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet
|
||||
idorwp=1
|
||||
idorwp=0
|
||||
resistwp25_ori=resistwp25_ini
|
||||
if(idorch.eq.1)then
|
||||
resistch25_ori=resistch25_ini
|
||||
@@ -1638,11 +1650,12 @@
|
||||
co2imany(3)=3.0d0
|
||||
co2imany(4)=4.0d0
|
||||
co2imany(5)=5.0d0
|
||||
m=5
|
||||
co2imany(6)=6.0d0
|
||||
m=6
|
||||
term=ACipco2i(nACiPoints(i),i)+10.0d0
|
||||
do ccc=6.0d0,term,2.5d0
|
||||
do while (co2imany(m).le.term)
|
||||
m=m+1
|
||||
co2imany(m)=ccc
|
||||
co2imany(m)=co2imany(m-1)+2.5d0
|
||||
enddo
|
||||
do j=1,m
|
||||
ccc=co2imany(j)
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user