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
|
||||||
@@ -17,7 +17,6 @@ CU USES covsrt,gaussj
|
|||||||
ia(j)=1
|
ia(j)=1
|
||||||
if(ia(j).ne.0) mfit=mfit+1
|
if(ia(j).ne.0) mfit=mfit+1
|
||||||
11 continue
|
11 continue
|
||||||
if(mfit.eq.0) pause 'lfit: no parameters to be fitted'
|
|
||||||
do 13 j=1,mfit
|
do 13 j=1,mfit
|
||||||
do 12 k=1,mfit
|
do 12 k=1,mfit
|
||||||
covar(j,k)=0.0d0
|
covar(j,k)=0.0d0
|
||||||
|
|||||||
@@ -285,29 +285,29 @@ 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
|
implicit none
|
||||||
INTEGER m,mp,n,np,NMAX
|
INTEGER m,mp,n,np,NMAX,ierr
|
||||||
double precision a(mp,np),v(np,np),w(np)
|
double precision a(mp,np),v(np,np),w(np)
|
||||||
PARAMETER (NMAX=1500)
|
PARAMETER (NMAX=1500)
|
||||||
CU USES pythag
|
CU USES pythag
|
||||||
INTEGER i,its,j,jj,k,l,nm
|
INTEGER i,its,j,jj,k,l,nm
|
||||||
INTEGER i,its,j,jj,k,l,nm
|
double precision anorm,c,f,g,h,s,scaling,x,y,z,
|
||||||
& rv1(NMAX),pythag
|
& rv1(NMAX),pythag
|
||||||
g=0.0d0
|
g=0.0d0
|
||||||
g=0.0d0
|
scaling=0.0d0
|
||||||
anorm=0.0d0
|
anorm=0.0d0
|
||||||
do 25 i=1,n
|
do 25 i=1,n
|
||||||
l=i+1
|
l=i+1
|
||||||
l=i+1
|
rv1(i)=scaling*g
|
||||||
g=0.0d0
|
g=0.0d0
|
||||||
s=0.0d0
|
s=0.0d0
|
||||||
s=0.0d0
|
scaling=0.0d0
|
||||||
if(i.le.m)then
|
if(i.le.m)then
|
||||||
do 11 k=i,m
|
do 11 k=i,m
|
||||||
do 11 k=i,m
|
scaling=scaling+dabs(a(k,i))
|
||||||
11 continue
|
11 continue
|
||||||
11 continue
|
if(scaling.ne.0.0d0)then
|
||||||
do 12 k=i,m
|
do 12 k=i,m
|
||||||
do 12 k=i,m
|
a(k,i)=a(k,i)/scaling
|
||||||
s=s+a(k,i)*a(k,i)
|
s=s+a(k,i)*a(k,i)
|
||||||
12 continue
|
12 continue
|
||||||
f=a(i,i)
|
f=a(i,i)
|
||||||
@@ -325,21 +325,21 @@ CU USES pythag
|
|||||||
14 continue
|
14 continue
|
||||||
15 continue
|
15 continue
|
||||||
do 16 k=i,m
|
do 16 k=i,m
|
||||||
do 16 k=i,m
|
a(k,i)=scaling*a(k,i)
|
||||||
16 continue
|
16 continue
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
endif
|
w(i)=scaling*g
|
||||||
g=0.0d0
|
g=0.0d0
|
||||||
s=0.0d0
|
s=0.0d0
|
||||||
s=0.0d0
|
scaling=0.0d0
|
||||||
if((i.le.m).and.(i.ne.n))then
|
if((i.le.m).and.(i.ne.n))then
|
||||||
do 17 k=l,n
|
do 17 k=l,n
|
||||||
do 17 k=l,n
|
scaling=scaling+dabs(a(i,k))
|
||||||
17 continue
|
17 continue
|
||||||
17 continue
|
if(scaling.ne.0.0d0)then
|
||||||
do 18 k=l,n
|
do 18 k=l,n
|
||||||
do 18 k=l,n
|
a(i,k)=a(i,k)/scaling
|
||||||
s=s+a(i,k)*a(i,k)
|
s=s+a(i,k)*a(i,k)
|
||||||
18 continue
|
18 continue
|
||||||
f=a(i,l)
|
f=a(i,l)
|
||||||
@@ -359,7 +359,7 @@ CU USES pythag
|
|||||||
22 continue
|
22 continue
|
||||||
23 continue
|
23 continue
|
||||||
do 24 k=l,n
|
do 24 k=l,n
|
||||||
do 24 k=l,n
|
a(i,k)=scaling*a(i,k)
|
||||||
24 continue
|
24 continue
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
@@ -708,20 +708,20 @@ CU USES lubksb
|
|||||||
DOUBLE PRECISION a(np,np),c(n),d(n)
|
DOUBLE PRECISION a(np,np),c(n),d(n)
|
||||||
LOGICAL sing
|
LOGICAL sing
|
||||||
INTEGER i,j,k
|
INTEGER i,j,k
|
||||||
INTEGER i,j,k
|
DOUBLE PRECISION scaling,sigma,sum,tau
|
||||||
sing=.false.
|
sing=.false.
|
||||||
do 17 k=1,n-1
|
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
|
||||||
do 11 i=k,n
|
scaling=dmax1(scaling,dabs(a(i,k)))
|
||||||
11 continue
|
11 continue
|
||||||
11 continue
|
if(scaling.eq.0.0d0)then
|
||||||
sing=.true.
|
sing=.true.
|
||||||
c(k)=0.0d0
|
c(k)=0.0d0
|
||||||
d(k)=0.0d0
|
d(k)=0.0d0
|
||||||
else
|
else
|
||||||
do 12 i=k,n
|
do 12 i=k,n
|
||||||
do 12 i=k,n
|
a(i,k)=a(i,k)/scaling
|
||||||
12 continue
|
12 continue
|
||||||
sum=0.0d0
|
sum=0.0d0
|
||||||
do 13 i=k,n
|
do 13 i=k,n
|
||||||
@@ -730,7 +730,7 @@ CU USES lubksb
|
|||||||
sigma=dsign(dsqrt(sum),a(k,k))
|
sigma=dsign(dsqrt(sum),a(k,k))
|
||||||
a(k,k)=a(k,k)+sigma
|
a(k,k)=a(k,k)+sigma
|
||||||
c(k)=sigma*a(k,k)
|
c(k)=sigma*a(k,k)
|
||||||
c(k)=sigma*a(k,k)
|
d(k)=-scaling*sigma
|
||||||
do 16 j=k+1,n
|
do 16 j=k+1,n
|
||||||
sum=0.0d0
|
sum=0.0d0
|
||||||
do 14 i=k,n
|
do 14 i=k,n
|
||||||
|
|||||||
@@ -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,
|
call cplnsrch(nunknowns,xpold,fsqsumold,
|
||||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||||
& check,funcnleq1,fequ)
|
& 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
|
do i=1,nunknowns
|
||||||
call reinitialization(x0min(i),xpold(i),
|
call reinitialization(x0min(i),xpold(i),
|
||||||
& x0max(i),xp(i),6678)
|
& 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,
|
call lnsrch(nunknowns,xpold,fsqsumold,
|
||||||
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
& gfuncsum,deltax,xp,fsqsumnew,stpmax,
|
||||||
& check,funcnleq1,fequ)
|
& 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
|
do i=1,nunknowns
|
||||||
call reinitialization(x0min(i),xpold(i),
|
call reinitialization(x0min(i),xpold(i),
|
||||||
& x0max(i),xp(i),6678)
|
& 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,
|
subroutine nonsyssolver(funcnleq1,fmin_funcnleq1,
|
||||||
& f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
&f1dim_funcnleq1,DNQFJ_funcnleq1,x0min,x0ori,xp,x0max,fp,
|
||||||
& nunknowns,iwhichsolver)
|
&nunknowns,iwhichsolver)
|
||||||
implicit none
|
implicit none
|
||||||
integer nunknowns,iwhichsolver
|
integer nunknowns,iwhichsolver
|
||||||
double precision x0min(nunknowns),x0ori(nunknowns),
|
double precision x0min(nunknowns),x0ori(nunknowns),
|
||||||
@@ -27,30 +27,48 @@
|
|||||||
! =4 solved by fixed point method 4
|
! =4 solved by fixed point method 4
|
||||||
! =6 solved by broydn
|
! =6 solved by broydn
|
||||||
! =7 Solved by multiobjective minimization.
|
! =7 Solved by multiobjective minimization.
|
||||||
|
! =8 Solved by DNQSOL
|
||||||
! =-9999 Best approximation returned. Solution may not be accurate.
|
! =-9999 Best approximation returned. Solution may not be accurate.
|
||||||
! --------- Local variables ---------------------------------------
|
! --------- Local variables ---------------------------------------
|
||||||
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,
|
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,ran2,
|
||||||
& sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,
|
&sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,f1dim_funcnleq1,
|
||||||
& f1dim_funcnleq1
|
&D1MACH,Warray(3+(15*nunknowns+3*nunknowns*nunknowns)/2+1)
|
||||||
integer i,irepeat,maxrepeats,IERR,notfound
|
integer i,irepeat,maxrepeats,IERR,notfound,IOPT(5),IDIMW
|
||||||
intrinsic dble
|
intrinsic dble
|
||||||
parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-7)
|
parameter(maxrepeats=100,notfound=-9999)
|
||||||
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1
|
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1,
|
||||||
|
&DNQFJ_funcnleq1
|
||||||
!-------------------------------------------------------------------
|
!-------------------------------------------------------------------
|
||||||
stpmax=0.0d0
|
|
||||||
sum=0.0d0
|
|
||||||
do i=1, nunknowns
|
do i=1, nunknowns
|
||||||
x0(i)=x0ori(i)
|
xp(i)=x0ori(i)
|
||||||
sum=sum+x0ori(i)*x0ori(i)
|
|
||||||
stpmax=stpmax+
|
|
||||||
& (x0min(i)-x0max(i))*(x0min(i)-x0max(i))
|
|
||||||
enddo
|
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
|
iwhichsolver=notfound
|
||||||
|
TOLF=dsqrt(D1MACH(4))
|
||||||
do irepeat=1,maxrepeats
|
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,
|
call fixedpoint(funcnleq1,x0min,x0,xp,
|
||||||
& x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
|
& x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
|
||||||
if(iwhichsolver.ne.notfound)return
|
if(iwhichsolver.ne.notfound)return
|
||||||
@@ -82,6 +100,11 @@
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
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
|
fsqsum=0.0d0
|
||||||
do i=1,nunknowns
|
do i=1,nunknowns
|
||||||
fsqsum=fsqsum+fp(i)*fp(i)
|
fsqsum=fsqsum+fp(i)*fp(i)
|
||||||
@@ -89,11 +112,11 @@
|
|||||||
tp=fsqsum
|
tp=fsqsum
|
||||||
call nongradopt(nunknowns,fmin_funcnleq1,
|
call nongradopt(nunknowns,fmin_funcnleq1,
|
||||||
& f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
|
& f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
|
||||||
! if(dabs(tp-fsqsum).gt.TOLF)then
|
if(dabs(tp-fsqsum).gt.TOLF)then
|
||||||
! call RepeatCompassSearch(nunknowns,xp,fsqsum,
|
call RepeatCompassSearch(nunknowns,xp,fsqsum,
|
||||||
! & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
& x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
|
||||||
! & TOLF)
|
& TOLF)
|
||||||
! endif
|
endif
|
||||||
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
call funcnleq1(nunknowns,xp,fp,fsqsum)
|
||||||
tp=dabs(fp(1))
|
tp=dabs(fp(1))
|
||||||
do i=2,nunknowns
|
do i=2,nunknowns
|
||||||
@@ -109,7 +132,7 @@
|
|||||||
enddo
|
enddo
|
||||||
if(IERR.eq.0)return
|
if(IERR.eq.0)return
|
||||||
do i=1,nunknowns
|
do i=1,nunknowns
|
||||||
x0(i)=xp(i)
|
xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
end subroutine nonsyssolver
|
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
|
implicit none
|
||||||
integer ndim
|
integer ndim
|
||||||
double precision xbest(1:ndim),fbest,
|
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)
|
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
|
||||||
integer i,n
|
integer i,n
|
||||||
logical resetran2
|
logical resetran2
|
||||||
@@ -62,7 +62,7 @@
|
|||||||
! =1 convergence criterion reached (minimum found)
|
! =1 convergence criterion reached (minimum found)
|
||||||
!
|
!
|
||||||
integer ndim
|
integer ndim
|
||||||
double precision xbest(1:ndim),fbest,
|
double precision xbest(1:ndim),fbest,f1dim,
|
||||||
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
|
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
|
||||||
external funkmin,f1dim
|
external funkmin,f1dim
|
||||||
!------------------------------- Locals -----------------------------------------------------------
|
!------------------------------- Locals -----------------------------------------------------------
|
||||||
@@ -71,10 +71,10 @@
|
|||||||
& xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink,
|
& xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink,
|
||||||
& direction(ndim),dmax,fcent0,ran2_reset,ran2
|
& direction(ndim),dmax,fcent0,ran2_reset,ran2
|
||||||
integer i,j,k,iter
|
integer i,j,k,iter
|
||||||
parameter(shrink=0.618d0)
|
parameter(shrink=0.95d0)
|
||||||
!
|
!
|
||||||
diftol=xtol
|
diftol=xtol
|
||||||
delta=0.618d0
|
delta=0.95d0
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
xcent(i)=xbest(i)
|
xcent(i)=xbest(i)
|
||||||
enddo
|
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),
|
&beta_in_out(ndim0),betamin0(ndim0),betamax0(ndim0),
|
||||||
&shorty0(npoints,ny),shortx0(npoints,nx),fatbeta
|
&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),
|
double precision xtol,beta(ndim0+nx*npoints),
|
||||||
&betacp(ndim0+nx*npoints),fatbetacp,beta0(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)
|
parameter(xtol=1.0d-7,ftol=1.0d-7)
|
||||||
external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia
|
external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia
|
||||||
!-----------------------------------------------------
|
!-----------------------------------------------------
|
||||||
@@ -97,26 +98,124 @@ c (default is 0)
|
|||||||
10 call funkmin_generic(ndim,beta,fatbeta)
|
10 call funkmin_generic(ndim,beta,fatbeta)
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta0(i)=beta(i)
|
beta0(i)=beta(i)
|
||||||
|
history(1,i)=beta(i)
|
||||||
enddo
|
enddo
|
||||||
fatbeta0=fatbeta
|
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
|
j=0
|
||||||
k=0
|
k=0
|
||||||
ftol_relax=ftol*100.0d0
|
n=1
|
||||||
30 call nongradopt(ndim,funkmin_generic,
|
nave=1
|
||||||
&f1dim_generic,beta,betamin,betamax,ftol_relax,fatbeta)
|
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)
|
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
|
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)
|
beta(i)=beta0(i)
|
||||||
enddo
|
enddo
|
||||||
fatbeta=fatbeta0
|
fatbeta=fatbeta0
|
||||||
else
|
else
|
||||||
if((fatbeta0-fatbeta).lt.ftol_relax)then
|
!success
|
||||||
!increment the counter for arriving at the same minimum
|
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
|
k=k+1
|
||||||
else
|
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
|
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
|
endif
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta0(i)=beta(i)
|
beta0(i)=beta(i)
|
||||||
@@ -124,54 +223,125 @@ c (default is 0)
|
|||||||
fatbeta0=fatbeta
|
fatbeta0=fatbeta
|
||||||
endif
|
endif
|
||||||
j=j+1
|
j=j+1
|
||||||
!try different initial guesses
|
if(j.lt.20.and.k.lt.2)then
|
||||||
if(j.lt.100.and.k.lt.5)then
|
if(j.lt.10)then
|
||||||
if(ran2().gt.0.3d0)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
|
do i=1,ndim
|
||||||
if(ran2().gt.0.5d0)then
|
lower=history(1,i)-term1*(history(1,i)-betamin(i))
|
||||||
beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))*
|
upper=history(1,i)+term1*(betamax(i)-history(1,i))
|
||||||
&(betamax(i)-beta(i))
|
beta(i)=lower+ran2()*(upper-lower)
|
||||||
else
|
enddo
|
||||||
beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))*
|
icompete=1
|
||||||
&(beta(i)-betamin(i))
|
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
|
endif
|
||||||
enddo
|
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
|
else
|
||||||
|
!completely random guess
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
|
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
|
||||||
enddo
|
enddo
|
||||||
|
icompete=0
|
||||||
endif
|
endif
|
||||||
call funkmin_generic(ndim,beta,fatbeta)
|
70 call funkmin_generic(ndim,beta,fatbeta)
|
||||||
goto 30
|
goto 30
|
||||||
else
|
else
|
||||||
if((ftol_relax-ftol).gt.ftol)then
|
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
|
ftol_relax=ftol
|
||||||
goto 30
|
goto 30
|
||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
goto 110
|
||||||
|
|
||||||
call RepeatCompassSearch(ndim,beta,fatbeta,
|
call RepeatCompassSearch(ndim,beta,fatbeta,
|
||||||
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
|
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
|
||||||
call funkmin_generic(ndim,beta,fatbeta)
|
call funkmin_generic(ndim,beta,fatbeta)
|
||||||
k=0
|
if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then
|
||||||
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 RepeatCompassSearch cannot improve, we end the search
|
!if RepeatCompassSearch cannot improve, we end the search
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta(i)=beta0(i)
|
beta(i)=beta0(i)
|
||||||
enddo
|
enddo
|
||||||
fatbeta=fatbeta0
|
fatbeta=fatbeta0
|
||||||
goto 110
|
goto 110
|
||||||
else
|
|
||||||
if((fatbeta0-fatbeta).lt.ftol)goto 40
|
|
||||||
endif
|
endif
|
||||||
do i=1,12
|
do i=1,12
|
||||||
gacontrol(i)=-1.0d0
|
gacontrol(i)=-1.0d0
|
||||||
@@ -182,65 +352,40 @@ c (default is 0)
|
|||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
|
beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
|
||||||
enddo
|
enddo
|
||||||
idobounded=0
|
fatbeta0=fatbeta
|
||||||
call pikaia(generic_pikaia,ndim,gacontrol,beta0,fatbeta0,j)
|
call pikaia(generic_pikaia,ndim,gacontrol,beta0,fatbeta0,j)
|
||||||
fatbeta0=1.0d+100
|
fatbeta0=1.0d+100
|
||||||
if(j.eq.0)then
|
if(j.eq.0)then
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta0(i)=betamin(i)+beta0(i)*(betamax(i)-betamin(i))
|
beta0(i)=betamin(i)+beta0(i)*(betamax(i)-betamin(i))
|
||||||
enddo
|
enddo
|
||||||
idobounded=1
|
|
||||||
call funkmin_generic(ndim,beta0,fatbeta0)
|
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
|
endif
|
||||||
|
80 if(isitnaninf(fatbeta0).eq.1.or.fatbeta0.gt.fatbeta)then
|
||||||
40 if(fatbeta0.gt.fatbeta)then
|
|
||||||
fatbeta0=fatbeta
|
fatbeta0=fatbeta
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta0(i)=beta(i)
|
beta0(i)=beta(i)
|
||||||
enddo
|
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
|
else
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta(i)=beta0(i)
|
beta(i)=beta0(i)
|
||||||
enddo
|
enddo
|
||||||
fatbeta=fatbeta0
|
fatbeta=fatbeta0
|
||||||
endif
|
endif
|
||||||
do i=1,ndim
|
!
|
||||||
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
|
INFO=iregrestype
|
||||||
do j=1,ndim
|
call odr_leastsquare(ndim,FCN_generic,beta,nobs,
|
||||||
beta(j)=beta0(j)
|
&xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
|
||||||
enddo
|
&nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
|
||||||
fatbeta=fatbeta0
|
&iderivative,shortx(1:nobs,1:nxvars),
|
||||||
endif
|
&shorty(1:nobs,1:nyvars),fatbeta,INFO)
|
||||||
enddo
|
call funkmin_generic(ndim,beta,fatbeta)
|
||||||
fatbeta0=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
|
iregrestype=iregrestype0
|
||||||
if(iregrestype.eq.2)then
|
if(iregrestype.eq.2)then
|
||||||
do i=1,npoints
|
do i=1,npoints
|
||||||
@@ -266,13 +411,7 @@ c (default is 0)
|
|||||||
call nongradopt(ndim,funkmin_generic,
|
call nongradopt(ndim,funkmin_generic,
|
||||||
&f1dim_generic,beta,betamin,betamax,ftol,fatbeta)
|
&f1dim_generic,beta,betamin,betamax,ftol,fatbeta)
|
||||||
call funkmin_generic(ndim,beta,fatbeta)
|
call funkmin_generic(ndim,beta,fatbeta)
|
||||||
k=0
|
if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then
|
||||||
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
|
|
||||||
fatbeta=fatbeta0
|
fatbeta=fatbeta0
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta(i)=beta0(i)
|
beta(i)=beta0(i)
|
||||||
@@ -286,19 +425,13 @@ c (default is 0)
|
|||||||
call RepeatCompassSearch(ndim,betacp,fatbetacp,
|
call RepeatCompassSearch(ndim,betacp,fatbetacp,
|
||||||
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
|
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
|
||||||
call funkmin_generic(ndim,betacp,fatbetacp)
|
call funkmin_generic(ndim,betacp,fatbetacp)
|
||||||
k=0
|
if(isitnaninf(fatbetacp).eq.1.or.fatbetacp.ge.fatbeta)then
|
||||||
if((fatbetacp+1.0d0).eq.fatbetacp)k=1
|
goto 110
|
||||||
do i=1,ndim
|
else
|
||||||
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
|
|
||||||
fatbeta=fatbetacp
|
fatbeta=fatbetacp
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta(i)=betacp(i)
|
beta(i)=betacp(i)
|
||||||
enddo
|
enddo
|
||||||
else
|
|
||||||
goto 110
|
|
||||||
endif
|
endif
|
||||||
if(j.ge.2.or.fatbeta.eq.fatbeta0)goto 110
|
if(j.ge.2.or.fatbeta.eq.fatbeta0)goto 110
|
||||||
if(dabs(fatbeta0-fatbeta).gt.ftol)then
|
if(dabs(fatbeta0-fatbeta).gt.ftol)then
|
||||||
@@ -310,7 +443,7 @@ c (default is 0)
|
|||||||
call linmin(beta,betamin,betamax,betacp,ndim,
|
call linmin(beta,betamin,betamax,betacp,ndim,
|
||||||
&f1dim_generic,fatbeta)
|
&f1dim_generic,fatbeta)
|
||||||
call funkmin_generic(ndim,beta,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
|
fatbeta=fatbeta0
|
||||||
do i=1,ndim
|
do i=1,ndim
|
||||||
beta(i)=beta0(i)
|
beta(i)=beta0(i)
|
||||||
|
|||||||
@@ -3,7 +3,7 @@
|
|||||||
implicit none
|
implicit none
|
||||||
integer ndim
|
integer ndim
|
||||||
double precision xbest(1:ndim),fbest,
|
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)
|
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
|
||||||
parameter(ftol=1.0d-7)
|
parameter(ftol=1.0d-7)
|
||||||
integer i,n
|
integer i,n
|
||||||
@@ -62,7 +62,7 @@
|
|||||||
! =1 convergence criterion reached (minimum found)
|
! =1 convergence criterion reached (minimum found)
|
||||||
!
|
!
|
||||||
integer ndim
|
integer ndim
|
||||||
double precision xbest(1:ndim),fbest,
|
double precision xbest(1:ndim),fbest,f1dim,
|
||||||
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
|
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
|
||||||
external funkmin,f1dim
|
external funkmin,f1dim
|
||||||
!------------------------------- Locals -----------------------------------------------------------
|
!------------------------------- Locals -----------------------------------------------------------
|
||||||
|
|||||||
@@ -7,7 +7,7 @@
|
|||||||
!
|
!
|
||||||
integer ndim
|
integer ndim
|
||||||
double precision beta(1:ndim),bmin(1:ndim),
|
double precision beta(1:ndim),bmin(1:ndim),
|
||||||
& bmax(1:ndim),ftol,fatbeta
|
&bmax(1:ndim),ftol,fatbeta,f1dim
|
||||||
!
|
!
|
||||||
! ------------------ Inputs -----------------------------
|
! ------------------ Inputs -----------------------------
|
||||||
! ndim: the total number of parameters to be estimated
|
! ndim: the total number of parameters to be estimated
|
||||||
|
|||||||
@@ -4,7 +4,7 @@
|
|||||||
implicit none
|
implicit none
|
||||||
INTEGER iter,n,np,NMAX,ITMAX
|
INTEGER iter,n,np,NMAX,ITMAX
|
||||||
double precision fret,ftol,p(np),xi(np,np),TINY,
|
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)
|
PARAMETER (NMAX=1000,TINY=1.0d-25)
|
||||||
CU USES funkmin,linmin
|
CU USES funkmin,linmin
|
||||||
INTEGER i,ibig,j
|
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)
|
SUBROUTINE cplinmin(p,pmin,pmax,xi,n,f1dim,fret)
|
||||||
implicit none
|
implicit none
|
||||||
INTEGER n
|
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)
|
PARAMETER (TOL=1.0d-8)
|
||||||
CU USES brent,f1dim,mnbrak
|
CU USES brent,f1dim,mnbrak
|
||||||
INTEGER j,k,ierr
|
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
|
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(1) = m*n
|
||||||
isave(2) = m**2
|
isave(2) = m**2
|
||||||
isave(3) = 4*m**2
|
isave(3) = 4*m**2
|
||||||
@@ -442,7 +442,7 @@ c ************
|
|||||||
double precision one,zero
|
double precision one,zero
|
||||||
parameter (one=1.0d0,zero=0.0d0)
|
parameter (one=1.0d0,zero=0.0d0)
|
||||||
|
|
||||||
if (task .eq. 'START') then
|
if (task .eqv. 'START') then
|
||||||
|
|
||||||
call timer(time1)
|
call timer(time1)
|
||||||
|
|
||||||
@@ -508,7 +508,7 @@ c open a summary file 'iterate.dat'
|
|||||||
c Check the input arguments for errors.
|
c Check the input arguments for errors.
|
||||||
|
|
||||||
call errclb(n,m,factr,l,u,nbd,task,info,k)
|
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,
|
call prn3lb(n,x,f,task,iprint,info,itfile,
|
||||||
+ iter,nfgv,nintol,nskip,nact,sbgnrm,
|
+ iter,nfgv,nintol,nskip,nact,sbgnrm,
|
||||||
+ zero,nint,word,iback,stp,xstep,k,
|
+ 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 After returning from the driver go to the point where execution
|
||||||
c is to resume.
|
c is to resume.
|
||||||
|
|
||||||
if (task(1:5) .eq. 'FG_LN') goto 666
|
if (task(1:5) .eqv. 'FG_LN') goto 666
|
||||||
if (task(1:5) .eq. 'NEW_X') goto 777
|
if (task(1:5) .eqv. 'NEW_X') goto 777
|
||||||
if (task(1:5) .eq. 'FG_ST') goto 111
|
if (task(1:5) .eqv. 'FG_ST') goto 111
|
||||||
if (task(1:4) .eq. 'STOP') then
|
if (task(1:4) .eqv. 'STOP') then
|
||||||
if (task(7:9) .eq. 'CPU') then
|
if (task(7:9) .eqv. 'CPU') then
|
||||||
c restore the previous iterate.
|
c restore the previous iterate.
|
||||||
call dcopy(n,t,1,x,1)
|
call dcopy(n,t,1,x,1)
|
||||||
call dcopy(n,r,1,g,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
|
lnscht = lnscht + cpu2 - cpu1
|
||||||
goto 222
|
goto 222
|
||||||
endif
|
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.
|
c return to the driver for calculating f and g; reenter at 666.
|
||||||
goto 1000
|
goto 1000
|
||||||
else
|
else
|
||||||
@@ -2444,7 +2444,7 @@ c **********
|
|||||||
double precision ftol,gtol,xtol
|
double precision ftol,gtol,xtol
|
||||||
parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0)
|
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)
|
dtd = ddot(n,d,1,d,1)
|
||||||
dnorm = sqrt(dtd)
|
dnorm = sqrt(dtd)
|
||||||
@@ -2789,7 +2789,7 @@ c ************
|
|||||||
|
|
||||||
integer i
|
integer i
|
||||||
|
|
||||||
if (task(1:5) .eq. 'ERROR') goto 999
|
if (task(1:5) .eqv. 'ERROR') goto 999
|
||||||
|
|
||||||
if (iprint .ge. 0) then
|
if (iprint .ge. 0) then
|
||||||
write (6,3003)
|
write (6,3003)
|
||||||
@@ -3271,7 +3271,7 @@ c
|
|||||||
c task = 'START'
|
c task = 'START'
|
||||||
c 10 continue
|
c 10 continue
|
||||||
c call dcsrch( ... )
|
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 Evaluate the function and the gradient at stp
|
||||||
c goto 10
|
c goto 10
|
||||||
c end if
|
c end if
|
||||||
@@ -3377,7 +3377,7 @@ c **********
|
|||||||
|
|
||||||
c Initialization block.
|
c Initialization block.
|
||||||
|
|
||||||
if (task(1:5) .eq. 'START') then
|
if (task(1:5) .eqv. 'START') then
|
||||||
|
|
||||||
c Check the input arguments for errors.
|
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.
|
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.
|
c Initialize local variables.
|
||||||
|
|
||||||
@@ -3479,7 +3479,7 @@ c Test for convergence.
|
|||||||
|
|
||||||
c Test for termination.
|
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 A modified function is used to predict the step during the
|
||||||
c first stage if a lower function value has been obtained but
|
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
|
integer ndim
|
||||||
double precision beta(1:ndim),bmin(1:ndim),
|
double precision beta(1:ndim),bmin(1:ndim),
|
||||||
& bmax(1:ndim),ftol,fatbeta
|
&bmax(1:ndim),ftol,fatbeta,f1dim
|
||||||
!
|
!
|
||||||
! ------------------ Inputs -----------------------------
|
! ------------------ Inputs -----------------------------
|
||||||
! ndim: the total number of parameters to be estimated
|
! ndim: the total number of parameters to be estimated
|
||||||
@@ -24,7 +24,7 @@
|
|||||||
|
|
||||||
integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
|
integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
|
||||||
& icycle
|
& icycle
|
||||||
parameter(maxredo=10,ITMAX=10000)
|
parameter(maxredo=5,ITMAX=50000)
|
||||||
double precision fbest,xbest(1:ndim),term,
|
double precision fbest,xbest(1:ndim),term,
|
||||||
& xinidir(1:ndim,1:ndim),xbest0(1:ndim),
|
& xinidir(1:ndim,1:ndim),xbest0(1:ndim),
|
||||||
& pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1)
|
& pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1)
|
||||||
@@ -50,7 +50,7 @@
|
|||||||
fatbeta=fbest
|
fatbeta=fbest
|
||||||
goto 10
|
goto 10
|
||||||
endif
|
endif
|
||||||
if((fbest-fatbeta).gt.ftol)then
|
if((fbest-fatbeta).gt.100.0d0*ftol)then
|
||||||
if(iredo.gt.maxredo)goto 10
|
if(iredo.gt.maxredo)goto 10
|
||||||
iredo=iredo+1
|
iredo=iredo+1
|
||||||
goto 3
|
goto 3
|
||||||
@@ -92,6 +92,9 @@
|
|||||||
if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then
|
if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then
|
||||||
term=term/3.0d0
|
term=term/3.0d0
|
||||||
fbest=fatbeta
|
fbest=fatbeta
|
||||||
|
do n=1,ndim
|
||||||
|
xbest(n)=beta(n)
|
||||||
|
enddo
|
||||||
goto 30
|
goto 30
|
||||||
endif
|
endif
|
||||||
do n=1,ndim
|
do n=1,ndim
|
||||||
@@ -144,7 +147,7 @@
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
if((fbest-fatbeta).gt.ftol)then
|
if((fbest-fatbeta).gt.ftol*100.0d0)then
|
||||||
if(iredo.gt.maxredo)then
|
if(iredo.gt.maxredo)then
|
||||||
if(icycle.lt.maxredo)then
|
if(icycle.lt.maxredo)then
|
||||||
icycle=icycle+1
|
icycle=icycle+1
|
||||||
@@ -167,15 +170,15 @@
|
|||||||
external funkmin
|
external funkmin
|
||||||
CU USES guamotry,funkmin
|
CU USES guamotry,funkmin
|
||||||
INTEGER i,ihi,ilo,inhi,j,m,n
|
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
|
& guamotry,degen
|
||||||
iter=0
|
iter=0
|
||||||
1 do 12 n=1,ndim
|
1 do 12 n=1,ndim
|
||||||
sum=0.0d0
|
cumx=0.0d0
|
||||||
do 11 m=1,ndim+1
|
do 11 m=1,ndim+1
|
||||||
sum=sum+p(m,n)
|
cumx=cumx+p(m,n)
|
||||||
11 continue
|
11 continue
|
||||||
psum(n)=sum
|
pcumx(n)=cumx
|
||||||
12 continue
|
12 continue
|
||||||
2 ilo=1
|
2 ilo=1
|
||||||
if (y(1).gt.y(2)) then
|
if (y(1).gt.y(2)) then
|
||||||
@@ -232,20 +235,20 @@ CU USES guamotry,funkmin
|
|||||||
endif
|
endif
|
||||||
if(iter.ge.ITMAX)return
|
if(iter.ge.ITMAX)return
|
||||||
iter=iter+2
|
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
|
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
|
else if (ytry.ge.y(inhi)) then
|
||||||
ysave=y(ihi)
|
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
|
if (ytry.ge.ysave) then
|
||||||
do 16 i=1,ndim+1
|
do 16 i=1,ndim+1
|
||||||
if(i.ne.ilo)then
|
if(i.ne.ilo)then
|
||||||
do 15 j=1,ndim
|
do 15 j=1,ndim
|
||||||
psum(j)=0.5d0*(p(i,j)+p(ilo,j))
|
pcumx(j)=0.5d0*(p(i,j)+p(ilo,j))
|
||||||
p(i,j)=psum(j)
|
p(i,j)=pcumx(j)
|
||||||
15 continue
|
15 continue
|
||||||
call funkmin(ndim,psum,y(i))
|
call funkmin(ndim,pcumx,y(i))
|
||||||
endif
|
endif
|
||||||
16 continue
|
16 continue
|
||||||
iter=iter+ndim
|
iter=iter+ndim
|
||||||
|
|||||||
@@ -24,7 +24,6 @@ C VARIABLE DECLARATIONS
|
|||||||
double precision weity(N,NQ),weitx(N,M),shorty(N,NQ),
|
double precision weity(N,NQ),weitx(N,M),shorty(N,NQ),
|
||||||
&shortx(N,M),fvalue,BETA(NP),X(N,M),Y(N,NQ)
|
&shortx(N,M),fvalue,BETA(NP),X(N,M),Y(N,NQ)
|
||||||
EXTERNAL FCN
|
EXTERNAL FCN
|
||||||
|
|
||||||
LWORK=18+11*NP+NP**2+M+M**2+4*N*NQ+6*N*M+2*N*NQ*NP+
|
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
|
&2*N*NQ*M+NQ**2+5*NQ+NQ*(NP+M)+N*1*NQ
|
||||||
LIWORK=20+NP+NQ*(NP+M)
|
LIWORK=20+NP+NQ*(NP+M)
|
||||||
@@ -96,7 +95,7 @@ C VARIABLE DECLARATIONS
|
|||||||
+ WORK(LWORK),X(N,M),Y(N,NQ)
|
+ WORK(LWORK),X(N,M),Y(N,NQ)
|
||||||
!------------For using information in WORK----------------------------
|
!------------For using information in WORK----------------------------
|
||||||
LOGICAL
|
LOGICAL
|
||||||
+ ISODR
|
+ISODR
|
||||||
INTEGER
|
INTEGER
|
||||||
+ DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
|
+ DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
|
||||||
+ RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
|
+ RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
|
||||||
@@ -105,7 +104,7 @@ C VARIABLE DECLARATIONS
|
|||||||
+ BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
|
+ BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
|
||||||
+ FSI,FJACBI,WE1I,DIFFI,
|
+ FSI,FJACBI,WE1I,DIFFI,
|
||||||
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
||||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||||
+ LWKMN
|
+ LWKMN
|
||||||
c
|
c
|
||||||
integer i1,i2,i3,i4,i5,iderivative
|
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,
|
+ BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
|
||||||
+ FSI,FJACBI,WE1I,DIFFI,
|
+ FSI,FJACBI,WE1I,DIFFI,
|
||||||
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
||||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||||
+ LWKMN)
|
+ LWKMN)
|
||||||
fvalue=0.0d0
|
fvalue=0.0d0
|
||||||
do I=1,N
|
do I=1,N
|
||||||
|
|||||||
@@ -209,20 +209,20 @@ c TD = I1MACH(14)
|
|||||||
c DMPREC = B ** (1-TD)
|
c DMPREC = B ** (1-TD)
|
||||||
|
|
||||||
call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp,
|
call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp,
|
||||||
*minexp,
maxexp,eps,epsneg,xmin,xmax)
|
*minexp,maxexp,eps,epsneg,xmin,xmax)
|
||||||
DMPREC=eps
|
DMPREC=eps
|
||||||
RETURN
|
RETURN
|
||||||
|
|
||||||
END
|
END
|
||||||
|
|
||||||
SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep,
|
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
|
implicit none
|
||||||
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
|
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
|
||||||
double precision eps,epsneg,xmax,xmin
|
double precision eps,epsneg,xmax,xmin
|
||||||
INTEGER i,itemp,iz,j,k,mx,nxres
|
INTEGER i,itemp,iz,j,k,mx,nxres
|
||||||
double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa,
|
double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa,
|
||||||
&two,y,z,zero,
CONV
|
&two,y,z,zero,CONV
|
||||||
CONV(i)=dble(i)
|
CONV(i)=dble(i)
|
||||||
one=CONV(1)
|
one=CONV(1)
|
||||||
two=one+one
|
two=one+one
|
||||||
@@ -966,7 +966,6 @@ C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
|
|||||||
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
|
||||||
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
|
||||||
+ LWKMN)
|
+ LWKMN)
|
||||||
|
|
||||||
IF (ACCESS) THEN
|
IF (ACCESS) THEN
|
||||||
|
|
||||||
C SET STARTING LOCATIONS FOR WORK VECTORS
|
C SET STARTING LOCATIONS FOR WORK VECTORS
|
||||||
@@ -1052,7 +1051,6 @@ C STORE VALUES INTO THE WORK VECTORS
|
|||||||
IWORK(IDFI) = IDF
|
IWORK(IDFI) = IDF
|
||||||
IWORK(INT2I) = INT2
|
IWORK(INT2I) = INT2
|
||||||
END IF
|
END IF
|
||||||
|
|
||||||
RETURN
|
RETURN
|
||||||
END
|
END
|
||||||
*DESUBI
|
*DESUBI
|
||||||
@@ -5916,7 +5914,6 @@ C***FIRST EXECUTABLE STATEMENT DODMN
|
|||||||
|
|
||||||
|
|
||||||
C INITIALIZE NECESSARY VARIABLES
|
C INITIALIZE NECESSARY VARIABLES
|
||||||
|
|
||||||
CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
|
CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
|
||||||
+ ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
|
+ ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
|
||||||
ACCESS = .TRUE.
|
ACCESS = .TRUE.
|
||||||
@@ -5936,7 +5933,6 @@ C INITIALIZE NECESSARY VARIABLES
|
|||||||
DIDVCV = .FALSE.
|
DIDVCV = .FALSE.
|
||||||
INTDBL = .FALSE.
|
INTDBL = .FALSE.
|
||||||
LSTEP = .TRUE.
|
LSTEP = .TRUE.
|
||||||
|
|
||||||
C PRINT INITIAL SUMMARY IF DESIRED
|
C PRINT INITIAL SUMMARY IF DESIRED
|
||||||
|
|
||||||
IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
|
IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
|
||||||
@@ -6295,7 +6291,6 @@ C PRINT ITERATION REPORT
|
|||||||
END IF
|
END IF
|
||||||
END IF
|
END IF
|
||||||
END IF
|
END IF
|
||||||
|
|
||||||
C CHECK IF FINISHED
|
C CHECK IF FINISHED
|
||||||
|
|
||||||
IF (INFO.EQ.0) THEN
|
IF (INFO.EQ.0) THEN
|
||||||
@@ -6315,9 +6310,7 @@ C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET
|
|||||||
GO TO 110
|
GO TO 110
|
||||||
END IF
|
END IF
|
||||||
END IF
|
END IF
|
||||||
|
|
||||||
150 CONTINUE
|
150 CONTINUE
|
||||||
|
|
||||||
IF (ISTOP.GT.0) INFO = INFO + 100
|
IF (ISTOP.GT.0) INFO = INFO + 100
|
||||||
|
|
||||||
C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
|
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
|
END IF
|
||||||
CALL DUNPAC(NP,BETAC,BETA,IFIXB)
|
CALL DUNPAC(NP,BETAC,BETA,IFIXB)
|
||||||
CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)
|
CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)
|
||||||
|
|
||||||
C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
|
C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
|
||||||
C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED
|
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 RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED
|
||||||
C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
|
C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
|
||||||
C TO COMPUTE COVARIANCE MATRIX
|
C TO COMPUTE COVARIANCE MATRIX
|
||||||
@@ -6350,8 +6340,6 @@ C TO COMPUTE COVARIANCE MATRIX
|
|||||||
+ T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
|
+ T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
|
||||||
+ FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
|
+ FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
|
||||||
+ NJEV,NFEV,ISTOP,INFO)
|
+ NJEV,NFEV,ISTOP,INFO)
|
||||||
|
|
||||||
|
|
||||||
IF (ISTOP.NE.0) THEN
|
IF (ISTOP.NE.0) THEN
|
||||||
INFO = 51000
|
INFO = 51000
|
||||||
GO TO 200
|
GO TO 200
|
||||||
@@ -6359,7 +6347,6 @@ C TO COMPUTE COVARIANCE MATRIX
|
|||||||
GO TO 200
|
GO TO 200
|
||||||
END IF
|
END IF
|
||||||
END IF
|
END IF
|
||||||
|
|
||||||
IF (IMPLCT) THEN
|
IF (IMPLCT) THEN
|
||||||
CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
|
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)
|
RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1)
|
||||||
@@ -6383,9 +6370,7 @@ C TO COMPUTE COVARIANCE MATRIX
|
|||||||
END IF
|
END IF
|
||||||
DIDVCV = .TRUE.
|
DIDVCV = .TRUE.
|
||||||
END IF
|
END IF
|
||||||
|
|
||||||
END IF
|
END IF
|
||||||
|
|
||||||
C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS
|
C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS
|
||||||
|
|
||||||
200 DO 210 I=0,NP-1
|
200 DO 210 I=0,NP-1
|
||||||
@@ -12072,15 +12057,23 @@ C***FIRST EXECUTABLE STATEMENT DNRM2_odr
|
|||||||
DNRM2_odr = ZERO
|
DNRM2_odr = ZERO
|
||||||
GO TO 300
|
GO TO 300
|
||||||
|
|
||||||
10 ASSIGN 30 TO NEXT
|
! 10 ASSIGN 30 TO NEXT
|
||||||
|
10 NEXT=30
|
||||||
SUM = ZERO
|
SUM = ZERO
|
||||||
NN = N * INCX
|
NN = N * INCX
|
||||||
C BEGIN MAIN LOOP
|
C BEGIN MAIN LOOP
|
||||||
I = 1
|
I = 1
|
||||||
C 20 GO TO NEXT,(30, 50, 70, 110)
|
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
|
30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
|
||||||
ASSIGN 50 TO NEXT
|
! ASSIGN 50 TO NEXT
|
||||||
|
NEXT=50
|
||||||
XMAX = ZERO
|
XMAX = ZERO
|
||||||
|
|
||||||
C PHASE 1. SUM IS 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
|
IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
|
||||||
|
|
||||||
C PREPARE FOR PHASE 2.
|
C PREPARE FOR PHASE 2.
|
||||||
ASSIGN 70 TO NEXT
|
! ASSIGN 70 TO NEXT
|
||||||
|
NEXT=70
|
||||||
GO TO 105
|
GO TO 105
|
||||||
|
|
||||||
C PREPARE FOR PHASE 4.
|
C PREPARE FOR PHASE 4.
|
||||||
|
|
||||||
100 I = J
|
100 I = J
|
||||||
ASSIGN 110 TO NEXT
|
! ASSIGN 110 TO NEXT
|
||||||
|
NEXT=110
|
||||||
SUM = (SUM / DX(I)) / DX(I)
|
SUM = (SUM / DX(I)) / DX(I)
|
||||||
105 XMAX = DABS(DX(I))
|
105 XMAX = DABS(DX(I))
|
||||||
GO TO 115
|
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
|
implicit none
|
||||||
INTEGER iter,n,np,NMAX,ITMAX
|
INTEGER iter,n,np,NMAX,ITMAX
|
||||||
double precision fret,ftol,p(np),xi(np,np),TINY,
|
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)
|
PARAMETER (NMAX=1000,TINY=1.0d-25)
|
||||||
CU USES funkmin,linmin
|
CU USES funkmin,linmin
|
||||||
INTEGER i,ibig,j
|
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)
|
SUBROUTINE linmin(p,pmin,pmax,xi,n,f1dim,fret)
|
||||||
implicit none
|
implicit none
|
||||||
INTEGER n
|
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)
|
PARAMETER (TOL=1.0d-8)
|
||||||
CU USES brent,f1dim,mnbrak
|
CU USES brent,f1dim,mnbrak
|
||||||
INTEGER j,k,ierr
|
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
|
! 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 '_'
|
! the saparating character and blank spaces are repalced with '_'
|
||||||
integer nmax,n
|
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
|
integer i,k,pos1,pos2,leng,posindex(0:nmax+100),itiscomma
|
||||||
!
|
!
|
||||||
leng=LEN_TRIM(longchar)
|
leng=LEN_TRIM(longchar)
|
||||||
@@ -35,6 +36,10 @@
|
|||||||
do i=1,leng
|
do i=1,leng
|
||||||
if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1
|
if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1
|
||||||
enddo
|
enddo
|
||||||
|
if(itiscomma.ge.nmax)then
|
||||||
|
n=0
|
||||||
|
return
|
||||||
|
endif
|
||||||
if(itiscomma.gt.0)then
|
if(itiscomma.gt.0)then
|
||||||
!If the line contains at least one comma, it is assumed a comma separated line
|
!If the line contains at least one comma, it is assumed a comma separated line
|
||||||
n=0
|
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.
|
!number.
|
||||||
!ierr=0, successful conversion
|
!ierr=0, successful conversion
|
||||||
! =1, conversion failed
|
! =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
|
double precision f,fsign,factor
|
||||||
integer ipos1,ipos2,ideci,k,j,i,m,numchar0,
|
integer ipos1,ipos2,ideci,k,j,i,m,numchar0,
|
||||||
& numchar,ierr,ispartnum,nlength
|
& numchar,ierr,ispartnum,nlength
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@@ -71,13 +71,13 @@
|
|||||||
return
|
return
|
||||||
end
|
end
|
||||||
|
|
||||||
double precision function ran1(idum)
|
! double precision function ran1(idum)
|
||||||
implicit none
|
! implicit none
|
||||||
integer idum,IA,IM,IQ,IR,NTAB,NDIV
|
! integer idum,IA,IM,IQ,IR,NTAB,NDIV
|
||||||
double precision AM,EPS,RNMX
|
! double precision AM,EPS,RNMX
|
||||||
PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
|
! PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
|
||||||
& IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
|
! & IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
|
||||||
& RNMX=1.0d0-EPS)
|
! & RNMX=1.0d0-EPS)
|
||||||
!
|
!
|
||||||
! Minimal random number generator of Park and Miller with Bays-Durham shuffle and
|
! 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
|
! 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
|
! thereafter, do not alter idum between successive deviates in a sequence. RNMX
|
||||||
! should approximate the largest floating value that is less than 1.
|
! should approximate the largest floating value that is less than 1.
|
||||||
!
|
!
|
||||||
integer j,k,iv(NTAB),iy
|
! integer j,k,iv(NTAB),iy
|
||||||
save iv,iy
|
! save iv,iy
|
||||||
data iv /NTAB*0/,iy /0/
|
! data iv /NTAB*0/,iy /0/
|
||||||
if(idum.le.0.or.iy.eq.0)then
|
! if(idum.le.0.or.iy.eq.0)then
|
||||||
idum=max(-idum,1)
|
! idum=max(-idum,1)
|
||||||
do j=NTAB+8,1,-1
|
! do j=NTAB+8,1,-1
|
||||||
k=idum/IQ
|
! k=idum/IQ
|
||||||
idum=IA*(idum-k*IQ)-IR*k
|
! idum=IA*(idum-k*IQ)-IR*k
|
||||||
if(idum.lt.0)idum=idum+IM
|
! if(idum.lt.0)idum=idum+IM
|
||||||
if(j.le.NTAB)iv(j)=idum
|
! if(j.le.NTAB)iv(j)=idum
|
||||||
enddo
|
! enddo
|
||||||
iy=iv(1)
|
! iy=iv(1)
|
||||||
endif
|
! endif
|
||||||
k=idum/IQ
|
! k=idum/IQ
|
||||||
idum=IA*(idum-k*IQ)-IR*k
|
! idum=IA*(idum-k*IQ)-IR*k
|
||||||
if(idum.lt.0)idum=idum+IM
|
! if(idum.lt.0)idum=idum+IM
|
||||||
j=1+iy/NDIV
|
! j=1+iy/NDIV
|
||||||
iy=iv(j)
|
! iy=iv(j)
|
||||||
iv(j)=idum
|
! iv(j)=idum
|
||||||
ran1=dmin1(AM*iy,RNMX)
|
! ran1=dmin1(AM*iy,RNMX)
|
||||||
return
|
! return
|
||||||
end
|
! end
|
||||||
|
|||||||
@@ -73,7 +73,7 @@
|
|||||||
do i=1,6
|
do i=1,6
|
||||||
grad(i)=grad6(i)
|
grad(i)=grad6(i)
|
||||||
enddo
|
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)
|
grad(6)=grad(6)-grad6(6)
|
||||||
do i=1,4
|
do i=1,4
|
||||||
grad(6+i)=-grad6(i)
|
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)
|
subroutine sort_shell(n,a,iorder)
|
||||||
!sort array a with the Shell method (from smallest to largest).
|
!sort array a with the Shell method (from smallest to largest).
|
||||||
!iorder records the original position of each member.
|
!iorder records the original position of each member.
|
||||||
@@ -66,6 +117,41 @@ c: x^3+p*x^2+q*x+r=0
|
|||||||
cubicroot=root2
|
cubicroot=root2
|
||||||
return
|
return
|
||||||
end
|
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&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||||
subroutine quadraticroots(a,b,c,root1,root2)
|
subroutine quadraticroots(a,b,c,root1,root2)
|
||||||
implicit none
|
implicit none
|
||||||
@@ -532,6 +618,30 @@ c####################################################################
|
|||||||
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
|
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
|
||||||
enddo
|
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
|
end
|
||||||
c#######################################################################
|
c#######################################################################
|
||||||
subroutine reinitialization(x0min,x0likely,
|
subroutine reinitialization(x0min,x0likely,
|
||||||
|
|||||||
@@ -4,7 +4,8 @@
|
|||||||
implicit none
|
implicit none
|
||||||
integer nmax,n
|
integer nmax,n
|
||||||
double precision vars(nmax+100)
|
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
|
integer i,pos1,pos2,ispartnum,leng,numchar,ierr
|
||||||
!
|
!
|
||||||
n=0
|
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
|
2001 continue
|
||||||
enddo
|
enddo
|
||||||
|
|
||||||
! goto 1000
|
goto 1000
|
||||||
|
|
||||||
gacontrol(1)=200.0d0
|
gacontrol(1)=200.0d0
|
||||||
gacontrol(2)=2000.0d0
|
gacontrol(2)=2000.0d0
|
||||||
|
|||||||
@@ -596,8 +596,8 @@
|
|||||||
do j=1,npoints
|
do j=1,npoints
|
||||||
write(unitwuecicacomp,380)curveno,trim(curvename),co2a_ppm(j),
|
write(unitwuecicacomp,380)curveno,trim(curvename),co2a_ppm(j),
|
||||||
&vpdl(j),wue(j),wuemod(j),cicameas(j),cicamod(j),wue_intrin(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),
|
&wue_intrinmod(j),(cccimeas(k,j),cccimod(k,j),k=1,4),
|
||||||
&((co2recycleratio(k,j),recycmod(k,j)),k=1,6)
|
&(co2recycleratio(k,j),recycmod(k,j),k=1,6)
|
||||||
enddo
|
enddo
|
||||||
write(unitparamsout,390)curveno,trim(curvename),npoints_stom,
|
write(unitparamsout,390)curveno,trim(curvename),npoints_stom,
|
||||||
&co2threshold,co2current,vpdl_ref,ballintersurf,ballslopesurf,
|
&co2threshold,co2current,vpdl_ref,ballintersurf,ballslopesurf,
|
||||||
@@ -608,10 +608,10 @@
|
|||||||
&dewarrsqgsw,wueref,der_wueref,rsqwue,(alfit(i),i=1,5),
|
&dewarrsqgsw,wueref,der_wueref,rsqwue,(alfit(i),i=1,5),
|
||||||
&wueref_intrin,der_wueref_intrin,rsqwue_intrin,(blfit(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),
|
&cicaref,der_cicaref,rsqcica,(cicafit(i),i=1,5),
|
||||||
&avetleaf,avetair,avevpdl,avepari,((ccciref(i),der_ccciref(i),
|
&avetleaf,avetair,avevpdl,avepari,(ccciref(i),der_ccciref(i),
|
||||||
&rsqccci(i),(cccifit(i,j),j=1,6)),i=1,4),
|
&rsqccci(i),(cccifit(i,j),j=1,6),i=1,4),
|
||||||
&((recycref(i),der_recycref(i),
|
&(recycref(i),der_recycref(i),
|
||||||
&rsqrecyc(i),(recycfit(i,j),j=1,5)),i=1,6),
|
&rsqrecyc(i),(recycfit(i,j),j=1,5),i=1,6),
|
||||||
!
|
!
|
||||||
&trim(siteID),Latitude,Longitude,Elevation,yearsampled,
|
&trim(siteID),Latitude,Longitude,Elevation,yearsampled,
|
||||||
&sampledoy,GrowingSeasonStart,GrowingSeasonEnd,
|
&sampledoy,GrowingSeasonStart,GrowingSeasonEnd,
|
||||||
|
|||||||
@@ -17,7 +17,7 @@
|
|||||||
integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2,
|
integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2,
|
||||||
&ntotfiles,noutputfiles,i,j,k,rank_mpi,numproc_mpi,numproc,
|
&ntotfiles,noutputfiles,i,j,k,rank_mpi,numproc_mpi,numproc,
|
||||||
&ierror_mpi,nshare,nmod,npartfiles,istartno,iendno,indexunit(20),
|
&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,
|
character rundate*8,runtime*10,runzone*5,longchar*5000,achar*5,
|
||||||
&longchar1*5000
|
&longchar1*5000
|
||||||
character*100 datapath,outpath,storein,storeout,ACidata(8000)
|
character*100 datapath,outpath,storein,storeout,ACidata(8000)
|
||||||
@@ -26,12 +26,13 @@
|
|||||||
! Set input / output directory
|
! Set input / output directory
|
||||||
parameter(
|
parameter(
|
||||||
& datapath=
|
& datapath=
|
||||||
|
&'../input/',
|
||||||
! &'/home/l2g/ngeetropics/gamboa/curves/',
|
! &'/home/l2g/ngeetropics/gamboa/curves/',
|
||||||
! &'/home/l2g/ngeetropics/metropolitano/curves/',
|
! &'/home/l2g/ngeetropics/metropolitano/curves/',
|
||||||
! &'/home/l2g/ngeetropics/fortsherman/curves/',
|
! &'/home/l2g/ngeetropics/fortsherman/curves/',
|
||||||
! & '/home/l2g/ngeetropics/kelsey/curves/',
|
! & '/home/l2g/ngeetropics/kelsey/curves/',
|
||||||
! & '/home/l2g/leafres/hybriddata/Berner/',
|
! & '/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/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/',
|
||||||
|
|
||||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
|
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
|
||||||
@@ -61,12 +62,13 @@
|
|||||||
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
|
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
|
||||||
! & '/home/l2g/GEMSiS/curves/',
|
! & '/home/l2g/GEMSiS/curves/',
|
||||||
& outpath=
|
& outpath=
|
||||||
|
&'../output/fitresult/touser/',
|
||||||
! &'/home/l2g/ngeetropics/gamboa/results/',
|
! &'/home/l2g/ngeetropics/gamboa/results/',
|
||||||
! &'/home/l2g/ngeetropics/metropolitano/results/',
|
! &'/home/l2g/ngeetropics/metropolitano/results/',
|
||||||
! &'/home/l2g/ngeetropics/fortsherman/',
|
! &'/home/l2g/ngeetropics/fortsherman/',
|
||||||
! &'/home/l2g/ngeetropics/kelsey/results/',
|
! &'/home/l2g/ngeetropics/kelsey/results/',
|
||||||
! & '/home/l2g/leafres/hybriddata/Berner/',
|
! & '/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/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/',
|
||||||
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
|
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
|
||||||
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
|
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
|
||||||
@@ -100,23 +102,50 @@
|
|||||||
! &storein='/home/l2g/leafweb/users/curves/',
|
! &storein='/home/l2g/leafweb/users/curves/',
|
||||||
! &storeout='/home/l2g/leafweb/users/results/',
|
! &storeout='/home/l2g/leafweb/users/results/',
|
||||||
|
|
||||||
&storein='/home/l2g/clm/results/',
|
&storein='../output/clninput/',
|
||||||
&storeout='/home/l2g/clm/results/',
|
&storeout='../output/fitresult/nottouser/',
|
||||||
|
|
||||||
! &storein='/home/l2g/junk/',
|
! &storein='/home/l2g/junk/',
|
||||||
! &storeout='/home/l2g/junk/',
|
! &storeout='/home/l2g/junk/',
|
||||||
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
||||||
! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
||||||
|
|
||||||
& AllACiFiles='AllLeafGasFiles')
|
& AllACiFiles='../piscal.cfg')
|
||||||
!---------------End of variable declaration----------------
|
!---------------End of variable declaration----------------
|
||||||
rootprocess=0
|
rootprocess=0
|
||||||
dataunit=1
|
dataunit=1
|
||||||
spareunit=3
|
spareunit=3
|
||||||
! if(rank_mpi.ne.rootprocess)goto 25
|
! if(rank_mpi.ne.rootprocess)goto 25
|
||||||
!read A/Ci curve names stored in AllACiFiles
|
!read A/Ci curve names stored in AllACiFiles
|
||||||
open(unit=2,file=trim(datapath)//trim(AllACiFiles))
|
open(unit=2,file=trim(AllACiFiles))
|
||||||
ntotfiles=1
|
ntotfiles=1
|
||||||
|
ic3c4cam=-9999
|
||||||
10 read(2,fmt=300,end=20)longchar
|
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)
|
i=len(longchar)
|
||||||
j=0
|
j=0
|
||||||
15 j=j+1
|
15 j=j+1
|
||||||
@@ -153,6 +182,9 @@
|
|||||||
noutputfiles=11
|
noutputfiles=11
|
||||||
!10 to 20 are used for file units for output files
|
!10 to 20 are used for file units for output files
|
||||||
do i=1,noutputfiles
|
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
|
indexunit(i)=i+9
|
||||||
enddo
|
enddo
|
||||||
call MPI_INIT(ierror_mpi)
|
call MPI_INIT(ierror_mpi)
|
||||||
@@ -190,82 +222,16 @@
|
|||||||
numchar=numchar+1
|
numchar=numchar+1
|
||||||
goto 30
|
goto 30
|
||||||
40 call NumberToChar(rank_mpi,numchar,achar)
|
40 call NumberToChar(rank_mpi,numchar,achar)
|
||||||
do i=1,noutputfiles-1
|
do i=1,noutputfiles
|
||||||
open(unit=indexunit(i),
|
open(unit=indexunit(i),
|
||||||
&file=trim(outpath)//trim(outputfile(i))//trim(achar))
|
&file=trim(outpath)//trim(outputfile(i))//trim(achar))
|
||||||
enddo
|
enddo
|
||||||
call ToLeafGasOptimization(npartfiles,ACidata(istartno:iendno),
|
call ToLeafGasOptimization(ic3c4cam,npartfiles,
|
||||||
&dataunit,spareunit,datapath,indexunit,ierr)
|
&ACidata(istartno:iendno),dataunit,spareunit,datapath,indexunit,
|
||||||
do i=1,noutputfiles-1
|
&ierr)
|
||||||
|
do i=1,noutputfiles
|
||||||
close(indexunit(i))
|
close(indexunit(i))
|
||||||
enddo
|
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.
|
!make sure everyone is done before wrapping up.
|
||||||
45 call MPI_BARRIER(MPI_COMM_WORLD,ierror_mpi)
|
45 call MPI_BARRIER(MPI_COMM_WORLD,ierror_mpi)
|
||||||
if(rank_mpi.eq.rootprocess)then
|
if(rank_mpi.eq.rootprocess)then
|
||||||
@@ -326,29 +292,41 @@
|
|||||||
enddo
|
enddo
|
||||||
!----------------------------------------------------------
|
!----------------------------------------------------------
|
||||||
!intercept the data
|
!intercept the data
|
||||||
goto 450
|
if(needheader(noutputfiles).eq.2)then
|
||||||
399 call date_and_time(rundate,runtime,runzone,runvalues)
|
!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
|
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=
|
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
|
400 read(1,fmt=300,end=410)longchar
|
||||||
write(2,310)trim(longchar)
|
write(2,310)trim(longchar)
|
||||||
goto 400
|
goto 400
|
||||||
410 close(1)
|
410 close(1,status='delete')
|
||||||
close(2)
|
close(2)
|
||||||
enddo
|
enddo
|
||||||
do i=1,6
|
do i=1,noutputfiles
|
||||||
k=0
|
k=0
|
||||||
open(unit=1,file=trim(outpath)//trim(outputfile(i)))
|
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)))
|
&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
|
420 read(1,fmt=300,end=430)longchar
|
||||||
write(2,310)trim(longchar)
|
write(2,310)trim(longchar)
|
||||||
k=1
|
k=1
|
||||||
goto 420
|
goto 420
|
||||||
430 if(k.eq.1)then
|
430 if(k.eq.1)then
|
||||||
close(1)
|
close(1,status='delete')
|
||||||
close(2)
|
close(2)
|
||||||
else
|
else
|
||||||
close(1,status='delete')
|
close(1,status='delete')
|
||||||
|
|||||||
@@ -15,7 +15,7 @@
|
|||||||
program main
|
program main
|
||||||
implicit none
|
implicit none
|
||||||
integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2,
|
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 rundate*8,runtime*10,runzone*5,longchar*5000
|
||||||
character*100 datapath,outpath,storein,storeout,
|
character*100 datapath,outpath,storein,storeout,
|
||||||
&ACidata(8000)
|
&ACidata(8000)
|
||||||
@@ -23,11 +23,14 @@
|
|||||||
|
|
||||||
! Set input / output directory
|
! Set input / output directory
|
||||||
parameter(datapath=
|
parameter(datapath=
|
||||||
|
! &'../input/',
|
||||||
|
&'/home/l2g/jimei/',
|
||||||
! &'/home/l2g/ngeetropics/gamboa/curves/',
|
! &'/home/l2g/ngeetropics/gamboa/curves/',
|
||||||
! &'/home/l2g/ngeetropics/metropolitano/curves/',
|
! &'/home/l2g/ngeetropics/metropolitano/curves/',
|
||||||
! &'/home/l2g/ngeetropics/fortsherman/curves/',
|
! &'/home/l2g/ngeetropics/fortsherman/curves/',
|
||||||
! &'/home/l2g/ngeetropics/kelsey/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/dwestonpoplus/data3/',
|
||||||
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
|
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
|
||||||
! &'/home/l2g/leafres/hybriddata/hanjimei/',
|
! &'/home/l2g/leafres/hybriddata/hanjimei/',
|
||||||
@@ -59,6 +62,8 @@
|
|||||||
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
|
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
|
||||||
! & '/home/l2g/GEMSiS/curves/',
|
! & '/home/l2g/GEMSiS/curves/',
|
||||||
& outpath=
|
& outpath=
|
||||||
|
! &'../output/fitresult/touser/',
|
||||||
|
&'/home/l2g/jimei/',
|
||||||
! &'/home/l2g/ngeetropics/gamboa/results/',
|
! &'/home/l2g/ngeetropics/gamboa/results/',
|
||||||
! &'/home/l2g/ngeetropics/metropolitano/results/',
|
! &'/home/l2g/ngeetropics/metropolitano/results/',
|
||||||
! &'/home/l2g/ngeetropics/fortsherman/results/',
|
! &'/home/l2g/ngeetropics/fortsherman/results/',
|
||||||
@@ -69,7 +74,9 @@
|
|||||||
! &'/home/l2g/leafres/hybriddata/hanjimei/',
|
! &'/home/l2g/leafres/hybriddata/hanjimei/',
|
||||||
!
|
!
|
||||||
! & '/home/l2g/leafres/hybriddata/Berner/',
|
! & '/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/huidafeng/',
|
||||||
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/
|
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/
|
||||||
! &',
|
! &',
|
||||||
@@ -99,43 +106,28 @@
|
|||||||
! &storein='/home/l2g/leafweb/users/curves/',
|
! &storein='/home/l2g/leafweb/users/curves/',
|
||||||
! &storeout='/home/l2g/leafweb/users/results/',
|
! &storeout='/home/l2g/leafweb/users/results/',
|
||||||
|
|
||||||
&storein='/home/l2g/leafres/testdata/',
|
! &storein='../output/clninput/',
|
||||||
&storeout='/home/l2g/leafres/testdata/',
|
! &storeout='../output/fitresult/nottouser/',
|
||||||
! &storein='/home/l2g/junk/',
|
|
||||||
! &storeout='/home/l2g/junk/',
|
&storein='/home/l2g/jimei/',
|
||||||
|
&storeout='/home/l2g/jimei/',
|
||||||
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
|
||||||
! &storeout='/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----------------
|
!---------------End of variable declaration----------------
|
||||||
ierr(1)=-1
|
ierr(1)=-1
|
||||||
ierr(2)=-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
|
!read A/Ci curve names stored in AllACiFiles
|
||||||
dataunit=1
|
dataunit=1
|
||||||
spareunit=3
|
spareunit=3
|
||||||
open(unit=dataunit,status='scratch')
|
open(unit=dataunit,status='scratch')
|
||||||
open(unit=spareunit,file=trim(datapath)//trim(AllACiFiles))
|
open(unit=spareunit,file=trim(AllACiFiles))
|
||||||
read(spareunit,fmt=300,err=40,end=40)longchar
|
read(spareunit,fmt=300,err=90,end=90)longchar
|
||||||
rewind(spareunit)
|
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))
|
3 k=index(longchar,char(13))
|
||||||
if(k.gt.0)then
|
if(k.gt.0)then
|
||||||
!DOS text format, convert it to unix format
|
!DOS text format, convert it to unix format
|
||||||
@@ -147,7 +139,34 @@
|
|||||||
5 close(spareunit)
|
5 close(spareunit)
|
||||||
rewind(dataunit)
|
rewind(dataunit)
|
||||||
ntotfiles=1
|
ntotfiles=1
|
||||||
|
ic3c4cam=-9999
|
||||||
10 read(dataunit,fmt=300,end=20)longchar
|
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)
|
i=len(longchar)
|
||||||
j=0
|
j=0
|
||||||
15 j=j+1
|
15 j=j+1
|
||||||
@@ -170,83 +189,32 @@
|
|||||||
goto 10
|
goto 10
|
||||||
20 ntotfiles=ntotfiles-1
|
20 ntotfiles=ntotfiles-1
|
||||||
close(dataunit)
|
close(dataunit)
|
||||||
call ToLeafGasOptimization(ntotfiles,ACidata,dataunit,spareunit,
|
outputfile(1)='leafgasparameters.csv'
|
||||||
&datapath,indexunit,ierr)
|
outputfile(2)='leafgascomparison.csv'
|
||||||
40 do i=1,noutputfiles-1
|
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))
|
close(indexunit(i))
|
||||||
enddo
|
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
|
do j=1,noutputfiles
|
||||||
open(unit=2,file=trim(outpath)//trim(outputfile(j)))
|
open(unit=2,file=trim(outpath)//trim(outputfile(j)))
|
||||||
read(2,*,end=70)
|
read(2,*,end=70)
|
||||||
@@ -260,29 +228,47 @@
|
|||||||
80 enddo
|
80 enddo
|
||||||
!----------------------------------------------------------
|
!----------------------------------------------------------
|
||||||
!intercept the data
|
!intercept the data
|
||||||
goto 450
|
90 if(ierr(1).ne.0)then
|
||||||
399 call date_and_time(rundate,runtime,runzone,runvalues)
|
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
|
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=
|
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
|
400 read(1,fmt=300,end=410)longchar
|
||||||
write(2,310)trim(longchar)
|
write(2,310)trim(longchar)
|
||||||
goto 400
|
goto 400
|
||||||
410 close(1)
|
410 close(1,status='delete')
|
||||||
close(2)
|
close(2)
|
||||||
enddo
|
enddo
|
||||||
do i=1,6
|
do i=1,noutputfiles
|
||||||
k=0
|
k=0
|
||||||
open(unit=1,file=trim(outpath)//trim(outputfile(i)))
|
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)))
|
&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
|
420 read(1,fmt=300,end=430)longchar
|
||||||
write(2,310)trim(longchar)
|
write(2,310)trim(longchar)
|
||||||
k=1
|
k=1
|
||||||
goto 420
|
goto 420
|
||||||
430 if(k.eq.1)then
|
430 if(k.eq.1)then
|
||||||
close(1)
|
close(1,status='delete')
|
||||||
close(2)
|
close(2)
|
||||||
else
|
else
|
||||||
close(1,status='delete')
|
close(1,status='delete')
|
||||||
|
|||||||
@@ -58,7 +58,7 @@
|
|||||||
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
|
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
|
||||||
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
|
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
|
||||||
&ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax,
|
&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,
|
integer minimumrubis,minimumfj,minimumvt,idorwp,idorch,idord,
|
||||||
&idostargamma,idoalpha,idokc,idoko,ifixunivparams(maxpsnparam),
|
&idostargamma,idoalpha,idokc,idoko,ifixunivparams(maxpsnparam),
|
||||||
@@ -84,7 +84,7 @@
|
|||||||
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
|
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
|
||||||
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
|
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
|
||||||
&ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax,
|
&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,
|
common /intleafparams/minimumrubis,minimumfj,minimumvt,idorwp,
|
||||||
&idorch,idord,idostargamma,idoalpha,idokc,idoko,ifixunivparams,
|
&idorch,idord,idostargamma,idoalpha,idokc,idoko,ifixunivparams,
|
||||||
|
|||||||
@@ -1,8 +1,9 @@
|
|||||||
subroutine LeafGasPrintToFiles(isitmassbased,indexunit)
|
subroutine LeafGasPrintToFiles(isitmassbased,indexunit,
|
||||||
|
&ic3c4cam)
|
||||||
implicit none
|
implicit none
|
||||||
integer isitmassbased,indexunit(20),paramunit,compareunit,
|
integer isitmassbased,indexunit(20),paramunit,compareunit,
|
||||||
&stomwuecicaoutunit,stomcompunit,wuecicacompunit,fluorescenceunit,
|
&stomwuecicaoutunit,stomcompunit,wuecicacompunit,fluorescenceunit,
|
||||||
&fluoresparamunit,aciempfitunit,alightempfitunit
|
&fluoresparamunit,aciempfitunit,alightempfitunit,ic3c4cam
|
||||||
character *25,
|
character *25,
|
||||||
& sitevars(50),unitsitevars(50),
|
& sitevars(50),unitsitevars(50),
|
||||||
& paramsvar(0:50),unitparamsvar(0:50),
|
& paramsvar(0:50),unitparamsvar(0:50),
|
||||||
@@ -411,15 +412,25 @@
|
|||||||
unitsitevars(21)='ring/diffuse'
|
unitsitevars(21)='ring/diffuse'
|
||||||
unitsitevars(22)='g/cm3'
|
unitsitevars(22)='g/cm3'
|
||||||
unitsitevars(23)='Unitless'
|
unitsitevars(23)='Unitless'
|
||||||
|
if(ic3c4cam.eq.1)then
|
||||||
write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9),
|
write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9),
|
||||||
&(trim(paramsvar(i)),',',i=0,34),(trim(paramsvar(i)),',',i=39,42),
|
&(trim(paramsvar(i)),',',i=0,34),(trim(paramsvar(i)),',',i=39,42),
|
||||||
&(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
|
&(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=0,34),
|
||||||
&(trim(unitparamsvar(i)),',',i=39,42),
|
&(trim(unitparamsvar(i)),',',i=39,42),
|
||||||
&(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23))
|
&(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)),',',
|
write(fluorescenceunit,'(1000A)')trim(univcomvars(1)),',',
|
||||||
&(trim(univcomvars(i)),',',i=10,14),
|
&(trim(univcomvars(i)),',',i=10,14),
|
||||||
&(trim(univcomvars(i)),',',i=17,27),
|
&(trim(univcomvars(i)),',',i=17,27),
|
||||||
@@ -514,9 +525,9 @@
|
|||||||
unitstomwuecica(16)='umolkg-1s-1'
|
unitstomwuecica(16)='umolkg-1s-1'
|
||||||
endif
|
endif
|
||||||
|
|
||||||
write(stomcompunit,'(100A)')((trim(stomwuecica(i)),','),
|
write(stomcompunit,'(100A)')(trim(stomwuecica(i)),',',
|
||||||
&i=1,15),trim(stomwuecica(16))
|
&i=1,15),trim(stomwuecica(16))
|
||||||
write(stomcompunit,'(100A)')((trim(unitstomwuecica(i)),','),
|
write(stomcompunit,'(100A)')(trim(unitstomwuecica(i)),',',
|
||||||
&i=1,15),trim(unitstomwuecica(16))
|
&i=1,15),trim(unitstomwuecica(16))
|
||||||
!------------------------------------------------------------
|
!------------------------------------------------------------
|
||||||
stomwuecica(1)='curveno'
|
stomwuecica(1)='curveno'
|
||||||
@@ -581,9 +592,9 @@
|
|||||||
unitstomwuecica(29)='NA'
|
unitstomwuecica(29)='NA'
|
||||||
unitstomwuecica(30)='NA'
|
unitstomwuecica(30)='NA'
|
||||||
|
|
||||||
write(wuecicacompunit,'(200A)')((trim(stomwuecica(i)),','),
|
write(wuecicacompunit,'(200A)')(trim(stomwuecica(i)),',',
|
||||||
&i=1,29),trim(stomwuecica(30))
|
&i=1,29),trim(stomwuecica(30))
|
||||||
write(wuecicacompunit,'(200A)')((trim(unitstomwuecica(i)),','),
|
write(wuecicacompunit,'(200A)')(trim(unitstomwuecica(i)),',',
|
||||||
&i=1,29),trim(stomwuecica(30))
|
&i=1,29),trim(stomwuecica(30))
|
||||||
|
|
||||||
stomwuecica(1)='curveno'
|
stomwuecica(1)='curveno'
|
||||||
@@ -875,10 +886,10 @@
|
|||||||
unitstomwuecica(55)='umolkg-1s-1'
|
unitstomwuecica(55)='umolkg-1s-1'
|
||||||
endif
|
endif
|
||||||
|
|
||||||
write(stomwuecicaoutunit,'(2000A)')((trim(stomwuecica(i)),','),
|
write(stomwuecicaoutunit,'(2000A)')(trim(stomwuecica(i)),',',
|
||||||
&i=1,139),((trim(sitevars(i)),','),i=1,22),trim(sitevars(23))
|
&i=1,139),(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
|
||||||
write(stomwuecicaoutunit,'(2000A)')((trim(unitstomwuecica(i)),
|
write(stomwuecicaoutunit,'(2000A)')(trim(unitstomwuecica(i)),
|
||||||
&','),i=1,139),((trim(unitsitevars(i)),','),i=1,22),
|
&',',i=1,139),(trim(unitsitevars(i)),',',i=1,22),
|
||||||
&trim(unitsitevars(23))
|
&trim(unitsitevars(23))
|
||||||
return
|
return
|
||||||
end
|
end
|
||||||
|
|||||||
@@ -685,7 +685,7 @@
|
|||||||
else
|
else
|
||||||
betamin(1)=0.5d0*amaxave
|
betamin(1)=0.5d0*amaxave
|
||||||
endif
|
endif
|
||||||
betamax(1)=200.0d0
|
betamax(1)=1000.0d0
|
||||||
beta(2)=1.5d0
|
beta(2)=1.5d0
|
||||||
betamin(2)=1.0d-5
|
betamin(2)=1.0d-5
|
||||||
betamax(2)=1000.0d0
|
betamax(2)=1000.0d0
|
||||||
@@ -696,8 +696,8 @@
|
|||||||
betamin(4)=0.0d0
|
betamin(4)=0.0d0
|
||||||
betamax(4)=5000.0d0
|
betamax(4)=5000.0d0
|
||||||
beta(5)=-10.0d0
|
beta(5)=-10.0d0
|
||||||
betamin(5)=-100.0d0
|
betamin(5)=-1000.0d0
|
||||||
betamax(5)=100.0d0
|
betamax(5)=1000.0d0
|
||||||
k=0
|
k=0
|
||||||
n=0
|
n=0
|
||||||
do j=1,nACiPoints(i)
|
do j=1,nACiPoints(i)
|
||||||
@@ -717,6 +717,7 @@
|
|||||||
wvector(n)=ACipco2ambient(j,i)
|
wvector(n)=ACipco2ambient(j,i)
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
|
!
|
||||||
call GenericRegres(nACiPoints(i),1,
|
call GenericRegres(nACiPoints(i),1,
|
||||||
&ACianet_obs(1:nACiPoints(i),i:i),1,ACipco2i(1:nACiPoints(i),i:i),
|
&ACianet_obs(1:nACiPoints(i),i:i),1,ACipco2i(1:nACiPoints(i),i:i),
|
||||||
&weity,weitx,5,beta,betamin,betamax,xmin,xmax,iderivative,INFO,
|
&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(nACiPoints(i):nACiPoints(i),i:i),der_ACiend(i),term,
|
||||||
&ACipco2i(1:1,i:i),ACipco2i(nACiPoints(i):nACiPoints(i),i:i),
|
&ACipco2i(1:1,i:i),ACipco2i(nACiPoints(i):nACiPoints(i),i:i),
|
||||||
&ACimaxcurvature(i),ACimaxcurvpco2i(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,
|
&betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector,
|
||||||
&sumsquare)
|
&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),
|
&Amax_ACa(i),ACainter(i),der_ACainter(i),40.0d0,der_ACa400ppm(i),
|
||||||
&anet_ACa400ppm(i),wvector(1),wvector(n),ACamaxcurvature(i),
|
&anet_ACa400ppm(i),wvector(1),wvector(n),ACamaxcurvature(i),
|
||||||
&ACamaxcurvpco2a(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)
|
if(Amax_ACi(i).lt.50.0d0)amaxave=Amax_ACi(i)
|
||||||
j=min0(5,nACiPoints(i))
|
j=min0(5,nACiPoints(i))
|
||||||
call y_aPLUSbx(j,ACipco2i(1:j,i:i),ACianet_obs(1:j,i:i),ac,at)
|
call y_aPLUSbx(j,ACipco2i(1:j,i:i),ACianet_obs(1:j,i:i),ac,at)
|
||||||
@@ -1268,7 +1280,7 @@
|
|||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
idotempcoeff=0
|
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
|
!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.
|
!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
|
pco2c_pco2i_flu(i)=-9999.0d0
|
||||||
enddo
|
enddo
|
||||||
if(ntotphips2.gt.5)then
|
if(ntotphips2.gt.5)then
|
||||||
do idorch=1,1
|
do idorch=0,0
|
||||||
!we do a fluorescence only fit
|
!we do a fluorescence only fit
|
||||||
Prioriknowlimit=-1
|
Prioriknowlimit=-1
|
||||||
ifitmode=1
|
ifitmode=1
|
||||||
@@ -1291,7 +1303,7 @@
|
|||||||
!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i
|
!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: =1, orthogonal fitting with anet calculated as a function of pco2i
|
||||||
!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet
|
!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet
|
||||||
idorwp=1
|
idorwp=0
|
||||||
resistwp25_ori=resistwp25_ini
|
resistwp25_ori=resistwp25_ini
|
||||||
if(idorch.eq.1)then
|
if(idorch.eq.1)then
|
||||||
resistch25_ori=resistch25_ini
|
resistch25_ori=resistch25_ini
|
||||||
@@ -1638,11 +1650,12 @@
|
|||||||
co2imany(3)=3.0d0
|
co2imany(3)=3.0d0
|
||||||
co2imany(4)=4.0d0
|
co2imany(4)=4.0d0
|
||||||
co2imany(5)=5.0d0
|
co2imany(5)=5.0d0
|
||||||
m=5
|
co2imany(6)=6.0d0
|
||||||
|
m=6
|
||||||
term=ACipco2i(nACiPoints(i),i)+10.0d0
|
term=ACipco2i(nACiPoints(i),i)+10.0d0
|
||||||
do ccc=6.0d0,term,2.5d0
|
do while (co2imany(m).le.term)
|
||||||
m=m+1
|
m=m+1
|
||||||
co2imany(m)=ccc
|
co2imany(m)=co2imany(m-1)+2.5d0
|
||||||
enddo
|
enddo
|
||||||
do j=1,m
|
do j=1,m
|
||||||
ccc=co2imany(j)
|
ccc=co2imany(j)
|
||||||
|
|||||||
@@ -1,15 +1,16 @@
|
|||||||
subroutine ToLeafGasOptimization(ntotfiles,ACidata,dataunit,
|
subroutine ToLeafGasOptimization(ic3c4cam,ntotfiles,ACidata,
|
||||||
&spareunit,datapath,indexunit,ierr)
|
&dataunit,spareunit,datapath,indexunit,ierr)
|
||||||
implicit none
|
implicit none
|
||||||
!--------------All inputs except for ierr. Outputs are written to files----------------
|
!--------------All inputs except for ierr. Outputs are written to files----------------
|
||||||
integer ntotfiles,dataunit,spareunit,ierr(2),indexunit(20)
|
integer ic3c4cam,ntotfiles,dataunit,spareunit,ierr(2),
|
||||||
!ierr(1)=0, ok, >1 input data out of range
|
&indexunit(20)
|
||||||
|
!ierr(1)=0, ok, >=1 input data out of range
|
||||||
!ierr(2) specifies in which input file, the data is out of range
|
!ierr(2) specifies in which input file, the data is out of range
|
||||||
character*100 datapath,ACidata(ntotfiles)
|
character*100 datapath,ACidata(ntotfiles)
|
||||||
!-------------------------------------------------------------------------------
|
!-------------------------------------------------------------------------------
|
||||||
integer ntotpoints,npoints(ntotfiles),i,j,k,n,curveno(ntotfiles),
|
integer ntotpoints,npoints(ntotfiles),i,j,k,n,curveno(ntotfiles),
|
||||||
&iobs,maxobs,nmax,iwarning,warningunit,isitmassbased(ntotfiles),
|
&iobs,maxobs,nmax,iwarning,warningunit,isitmassbased(ntotfiles),
|
||||||
&iprintheader(ntotfiles),ivector(1000),startline
|
&iprintheader(ntotfiles),ivector(1000),startline,errorunit
|
||||||
parameter(maxobs=2000,nmax=100)
|
parameter(maxobs=2000,nmax=100)
|
||||||
character*100 sample(ntotfiles)
|
character*100 sample(ntotfiles)
|
||||||
character*50 chartime,siteID(ntotfiles),species(ntotfiles),ftime,
|
character*50 chartime,siteID(ntotfiles),species(ntotfiles),ftime,
|
||||||
@@ -49,8 +50,14 @@
|
|||||||
&stdco2,fmeanco2,xminco2,xmaxco2
|
&stdco2,fmeanco2,xminco2,xmaxco2
|
||||||
!
|
!
|
||||||
warningunit=indexunit(10)
|
warningunit=indexunit(10)
|
||||||
|
errorunit=indexunit(11)
|
||||||
ierr(1)=0
|
ierr(1)=0
|
||||||
|
if(ic3c4cam.ne.1.and.ic3c4cam.ne.2)then
|
||||||
|
write(errorunit,*)'The analysis for CAM photosyntehsis is still
|
||||||
|
&under development. Check out LeafWeb for this function later.'
|
||||||
|
ierr(1)=1
|
||||||
|
return
|
||||||
|
endif
|
||||||
! open(unit=121,file='sphagnumdata.csv')
|
! open(unit=121,file='sphagnumdata.csv')
|
||||||
! write(121,'(200A)')'name,','hhmmss,','no,','time,','datumlimit,',
|
! write(121,'(200A)')'name,','hhmmss,','no,','time,','datumlimit,',
|
||||||
! &'stom_COND_mol,','CO2chamber_ppm,','CO2i_ppm,','PARi_umol,',
|
! &'stom_COND_mol,','CO2chamber_ppm,','CO2i_ppm,','PARi_umol,',
|
||||||
@@ -76,12 +83,12 @@
|
|||||||
!In early 2015, the following section of code is added to allow flexibity for the starting rows to be used for metadata.
|
!In early 2015, the following section of code is added to allow flexibity for the starting rows to be used for metadata.
|
||||||
!There is no need for a strict number of rows for metadata because the main data section is now determined automatically.
|
!There is no need for a strict number of rows for metadata because the main data section is now determined automatically.
|
||||||
!Locate the rows for the actual data
|
!Locate the rows for the actual data
|
||||||
|
open(unit=spareunit,file=trim(datapath)//trim(ACidata(i)))
|
||||||
|
read(spareunit,fmt=300,err=35,end=35)longchar1
|
||||||
|
rewind(spareunit)
|
||||||
open(unit=dataunit,file=
|
open(unit=dataunit,file=
|
||||||
&trim(datapath)//trim(ACidata(i))//'middle')
|
&trim(datapath)//trim(ACidata(i))//'middle')
|
||||||
open(unit=spareunit,file=trim(datapath)//trim(ACidata(i)))
|
2 read(spareunit,fmt=300,err=35,end=5)longchar1
|
||||||
read(spareunit,fmt=300,err=40,end=40)longchar1
|
|
||||||
rewind(spareunit)
|
|
||||||
2 read(spareunit,fmt=300,err=40,end=5)longchar1
|
|
||||||
3 k=index(longchar1,char(13))
|
3 k=index(longchar1,char(13))
|
||||||
if(k.gt.0)then
|
if(k.gt.0)then
|
||||||
!DOS text format, convert it to unix format
|
!DOS text format, convert it to unix format
|
||||||
@@ -94,8 +101,8 @@
|
|||||||
rewind(dataunit)
|
rewind(dataunit)
|
||||||
|
|
||||||
open(unit=spareunit,file=
|
open(unit=spareunit,file=
|
||||||
&trim(datapath)//trim(ACidata(i))//'clean')
|
&trim(datapath)//'clean'//trim(ACidata(i)))
|
||||||
7 read(dataunit,fmt=310,err=40,end=9)longchar
|
7 read(dataunit,fmt=310,err=36,end=9)longchar
|
||||||
if(longchar.eq.''.or.longchar.eq.' ')goto 7
|
if(longchar.eq.''.or.longchar.eq.' ')goto 7
|
||||||
call charlineparser(longchar,nmax,charvars,n)
|
call charlineparser(longchar,nmax,charvars,n)
|
||||||
if(n.eq.0)goto 7
|
if(n.eq.0)goto 7
|
||||||
@@ -110,15 +117,21 @@
|
|||||||
j=j+1
|
j=j+1
|
||||||
ivector(j)=n
|
ivector(j)=n
|
||||||
goto 500
|
goto 500
|
||||||
600 if(j.lt.12)then
|
600 rewind(spareunit)
|
||||||
close(spareunit,status='delete')
|
|
||||||
goto 630
|
|
||||||
else
|
|
||||||
rewind(spareunit)
|
|
||||||
endif
|
|
||||||
startline=0
|
startline=0
|
||||||
610 startline=startline+1
|
610 startline=startline+1
|
||||||
if(startline.gt.j-11)goto 40
|
if(j.lt.12.or.startline.gt.j-11)then
|
||||||
|
if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'This file has incorrect data format or does
|
||||||
|
¬ contain data'
|
||||||
|
ierr(1)=1
|
||||||
|
goto 630
|
||||||
|
endif
|
||||||
n=0
|
n=0
|
||||||
if(ivector(startline).ne.ivector(startline+1))n=1
|
if(ivector(startline).ne.ivector(startline+1))n=1
|
||||||
if(ivector(startline).ne.ivector(startline+2))n=1
|
if(ivector(startline).ne.ivector(startline+2))n=1
|
||||||
@@ -149,7 +162,7 @@
|
|||||||
read(spareunit,*)
|
read(spareunit,*)
|
||||||
enddo
|
enddo
|
||||||
!=========================================================================================================================
|
!=========================================================================================================================
|
||||||
read(spareunit,fmt=310,err=13)longchar
|
read(spareunit,fmt=310,err=40)longchar
|
||||||
call charlineparser(longchar,nmax,charvars,n)
|
call charlineparser(longchar,nmax,charvars,n)
|
||||||
do j=n+1,nmax
|
do j=n+1,nmax
|
||||||
charvars(j)='-9999'
|
charvars(j)='-9999'
|
||||||
@@ -199,7 +212,7 @@
|
|||||||
do j=1,2
|
do j=1,2
|
||||||
read(spareunit,*)
|
read(spareunit,*)
|
||||||
enddo
|
enddo
|
||||||
read(spareunit,fmt=310,err=36)longchar
|
read(spareunit,fmt=310,err=40)longchar
|
||||||
call charlineparser(longchar,nmax,charvars,n)
|
call charlineparser(longchar,nmax,charvars,n)
|
||||||
do j=n+1,nmax
|
do j=n+1,nmax
|
||||||
charvars(j)='-9999'
|
charvars(j)='-9999'
|
||||||
@@ -235,7 +248,7 @@
|
|||||||
do j=1,2
|
do j=1,2
|
||||||
read(spareunit,*)
|
read(spareunit,*)
|
||||||
enddo
|
enddo
|
||||||
20 read(spareunit,fmt=310,err=39,end=100)longchar
|
20 read(spareunit,fmt=310,err=40,end=100)longchar
|
||||||
call charlineparser(longchar,nmax,charvars,n)
|
call charlineparser(longchar,nmax,charvars,n)
|
||||||
if(n.le.25)goto 20
|
if(n.le.25)goto 20
|
||||||
do j=n+1,nmax
|
do j=n+1,nmax
|
||||||
@@ -323,7 +336,18 @@
|
|||||||
!We assume the user requires mass-based calculations. We convert net photosynthesis,
|
!We assume the user requires mass-based calculations. We convert net photosynthesis,
|
||||||
!transpiration, conductance and PAR from area basis to mass basis. All fitted parameters
|
!transpiration, conductance and PAR from area basis to mass basis. All fitted parameters
|
||||||
!are mass-based. However, mixing area- and mass- based calculations is not allowed.
|
!are mass-based. However, mixing area- and mass- based calculations is not allowed.
|
||||||
if(npoints(i).gt.0.and.isitmassbased(i).eq.0)goto 34
|
if(npoints(i).gt.0.and.isitmassbased(i).eq.0)then
|
||||||
|
if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'Line starting with ',longchar(1:50)
|
||||||
|
write(errorunit,*)'Check Column 33 or 34. Mixing area- and
|
||||||
|
&mass-based measurements is not allowed'
|
||||||
|
ierr(1)=1
|
||||||
|
endif
|
||||||
isitmassbased(i)=1
|
isitmassbased(i)=1
|
||||||
!Convert PAR from umol/m2/s to umol/kg/s. tissuearea is in cm2 and tissuemass in in g
|
!Convert PAR from umol/m2/s to umol/kg/s. tissuearea is in cm2 and tissuemass in in g
|
||||||
PARi_umol=PARi_umol*tissuearea/(tissuemass*10.0d0)
|
PARi_umol=PARi_umol*tissuearea/(tissuemass*10.0d0)
|
||||||
@@ -346,7 +370,18 @@
|
|||||||
CO2i_ppm=((gtc-1.0d-3*transp_mmol/2.0d0)*CO2chamber_ppm-
|
CO2i_ppm=((gtc-1.0d-3*transp_mmol/2.0d0)*CO2chamber_ppm-
|
||||||
&PNcor_umol)/(gtc-1.0d-3*transp_mmol/2.0d0)
|
&PNcor_umol)/(gtc-1.0d-3*transp_mmol/2.0d0)
|
||||||
else
|
else
|
||||||
if(isitmassbased(i).ne.0)goto 34
|
if(isitmassbased(i).ne.0)then
|
||||||
|
if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'Line starting with ',longchar(1:50)
|
||||||
|
write(errorunit,*)'Check Column 33 or 34. Mixing area- and
|
||||||
|
&mass-based measurements is not allowed'
|
||||||
|
ierr(1)=1
|
||||||
|
endif
|
||||||
endif
|
endif
|
||||||
if(isitmassbased(i).eq.0)then
|
if(isitmassbased(i).eq.0)then
|
||||||
term=-100.0d0
|
term=-100.0d0
|
||||||
@@ -356,8 +391,21 @@
|
|||||||
term1=1.0d+10
|
term1=1.0d+10
|
||||||
endif
|
endif
|
||||||
if(PNcor_umol.lt.term.or.PNcor_umol.gt.term1)then
|
if(PNcor_umol.lt.term.or.PNcor_umol.gt.term1)then
|
||||||
ierr(1)=1
|
if(fm_fluoresce.le.0.0d0)then
|
||||||
if(fm_fluoresce.le.0.0d0)return
|
if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'Line starting with ',longchar(1:50), '...
|
||||||
|
&is within the main data body but has no valid photosynthesis data'
|
||||||
|
if(dabs(PNcor_umol+9999.0d0).gt.1.d-6)then
|
||||||
|
write(errorunit,*)'Photosynthesis out of range:'
|
||||||
|
write(errorunit,*)PNcor_umol
|
||||||
|
endif
|
||||||
|
ierr(1)=1
|
||||||
|
endif
|
||||||
else
|
else
|
||||||
if(transp_mmol.gt.0.0d0.and.stom_COND_mol.gt.0.0d0
|
if(transp_mmol.gt.0.0d0.and.stom_COND_mol.gt.0.0d0
|
||||||
&.and.BLCond.gt.0.0d0)then
|
&.and.BLCond.gt.0.0d0)then
|
||||||
@@ -381,13 +429,29 @@
|
|||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
if(CO2i_ppm.le.0.0d0.or.CO2i_ppm.gt.10000.0d0)then
|
if(CO2i_ppm.le.0.0d0.or.CO2i_ppm.gt.10000.0d0)then
|
||||||
! ierr(1)=2
|
! if(ierr(2).gt.0)then
|
||||||
! return
|
! write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
! write(errorunit,*)
|
||||||
|
! &'Please resubmit the data after correcting the following error:'
|
||||||
|
! ierr(2)=-ierr(2)
|
||||||
|
! endif
|
||||||
|
! write(errorunit,*)'Intercellular CO2 (ppm) out of range'
|
||||||
|
! ierr(1)=1
|
||||||
if(fm_fluoresce.le.0.0d0)goto 20
|
if(fm_fluoresce.le.0.0d0)goto 20
|
||||||
endif
|
endif
|
||||||
if(Tleaf_oC.lt.-50.0d0.or.Tleaf_oC.gt.100.0d0)then
|
if(Tleaf_oC.lt.-50.0d0.or.Tleaf_oC.gt.100.0d0)then
|
||||||
ierr(1)=3
|
if(fm_fluoresce.le.0.0d0)then
|
||||||
if(fm_fluoresce.le.0.0d0)return
|
if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'Line starting with ',longchar(1:50), '...
|
||||||
|
&is within the main data body but has no valid leaf temperature'
|
||||||
|
write(errorunit,*)'Leaf temperature (oC) out of range'
|
||||||
|
ierr(1)=1
|
||||||
|
endif
|
||||||
endif
|
endif
|
||||||
if(isitmassbased(i).eq.0)then
|
if(isitmassbased(i).eq.0)then
|
||||||
term1=1.0d+5
|
term1=1.0d+5
|
||||||
@@ -395,15 +459,29 @@
|
|||||||
term1=1.0d+10
|
term1=1.0d+10
|
||||||
endif
|
endif
|
||||||
if(PARi_umol.lt.-10.01d0.or.PARi_umol.gt.term1)then
|
if(PARi_umol.lt.-10.01d0.or.PARi_umol.gt.term1)then
|
||||||
ierr(1)=4
|
if(ierr(2).gt.0)then
|
||||||
return
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'Line starting with ',longchar(1:50), '.....
|
||||||
|
&is within the main data body but has no valid PAR data'
|
||||||
|
write(errorunit,*)'Sample chamber PAR out of range'
|
||||||
|
ierr(1)=1
|
||||||
else
|
else
|
||||||
PARi_umol=dmax1(0.0d0,PARi_umol)
|
PARi_umol=dmax1(0.0d0,PARi_umol)
|
||||||
endif
|
endif
|
||||||
if(Press_KPa.lt.50.0d0.or.Press_KPa.gt.150.0d0)then
|
if(Press_KPa.lt.50.0d0.or.Press_KPa.gt.150.0d0)then
|
||||||
Press_KPa=98.9d0
|
Press_KPa=98.9d0
|
||||||
! ierr(1)=5
|
! if(ierr(2).gt.0)then
|
||||||
! return
|
! write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
! write(errorunit,*)
|
||||||
|
! &'Please resubmit the data after correcting the following error:'
|
||||||
|
! ierr(2)=-ierr(2)
|
||||||
|
! endif
|
||||||
|
! write(errorunit,*)'Air pressure out of range'
|
||||||
|
! ierr(1)=1
|
||||||
endif
|
endif
|
||||||
if(Tair_oC.lt.-50.0d0.or.Tair_oC.gt.100.0d0)then
|
if(Tair_oC.lt.-50.0d0.or.Tair_oC.gt.100.0d0)then
|
||||||
Tair_oC=Tleaf_oC
|
Tair_oC=Tleaf_oC
|
||||||
@@ -483,14 +561,47 @@
|
|||||||
call CharToNumeric(chartime,term)
|
call CharToNumeric(chartime,term)
|
||||||
sampletime(i,npoints(i))=term
|
sampletime(i,npoints(i))=term
|
||||||
goto 20
|
goto 20
|
||||||
100 close(spareunit,status='delete')
|
100 do j=1,npoints(i)
|
||||||
do j=1,npoints(i)
|
|
||||||
vectorhorse(j)=sampletime(i,j)
|
vectorhorse(j)=sampletime(i,j)
|
||||||
call time_resolution(npoints(i),vectorhorse,
|
call time_resolution(npoints(i),vectorhorse,
|
||||||
& avetimeresolution(i),avetimesampled(i))
|
& avetimeresolution(i),avetimesampled(i))
|
||||||
enddo
|
enddo
|
||||||
630 continue
|
630 close(spareunit)
|
||||||
|
goto 640
|
||||||
|
35 if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'This file has incorrect data format'
|
||||||
|
ierr(1)=1
|
||||||
|
close(spareunit)
|
||||||
|
goto 640
|
||||||
|
|
||||||
|
36 if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'This file has incorrect data format'
|
||||||
|
ierr(1)=1
|
||||||
|
close(dataunit,status='delete')
|
||||||
|
goto 640
|
||||||
|
|
||||||
|
40 if(ierr(2).gt.0)then
|
||||||
|
write(errorunit,*)'Input data error in ',trim(ACidata(i))
|
||||||
|
write(errorunit,*)
|
||||||
|
&'Please resubmit the data after correcting the following error:'
|
||||||
|
ierr(2)=-ierr(2)
|
||||||
|
endif
|
||||||
|
write(errorunit,*)'This file has incorrect data format'
|
||||||
|
ierr(1)=1
|
||||||
|
close(spareunit)
|
||||||
|
640 continue
|
||||||
10 enddo
|
10 enddo
|
||||||
|
if(ierr(1).eq.1)return
|
||||||
iprintheader(1)=1
|
iprintheader(1)=1
|
||||||
do i=2,ntotfiles
|
do i=2,ntotfiles
|
||||||
if(isitmassbased(i).eq.isitmassbased(i-1))then
|
if(isitmassbased(i).eq.isitmassbased(i-1))then
|
||||||
@@ -502,7 +613,8 @@
|
|||||||
k=1
|
k=1
|
||||||
do i=1,ntotfiles
|
do i=1,ntotfiles
|
||||||
if(k.eq.1.or.iprintheader(i).eq.1)then
|
if(k.eq.1.or.iprintheader(i).eq.1)then
|
||||||
call LeafGasPrintToFiles(isitmassbased(i:i),indexunit)
|
call LeafGasPrintToFiles(isitmassbased(i:i),indexunit,
|
||||||
|
&ic3c4cam)
|
||||||
k=0
|
k=0
|
||||||
endif
|
endif
|
||||||
if(npoints(i).lt.3)goto 1112
|
if(npoints(i).lt.3)goto 1112
|
||||||
@@ -536,7 +648,30 @@
|
|||||||
endif
|
endif
|
||||||
endif
|
endif
|
||||||
!------------------------------------------------------
|
!------------------------------------------------------
|
||||||
call SetUpLeafGasFit(curveno(i:i),sample(i:i),npoints(i:i),
|
if(ic3c4cam.eq.1)
|
||||||
|
&call SetUpLeafGasFit(curveno(i:i),sample(i:i),npoints(i:i),
|
||||||
|
&CurveTypeID(i:i,1:npoints(i)),yAnet(i:i,1:npoints(i)),
|
||||||
|
&xpco2i(i:i,1:npoints(i)),templeaf(i:i,1:npoints(i)),
|
||||||
|
&pari(i:i,1:npoints(i)),pres_air(i:i,1:npoints(i)),
|
||||||
|
&po2i(i:i,1:npoints(i)),chlflphips2(i:i,1:npoints(i)),
|
||||||
|
&pco2ambient(i:i,1:npoints(i)),trmmol(i:i,1:npoints(i)),
|
||||||
|
&gswmeas(i:i,1:npoints(i)),vpdl(i:i,1:npoints(i)),
|
||||||
|
&tempair(i:i,1:npoints(i)),eambient(i:i,1:npoints(i)),
|
||||||
|
&fo_pam(i:i,1:npoints(i)),fm_pam(i:i,1:npoints(i)),
|
||||||
|
&fs_pam(i:i,1:npoints(i)),pam_measlight(i:i,1:npoints(i)),
|
||||||
|
&stargamma25_usr(i:i),fkc25_usr(i:i),fko25_usr(i:i),
|
||||||
|
&rdlight25_usr(i:i),alpha25_usr(i:i),resistwp25_usr(i:i),
|
||||||
|
&resistch25_usr(i:i),isitmassbased(i:i),indexunit,
|
||||||
|
&siteID(i:i),Latitude(i:i),Longitude(i:i),Elevation(i:i),
|
||||||
|
&yearsampled(i:i),sampledoy(i:i),GrowingSeasonStart(i:i),
|
||||||
|
&GrowingSeasonEnd(i:i),standage(i:i),CanopyHeight(i:i),
|
||||||
|
&LeafAreaIndex(i:i),species(i:i),avetimeresolution(i:i),
|
||||||
|
&avetimesampled(i:i),SampleHeight(i:i),Needleage(i:i),
|
||||||
|
&specificLAI(i:i),nitrogencontent(i:i),carboncontent(i:i),
|
||||||
|
&phoscontent(i:i),woodporosity(i:i),sapwooddensity(i:i),
|
||||||
|
&leafratio(i:i))
|
||||||
|
if(ic3c4cam.eq.2)
|
||||||
|
&call C4SetUpLeafGasFit(curveno(i:i),sample(i:i),npoints(i:i),
|
||||||
&CurveTypeID(i:i,1:npoints(i)),yAnet(i:i,1:npoints(i)),
|
&CurveTypeID(i:i,1:npoints(i)),yAnet(i:i,1:npoints(i)),
|
||||||
&xpco2i(i:i,1:npoints(i)),templeaf(i:i,1:npoints(i)),
|
&xpco2i(i:i,1:npoints(i)),templeaf(i:i,1:npoints(i)),
|
||||||
&pari(i:i,1:npoints(i)),pres_air(i:i,1:npoints(i)),
|
&pari(i:i,1:npoints(i)),pres_air(i:i,1:npoints(i)),
|
||||||
@@ -560,16 +695,6 @@
|
|||||||
1112 continue
|
1112 continue
|
||||||
enddo
|
enddo
|
||||||
return
|
return
|
||||||
13 ierr(1)=13
|
|
||||||
return
|
|
||||||
34 ierr(1)=34
|
|
||||||
return
|
|
||||||
36 ierr(1)=36
|
|
||||||
return
|
|
||||||
39 ierr(1)=39
|
|
||||||
return
|
|
||||||
40 ierr(1)=40
|
|
||||||
return
|
|
||||||
300 format(a50000)
|
300 format(a50000)
|
||||||
310 format(a5000)
|
310 format(a5000)
|
||||||
340 format(a)
|
340 format(a)
|
||||||
|
|||||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user