diff --git a/dataassim/math/algebra/d_svdfit.f b/dataassim/math/algebra/d_svdfit.f new file mode 100644 index 0000000..09da430 --- /dev/null +++ b/dataassim/math/algebra/d_svdfit.f @@ -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 diff --git a/dataassim/math/algebra/d_svdvar.f b/dataassim/math/algebra/d_svdvar.f new file mode 100644 index 0000000..b022927 --- /dev/null +++ b/dataassim/math/algebra/d_svdvar.f @@ -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 diff --git a/dataassim/math/algebra/eigen.f b/dataassim/math/algebra/eigen.f new file mode 100644 index 0000000..39b4195 --- /dev/null +++ b/dataassim/math/algebra/eigen.f @@ -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 diff --git a/dataassim/math/algebra/eigen1.f b/dataassim/math/algebra/eigen1.f new file mode 100644 index 0000000..1dd75b8 --- /dev/null +++ b/dataassim/math/algebra/eigen1.f @@ -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 diff --git a/dataassim/math/algebra/eigen_sym_up.f b/dataassim/math/algebra/eigen_sym_up.f index 953c462..fae8ddf 100644 --- a/dataassim/math/algebra/eigen_sym_up.f +++ b/dataassim/math/algebra/eigen_sym_up.f @@ -48,4 +48,4 @@ enddo !--------------------------------------------- return - end \ No newline at end of file + end diff --git a/dataassim/math/algebra/lfit.f b/dataassim/math/algebra/lfit.f index cceb39b..7229bc2 100644 --- a/dataassim/math/algebra/lfit.f +++ b/dataassim/math/algebra/lfit.f @@ -17,7 +17,6 @@ CU USES covsrt,gaussj ia(j)=1 if(ia(j).ne.0) mfit=mfit+1 11 continue - if(mfit.eq.0) pause 'lfit: no parameters to be fitted' do 13 j=1,mfit do 12 k=1,mfit covar(j,k)=0.0d0 diff --git a/dataassim/math/algebra/matrixoper.f b/dataassim/math/algebra/matrixoper.f index fe04a19..2622001 100644 --- a/dataassim/math/algebra/matrixoper.f +++ b/dataassim/math/algebra/matrixoper.f @@ -255,282 +255,282 @@ end !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x) + SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x) implicit none - INTEGER m,mp,n,np,NMAX - double precision b(mp),u(mp,np),v(np,np),w(np),x(np) - PARAMETER (NMAX=1500) - INTEGER i,j,jj - double precision s,tmp(NMAX) - do 12 j=1,n + INTEGER m,mp,n,np,NMAX + double precision b(mp),u(mp,np),v(np,np),w(np),x(np) + PARAMETER (NMAX=1500) + INTEGER i,j,jj + double precision s,tmp(NMAX) + do 12 j=1,n s=0.0d0 - if(w(j).ne.0.0d0)then - do 11 i=1,m - s=s+u(i,j)*b(i) -11 continue - s=s/w(j) - endif - tmp(j)=s -12 continue - do 14 j=1,n + if(w(j).ne.0.0d0)then + do 11 i=1,m + s=s+u(i,j)*b(i) +11 continue + s=s/w(j) + endif + tmp(j)=s +12 continue + do 14 j=1,n s=0.0d0 - do 13 jj=1,n - s=s+v(j,jj)*tmp(jj) -13 continue - x(j)=s -14 continue - return - END -C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + do 13 jj=1,n + s=s+v(j,jj)*tmp(jj) +13 continue + x(j)=s +14 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. - SUBROUTINE svdcmp(a,m,n,mp,np,w,v,ierr) + SUBROUTINE svdcmp(a,m,n,mp,np,w,v,ierr) implicit none - INTEGER m,mp,n,np,NMAX ,ierr - double precision a(mp,np),v(np,np),w(np) - PARAMETER (NMAX=1500) -CU USES pythag - INTEGER i,its,j,jj,k,l,nm - double precision anorm,c,f,g,h,s,scale,x,y,z, - & rv1(NMAX),pythag + INTEGER m,mp,n,np,NMAX,ierr + double precision a(mp,np),v(np,np),w(np) + PARAMETER (NMAX=1500) +CU USES pythag + INTEGER i,its,j,jj,k,l,nm + double precision anorm,c,f,g,h,s,scaling,x,y,z, + & rv1(NMAX),pythag g=0.0d0 - scale=0.0d0 + scaling=0.0d0 anorm=0.0d0 - do 25 i=1,n - l=i+1 - rv1(i)=scale*g + do 25 i=1,n + l=i+1 + rv1(i)=scaling*g g=0.0d0 s=0.0d0 - scale=0.0d0 - if(i.le.m)then - do 11 k=i,m - scale=scale+dabs(a(k,i)) -11 continue - if(scale.ne.0.0d0)then - do 12 k=i,m - a(k,i)=a(k,i)/scale - s=s+a(k,i)*a(k,i) -12 continue - f=a(i,i) - g=-dsign(dsqrt(s),f) - h=f*g-s - a(i,i)=f-g - do 15 j=l,n + scaling=0.0d0 + if(i.le.m)then + do 11 k=i,m + scaling=scaling+dabs(a(k,i)) +11 continue + if(scaling.ne.0.0d0)then + do 12 k=i,m + a(k,i)=a(k,i)/scaling + s=s+a(k,i)*a(k,i) +12 continue + f=a(i,i) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,i)=f-g + do 15 j=l,n s=0.0d0 - do 13 k=i,m - s=s+a(k,i)*a(k,j) -13 continue - f=s/h - do 14 k=i,m - a(k,j)=a(k,j)+f*a(k,i) -14 continue -15 continue - do 16 k=i,m - a(k,i)=scale*a(k,i) -16 continue - endif - endif - w(i)=scale*g + do 13 k=i,m + s=s+a(k,i)*a(k,j) +13 continue + f=s/h + do 14 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +14 continue +15 continue + do 16 k=i,m + a(k,i)=scaling*a(k,i) +16 continue + endif + endif + w(i)=scaling*g g=0.0d0 s=0.0d0 - scale=0.0d0 - if((i.le.m).and.(i.ne.n))then - do 17 k=l,n - scale=scale+dabs(a(i,k)) -17 continue - if(scale.ne.0.0d0)then - do 18 k=l,n - a(i,k)=a(i,k)/scale - s=s+a(i,k)*a(i,k) -18 continue - f=a(i,l) - g=-dsign(dsqrt(s),f) - h=f*g-s - a(i,l)=f-g - do 19 k=l,n - rv1(k)=a(i,k)/h -19 continue - do 23 j=l,m + scaling=0.0d0 + if((i.le.m).and.(i.ne.n))then + do 17 k=l,n + scaling=scaling+dabs(a(i,k)) +17 continue + if(scaling.ne.0.0d0)then + do 18 k=l,n + a(i,k)=a(i,k)/scaling + s=s+a(i,k)*a(i,k) +18 continue + f=a(i,l) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,l)=f-g + do 19 k=l,n + rv1(k)=a(i,k)/h +19 continue + do 23 j=l,m s=0.0d0 - do 21 k=l,n - s=s+a(j,k)*a(i,k) -21 continue - do 22 k=l,n - a(j,k)=a(j,k)+s*rv1(k) -22 continue -23 continue - do 24 k=l,n - a(i,k)=scale*a(i,k) -24 continue - endif - endif - anorm=dmax1(anorm,(dabs(w(i))+dabs(rv1(i)))) -25 continue - do 32 i=n,1,-1 - if(i.lt.n)then - if(g.ne.0.0d0)then - do 26 j=l,n - v(j,i)=(a(i,j)/a(i,l))/g -26 continue - do 29 j=l,n + do 21 k=l,n + s=s+a(j,k)*a(i,k) +21 continue + do 22 k=l,n + a(j,k)=a(j,k)+s*rv1(k) +22 continue +23 continue + do 24 k=l,n + a(i,k)=scaling*a(i,k) +24 continue + endif + endif + anorm=dmax1(anorm,(dabs(w(i))+dabs(rv1(i)))) +25 continue + do 32 i=n,1,-1 + if(i.lt.n)then + if(g.ne.0.0d0)then + do 26 j=l,n + v(j,i)=(a(i,j)/a(i,l))/g +26 continue + do 29 j=l,n s=0.0d0 - do 27 k=l,n - s=s+a(i,k)*v(k,j) -27 continue - do 28 k=l,n - v(k,j)=v(k,j)+s*v(k,i) -28 continue -29 continue - endif - do 31 j=l,n + do 27 k=l,n + s=s+a(i,k)*v(k,j) +27 continue + do 28 k=l,n + v(k,j)=v(k,j)+s*v(k,i) +28 continue +29 continue + endif + do 31 j=l,n v(i,j)=0.0d0 v(j,i)=0.0d0 -31 continue - endif +31 continue + endif v(i,i)=1.0d0 - g=rv1(i) - l=i -32 continue - do 39 i=min(m,n),1,-1 - l=i+1 - g=w(i) - do 33 j=l,n + g=rv1(i) + l=i +32 continue + do 39 i=min(m,n),1,-1 + l=i+1 + g=w(i) + do 33 j=l,n a(i,j)=0.0d0 -33 continue - if(g.ne.0.0d0)then - g=1.0d0/g - do 36 j=l,n +33 continue + if(g.ne.0.0d0)then + g=1.0d0/g + do 36 j=l,n s=0.0d0 - do 34 k=l,m - s=s+a(k,i)*a(k,j) -34 continue - f=(s/a(i,i))*g - do 35 k=i,m - a(k,j)=a(k,j)+f*a(k,i) -35 continue -36 continue - do 37 j=i,m - a(j,i)=a(j,i)*g -37 continue - else - do 38 j= i,m + do 34 k=l,m + s=s+a(k,i)*a(k,j) +34 continue + f=(s/a(i,i))*g + do 35 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +35 continue +36 continue + do 37 j=i,m + a(j,i)=a(j,i)*g +37 continue + else + do 38 j= i,m a(j,i)=0.0d0 -38 continue - endif +38 continue + endif a(i,i)=a(i,i)+1.0d0 -39 continue - do 49 k=n,1,-1 - do 48 its=1,30 - do 41 l=k,1,-1 - nm=l-1 - if((dabs(rv1(l))+anorm).eq.anorm) goto 2 - if((dabs(w(nm))+anorm).eq.anorm) goto 1 -41 continue +39 continue + do 49 k=n,1,-1 + do 48 its=1,30 + do 41 l=k,1,-1 + nm=l-1 + if((dabs(rv1(l))+anorm).eq.anorm) goto 2 + if((dabs(w(nm))+anorm).eq.anorm) goto 1 +41 continue 1 c=0.0d0 s=1.0d0 - do 43 i=l,k - f=s*rv1(i) - rv1(i)=c*rv1(i) - if((dabs(f)+anorm).eq.anorm) goto 2 - g=w(i) - h=pythag(f,g) - w(i)=h - h=1.0d0/h - c= (g*h) - s=-(f*h) - do 42 j=1,m - y=a(j,nm) - z=a(j,i) - a(j,nm)=(y*c)+(z*s) - a(j,i)=-(y*s)+(z*c) -42 continue -43 continue -2 z=w(k) - if(l.eq.k)then - if(z.lt.0.0d0)then - w(k)=-z - do 44 j=1,n - v(j,k)=-v(j,k) -44 continue - endif - goto 3 - endif + do 43 i=l,k + f=s*rv1(i) + rv1(i)=c*rv1(i) + if((dabs(f)+anorm).eq.anorm) goto 2 + g=w(i) + h=pythag(f,g) + w(i)=h + h=1.0d0/h + c= (g*h) + s=-(f*h) + do 42 j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) +42 continue +43 continue +2 z=w(k) + if(l.eq.k)then + if(z.lt.0.0d0)then + w(k)=-z + do 44 j=1,n + v(j,k)=-v(j,k) +44 continue + endif + goto 3 + endif if(its.eq.30)then ierr=0 return endif - x=w(l) - nm=k-1 - y=w(nm) - g=rv1(nm) - h=rv1(k) - f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y) - g=pythag(f,1.0d0) - f=((x-z)*(x+z)+h*((y/(f+dsign(g,f)))-h))/x + x=w(l) + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y) + g=pythag(f,1.0d0) + f=((x-z)*(x+z)+h*((y/(f+dsign(g,f)))-h))/x c=1.0d0 s=1.0d0 - do 47 j=l,nm - i=j+1 - g=rv1(i) - y=w(i) - h=s*g - g=c*g - z=pythag(f,h) - rv1(j)=z - c=f/z - s=h/z - f= (x*c)+(g*s) - g=-(x*s)+(g*c) - h=y*s - y=y*c - do 45 jj=1,n - x=v(jj,j) - z=v(jj,i) - v(jj,j)= (x*c)+(z*s) - v(jj,i)=-(x*s)+(z*c) -45 continue - z=pythag(f,h) - w(j)=z - if(z.ne.0.0d0)then - z=1.0d0/z - c=f*z - s=h*z - endif - f= (c*g)+(s*y) - x=-(s*g)+(c*y) - do 46 jj=1,m - y=a(jj,j) - z=a(jj,i) - a(jj,j)= (y*c)+(z*s) - a(jj,i)=-(y*s)+(z*c) -46 continue -47 continue + do 47 j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=pythag(f,h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do 45 jj=1,n + x=v(jj,j) + z=v(jj,i) + v(jj,j)= (x*c)+(z*s) + v(jj,i)=-(x*s)+(z*c) +45 continue + z=pythag(f,h) + w(j)=z + if(z.ne.0.0d0)then + z=1.0d0/z + c=f*z + s=h*z + endif + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do 46 jj=1,m + y=a(jj,j) + z=a(jj,i) + a(jj,j)= (y*c)+(z*s) + a(jj,i)=-(y*s)+(z*c) +46 continue +47 continue rv1(l)=0.0d0 - rv1(k)=f - w(k)=x -48 continue -3 continue -49 continue - return - END -C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + rv1(k)=f + w(k)=x +48 continue +3 continue +49 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. - double precision FUNCTION pythag(a,b) + double precision FUNCTION pythag(a,b) double precision a,b - double precision absa,absb - absa=dabs(a) - absb=dabs(b) - if(absa.gt.absb)then - pythag=absa*dsqrt(1.0d0+(absb/absa)**2) - else - if(absb.eq.0.0d0)then + double precision absa,absb + absa=dabs(a) + absb=dabs(b) + if(absa.gt.absb)then + pythag=absa*dsqrt(1.0d0+(absb/absa)**2) + else + if(absb.eq.0.0d0)then pythag=0.0d0 - else - pythag=absb*dsqrt(1.0d0+(absa/absb)**2) - endif - endif - return - END -C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + else + pythag=absb*dsqrt(1.0d0+(absa/absb)**2) + endif + endif + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. subroutine xmprove(N,NP,a,b,x,mark) @@ -687,7 +687,7 @@ CU USES lubksb u(i,j)=a(i,j) enddo enddo - call svdcmp(u(1:n,1:n),n,n,np,np,w,v(1:n,1:n),ierr) + call svdcmp(u(1:n,1:n),n,n,np,np,w,v(1:n,1:n),ierr) wmax=0.0d0 do j=1,n if(w(j).gt.wmax)wmax=w(j) @@ -696,7 +696,7 @@ CU USES lubksb do j=1,n if(w(j).lt.wmin)w(j)=0.0d0 enddo - call svbksb(u(1:n,1:n),w,v(1:n,1:n),n,n,np,np,b,x) + call svbksb(u(1:n,1:n),w,v(1:n,1:n),n,n,np,np,b,x) return end @@ -708,20 +708,20 @@ CU USES lubksb DOUBLE PRECISION a(np,np),c(n),d(n) LOGICAL sing INTEGER i,j,k - DOUBLE PRECISION scale,sigma,sum,tau + DOUBLE PRECISION scaling,sigma,sum,tau sing=.false. do 17 k=1,n-1 - scale=0.0d0 + scaling=0.0d0 do 11 i=k,n - scale=dmax1(scale,dabs(a(i,k))) + scaling=dmax1(scaling,dabs(a(i,k))) 11 continue - if(scale.eq.0.0d0)then + if(scaling.eq.0.0d0)then sing=.true. c(k)=0.0d0 d(k)=0.0d0 else do 12 i=k,n - a(i,k)=a(i,k)/scale + a(i,k)=a(i,k)/scaling 12 continue sum=0.0d0 do 13 i=k,n @@ -730,7 +730,7 @@ CU USES lubksb sigma=dsign(dsqrt(sum),a(k,k)) a(k,k)=a(k,k)+sigma c(k)=sigma*a(k,k) - d(k)=-scale*sigma + d(k)=-scaling*sigma do 16 j=k+1,n sum=0.0d0 do 14 i=k,n @@ -997,4 +997,4 @@ c endif goto 10 end -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& \ No newline at end of file +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& diff --git a/dataassim/math/algebra/test.f b/dataassim/math/algebra/test.f new file mode 100644 index 0000000..2d73c28 --- /dev/null +++ b/dataassim/math/algebra/test.f @@ -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 diff --git a/dataassim/math/nonlinsystems/cpfixedpoint.f b/dataassim/math/nonlinsystems/cpfixedpoint.f index ecdd1b6..88fa0d0 100644 --- a/dataassim/math/nonlinsystems/cpfixedpoint.f +++ b/dataassim/math/nonlinsystems/cpfixedpoint.f @@ -258,7 +258,7 @@ call cplnsrch(nunknowns,xpold,fsqsumold, & gfuncsum,deltax,xp,fsqsumnew,stpmax, & check,funcnleq1,fequ) - if(check.eq..true..or.check.eq..TRUE.)then + if(check.eqv..true..or.check.eqv..TRUE.)then do i=1,nunknowns call reinitialization(x0min(i),xpold(i), & x0max(i),xp(i),6678) diff --git a/dataassim/math/nonlinsystems/d1mach.f b/dataassim/math/nonlinsystems/d1mach.f new file mode 100644 index 0000000..232582a --- /dev/null +++ b/dataassim/math/nonlinsystems/d1mach.f @@ -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 +*#include +*#include +*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 diff --git a/dataassim/math/nonlinsystems/derv1.f b/dataassim/math/nonlinsystems/derv1.f new file mode 100644 index 0000000..3d125e0 --- /dev/null +++ b/dataassim/math/nonlinsystems/derv1.f @@ -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 diff --git a/dataassim/math/nonlinsystems/dnqsol.f b/dataassim/math/nonlinsystems/dnqsol.f new file mode 100644 index 0000000..ad39436 --- /dev/null +++ b/dataassim/math/nonlinsystems/dnqsol.f @@ -0,0 +1,1964 @@ + subroutine DNQSOL(DNQFJ, N, X, FVEC, XTOL, IOPT, W, IDIMW) +c Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +c ALL RIGHTS RESERVED. +c Based on Government Sponsored Research NAS7-03001. +c>> 2001-05-25 DNQSOL Krogh Minor change for making .f90 version. +c>> 2000-12-01 DNQSOL Krogh Removed unused parameter P001. +c>> 1996-05-16 DNQSOL Krogh Changes to use .C. and C%%. +c>> 1996-03-30 DNQSOL Krogh Added external stmts. SIN => VSIN, etc. +c>> 1994-11-02 DNQSOL Krogh Changes to use M77CON +c>> 1992-04-27 DNQSOL CLL Deleted unreferenced stmt label. +c>> 1992-04-07 CAO Extra comma in Print removed (error from VAX compile) +c>> 1992-01-15 CLL +c>> 1991-12-18 CLL & FTK Adding treatment of slow convergence to 0. +c>> 1991-12-05 CLL & FTK Adding Option vector interface. +c>> 1990-04-20 CLL@JPL Adapting code from Minpack for MATH77 +c +c Solves a system of N nonlinear equations in N unknowns. +c DNQSOL is the the user-interface subroutine. It calls DNQSL1 which +c contains the top-level logic of the solution algorithm. +c DNQSOL & DNQSL1 also need: +c Other subroutines that are in this file: +c DNQFDJ, DNQDOG, DNQQFM, DNQQRF, DNQUPD. +c Other subprograms from the MATH77 library: DNRM2, DERV1, +c [D/R]1MACH (Fortan 77 only), IERV1, & IERM1. +C A user-provided subroutine: DNQFJ. +c +c Most of these subprograms are derived from MINPACK-1. +c MINPACK-1, 1980, was developed by Jorge J. More', +c Burton S. Garbow, and Kenneth E. Hillstrom, Argonne Nat'l Lab. +c The MINPACK-1 code was obtained as FILE05 from MINPACK/EX from +c Netlib, downloaded to JPL on Tue Feb 6 12:17:45 EST 1990. +c +c Old Name New Name +c -------- -------- +c HYBRJ1, HYBRD1 DNQSOL (Completely redesigned.) +c HYBRJ, HYBRD DNQSL1 (Algorithm and code changes.) +c DOGLEG DNQDOG +c ENORM DNRM2 in BLAS and MATH77 +c FDJAC1 DNQFDJ +c QFORM DNQQFM +c QRFAC DNQQRF +c R1MPYQ DNQAQ +c R1UPDT DNQUPD +c [D/S]PMPAR [D/R]1MACH in file amach.f (Fortran 77 only) +c FCN DNQFJ +c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Arguments for DNQSOL +c +c call DNQSOL(DNQFJ, N, X, FVEC, XTOL, IOPT, W, IDIMW) +c +c DNQFJ Name of user-supplied subroutine. +c +c N [in] Problem size +c X(N) [inout] Initial and final x-vector. +c FVEC(N) [out] Final F values. +c XTOL [in] Rel. Conv. tolerance on weighted X +c IOPT() [inout] First 3 elements contain output values. +c IOPT(1) = INFO. Output status. +c IOPT(2) = NFEV. No. of F evals used. +c IOPT(3) = NJEV. No. of evals of Jacobian. +c +c Ramaining elements in IOPT() select options. +c +c Option No. of Affected variables Affected variables +c Number arguments in DNQSOL. in DNQSL1. +c 1 0 HAVEJ HAVEJ +c 2 1 DMODE, HAVED, W(4:3+N) HAVED, DIAG(1:N) +c 3 1 NPRINT NPRINT +c 4 1 MAXFEV MAXFEV +c 5 2 ML, MU ML, MU +c 6 0 W(1) EPSFCN +c 7 0 W(2) FACTOR +c 8 0 TRACE TRACE +c +c Functionality of options, listed by option numbers in square brackets. +c [1] If set, user is not computing a Jacobian. +c This subr sets HAVEJ = .false. +c [2] Arg: DMODE = 1, 2, or 3. +c 1. This subr sets DIAG() to all ones and HAVED = .true. +c 2. User has set DIAG(). This subr sets HAVED = .true. +c 3. This subr sets HAVED = .false. so DNQSL1 will set +c DIAG() dynamically. +c [3] Arg: NPRINT Print control. +c [4] Arg: MAXFEV Limit on no. of F evals. +c [5] Args: ML & MU Band structure. +c [6] If set means EPSFCN has been set in W(1). +c [7] If set means FACTOR has been set in W(2). +c [8] If set, this subr sets TRACE = .true., else this subr +c sets TRACE = .false. When TRACE is .true., DNQSL1 prints +c detailed intermediate results. +c +c W() [inout] W(1) and W(2) may be used to pass EPSFCN and FACTOR +c to the subroutine. W(3) contains TOLTST on return. +c W( 4 : 3+(15*N + 3*N**2)/2 ) is used as work space. +c +c EPSFCN W(1) Error in F evals. Used in computing +c approx derivs. +c FACTOR W(2) Algorithm parameter. +c TOLTST W(3) Output. Final value of quantity compared +c with XTOL for convergence test. +c DIAG(N) W(4:N+3) Scaling values. May be input or +c computed. See option 2. +c WA1(N) W() Work space of length N. +c WA2(N) W() Work space of length N. +c WA3(N) W() Work space of length N. +c WA4(N) W() Work space of length N. +c GNSTEP(N) W() Work space of length N. +c QTF(N) W() Wrk space. At end has (Q**t)*F. +c FJAC(N,N) W() Work space for Jacobian. At end has Q of +c QR factorization. +c R( (N + N**2)/2 ) W() Wrk spc. At end has Packed R of +c QR factorization. +c IDIMW [in] Dimension of W(). Require IDIMW .ge. 3+(15*N+3*N**2)/2 +c ------------------------------------------------------------------ +c--D replaces "?": ?NQSOL,?NQSL1,?ERV1,?NQFJ,?NQDOG,?NRM2,?NQFDJ +c--& ?NQQFM,?NQQRF,?NQAQ,?NQUPD +c Also uses IERM1, IERV1 +c ------------------------------------------------------------------ + external D1MACH, DNQFJ + integer N, IOPT(*), IDIMW + double precision X(N), FVEC(N), XTOL, W(IDIMW) +c + integer IWTOLT, IWDIAG, IWA1, IWA2, IWA3, IWA4, IWGNST + integer IWQTF, IWFJAC, IWR + parameter(IWTOLT = 3, IWDIAG = 4 ) + double precision D1MACH, EPSFCN, EPSMCH, FAC1, FACTOR + integer DMODE, J, JABS, K, NI, NPRINT, MAXF1, MAXFEV, ML, MU + logical JPOS, HAVEJ, HAVED, TRACE + parameter(FAC1 = 0.75d0, MAXF1 = 200) + save EPSMCH + data EPSMCH / 0.0d0 / +c ------------------------------------------------------------------ +c + if(EPSMCH .eq. 0.0d0) EPSMCH = D1MACH(4) + NI = N + IOPT(1) = 1 + if (NI .le. 0) then + call IERM1('DNQSOL',IOPT(1),0,'Require N > 0','N',NI,'.') + go to 900 + endif + if (IDIMW .lt. 3 + (NI*(15+3*NI))/2) then + call IERM1('DNQSOL',IOPT(1),0,'Require IDIMW .ge. NEED', + * 'IDIMW',IDIMW,',') + call IERV1('NEED =', 3 + (NI*(15+3*NI))/2,'.') + go to 900 + endif +c Set default values. + HAVEJ = .true. + DMODE = 1 + NPRINT = 0 + MAXFEV = MAXF1 * (NI + 1) + ML = NI - 1 + MU = ML + EPSFCN = EPSMCH + FACTOR = FAC1 + TRACE = .false. +c +c Loop on K beginning with K = 4 and +c terminating when an option code, J, is zero. + K = 4 + 20 continue + J = IOPT(K) + JABS = abs(J) + JPOS = J .gt. 0 + go to (40, 31, 32, 33, 34, 35, 36, 37, 38), JABS+1 +c +c ANSI Standard Fortran 77 drops thru to here if JABS is +c larger than 7. This is an error condition. +c + call IERM1('DNQSOL',IOPT(1),0,'IOPT(K) must be in [-7..7]', + * 'K',K,',') + call IERV1('IOPT(K)',J,'.') + go to 900 +c + 31 HAVEJ = .not. JPOS + K = K+1 + go to 20 +c Option 2. Argument = 1, 2, or 3. Default = 1. +c 1. This subr sets DIAG() to all ones. +c 2. User has set DIAG(). +c 3. Subr DNQSL1 sets DIAG() dynamically. + + 32 if( JPOS .and. IOPT(K+1) .eq. 2) then + DMODE = 2 + elseif( JPOS .and. IOPT(K+1) .eq. 3) then + DMODE = 3 + elseif(.not. JPOS .or. IOPT(K+1) .eq. 1) then + DMODE = 1 + else +c Error. + call IERM1('DNQSOL',IOPT(1),0,'Bad argument for Option 2.', + * 'Argument',IOPT(K+1),'.') + go to 900 + endif + K = K+2 + go to 20 + 33 if(JPOS) then + NPRINT = IOPT(K+1) + else + NPRINT = 0 + endif + K = K+2 + go to 20 + 34 if(JPOS) then + MAXFEV = IOPT(K+1) + else + MAXFEV = MAXF1 * (NI + 1) + endif + K = K+2 + go to 20 + 35 if(JPOS) then + ML = IOPT(K+1) + MU = IOPT(K+2) + else + ML = NI+1 + MU = ML + endif + K = K+3 + go to 20 + 36 if(JPOS) then + EPSFCN = W(1) + else + EPSFCN = EPSMCH + endif + K = K+1 + go to 20 + 37 If(JPOS) then + FACTOR = W(2) + else + FACTOR = FAC1 + endif + K = K+1 + go to 20 + 38 If(JPOS) then + TRACE = .true. + else + TRACE = .false. + endif + K = K+1 + go to 20 +c End loop on K + 40 continue +c +c Option 2. DMODE = 1, 2, or 3. +c 1. This subr sets DIAG() to all ones. +c 2. User has set DIAG(). +c 3. Subr DNQSL1 sets DIAG() dynamically. + + if(DMODE .eq. 1) then + HAVED = .true. + do 50 K = IWDIAG, IWDIAG+NI-1 + W(K) = 1.0d0 + 50 continue + else + HAVED = DMODE .eq. 2 + endif +c + IWA1 = IWDIAG + NI + IWA2 = IWA1 + NI + IWA3 = IWA2 + NI + IWA4 = IWA3 + NI + IWGNST = IWA4 + NI + IWQTF = IWGNST + NI + IWFJAC = IWQTF + NI + IWR = IWFJAC + NI*NI +c IWNEXT = IWR + (N * (N+1)) / 2 Next available loc in W(). +c + call DNQSL1(DNQFJ, NI, X, FVEC, XTOL, + 1 IOPT(1), IOPT(2), IOPT(3), + 2 NPRINT, HAVEJ, MAXFEV, HAVED, ML, MU, + 3 EPSFCN, FACTOR, TRACE, W(IWTOLT), W(IWDIAG), + 4 W(IWA1), W(IWA2), W(IWA3), W(IWA4), W(IWGNST), W(IWQTF), + 5 W(IWFJAC), W(IWR)) + return +c Error return + 900 continue + IOPT(2) = 0 + IOPT(3) = 0 + W(3) = 0.0d0 + return + end +c ================================================================== + subroutine DNQSL1(DNQFJ, N, X, FVEC, XTOL, + * INFO, NFEV, NJEV, + * NPRINT, HAVEJ, MAXFEV, HAVED, ML, MU, + * EPSFCN, FACTOR, TRACE, TOLTST, DIAG, + * WA1, WA2, WA3, WA4, GNSTEP, QTF, FJAC, R) +c>> 1991-12-04 CLL +c>> 1991-12-02 CLL +c>> 1991-06-18 CLL@JPL Adapting code from Minpack for MATH77 + +c 26 arguments. +c Dimension of R() must be (N + N**2)/2. +c Total space occupied by EPSFCN, FACTOR, and TOLTST through R is +c 3 + (15*N + 3*N**2)/2 + + external DNQFJ + integer N, MAXFEV, NPRINT, INFO, NFEV, NJEV, ML, MU + logical HAVEJ, HAVED, TRACE + double precision XTOL, EPSFCN, FACTOR, TOLTST + double precision X(N), FVEC(N), FJAC(N,N), DIAG(N), R(*) + double precision QTF(N), WA1(N), WA2(N), WA3(N), WA4(N) + double precision GNSTEP(N) +C ********** +C +C SUBROUTINE DNQSL1 +C +C THE PURPOSE OF DNQSL1 IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS and THE JACOBIAN. +C +C ------------------------------------------------------------------ +c Arguments +c +c DNQFJ is THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +c CALCULATES THE FUNCTIONS and THE JACOBIAN. DNQFJ MUST +c BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +c CALLING PROGRAM. DNQFJ will not be called with IFLAG = 2 +c if HAVEJ is .false. DNQFJ will not be called with IFLAG = 0 +c if NPRINT is <= 0. +c DNQFJ is specified as follows: +C +c subroutine DNQFJ(N, X, FVEC, FJAC, IFLAG) +c integer N, IFLAG +c double precision X(N), FVEC(N), FJAC(N,N) +c ---------- +c if IFLAG = 0, Print X() and FVEC() and return. +c IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +c RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +c IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +c RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +c Set IFLAG to a negative value to force an immediate +c termination of the solution procedure. Otherwise do not +c alter IFLAG. +c --------- +c RETURN +c END +C +c N is A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +c OF FUNCTIONS and VARIABLES. +C +c X is AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +c AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +c CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +c FVEC is AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +c THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +c XTOL is A NONNEGATIVE INPUT VARIABLE. TERMINATION +c OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +c ITERATES is AT MOST XTOL. +C +c INFO [integer,out] If the user has terminated execution by setting +c IFLAG negative in DNQFJ, INFO is set to IFLAG. +c Otherwise, INFO is set as follows: +C +c INFO = 0 Successful termination. Radius of trust region has +c been reduced to at most max(XTOL, machine precision). +C +c INFO = 1 IMPROPER INPUT PARAMETERS. +C +c INFO = 2 Number of calls to DNQFJ for function evaluations has +c reached MAXFEV. +C +c INFO = 3 XTOL is TOO SMALL. NO FURTHER IMPROVEMENT IN +c THE APPROXIMATE SOLUTION X is POSSIBLE. +C +c INFO = 4 Iteration is not making good progress, as +c measured by the improvement through the last +c five Jacobian evaluations. +C +c INFO = 5 Iteration is not making good progress, as +c measured by the improvement through last +c ten function evaluations. +C +c NFEV [out,integer] The number of calls to DNQFJ with IFLAG = 1. +C +c NJEV [out,integer] The number of evaluations of the Jacobian matrix. +c If HAVEJ is .true. this will be the number of calls to DNQFJ with +c IFLAG = 2. Otherwise it is the number of times the Jacobian has +c been approximately computed by differencing. +C +c NPRINT [in, integer] Enables controlled printing of iterates if it +c is positive. In this case, DNQFJ is called with IFLAG = 0 at the +c beginning of the first iteration and every NPRINTth time a new X +c vector is accepted as an improvement, and at termination. +c On these calls the new best X and FVEC are made available for +c printing. FVEC and FJAC should not be altered. +c If NPRINT is not positive, no special calls to DNQFJ with +c IFLAG = 0 will be made. +C +c HAVEJ [in, logical] True means the user subroutine DNQFJ contains +c code for computing the Jacobian matrix, and false means it does +c not. +c +c MAXFEV is A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +c OCCURS WHEN THE NUMBER OF CALLS TO DNQFJ WITH IFLAG = 1 +c HAS REACHED MAXFEV. +C +c HAVED = true means initial values of DIAG() are given by the +c calling program. False means this subroutine must compute +c initial values of DIAG(). It will set DIAG(j) = the euclidean +c norm of column j, unless this is zero, in which case it will +c set DIAG(j) = 0.0. +C +c ML and MU specify the band structure, if any, of the Jacobian +c matrix. All nonzero elements of the Jacobian matrix lie +c within the first ML subdiagonals, the main diagonal, and the +c first MU superdiagonals. +c ML and MU are only used when HAVEJ is .false. and are only useful +c if ML+MU+1 < N. In this case they are used to +c reduce the number of function evaluations in estimating +c derivatives. If the Jacobian has no band structure set +c ML = MU = N-1. +C +c EPSFCN is an input variable used in determining a suitable +c step length for the forward-difference approximation. This +c approximation assumes that the relative errors in the +c functions are of the order of max(EPSFCN, Machine precision). +C +c FACTOR is a positive input variable used in determining the +c initial step bound. This bound is set to the product of +c FACTOR and the euclidean norm of DIAG*X if nonzero, or else +c to FACTOR itself. In most cases FACTOR should lie in the +c interval (0.1, 10.0). Default: FACTOR = 0.75. +C +c TRACE [in, logical] If true, this subr will print detailed +c intermediate output. Otherwise it will not. +c +c TOLTST [out] Final value of quantity that is compared with +c XTOL for convergence test. +c +c DIAG is an array of length N. If HAVED = false, +c DIAG is internally set. If HAVED = true, DIAG() +c MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +c MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +c WA1, WA2, WA3, and WA4 are work arrays of length N. +c +c GNSTEP() [scratch] Work array of length N to save the +c Gauss-Newton step vector computed in DNQDOG. +c +c QTF is AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +c THE VECTOR (Q TRANSPOSE)*FVEC. +C +c FJAC is AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +c ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION +c OF THE FINAL APPROXIMATE JACOBIAN. +C +c R is AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE packed +c UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION +c OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. +C -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... DNQFJ +C +C MINPACK-SUPPLIED ... DNQDOG,D1MACH,DNRM2,DNQFDJ, +C DNQQFM,DNQQRF,DNQAQ,DNQUPD +C +C FORTRAN-SUPPLIED ... abs,max,min,mod +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE' +c Argonne Reports: ANL-80-68 and ANL-80-74, 1980. +C +c 1991-12-09 CLL at JPL. Replacing integer argument MODE that had +c values 2 or 1 with logical argument HAVED related to MODE by +c HAVED = MODE .eq. 2. Thus the user must set HAVED = .true. when +c supplying the DIAG() values, and .false. otherwise. +C ********** +c ------------------------------------------------------------------ +c Description of some of the local variables. +c +c DELTA [flpt] Diameter of trust region. +c HLIM0 [flpt] Upper limit on DELTA when working with a computed +c Jacobian. +c HLIM1 [flpt] Upper limit on DELTA when working with an updated +c Jacobian. +c JACT [integer] Can have values of COMPUT, UPDATE, or KEEP. +c Initially set to COMPUT. At the beginning of the main loop +c we either compute a new Jacobian, update the Jacobian, or keep +c the old Jacobian, depending on the setting of JACT. +c JACT0 [integer] Saves the value of JACT at the beginning of the +c main loop. As JACT gets changed in the loop, JACT0 is still +c available as a record of what it was at the beginning of the loop. +c JEVAL [logical] Set true whenever the Jacobian is computed, and set +c false when it is updated. +c NBEST [integer] Counter, incremented each time an x-vector is +c accepted as being a better approximation to the solution. Used +c in connection with NPRINT to trigger calles to DNQFJ for printing. +c NCFAIL [integer] Counts consecutive "failed" steps since the last +c computation of the Jacobian. NCFAIL is set to 0 when the Jacobian +c is computed or when a step "succeeds" in the sense that +c RATIO .ge. 0.1. It is incremented when RATIO .lt. 0.1. +c NLOOP [integer] Counter for main iteration loop. +c NUPDAT [integer] Counts number of consecutive times the Jacobian +c matrix is updated. +c TRYZER [logical] Initially set to true. While true, the algorithm +c will monitor X's to see if they seem to be all approaching zero. +c If so will try setting them all to zero. If this gives an exactly +c zero function vector then we are finished. If not, we set TRYZER +c to false and restore X to its previous value (even if the function +c value at X = 0 was an improvement) and omit any further testing +c for X's approaching zero. (We tryed accepting the X reached by +c this exceptional step if the function value was an improvement, +c but in one test case this caused the algorithm to end at a local +c nonzero minimum rather than finding a zero.) +c ------------------------------------------------------------------ + external D1MACH, DNRM2 + integer COMPUT, I, IFLAG, IWA(1), J, JACT, JACT0 + integer KEEP, L, LDFJAC, LR + integer MSUM, NBEST, NCFAIL, NCSUC, NEXTPR + integer NLOOP, NSLOW1, NSLOW2, NUMNWT, NUPDAT, UPDATE + logical JEVAL, NEWX, NEWTOK, SING, TRYZER + double precision D1MACH,DNRM2 + double precision ACTRED,DELTA,EPSMCH,FNORM,FNORM1, HLIM0, HLIM1 + double precision ONE,PNORM, PRERED,P1,P5,P0001,RATIO + double precision SUM,TEMP,XNORM, ZERO + parameter(COMPUT = 1, UPDATE = 2, KEEP = 3) + parameter(ONE = 1.0d0, P1 = 0.1d0, P5 = 0.5d0) + parameter(P0001 = 0.0001d0, ZERO = 0.0d0) + save EPSMCH + data EPSMCH /0.0d0 / +c ------------------------------------------------------------------ +C Set EPSMCH to the machine precision. +C + if(EPSMCH .eq. 0.0d0) EPSMCH = D1MACH(4) +C +C Initialize values of output arguments. +C + INFO = 1 + NFEV = 0 + NJEV = 0 + TOLTST = 0.0d0 + TRYZER = .true. +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C We assume the condition N > 0 has already been checked in +c the user-interface subroutine that called this one. + + IF ( XTOL .lt. ZERO .or. MAXFEV .le. 0 + * .or. FACTOR .le. ZERO ) then + call IERM1('DNQSL1',INFO,0, + * 'Require MAXFEV > 0, XTOL .gt. 0.0, FACTOR > 0.0', + * 'MAXFEV',MAXFEV,',') + call DERV1('XTOL',XTOL,',') + call DERV1('FACTOR',FACTOR,'.') + go to 300 + endif + if( .not. HAVEJ .and. (ML .lt. 0 .or. MU .lt. 0)) then + call IERM1('DNQSL1',INFO,0, + * 'With HAVEJ false, require ML .ge. 0 and MU .ge. 0', + * 'ML',ML,',') + call IERV1('MU',MU,',') + go to 300 + endif +c HAVED = true means the user has set DIAG(). + IF ( HAVED ) then + DO 10 J = 1, N + IF (DIAG(J) .le. ZERO) then + call IERM1('DNQSL1',INFO,0, + * 'With HAVED = .true., require all DIAG(J) > 0.0', + * 'J',J,',') + call DERV1('DIAG(J)',DIAG(J),'.') + go to 300 + endif + 10 CONTINUE + endif +c Initialize algorithm variables. + INFO = 0 + JACT = COMPUT + LDFJAC = N + LR = (N*(N+1)) / 2 + MSUM = min(ML + MU + 1, N) + NBEST = 1 + NCSUC = 0 + NEXTPR = 1 + NLOOP = 0 + NSLOW1 = 0 + NSLOW2 = 0 + NUMNWT = 0 +C +C Evaluate the function at the starting point. +C Calculate and test its norm. +C + IFLAG = 1 +C%% (*dnqfj)( n, x, fvec, fjac, &iflag ); + CALL DNQFJ(N, X, FVEC, FJAC, IFLAG) + NFEV = 1 + IF (IFLAG .lt. 0) GO TO 300 + FNORM = DNRM2(N,FVEC,1) + if(TRACE) then + print'(1x,i5,a/(6x,5g15.6))',NLOOP, + * ' Initial X:',(X(J),J=1,N) + print'(1x,5x,a,g15.6)', + * ' Initial FNORM:',FNORM + endif + if(FNORM .eq. 0.0d0) then + go to 300 + endif +C +C Beginning of main loop. +C + 30 continue + NLOOP = NLOOP + 1 + JACT0 = JACT +C +C Compute, Update, or Keep Jacobian, depending on JACT. +C + if (JACT .eq. COMPUT) then + JEVAL = .TRUE. + NUPDAT = 0 + NCFAIL = 0 +C +C CALCULATE THE JACOBIAN MATRIX. +C + if(TRACE) print'(1x,i5,a)',NLOOP, + * ' Computing new Jacobian matrix.' + NJEV = NJEV + 1 + if(HAVEJ) then + IFLAG = 2 +C%% (*dnqfj)( n, x, fvec, fjac, &iflag ); + CALL DNQFJ(N, X, FVEC, FJAC, IFLAG) + else + CALL DNQFDJ(DNQFJ,N,X,FVEC,FJAC,LDFJAC, + * IFLAG,ML,MU,EPSFCN,WA1, WA2) + NFEV = NFEV + MSUM + endif + IF (IFLAG .lt. 0) GO TO 300 +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL DNQQRF(N,N,FJAC,LDFJAC, .false., IWA,1,WA1,WA2,WA3) +C +C On the first iteration and if HAVED is .false., scale according +C to the norms of the columns of the initial Jacobian. +C Also on the first iteration calculate the norm of the scaled X +C and initialize the trust region diameter, DELTA. +C + IF (NLOOP .eq. 1) then + IF ( .not. HAVED ) then + DO 40 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .eq. ZERO) DIAG(J) = ONE + 40 CONTINUE + endif +C + DO 60 J = 1, N + WA3(J) = DIAG(J)*X(J) + 60 CONTINUE + XNORM = DNRM2(N,WA3,1) + DELTA = FACTOR*XNORM + IF (DELTA .eq. ZERO) DELTA = FACTOR + endif +C +C FORM (Q TRANSPOSE)*FVEC and STORE IN QTF. +C + DO 80 I = 1, N + QTF(I) = FVEC(I) + 80 CONTINUE + DO 120 J = 1, N + IF (FJAC(J,J) .eq. ZERO) GO TO 110 + SUM = ZERO + DO 90 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 90 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 100 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +C +C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. +c The diagonal elts come from WA1(). The strictly upper +c triangular elts come from FJAC(,). The upper triangular matrix +c will be stored, packed by rows, in R(). +C + SING = .FALSE. + DO 150 J = 1, N + L = J + DO 130 I = 1, J-1 + R(L) = FJAC(I,J) + L = L + N - I + 130 CONTINUE + R(L) = WA1(J) + IF (WA1(J) .eq. ZERO) SING = .true. + 150 CONTINUE +C +C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. +C + CALL DNQQFM(N,N,FJAC,LDFJAC,WA1) +C +C RESCALE IF NECESSARY. +C + if ( .not. HAVED ) then + DO 160 J = 1, N + DIAG(J) = max(DIAG(J),WA2(J)) + 160 CONTINUE + endif +c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + elseif(JACT .eq. UPDATE) then + +C +C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN +C and UPDATE QTF IF NECESSARY. +C + if(TRACE) print'(1x,i5,a)',NLOOP, + * ' Updating Jacobian matrix.' + NUPDAT = NUPDAT + 1 + JEVAL = .FALSE. + DO 280 J = 1, N + SUM = ZERO + DO 270 I = 1, N + SUM = SUM + FJAC(I,J)*WA4(I) + 270 CONTINUE + WA2(J) = (SUM - WA3(J))/PNORM + WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) + IF (RATIO .ge. P0001) QTF(J) = SUM + 280 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. +C + CALL DNQUPD(N,N,R,LR,WA1,WA2,WA3,SING) + CALL DNQAQ(N,N,FJAC,LDFJAC,WA2,WA3) + CALL DNQAQ(1,N,QTF,1,WA2,WA3) + else + if(TRACE) print'(1x,i5,a)',NLOOP, + * ' Keeping Jacobian matrix unchanged.' + endif +C +C Now have a new or updated or retained Jacobian matrix. +C +C IF REQUESTED, CALL DNQFJ TO ENABLE PRINTING OF ITERATES. +C + if (NPRINT .gt. 0) then + if (NBEST .eq. NEXTPR) then + IFLAG = 0 +C%% (*dnqfj)( n, x, fvec, fjac, &iflag ); + CALL DNQFJ(N, X, FVEC, FJAC, IFLAG) + IF (IFLAG .lt. 0) GO TO 300 + NEXTPR = NEXTPR + NPRINT + endif + endif +C +C Determine the direction P, using a dogleg method, and +c returning -P in WA1(). +C + CALL DNQDOG(N,R,LR,DIAG,QTF,DELTA,WA1,NEWTOK,WA2,WA3, + * JACT0 .eq. KEEP, GNSTEP) +c +c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(TRYZER) then +c NUMNWT counts number of consecutive +c full Newton steps. + if(NEWTOK) then + NUMNWT = NUMNWT + 1 + else + NUMNWT = 0 + endif +c +c Test for convergence of some x components toward 0. +c If this seems to be happening try setting such +c components to 0. +c + if(NUMNWT .ge. 5 .and. NCSUC .ge. 4) then + NUMNWT = 0 + do 204 J = 1,N + WA2(J) = X(J) - WA1(J) + if(abs(WA2(J)) .le. 0.75d0 * abs(X(J)) ) then + WA2(J) = 0.0d0 + else + go to 203 + endif + 204 continue + if(TRACE) print'(1x,i5,a)',NLOOP, + * ' Trial setting of X() to zero.' +C +C EVALUATE THE FUNCTION AT WA2() and CALCULATE ITS NORM. +C + IFLAG = 1 +c%% (*dnqfj)( n, wa2, wa4, fjac, &iflag ); + CALL DNQFJ(N, WA2, WA4, FJAC, IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .lt. 0) GO TO 300 + FNORM1 = DNRM2(N,WA4,1) + if(TRACE) print'(1x,i5,a,g15.6)',NLOOP, + * ' FNORM1 = ', FNORM1 + if(FNORM1 .eq. 0.0d0) then +c +C Accept new point as final solution. +c Update X() and FVEC() and go to termination. +C + INFO = 0 + TOLTST = 0.0d0 + do 201 J = 1, N + X(J) = WA2(J) + FVEC(J) = WA4(J) + 201 continue + if(TRACE) print'(1x,i5,a,(6x,5g15.6))',NLOOP, + * ' Accepting X = all zeros.' + go to 300 + else + TRYZER = .false. + endif + endif +c The following "endif" matches "if(TRYZER)then" + endif +c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C +C STORE THE DIRECTION P and X + P. CALCULATE THE NORM OF P. +C + 203 continue + DO 200 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 200 continue + + PNORM = DNRM2(N,WA3,1) + if(TRACE) then + print'(1x,i5,a,/1x,5x,2g15.6)',NLOOP, + * ' DELTA PNORM',DELTA,PNORM + print'(6x,a/(6x,5g15.6))',' Trial X:',(WA2(J),J=1,N) + endif +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (NLOOP .eq. 1) then + DELTA = min(DELTA,PNORM) + HLIM0 = DELTA + HLIM1 = DELTA + endif +C +C EVALUATE THE FUNCTION AT X + P and CALCULATE ITS NORM. +C + IFLAG = 1 +c%% (*dnqfj)( n, wa2, wa4, fjac, &iflag ); + CALL DNQFJ(N, WA2, WA4, FJAC, IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .lt. 0) GO TO 300 + FNORM1 = DNRM2(N,WA4,1) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (FNORM1 .lt. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION. +C + L = 1 + DO 220 I = 1, N + SUM = ZERO + DO 210 J = I, N + SUM = SUM + R(L)*WA1(J) + L = L + 1 + 210 CONTINUE + WA3(I) = QTF(I) + SUM + 220 CONTINUE + TEMP = DNRM2(N,WA3,1) + PRERED = ZERO + IF (TEMP .lt. FNORM) PRERED = ONE - (TEMP/FNORM)**2 +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .gt. ZERO) RATIO = ACTRED/PRERED + if(TRACE) print'(1x,i5,a,/1x,5x,4g15.6)',NLOOP, + * ' FNORM1 ACTRED PRERED RATIO', + * FNORM1,ACTRED,PRERED,RATIO +C +c Analyze RATIO, NCSUC and JEVAL to decide on accepting or +c rejecting the new X, and assigning new values to +c NCSUC, JACT, and DELTA. +c + if( RATIO .lt. 0.0000D0) then + NCSUC = 0 + NCFAIL = NCFAIL + 1 + NEWX = .false. + if(JEVAL) HLIM0 = min(HLIM0, 0.707107d0 * PNORM) + HLIM1 = min(HLIM1, 0.707107d0 * PNORM) + if( JEVAL .or. (NCFAIL .le. 1 .and. NUPDAT .le. 2)) then + JACT = KEEP + DELTA = 0.5d0 * PNORM + else + JACT = COMPUT + DELTA = HLIM0 + endif + elseif( RATIO .lt. 0.1D0) then + NCSUC = 0 + NCFAIL = NCFAIL + 1 + NEWX = .true. + if(NCFAIL .le. 1 .and. NUPDAT .le. 2) then + JACT = UPDATE + DELTA = 0.5d0 * PNORM + else + JACT = COMPUT + DELTA = HLIM0 + endif + else +c Here we have RATIO .ge. 0.1 + NCSUC = NCSUC + 1 + NCFAIL = 0 + NEWX = .true. + JACT = UPDATE + if(RATIO .lt. 0.5d0) then + if(NCSUC .ge. 5) + * HLIM1 = max(HLIM1, 1.414214d0 * PNORM) + if(NCSUC .ge. 2) + * DELTA = min(HLIM1, max(DELTA, 1.414214d0 * PNORM)) + elseif(RATIO .lt. 0.9d0) then + if(JACT0 .eq. COMPUT) + * HLIM0 = max(HLIM0, 1.414214d0 * PNORM) + if(NCSUC .ge. 4) + * HLIM1 = max(HLIM1, 1.414214d0 * PNORM) + if(NCSUC .ge. 2) + * DELTA = min(HLIM1, max(DELTA, 1.414214d0 * PNORM)) + elseif(RATIO .lt. 1.1d0) then + if(JACT0 .eq. COMPUT) + * HLIM0 = max(HLIM0, 2.0d0 * PNORM) + if(NCSUC .eq. 1) then + DELTA = 1.414214d0 * PNORM + else + DELTA = 2.0d0 * PNORM + endif + HLIM1 = max(HLIM1, DELTA) + endif + endif + HLIM0 = max(HLIM0, HLIM1) + if(TRACE) print'(1x,i5,a,a,/1x,5x,3i8,3g13.4)',NLOOP, + * ' NCSUC NCFAIL NUPDAT', + * ' DELTA HLIM0 HLIM1', + * NCSUC, NCFAIL, NUPDAT, DELTA,HLIM0, HLIM1 +C + if(NEWX) then +c Accept new X, FVEC, and their norms. + DO 250 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + FVEC(J) = WA4(J) + 250 CONTINUE + XNORM = DNRM2(N,WA2,1) + FNORM = FNORM1 + NBEST = NBEST + 1 + if(TRACE) print'(1x,i5,a,g15.6)',NLOOP, + * ' Accepting new X with XNORM = ',XNORM + endif +C +C DETERMINE THE PROGRESS OF THE ITERATION. +C + if( ACTRED .ge. 0.001d0) then + NSLOW1 = 0 + else + NSLOW1 = NSLOW1 + 1 + endif + if( ACTRED .ge. 0.1d0) then + NSLOW2 = 0 + elseif( JACT0 .eq. COMPUT) then + NSLOW2 = NSLOW2 + 1 + endif + if(TRACE) print'(1x,i5,a,/1x,5x,2(i11,4x))',NLOOP, + * ' NSLOW1 NSLOW2', + * NSLOW1, NSLOW2 +C +C TEST FOR CONVERGENCE. +C + IF (DELTA .le. XTOL*XNORM .or. FNORM .eq. ZERO) then + INFO = 0 + if(TRACE) print'(1x,i5,a,/1x,5x,i14,g15.6)',NLOOP, + * ' INFO XNORM', INFO, XNORM + go to 295 + endif +C +C TESTS FOR TERMINATION and STRINGENT TOLERANCES. +C + IF (NFEV .ge. MAXFEV) INFO = 2 + IF (P1*max(P1*DELTA,PNORM) .le. EPSMCH*XNORM) INFO = 3 + IF (NSLOW2 .eq. 5) INFO = 4 + IF (NSLOW1 .eq. 10) INFO = 5 + IF (INFO .ne. 0) then + if(TRACE) print'(1x,i5,a,/1x,5x,i14,g15.6)',NLOOP, + * ' INFO XNORM', INFO, XNORM + call IERM1('DNQSL1',INFO, 0,'Unsuccessful termination.', + * 'INFO',INFO,'.') + go to 295 + endif + go to 30 +C End of main loop. +C +c Come to following stmt when INFO has been set to +c 2, 3, 4, or 5, or to 0 due to successful XTOL test. + 295 continue + if(XNORM .ne. 0.0d0) then + TOLTST = DELTA / XNORM + else + TOLTST = DELTA + endif +c +c Jump to following statement with IFLAG negative +c or INFO = 1 or INFO = 0 due to FNORM being zero. +c Here we have TOLTST = 0.0. + 300 continue +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .lt. 0) INFO = IFLAG + if(TRACE) print'(1x,i5,a,i3)',NLOOP, + * ' Quitting with INFO = ',INFO + IFLAG = 0 +c%% if (nprint > 0) (*dnqfj)( n, x, fvec, fjac, &iflag ); + IF (NPRINT .gt. 0) CALL DNQFJ(N,X,FVEC,FJAC, IFLAG) + if(INFO .lt. 0) then + call IERM1('DNQSL1',INFO, 0, + * 'Quitting because user code set IFLAG negative.', + * 'IFLAG',INFO,'.') + endif + return +C +C Last line of subroutine DNQSL1. +C + END +c ================================================================== + subroutine DNQFDJ(DNQFJ,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, + * WA1,WA2) +c>> 1991-12-04 CLL Changed arg list of user supplied subroutine. +c>> 1991-06-18 CLL@JPL Adapting code from Minpack for MATH77 + external DNQFJ + integer N,LDFJAC,IFLAG,ML,MU + double precision EPSFCN + double precision X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N) +C ********** +C +C SUBROUTINE DNQFDJ +C +C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION +C TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED +C PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS +C A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY +C APPROXIMATING THE NONZERO TERMS. +C +C THE SUBROUTINE STATEMENT IS +C +C subroutine DNQFDJ(DNQFJ,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, +C WA1,WA2) +C +C WHERE +C +C DNQFJ IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. DNQFJ MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, and SHOULD BE WRITTEN AS FOLLOWS. +C +C subroutine DNQFJ(N,X,FVEC,IFLAG) +C integer N,IFLAG +C double precision X(N),FVEC(N) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY DNQFJ UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF DNQFDJ. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS and VARIABLES. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C FUNCTIONS EVALUATED AT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE +C THE EXECUTION OF DNQFDJ. SEE DESCRIPTION OF DNQFJ. +C +C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C ML TO AT LEAST N - 1. +C +C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C MU TO AT LEAST N - 1. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C WA1 and WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT +C LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, and WA2 IS +C NOT REFERENCED. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... D1MACH +C +C FORTRAN-SUPPLIED ... abs,max,sqrt +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** +c ------------------------------------------------------------------ + external D1MACH + integer I,J,K,MSUM + double precision EPS,EPSMCH,H,TEMP,ZERO +c++ CODE for ~.C. is active + double precision DUMMY(1,1) +c++ CODE for .C. & (.N. == 'S') is inactive +c%% float *dummy; +c++ CODE for .C. & (.N. == 'D') is inactive +c%% double *dummy; +C++ End + double precision D1MACH + parameter(ZERO = 0.0d0) +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = D1MACH(4) +C + EPS = sqrt(max(EPSFCN,EPSMCH)) + IFLAG = 1 + MSUM = ML + MU + 1 + IF (MSUM .lt. N) GO TO 40 +C +C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. +C + DO 20 J = 1, N + TEMP = X(J) + H = EPS*abs(TEMP) + IF (H .eq. ZERO) H = EPS + X(J) = TEMP + H +c%% (*dnqfj)( n, x, wa1, dummy, iflag ); + CALL DNQFJ(N, X, WA1, DUMMY, IFLAG) + IF (IFLAG .lt. 0) GO TO 30 + X(J) = TEMP + DO 10 I = 1, N + FJAC(I,J) = (WA1(I) - FVEC(I))/H + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + GO TO 110 + 40 CONTINUE +C +C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. +C + DO 90 K = 1, MSUM + DO 60 J = K, N, MSUM + WA2(J) = X(J) + H = EPS*abs(WA2(J)) + IF (H .eq. ZERO) H = EPS + X(J) = WA2(J) + H + 60 CONTINUE +c%% (*dnqfj)( n, x, wa1, dummy, iflag ); + CALL DNQFJ(N, X, WA1, DUMMY, IFLAG) + IF (IFLAG .lt. 0) GO TO 100 + DO 80 J = K, N, MSUM + X(J) = WA2(J) + H = EPS*abs(WA2(J)) + IF (H .eq. ZERO) H = EPS + DO 70 I = 1, N + FJAC(I,J) = ZERO + IF (I .ge. J - MU .and. I .le. J + ML) + * FJAC(I,J) = (WA1(I) - FVEC(I))/H + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + RETURN +C +C Last line of subroutine DNQFDJ. +C + END +c ================================================================== + subroutine DNQAQ(M,N,A,LDA,V,W) + integer M,N,LDA + double precision A(LDA,N),V(N),W(N) +C ********** +C +C SUBROUTINE DNQAQ +C +C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE +C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS +C +C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) +C +C and GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH +C ELIMINATE ELEMENTS IN THE I-TH and N-TH PLANES, RESPECTIVELY. +C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE +C GV, GW ROTATIONS IS SUPPLIED. +C +C THE SUBROUTINE STATEMENT IS +C +C subroutine DNQAQ(M,N,A,LDA,V,W) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX +C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q +C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A. +C +C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. +C +C V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE +C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) +C DESCRIBED ABOVE. +C +C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE +C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) +C DESCRIBED ABOVE. +C +C SUBROUTINES CALLED +C +C FORTRAN-SUPPLIED ... abs,sqrt +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** +c ------------------------------------------------------------------ + integer I,J,NMJ,NM1 + double precision VCOS,ONE,VSIN,TEMP + parameter(ONE = 1.0d0) +C +C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. +C + NM1 = N - 1 + IF (NM1 .lt. 1) GO TO 50 + DO 20 NMJ = 1, NM1 + J = N - NMJ + IF (abs(V(J)) .gt. ONE) VCOS = ONE/V(J) + IF (abs(V(J)) .gt. ONE) VSIN = sqrt(ONE-VCOS**2) + IF (abs(V(J)) .le. ONE) VSIN = V(J) + IF (abs(V(J)) .le. ONE) VCOS = sqrt(ONE-VSIN**2) + DO 10 I = 1, M + TEMP = VCOS*A(I,J) - VSIN*A(I,N) + A(I,N) = VSIN*A(I,J) + VCOS*A(I,N) + A(I,J) = TEMP + 10 CONTINUE + 20 CONTINUE +C +C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. +C + DO 40 J = 1, NM1 + IF (abs(W(J)) .gt. ONE) VCOS = ONE/W(J) + IF (abs(W(J)) .gt. ONE) VSIN = sqrt(ONE-VCOS**2) + IF (abs(W(J)) .le. ONE) VSIN = W(J) + IF (abs(W(J)) .le. ONE) VCOS = sqrt(ONE-VSIN**2) + DO 30 I = 1, M + TEMP = VCOS*A(I,J) + VSIN*A(I,N) + A(I,N) = -VSIN*A(I,J) + VCOS*A(I,N) + A(I,J) = TEMP + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + RETURN +C +C Last line of subroutine DNQAQ. +C + END +c ================================================================== + subroutine DNQDOG(N,R,LR,DIAG,QTB,DELTA,X,NEWTOK,WA1,WA2, + * SAMEJ, GNSTEP) +c>> 1992-01-03 CLL + integer N,LR + logical SAMEJ, NEWTOK + double precision DELTA, GNSTEP(N) + double precision R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N) +C ********** +C +C subroutine DNQDOG +C +c Given an M by N matrix A, an N by N nonsingular diagonal +c matrix D, an M-vector B, and a positive number DELTA, the +c problem is to determine the convex combination X of the +c gauss-newton and scaled gradient directions that minimizes +c (A*X - B) in the least squares sense, subject to the +c restriction that the euclidean norm of D*X be at most DELTA. +c +c This subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c QR factorization of A. that is, if A = Q*R, where Q has +c orthogonal columns and R is an upper triangular matrix, +c then DNQDOG needs the full upper triangle of R and +c the first N components of (Q transpose)*B. +c +c The subroutine statement is +C +C subroutine DNQDOG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) +C +C where +C +c N is A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +c R() [in] An ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER +c TRIANGULAR MATRIX R STORED BY ROWS. +C +c LR is A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +c (N*(N+1))/2. +C +c DIAG() [in] An ARRAY OF LENGTH N WHICH MUST CONTAIN THE +c DIAGONAL ELEMENTS OF THE MATRIX D. +C +c QTB() [in] An ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST +c N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. +C +c DELTA is a POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER +c BOUND ON THE EUCLIDEAN NORM OF D*X. +C +c X() [out] An ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED +c CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION and THE +c SCALED GRADIENT DIRECTION. +c +c NEWTOK [logical, out] True means the full Newton step was +c used. False means a modified, shorter, step was used. +c +c WA1() and WA2() are work arrays of length N. +c +c SAMEJ [logical, in] True means we have the same Jacobian matrix as +c on the previous call to this subr. The Gauss-Newton vector in +c GNSTEP() can be reused. +c +c GNSTEP() [inout] On return holds the Gauss-Newton vector. On entry +c with SAMEJ = .true., contains the GN vector from the previous call. +C ------------------------------------------------------------------ +C SUBPROGRAMS CALLED +C +c MINPACK-SUPPLIED ... D1MACH,DNRM2 +C +C FORTRAN-SUPPLIED ... abs,max,min,sqrt +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +c ------------------------------------------------------------------ + external D1MACH, DNRM2 + integer I,J,JJ,JP1,K,L, NP1 + double precision ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM + double precision TEMP,ZERO + double precision D1MACH,DNRM2 + parameter(ONE = 1.0d0, ZERO = 0.0d0) + save EPSMCH + data EPSMCH / 0.0d0 / +c ------------------------------------------------------------------ +C Set EPSMCH to the machine precision. +C + if(EPSMCH .eq. 0.0d0) EPSMCH = D1MACH(4) + if(.not. SAMEJ) then +C +C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. +C + NP1 = N+1 + JJ = (N*(N + 1))/2 + 1 + DO 50 K = 1, N + J = NP1 - K + JP1 = J + 1 + JJ = JJ - K + L = JJ + 1 + SUM = ZERO + DO 10 I = JP1, N + SUM = SUM + R(L)*GNSTEP(I) + L = L + 1 + 10 CONTINUE + TEMP = R(JJ) + IF (TEMP .eq. ZERO) then + L = J + DO 30 I = 1, J-1 + TEMP = max(TEMP,abs(R(L))) + L = L + N - I + 30 CONTINUE + TEMP = EPSMCH*TEMP + endif + if (TEMP .eq. ZERO) then + GNSTEP(J) = 0.0d0 + else + GNSTEP(J) = (QTB(J) - SUM)/TEMP + endif + 50 CONTINUE + endif +C +C TEST WHETHER THE GAUSS-NEWTON DIRECTION is ACCEPTABLE. +C + DO 60 J = 1, N + WA1(J) = ZERO + WA2(J) = DIAG(J)*GNSTEP(J) + 60 CONTINUE + QNORM = DNRM2(N,WA2,1) + NEWTOK = QNORM .le. DELTA + if (NEWTOK) then + do 65 J = 1,N + X(J) = GNSTEP(J) + 65 continue + go to 140 + endif +C +C THE GAUSS-NEWTON DIRECTION is NOT ACCEPTABLE. +C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. +C + L = 1 + DO 80 J = 1, N + TEMP = QTB(J) + DO 70 I = J, N + WA1(I) = WA1(I) + R(L)*TEMP + L = L + 1 + 70 CONTINUE + WA1(J) = WA1(J)/DIAG(J) + 80 CONTINUE +C +C CALCULATE THE NORM OF THE SCALED GRADIENT and TEST FOR +C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT is ZERO. +C + GNORM = DNRM2(N,WA1,1) + if (GNORM .eq. ZERO) then + ALPHA = DELTA/QNORM + do 85 J = 1, N + X(J) = ALPHA*GNSTEP(J) + 85 continue + go to 140 + endif +C +C CALCULATE THE POINT ALONG THE SCALED GRADIENT +C AT WHICH THE QUADRATIC is MINIMIZED. +C + DO 90 J = 1, N + WA1(J) = (WA1(J)/GNORM)/DIAG(J) + 90 CONTINUE + L = 1 + DO 110 J = 1, N + SUM = ZERO + DO 100 I = J, N + SUM = SUM + R(L)*WA1(I) + L = L + 1 + 100 CONTINUE + WA2(J) = SUM + 110 CONTINUE + TEMP = DNRM2(N,WA2,1) + SGNORM = (GNORM/TEMP)/TEMP +C +C TEST WHETHER THE SCALED GRADIENT DIRECTION is ACCEPTABLE. +C + ALPHA = ZERO + if (SGNORM .lt. DELTA) then +C +C THE SCALED GRADIENT DIRECTION is NOT ACCEPTABLE. +C FINALLY, CALCULATE THE POINT ALONG THE dogleg +C AT WHICH THE QUADRATIC is MINIMIZED. +C + BNORM = DNRM2(N,QTB,1) + TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) + TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 + * + sqrt((TEMP-(DELTA/QNORM))**2 + * +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) + ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP + endif +C +C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON +C DIRECTION and THE SCALED GRADIENT DIRECTION. +C + TEMP = (ONE - ALPHA)*min(SGNORM,DELTA) + DO 130 J = 1, N + X(J) = TEMP*WA1(J) + ALPHA*GNSTEP(J) + 130 CONTINUE + 140 CONTINUE + RETURN +C +C Last line of subroutine DNQDOG. +C + END + subroutine DNQQFM(M,N,Q,LDQ,WA) + integer M,N,LDQ + double precision Q(LDQ,M),WA(M) +C ********** +C +C SUBROUTINE DNQQFM +C +C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF +C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX +C Q FROM ITS FACTORED FORM. +C +C THE SUBROUTINE STATEMENT IS +C +C subroutine DNQQFM(M,N,Q,LDQ,WA) +C +C WHERE +C +C M is A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A and THE ORDER OF Q. +C +C N is A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C Q is AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN +C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM. +C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX. +C +C LDQ is A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q. +C +C WA is A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... min +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +c ------------------------------------------------------------------ + integer I,J,JM1,K,L,MINMN,NP1 + double precision ONE,SUM,TEMP,ZERO + parameter(ONE = 1.0d0, ZERO = 0.0d0) +C +C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. +C + MINMN = min(M,N) + IF (MINMN .lt. 2) GO TO 30 + DO 20 J = 2, MINMN + JM1 = J - 1 + DO 10 I = 1, JM1 + Q(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. +C + NP1 = N + 1 + IF (M .lt. NP1) GO TO 60 + DO 50 J = NP1, M + DO 40 I = 1, M + Q(I,J) = ZERO + 40 CONTINUE + Q(J,J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ACCUMULATE Q FROM ITS FACTORED FORM. +C + DO 120 L = 1, MINMN + K = MINMN - L + 1 + DO 70 I = K, M + WA(I) = Q(I,K) + Q(I,K) = ZERO + 70 CONTINUE + Q(K,K) = ONE + IF (WA(K) .eq. ZERO) GO TO 110 + DO 100 J = K, M + SUM = ZERO + DO 80 I = K, M + SUM = SUM + Q(I,J)*WA(I) + 80 CONTINUE + TEMP = SUM/WA(K) + DO 90 I = K, M + Q(I,J) = Q(I,J) - TEMP*WA(I) + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + RETURN +C +C Last line of subroutine DNQQFM. +C + END + subroutine DNQQRF(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) + integer M,N,LDA,LIPVT + integer IPVT(LIPVT) + logical PIVOT + double precision A(LDA,N),RDIAG(N),ACNORM(N),WA(N) +C ********** +C +C SUBROUTINE DNQQRF +C +C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN +C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE +C M BY N MATRIX A. THAT IS, DNQQRF DETERMINES AN ORTHOGONAL +C MATRIX Q, A PERMUTATION MATRIX P, and AN UPPER TRAPEZOIDAL +C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, +C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR +C COLUMN K, K = 1,2,...,MIN(M,N), is OF THE FORM +C +C T +C I - (1/U(K))*U*U +C +C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF +C THIS TRANSFORMATION and THE METHOD OF PIVOTING FIRST +C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. +C +C THE SUBROUTINE STATEMENT IS +C +C subroutine DNQQRF(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) +C +C WHERE +C +C M is A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A. +C +C N is A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C A is AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR +C WHICH THE QR FACTORIZATION is TO BE COMPUTED. ON OUTPUT +C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT +C UPPER TRAPEZOIDAL PART OF R, and THE LOWER TRAPEZOIDAL +C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL +C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). +C +C LDA is A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. +C +C PIVOT is A LOGICAL INPUT VARIABLE. IF PIVOT is SET TRUE, +C THEN COLUMN PIVOTING is ENFORCED. IF PIVOT is SET FALSE, +C THEN NO COLUMN PIVOTING is DONE. +C +C IPVT is AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT +C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. +C COLUMN J OF P is COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C IF PIVOT is FALSE, IPVT is NOT REFERENCED. +C +C LIPVT is A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT is FALSE, +C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT is TRUE, THEN +C LIPVT MUST BE AT LEAST N. +C +C RDIAG is AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C DIAGONAL ELEMENTS OF R. +C +C ACNORM is AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. +C IF THIS INFORMATION is NOT NEEDED, THEN ACNORM CAN COINCIDE +C WITH RDIAG. +C +C WA is A WORK ARRAY OF LENGTH N. IF PIVOT is FALSE, THEN WA +C CAN COINCIDE WITH RDIAG. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... D1MACH,DNRM2 +C +C FORTRAN-SUPPLIED ... max,sqrt,min +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** +c ------------------------------------------------------------------ + external D1MACH, DNRM2 + integer I,J,JP1,K,KMAX,MINMN + double precision AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO + double precision D1MACH,DNRM2 + parameter(ONE = 1.0d0, P05 = 0.05d0, ZERO = 0.0d0) +C +C EPSMCH is THE MACHINE PRECISION. +C + EPSMCH = D1MACH(4) +C +C COMPUTE THE INITIAL COLUMN NORMS and INITIALIZE SEVERAL ARRAYS. +C + DO 10 J = 1, N + ACNORM(J) = DNRM2(M,A(1,J),1) + RDIAG(J) = ACNORM(J) + WA(J) = RDIAG(J) + IF (PIVOT) IPVT(J) = J + 10 CONTINUE +C +C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. +C + MINMN = min(M,N) + DO 110 J = 1, MINMN + IF (.NOT.PIVOT) GO TO 40 +C +C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. +C + KMAX = J + DO 20 K = J, N + IF (RDIAG(K) .gt. RDIAG(KMAX)) KMAX = K + 20 CONTINUE + IF (KMAX .eq. J) GO TO 40 + DO 30 I = 1, M + TEMP = A(I,J) + A(I,J) = A(I,KMAX) + A(I,KMAX) = TEMP + 30 CONTINUE + RDIAG(KMAX) = RDIAG(J) + WA(KMAX) = WA(J) + K = IPVT(J) + IPVT(J) = IPVT(KMAX) + IPVT(KMAX) = K + 40 CONTINUE +C +C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE +C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. +C + AJNORM = DNRM2(M-J+1,A(J,J),1) + IF (AJNORM .eq. ZERO) GO TO 100 + IF (A(J,J) .lt. ZERO) AJNORM = -AJNORM + DO 50 I = J, M + A(I,J) = A(I,J)/AJNORM + 50 CONTINUE + A(J,J) = A(J,J) + ONE +C +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS +C and UPDATE THE NORMS. +C + JP1 = J + 1 + IF (N .lt. JP1) GO TO 100 + DO 90 K = JP1, N + SUM = ZERO + DO 60 I = J, M + SUM = SUM + A(I,J)*A(I,K) + 60 CONTINUE + TEMP = SUM/A(J,J) + DO 70 I = J, M + A(I,K) = A(I,K) - TEMP*A(I,J) + 70 CONTINUE + IF (.NOT.PIVOT .or. RDIAG(K) .eq. ZERO) GO TO 80 + TEMP = A(J,K)/RDIAG(K) + RDIAG(K) = RDIAG(K)*sqrt(max(ZERO,ONE-TEMP**2)) + IF (P05*(RDIAG(K)/WA(K))**2 .gt. EPSMCH) GO TO 80 + RDIAG(K) = DNRM2(M-J,A(JP1,K),1) + WA(K) = RDIAG(K) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RDIAG(J) = -AJNORM + 110 CONTINUE + RETURN +C +C Last line of subroutine DNQQRF. +C + END + subroutine DNQUPD(M,N,S,LS,U,V,W,SING) + integer M,N,LS + logical SING + double precision S(LS),U(M),V(N),W(M) +C ********** +C +C SUBROUTINE DNQUPD +C +C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U, +C and AN N-VECTOR V, THE PROBLEM is TO DETERMINE AN +C ORTHOGONAL MATRIX Q SUCH THAT +C +C T +C (S + U*V )*Q +C +C is AGAIN LOWER TRAPEZOIDAL. +C +C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1) +C TRANSFORMATIONS +C +C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) +C +C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE +C WHICH ELIMINATE ELEMENTS IN THE I-TH and N-TH PLANES, +C RESPECTIVELY. Q ITSELF is NOT ACCUMULATED, RATHER THE +C INFORMATION TO RECOVER THE GV, GW ROTATIONS is RETURNED. +C +C THE SUBROUTINE STATEMENT IS +C +C subroutine DNQUPD(M,N,S,LS,U,V,W,SING) +C +C WHERE +C +C M is A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF S. +C +C N is A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF S. N MUST NOT EXCEED M. +C +C S is AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER +C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS +C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE. +C +C LS is A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(2*M-N+1))/2. +C +C U is AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE +C VECTOR U. +C +C V is AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR +C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO +C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE. +C +C W is AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION +C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED +C ABOVE. +C +C SING is A LOGICAL OUTPUT VARIABLE. SING is SET TRUE IF ANY +C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE +C SING is SET FALSE. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... D1MACH +C +C FORTRAN-SUPPLIED ... abs,sqrt +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, +C JOHN L. NAZARETH +C +C ********** +c ------------------------------------------------------------------ + external D1MACH + integer I,J,JJ,L,NMJ,NM1 + double precision VCOS,COTAN,GIANT,ONE,P5,P25,VSIN,VTAN,TAU,TEMP, + * ZERO + double precision D1MACH + parameter(ONE = 1.0d0, P5 = 0.5d0, P25 = 0.25d0, ZERO = 0.0d0) + save GIANT + data GIANT / 0.0d0 / +C +C GIANT is THE LARGEST MAGNITUDE. +C + if(GIANT .eq. 0.0d0) GIANT = D1MACH(2) +C +C INITIALIZE THE DIAGONAL ELEMENT POINTER. +C + JJ = (N*(2*M - N + 1))/2 - (M - N) +C +C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. +C + L = JJ + DO 10 I = N, M + W(I) = S(L) + L = L + 1 + 10 CONTINUE +C +C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR +C IN SUCH A WAY THAT A SPIKE is INTRODUCED INTO W. +C + NM1 = N - 1 + IF (NM1 .lt. 1) GO TO 70 + DO 60 NMJ = 1, NM1 + J = N - NMJ + JJ = JJ - (M - J + 1) + W(J) = ZERO + IF (V(J) .eq. ZERO) GO TO 50 +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C J-TH ELEMENT OF V. +C + IF (abs(V(N)) .ge. abs(V(J))) GO TO 20 + COTAN = V(N)/V(J) + VSIN = P5/sqrt(P25+P25*COTAN**2) + VCOS = VSIN*COTAN + TAU = ONE + IF (abs(VCOS)*GIANT .gt. ONE) TAU = ONE/VCOS + GO TO 30 + 20 CONTINUE + VTAN = V(J)/V(N) + VCOS = P5/sqrt(P25+P25*VTAN**2) + VSIN = VCOS*VTAN + TAU = VSIN + 30 CONTINUE +C +C APPLY THE TRANSFORMATION TO V and STORE THE INFORMATION +C NECESSARY TO RECOVER THE GIVENS ROTATION. +C + V(N) = VSIN*V(J) + VCOS*V(N) + V(J) = TAU +C +C APPLY THE TRANSFORMATION TO S and EXTEND THE SPIKE IN W. +C + L = JJ + DO 40 I = J, M + TEMP = VCOS*S(L) - VSIN*W(I) + W(I) = VSIN*S(L) + VCOS*W(I) + S(L) = TEMP + L = L + 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE +C +C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. +C + DO 80 I = 1, M + W(I) = W(I) + V(N)*U(I) + 80 CONTINUE +C +C ELIMINATE THE SPIKE. +C + SING = .FALSE. + IF (NM1 .lt. 1) GO TO 140 + DO 130 J = 1, NM1 + IF (W(J) .eq. ZERO) GO TO 120 +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C J-TH ELEMENT OF THE SPIKE. +C + IF (abs(S(JJ)) .ge. abs(W(J))) GO TO 90 + COTAN = S(JJ)/W(J) + VSIN = P5/sqrt(P25+P25*COTAN**2) + VCOS = VSIN*COTAN + TAU = ONE + IF (abs(VCOS)*GIANT .gt. ONE) TAU = ONE/VCOS + GO TO 100 + 90 CONTINUE + VTAN = W(J)/S(JJ) + VCOS = P5/sqrt(P25+P25*VTAN**2) + VSIN = VCOS*VTAN + TAU = VSIN + 100 CONTINUE +C +C APPLY THE TRANSFORMATION TO S and REDUCE THE SPIKE IN W. +C + L = JJ + DO 110 I = J, M + TEMP = VCOS*S(L) + VSIN*W(I) + W(I) = -VSIN*S(L) + VCOS*W(I) + S(L) = TEMP + L = L + 1 + 110 CONTINUE +C +C STORE THE INFORMATION NECESSARY TO RECOVER THE +C GIVENS ROTATION. +C + W(J) = TAU + 120 CONTINUE +C +C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. +C + IF (S(JJ) .eq. ZERO) SING = .TRUE. + JJ = JJ + (M - J + 1) + 130 CONTINUE + 140 CONTINUE +C +C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. +C + L = JJ + DO 150 I = N, M + S(L) = W(I) + L = L + 1 + 150 CONTINUE + IF (S(JJ) .eq. ZERO) SING = .TRUE. + RETURN +C +C Last line of subroutine DNQUPD. +C + END diff --git a/dataassim/math/nonlinsystems/dnrm2.f b/dataassim/math/nonlinsystems/dnrm2.f new file mode 100644 index 0000000..480c912 --- /dev/null +++ b/dataassim/math/nonlinsystems/dnrm2.f @@ -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 diff --git a/dataassim/math/nonlinsystems/erfin.f b/dataassim/math/nonlinsystems/erfin.f new file mode 100644 index 0000000..4fc7eb1 --- /dev/null +++ b/dataassim/math/nonlinsystems/erfin.f @@ -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 diff --git a/dataassim/math/nonlinsystems/ermsg.f b/dataassim/math/nonlinsystems/ermsg.f new file mode 100644 index 0000000..a23b60e --- /dev/null +++ b/dataassim/math/nonlinsystems/ermsg.f @@ -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 diff --git a/dataassim/math/nonlinsystems/fixedpoint.f b/dataassim/math/nonlinsystems/fixedpoint.f index 8147bc3..ffe383c 100644 --- a/dataassim/math/nonlinsystems/fixedpoint.f +++ b/dataassim/math/nonlinsystems/fixedpoint.f @@ -311,7 +311,7 @@ call lnsrch(nunknowns,xpold,fsqsumold, & gfuncsum,deltax,xp,fsqsumnew,stpmax, & check,funcnleq1,fequ) - if(check.eq..true..or.check.eq..TRUE.)then + if(check.eqv..true..or.check.eqv..TRUE.)then do i=1,nunknowns call reinitialization(x0min(i),xpold(i), & x0max(i),xp(i),6678) diff --git a/dataassim/math/nonlinsystems/ierm1.f b/dataassim/math/nonlinsystems/ierm1.f new file mode 100644 index 0000000..cf7b840 --- /dev/null +++ b/dataassim/math/nonlinsystems/ierm1.f @@ -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 diff --git a/dataassim/math/nonlinsystems/ierv1.f b/dataassim/math/nonlinsystems/ierv1.f new file mode 100644 index 0000000..9a3d52c --- /dev/null +++ b/dataassim/math/nonlinsystems/ierv1.f @@ -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 diff --git a/dataassim/math/nonlinsystems/math77 b/dataassim/math/nonlinsystems/math77 new file mode 100644 index 0000000..813f3c8 Binary files /dev/null and b/dataassim/math/nonlinsystems/math77 differ diff --git a/dataassim/math/nonlinsystems/nonsyssolver.f b/dataassim/math/nonlinsystems/nonsyssolver.f index 6bd2d78..93a8592 100644 --- a/dataassim/math/nonlinsystems/nonsyssolver.f +++ b/dataassim/math/nonlinsystems/nonsyssolver.f @@ -1,6 +1,6 @@ subroutine nonsyssolver(funcnleq1,fmin_funcnleq1, - & f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp, - & nunknowns,iwhichsolver) + &f1dim_funcnleq1,DNQFJ_funcnleq1,x0min,x0ori,xp,x0max,fp, + &nunknowns,iwhichsolver) implicit none integer nunknowns,iwhichsolver double precision x0min(nunknowns),x0ori(nunknowns), @@ -27,30 +27,48 @@ ! =4 solved by fixed point method 4 ! =6 solved by broydn ! =7 Solved by multiobjective minimization. +! =8 Solved by DNQSOL ! =-9999 Best approximation returned. Solution may not be accurate. ! --------- Local variables --------------------------------------- - double precision x0(nunknowns),TOLF,stpmax,scldstpmax, - & sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum, - & f1dim_funcnleq1 - integer i,irepeat,maxrepeats,IERR,notfound + double precision x0(nunknowns),TOLF,stpmax,scldstpmax,ran2, + &sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,f1dim_funcnleq1, + &D1MACH,Warray(3+(15*nunknowns+3*nunknowns*nunknowns)/2+1) + integer i,irepeat,maxrepeats,IERR,notfound,IOPT(5),IDIMW intrinsic dble - parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-7) - external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1 + parameter(maxrepeats=100,notfound=-9999) + external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1, + &DNQFJ_funcnleq1 !------------------------------------------------------------------- - stpmax=0.0d0 - sum=0.0d0 do i=1, nunknowns - x0(i)=x0ori(i) - sum=sum+x0ori(i)*x0ori(i) - stpmax=stpmax+ - & (x0min(i)-x0max(i))*(x0min(i)-x0max(i)) + xp(i)=x0ori(i) enddo - stpmax=dsqrt(stpmax)/4.0d0 - scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns)) -! In Numerical Recipes, scldstpmax (STPMX) is 100 - scldstpmax=dmax1(100.0d0,scldstpmax) iwhichsolver=notfound + TOLF=dsqrt(D1MACH(4)) do irepeat=1,maxrepeats + IDIMW=3+(15*nunknowns+3*nunknowns*nunknowns)/2+1 + do i=1,5 + IOPT(i)=0 + enddo + IOPT(4)=1 + call DNQSOL(DNQFJ_funcnleq1,nunknowns,xp,fp,TOLF, + &IOPT,Warray,IDIMW) + if(IOPT(1).eq.0)then + iwhichsolver=8 + return + endif + do i=1,nunknowns + x0(i)=x0min(i)+ran2()*(x0max(i)-x0min(i)) + enddo + stpmax=0.0d0 + sum=0.0d0 + do i=1, nunknowns + sum=sum+x0(i)*x0(i) + stpmax=stpmax+(x0min(i)-x0max(i))*(x0min(i)-x0max(i)) + enddo + stpmax=dsqrt(stpmax)/4.0d0 + scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns)) +! In Numerical Recipes, scldstpmax (STPMX) is 100 + scldstpmax=dmax1(100.0d0,scldstpmax) call fixedpoint(funcnleq1,x0min,x0,xp, & x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver) if(iwhichsolver.ne.notfound)return @@ -82,6 +100,11 @@ return endif endif + + do i=1,nunknowns + xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i)) + enddo + call funcnleq1(nunknowns,xp,fp,fsqsum) fsqsum=0.0d0 do i=1,nunknowns fsqsum=fsqsum+fp(i)*fp(i) @@ -89,11 +112,11 @@ tp=fsqsum call nongradopt(nunknowns,fmin_funcnleq1, & f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum) -! if(dabs(tp-fsqsum).gt.TOLF)then -! call RepeatCompassSearch(nunknowns,xp,fsqsum, -! & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1, -! & TOLF) -! endif + if(dabs(tp-fsqsum).gt.TOLF)then + call RepeatCompassSearch(nunknowns,xp,fsqsum, + & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1, + & TOLF) + endif call funcnleq1(nunknowns,xp,fp,fsqsum) tp=dabs(fp(1)) do i=2,nunknowns @@ -109,7 +132,7 @@ enddo if(IERR.eq.0)return do i=1,nunknowns - x0(i)=xp(i) + xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i)) enddo enddo end subroutine nonsyssolver diff --git a/dataassim/math/numrec/Document.txt b/dataassim/math/numrec/Document.txt new file mode 100644 index 0000000..63bf29b --- /dev/null +++ b/dataassim/math/numrec/Document.txt @@ -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 diff --git a/dataassim/math/numrec/PrinCompAna.f b/dataassim/math/numrec/PrinCompAna.f new file mode 100644 index 0000000..39e2bf4 --- /dev/null +++ b/dataassim/math/numrec/PrinCompAna.f @@ -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 diff --git a/dataassim/math/numrec/Table8.3.txt b/dataassim/math/numrec/Table8.3.txt new file mode 100644 index 0000000..d994e97 --- /dev/null +++ b/dataassim/math/numrec/Table8.3.txt @@ -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 diff --git a/dataassim/math/numrec/daxpy.f b/dataassim/math/numrec/daxpy.f new file mode 100644 index 0000000..ddc7449 --- /dev/null +++ b/dataassim/math/numrec/daxpy.f @@ -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 diff --git a/dataassim/math/numrec/dcopy.f b/dataassim/math/numrec/dcopy.f new file mode 100644 index 0000000..a441450 --- /dev/null +++ b/dataassim/math/numrec/dcopy.f @@ -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 diff --git a/dataassim/math/numrec/ddot.f b/dataassim/math/numrec/ddot.f new file mode 100644 index 0000000..33719ee --- /dev/null +++ b/dataassim/math/numrec/ddot.f @@ -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 diff --git a/dataassim/math/numrec/dgeev.f b/dataassim/math/numrec/dgeev.f new file mode 100644 index 0000000..cab9d1f --- /dev/null +++ b/dataassim/math/numrec/dgeev.f @@ -0,0 +1,18122 @@ +*> \brief \b DGEBAK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEBAK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB, SIDE +* INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION SCALE( * ), V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEBAK forms the right or left eigenvectors of a real general matrix +*> by backward transformation on the computed eigenvectors of the +*> balanced matrix output by DGEBAL. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> Specifies the type of backward transformation required: +*> = 'N', do nothing, return immediately; +*> = 'P', do backward transformation for permutation only; +*> = 'S', do backward transformation for scaling only; +*> = 'B', do backward transformations for both permutation and +*> scaling. +*> JOB must be the same as the argument JOB supplied to DGEBAL. +*> \endverbatim +*> +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': V contains right eigenvectors; +*> = 'L': V contains left eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows of the matrix V. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> The integers ILO and IHI determined by DGEBAL. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION array, dimension (N) +*> Details of the permutation and scaling factors, as returned +*> by DGEBAL. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of columns of the matrix V. M >= 0. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,M) +*> On entry, the matrix of right or left eigenvectors to be +*> transformed, as returned by DHSEIN or DTREVC. +*> On exit, V is overwritten by the transformed eigenvectors. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. LDV >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup doubleGEcomputational +* +* ===================================================================== + SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ), V( LDV, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFTV, RIGHTV + INTEGER I, II, K + DOUBLE PRECISION S +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Decode and Test the input parameters +* + RIGHTV = LSAME( SIDE, 'R' ) + LEFTV = LSAME( SIDE, 'L' ) +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEBAK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( M.EQ.0 ) + $ RETURN + IF( LSAME( JOB, 'N' ) ) + $ RETURN +* + IF( ILO.EQ.IHI ) + $ GO TO 30 +* +* Backward balance +* + IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN +* + IF( RIGHTV ) THEN + DO 10 I = ILO, IHI + S = SCALE( I ) + CALL DSCAL( M, S, V( I, 1 ), LDV ) + 10 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 20 I = ILO, IHI + S = ONE / SCALE( I ) + CALL DSCAL( M, S, V( I, 1 ), LDV ) + 20 CONTINUE + END IF +* + END IF +* +* Backward permutation +* +* For I = ILO-1 step -1 until 1, +* IHI+1 step 1 until N do -- +* + 30 CONTINUE + IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN + IF( RIGHTV ) THEN + DO 40 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 40 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 40 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 40 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 50 II = 1, N + I = II + IF( I.GE.ILO .AND. I.LE.IHI ) + $ GO TO 50 + IF( I.LT.ILO ) + $ I = ILO - II + K = SCALE( I ) + IF( K.EQ.I ) + $ GO TO 50 + CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 50 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEBAK +* + END +*> \brief \b DGEBAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEBAL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOB +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), SCALE( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEBAL balances a general real matrix A. This involves, first, +*> permuting A by a similarity transformation to isolate eigenvalues +*> in the first 1 to ILO-1 and last IHI+1 to N elements on the +*> diagonal; and second, applying a diagonal similarity transformation +*> to rows and columns ILO to IHI to make the rows and columns as +*> close in norm as possible. Both steps are optional. +*> +*> Balancing may reduce the 1-norm of the matrix, and improve the +*> accuracy of the computed eigenvalues and/or eigenvectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> Specifies the operations to be performed on A: +*> = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 +*> for i = 1,...,N; +*> = 'P': permute only; +*> = 'S': scale only; +*> = 'B': both permute and scale. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE array, dimension (LDA,N) +*> On entry, the input matrix A. +*> On exit, A is overwritten by the balanced matrix. +*> If JOB = 'N', A is not referenced. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> \param[out] IHI +*> \verbatim +*> IHI is INTEGER +*> ILO and IHI are set to integers such that on exit +*> A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. +*> If JOB = 'N' or 'S', ILO = 1 and IHI = N. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE array, dimension (N) +*> Details of the permutations and scaling factors applied to +*> A. If P(j) is the index of the row and column interchanged +*> with row and column j and D(j) is the scaling factor +*> applied to row and column j, then +*> SCALE(j) = P(j) for j = 1,...,ILO-1 +*> = D(j) for j = ILO,...,IHI +*> = P(j) for j = IHI+1,...,N. +*> The order in which the interchanges are made is N to IHI+1, +*> then 1 to ILO-1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The permutations consist of row and column interchanges which put +*> the matrix in the form +*> +*> ( T1 X Y ) +*> P A P = ( 0 B Z ) +*> ( 0 0 T2 ) +*> +*> where T1 and T2 are upper triangular matrices whose eigenvalues lie +*> along the diagonal. The column indices ILO and IHI mark the starting +*> and ending columns of the submatrix B. Balancing consists of applying +*> a diagonal similarity transformation inv(D) * B * D to make the +*> 1-norms of each row of B and its corresponding column nearly equal. +*> The output matrix is +*> +*> ( T1 X*D Y ) +*> ( 0 inv(D)*B*D inv(D)*Z ). +*> ( 0 0 T2 ) +*> +*> Information about the permutations P and the diagonal matrix D is +*> returned in the vector SCALE. +*> +*> This subroutine is based on the EISPACK routine BALANC. +*> +*> Modified by Tzu-Yi Chen, Computer Science Division, University of +*> California at Berkeley, USA +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), SCALE( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 2.0D+0 ) + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 0.95D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IEXC, IRA, J, K, L, M + DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, + $ SFMIN2 +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* Test the input parameters +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEBAL', -INFO ) + RETURN + END IF +* + K = 1 + L = N +* + IF( N.EQ.0 ) + $ GO TO 210 +* + IF( LSAME( JOB, 'N' ) ) THEN + DO 10 I = 1, N + SCALE( I ) = ONE + 10 CONTINUE + GO TO 210 + END IF +* + IF( LSAME( JOB, 'S' ) ) + $ GO TO 120 +* +* Permutation to isolate eigenvalues if possible +* + GO TO 50 +* +* Row and column exchange. +* + 20 CONTINUE + SCALE( M ) = J + IF( J.EQ.M ) + $ GO TO 30 +* + CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) + CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) +* + 30 CONTINUE + GO TO ( 40, 80 )IEXC +* +* Search for rows isolating an eigenvalue and push them down. +* + 40 CONTINUE + IF( L.EQ.1 ) + $ GO TO 210 + L = L - 1 +* + 50 CONTINUE + DO 70 J = L, 1, -1 +* + DO 60 I = 1, L + IF( I.EQ.J ) + $ GO TO 60 + IF( A( J, I ).NE.ZERO ) + $ GO TO 70 + 60 CONTINUE +* + M = L + IEXC = 1 + GO TO 20 + 70 CONTINUE +* + GO TO 90 +* +* Search for columns isolating an eigenvalue and push them left. +* + 80 CONTINUE + K = K + 1 +* + 90 CONTINUE + DO 110 J = K, L +* + DO 100 I = K, L + IF( I.EQ.J ) + $ GO TO 100 + IF( A( I, J ).NE.ZERO ) + $ GO TO 110 + 100 CONTINUE +* + M = K + IEXC = 2 + GO TO 20 + 110 CONTINUE +* + 120 CONTINUE + DO 130 I = K, L + SCALE( I ) = ONE + 130 CONTINUE +* + IF( LSAME( JOB, 'P' ) ) + $ GO TO 210 +* +* Balance the submatrix in rows K to L. +* +* Iterative loop for norm reduction +* + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +* + 140 CONTINUE + NOCONV = .FALSE. +* + DO 200 I = K, L +* + C = DNRM2( L-K+1, A( K, I ), 1 ) + R = DNRM2( L-K+1, A( I, K ), LDA ) + ICA = IDAMAX( L, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IDAMAX( N-K+1, A( I, K ), LDA ) + RA = ABS( A( I, IRA+K-1 ) ) +* +* Guard against zero C or R due to underflow. +* + IF( C.EQ.ZERO .OR. R.EQ.ZERO ) + $ GO TO 200 + G = R / SCLFAC + F = ONE + S = C + R + 160 CONTINUE + IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. + $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 + IF( DISNAN( C+F+CA+R+G+RA ) ) THEN +* +* Exit if NaN to avoid infinite loop +* + INFO = -3 + CALL XERBLA( 'DGEBAL', -INFO ) + RETURN + END IF + F = F*SCLFAC + C = C*SCLFAC + CA = CA*SCLFAC + R = R / SCLFAC + G = G / SCLFAC + RA = RA / SCLFAC + GO TO 160 +* + 170 CONTINUE + G = C / SCLFAC + 180 CONTINUE + IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. + $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 + F = F / SCLFAC + C = C / SCLFAC + G = G / SCLFAC + CA = CA / SCLFAC + R = R*SCLFAC + RA = RA*SCLFAC + GO TO 180 +* +* Now balance. +* + 190 CONTINUE + IF( ( C+R ).GE.FACTOR*S ) + $ GO TO 200 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 200 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 200 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +* + CALL DSCAL( N-K+1, G, A( I, K ), LDA ) + CALL DSCAL( L, F, A( 1, I ), 1 ) +* + 200 CONTINUE +* + IF( NOCONV ) + $ GO TO 140 +* + 210 CONTINUE + ILO = K + IHI = L +* + RETURN +* +* End of DGEBAL +* + END +*> \brief DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, +* LDVR, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVL, JOBVR +* INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WI( * ), WORK( * ), WR( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEEV computes for an N-by-N real nonsymmetric matrix A, the +*> eigenvalues and, optionally, the left and/or right eigenvectors. +*> +*> The right eigenvector v(j) of A satisfies +*> A * v(j) = lambda(j) * v(j) +*> where lambda(j) is its eigenvalue. +*> The left eigenvector u(j) of A satisfies +*> u(j)**H * A = lambda(j) * u(j)**H +*> where u(j)**H denotes the conjugate-transpose of u(j). +*> +*> The computed eigenvectors are normalized to have Euclidean norm +*> equal to 1 and largest component real. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': left eigenvectors of A are not computed; +*> = 'V': left eigenvectors of A are computed. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': right eigenvectors of A are not computed; +*> = 'V': right eigenvectors of A are computed. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N matrix A. +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (N) +*> WR and WI contain the real and imaginary parts, +*> respectively, of the computed eigenvalues. Complex +*> conjugate pairs of eigenvalues appear consecutively +*> with the eigenvalue having the positive imaginary part +*> first. +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,N) +*> If JOBVL = 'V', the left eigenvectors u(j) are stored one +*> after another in the columns of VL, in the same order +*> as their eigenvalues. +*> If JOBVL = 'N', VL is not referenced. +*> If the j-th eigenvalue is real, then u(j) = VL(:,j), +*> the j-th column of VL. +*> If the j-th and (j+1)-st eigenvalues form a complex +*> conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and +*> u(j+1) = VL(:,j) - i*VL(:,j+1). +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1; if +*> JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,N) +*> If JOBVR = 'V', the right eigenvectors v(j) are stored one +*> after another in the columns of VR, in the same order +*> as their eigenvalues. +*> If JOBVR = 'N', VR is not referenced. +*> If the j-th eigenvalue is real, then v(j) = VR(:,j), +*> the j-th column of VR. +*> If the j-th and (j+1)-st eigenvalues form a complex +*> conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and +*> v(j+1) = VR(:,j) - i*VR(:,j+1). +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1; if +*> JOBVR = 'V', LDVR >= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,3*N), and +*> if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good +*> performance, LWORK must generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the QR algorithm failed to compute all the +*> eigenvalues, and no eigenvectors have been computed; +*> elements i+1:N of WR and WI contain eigenvalues which +*> have converged. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +* @precisions fortran d -> s +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, + $ LDVR, WORK, LWORK, INFO ) + implicit none +* +* -- LAPACK driver routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WI( * ), WORK( * ), WR( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, SCALEA, WANTVL, WANTVR + CHARACTER SIDE + INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, + $ LWORK_TREVC, MAXWRK, MINWRK, NOUT + DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, + $ SN +* .. +* .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, + $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC3, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 + EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, + $ DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVL = LSAME( JOBVL, 'V' ) + WANTVR = LSAME( JOBVR, 'V' ) + IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN + INFO = -9 + ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN + INFO = -11 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* HSWORK refers to the workspace preferred by DHSEQR, as +* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, +* the worst case.) +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + IF( WANTVL ) THEN + MINWRK = 4*N + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL, + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL DTREVC3( 'L', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) + MAXWRK = MAX( MAXWRK, 4*N ) + ELSE IF( WANTVR ) THEN + MINWRK = 4*N + MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1, + $ 'DORGHR', ' ', N, 1, N, -1 ) ) + CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR, + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + CALL DTREVC3( 'R', 'B', SELECT, N, A, LDA, + $ VL, LDVL, VR, LDVR, N, NOUT, + $ WORK, -1, IERR ) + LWORK_TREVC = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) + MAXWRK = MAX( MAXWRK, 4*N ) + ELSE + MINWRK = 3*N + CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR, + $ WORK, -1, INFO ) + HSWORK = INT( WORK(1) ) + MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK ) + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Balance the matrix +* (Workspace: need N) +* + IBAL = 1 + CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR ) +* +* Reduce to upper Hessenberg form +* (Workspace: need 3*N, prefer 2*N+N*NB) +* + ITAU = IBAL + N + IWRK = ITAU + N + CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* + IF( WANTVL ) THEN +* +* Want left eigenvectors +* Copy Householder vectors to VL +* + SIDE = 'L' + CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL ) +* +* Generate orthogonal matrix in VL +* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* + CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VL +* (Workspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + IF( WANTVR ) THEN +* +* Want left and right eigenvectors +* Copy Schur vectors to VR +* + SIDE = 'B' + CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) + END IF +* + ELSE IF( WANTVR ) THEN +* +* Want right eigenvectors +* Copy Householder vectors to VR +* + SIDE = 'R' + CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR ) +* +* Generate orthogonal matrix in VR +* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) +* + CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VR +* (Workspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + ELSE +* +* Compute eigenvalues only +* (Workspace: need N+1, prefer N+HSWORK (see comments) ) +* + IWRK = ITAU + CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) + END IF +* +* If INFO .NE. 0 from DHSEQR, then quit +* + IF( INFO.NE.0 ) + $ GO TO 50 +* + IF( WANTVL .OR. WANTVR ) THEN +* +* Compute left and/or right eigenvectors +* (Workspace: need 4*N, prefer N + N + 2*N*NB) +* + CALL DTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, IERR ) + END IF +* + IF( WANTVL ) THEN +* +* Undo balancing of left eigenvectors +* (Workspace: need N) +* + CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL, + $ IERR ) +* +* Normalize left eigenvectors and make largest component real +* + DO 20 I = 1, N + IF( WI( I ).EQ.ZERO ) THEN + SCL = ONE / DNRM2( N, VL( 1, I ), 1 ) + CALL DSCAL( N, SCL, VL( 1, I ), 1 ) + ELSE IF( WI( I ).GT.ZERO ) THEN + SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), + $ DNRM2( N, VL( 1, I+1 ), 1 ) ) + CALL DSCAL( N, SCL, VL( 1, I ), 1 ) + CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 ) + DO 10 K = 1, N + WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2 + 10 CONTINUE + K = IDAMAX( N, WORK( IWRK ), 1 ) + CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R ) + CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN ) + VL( K, I+1 ) = ZERO + END IF + 20 CONTINUE + END IF +* + IF( WANTVR ) THEN +* +* Undo balancing of right eigenvectors +* (Workspace: need N) +* + CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR, + $ IERR ) +* +* Normalize right eigenvectors and make largest component real +* + DO 40 I = 1, N + IF( WI( I ).EQ.ZERO ) THEN + SCL = ONE / DNRM2( N, VR( 1, I ), 1 ) + CALL DSCAL( N, SCL, VR( 1, I ), 1 ) + ELSE IF( WI( I ).GT.ZERO ) THEN + SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), + $ DNRM2( N, VR( 1, I+1 ), 1 ) ) + CALL DSCAL( N, SCL, VR( 1, I ), 1 ) + CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 ) + DO 30 K = 1, N + WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2 + 30 CONTINUE + K = IDAMAX( N, WORK( IWRK ), 1 ) + CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R ) + CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN ) + VR( K, I+1 ) = ZERO + END IF + 40 CONTINUE + END IF +* +* Undo scaling if necessary +* + 50 CONTINUE + IF( SCALEA ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + IF( INFO.GT.0 ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, + $ IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, + $ IERR ) + END IF + END IF +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of DGEEV +* + END +*> \brief \b DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by +*> an orthogonal similarity transformation: Q**T * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to DGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= max(1,N). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the n by n general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the orthogonal matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION AII +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEHD2', -INFO ) + RETURN + END IF +* + DO 10 I = ILO, IHI - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + AII = A( I+1, I ) + A( I+1, I ) = ONE +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) +* +* Apply H(i) to A(i+1:ihi,i+1:n) from the left +* + CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), + $ A( I+1, I+1 ), LDA, WORK ) +* + A( I+1, I ) = AII + 10 CONTINUE +* + RETURN +* +* End of DGEHD2 +* + END +*> \brief \b DGEHRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEHRD reduces a real general matrix A to upper Hessenberg form H by +*> an orthogonal similarity transformation: Q**T * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to DGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the orthogonal matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to +*> zero. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,N). +*> For good performance, LWORK should generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup doubleGEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> +*> This file is a slight modification of LAPACK-3.0's DGEHRD +*> subroutine incorporating improvements proposed by Quintana-Orti and +*> Van de Geijn (2006). (See DLAHR2.) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + DOUBLE PRECISION EI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Compute the workspace requirements +* + NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + LWKOPT = N*NB + TSIZE + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEHRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero +* + DO 10 I = 1, ILO - 1 + TAU( I ) = ZERO + 10 CONTINUE + DO 20 I = MAX( 1, IHI ), N - 1 + TAU( I ) = ZERO + 20 CONTINUE +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Determine the block size +* + NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + NBMIN = 2 + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code) +* + NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code +* + IF( LWORK.LT.N*NB+TSIZE ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code +* + NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.(N*NBMIN + TSIZE) ) THEN + NB = (LWORK-TSIZE) / N + ELSE + NB = 1 + END IF + END IF + END IF + END IF + LDWORK = N +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + I = ILO +* + ELSE +* +* Use blocked code +* + IWT = 1 + N*NB + DO 40 I = ILO, IHI - 1 - NX, NB + IB = MIN( NB, IHI-I ) +* +* Reduce columns i:i+ib-1 to Hessenberg form, returning the +* matrices V and T of the block reflector H = I - V*T*V**T +* which performs the reduction, and also the matrix Y = A*V*T +* + CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), + $ WORK( IWT ), LDT, WORK, LDWORK ) +* +* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the +* right, computing A := A - Y * V**T. V(i+ib,ib-1) must be set +* to 1 +* + EI = A( I+IB, I+IB-1 ) + A( I+IB, I+IB-1 ) = ONE + CALL DGEMM( 'No transpose', 'Transpose', + $ IHI, IHI-I-IB+1, + $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, + $ A( 1, I+IB ), LDA ) + A( I+IB, I+IB-1 ) = EI +* +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE +* +* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the +* left +* + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', + $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, + $ WORK( IWT ), LDT, A( I+1, I+IB ), LDA, + $ WORK, LDWORK ) + 40 CONTINUE + END IF +* +* Use unblocked code to reduce the rest of the matrix +* + CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DGEHRD +* + END +*> \brief \b DHSEQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DHSEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, +* LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N +* CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DHSEQR computes the eigenvalues of a Hessenberg matrix H +*> and, optionally, the matrices T and Z from the Schur decomposition +*> H = Z T Z**T, where T is an upper quasi-triangular matrix (the +*> Schur form), and Z is the orthogonal matrix of Schur vectors. +*> +*> Optionally Z may be postmultiplied into an input orthogonal +*> matrix Q so that this routine can give the Schur factorization +*> of a matrix A which has been reduced to the Hessenberg form H +*> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOB +*> \verbatim +*> JOB is CHARACTER*1 +*> = 'E': compute eigenvalues only; +*> = 'S': compute eigenvalues and the Schur form T. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': no Schur vectors are computed; +*> = 'I': Z is initialized to the unit matrix and the matrix Z +*> of Schur vectors of H is returned; +*> = 'V': Z must contain an orthogonal matrix Q on entry, and +*> the product Q*Z is returned. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that H is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to DGEBAL, and then passed to ZGEHRD +*> when the matrix output by DGEBAL is reduced to Hessenberg +*> form. Otherwise ILO and IHI should be set to 1 and N +*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +*> If N = 0, then ILO = 1 and IHI = 0. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO = 0 and JOB = 'S', then H contains the +*> upper quasi-triangular matrix T from the Schur decomposition +*> (the Schur form); 2-by-2 diagonal blocks (corresponding to +*> complex conjugate pairs of eigenvalues) are returned in +*> standard form, with H(i,i) = H(i+1,i+1) and +*> H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the +*> contents of H are unspecified on exit. (The output value of +*> H when INFO.GT.0 is given under the description of INFO +*> below.) +*> +*> Unlike earlier versions of DHSEQR, this subroutine may +*> explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 +*> or j = IHI+1, IHI+2, ... N. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (N) +*> +*> The real and imaginary parts, respectively, of the computed +*> eigenvalues. If two eigenvalues are computed as a complex +*> conjugate pair, they are stored in consecutive elements of +*> WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and +*> WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in +*> the same order as on the diagonal of the Schur form returned +*> in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 +*> diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +*> WI(i+1) = -WI(i). +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,N) +*> If COMPZ = 'N', Z is not referenced. +*> If COMPZ = 'I', on entry Z need not be set and on exit, +*> if INFO = 0, Z contains the orthogonal matrix Z of the Schur +*> vectors of H. If COMPZ = 'V', on entry Z must contain an +*> N-by-N matrix Q, which is assumed to be equal to the unit +*> matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, +*> if INFO = 0, Z contains Q*Z. +*> Normally Q is the orthogonal matrix generated by DORGHR +*> after the call to DGEHRD which formed the Hessenberg matrix +*> H. (The output value of Z when INFO.GT.0 is given under +*> the description of INFO below.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if COMPZ = 'I' or +*> COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK .GE. max(1,N) +*> is sufficient and delivers very good and sometimes +*> optimal performance. However, LWORK as large as 11*N +*> may be required for optimal performance. A workspace +*> query is recommended to determine the optimal workspace +*> size. +*> +*> If LWORK = -1, then DHSEQR does a workspace query. +*> In this case, DHSEQR checks the input parameters and +*> estimates the optimal workspace size for the given +*> values of N, ILO and IHI. The estimate is returned +*> in WORK(1). No error message related to LWORK is +*> issued by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .LT. 0: if INFO = -i, the i-th argument had an illegal +*> value +*> .GT. 0: if INFO = i, DHSEQR failed to compute all of +*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +*> and WI contain those eigenvalues which have been +*> successfully computed. (Failures are rare.) +*> +*> If INFO .GT. 0 and JOB = 'E', then on exit, the +*> remaining unconverged eigenvalues are the eigen- +*> values of the upper Hessenberg matrix rows and +*> columns ILO through INFO of the final, output +*> value of H. +*> +*> If INFO .GT. 0 and JOB = 'S', then on exit +*> +*> (*) (initial value of H)*U = U*(final value of H) +*> +*> where U is an orthogonal matrix. The final +*> value of H is upper Hessenberg and quasi-triangular +*> in rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and COMPZ = 'V', then on exit +*> +*> (final value of Z) = (initial value of Z)*U +*> +*> where U is the orthogonal matrix in (*) (regard- +*> less of the value of JOB.) +*> +*> If INFO .GT. 0 and COMPZ = 'I', then on exit +*> (final value of Z) = U +*> where U is the orthogonal matrix in (*) (regard- +*> less of the value of JOB.) +*> +*> If INFO .GT. 0 and COMPZ = 'N', then Z is not +*> accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Default values supplied by +*> ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). +*> It is suggested that these defaults be adjusted in order +*> to attain best performance in each particular +*> computational environment. +*> +*> ISPEC=12: The DLAHQR vs DLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> ISPEC=13: Recommended deflation window size. +*> This depends on ILO, IHI and NS. NS is the +*> number of simultaneous shifts returned +*> by ILAENV(ISPEC=15). (See ISPEC=15 below.) +*> The default for (IHI-ILO+1).LE.500 is NS. +*> The default for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> ISPEC=14: Nibble crossover point. (See IPARMQ for +*> details.) Default: 14% of deflation window +*> size. +*> +*> ISPEC=15: Number of simultaneous shifts in a multishift +*> QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 1 30 NS = 2(+) +*> 30 60 NS = 4(+) +*> 60 150 NS = 10(+) +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default some or all matrices of this order +*> are passed to the implicit double shift routine +*> DLAHQR and this parameter is ignored. See +*> ISPEC=12 above and comments in IPARMQ for +*> details. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function of N increasing from 10 to 64. +*> +*> ISPEC=16: Select structured matrix multiply. +*> If the number of simultaneous shifts (specified +*> by ISPEC=15) is less than 14, then the default +*> for ISPEC=16 is 0. Otherwise the default for +*> ISPEC=16 is 2. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> \n +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +*> of Matrix Analysis, volume 23, pages 948--973, 2002. +* +* ===================================================================== + SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, + $ LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== NL allocates some local workspace to help small matrices +* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- +* . mended. (The default value of NMIN is 75.) Using NL = 49 +* . allows up to six simultaneous shifts and a 16-by-16 +* . deflation window. ==== + INTEGER NL + PARAMETER ( NL = 49 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Arrays .. + DOUBLE PRECISION HL( NL, NL ), WORKL( NL ) +* .. +* .. Local Scalars .. + INTEGER I, KBOT, NMIN + LOGICAL INITZ, LQUERY, WANTT, WANTZ +* .. +* .. External Functions .. + INTEGER ILAENV + LOGICAL LSAME + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* ==== Decode and check the input parameters. ==== +* + WANTT = LSAME( JOB, 'S' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DBLE( MAX( 1, N ) ) + LQUERY = LWORK.EQ.-1 +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.NE.0 ) THEN +* +* ==== Quick return in case of invalid argument. ==== +* + CALL XERBLA( 'DHSEQR', -INFO ) + RETURN +* + ELSE IF( N.EQ.0 ) THEN +* +* ==== Quick return in case N = 0; nothing to do. ==== +* + RETURN +* + ELSE IF( LQUERY ) THEN +* +* ==== Quick return in case of a workspace query ==== +* + CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, WORK, LWORK, INFO ) +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== + WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) + RETURN +* + ELSE +* +* ==== copy eigenvalues isolated by DGEBAL ==== +* + DO 10 I = 1, ILO - 1 + WR( I ) = H( I, I ) + WI( I ) = ZERO + 10 CONTINUE + DO 20 I = IHI + 1, N + WR( I ) = H( I, I ) + WI( I ) = ZERO + 20 CONTINUE +* +* ==== Initialize Z, if requested ==== +* + IF( INITZ ) + $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) +* +* ==== Quick return if possible ==== +* + IF( ILO.EQ.IHI ) THEN + WR( ILO ) = H( ILO, ILO ) + WI( ILO ) = ZERO + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, + $ ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== +* + IF( N.GT.NMIN ) THEN + CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, WORK, LWORK, INFO ) + ELSE +* +* ==== Small matrix ==== +* + CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, + $ IHI, Z, LDZ, INFO ) +* + IF( INFO.GT.0 ) THEN +* +* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds +* . when DLAHQR fails. ==== +* + KBOT = INFO +* + IF( N.GE.NL ) THEN +* +* ==== Larger matrices have enough subdiagonal scratch +* . space to call DLAQR0 directly. ==== +* + CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR, + $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) +* + ELSE +* +* ==== Tiny matrices don't have enough subdiagonal +* . scratch space to benefit from DLAQR0. Hence, +* . tiny matrices must be copied into a larger +* . array before calling DLAQR0. ==== +* + CALL DLACPY( 'A', N, N, H, LDH, HL, NL ) + HL( N+1, N ) = ZERO + CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), + $ NL ) + CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR, + $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO ) + IF( WANTT .OR. INFO.NE.0 ) + $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH ) + END IF + END IF + END IF +* +* ==== Clear out the trash, if necessary. ==== +* + IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) +* +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== +* + WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) ) + END IF +* +* ==== End of DHSEQR ==== +* + END +*> \brief \b DISNAN tests input for NaN. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* LOGICAL FUNCTION DISNAN( DIN ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DIN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DISNAN returns .TRUE. if its argument is NaN, and .FALSE. +*> otherwise. To be replaced by the Fortran 2003 intrinsic in the +*> future. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIN +*> \verbatim +*> DIN is DOUBLE PRECISION +*> Input to test for NaN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + LOGICAL FUNCTION DISNAN( DIN ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DIN +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL DLAISNAN + EXTERNAL DLAISNAN +* .. +* .. Executable Statements .. + DISNAN = DLAISNAN(DIN,DIN) + RETURN + END +*> \brief \b DLABAD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLABAD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLABAD( SMALL, LARGE ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION LARGE, SMALL +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLABAD takes as input the values computed by DLAMCH for underflow and +*> overflow, and returns the square root of each of these values if the +*> log of LARGE is sufficiently large. This subroutine is intended to +*> identify machines with a large exponent range, such as the Crays, and +*> redefine the underflow and overflow limits to be the square roots of +*> the values computed by DLAMCH. This subroutine is needed because +*> DLAMCH does not compensate for poor arithmetic in the upper half of +*> the exponent range, as is found on a Cray. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] SMALL +*> \verbatim +*> SMALL is DOUBLE PRECISION +*> On entry, the underflow threshold as computed by DLAMCH. +*> On exit, if LOG10(LARGE) is sufficiently large, the square +*> root of SMALL, otherwise unchanged. +*> \endverbatim +*> +*> \param[in,out] LARGE +*> \verbatim +*> LARGE is DOUBLE PRECISION +*> On entry, the overflow threshold as computed by DLAMCH. +*> On exit, if LOG10(LARGE) is sufficiently large, the square +*> root of LARGE, otherwise unchanged. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLABAD( SMALL, LARGE ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + DOUBLE PRECISION LARGE, SMALL +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LOG10, SQRT +* .. +* .. Executable Statements .. +* +* If it looks like we're on a Cray, take the square root of +* SMALL and LARGE to avoid overflow and underflow problems. +* + IF( LOG10( LARGE ).GT.2000.D0 ) THEN + SMALL = SQRT( SMALL ) + LARGE = SQRT( LARGE ) + END IF +* + RETURN +* +* End of DLABAD +* + END +*> \brief \b DLACPY copies all or part of one two-dimensional array to another. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLACPY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLACPY copies all or part of a two-dimensional matrix A to another +*> matrix B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies the part of the matrix A to be copied to B. +*> = 'U': Upper triangular part +*> = 'L': Lower triangular part +*> Otherwise: All of the matrix A +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. If UPLO = 'U', only the upper triangle +*> or trapezoid is accessed; if UPLO = 'L', only the lower +*> triangle or trapezoid is accessed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> On exit, B = A in the locations specified by UPLO. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B( I, J ) = A( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF + RETURN +* +* End of DLACPY +* + END +*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLADIV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLADIV performs complex division in real arithmetic +*> +*> a + i*b +*> p + i*q = --------- +*> c + i*d +*> +*> The algorithm is due to Michael Baudin and Robert L. Smith +*> and can be found in the paper +*> "A Robust Complex Division in Scilab" +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION +*> The scalars a, b, c, and d in the above expression. +*> \endverbatim +*> +*> \param[out] P +*> \verbatim +*> P is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION +*> The scalars p and q in the above expression. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2013 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLADIV( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION BS + PARAMETER ( BS = 2.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLADIV1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + AA = A + BB = B + CC = C + DD = D + AB = MAX( ABS(A), ABS(B) ) + CD = MAX( ABS(C), ABS(D) ) + S = 1.0D0 + + OV = DLAMCH( 'Overflow threshold' ) + UN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + BE = BS / (EPS*EPS) + + IF( AB >= HALF*OV ) THEN + AA = HALF * AA + BB = HALF * BB + S = TWO * S + END IF + IF( CD >= HALF*OV ) THEN + CC = HALF * CC + DD = HALF * DD + S = HALF * S + END IF + IF( AB <= UN*BS/EPS ) THEN + AA = AA * BE + BB = BB * BE + S = S / BE + END IF + IF( CD <= UN*BS/EPS ) THEN + CC = CC * BE + DD = DD * BE + S = S * BE + END IF + IF( ABS( D ).LE.ABS( C ) ) THEN + CALL DLADIV1(AA, BB, CC, DD, P, Q) + ELSE + CALL DLADIV1(BB, AA, DD, CC, P, Q) + Q = -Q + END IF + P = P * S + Q = Q * S +* + RETURN +* +* End of DLADIV +* + END + + + + SUBROUTINE DLADIV1( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION R, T +* .. +* .. External Functions .. + DOUBLE PRECISION DLADIV2 + EXTERNAL DLADIV2 +* .. +* .. Executable Statements .. +* + R = D / C + T = ONE / (C + D * R) + P = DLADIV2(A, B, C, D, R, T) + A = -A + Q = DLADIV2(B, A, C, D, R, T) +* + RETURN +* +* End of DLADIV1 +* + END + + DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, R, T +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION BR +* .. +* .. Executable Statements .. +* + IF( R.NE.ZERO ) THEN + BR = B * R + IF( BR.NE.ZERO ) THEN + DLADIV2 = (A + BR) * T + ELSE + DLADIV2 = A * T + (B * T) * R + END IF + ELSE + DLADIV2 = (A + D * (B / C)) * T + END IF +* + RETURN +* +* End of DLADIV12 +* + END +*> \brief \b DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAEXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* LOGICAL WANTQ +* INTEGER INFO, J1, LDQ, LDT, N, N1, N2 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in +*> an upper quasi-triangular matrix T by an orthogonal similarity +*> transformation. +*> +*> T must be in Schur canonical form, that is, block upper triangular +*> with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block +*> has its diagonal elemnts equal and its off-diagonal elements of +*> opposite sign. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTQ +*> \verbatim +*> WANTQ is LOGICAL +*> = .TRUE. : accumulate the transformation in the matrix Q; +*> = .FALSE.: do not accumulate the transformation. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> On entry, the upper quasi-triangular matrix T, in Schur +*> canonical form. +*> On exit, the updated matrix T, again in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> On entry, if WANTQ is .TRUE., the orthogonal matrix Q. +*> On exit, if WANTQ is .TRUE., the updated matrix Q. +*> If WANTQ is .FALSE., Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. +*> \endverbatim +*> +*> \param[in] J1 +*> \verbatim +*> J1 is INTEGER +*> The index of the first row of the first block T11. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> The order of the first block T11. N1 = 0, 1 or 2. +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> The order of the second block T22. N2 = 0, 1 or 2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> = 1: the transformed matrix T would be too far from Schur +*> form; the blocks are not swapped and T and Q are +*> unchanged. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, + $ INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + LOGICAL WANTQ + INTEGER INFO, J1, LDQ, LDT, N, N1, N2 +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 1.0D+1 ) + INTEGER LDD, LDX + PARAMETER ( LDD = 4, LDX = 2 ) +* .. +* .. Local Scalars .. + INTEGER IERR, J2, J3, J4, K, ND + DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, + $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, + $ WR1, WR2, XNORM +* .. +* .. Local Arrays .. + DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), + $ X( LDX, 2 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2, + $ DROT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN + IF( J1+N1.GT.N ) + $ RETURN +* + J2 = J1 + 1 + J3 = J1 + 2 + J4 = J1 + 3 +* + IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN +* +* Swap two 1-by-1 blocks. +* + T11 = T( J1, J1 ) + T22 = T( J2, J2 ) +* +* Determine the transformation to perform the interchange. +* + CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) +* +* Apply transformation to the matrix T. +* + IF( J3.LE.N ) + $ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, + $ SN ) + CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) +* + T( J1, J1 ) = T22 + T( J2, J2 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) + END IF +* + ELSE +* +* Swapping involves at least one 2-by-2 block. +* +* Copy the diagonal block of order N1+N2 to the local array D +* and compute its norm. +* + ND = N1 + N2 + CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) + DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK ) +* +* Compute machine-dependent threshold for test for accepting +* swap. +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) +* +* Solve T11*X - X*T22 = scale*T12 for X. +* + CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, + $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, + $ LDX, XNORM, IERR ) +* +* Swap the adjacent diagonal blocks. +* + K = N1 + N1 + N2 - 3 + GO TO ( 10, 20, 30 )K +* + 10 CONTINUE +* +* N1 = 1, N2 = 2: generate elementary reflector H so that: +* +* ( scale, X11, X12 ) H = ( 0, 0, * ) +* + U( 1 ) = SCALE + U( 2 ) = X( 1, 1 ) + U( 3 ) = X( 1, 2 ) + CALL DLARFG( 3, U( 3 ), U, 1, TAU ) + U( 3 ) = ONE + T11 = T( J1, J1 ) +* +* Perform swap provisionally on diagonal block in D. +* + CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) + CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) +* +* Test whether to reject swap. +* + IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, + $ 3 )-T11 ) ).GT.THRESH )GO TO 50 +* +* Accept swap: apply transformation to the entire matrix T. +* + CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) + CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) +* + T( J3, J1 ) = ZERO + T( J3, J2 ) = ZERO + T( J3, J3 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) + END IF + GO TO 40 +* + 20 CONTINUE +* +* N1 = 2, N2 = 1: generate elementary reflector H so that: +* +* H ( -X11 ) = ( * ) +* ( -X21 ) = ( 0 ) +* ( scale ) = ( 0 ) +* + U( 1 ) = -X( 1, 1 ) + U( 2 ) = -X( 2, 1 ) + U( 3 ) = SCALE + CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) + U( 1 ) = ONE + T33 = T( J3, J3 ) +* +* Perform swap provisionally on diagonal block in D. +* + CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) + CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) +* +* Test whether to reject swap. +* + IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, + $ 1 )-T33 ) ).GT.THRESH )GO TO 50 +* +* Accept swap: apply transformation to the entire matrix T. +* + CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) + CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) +* + T( J1, J1 ) = T33 + T( J2, J1 ) = ZERO + T( J3, J1 ) = ZERO +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) + END IF + GO TO 40 +* + 30 CONTINUE +* +* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so +* that: +* +* H(2) H(1) ( -X11 -X12 ) = ( * * ) +* ( -X21 -X22 ) ( 0 * ) +* ( scale 0 ) ( 0 0 ) +* ( 0 scale ) ( 0 0 ) +* + U1( 1 ) = -X( 1, 1 ) + U1( 2 ) = -X( 2, 1 ) + U1( 3 ) = SCALE + CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) + U1( 1 ) = ONE +* + TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) + U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) + U2( 2 ) = -TEMP*U1( 3 ) + U2( 3 ) = SCALE + CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) + U2( 1 ) = ONE +* +* Perform swap provisionally on diagonal block in D. +* + CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) + CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) + CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) + CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) +* +* Test whether to reject swap. +* + IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), + $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 +* +* Accept swap: apply transformation to the entire matrix T. +* + CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) + CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) + CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) + CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) +* + T( J3, J1 ) = ZERO + T( J3, J2 ) = ZERO + T( J4, J1 ) = ZERO + T( J4, J2 ) = ZERO +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) + CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) + END IF +* + 40 CONTINUE +* + IF( N2.EQ.2 ) THEN +* +* Standardize new 2-by-2 block T11 +* + CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), + $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) + CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, + $ CS, SN ) + CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) + IF( WANTQ ) + $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) + END IF +* + IF( N1.EQ.2 ) THEN +* +* Standardize new 2-by-2 block T22 +* + J3 = J1 + N2 + J4 = J3 + 1 + CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), + $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) + IF( J3+2.LE.N ) + $ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), + $ LDT, CS, SN ) + CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) + IF( WANTQ ) + $ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) + END IF +* + END IF + RETURN +* +* Exit with INFO = 1 if swap was rejected. +* + 50 CONTINUE + INFO = 1 + RETURN +* +* End of DLAEXC +* + END +*> \brief \b DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAHQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +* ILOZ, IHIZ, Z, LDZ, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAHQR is an auxiliary routine called by DHSEQR to update the +*> eigenvalues and Schur decomposition already computed by DHSEQR, by +*> dealing with the Hessenberg submatrix in rows and columns ILO to +*> IHI. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper quasi-triangular in +*> rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless +*> ILO = 1). DLAHQR works primarily with the Hessenberg +*> submatrix in rows and columns ILO to IHI, but applies +*> transformations to all of H if WANTT is .TRUE.. +*> 1 <= ILO <= max(1,IHI); IHI <= N. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO is zero and if WANTT is .TRUE., H is upper +*> quasi-triangular in rows and columns ILO:IHI, with any +*> 2-by-2 diagonal blocks in standard form. If INFO is zero +*> and WANTT is .FALSE., the contents of H are unspecified on +*> exit. The output state of H if INFO is nonzero is given +*> below under the description of INFO. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH >= max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (N) +*> The real and imaginary parts, respectively, of the computed +*> eigenvalues ILO to IHI are stored in the corresponding +*> elements of WR and WI. If two eigenvalues are computed as a +*> complex conjugate pair, they are stored in consecutive +*> elements of WR and WI, say the i-th and (i+1)th, with +*> WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the +*> eigenvalues are stored in the same order as on the diagonal +*> of the Schur form returned in H, with WR(i) = H(i,i), and, if +*> H(i:i+1,i:i+1) is a 2-by-2 diagonal block, +*> WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,N) +*> If WANTZ is .TRUE., on entry Z must contain the current +*> matrix Z of transformations accumulated by DHSEQR, and on +*> exit Z has been updated; transformations are applied only to +*> the submatrix Z(ILOZ:IHIZ,ILO:IHI). +*> If WANTZ is .FALSE., Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .GT. 0: If INFO = i, DLAHQR failed to compute all the +*> eigenvalues ILO to IHI in a total of 30 iterations +*> per eigenvalue; elements i+1:ihi of WR and WI +*> contain those eigenvalues which have been +*> successfully computed. +*> +*> If INFO .GT. 0 and WANTT is .FALSE., then on exit, +*> the remaining unconverged eigenvalues are the +*> eigenvalues of the upper Hessenberg matrix rows +*> and columns ILO thorugh INFO of the final, output +*> value of H. +*> +*> If INFO .GT. 0 and WANTT is .TRUE., then on exit +*> (*) (initial value of H)*U = U*(final value of H) +*> where U is an orthognal matrix. The final +*> value of H is upper Hessenberg and triangular in +*> rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit +*> (final value of Z) = (initial value of Z)*U +*> where U is the orthogonal matrix in (*) +*> (regardless of the value of WANTT.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> 02-96 Based on modifications by +*> David Day, Sandia National Laboratory, USA +*> +*> 12-04 Further modifications by +*> Ralph Byers, University of Kansas, USA +*> This is a modified version of DLAHQR from LAPACK version 3.0. +*> It is (1) more robust against overflow and underflow and +*> (2) adopts the more conservative Ahues & Tisseur stopping +*> criterion (LAWN 122, 1997). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) +* .. +* +* ========================================================= +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 ) + DOUBLE PRECISION DAT1, DAT2 + PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S, + $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX, + $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST, + $ ULP, V2, V3 + INTEGER I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ +* .. +* .. Local Arrays .. + DOUBLE PRECISION V( 3 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( ILO.EQ.IHI ) THEN + WR( ILO ) = H( ILO, ILO ) + WI( ILO ) = ZERO + RETURN + END IF +* +* ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO +* + NH = IHI - ILO + 1 + NZ = IHIZ - ILOZ + 1 +* +* Set machine-dependent constants for the stopping criterion. +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) +* +* I1 and I2 are the indices of the first row and last column of H +* to which transformations must be applied. If eigenvalues only are +* being computed, I1 and I2 are set inside the main loop. +* + IF( WANTT ) THEN + I1 = 1 + I2 = N + END IF +* +* ITMAX is the total number of QR iterations allowed. +* + ITMAX = 30 * MAX( 10, NH ) +* +* The main loop begins here. I is the loop index and decreases from +* IHI to ILO in steps of 1 or 2. Each iteration of the loop works +* with the active submatrix in rows and columns L to I. +* Eigenvalues I+1 to IHI have already converged. Either L = ILO or +* H(L,L-1) is negligible so that the matrix splits. +* + I = IHI + 20 CONTINUE + L = ILO + IF( I.LT.ILO ) + $ GO TO 160 +* +* Perform QR iterations on rows and columns ILO to I until a +* submatrix of order 1 or 2 splits off at the bottom because a +* subdiagonal element has become negligible. +* + DO 140 ITS = 0, ITMAX +* +* Look for a single small subdiagonal element. +* + DO 30 K = I, L + 1, -1 + IF( ABS( H( K, K-1 ) ).LE.SMLNUM ) + $ GO TO 40 + TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) + IF( TST.EQ.ZERO ) THEN + IF( K-2.GE.ILO ) + $ TST = TST + ABS( H( K-1, K-2 ) ) + IF( K+1.LE.IHI ) + $ TST = TST + ABS( H( K+1, K ) ) + END IF +* ==== The following is a conservative small subdiagonal +* . deflation criterion due to Ahues & Tisseur (LAWN 122, +* . 1997). It has better mathematical foundation and +* . improves accuracy in some cases. ==== + IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN + AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) + BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) ) + AA = MAX( ABS( H( K, K ) ), + $ ABS( H( K-1, K-1 )-H( K, K ) ) ) + BB = MIN( ABS( H( K, K ) ), + $ ABS( H( K-1, K-1 )-H( K, K ) ) ) + S = AA + AB + IF( BA*( AB / S ).LE.MAX( SMLNUM, + $ ULP*( BB*( AA / S ) ) ) )GO TO 40 + END IF + 30 CONTINUE + 40 CONTINUE + L = K + IF( L.GT.ILO ) THEN +* +* H(L,L-1) is negligible +* + H( L, L-1 ) = ZERO + END IF +* +* Exit from loop if a submatrix of order 1 or 2 has split off. +* + IF( L.GE.I-1 ) + $ GO TO 150 +* +* Now the active submatrix is in rows and columns L to I. If +* eigenvalues only are being computed, only the active submatrix +* need be transformed. +* + IF( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF +* + IF( ITS.EQ.10 ) THEN +* +* Exceptional shift. +* + S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) + H11 = DAT1*S + H( L, L ) + H12 = DAT2*S + H21 = S + H22 = H11 + ELSE IF( ITS.EQ.20 ) THEN +* +* Exceptional shift. +* + S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + H11 = DAT1*S + H( I, I ) + H12 = DAT2*S + H21 = S + H22 = H11 + ELSE +* +* Prepare to use Francis' double shift +* (i.e. 2nd degree generalized Rayleigh quotient) +* + H11 = H( I-1, I-1 ) + H21 = H( I, I-1 ) + H12 = H( I-1, I ) + H22 = H( I, I ) + END IF + S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 ) + IF( S.EQ.ZERO ) THEN + RT1R = ZERO + RT1I = ZERO + RT2R = ZERO + RT2I = ZERO + ELSE + H11 = H11 / S + H21 = H21 / S + H12 = H12 / S + H22 = H22 / S + TR = ( H11+H22 ) / TWO + DET = ( H11-TR )*( H22-TR ) - H12*H21 + RTDISC = SQRT( ABS( DET ) ) + IF( DET.GE.ZERO ) THEN +* +* ==== complex conjugate shifts ==== +* + RT1R = TR*S + RT2R = RT1R + RT1I = RTDISC*S + RT2I = -RT1I + ELSE +* +* ==== real shifts (use only one of them) ==== +* + RT1R = TR + RTDISC + RT2R = TR - RTDISC + IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN + RT1R = RT1R*S + RT2R = RT1R + ELSE + RT2R = RT2R*S + RT1R = RT2R + END IF + RT1I = ZERO + RT2I = ZERO + END IF + END IF +* +* Look for two consecutive small subdiagonal elements. +* + DO 50 M = I - 2, L, -1 +* Determine the effect of starting the double-shift QR +* iteration at row M, and see if this would make H(M,M-1) +* negligible. (The following uses scaling to avoid +* overflows and most underflows.) +* + H21S = H( M+1, M ) + S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S ) + H21S = H( M+1, M ) / S + V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )* + $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S ) + V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R ) + V( 3 ) = H21S*H( M+2, M+1 ) + S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) ) + V( 1 ) = V( 1 ) / S + V( 2 ) = V( 2 ) / S + V( 3 ) = V( 3 ) / S + IF( M.EQ.L ) + $ GO TO 60 + IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE. + $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M, + $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60 + 50 CONTINUE + 60 CONTINUE +* +* Double-shift QR step +* + DO 130 K = M, I - 1 +* +* The first iteration of this loop determines a reflection G +* from the vector V and applies it from left and right to H, +* thus creating a nonzero bulge below the subdiagonal. +* +* Each subsequent iteration determines a reflection G to +* restore the Hessenberg form in the (K-1)th column, and thus +* chases the bulge one step toward the bottom of the active +* submatrix. NR is the order of G. +* + NR = MIN( 3, I-K+1 ) + IF( K.GT.M ) + $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) + CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) + IF( K.GT.M ) THEN + H( K, K-1 ) = V( 1 ) + H( K+1, K-1 ) = ZERO + IF( K.LT.I-1 ) + $ H( K+2, K-1 ) = ZERO + ELSE IF( M.GT.L ) THEN +* ==== Use the following instead of +* . H( K, K-1 ) = -H( K, K-1 ) to +* . avoid a bug when v(2) and v(3) +* . underflow. ==== + H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) + END IF + V2 = V( 2 ) + T2 = T1*V2 + IF( NR.EQ.3 ) THEN + V3 = V( 3 ) + T3 = T1*V3 +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 70 J = K, I2 + SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) + H( K, J ) = H( K, J ) - SUM*T1 + H( K+1, J ) = H( K+1, J ) - SUM*T2 + H( K+2, J ) = H( K+2, J ) - SUM*T3 + 70 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+3,I). +* + DO 80 J = I1, MIN( K+3, I ) + SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) + H( J, K ) = H( J, K ) - SUM*T1 + H( J, K+1 ) = H( J, K+1 ) - SUM*T2 + H( J, K+2 ) = H( J, K+2 ) - SUM*T3 + 80 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 90 J = ILOZ, IHIZ + SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) + Z( J, K ) = Z( J, K ) - SUM*T1 + Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 + Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 + 90 CONTINUE + END IF + ELSE IF( NR.EQ.2 ) THEN +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 100 J = K, I2 + SUM = H( K, J ) + V2*H( K+1, J ) + H( K, J ) = H( K, J ) - SUM*T1 + H( K+1, J ) = H( K+1, J ) - SUM*T2 + 100 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+3,I). +* + DO 110 J = I1, I + SUM = H( J, K ) + V2*H( J, K+1 ) + H( J, K ) = H( J, K ) - SUM*T1 + H( J, K+1 ) = H( J, K+1 ) - SUM*T2 + 110 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 120 J = ILOZ, IHIZ + SUM = Z( J, K ) + V2*Z( J, K+1 ) + Z( J, K ) = Z( J, K ) - SUM*T1 + Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 + 120 CONTINUE + END IF + END IF + 130 CONTINUE +* + 140 CONTINUE +* +* Failure to converge in remaining number of iterations +* + INFO = I + RETURN +* + 150 CONTINUE +* + IF( L.EQ.I ) THEN +* +* H(I,I-1) is negligible: one eigenvalue has converged. +* + WR( I ) = H( I, I ) + WI( I ) = ZERO + ELSE IF( L.EQ.I-1 ) THEN +* +* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. +* +* Transform the 2-by-2 submatrix to standard Schur form, +* and compute and store the eigenvalues. +* + CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), + $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), + $ CS, SN ) +* + IF( WANTT ) THEN +* +* Apply the transformation to the rest of H. +* + IF( I2.GT.I ) + $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, + $ CS, SN ) + CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) + END IF + IF( WANTZ ) THEN +* +* Apply the transformation to Z. +* + CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) + END IF + END IF +* +* return to start of the main loop with new value of I. +* + I = L - 1 + GO TO 20 +* + 160 CONTINUE + RETURN +* +* End of DLAHQR +* + END +*> \brief \b DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAHR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* .. Scalar Arguments .. +* INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), +* $ Y( LDY, NB ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) +*> matrix A so that elements below the k-th subdiagonal are zero. The +*> reduction is performed by an orthogonal similarity transformation +*> Q**T * A * Q. The routine returns the matrices V and T which determine +*> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T. +*> +*> This is an auxiliary routine called by DGEHRD. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The offset for the reduction. Elements below the k-th +*> subdiagonal in the first NB columns are reduced to zero. +*> K < N. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of columns to be reduced. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N-K+1) +*> On entry, the n-by-(n-k+1) general matrix A. +*> On exit, the elements on and above the k-th subdiagonal in +*> the first NB columns are overwritten with the corresponding +*> elements of the reduced matrix; the elements below the k-th +*> subdiagonal, with the array TAU, represent the matrix Q as a +*> product of elementary reflectors. The other columns of A are +*> unchanged. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (NB) +*> The scalar factors of the elementary reflectors. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NB) +*> The upper triangular matrix T. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= NB. +*> \endverbatim +*> +*> \param[out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension (LDY,NB) +*> The n-by-nb matrix Y. +*> \endverbatim +*> +*> \param[in] LDY +*> \verbatim +*> LDY is INTEGER +*> The leading dimension of the array Y. LDY >= N. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of nb elementary reflectors +*> +*> Q = H(1) H(2) . . . H(nb). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in +*> A(i+k+1:n,i), and tau in TAU(i). +*> +*> The elements of the vectors v together form the (n-k+1)-by-nb matrix +*> V which is needed, with T and Y, to apply the transformation to the +*> unreduced part of the matrix, using an update of the form: +*> A := (I - V*T*V**T) * (A - Y*V**T). +*> +*> The contents of A on exit are illustrated by the following example +*> with n = 7, k = 3 and nb = 2: +*> +*> ( a a a a a ) +*> ( a a a a a ) +*> ( a a a a a ) +*> ( h h a a a ) +*> ( v1 h a a a ) +*> ( v1 v2 a a a ) +*> ( v1 v2 a a a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> +*> This subroutine is a slight modification of LAPACK-3.0's DLAHRD +*> incorporating improvements proposed by Quintana-Orti and Van de +*> Gejin. Note that the entries of A(1:K,2:NB) differ from those +*> returned by the original LAPACK-3.0's DLAHRD routine. (This +*> subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) +*> \endverbatim +* +*> \par References: +* ================ +*> +*> Gregorio Quintana-Orti and Robert van de Geijn, "Improving the +*> performance of reduction to Hessenberg form," ACM Transactions on +*> Mathematical Software, 32(2):180-194, June 2006. +*> +* ===================================================================== + SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, + $ ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION EI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, + $ DLARFG, DSCAL, DTRMM, DTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V**T +* + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) +* +* Apply I - V * T**T * V**T to this column (call it b) from the +* left, using the last column of T as workspace +* +* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) +* ( V2 ) ( b2 ) +* +* where V1 is unit lower triangular +* +* w := V1**T * b1 +* + CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL DTRMV( 'Lower', 'Transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2**T * b2 +* + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), + $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) +* +* w := T**T * w +* + CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, + $ A( K+I, 1 ), + $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) +* +* b1 := b1 - V1*w +* + CALL DTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) +* + A( K+I-1, I-1 ) = EI + END IF +* +* Generate the elementary reflector H(I) to annihilate +* A(K+I+1:N,I) +* + CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(K+1:N,I) +* + CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) +* +* Compute T(1:I,I) +* + CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* +* Compute Y(1:K,1:NB) +* + CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) +* + RETURN +* +* End of DLAHR2 +* + END +*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAISNAN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DIN1, DIN2 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This routine is not for general use. It exists solely to avoid +*> over-optimization in DISNAN. +*> +*> DLAISNAN checks for NaNs by comparing its two arguments for +*> inequality. NaN is the only floating-point value where NaN != NaN +*> returns .TRUE. To check for NaNs, pass the same variable as both +*> arguments. +*> +*> A compiler must assume that the two arguments are +*> not the same variable, and the test will not be optimized away. +*> Interprocedural or whole-program optimization may delete this +*> test. The ISNAN functions will be replaced by the correct +*> Fortran 03 intrinsic once the intrinsic is widely available. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIN1 +*> \verbatim +*> DIN1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] DIN2 +*> \verbatim +*> DIN2 is DOUBLE PRECISION +*> Two numbers to compare for inequality. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DIN1, DIN2 +* .. +* +* ===================================================================== +* +* .. Executable Statements .. + DLAISNAN = (DIN1.NE.DIN2) + RETURN + END +*> \brief \b DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLALN2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, +* LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) +* +* .. Scalar Arguments .. +* LOGICAL LTRANS +* INTEGER INFO, LDA, LDB, LDX, NA, NW +* DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLALN2 solves a system of the form (ca A - w D ) X = s B +*> or (ca A**T - w D) X = s B with possible scaling ("s") and +*> perturbation of A. (A**T means A-transpose.) +*> +*> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA +*> real diagonal matrix, w is a real or complex value, and X and B are +*> NA x 1 matrices -- real if w is real, complex if w is complex. NA +*> may be 1 or 2. +*> +*> If w is complex, X and B are represented as NA x 2 matrices, +*> the first column of each being the real part and the second +*> being the imaginary part. +*> +*> "s" is a scaling factor (.LE. 1), computed by DLALN2, which is +*> so chosen that X can be computed without overflow. X is further +*> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less +*> than overflow. +*> +*> If both singular values of (ca A - w D) are less than SMIN, +*> SMIN*identity will be used instead of (ca A - w D). If only one +*> singular value is less than SMIN, one element of (ca A - w D) will be +*> perturbed enough to make the smallest singular value roughly SMIN. +*> If both singular values are at least SMIN, (ca A - w D) will not be +*> perturbed. In any case, the perturbation will be at most some small +*> multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values +*> are computed by infinity-norm approximations, and thus will only be +*> correct to a factor of 2 or so. +*> +*> Note: all input quantities are assumed to be smaller than overflow +*> by a reasonable factor. (See BIGNUM.) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] LTRANS +*> \verbatim +*> LTRANS is LOGICAL +*> =.TRUE.: A-transpose will be used. +*> =.FALSE.: A will be used (not transposed.) +*> \endverbatim +*> +*> \param[in] NA +*> \verbatim +*> NA is INTEGER +*> The size of the matrix A. It may (only) be 1 or 2. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> 1 if "w" is real, 2 if "w" is complex. It may only be 1 +*> or 2. +*> \endverbatim +*> +*> \param[in] SMIN +*> \verbatim +*> SMIN is DOUBLE PRECISION +*> The desired lower bound on the singular values of A. This +*> should be a safe distance away from underflow or overflow, +*> say, between (underflow/machine precision) and (machine +*> precision * overflow ). (See BIGNUM and ULP.) +*> \endverbatim +*> +*> \param[in] CA +*> \verbatim +*> CA is DOUBLE PRECISION +*> The coefficient c, which A is multiplied by. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,NA) +*> The NA x NA matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least NA. +*> \endverbatim +*> +*> \param[in] D1 +*> \verbatim +*> D1 is DOUBLE PRECISION +*> The 1,1 element in the diagonal matrix D. +*> \endverbatim +*> +*> \param[in] D2 +*> \verbatim +*> D2 is DOUBLE PRECISION +*> The 2,2 element in the diagonal matrix D. Not used if NW=1. +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NW) +*> The NA x NW matrix B (right-hand side). If NW=2 ("w" is +*> complex), column 1 contains the real part of B and column 2 +*> contains the imaginary part. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. It must be at least NA. +*> \endverbatim +*> +*> \param[in] WR +*> \verbatim +*> WR is DOUBLE PRECISION +*> The real part of the scalar "w". +*> \endverbatim +*> +*> \param[in] WI +*> \verbatim +*> WI is DOUBLE PRECISION +*> The imaginary part of the scalar "w". Not used if NW=1. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NW) +*> The NA x NW matrix X (unknowns), as computed by DLALN2. +*> If NW=2 ("w" is complex), on exit, column 1 will contain +*> the real part of X and column 2 will contain the imaginary +*> part. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of X. It must be at least NA. +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> The scale factor that B must be multiplied by to insure +*> that overflow does not occur when computing X. Thus, +*> (ca A - w D) X will be SCALE*B, not B (ignoring +*> perturbations of A.) It will be at most 1. +*> \endverbatim +*> +*> \param[out] XNORM +*> \verbatim +*> XNORM is DOUBLE PRECISION +*> The infinity-norm of X, when X is regarded as an NA x NW +*> real matrix. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> An error flag. It will be set to zero if no error occurs, +*> a negative number if an argument is in error, or a positive +*> number if ca A - w D had to be perturbed. +*> The possible values are: +*> = 0: No error occurred, and (ca A - w D) did not have to be +*> perturbed. +*> = 1: (ca A - w D) had to be perturbed to make its smallest +*> (or only) singular value greater than SMIN. +*> NOTE: In the interests of speed, this routine does not +*> check the inputs for errors. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, + $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + LOGICAL LTRANS + INTEGER INFO, LDA, LDB, LDX, NA, NW + DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* .. +* .. Local Scalars .. + INTEGER ICMAX, J + DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, + $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, + $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, + $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, + $ UR22, XI1, XI2, XR1, XR2 +* .. +* .. Local Arrays .. + LOGICAL RSWAP( 4 ), ZSWAP( 4 ) + INTEGER IPIVOT( 4, 4 ) + DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Equivalences .. + EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), + $ ( CR( 1, 1 ), CRV( 1 ) ) +* .. +* .. Data statements .. + DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / + DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, + $ 3, 2, 1 / +* .. +* .. Executable Statements .. +* +* Compute BIGNUM +* + SMLNUM = TWO*DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + SMINI = MAX( SMIN, SMLNUM ) +* +* Don't check for input errors +* + INFO = 0 +* +* Standard Initializations +* + SCALE = ONE +* + IF( NA.EQ.1 ) THEN +* +* 1 x 1 (i.e., scalar) system C X = B +* + IF( NW.EQ.1 ) THEN +* +* Real 1x1 system. +* +* C = ca A - w D +* + CSR = CA*A( 1, 1 ) - WR*D1 + CNORM = ABS( CSR ) +* +* If | C | < SMINI, use C = SMINI +* + IF( CNORM.LT.SMINI ) THEN + CSR = SMINI + CNORM = SMINI + INFO = 1 + END IF +* +* Check scaling for X = B / C +* + BNORM = ABS( B( 1, 1 ) ) + IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*CNORM ) + $ SCALE = ONE / BNORM + END IF +* +* Compute X +* + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR + XNORM = ABS( X( 1, 1 ) ) + ELSE +* +* Complex 1x1 system (w is complex) +* +* C = ca A - w D +* + CSR = CA*A( 1, 1 ) - WR*D1 + CSI = -WI*D1 + CNORM = ABS( CSR ) + ABS( CSI ) +* +* If | C | < SMINI, use C = SMINI +* + IF( CNORM.LT.SMINI ) THEN + CSR = SMINI + CSI = ZERO + CNORM = SMINI + INFO = 1 + END IF +* +* Check scaling for X = B / C +* + BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) + IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*CNORM ) + $ SCALE = ONE / BNORM + END IF +* +* Compute X +* + CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, + $ X( 1, 1 ), X( 1, 2 ) ) + XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) + END IF +* + ELSE +* +* 2x2 System +* +* Compute the real part of C = ca A - w D (or ca A**T - w D ) +* + CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 + CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 + IF( LTRANS ) THEN + CR( 1, 2 ) = CA*A( 2, 1 ) + CR( 2, 1 ) = CA*A( 1, 2 ) + ELSE + CR( 2, 1 ) = CA*A( 2, 1 ) + CR( 1, 2 ) = CA*A( 1, 2 ) + END IF +* + IF( NW.EQ.1 ) THEN +* +* Real 2x2 system (w is real) +* +* Find the largest element in C +* + CMAX = ZERO + ICMAX = 0 +* + DO 10 J = 1, 4 + IF( ABS( CRV( J ) ).GT.CMAX ) THEN + CMAX = ABS( CRV( J ) ) + ICMAX = J + END IF + 10 CONTINUE +* +* If norm(C) < SMINI, use SMINI*identity. +* + IF( CMAX.LT.SMINI ) THEN + BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) + IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*SMINI ) + $ SCALE = ONE / BNORM + END IF + TEMP = SCALE / SMINI + X( 1, 1 ) = TEMP*B( 1, 1 ) + X( 2, 1 ) = TEMP*B( 2, 1 ) + XNORM = TEMP*BNORM + INFO = 1 + RETURN + END IF +* +* Gaussian elimination with complete pivoting. +* + UR11 = CRV( ICMAX ) + CR21 = CRV( IPIVOT( 2, ICMAX ) ) + UR12 = CRV( IPIVOT( 3, ICMAX ) ) + CR22 = CRV( IPIVOT( 4, ICMAX ) ) + UR11R = ONE / UR11 + LR21 = UR11R*CR21 + UR22 = CR22 - UR12*LR21 +* +* If smaller pivot < SMINI, use SMINI +* + IF( ABS( UR22 ).LT.SMINI ) THEN + UR22 = SMINI + INFO = 1 + END IF + IF( RSWAP( ICMAX ) ) THEN + BR1 = B( 2, 1 ) + BR2 = B( 1, 1 ) + ELSE + BR1 = B( 1, 1 ) + BR2 = B( 2, 1 ) + END IF + BR2 = BR2 - LR21*BR1 + BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) + IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN + IF( BBND.GE.BIGNUM*ABS( UR22 ) ) + $ SCALE = ONE / BBND + END IF +* + XR2 = ( BR2*SCALE ) / UR22 + XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) + IF( ZSWAP( ICMAX ) ) THEN + X( 1, 1 ) = XR2 + X( 2, 1 ) = XR1 + ELSE + X( 1, 1 ) = XR1 + X( 2, 1 ) = XR2 + END IF + XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) +* +* Further scaling if norm(A) norm(X) > overflow +* + IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN + IF( XNORM.GT.BIGNUM / CMAX ) THEN + TEMP = CMAX / BIGNUM + X( 1, 1 ) = TEMP*X( 1, 1 ) + X( 2, 1 ) = TEMP*X( 2, 1 ) + XNORM = TEMP*XNORM + SCALE = TEMP*SCALE + END IF + END IF + ELSE +* +* Complex 2x2 system (w is complex) +* +* Find the largest element in C +* + CI( 1, 1 ) = -WI*D1 + CI( 2, 1 ) = ZERO + CI( 1, 2 ) = ZERO + CI( 2, 2 ) = -WI*D2 + CMAX = ZERO + ICMAX = 0 +* + DO 20 J = 1, 4 + IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN + CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) + ICMAX = J + END IF + 20 CONTINUE +* +* If norm(C) < SMINI, use SMINI*identity. +* + IF( CMAX.LT.SMINI ) THEN + BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), + $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) + IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN + IF( BNORM.GT.BIGNUM*SMINI ) + $ SCALE = ONE / BNORM + END IF + TEMP = SCALE / SMINI + X( 1, 1 ) = TEMP*B( 1, 1 ) + X( 2, 1 ) = TEMP*B( 2, 1 ) + X( 1, 2 ) = TEMP*B( 1, 2 ) + X( 2, 2 ) = TEMP*B( 2, 2 ) + XNORM = TEMP*BNORM + INFO = 1 + RETURN + END IF +* +* Gaussian elimination with complete pivoting. +* + UR11 = CRV( ICMAX ) + UI11 = CIV( ICMAX ) + CR21 = CRV( IPIVOT( 2, ICMAX ) ) + CI21 = CIV( IPIVOT( 2, ICMAX ) ) + UR12 = CRV( IPIVOT( 3, ICMAX ) ) + UI12 = CIV( IPIVOT( 3, ICMAX ) ) + CR22 = CRV( IPIVOT( 4, ICMAX ) ) + CI22 = CIV( IPIVOT( 4, ICMAX ) ) + IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN +* +* Code when off-diagonals of pivoted C are real +* + IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN + TEMP = UI11 / UR11 + UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) + UI11R = -TEMP*UR11R + ELSE + TEMP = UR11 / UI11 + UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) + UR11R = -TEMP*UI11R + END IF + LR21 = CR21*UR11R + LI21 = CR21*UI11R + UR12S = UR12*UR11R + UI12S = UR12*UI11R + UR22 = CR22 - UR12*LR21 + UI22 = CI22 - UR12*LI21 + ELSE +* +* Code when diagonals of pivoted C are real +* + UR11R = ONE / UR11 + UI11R = ZERO + LR21 = CR21*UR11R + LI21 = CI21*UR11R + UR12S = UR12*UR11R + UI12S = UI12*UR11R + UR22 = CR22 - UR12*LR21 + UI12*LI21 + UI22 = -UR12*LI21 - UI12*LR21 + END IF + U22ABS = ABS( UR22 ) + ABS( UI22 ) +* +* If smaller pivot < SMINI, use SMINI +* + IF( U22ABS.LT.SMINI ) THEN + UR22 = SMINI + UI22 = ZERO + INFO = 1 + END IF + IF( RSWAP( ICMAX ) ) THEN + BR2 = B( 1, 1 ) + BR1 = B( 2, 1 ) + BI2 = B( 1, 2 ) + BI1 = B( 2, 2 ) + ELSE + BR1 = B( 1, 1 ) + BR2 = B( 2, 1 ) + BI1 = B( 1, 2 ) + BI2 = B( 2, 2 ) + END IF + BR2 = BR2 - LR21*BR1 + LI21*BI1 + BI2 = BI2 - LI21*BR1 - LR21*BI1 + BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* + $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), + $ ABS( BR2 )+ABS( BI2 ) ) + IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN + IF( BBND.GE.BIGNUM*U22ABS ) THEN + SCALE = ONE / BBND + BR1 = SCALE*BR1 + BI1 = SCALE*BI1 + BR2 = SCALE*BR2 + BI2 = SCALE*BI2 + END IF + END IF +* + CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) + XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 + XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 + IF( ZSWAP( ICMAX ) ) THEN + X( 1, 1 ) = XR2 + X( 2, 1 ) = XR1 + X( 1, 2 ) = XI2 + X( 2, 2 ) = XI1 + ELSE + X( 1, 1 ) = XR1 + X( 2, 1 ) = XR2 + X( 1, 2 ) = XI1 + X( 2, 2 ) = XI2 + END IF + XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) +* +* Further scaling if norm(A) norm(X) > overflow +* + IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN + IF( XNORM.GT.BIGNUM / CMAX ) THEN + TEMP = CMAX / BIGNUM + X( 1, 1 ) = TEMP*X( 1, 1 ) + X( 2, 1 ) = TEMP*X( 2, 1 ) + X( 1, 2 ) = TEMP*X( 1, 2 ) + X( 2, 2 ) = TEMP*X( 2, 2 ) + XNORM = TEMP*XNORM + SCALE = TEMP*SCALE + END IF + END IF + END IF + END IF +* + RETURN +* +* End of DLALN2 +* + END +*> \brief \b DLAMCH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMCH determines double precision machine parameters. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CMACH +*> \verbatim +*> Specifies the value to be returned by DLAMCH: +*> = 'E' or 'e', DLAMCH := eps +*> = 'S' or 's , DLAMCH := sfmin +*> = 'B' or 'b', DLAMCH := base +*> = 'P' or 'p', DLAMCH := eps*base +*> = 'N' or 'n', DLAMCH := t +*> = 'R' or 'r', DLAMCH := rnd +*> = 'M' or 'm', DLAMCH := emin +*> = 'U' or 'u', DLAMCH := rmin +*> = 'L' or 'l', DLAMCH := emax +*> = 'O' or 'o', DLAMCH := rmax +*> where +*> eps = relative machine precision +*> sfmin = safe minimum, such that 1/sfmin does not overflow +*> base = base of the machine +*> prec = eps*base +*> t = number of (base) digits in the mantissa +*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +*> emin = minimum exponent before (gradual) underflow +*> rmin = underflow threshold - base**(emin-1) +*> emax = largest exponent before overflow +*> rmax = overflow threshold - (base**emax)*(1-eps) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +************************************************************************ +*> \brief \b DLAMC3 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC3 is intended to force A and B to be stored prior to doing +*> the addition of A and B , for use in situations where optimizers +*> might hold one of these in a register. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date November 2015 +*> \ingroup auxOTHERauxiliary +*> +*> \param[in] A +*> \verbatim +*> A is a DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is a DOUBLE PRECISION +*> The values A and B. +*> \endverbatim +*> + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ +*> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANGE + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANGE returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> real matrix A. +*> \endverbatim +*> +*> \return DLANGE +*> \verbatim +*> +*> DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANGE as described +*> above. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. When M = 0, +*> DLANGE is set to zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. When N = 0, +*> DLANGE is set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(M,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not +*> referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleGEauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SQRT +* .. +* .. Executable Statements .. +* + IF( MIN( M, N ).EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + DO 20 J = 1, N + DO 10 I = 1, M + TEMP = ABS( A( I, J ) ) + IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP + 10 CONTINUE + 20 CONTINUE + ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN +* +* Find norm1(A). +* + VALUE = ZERO + DO 40 J = 1, N + SUM = ZERO + DO 30 I = 1, M + SUM = SUM + ABS( A( I, J ) ) + 30 CONTINUE + IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 40 CONTINUE + ELSE IF( LSAME( NORM, 'I' ) ) THEN +* +* Find normI(A). +* + DO 50 I = 1, M + WORK( I ) = ZERO + 50 CONTINUE + DO 70 J = 1, N + DO 60 I = 1, M + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) + 60 CONTINUE + 70 CONTINUE + VALUE = ZERO + DO 80 I = 1, M + TEMP = WORK( I ) + IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP + 80 CONTINUE + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + DO 90 J = 1, N + CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANGE = VALUE + RETURN +* +* End of DLANGE +* + END +*> \brief \b DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANV2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric +*> matrix in standard form: +*> +*> [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] +*> [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] +*> +*> where either +*> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or +*> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex +*> conjugate eigenvalues. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION +*> On entry, the elements of the input matrix. +*> On exit, they are overwritten by the elements of the +*> standardised Schur form. +*> \endverbatim +*> +*> \param[out] RT1R +*> \verbatim +*> RT1R is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] RT1I +*> \verbatim +*> RT1I is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] RT2R +*> \verbatim +*> RT2R is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] RT2I +*> \verbatim +*> RT2I is DOUBLE PRECISION +*> The real and imaginary parts of the eigenvalues. If the +*> eigenvalues are a complex conjugate pair, RT1I > 0. +*> \endverbatim +*> +*> \param[out] CS +*> \verbatim +*> CS is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] SN +*> \verbatim +*> SN is DOUBLE PRECISION +*> Parameters of the rotation matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Modified by V. Sima, Research Institute for Informatics, Bucharest, +*> Romania, to reduce the risk of cancellation errors, +*> when computing real eigenvalues, and to ensure, if possible, that +*> abs(RT1R) >= abs(RT2R). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION MULTPL + PARAMETER ( MULTPL = 4.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, + $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN, SQRT +* .. +* .. Executable Statements .. +* + EPS = DLAMCH( 'P' ) + IF( C.EQ.ZERO ) THEN + CS = ONE + SN = ZERO + GO TO 10 +* + ELSE IF( B.EQ.ZERO ) THEN +* +* Swap rows and columns +* + CS = ZERO + SN = ONE + TEMP = D + D = A + A = TEMP + B = -C + C = ZERO + GO TO 10 + ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) + $ THEN + CS = ONE + SN = ZERO + GO TO 10 + ELSE +* + TEMP = A - D + P = HALF*TEMP + BCMAX = MAX( ABS( B ), ABS( C ) ) + BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C ) + SCALE = MAX( ABS( P ), BCMAX ) + Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS +* +* If Z is of the order of the machine accuracy, postpone the +* decision on the nature of eigenvalues +* + IF( Z.GE.MULTPL*EPS ) THEN +* +* Real eigenvalues. Compute A and D. +* + Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P ) + A = D + Z + D = D - ( BCMAX / Z )*BCMIS +* +* Compute B and the rotation matrix +* + TAU = DLAPY2( C, Z ) + CS = Z / TAU + SN = C / TAU + B = B - C + C = ZERO + ELSE +* +* Complex eigenvalues, or real (almost) equal eigenvalues. +* Make diagonal elements equal. +* + SIGMA = B + C + TAU = DLAPY2( SIGMA, TEMP ) + CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) + SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA ) +* +* Compute [ AA BB ] = [ A B ] [ CS -SN ] +* [ CC DD ] [ C D ] [ SN CS ] +* + AA = A*CS + B*SN + BB = -A*SN + B*CS + CC = C*CS + D*SN + DD = -C*SN + D*CS +* +* Compute [ A B ] = [ CS SN ] [ AA BB ] +* [ C D ] [-SN CS ] [ CC DD ] +* + A = AA*CS + CC*SN + B = BB*CS + DD*SN + C = -AA*SN + CC*CS + D = -BB*SN + DD*CS +* + TEMP = HALF*( A+D ) + A = TEMP + D = TEMP +* + IF( C.NE.ZERO ) THEN + IF( B.NE.ZERO ) THEN + IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN +* +* Real eigenvalues: reduce to upper triangular form +* + SAB = SQRT( ABS( B ) ) + SAC = SQRT( ABS( C ) ) + P = SIGN( SAB*SAC, C ) + TAU = ONE / SQRT( ABS( B+C ) ) + A = TEMP + P + D = TEMP - P + B = B - C + C = ZERO + CS1 = SAB*TAU + SN1 = SAC*TAU + TEMP = CS*CS1 - SN*SN1 + SN = CS*SN1 + SN*CS1 + CS = TEMP + END IF + ELSE + B = -C + C = ZERO + TEMP = CS + CS = -SN + SN = TEMP + END IF + END IF + END IF +* + END IF +* + 10 CONTINUE +* +* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). +* + RT1R = A + RT2R = D + IF( C.EQ.ZERO ) THEN + RT1I = ZERO + RT2I = ZERO + ELSE + RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) + RT2I = -RT1I + END IF + RETURN +* +* End of DLANV2 +* + END +*> \brief \b DLAPY2 returns sqrt(x2+y2). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAPY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION X, Y +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +*> overflow. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION +*> X and Y specify the values x and y. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END +*> \brief \b DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR0 computes the eigenvalues of a Hessenberg matrix H +*> and, optionally, the matrices T and Z from the Schur decomposition +*> H = Z T Z**T, where T is an upper quasi-triangular matrix (the +*> Schur form), and Z is the orthogonal matrix of Schur vectors. +*> +*> Optionally Z may be postmultiplied into an input orthogonal +*> matrix Q so that this routine can give the Schur factorization +*> of a matrix A which has been reduced to the Hessenberg form H +*> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, +*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +*> previous call to DGEBAL, and then passed to DGEHRD when the +*> matrix output by DGEBAL is reduced to Hessenberg form. +*> Otherwise, ILO and IHI should be set to 1 and N, +*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +*> If N = 0, then ILO = 1 and IHI = 0. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO = 0 and WANTT is .TRUE., then H contains +*> the upper quasi-triangular matrix T from the Schur +*> decomposition (the Schur form); 2-by-2 diagonal blocks +*> (corresponding to complex conjugate pairs of eigenvalues) +*> are returned in standard form, with H(i,i) = H(i+1,i+1) +*> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is +*> .FALSE., then the contents of H are unspecified on exit. +*> (The output value of H when INFO.GT.0 is given under the +*> description of INFO below.) +*> +*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and +*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (IHI) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (IHI) +*> The real and imaginary parts, respectively, of the computed +*> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) +*> and WI(ILO:IHI). If two eigenvalues are computed as a +*> complex conjugate pair, they are stored in consecutive +*> elements of WR and WI, say the i-th and (i+1)th, with +*> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then +*> the eigenvalues are stored in the same order as on the +*> diagonal of the Schur form returned in H, with +*> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +*> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +*> WI(i+1) = -WI(i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) +*> If WANTZ is .FALSE., then Z is not referenced. +*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +*> (The output value of Z when INFO.GT.0 is given under +*> the description of INFO below.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if WANTZ is .TRUE. +*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if LWORK = -1, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK .GE. max(1,N) +*> is sufficient, but LWORK typically as large as 6*N may +*> be required for optimal performance. A workspace query +*> to determine the optimal workspace size is recommended. +*> +*> If LWORK = -1, then DLAQR0 does a workspace query. +*> In this case, DLAQR0 checks the input parameters and +*> estimates the optimal workspace size for the given +*> values of N, ILO and IHI. The estimate is returned +*> in WORK(1). No error message related to LWORK is +*> issued by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .GT. 0: if INFO = i, DLAQR0 failed to compute all of +*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +*> and WI contain those eigenvalues which have been +*> successfully computed. (Failures are rare.) +*> +*> If INFO .GT. 0 and WANT is .FALSE., then on exit, +*> the remaining unconverged eigenvalues are the eigen- +*> values of the upper Hessenberg matrix rows and +*> columns ILO through INFO of the final, output +*> value of H. +*> +*> If INFO .GT. 0 and WANTT is .TRUE., then on exit +*> +*> (*) (initial value of H)*U = U*(final value of H) +*> +*> where U is an orthogonal matrix. The final +*> value of H is upper Hessenberg and quasi-triangular +*> in rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit +*> +*> (final value of Z(ILO:IHI,ILOZ:IHIZ) +*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +*> +*> where U is the orthogonal matrix in (*) (regard- +*> less of the value of WANTT.) +*> +*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +*> accessed. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> \n +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +*> of Matrix Analysis, volume 23, pages 948--973, 2002. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use DLAHQR. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to DLAQR3 ==== +* + CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 80 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 90 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if DLAQR3 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . DLAQR3 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + ELSE +* +* ==== Got NS/2 or fewer shifts? Use DLAQR4 or +* . DLAHQR on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL DLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, WORK, + $ LWORK, INF ) + ELSE + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), + $ WI( KS ), 1, 1, ZDUM, 1, INF ) + END IF + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. ==== +* + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) +* . Bubble sort keeps complex conjugate +* . pairs together. ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + SORTED = .false. +* + SWAP = WR( I ) + WR( I ) = WR( I+1 ) + WR( I+1 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I+1 ) + WI( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF +* +* ==== Shuffle shifts into pairs of real shifts +* . and pairs of complex conjugate shifts +* . assuming complex conjugate shifts are +* . already adjacent to one another. (Yes, +* . they are.) ==== +* + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN +* + SWAP = WR( I ) + WR( I ) = WR( I-1 ) + WR( I-1 ) = WR( I-2 ) + WR( I-2 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I-1 ) + WI( I-1 ) = WI( I-2 ) + WI( I-2 ) = SWAP + END IF + 70 CONTINUE + END IF +* +* ==== If there are only two shifts and both are +* . real, then use only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 80 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 90 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR0 ==== +* + END +*> \brief \b DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION SI1, SI2, SR1, SR2 +* INTEGER LDH, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), V( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a +*> scalar multiple of the first column of the product +*> +*> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) +*> +*> scaling to avoid overflows and most underflows. It +*> is assumed that either +*> +*> 1) sr1 = sr2 and si1 = -si2 +*> or +*> 2) si1 = si2 = 0. +*> +*> This is useful for starting double implicit shift bulges +*> in the QR algorithm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is integer +*> Order of the matrix H. N must be either 2 or 3. +*> \endverbatim +*> +*> \param[in] H +*> \verbatim +*> H is DOUBLE PRECISION array of dimension (LDH,N) +*> The 2-by-2 or 3-by-3 matrix H in (*). +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer +*> The leading dimension of H as declared in +*> the calling procedure. LDH.GE.N +*> \endverbatim +*> +*> \param[in] SR1 +*> \verbatim +*> SR1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] SI1 +*> \verbatim +*> SI1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] SR2 +*> \verbatim +*> SR2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] SI2 +*> \verbatim +*> SI2 is DOUBLE PRECISION +*> The shifts in (*). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array of dimension N +*> A scalar multiple of the first column of the +*> matrix K in (*). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + DOUBLE PRECISION SI1, SI2, SR1, SR2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), V( * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION H21S, H31S, S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )* + $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + END IF + ELSE + S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) + + $ ABS( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) - + $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) + + $ H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) + + $ H21S*H( 3, 2 ) + END IF + END IF + END +*> \brief \b DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +* LDT, NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR2 is identical to DLAQR3 except that it avoids +*> recursion by calling DLAHQR instead of DLAQR4. +*> +*> Aggressive early deflation: +*> +*> This subroutine accepts as input an upper Hessenberg matrix +*> H and performs an orthogonal similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an orthogonal similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the quasi-triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the orthogonal matrix Z is updated so +*> so that the orthogonal Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the orthogonal matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by an orthogonal +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer +*> Leading dimension of H just as declared in the calling +*> subroutine. N .LE. LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,N) +*> IF WANTZ is .TRUE., then on output, the orthogonal +*> similarity transformation mentioned above has been +*> accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is integer +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 .LE. LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is integer +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is integer +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array, dimension (KBOT) +*> \endverbatim +*> +*> \param[out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array, dimension (KBOT) +*> On output, the real and imaginary parts of approximate +*> eigenvalues that may be used for shifts are stored in +*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +*> The real and imaginary parts of converged eigenvalues +*> are stored in SR(KBOT-ND+1) through SR(KBOT) and +*> SI(KBOT-ND+1) through SI(KBOT), respectively. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is integer scalar +*> The leading dimension of V just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is integer scalar +*> The number of columns of T. NH.GE.NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is integer +*> The leading dimension of T just as declared in the +*> calling subroutine. NW .LE. LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is integer +*> The number of rows of work array WV available for +*> workspace. NV.GE.NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is integer +*> The leading dimension of W just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; DLAQR2 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, + $ LWKOPT + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLARF, DLARFG, DLASET, DORMHR, DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORMHR ==== +* + CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT.BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undeflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR2 ==== +* + END +*> \brief \b DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +* LDT, NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Aggressive early deflation: +*> +*> DLAQR3 accepts as input an upper Hessenberg matrix +*> H and performs an orthogonal similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an orthogonal similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the quasi-triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the orthogonal matrix Z is updated so +*> so that the orthogonal Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the orthogonal matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by an orthogonal +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer +*> Leading dimension of H just as declared in the calling +*> subroutine. N .LE. LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,N) +*> IF WANTZ is .TRUE., then on output, the orthogonal +*> similarity transformation mentioned above has been +*> accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is integer +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 .LE. LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is integer +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is integer +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array, dimension (KBOT) +*> \endverbatim +*> +*> \param[out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array, dimension (KBOT) +*> On output, the real and imaginary parts of approximate +*> eigenvalues that may be used for shifts are stored in +*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +*> The real and imaginary parts of converged eigenvalues +*> are stored in SR(KBOT-ND+1) through SR(KBOT) and +*> SI(KBOT-ND+1) through SI(KBOT), respectively. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is integer scalar +*> The leading dimension of V just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is integer scalar +*> The number of columns of T. NH.GE.NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is integer +*> The leading dimension of T just as declared in the +*> calling subroutine. NW .LE. LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is integer +*> The number of rows of work array WV available for +*> workspace. NV.GE.NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is integer +*> The leading dimension of W just as declared in the +*> calling subroutine. NW .LE. LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; DLAQR3 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, + $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORMHR, + $ DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORMHR ==== +* + CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DLAQR4 ==== +* + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, + $ V, LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) ) + $ THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) + END IF +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT. BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undeflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR3 ==== +* + END +*> \brief \b DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, +* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR4 implements one level of recursion for DLAQR0. +*> It is a complete implementation of the small bulge multi-shift +*> QR algorithm. It may be called by DLAQR0 and, for large enough +*> deflation window size, it may be called by DLAQR3. This +*> subroutine is identical to DLAQR0 except that it calls DLAQR2 +*> instead of DLAQR3. +*> +*> DLAQR4 computes the eigenvalues of a Hessenberg matrix H +*> and, optionally, the matrices T and Z from the Schur decomposition +*> H = Z T Z**T, where T is an upper quasi-triangular matrix (the +*> Schur form), and Z is the orthogonal matrix of Schur vectors. +*> +*> Optionally Z may be postmultiplied into an input orthogonal +*> matrix Q so that this routine can give the Schur factorization +*> of a matrix A which has been reduced to the Hessenberg form H +*> by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> = .TRUE. : the full Schur form T is required; +*> = .FALSE.: only eigenvalues are required. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> = .TRUE. : the matrix of Schur vectors Z is required; +*> = .FALSE.: Schur vectors are not required. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H. N .GE. 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, +*> H(ILO,ILO-1) is zero. ILO and IHI are normally set by a +*> previous call to DGEBAL, and then passed to DGEHRD when the +*> matrix output by DGEBAL is reduced to Hessenberg form. +*> Otherwise, ILO and IHI should be set to 1 and N, +*> respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. +*> If N = 0, then ILO = 1 and IHI = 0. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On entry, the upper Hessenberg matrix H. +*> On exit, if INFO = 0 and WANTT is .TRUE., then H contains +*> the upper quasi-triangular matrix T from the Schur +*> decomposition (the Schur form); 2-by-2 diagonal blocks +*> (corresponding to complex conjugate pairs of eigenvalues) +*> are returned in standard form, with H(i,i) = H(i+1,i+1) +*> and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is +*> .FALSE., then the contents of H are unspecified on exit. +*> (The output value of H when INFO.GT.0 is given under the +*> description of INFO below.) +*> +*> This subroutine may explicitly set H(i,j) = 0 for i.GT.j and +*> j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the array H. LDH .GE. max(1,N). +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array, dimension (IHI) +*> \endverbatim +*> +*> \param[out] WI +*> \verbatim +*> WI is DOUBLE PRECISION array, dimension (IHI) +*> The real and imaginary parts, respectively, of the computed +*> eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) +*> and WI(ILO:IHI). If two eigenvalues are computed as a +*> complex conjugate pair, they are stored in consecutive +*> elements of WR and WI, say the i-th and (i+1)th, with +*> WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then +*> the eigenvalues are stored in the same order as on the +*> diagonal of the Schur form returned in H, with +*> WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal +*> block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and +*> WI(i+1) = -WI(i). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. +*> 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ,IHI) +*> If WANTZ is .FALSE., then Z is not referenced. +*> If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is +*> replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the +*> orthogonal Schur factor of H(ILO:IHI,ILO:IHI). +*> (The output value of Z when INFO.GT.0 is given under +*> the description of INFO below.) +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. if WANTZ is .TRUE. +*> then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension LWORK +*> On exit, if LWORK = -1, WORK(1) returns an estimate of +*> the optimal value for LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK .GE. max(1,N) +*> is sufficient, but LWORK typically as large as 6*N may +*> be required for optimal performance. A workspace query +*> to determine the optimal workspace size is recommended. +*> +*> If LWORK = -1, then DLAQR4 does a workspace query. +*> In this case, DLAQR4 checks the input parameters and +*> estimates the optimal workspace size for the given +*> values of N, ILO and IHI. The estimate is returned +*> in WORK(1). No error message related to LWORK is +*> issued by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> .GT. 0: if INFO = i, DLAQR4 failed to compute all of +*> the eigenvalues. Elements 1:ilo-1 and i+1:n of WR +*> and WI contain those eigenvalues which have been +*> successfully computed. (Failures are rare.) +*> +*> If INFO .GT. 0 and WANT is .FALSE., then on exit, +*> the remaining unconverged eigenvalues are the eigen- +*> values of the upper Hessenberg matrix rows and +*> columns ILO through INFO of the final, output +*> value of H. +*> +*> If INFO .GT. 0 and WANTT is .TRUE., then on exit +*> +*> (*) (initial value of H)*U = U*(final value of H) +*> +*> where U is a orthogonal matrix. The final +*> value of H is upper Hessenberg and triangular in +*> rows and columns INFO+1 through IHI. +*> +*> If INFO .GT. 0 and WANTZ is .TRUE., then on exit +*> +*> (final value of Z(ILO:IHI,ILOZ:IHIZ) +*> = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U +*> +*> where U is the orthogonal matrix in (*) (regard- +*> less of the value of WANTT.) +*> +*> If INFO .GT. 0 and WANTZ is .FALSE., then Z is not +*> accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> \n +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part II: Aggressive Early Deflation, SIAM Journal +*> of Matrix Analysis, volume 23, pages 948--973, 2002. +*> +* ===================================================================== + SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . DLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== + DOUBLE PRECISION WILK1, WILK2 + PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + DOUBLE PRECISION ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use DLAHQR. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, + $ ILOZ, IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to DLAQR2 ==== +* + CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH, + $ N, H, LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== DLAHQR/DLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 80 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 90 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH, + $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, + $ WORK, LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if DLAQR2 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . DLAQR2 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2 + SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) + AA = WILK1*SS + H( I, I ) + BB = SS + CC = WILK2*SS + DD = AA + CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) + 30 CONTINUE + IF( KS.EQ.KTOP ) THEN + WR( KS+1 ) = H( KS+1, KS+1 ) + WI( KS+1 ) = ZERO + WR( KS ) = WR( KS+1 ) + WI( KS ) = WI( KS+1 ) + END IF + ELSE +* +* ==== Got NS/2 or fewer shifts? Use DLAHQR +* . on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL DLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, WR( KS ), WI( KS ), + $ 1, 1, ZDUM, 1, INF ) + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. ==== +* + IF( KS.GE.KBOT ) THEN + AA = H( KBOT-1, KBOT-1 ) + CC = H( KBOT, KBOT-1 ) + BB = H( KBOT-1, KBOT ) + DD = H( KBOT, KBOT ) + CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ), + $ WI( KBOT-1 ), WR( KBOT ), + $ WI( KBOT ), CS, SN ) + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) +* . Bubble sort keeps complex conjugate +* . pairs together. ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( ABS( WR( I ) )+ABS( WI( I ) ).LT. + $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN + SORTED = .false. +* + SWAP = WR( I ) + WR( I ) = WR( I+1 ) + WR( I+1 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I+1 ) + WI( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF +* +* ==== Shuffle shifts into pairs of real shifts +* . and pairs of complex conjugate shifts +* . assuming complex conjugate shifts are +* . already adjacent to one another. (Yes, +* . they are.) ==== +* + DO 70 I = KBOT, KS + 2, -2 + IF( WI( I ).NE.-WI( I-1 ) ) THEN +* + SWAP = WR( I ) + WR( I ) = WR( I-1 ) + WR( I-1 ) = WR( I-2 ) + WR( I-2 ) = SWAP +* + SWAP = WI( I ) + WI( I ) = WI( I-1 ) + WI( I-1 ) = WI( I-2 ) + WI( I-2 ) = SWAP + END IF + 70 CONTINUE + END IF +* +* ==== If there are only two shifts and both are +* . real, then use only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( WI( KBOT ).EQ.ZERO ) THEN + IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT. + $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + WR( KBOT-1 ) = WR( KBOT ) + ELSE + WR( KBOT ) = WR( KBOT-1 ) + END IF + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z, + $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE, + $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 80 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 90 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR4 ==== +* + END +*> \brief \b DLAQR5 performs a single small-bulge multi-shift QR sweep. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQR5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, +* SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, +* LDU, NV, WV, LDWV, NH, WH, LDWH ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, +* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), +* $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR5, called by DLAQR0, performs a +*> single small-bulge multi-shift QR sweep. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is logical scalar +*> WANTT = .true. if the quasi-triangular Schur factor +*> is being computed. WANTT is set to .false. otherwise. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is logical scalar +*> WANTZ = .true. if the orthogonal Schur factor is being +*> computed. WANTZ is set to .false. otherwise. +*> \endverbatim +*> +*> \param[in] KACC22 +*> \verbatim +*> KACC22 is integer with value 0, 1, or 2. +*> Specifies the computation mode of far-from-diagonal +*> orthogonal updates. +*> = 0: DLAQR5 does not accumulate reflections and does not +*> use matrix-matrix multiply to update far-from-diagonal +*> matrix entries. +*> = 1: DLAQR5 accumulates reflections and uses matrix-matrix +*> multiply to update the far-from-diagonal matrix entries. +*> = 2: DLAQR5 accumulates reflections, uses matrix-matrix +*> multiply to update the far-from-diagonal matrix entries, +*> and takes advantage of 2-by-2 block structure during +*> matrix multiplies. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is integer scalar +*> N is the order of the Hessenberg matrix H upon which this +*> subroutine operates. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is integer scalar +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is integer scalar +*> These are the first and last rows and columns of an +*> isolated diagonal block upon which the QR sweep is to be +*> applied. It is assumed without a check that +*> either KTOP = 1 or H(KTOP,KTOP-1) = 0 +*> and +*> either KBOT = N or H(KBOT+1,KBOT) = 0. +*> \endverbatim +*> +*> \param[in] NSHFTS +*> \verbatim +*> NSHFTS is integer scalar +*> NSHFTS gives the number of simultaneous shifts. NSHFTS +*> must be positive and even. +*> \endverbatim +*> +*> \param[in,out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array of size (NSHFTS) +*> \endverbatim +*> +*> \param[in,out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array of size (NSHFTS) +*> SR contains the real parts and SI contains the imaginary +*> parts of the NSHFTS shifts of origin that define the +*> multi-shift QR sweep. On output SR and SI may be +*> reordered. +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array of size (LDH,N) +*> On input H contains a Hessenberg matrix. On output a +*> multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied +*> to the isolated diagonal block in rows and columns KTOP +*> through KBOT. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is integer scalar +*> LDH is the leading dimension of H just as declared in the +*> calling procedure. LDH.GE.MAX(1,N). +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array of size (LDZ,IHIZ) +*> If WANTZ = .TRUE., then the QR Sweep orthogonal +*> similarity transformation is accumulated into +*> Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. +*> If WANTZ = .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is integer scalar +*> LDA is the leading dimension of Z just as declared in +*> the calling procedure. LDZ.GE.N. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array of size (LDV,NSHFTS/2) +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is integer scalar +*> LDV is the leading dimension of V as declared in the +*> calling procedure. LDV.GE.3. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array of size +*> (LDU,3*NSHFTS-3) +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is integer scalar +*> LDU is the leading dimension of U just as declared in the +*> in the calling subroutine. LDU.GE.3*NSHFTS-3. +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is integer scalar +*> NH is the number of columns in array WH available for +*> workspace. NH.GE.1. +*> \endverbatim +*> +*> \param[out] WH +*> \verbatim +*> WH is DOUBLE PRECISION array of size (LDWH,NH) +*> \endverbatim +*> +*> \param[in] LDWH +*> \verbatim +*> LDWH is integer scalar +*> Leading dimension of WH just as declared in the +*> calling procedure. LDWH.GE.3*NSHFTS-3. +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is integer scalar +*> NV is the number of rows in WV agailable for workspace. +*> NV.GE.1. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array of size +*> (LDWV,3*NSHFTS-3) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is integer scalar +*> LDWV is the leading dimension of WV as declared in the +*> in the calling subroutine. LDWV.GE.NV. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +* +*> \par References: +* ================ +*> +*> K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +*> Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +*> Performance, SIAM Journal of Matrix Analysis, volume 23, pages +*> 929--947, 2002. +*> +* ===================================================================== + SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, + $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, + $ LDU, NV, WV, LDWV, NH, WH, LDWH ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), + $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM, + $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2, + $ ULP + INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, + $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, + $ NS, NU + LOGICAL ACCUM, BLK22, BMP22 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. +* + INTRINSIC ABS, DBLE, MAX, MIN, MOD +* .. +* .. Local Arrays .. + DOUBLE PRECISION VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET, + $ DTRMM +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( NSHFTS.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( KTOP.GE.KBOT ) + $ RETURN +* +* ==== Shuffle shifts into pairs of real shifts and pairs +* . of complex conjugate shifts assuming complex +* . conjugate shifts are already adjacent to one +* . another. ==== +* + DO 10 I = 1, NSHFTS - 2, 2 + IF( SI( I ).NE.-SI( I+1 ) ) THEN +* + SWAP = SR( I ) + SR( I ) = SR( I+1 ) + SR( I+1 ) = SR( I+2 ) + SR( I+2 ) = SWAP +* + SWAP = SI( I ) + SI( I ) = SI( I+1 ) + SI( I+1 ) = SI( I+2 ) + SI( I+2 ) = SWAP + END IF + 10 CONTINUE +* +* ==== NSHFTS is supposed to be even, but if it is odd, +* . then simply reduce it by one. The shuffle above +* . ensures that the dropped shift is real and that +* . the remaining shifts are paired. ==== +* + NS = NSHFTS - MOD( NSHFTS, 2 ) +* +* ==== Machine constants for deflation ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + NBMPS = NS / 2 +* +* ==== KDU = width of slab ==== +* + KDU = 6*NBMPS - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) +* +* ==== Near-the-diagonal bulge chase. The following loop +* . performs the near-the-diagonal part of a small bulge +* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal +* . chunk extends from column INCOL to column NDCOL +* . (including both column INCOL and column NDCOL). The +* . following loop chases a 3*NBMPS column long chain of +* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL +* . may be less than KTOP and and NDCOL may be greater than +* . KBOT indicating phantom columns from which to chase +* . bulges before they are actually introduced or to which +* . to chase bulges beyond column KBOT.) ==== +* + DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) +* +* ==== Bulges number MTOP to MBOT are active double implicit +* . shift bulges. There may or may not also be small +* . 2-by-2 bulge, if there is room. The inactive bulges +* . (if any) must wait until the active bulges have moved +* . down the diagonal to make room. The phantom matrix +* . paradigm described above helps keep track. ==== +* + MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) + MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) + M22 = MBOT + 1 + BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. + $ ( KBOT-2 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + DO 20 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ V( 1, M ) ) + ALPHA = V( 1, M ) + CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M ) = H( K+2, K ) + V( 3, M ) = H( K+3, K ) + CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), + $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), + $ VT ) + ALPHA = VT( 1 ) + CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* + $ H( K+2, K ) ) +* + IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ ABS( REFSUM*VT( 3 ) ).GT.ULP* + $ ( ABS( H( K, K ) )+ABS( H( K+1, + $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + H( K+1, K ) = H( K+1, K ) - REFSUM + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + V( 1, M ) = VT( 1 ) + V( 2, M ) = VT( 2 ) + V( 3, M ) = VT( 3 ) + END IF + END IF + END IF + 20 CONTINUE +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ), + $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ), + $ V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + END IF +* +* ==== Multiply H by reflections from the left ==== +* + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 40 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 30 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )* + $ H( K+2, J )+V( 3, M )*H( K+3, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) + H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) + 30 CONTINUE + 40 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 50 J = MAX( K+1, KTOP ), JBOT + REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )* + $ H( K+2, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) + 50 CONTINUE + END IF +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 90 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 60 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* + $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M ) + H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M ) + 60 CONTINUE +* + IF( ACCUM ) THEN +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + KMS = K - INCOL + DO 70 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* + $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M ) + U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M ) + 70 CONTINUE + ELSE IF( WANTZ ) THEN +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + DO 80 J = ILOZ, IHIZ + REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* + $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M ) + Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M ) + 80 CONTINUE + END IF + END IF + 90 CONTINUE +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF ( V( 1, M22 ).NE.ZERO ) THEN + DO 100 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* + $ H( J, K+2 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 ) + 100 CONTINUE +* + IF( ACCUM ) THEN + KMS = K - INCOL + DO 110 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ + $ V( 2, M22 )*U( J, KMS+2 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*V( 2, M22 ) + 110 CONTINUE + ELSE IF( WANTZ ) THEN + DO 120 J = ILOZ, IHIZ + REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* + $ Z( J, K+2 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 ) + 120 CONTINUE + END IF + END IF + END IF +* +* ==== Vigilant deflation check ==== +* + MSTART = MTOP + IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) + $ MSTART = MSTART + 1 + MEND = MBOT + IF( BMP22 ) + $ MEND = MEND + 1 + IF( KRCOL.EQ.KBOT-2 ) + $ MEND = MEND + 1 + DO 130 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) +* +* ==== The following convergence test requires that +* . the tradition small-compared-to-nearby-diagonals +* . criterion and the Ahues & Tisseur (LAWN 122, 1997) +* . criteria both be satisfied. The latter improves +* . accuracy in some examples. Falling back on an +* . alternate convergence criterion when TST1 or TST2 +* . is zero (as done here) is traditional but probably +* . unnecessary. ==== +* + IF( H( K+1, K ).NE.ZERO ) THEN + TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) ) + IF( TST1.EQ.ZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + ABS( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + ABS( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + ABS( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + ABS( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + ABS( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + ABS( H( K+4, K+1 ) ) + END IF + IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) ) + H11 = MAX( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( ABS( H( K+1, K+1 ) ), + $ ABS( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) +* + IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 130 CONTINUE +* +* ==== Fill in the last row of each bulge. ==== +* + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 140 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) + H( K+4, K+1 ) = -REFSUM + H( K+4, K+2 ) = -REFSUM*V( 2, M ) + H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M ) + 140 CONTINUE +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 150 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + IF( ACCUM ) THEN + IF( WANTT ) THEN + JTOP = 1 + JBOT = N + ELSE + JTOP = KTOP + JBOT = KBOT + END IF + IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. + $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN +* +* ==== Updates not exploiting the 2-by-2 block +* . structure of U. K1 and NU keep track of +* . the location and size of U in the special +* . cases of introducing bulges and chasing +* . bulges off the bottom. In these special +* . cases and in case the number of shifts +* . is NS = 2, there is no 2-by-2 block +* . structure to exploit. ==== +* + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 +* +* ==== Horizontal Multiply ==== +* + DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 160 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 170 CONTINUE +* +* ==== Z multiply (also vertical) ==== +* + IF( WANTZ ) THEN + DO 180 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 180 CONTINUE + END IF + ELSE +* +* ==== Updates exploiting U's 2-by-2 block structure. +* . (I2, I4, J2, J4 are the last rows and columns +* . of the blocks.) ==== +* + I2 = ( KDU+1 ) / 2 + I4 = KDU + J2 = I4 - I2 + J4 = KDU +* +* ==== KZS and KNZ deal with the band of zeros +* . along the diagonal of one of the triangular +* . blocks. ==== +* + KZS = ( J4-J2 ) - ( NS+1 ) + KNZ = NS + 1 +* +* ==== Horizontal multiply ==== +* + DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) +* +* ==== Multiply by U21**T ==== +* + CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) +* +* ==== Multiply top of H by U11**T ==== +* + CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H to bottom of WH ==== +* + CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21**T ==== +* + CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, + $ U( J2+1, I2+1 ), LDU, + $ H( INCOL+1+J2, JCOL ), LDH, ONE, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Copy it back ==== +* + CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 190 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ H( JROW, INCOL+1+J2 ), LDH, + $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Copy it back ==== +* + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 200 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( WANTZ ) THEN + DO 210 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL DLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U12 ==== +* + CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ U( J2+1, I2+1 ), LDU, ONE, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Copy the result back to Z ==== +* + CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 210 CONTINUE + END IF + END IF + END IF + 220 CONTINUE +* +* ==== End of DLAQR5 ==== +* + END +*> \brief \b DLARF applies an elementary reflector to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARF applies a real elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T +* + CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T +* + CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END +*> \brief \b DLARFB applies a block reflector or its transpose to a general rectangular matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, +* T, LDT, C, LDC, WORK, LDWORK ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, SIDE, STOREV, TRANS +* INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), +* $ WORK( LDWORK, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFB applies a real block reflector H or its transpose H**T to a +*> real m by n matrix C, from either the left or the right. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply H or H**T from the Left +*> = 'R': apply H or H**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply H (No transpose) +*> = 'T': apply H**T (Transpose) +*> \endverbatim +*> +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is CHARACTER*1 +*> Indicates how H is formed from a product of elementary +*> reflectors +*> = 'F': H = H(1) H(2) . . . H(k) (Forward) +*> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Indicates how the vectors which define the elementary +*> reflectors are stored: +*> = 'C': Columnwise +*> = 'R': Rowwise +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the matrix T (= the number of elementary +*> reflectors whose product defines the block reflector). +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (LDV,K) if STOREV = 'C' +*> (LDV,M) if STOREV = 'R' and SIDE = 'L' +*> (LDV,N) if STOREV = 'R' and SIDE = 'R' +*> The matrix V. See Further Details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +*> if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +*> if STOREV = 'R', LDV >= K. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The triangular k by k matrix T in the representation of the +*> block reflector. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LDWORK,K) +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. +*> If SIDE = 'L', LDWORK >= max(1,N); +*> if SIDE = 'R', LDWORK >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2013 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The shape of the matrix V and the storage of the vectors which define +*> the H(i) is best illustrated by the following example with n = 5 and +*> k = 3. The elements equal to 1 are not stored; the corresponding +*> array elements are modified but restored on exit. The rest of the +*> array is not used. +*> +*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +*> +*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +*> ( v1 1 ) ( 1 v2 v2 v2 ) +*> ( v1 v2 1 ) ( 1 v3 v3 ) +*> ( v1 v2 v3 ) +*> ( v1 v2 v3 ) +*> +*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +*> +*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) +*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +*> ( 1 v3 ) +*> ( 1 ) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2013 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) +* +* W := C1**T +* + DO 10 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2**T * V2 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 30 J = 1, K + DO 20 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) +* +* W := C2**T +* + DO 70 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1**T * V1 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 90 J = 1, K + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) +* +* W := C1**T +* + DO 130 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2**T * V2**T +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 150 J = 1, K + DO 140 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) +* +* W := C2**T +* + DO 190 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1**T * V1**T +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 210 J = 1, K + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END +*> \brief \b DLARFG generates an elementary reflector (Householder matrix). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFG generates a real elementary reflector H of order n, such +*> that +*> +*> H * ( alpha ) = ( beta ), H**T * H = I. +*> ( x ) ( 0 ) +*> +*> where alpha and beta are scalars, and x is an (n-1)-element real +*> vector. H is represented in the form +*> +*> H = I - tau * ( 1 ) * ( 1 v**T ) , +*> ( v ) +*> +*> where tau is a real scalar and v is a real (n-1)-element +*> vector. +*> +*> If the elements of x are all zero, then tau = 0 and H is taken to be +*> the unit matrix. +*> +*> Otherwise 1 <= tau <= 2. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the elementary reflector. +*> \endverbatim +*> +*> \param[in,out] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, the value alpha. +*> On exit, it is overwritten with the value beta. +*> \endverbatim +*> +*> \param[in,out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension +*> (1+(N-2)*abs(INCX)) +*> On entry, the vector x. +*> On exit, it is overwritten with the vector v. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between elements of X. INCX > 0. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + END IF + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFG +* + END +*> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* .. Scalar Arguments .. +* CHARACTER DIRECT, STOREV +* INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFT forms the triangular factor T of a real block reflector H +*> of order n, which is defined as a product of k elementary reflectors. +*> +*> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +*> +*> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +*> +*> If STOREV = 'C', the vector which defines the elementary reflector +*> H(i) is stored in the i-th column of the array V, and +*> +*> H = I - V * T * V**T +*> +*> If STOREV = 'R', the vector which defines the elementary reflector +*> H(i) is stored in the i-th row of the array V, and +*> +*> H = I - V**T * T * V +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DIRECT +*> \verbatim +*> DIRECT is CHARACTER*1 +*> Specifies the order in which the elementary reflectors are +*> multiplied to form the block reflector: +*> = 'F': H = H(1) H(2) . . . H(k) (Forward) +*> = 'B': H = H(k) . . . H(2) H(1) (Backward) +*> \endverbatim +*> +*> \param[in] STOREV +*> \verbatim +*> STOREV is CHARACTER*1 +*> Specifies how the vectors which define the elementary +*> reflectors are stored (see also Further Details): +*> = 'C': columnwise +*> = 'R': rowwise +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the block reflector H. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The order of the triangular factor T (= the number of +*> elementary reflectors). K >= 1. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (LDV,K) if STOREV = 'C' +*> (LDV,N) if STOREV = 'R' +*> The matrix V. See further details. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V. +*> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i). +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,K) +*> The k by k triangular factor T of the block reflector. +*> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +*> lower triangular. The rest of the array is not used. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= K. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The shape of the matrix V and the storage of the vectors which define +*> the H(i) is best illustrated by the following example with n = 5 and +*> k = 3. The elements equal to 1 are not stored. +*> +*> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +*> +*> V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +*> ( v1 1 ) ( 1 v2 v2 v2 ) +*> ( v1 v2 1 ) ( 1 v3 v3 ) +*> ( v1 v2 v3 ) +*> ( v1 v2 v3 ) +*> +*> DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +*> +*> V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +*> ( v1 v2 v3 ) ( v2 v2 v2 1 ) +*> ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +*> ( 1 v3 ) +*> ( 1 ) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO I = 1, K + PREVLASTV = MAX( I, PREVLASTV ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO J = 1, I + T( J, I ) = ZERO + END DO + ELSE +* +* general case +* + IF( LSAME( STOREV, 'C' ) ) THEN +* Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + DO J = 1, I-1 + T( J, I ) = -TAU( I ) * V( I , J ) + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) +* + CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, + $ T( 1, I ), 1 ) + ELSE +* Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + DO J = 1, I-1 + T( J, I ) = -TAU( I ) * V( J , I ) + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T +* + CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), + $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, + $ T( 1, I ), 1 ) + END IF +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + END DO + ELSE + PREVLASTV = 1 + DO I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO J = I, K + T( J, I ) = ZERO + END DO + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN +* Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + DO J = I+1, K + T( J, I ) = -TAU( I ) * V( N-K+I , J ) + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, + $ T( I+1, I ), 1 ) + ELSE +* Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + DO J = I+1, K + T( J, I ) = -TAU( I ) * V( J, N-K+I ) + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T +* + CALL DGEMV( 'No transpose', K-I, N-K+I-J, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ONE, T( I+1, I ), 1 ) + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + END DO + END IF + RETURN +* +* End of DLARFT +* + END +*> \brief \b DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARFX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFX applies a real elementary reflector H to a real m by n +*> matrix C, from either the left or the right. H is represented in the +*> form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector. +*> +*> If tau = 0, then H is taken to be the unit matrix +*> +*> This version uses inline code if H has order < 11. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (M) if SIDE = 'L' +*> or (N) if SIDE = 'R' +*> The vector v in the representation of H. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDA >= (1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> WORK is not referenced if H has order < 11. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J + DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, + $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C, where H has order m. +* + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 )M +* +* Code for general M +* + CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) + GO TO 410 + 10 CONTINUE +* +* Special code for 1 x 1 Householder +* + T1 = ONE - TAU*V( 1 )*V( 1 ) + DO 20 J = 1, N + C( 1, J ) = T1*C( 1, J ) + 20 CONTINUE + GO TO 410 + 30 CONTINUE +* +* Special code for 2 x 2 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 40 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + 40 CONTINUE + GO TO 410 + 50 CONTINUE +* +* Special code for 3 x 3 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 60 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + 60 CONTINUE + GO TO 410 + 70 CONTINUE +* +* Special code for 4 x 4 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 80 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + 80 CONTINUE + GO TO 410 + 90 CONTINUE +* +* Special code for 5 x 5 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 100 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + 100 CONTINUE + GO TO 410 + 110 CONTINUE +* +* Special code for 6 x 6 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 120 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + 120 CONTINUE + GO TO 410 + 130 CONTINUE +* +* Special code for 7 x 7 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 140 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + 140 CONTINUE + GO TO 410 + 150 CONTINUE +* +* Special code for 8 x 8 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 160 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + 160 CONTINUE + GO TO 410 + 170 CONTINUE +* +* Special code for 9 x 9 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 180 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + C( 9, J ) = C( 9, J ) - SUM*T9 + 180 CONTINUE + GO TO 410 + 190 CONTINUE +* +* Special code for 10 x 10 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + V10 = V( 10 ) + T10 = TAU*V10 + DO 200 J = 1, N + SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + + $ V10*C( 10, J ) + C( 1, J ) = C( 1, J ) - SUM*T1 + C( 2, J ) = C( 2, J ) - SUM*T2 + C( 3, J ) = C( 3, J ) - SUM*T3 + C( 4, J ) = C( 4, J ) - SUM*T4 + C( 5, J ) = C( 5, J ) - SUM*T5 + C( 6, J ) = C( 6, J ) - SUM*T6 + C( 7, J ) = C( 7, J ) - SUM*T7 + C( 8, J ) = C( 8, J ) - SUM*T8 + C( 9, J ) = C( 9, J ) - SUM*T9 + C( 10, J ) = C( 10, J ) - SUM*T10 + 200 CONTINUE + GO TO 410 + ELSE +* +* Form C * H, where H has order n. +* + GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, + $ 370, 390 )N +* +* Code for general N +* + CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) + GO TO 410 + 210 CONTINUE +* +* Special code for 1 x 1 Householder +* + T1 = ONE - TAU*V( 1 )*V( 1 ) + DO 220 J = 1, M + C( J, 1 ) = T1*C( J, 1 ) + 220 CONTINUE + GO TO 410 + 230 CONTINUE +* +* Special code for 2 x 2 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 240 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + 240 CONTINUE + GO TO 410 + 250 CONTINUE +* +* Special code for 3 x 3 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 260 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + 260 CONTINUE + GO TO 410 + 270 CONTINUE +* +* Special code for 4 x 4 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 280 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + 280 CONTINUE + GO TO 410 + 290 CONTINUE +* +* Special code for 5 x 5 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 300 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + 300 CONTINUE + GO TO 410 + 310 CONTINUE +* +* Special code for 6 x 6 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 320 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + 320 CONTINUE + GO TO 410 + 330 CONTINUE +* +* Special code for 7 x 7 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 340 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + 340 CONTINUE + GO TO 410 + 350 CONTINUE +* +* Special code for 8 x 8 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 360 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + 360 CONTINUE + GO TO 410 + 370 CONTINUE +* +* Special code for 9 x 9 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 380 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + C( J, 9 ) = C( J, 9 ) - SUM*T9 + 380 CONTINUE + GO TO 410 + 390 CONTINUE +* +* Special code for 10 x 10 Householder +* + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + V10 = V( 10 ) + T10 = TAU*V10 + DO 400 J = 1, M + SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + + $ V10*C( J, 10 ) + C( J, 1 ) = C( J, 1 ) - SUM*T1 + C( J, 2 ) = C( J, 2 ) - SUM*T2 + C( J, 3 ) = C( J, 3 ) - SUM*T3 + C( J, 4 ) = C( J, 4 ) - SUM*T4 + C( J, 5 ) = C( J, 5 ) - SUM*T5 + C( J, 6 ) = C( J, 6 ) - SUM*T6 + C( J, 7 ) = C( J, 7 ) - SUM*T7 + C( J, 8 ) = C( J, 8 ) - SUM*T8 + C( J, 9 ) = C( J, 9 ) - SUM*T9 + C( J, 10 ) = C( J, 10 ) - SUM*T10 + 400 CONTINUE + GO TO 410 + END IF + 410 CONTINUE + RETURN +* +* End of DLARFX +* + END +*> \brief \b DLARTG generates a plane rotation with real cosine and real sine. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARTG generate a plane rotation so that +*> +*> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. +*> [ -SN CS ] [ G ] [ 0 ] +*> +*> This is a slower, more accurate version of the BLAS1 routine DROTG, +*> with the following other differences: +*> F and G are unchanged on return. +*> If G=0, then CS=1 and SN=0. +*> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any +*> floating point operations (saves work in DBDSQR when +*> there are zeros on the diagonal). +*> +*> If F exceeds G in magnitude, CS will be positive. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] F +*> \verbatim +*> F is DOUBLE PRECISION +*> The first component of vector to be rotated. +*> \endverbatim +*> +*> \param[in] G +*> \verbatim +*> G is DOUBLE PRECISION +*> The second component of vector to be rotated. +*> \endverbatim +*> +*> \param[out] CS +*> \verbatim +*> CS is DOUBLE PRECISION +*> The cosine of the rotation. +*> \endverbatim +*> +*> \param[out] SN +*> \verbatim +*> SN is DOUBLE PRECISION +*> The sine of the rotation. +*> \endverbatim +*> +*> \param[out] R +*> \verbatim +*> R is DOUBLE PRECISION +*> The nonzero component of the rotated vector. +*> +*> This version has a few statements commented out for thread safety +*> (machine parameters are computed on each entry). 10 feb 03, SJH. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, SQRT +* .. +* .. Save statement .. +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. +* DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* IF( FIRST ) THEN + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 +* FIRST = .FALSE. +* END IF + IF( G.EQ.ZERO ) THEN + CS = ONE + SN = ZERO + R = F + ELSE IF( F.EQ.ZERO ) THEN + CS = ZERO + SN = ONE + R = G + ELSE + F1 = F + G1 = G + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) THEN + COUNT = 0 + 10 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMN2 + G1 = G1*SAFMN2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 20 I = 1, COUNT + R = R*SAFMX2 + 20 CONTINUE + ELSE IF( SCALE.LE.SAFMN2 ) THEN + COUNT = 0 + 30 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMX2 + G1 = G1*SAFMX2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.LE.SAFMN2 ) + $ GO TO 30 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 40 I = 1, COUNT + R = R*SAFMN2 + 40 CONTINUE + ELSE + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + END IF + IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN + CS = -CS + SN = -SN + R = -R + END IF + END IF + RETURN +* +* End of DLARTG +* + END +*> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASCL + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER TYPE +* INTEGER INFO, KL, KU, LDA, M, N +* DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASCL multiplies the M by N real matrix A by the real scalar +*> CTO/CFROM. This is done without over/underflow as long as the final +*> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +*> A may be full, upper triangular, lower triangular, upper Hessenberg, +*> or banded. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TYPE +*> \verbatim +*> TYPE is CHARACTER*1 +*> TYPE indices the storage type of the input matrix. +*> = 'G': A is a full matrix. +*> = 'L': A is a lower triangular matrix. +*> = 'U': A is an upper triangular matrix. +*> = 'H': A is an upper Hessenberg matrix. +*> = 'B': A is a symmetric band matrix with lower bandwidth KL +*> and upper bandwidth KU and with the only the lower +*> half stored. +*> = 'Q': A is a symmetric band matrix with lower bandwidth KL +*> and upper bandwidth KU and with the only the upper +*> half stored. +*> = 'Z': A is a band matrix with lower bandwidth KL and upper +*> bandwidth KU. See DGBTRF for storage details. +*> \endverbatim +*> +*> \param[in] KL +*> \verbatim +*> KL is INTEGER +*> The lower bandwidth of A. Referenced only if TYPE = 'B', +*> 'Q' or 'Z'. +*> \endverbatim +*> +*> \param[in] KU +*> \verbatim +*> KU is INTEGER +*> The upper bandwidth of A. Referenced only if TYPE = 'B', +*> 'Q' or 'Z'. +*> \endverbatim +*> +*> \param[in] CFROM +*> \verbatim +*> CFROM is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] CTO +*> \verbatim +*> CTO is DOUBLE PRECISION +*> +*> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed +*> without over/underflow if the final result CTO*A(I,J)/CFROM +*> can be represented without over/underflow. CFROM must be +*> nonzero. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The matrix to be multiplied by CTO/CFROM. See TYPE for the +*> storage type. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); +*> TYPE = 'B', LDA >= KL+1; +*> TYPE = 'Q', LDA >= KU+1; +*> TYPE = 'Z', LDA >= 2*KL+KU+1. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 0 - successful exit +*> <0 - if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +* + IF( ITYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN + INFO = -4 + ELSE IF( DISNAN(CTO) ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. + $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN + INFO = -7 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -2 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -3 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -9 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASCL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* + CFROMC = CFROM + CTOC = CTO +* + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + IF( CFROM1.EQ.CFROMC ) THEN +! CFROMC is an inf. Multiply by a correctly signed zero for +! finite CTOC, or a NaN if CTOC is infinite. + MUL = CTOC / CFROMC + DONE = .TRUE. + CTO1 = CTOC + ELSE + CTO1 = CTOC / BIGNUM + IF( CTO1.EQ.CTOC ) THEN +! CTOC is either 0 or an inf. In both cases, CTOC itself +! serves as the correct multiplication factor. + MUL = CTOC + DONE = .TRUE. + CFROMC = ONE + ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF + END IF +* + IF( ITYPE.EQ.0 ) THEN +* +* Full matrix +* + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( ITYPE.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 J = 1, N + DO 60 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 J = 1, N + DO 80 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + K3 = KL + 1 + K4 = N + 1 + DO 110 J = 1, N + DO 100 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + K1 = KU + 2 + K3 = KU + 1 + DO 130 J = 1, N + DO 120 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( ITYPE.EQ.6 ) THEN +* +* Band matrix +* + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 150 J = 1, N + DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of DLASCL +* + END +*> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASET + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, M, N +* DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASET initializes an m-by-n matrix A to BETA on the diagonal and +*> ALPHA on the offdiagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies the part of the matrix A to be set. +*> = 'U': Upper triangular part is set; the strictly lower +*> triangular part of A is not changed. +*> = 'L': Lower triangular part is set; the strictly upper +*> triangular part of A is not changed. +*> Otherwise: All of the matrix A is set. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> The constant to which the offdiagonal elements are to be set. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION +*> The constant to which the diagonal elements are to be set. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On exit, the leading m-by-n submatrix of A is set as follows: +*> +*> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, +*> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, +*> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, +*> +*> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Set the strictly upper triangular or trapezoidal part of the +* array to ALPHA. +* + DO 20 J = 2, N + DO 10 I = 1, MIN( J-1, M ) + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN +* +* Set the strictly lower triangular or trapezoidal part of the +* array to ALPHA. +* + DO 40 J = 1, MIN( M, N ) + DO 30 I = J + 1, M + A( I, J ) = ALPHA + 30 CONTINUE + 40 CONTINUE +* + ELSE +* +* Set the leading m-by-n submatrix to ALPHA. +* + DO 60 J = 1, N + DO 50 I = 1, M + A( I, J ) = ALPHA + 50 CONTINUE + 60 CONTINUE + END IF +* +* Set the first min(M,N) diagonal elements to BETA. +* + DO 70 I = 1, MIN( M, N ) + A( I, I ) = BETA + 70 CONTINUE +* + RETURN +* +* End of DLASET +* + END +*> \brief \b DLASSQ updates a sum of squares represented in scaled form. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASSQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* .. Scalar Arguments .. +* INTEGER INCX, N +* DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION X( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASSQ returns the values scl and smsq such that +*> +*> ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, +*> +*> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is +*> assumed to be non-negative and scl returns the value +*> +*> scl = max( scale, abs( x( i ) ) ). +*> +*> scale and sumsq must be supplied in SCALE and SUMSQ and +*> scl and smsq are overwritten on SCALE and SUMSQ respectively. +*> +*> The routine makes only one pass through the vector x. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of elements to be used from the vector X. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (N) +*> The vector for which a scaled sum of squares is computed. +*> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> The increment between successive values of the vector X. +*> INCX > 0. +*> \endverbatim +*> +*> \param[in,out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> On entry, the value scale in the equation above. +*> On exit, SCALE is overwritten with scl , the scaling factor +*> for the sum of squares. +*> \endverbatim +*> +*> \param[in,out] SUMSQ +*> \verbatim +*> SUMSQ is DOUBLE PRECISION +*> On entry, the value sumsq in the equation above. +*> On exit, SUMSQ is overwritten with smsq , the basic sum of +*> squares from which scl has been factored out. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI +* .. +* .. External Functions .. + LOGICAL DISNAN + EXTERNAL DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + ABSXI = ABS( X( IX ) ) + IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN + IF( SCALE.LT.ABSXI ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF + RETURN +* +* End of DLASSQ +* + END +*> \brief \b DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASY2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, +* LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +* +* .. Scalar Arguments .. +* LOGICAL LTRANL, LTRANR +* INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 +* DOUBLE PRECISION SCALE, XNORM +* .. +* .. Array Arguments .. +* DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in +*> +*> op(TL)*X + ISGN*X*op(TR) = SCALE*B, +*> +*> where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or +*> -1. op(T) = T or T**T, where T**T denotes the transpose of T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] LTRANL +*> \verbatim +*> LTRANL is LOGICAL +*> On entry, LTRANL specifies the op(TL): +*> = .FALSE., op(TL) = TL, +*> = .TRUE., op(TL) = TL**T. +*> \endverbatim +*> +*> \param[in] LTRANR +*> \verbatim +*> LTRANR is LOGICAL +*> On entry, LTRANR specifies the op(TR): +*> = .FALSE., op(TR) = TR, +*> = .TRUE., op(TR) = TR**T. +*> \endverbatim +*> +*> \param[in] ISGN +*> \verbatim +*> ISGN is INTEGER +*> On entry, ISGN specifies the sign of the equation +*> as described before. ISGN may only be 1 or -1. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> On entry, N1 specifies the order of matrix TL. +*> N1 may only be 0, 1 or 2. +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> On entry, N2 specifies the order of matrix TR. +*> N2 may only be 0, 1 or 2. +*> \endverbatim +*> +*> \param[in] TL +*> \verbatim +*> TL is DOUBLE PRECISION array, dimension (LDTL,2) +*> On entry, TL contains an N1 by N1 matrix. +*> \endverbatim +*> +*> \param[in] LDTL +*> \verbatim +*> LDTL is INTEGER +*> The leading dimension of the matrix TL. LDTL >= max(1,N1). +*> \endverbatim +*> +*> \param[in] TR +*> \verbatim +*> TR is DOUBLE PRECISION array, dimension (LDTR,2) +*> On entry, TR contains an N2 by N2 matrix. +*> \endverbatim +*> +*> \param[in] LDTR +*> \verbatim +*> LDTR is INTEGER +*> The leading dimension of the matrix TR. LDTR >= max(1,N2). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,2) +*> On entry, the N1 by N2 matrix B contains the right-hand +*> side of the equation. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the matrix B. LDB >= max(1,N1). +*> \endverbatim +*> +*> \param[out] SCALE +*> \verbatim +*> SCALE is DOUBLE PRECISION +*> On exit, SCALE contains the scale factor. SCALE is chosen +*> less than or equal to 1 to prevent the solution overflowing. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,2) +*> On exit, X contains the N1 by N2 solution. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the matrix X. LDX >= max(1,N1). +*> \endverbatim +*> +*> \param[out] XNORM +*> \verbatim +*> XNORM is DOUBLE PRECISION +*> On exit, XNORM is the infinity-norm of the solution. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> On exit, INFO is set to +*> 0: successful exit. +*> 1: TL and TR have too close eigenvalues, so TL or +*> TR is perturbed to get a nonsingular equation. +*> NOTE: In the interests of speed, this routine does not +*> check the inputs for errors. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup doubleSYauxiliary +* +* ===================================================================== + SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + LOGICAL LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TWO, HALF, EIGHT + PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL BSWAP, XSWAP + INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K + DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, + $ TEMP, U11, U12, U22, XMAX +* .. +* .. Local Arrays .. + LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) + INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), + $ LOCU22( 4 ) + DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Data statements .. + DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , + $ LOCU22 / 4, 3, 2, 1 / + DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / +* .. +* .. Executable Statements .. +* +* Do not check the input parameters for errors +* + INFO = 0 +* +* Quick return if possible +* + IF( N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +* + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +* +* 1 by 1: TL11*X + SGN*X*TR11 = B11 +* + 10 CONTINUE + TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) + BET = ABS( TAU1 ) + IF( BET.LE.SMLNUM ) THEN + TAU1 = SMLNUM + BET = SMLNUM + INFO = 1 + END IF +* + SCALE = ONE + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +* + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +* +* 1 by 2: +* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] +* [TR21 TR22] +* + 20 CONTINUE +* + SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), + $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) + IF( LTRANR ) THEN + TMP( 2 ) = SGN*TR( 2, 1 ) + TMP( 3 ) = SGN*TR( 1, 2 ) + ELSE + TMP( 2 ) = SGN*TR( 1, 2 ) + TMP( 3 ) = SGN*TR( 2, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 1, 2 ) + GO TO 40 +* +* 2 by 1: +* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] +* [TL21 TL22] [X21] [X21] [B21] +* + 30 CONTINUE + SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), + $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) + IF( LTRANL ) THEN + TMP( 2 ) = TL( 1, 2 ) + TMP( 3 ) = TL( 2, 1 ) + ELSE + TMP( 2 ) = TL( 2, 1 ) + TMP( 3 ) = TL( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + 40 CONTINUE +* +* Solve 2 by 2 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + IPIV = IDAMAX( 4, TMP, 1 ) + U11 = TMP( IPIV ) + IF( ABS( U11 ).LE.SMIN ) THEN + INFO = 1 + U11 = SMIN + END IF + U12 = TMP( LOCU12( IPIV ) ) + L21 = TMP( LOCL21( IPIV ) ) / U11 + U22 = TMP( LOCU22( IPIV ) ) - U12*L21 + XSWAP = XSWPIV( IPIV ) + BSWAP = BSWPIV( IPIV ) + IF( ABS( U22 ).LE.SMIN ) THEN + INFO = 1 + U22 = SMIN + END IF + IF( BSWAP ) THEN + TEMP = BTMP( 2 ) + BTMP( 2 ) = BTMP( 1 ) - L21*TEMP + BTMP( 1 ) = TEMP + ELSE + BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) + END IF + SCALE = ONE + IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. + $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN + SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + END IF + X2( 2 ) = BTMP( 2 ) / U22 + X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) + IF( XSWAP ) THEN + TEMP = X2( 2 ) + X2( 2 ) = X2( 1 ) + X2( 1 ) = TEMP + END IF + X( 1, 1 ) = X2( 1 ) + IF( N1.EQ.1 ) THEN + X( 1, 2 ) = X2( 2 ) + XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) + END IF + RETURN +* +* 2 by 2: +* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] +* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] +* +* Solve equivalent 4 by 4 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + BTMP( 1 ) = ZERO + CALL DCOPY( 16, BTMP, 0, T16, 1 ) + T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) + T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) + T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) + IF( LTRANL ) THEN + T16( 1, 2 ) = TL( 2, 1 ) + T16( 2, 1 ) = TL( 1, 2 ) + T16( 3, 4 ) = TL( 2, 1 ) + T16( 4, 3 ) = TL( 1, 2 ) + ELSE + T16( 1, 2 ) = TL( 1, 2 ) + T16( 2, 1 ) = TL( 2, 1 ) + T16( 3, 4 ) = TL( 1, 2 ) + T16( 4, 3 ) = TL( 2, 1 ) + END IF + IF( LTRANR ) THEN + T16( 1, 3 ) = SGN*TR( 1, 2 ) + T16( 2, 4 ) = SGN*TR( 1, 2 ) + T16( 3, 1 ) = SGN*TR( 2, 1 ) + T16( 4, 2 ) = SGN*TR( 2, 1 ) + ELSE + T16( 1, 3 ) = SGN*TR( 2, 1 ) + T16( 2, 4 ) = SGN*TR( 2, 1 ) + T16( 3, 1 ) = SGN*TR( 1, 2 ) + T16( 4, 2 ) = SGN*TR( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 1, 2 ) + BTMP( 4 ) = B( 2, 2 ) +* +* Perform elimination +* + DO 100 I = 1, 3 + XMAX = ZERO + DO 70 IP = I, 4 + DO 60 JP = I, 4 + IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T16( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 60 CONTINUE + 70 CONTINUE + IF( IPSV.NE.I ) THEN + CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T16( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T16( I, I ) = SMIN + END IF + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) THEN + INFO = 1 + T16( 4, 4 ) = SMIN + END IF + SCALE = ONE + IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN + SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + BTMP( 4 ) = BTMP( 4 )*SCALE + END IF + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE + 120 CONTINUE + DO 130 I = 1, 3 + IF( JPIV( 4-I ).NE.4-I ) THEN + TEMP = TMP( 4-I ) + TMP( 4-I ) = TMP( JPIV( 4-I ) ) + TMP( JPIV( 4-I ) ) = TEMP + END IF + 130 CONTINUE + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 3 ) + X( 2, 2 ) = TMP( 4 ) + XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), + $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) + RETURN +* +* End of DLASY2 +* + END +*> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORG2R generates an m by n real matrix Q with orthonormal columns, +*> which is defined as the first n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQRF in the first k columns of its array +*> argument A. +*> On exit, the m-by-n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2R +* + END +*> \brief \b DORGHR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORGHR generates a real orthogonal matrix Q which is defined as the +*> product of IHI-ILO elementary reflectors of order N, as returned by +*> DGEHRD: +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix Q. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI must have the same values as in the previous call +*> of DGEHRD. Q is equal to the unit matrix except in the +*> submatrix Q(ilo+1:ihi,ilo+1:ihi). +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the vectors which define the elementary reflectors, +*> as returned by DGEHRD. +*> On exit, the N-by-N orthogonal matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEHRD. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= IHI-ILO. +*> For optimum performance LWORK >= (IHI-ILO)*NB, where NB is +*> the optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH +* .. +* .. External Subroutines .. + EXTERNAL DORGQR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first ilo and the last n-ihi +* rows and columns to those of the unit matrix +* + DO 40 J = IHI, ILO + 1, -1 + DO 10 I = 1, J - 1 + A( I, J ) = ZERO + 10 CONTINUE + DO 20 I = J + 1, IHI + A( I, J ) = A( I, J-1 ) + 20 CONTINUE + DO 30 I = IHI + 1, N + A( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + DO 60 J = 1, ILO + DO 50 I = 1, N + A( I, J ) = ZERO + 50 CONTINUE + A( J, J ) = ONE + 60 CONTINUE + DO 80 J = IHI + 1, N + DO 70 I = 1, N + A( I, J ) = ZERO + 70 CONTINUE + A( J, J ) = ONE + 80 CONTINUE +* + IF( NH.GT.0 ) THEN +* +* Generate Q(ilo+1:ihi,ilo+1:ihi) +* + CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), + $ WORK, LWORK, IINFO ) + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGHR +* + END +*> \brief \b DORGQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORGQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORGQR generates an M-by-N real matrix Q with orthonormal columns, +*> which is defined as the first N columns of a product of K elementary +*> reflectors of order M +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQRF in the first k columns of its array +*> argument A. +*> On exit, the M-by-N matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= max(1,N). +*> For optimum performance LWORK >= N*NB, where NB is the +*> optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQR +* + END +*> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORM2R overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T* C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQRF in the first k columns of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END +*> \brief \b DORMHR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMHR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, +* LDC, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORMHR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix of order nq, with nq = m if +*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of +*> IHI-ILO elementary reflectors, as returned by DGEHRD: +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI must have the same values as in the previous call +*> of DGEHRD. Q is equal to the unit matrix except in the +*> submatrix Q(ilo+1:ihi,ilo+1:ihi). +*> If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and +*> ILO = 1 and IHI = 0, if M = 0; +*> if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and +*> ILO = 1 and IHI = 0, if N = 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L' +*> (LDA,N) if SIDE = 'R' +*> The vectors which define the elementary reflectors, as +*> returned by DGEHRD. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension +*> (M-1) if SIDE = 'L' +*> (N-1) if SIDE = 'R' +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEHRD. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For optimum performance LWORK >= N*NB if SIDE = 'L', and +*> LWORK >= M*NB if SIDE = 'R', where NB is the optimal +*> blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORMQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LEFT = LSAME( SIDE, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN + INFO = -5 + ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 ) + ELSE + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 ) + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( LEFT ) THEN + MI = NH + NI = N + I1 = ILO + 1 + I2 = 1 + ELSE + MI = M + NI = NH + I1 = 1 + I2 = ILO + 1 + END IF +* + CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, + $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMHR +* + END +*> \brief \b DORMQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORMQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORMQR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQRF in the first k columns of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For good performance, LWORK should generally be larger. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT, TSIZE + PARAMETER ( NBMAX = 64, LDT = NBMAX+1, + $ TSIZE = LDT*NBMAX ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Compute the workspace requirements +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + TSIZE + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IF( LWORK.LT.NW*NB+TSIZE ) THEN + NB = (LWORK-TSIZE) / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IWT = 1 + NW*NB + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), WORK( IWT ), LDT ) + IF( LEFT ) THEN +* +* H or H**T is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**T is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**T +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, WORK( IWT ), LDT, + $ C( IC, JC ), LDC, WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END +*> \brief \b DTREVC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTREVC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, +* LDVR, MM, M, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER HOWMNY, SIDE +* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. +* LOGICAL SELECT( * ) +* DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTREVC computes some or all of the right and/or left eigenvectors of +*> a real upper quasi-triangular matrix T. +*> Matrices of this type are produced by the Schur factorization of +*> a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. +*> +*> The right eigenvector x and the left eigenvector y of T corresponding +*> to an eigenvalue w are defined by: +*> +*> T*x = w*x, (y**T)*T = w*(y**T) +*> +*> where y**T denotes the transpose of y. +*> The eigenvalues are not input to this routine, but are read directly +*> from the diagonal blocks of T. +*> +*> This routine returns the matrices X and/or Y of right and left +*> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an +*> input matrix. If Q is the orthogonal factor that reduces a matrix +*> A to Schur form T, then Q*X and Q*Y are the matrices of right and +*> left eigenvectors of A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'R': compute right eigenvectors only; +*> = 'L': compute left eigenvectors only; +*> = 'B': compute both right and left eigenvectors. +*> \endverbatim +*> +*> \param[in] HOWMNY +*> \verbatim +*> HOWMNY is CHARACTER*1 +*> = 'A': compute all right and/or left eigenvectors; +*> = 'B': compute all right and/or left eigenvectors, +*> backtransformed by the matrices in VR and/or VL; +*> = 'S': compute selected right and/or left eigenvectors, +*> as indicated by the logical array SELECT. +*> \endverbatim +*> +*> \param[in,out] SELECT +*> \verbatim +*> SELECT is LOGICAL array, dimension (N) +*> If HOWMNY = 'S', SELECT specifies the eigenvectors to be +*> computed. +*> If w(j) is a real eigenvalue, the corresponding real +*> eigenvector is computed if SELECT(j) is .TRUE.. +*> If w(j) and w(j+1) are the real and imaginary parts of a +*> complex eigenvalue, the corresponding complex eigenvector is +*> computed if either SELECT(j) or SELECT(j+1) is .TRUE., and +*> on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to +*> .FALSE.. +*> Not referenced if HOWMNY = 'A' or 'B'. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> The upper quasi-triangular matrix T in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,MM) +*> On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must +*> contain an N-by-N matrix Q (usually the orthogonal matrix Q +*> of Schur vectors returned by DHSEQR). +*> On exit, if SIDE = 'L' or 'B', VL contains: +*> if HOWMNY = 'A', the matrix Y of left eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*Y; +*> if HOWMNY = 'S', the left eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VL, in the same order as their +*> eigenvalues. +*> A complex eigenvector corresponding to a complex eigenvalue +*> is stored in two consecutive columns, the first holding the +*> real part, and the second the imaginary part. +*> Not referenced if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the array VL. LDVL >= 1, and if +*> SIDE = 'L' or 'B', LDVL >= N. +*> \endverbatim +*> +*> \param[in,out] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,MM) +*> On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must +*> contain an N-by-N matrix Q (usually the orthogonal matrix Q +*> of Schur vectors returned by DHSEQR). +*> On exit, if SIDE = 'R' or 'B', VR contains: +*> if HOWMNY = 'A', the matrix X of right eigenvectors of T; +*> if HOWMNY = 'B', the matrix Q*X; +*> if HOWMNY = 'S', the right eigenvectors of T specified by +*> SELECT, stored consecutively in the columns +*> of VR, in the same order as their +*> eigenvalues. +*> A complex eigenvector corresponding to a complex eigenvalue +*> is stored in two consecutive columns, the first holding the +*> real part and the second the imaginary part. +*> Not referenced if SIDE = 'L'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the array VR. LDVR >= 1, and if +*> SIDE = 'R' or 'B', LDVR >= N. +*> \endverbatim +*> +*> \param[in] MM +*> \verbatim +*> MM is INTEGER +*> The number of columns in the arrays VL and/or VR. MM >= M. +*> \endverbatim +*> +*> \param[out] M +*> \verbatim +*> M is INTEGER +*> The number of columns in the arrays VL and/or VR actually +*> used to store the eigenvectors. +*> If HOWMNY = 'A' or 'B', M is set to N. +*> Each selected real eigenvector occupies one column and each +*> selected complex eigenvector occupies two columns. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (3*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The algorithm used in this program is basically backward (forward) +*> substitution, with scaling to make the the code robust against +*> possible overflow. +*> +*> Each eigenvector is normalized so that the element of largest +*> magnitude has magnitude 1; here the magnitude of a complex number +*> (x,y) is taken to be |x| + |y|. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV + INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 + DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, + $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, + $ XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Local Arrays .. + DOUBLE PRECISION X( 2, 2 ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE +* +* Set M to the number of columns required to store the selected +* eigenvectors, standardize the array SELECT if necessary, and +* test MM. +* + IF( SOMEV ) THEN + M = 0 + PAIR = .FALSE. + DO 10 J = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + SELECT( J ) = .FALSE. + ELSE + IF( J.LT.N ) THEN + IF( T( J+1, J ).EQ.ZERO ) THEN + IF( SELECT( J ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN + SELECT( J ) = .TRUE. + M = M + 2 + END IF + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + ELSE + M = N + END IF +* + IF( MM.LT.M ) THEN + INFO = -11 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTREVC', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) + BIGNUM = ( ONE-ULP ) / SMLNUM +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + WORK( 1 ) = ZERO + DO 30 J = 2, N + WORK( J ) = ZERO + DO 20 I = 1, J - 1 + WORK( J ) = WORK( J ) + ABS( T( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* +* Index IP is used to specify the real or complex eigenvalue: +* IP = 0, real eigenvalue, +* 1, first of conjugate complex pair: (wr,wi) +* -1, second of conjugate complex pair: (wr,wi) +* + N2 = 2*N +* + IF( RIGHTV ) THEN +* +* Compute right eigenvectors. +* + IP = 0 + IS = M + DO 140 KI = N, 1, -1 +* + IF( IP.EQ.1 ) + $ GO TO 130 + IF( KI.EQ.1 ) + $ GO TO 40 + IF( T( KI, KI-1 ).EQ.ZERO ) + $ GO TO 40 + IP = -1 +* + 40 CONTINUE + IF( SOMEV ) THEN + IF( IP.EQ.0 ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + ELSE + IF( .NOT.SELECT( KI-1 ) ) + $ GO TO 130 + END IF + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* + $ SQRT( ABS( T( KI-1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* Real right eigenvector +* + WORK( KI+N ) = ONE +* +* Form right-hand side +* + DO 50 K = 1, KI - 1 + WORK( K+N ) = -T( K, KI ) + 50 CONTINUE +* +* Solve the upper quasi-triangular system: +* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. +* + JNXT = KI - 1 + DO 60 J = KI - 1, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 60 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+N ), N, WR, ZERO, X, 2, + $ SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(2,1) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 2, 1 ) = X( 2, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + WORK( J-1+N ) = X( 1, 1 ) + WORK( J+N ) = X( 2, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + END IF + 60 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) +* + II = IDAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / ABS( VR( II, IS ) ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 70 K = KI + 1, N + VR( K, IS ) = ZERO + 70 CONTINUE + ELSE + IF( KI.GT.1 ) + $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, + $ WORK( 1+N ), 1, WORK( KI+N ), + $ VR( 1, KI ), 1 ) +* + II = IDAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / ABS( VR( II, KI ) ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF +* + ELSE +* +* Complex right eigenvector. +* +* Initial solve +* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. +* [ (T(KI,KI-1) T(KI,KI) ) ] +* + IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN + WORK( KI-1+N ) = ONE + WORK( KI+N2 ) = WI / T( KI-1, KI ) + ELSE + WORK( KI-1+N ) = -WI / T( KI, KI-1 ) + WORK( KI+N2 ) = ONE + END IF + WORK( KI+N ) = ZERO + WORK( KI-1+N2 ) = ZERO +* +* Form right-hand side +* + DO 80 K = 1, KI - 2 + WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) + WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) + 80 CONTINUE +* +* Solve upper quasi-triangular system: +* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) +* + JNXT = KI - 2 + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, + $ X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(1,2) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 1, 2 ) = X( 1, 2 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, + $ XNORM, IERR ) +* +* Scale X to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + REC = ONE / XNORM + X( 1, 1 ) = X( 1, 1 )*REC + X( 1, 2 ) = X( 1, 2 )*REC + X( 2, 1 ) = X( 2, 1 )*REC + X( 2, 2 ) = X( 2, 2 )*REC + SCALE = SCALE*REC + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) + END IF + WORK( J-1+N ) = X( 1, 1 ) + WORK( J+N ) = X( 2, 1 ) + WORK( J-1+N2 ) = X( 1, 2 ) + WORK( J+N2 ) = X( 2, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, + $ WORK( 1+N2 ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) + END IF + 90 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) + CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) +* + EMAX = ZERO + DO 100 K = 1, KI + EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ + $ ABS( VR( K, IS ) ) ) + 100 CONTINUE +* + REMAX = ONE / EMAX + CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 110 K = KI + 1, N + VR( K, IS-1 ) = ZERO + VR( K, IS ) = ZERO + 110 CONTINUE +* + ELSE +* + IF( KI.GT.2 ) THEN + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1+N ), 1, WORK( KI-1+N ), + $ VR( 1, KI-1 ), 1 ) + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1+N2 ), 1, WORK( KI+N2 ), + $ VR( 1, KI ), 1 ) + ELSE + CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) + CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) + END IF +* + EMAX = ZERO + DO 120 K = 1, N + EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ + $ ABS( VR( K, KI ) ) ) + 120 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF + END IF +* + IS = IS - 1 + IF( IP.NE.0 ) + $ IS = IS - 1 + 130 CONTINUE + IF( IP.EQ.1 ) + $ IP = 0 + IF( IP.EQ.-1 ) + $ IP = 1 + 140 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* Compute left eigenvectors. +* + IP = 0 + IS = 1 + DO 260 KI = 1, N +* + IF( IP.EQ.-1 ) + $ GO TO 250 + IF( KI.EQ.N ) + $ GO TO 150 + IF( T( KI+1, KI ).EQ.ZERO ) + $ GO TO 150 + IP = 1 +* + 150 CONTINUE + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 250 + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* + $ SQRT( ABS( T( KI+1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* Real left eigenvector. +* + WORK( KI+N ) = ONE +* +* Form right-hand side +* + DO 160 K = KI + 1, N + WORK( K+N ) = -T( KI, K ) + 160 CONTINUE +* +* Solve the quasi-triangular system: +* (T(KI+1:N,KI+1:N) - WR)**T*X = SCALE*WORK +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 1 + DO 170 J = KI + 1, N + IF( J.LT.JNXT ) + $ GO TO 170 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+N ), 1 ) +* +* Solve (T(J,J)-WR)**T*X = WORK +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) + VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+N ), 1 ) +* + WORK( J+1+N ) = WORK( J+1+N ) - + $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, + $ WORK( KI+1+N ), 1 ) +* +* Solve +* [T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) +* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) + WORK( J+1+N ) = X( 2, 1 ) +* + VMAX = MAX( ABS( WORK( J+N ) ), + $ ABS( WORK( J+1+N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 170 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) +* + II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / ABS( VL( II, IS ) ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 180 K = 1, KI - 1 + VL( K, IS ) = ZERO + 180 CONTINUE +* + ELSE +* + IF( KI.LT.N ) + $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1+N ), 1, WORK( KI+N ), + $ VL( 1, KI ), 1 ) +* + II = IDAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / ABS( VL( II, KI ) ) + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) +* + END IF +* + ELSE +* +* Complex left eigenvector. +* +* Initial solve: +* ((T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI))*X = 0. +* ((T(KI+1,KI) T(KI+1,KI+1)) ) +* + IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN + WORK( KI+N ) = WI / T( KI, KI+1 ) + WORK( KI+1+N2 ) = ONE + ELSE + WORK( KI+N ) = ONE + WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) + END IF + WORK( KI+1+N ) = ZERO + WORK( KI+N2 ) = ZERO +* +* Form right-hand side +* + DO 190 K = KI + 2, N + WORK( K+N ) = -WORK( KI+N )*T( KI, K ) + WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) + 190 CONTINUE +* +* Solve complex quasi-triangular system: +* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 2 + DO 200 J = KI + 2, N + IF( J.LT.JNXT ) + $ GO TO 200 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when +* forming the right-hand side elements. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N ), 1 ) + WORK( J+N2 ) = WORK( J+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N2 ), 1 ) +* +* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) + VMAX = MAX( ABS( WORK( J+N ) ), + $ ABS( WORK( J+N2 ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side elements. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N ), 1 ) +* + WORK( J+N2 ) = WORK( J+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N2 ), 1 ) +* + WORK( J+1+N ) = WORK( J+1+N ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+N ), 1 ) +* + WORK( J+1+N2 ) = WORK( J+1+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+N2 ), 1 ) +* +* Solve 2-by-2 complex linear equation +* ([T(j,j) T(j,j+1) ]**T-(wr-i*wi)*I)*X = SCALE*B +* ([T(j+1,j) T(j+1,j+1)] ) +* + CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) + WORK( J+1+N ) = X( 2, 1 ) + WORK( J+1+N2 ) = X( 2, 2 ) + VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), + $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 200 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) + CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), + $ 1 ) +* + EMAX = ZERO + DO 220 K = KI, N + EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ + $ ABS( VL( K, IS+1 ) ) ) + 220 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) +* + DO 230 K = 1, KI - 1 + VL( K, IS ) = ZERO + VL( K, IS+1 ) = ZERO + 230 CONTINUE + ELSE + IF( KI.LT.N-1 ) THEN + CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), + $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), + $ VL( 1, KI ), 1 ) + CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), + $ LDVL, WORK( KI+2+N2 ), 1, + $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) + ELSE + CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) + CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) + END IF +* + EMAX = ZERO + DO 240 K = 1, N + EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ + $ ABS( VL( K, KI+1 ) ) ) + 240 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) + CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) +* + END IF +* + END IF +* + IS = IS + 1 + IF( IP.NE.0 ) + $ IS = IS + 1 + 250 CONTINUE + IF( IP.EQ.-1 ) + $ IP = 0 + IF( IP.EQ.1 ) + $ IP = -1 +* + 260 CONTINUE +* + END IF +* + RETURN +* +* End of DTREVC +* + END +*> \brief \b DTREXC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DTREXC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ +* INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTREXC reorders the real Schur factorization of a real matrix +*> A = Q*T*Q**T, so that the diagonal block of T with row index IFST is +*> moved to row ILST. +*> +*> The real Schur form T is reordered by an orthogonal similarity +*> transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors +*> is updated by postmultiplying it with Z. +*> +*> T must be in Schur canonical form (as returned by DHSEQR), that is, +*> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each +*> 2-by-2 diagonal block has its diagonal elements equal and its +*> off-diagonal elements of opposite sign. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'V': update the matrix Q of Schur vectors; +*> = 'N': do not update Q. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix T. N >= 0. +*> \endverbatim +*> +*> \param[in,out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,N) +*> On entry, the upper quasi-triangular matrix T, in Schur +*> Schur canonical form. +*> On exit, the reordered upper quasi-triangular matrix, again +*> in Schur canonical form. +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of the array T. LDT >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ,N) +*> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. +*> On exit, if COMPQ = 'V', Q has been postmultiplied by the +*> orthogonal transformation matrix Z which reorders T. +*> If COMPQ = 'N', Q is not referenced. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. LDQ >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] IFST +*> \verbatim +*> IFST is INTEGER +*> \endverbatim +*> +*> \param[in,out] ILST +*> \verbatim +*> ILST is INTEGER +*> +*> Specify the reordering of the diagonal blocks of T. +*> The block with row index IFST is moved to row ILST, by a +*> sequence of transpositions between adjacent blocks. +*> On exit, if IFST pointed on entry to the second row of a +*> 2-by-2 block, it is changed to point to the first row; ILST +*> always points to the first row of the block in its final +*> position (which may differ from its input value by +1 or -1). +*> 1 <= IFST <= N; 1 <= ILST <= N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> = 1: two adjacent blocks were too close to swap (the problem +*> is very ill-conditioned); T may have been partially +*> reordered, and ILST points to the first row of the +*> current position of the block being moved. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER HERE, NBF, NBL, NBNEXT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAEXC, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input arguments. +* + INFO = 0 + WANTQ = LSAME( COMPQ, 'V' ) + IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -7 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTREXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* +* Determine the first row of specified block +* and find out it is 1 by 1 or 2 by 2. +* + IF( IFST.GT.1 ) THEN + IF( T( IFST, IFST-1 ).NE.ZERO ) + $ IFST = IFST - 1 + END IF + NBF = 1 + IF( IFST.LT.N ) THEN + IF( T( IFST+1, IFST ).NE.ZERO ) + $ NBF = 2 + END IF +* +* Determine the first row of the final block +* and find out it is 1 by 1 or 2 by 2. +* + IF( ILST.GT.1 ) THEN + IF( T( ILST, ILST-1 ).NE.ZERO ) + $ ILST = ILST - 1 + END IF + NBL = 1 + IF( ILST.LT.N ) THEN + IF( T( ILST+1, ILST ).NE.ZERO ) + $ NBL = 2 + END IF +* + IF( IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* Update ILST +* + IF( NBF.EQ.2 .AND. NBL.EQ.1 ) + $ ILST = ILST - 1 + IF( NBF.EQ.1 .AND. NBL.EQ.2 ) + $ ILST = ILST + 1 +* + HERE = IFST +* + 10 CONTINUE +* +* Swap block with next one below +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1 by 1 or 2 by 2 +* + NBNEXT = 1 + IF( HERE+NBF+1.LE.N ) THEN + IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + NBNEXT +* +* Test if 2 by 2 block breaks into two 1 by 1 blocks +* + IF( NBF.EQ.2 ) THEN + IF( T( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1 by 1 blocks each of which +* must be swapped individually +* + NBNEXT = 1 + IF( HERE+3.LE.N ) THEN + IF( T( HERE+3, HERE+2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1 by 1 blocks, no problems possible +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, + $ WORK, INFO ) + HERE = HERE + 1 + ELSE +* +* Recompute NBNEXT in case 2 by 2 split +* + IF( T( HERE+2, HERE+1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2 by 2 Block did not split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, + $ NBNEXT, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 2 + ELSE +* +* 2 by 2 Block did split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, + $ WORK, INFO ) + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, + $ WORK, INFO ) + HERE = HERE + 2 + END IF + END IF + END IF + IF( HERE.LT.ILST ) + $ GO TO 10 +* + ELSE +* + HERE = IFST + 20 CONTINUE +* +* Swap block with next one above +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1 by 1 or 2 by 2 +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( T( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, + $ NBF, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - NBNEXT +* +* Test if 2 by 2 block breaks into two 1 by 1 blocks +* + IF( NBF.EQ.2 ) THEN + IF( T( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1 by 1 blocks each of which +* must be swapped individually +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( T( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, + $ 1, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1 by 1 blocks, no problems possible +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, + $ WORK, INFO ) + HERE = HERE - 1 + ELSE +* +* Recompute NBNEXT in case 2 by 2 split +* + IF( T( HERE, HERE-1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2 by 2 Block did not split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 2 + ELSE +* +* 2 by 2 Block did split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, + $ WORK, INFO ) + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, + $ WORK, INFO ) + HERE = HERE - 2 + END IF + END IF + END IF + IF( HERE.GT.ILST ) + $ GO TO 20 + END IF + ILST = HERE +* + RETURN +* +* End of DTREXC +* + END +*> \brief \b IEEECK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* .. Scalar Arguments .. +* INTEGER ISPEC +* REAL ONE, ZERO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IEEECK is called from the ILAENV to verify that Infinity and +*> possibly NaN arithmetic is safe (i.e. will not trap). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies whether to test just for inifinity arithmetic +*> or whether to test for infinity and NaN arithmetic. +*> = 0: Verify infinity arithmetic only. +*> = 1: Verify infinity and NaN arithmetic. +*> \endverbatim +*> +*> \param[in] ZERO +*> \verbatim +*> ZERO is REAL +*> Must contain the value 0.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> \endverbatim +*> +*> \param[in] ONE +*> \verbatim +*> ONE is REAL +*> Must contain the value 1.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> +*> RETURN VALUE: INTEGER +*> = 0: Arithmetic failed to produce the correct answers +*> = 1: Arithmetic produced the correct answers +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END +*> \brief \b ILADLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILADLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILADLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILADLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILADLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILADLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILADLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILADLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END +*> \brief \b ILADLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILADLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILADLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILADLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILADLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILADLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILADLR = 0 + DO J = 1, N + I=M + DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILADLR = MAX( ILADLR, I ) + END DO + END IF + RETURN + END +*> \brief \b ILAENV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAENV is called from the LAPACK routines to choose problem-dependent +*> parameters for the local environment. See ISPEC for a description of +*> the parameters. +*> +*> ILAENV returns an INTEGER +*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC +*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. +*> +*> This version provides a set of parameters which should give good, +*> but not optimal, performance on many of the currently available +*> computers. Users are encouraged to modify this subroutine to set +*> the tuning parameters for their particular machine using the option +*> and problem size information in the arguments. +*> +*> This routine will not function correctly if it is converted to all +*> lower case. Converting it to all upper case is allowed. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies the parameter to be returned as the value of +*> ILAENV. +*> = 1: the optimal blocksize; if this value is 1, an unblocked +*> algorithm will give the best performance. +*> = 2: the minimum block size for which the block routine +*> should be used; if the usable block size is less than +*> this value, an unblocked routine should be used. +*> = 3: the crossover point (in a block routine, for N less +*> than this value, an unblocked routine should be used) +*> = 4: the number of shifts, used in the nonsymmetric +*> eigenvalue routines (DEPRECATED) +*> = 5: the minimum column dimension for blocking to be used; +*> rectangular blocks must have dimension at least k by m, +*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) +*> = 6: the crossover point for the SVD (when reducing an m by n +*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +*> this value, a QR factorization is used first to reduce +*> the matrix to a triangular form.) +*> = 7: the number of processors +*> = 8: the crossover point for the multishift QR method +*> for nonsymmetric eigenvalue problems (DEPRECATED) +*> = 9: maximum size of the subproblems at the bottom of the +*> computation tree in the divide-and-conquer algorithm +*> (used by xGELSD and xGESDD) +*> =10: ieee NaN arithmetic can be trusted not to trap +*> =11: infinity arithmetic can be trusted not to trap +*> 12 <= ISPEC <= 16: +*> xHSEQR or related subroutines, +*> see IPARMQ for detailed explanation +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is CHARACTER*(*) +*> The name of the calling subroutine, in either upper case or +*> lower case. +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> \endverbatim +*> +*> \param[in] N3 +*> \verbatim +*> N3 is INTEGER +*> \endverbatim +*> +*> \param[in] N4 +*> \verbatim +*> N4 is INTEGER +*> Problem dimensions for the subroutine NAME; these may not all +*> be required. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The following conventions have been used when calling ILAENV from the +*> LAPACK routines: +*> 1) OPTS is a concatenation of all of the character options to +*> subroutine NAME, in the same order that they appear in the +*> argument list for NAME, even if they are not used in determining +*> the value of the parameter specified by ISPEC. +*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order +*> that they appear in the argument list for NAME. N1 is used +*> first, N2 second, and so on, and unused problem dimensions are +*> passed a value of -1. +*> 3) The parameter value returned by ILAENV is checked for validity in +*> the calling subroutine. For example, ILAENV is used to retrieve +*> the optimal blocksize for STRTRI as follows: +*> +*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +*> IF( NB.LE.1 ) NB = MAX( 1, N ) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF ( C3.EQ.'EVC' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NB = 32 + IF( C3.EQ.'HD3' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NBMIN = 2 + IF( C3.EQ.'HD3' ) THEN + NBMIN = 2 + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NX = 128 + IF( C3.EQ.'HD3' ) THEN + NX = 128 + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or related subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END +*> \brief \b IPARMQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, ISPEC, LWORK, N +* CHARACTER NAME*( * ), OPTS*( * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever +*> IPARMQ is called with 12 <= ISPEC <= 16 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is integer scalar +*> ISPEC specifies which tunable parameter IPARMQ should +*> return. +*> +*> ISPEC=12: (INMIN) Matrices of order nmin or less +*> are sent directly to xLAHQR, the implicit +*> double shift QR algorithm. NMIN must be +*> at least 11. +*> +*> ISPEC=13: (INWIN) Size of the deflation window. +*> This is best set greater than or equal to +*> the number of simultaneous shifts NS. +*> Larger matrices benefit from larger deflation +*> windows. +*> +*> ISPEC=14: (INIBL) Determines when to stop nibbling and +*> invest in an (expensive) multi-shift QR sweep. +*> If the aggressive early deflation subroutine +*> finds LD converged eigenvalues from an order +*> NW deflation window and LD.GT.(NW*NIBBLE)/100, +*> then the next QR sweep is skipped and early +*> deflation is applied immediately to the +*> remaining active diagonal block. Setting +*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +*> multi-shift QR sweep whenever early deflation +*> finds a converged eigenvalue. Setting +*> IPARMQ(ISPEC=14) greater than or equal to 100 +*> prevents TTQRE from skipping a multi-shift +*> QR sweep. +*> +*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in +*> a multi-shift QR iteration. +*> +*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +*> following meanings. +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the +*> far-from-diagonal matrix entries. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. +*> (If xTRMM is slower than xGEMM, then +*> IPARMQ(ISPEC=16)=1 may be more efficient than +*> IPARMQ(ISPEC=16)=2 despite the greater level of +*> arithmetic work implied by the latter choice.) +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is character string +*> This is a concatenation of the string arguments to +*> TTQRE. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is integer scalar +*> N is the order of the Hessenberg matrix H. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer scalar +*> The amount of workspace available. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Little is known about how best to choose these parameters. +*> It is possible to use different values of the parameters +*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +*> +*> It is probably best to choose different parameters for +*> different matrices and different parameters at different +*> times during the iteration, but this has not been +*> implemented --- yet. +*> +*> +*> The best choices of most of the parameters depend +*> in an ill-understood way on the relative execution +*> rate of xLAQR3 and xLAQR5 and on the nature of each +*> particular eigenvalue problem. Experiment may be the +*> only practical way to determine which choices are most +*> effective. +*> +*> Following is a list of default values supplied by IPARMQ. +*> These defaults may be adjusted in order to attain better +*> performance in any particular computational environment. +*> +*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> IPARMQ(ISPEC=13) Recommended deflation window size. +*> This depends on ILO, IHI and NS, the +*> number of simultaneous shifts returned +*> by IPARMQ(ISPEC=15). The default for +*> (IHI-ILO+1).LE.500 is NS. The default +*> for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +*> +*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +*> a multi-shift QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 0 30 NS = 2+ +*> 30 60 NS = 4+ +*> 60 150 NS = 10 +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default matrices of this order are +*> passed to the implicit double shift routine +*> xLAHQR. See IPARMQ(ISPEC=12) above. These +*> values of NS are used only in case of a rare +*> xLAHQR failure. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function increasing from 10 to 64. +*> +*> IPARMQ(ISPEC=16) Select structured matrix multiply. +*> (See ISPEC=16 above for details.) +*> Default: 3. +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* +* +* Convert NAME to upper case if the first character is lower case. +* + IPARMQ = 0 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + END DO + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF + END IF +* + IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. + $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN + IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN + IF( NH.GE.KACMIN ) + $ IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. + $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + END IF +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME( CA, CB ) +* +* .. Scalar Arguments .. +* CHARACTER CA, CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA.EQ.CB + IF( LSAME ) + $ RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR( 'Z' ) +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR( CA ) + INTB = ICHAR( CB ) +* + IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 + IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 +* + ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.129 .AND. INTA.LE.137 .OR. + $ INTA.GE.145 .AND. INTA.LE.153 .OR. + $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 + IF( INTB.GE.129 .AND. INTB.LE.137 .OR. + $ INTB.GE.145 .AND. INTB.LE.153 .OR. + $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 +* + ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 + IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 + END IF + LSAME = INTA.EQ.INTB +* +* RETURN +* +* End of LSAME +* + END +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download XERBLA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + diff --git a/dataassim/math/numrec/dgemm.f b/dataassim/math/numrec/dgemm.f new file mode 100644 index 0000000..7ac8c46 --- /dev/null +++ b/dataassim/math/numrec/dgemm.f @@ -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 diff --git a/dataassim/math/numrec/dgemv.f b/dataassim/math/numrec/dgemv.f new file mode 100644 index 0000000..a412594 --- /dev/null +++ b/dataassim/math/numrec/dgemv.f @@ -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 diff --git a/dataassim/math/numrec/dger.f b/dataassim/math/numrec/dger.f new file mode 100644 index 0000000..1d95257 --- /dev/null +++ b/dataassim/math/numrec/dger.f @@ -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 diff --git a/dataassim/math/numrec/dnrm2.f b/dataassim/math/numrec/dnrm2.f new file mode 100644 index 0000000..480c912 --- /dev/null +++ b/dataassim/math/numrec/dnrm2.f @@ -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 diff --git a/dataassim/math/numrec/dscal.f b/dataassim/math/numrec/dscal.f new file mode 100644 index 0000000..986c24e --- /dev/null +++ b/dataassim/math/numrec/dscal.f @@ -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 diff --git a/dataassim/math/numrec/dswap.f b/dataassim/math/numrec/dswap.f new file mode 100644 index 0000000..93db05c --- /dev/null +++ b/dataassim/math/numrec/dswap.f @@ -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 diff --git a/dataassim/math/numrec/dsyev.f b/dataassim/math/numrec/dsyev.f new file mode 100644 index 0000000..4b586df --- /dev/null +++ b/dataassim/math/numrec/dsyev.f @@ -0,0 +1,10505 @@ + subroutine eigen_sym_up(N,A,W) + implicit none +! +!compute the eigenvalues and eigenvectors of a symmetrical matrix. +!A: On entry, A is a symmetrical matrix with its upper triangle filled. +! on exit, A contains the normalized eigenvectors in its columns. +!W: contains the eigenvalues in descending order. + + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N + DOUBLE PRECISION A(N, N), W( N ), WORK(3*N-1) + double precision p + integer i,j + + JOBZ='V' + UPLO='U' + LWORK=3*N-1 + LDA=N + call DSYEV(JOBZ,UPLO,N,A(1:N,1:N),LDA,W,WORK,LWORK,INFO) +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the algorithm failed to converge; i +* off-diagonal elements of an intermediate tridiagonal +* form did not converge to zero. + if(INFO.lt.0)then + write(*,*)'The ',-INFO, + & 'th argument in DSYEV has an illegal value' + stop + endif + if(INFO.gt.0)then + write(*,*)'The algorithm failed to converge' + stop + endif + +! Change the eigenvalue array from ascending to descending order and rearrange +! the eigen vectors accordingly. +!--------------------------------------------- + do i=1,N/2 + p=W(i) + W(i)=W(N-i+1) + W(N-i+1)=p + do j=1,N + p=A(j,i) + A(j,i)=A(j,N-i+1) + A(j,N-i+1)=p + enddo + enddo +!--------------------------------------------- + return + end + LOGICAL FUNCTION DISNAN( DIN ) +* +* -- LAPACK auxiliary routine (version 3.2.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DIN +* .. +* +* Purpose +* ======= +* +* DISNAN returns .TRUE. if its argument is NaN, and .FALSE. +* otherwise. To be replaced by the Fortran 2003 intrinsic in the +* future. +* +* Arguments +* ========= +* +* DIN (input) DOUBLE PRECISION +* Input to test for NaN. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL DLAISNAN + EXTERNAL DLAISNAN +* .. +* .. Executable Statements .. + DISNAN = DLAISNAN(DIN,DIN) + RETURN + END + SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, RT1, RT2 +* .. +* +* Purpose +* ======= +* +* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix +* [ A B ] +* [ B C ]. +* On return, RT1 is the eigenvalue of larger absolute value, and RT2 +* is the eigenvalue of smaller absolute value. +* +* Arguments +* ========= +* +* A (input) DOUBLE PRECISION +* The (1,1) element of the 2-by-2 matrix. +* +* B (input) DOUBLE PRECISION +* The (1,2) and (2,1) elements of the 2-by-2 matrix. +* +* C (input) DOUBLE PRECISION +* The (2,2) element of the 2-by-2 matrix. +* +* RT1 (output) DOUBLE PRECISION +* The eigenvalue of larger absolute value. +* +* RT2 (output) DOUBLE PRECISION +* The eigenvalue of smaller absolute value. +* +* Further Details +* =============== +* +* RT1 is accurate to a few ulps barring over/underflow. +* +* RT2 may be inaccurate if there is massive cancellation in the +* determinant A*C-B*B; higher precision or correctly rounded or +* correctly truncated arithmetic would be needed to compute RT2 +* accurately in all cases. +* +* Overflow is possible only if RT1 is within a factor of 5 of overflow. +* Underflow is harmless if the input data is 0 or exceeds +* underflow_threshold / macheps. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* +* Compute the eigenvalues +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* Includes case AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE IF( SM.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE +* +* Includes case RT1 = RT2 = 0 +* + RT1 = HALF*RT + RT2 = -HALF*RT + END IF + RETURN +* +* End of DLAE2 +* + END + SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 +* .. +* +* Purpose +* ======= +* +* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix +* [ A B ] +* [ B C ]. +* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the +* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right +* eigenvector for RT1, giving the decomposition +* +* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] +* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. +* +* Arguments +* ========= +* +* A (input) DOUBLE PRECISION +* The (1,1) element of the 2-by-2 matrix. +* +* B (input) DOUBLE PRECISION +* The (1,2) element and the conjugate of the (2,1) element of +* the 2-by-2 matrix. +* +* C (input) DOUBLE PRECISION +* The (2,2) element of the 2-by-2 matrix. +* +* RT1 (output) DOUBLE PRECISION +* The eigenvalue of larger absolute value. +* +* RT2 (output) DOUBLE PRECISION +* The eigenvalue of smaller absolute value. +* +* CS1 (output) DOUBLE PRECISION +* SN1 (output) DOUBLE PRECISION +* The vector (CS1, SN1) is a unit right eigenvector for RT1. +* +* Further Details +* =============== +* +* RT1 is accurate to a few ulps barring over/underflow. +* +* RT2 may be inaccurate if there is massive cancellation in the +* determinant A*C-B*B; higher precision or correctly rounded or +* correctly truncated arithmetic would be needed to compute RT2 +* accurately in all cases. +* +* CS1 and SN1 are accurate to a few ulps barring over/underflow. +* +* Overflow is possible only if RT1 is within a factor of 5 of overflow. +* Underflow is harmless if the input data is 0 or exceeds +* underflow_threshold / macheps. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + INTEGER SGN1, SGN2 + DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, + $ TB, TN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* +* Compute the eigenvalues +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* Includes case AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) + SGN1 = -1 +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE IF( SM.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) + SGN1 = 1 +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE +* +* Includes case RT1 = RT2 = 0 +* + RT1 = HALF*RT + RT2 = -HALF*RT + SGN1 = 1 + END IF +* +* Compute the eigenvector +* + IF( DF.GE.ZERO ) THEN + CS = DF + RT + SGN2 = 1 + ELSE + CS = DF - RT + SGN2 = -1 + END IF + ACS = ABS( CS ) + IF( ACS.GT.AB ) THEN + CT = -TB / CS + SN1 = ONE / SQRT( ONE+CT*CT ) + CS1 = CT*SN1 + ELSE + IF( AB.EQ.ZERO ) THEN + CS1 = ONE + SN1 = ZERO + ELSE + TN = -CS / TB + CS1 = ONE / SQRT( ONE+TN*TN ) + SN1 = TN*CS1 + END IF + END IF + IF( SGN1.EQ.SGN2 ) THEN + TN = CS1 + CS1 = -SN1 + SN1 = TN + END IF + RETURN +* +* End of DLAEV2 +* + END + LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) +* +* -- LAPACK auxiliary routine (version 3.2.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION DIN1, DIN2 +* .. +* +* Purpose +* ======= +* +* This routine is not for general use. It exists solely to avoid +* over-optimization in DISNAN. +* +* DLAISNAN checks for NaNs by comparing its two arguments for +* inequality. NaN is the only floating-point value where NaN != NaN +* returns .TRUE. To check for NaNs, pass the same variable as both +* arguments. +* +* A compiler must assume that the two arguments are +* not the same variable, and the test will not be optimized away. +* Interprocedural or whole-program optimization may delete this +* test. The ISNAN functions will be replaced by the correct +* Fortran 03 intrinsic once the intrinsic is widely available. +* +* Arguments +* ========= +* +* DIN1 (input) DOUBLE PRECISION +* +* DIN2 (input) DOUBLE PRECISION +* Two numbers to compare for inequality. +* +* ===================================================================== +* +* .. Executable Statements .. + DLAISNAN = (DIN1.NE.DIN2) + RETURN + END + DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* Purpose +* ======= +* +* DLANST returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* real symmetric tridiagonal matrix A. +* +* Description +* =========== +* +* DLANST returns the value +* +* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER*1 +* Specifies the value to be returned in DLANST as described +* above. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, DLANST is +* set to zero. +* +* D (input) DOUBLE PRECISION array, dimension (N) +* The diagonal elements of A. +* +* E (input) DOUBLE PRECISION array, dimension (N-1) +* The (n-1) sub-diagonal or super-diagonal elements of A. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ANORM, SCALE, SUM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + ANORM = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + ANORM = ABS( D( N ) ) + DO 10 I = 1, N - 1 + ANORM = MAX( ANORM, ABS( D( I ) ) ) + ANORM = MAX( ANORM, ABS( E( I ) ) ) + 10 CONTINUE + ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. + $ LSAME( NORM, 'I' ) ) THEN +* +* Find norm1(A). +* + IF( N.EQ.1 ) THEN + ANORM = ABS( D( 1 ) ) + ELSE + ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), + $ ABS( E( N-1 ) )+ABS( D( N ) ) ) + DO 20 I = 2, N - 1 + ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ + $ ABS( E( I-1 ) ) ) + 20 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( N.GT.1 ) THEN + CALL DLASSQ( N-1, E, 1, SCALE, SUM ) + SUM = 2*SUM + END IF + CALL DLASSQ( N, D, 1, SCALE, SUM ) + ANORM = SCALE*SQRT( SUM ) + END IF +* + DLANST = ANORM + RETURN +* +* End of DLANST +* + END + DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLANSY returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* real symmetric matrix A. +* +* Description +* =========== +* +* DLANSY returns the value +* +* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER*1 +* Specifies the value to be returned in DLANSY as described +* above. +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is to be referenced. +* = 'U': Upper triangular part of A is referenced +* = 'L': Lower triangular part of A is referenced +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, DLANSY is +* set to zero. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading n by n +* upper triangular part of A contains the upper triangular part +* of the matrix A, and the strictly lower triangular part of A +* is not referenced. If UPLO = 'L', the leading n by n lower +* triangular part of A contains the lower triangular part of +* the matrix A, and the strictly upper triangular part of A is +* not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(N,1). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +* WORK is not referenced. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is symmetric). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + ABS( A( J, J ) ) + 60 CONTINUE + DO 70 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + ABS( A( J, J ) ) + DO 90 I = J + 1, N + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + VALUE = MAX( VALUE, SUM ) + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) + 120 CONTINUE + END IF + SUM = 2*SUM + CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANSY = VALUE + RETURN +* +* End of DLANSY +* + END + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* Purpose +* ======= +* +* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +* overflow. +* +* Arguments +* ========= +* +* X (input) DOUBLE PRECISION +* Y (input) DOUBLE PRECISION +* X and Y specify the values x and y. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLARF applies a real elementary reflector H to a real m by n matrix +* C, from either the left or the right. H is represented in the form +* +* H = I - tau * v * v**T +* +* where tau is a real scalar and v is a real vector. +* +* If tau = 0, then H is taken to be the unit matrix. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': form H * C +* = 'R': form C * H +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* V (input) DOUBLE PRECISION array, dimension +* (1 + (M-1)*abs(INCV)) if SIDE = 'L' +* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +* The vector v in the representation of H. V is not used if +* TAU = 0. +* +* INCV (input) INTEGER +* The increment between elements of v. INCV <> 0. +* +* TAU (input) DOUBLE PRECISION +* The value tau in the representation of H. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by the matrix H * C if SIDE = 'L', +* or C * H if SIDE = 'R'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L' +* or (M) if SIDE = 'R' +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF +! Note that lastc.eq.0 renders the BLAS operations null; no special +! case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T +* + CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T +* + CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* Purpose +* ======= +* +* DLARFB applies a real block reflector H or its transpose H**T to a +* real m by n matrix C, from either the left or the right. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply H or H**T from the Left +* = 'R': apply H or H**T from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply H (No transpose) +* = 'T': apply H**T (Transpose) +* +* DIRECT (input) CHARACTER*1 +* Indicates how H is formed from a product of elementary +* reflectors +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Indicates how the vectors which define the elementary +* reflectors are stored: +* = 'C': Columnwise +* = 'R': Rowwise +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* K (input) INTEGER +* The order of the matrix T (= the number of elementary +* reflectors whose product defines the block reflector). +* +* V (input) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,M) if STOREV = 'R' and SIDE = 'L' +* (LDV,N) if STOREV = 'R' and SIDE = 'R' +* The matrix V. See Further Details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +* if STOREV = 'R', LDV >= K. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,K) +* The triangular k by k matrix T in the representation of the +* block reflector. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) +* +* LDWORK (input) INTEGER +* The leading dimension of the array WORK. +* If SIDE = 'L', LDWORK >= max(1,N); +* if SIDE = 'R', LDWORK >= max(1,M). +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J, LASTV, LASTC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) +* +* W := C1**T +* + DO 10 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T *V2 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 30 J = 1, K + DO 20 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) +* +* W := C2**T +* + DO 70 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1 * W**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 90 J = 1, K + DO 80 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) +* +* W := C1**T +* + DO 130 J = 1, K + CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**T*V2**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**T +* + DO 150 J = 1, K + DO 140 I = 1, LASTC + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**T +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**T * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) + LASTC = ILADLC( LASTV, N, C, LDC ) +* +* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) +* +* W := C2**T +* + DO 190 J = 1, K + CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**T * V1**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**T or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**T * W**T +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1**T * W**T +* + CALL DGEMM( 'Transpose', 'Transpose', + $ LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**T +* + DO 210 J = 1, K + DO 200 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**T where C = ( C1 C2 ) +* + LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) + LASTC = ILADLR( M, LASTV, C, LDC ) +* +* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**T +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1**T +* + CALL DGEMM( 'No transpose', 'Transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**T +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLARFG generates a real elementary reflector H of order n, such +* that +* +* H * ( alpha ) = ( beta ), H**T * H = I. +* ( x ) ( 0 ) +* +* where alpha and beta are scalars, and x is an (n-1)-element real +* vector. H is represented in the form +* +* H = I - tau * ( 1 ) * ( 1 v**T ) , +* ( v ) +* +* where tau is a real scalar and v is a real (n-1)-element +* vector. +* +* If the elements of x are all zero, then tau = 0 and H is taken to be +* the unit matrix. +* +* Otherwise 1 <= tau <= 2. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the elementary reflector. +* +* ALPHA (input/output) DOUBLE PRECISION +* On entry, the value alpha. +* On exit, it is overwritten with the value beta. +* +* X (input/output) DOUBLE PRECISION array, dimension +* (1+(N-2)*abs(INCX)) +* On entry, the vector x. +* On exit, it is overwritten with the vector v. +* +* INCX (input) INTEGER +* The increment between elements of X. INCX > 0. +* +* TAU (output) DOUBLE PRECISION +* The value tau. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + END IF + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of DLARFG +* + END + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* DLARFT forms the triangular factor T of a real block reflector H +* of order n, which is defined as a product of k elementary reflectors. +* +* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +* +* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +* +* If STOREV = 'C', the vector which defines the elementary reflector +* H(i) is stored in the i-th column of the array V, and +* +* H = I - V * T * V**T +* +* If STOREV = 'R', the vector which defines the elementary reflector +* H(i) is stored in the i-th row of the array V, and +* +* H = I - V**T * T * V +* +* Arguments +* ========= +* +* DIRECT (input) CHARACTER*1 +* Specifies the order in which the elementary reflectors are +* multiplied to form the block reflector: +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Specifies how the vectors which define the elementary +* reflectors are stored (see also Further Details): +* = 'C': columnwise +* = 'R': rowwise +* +* N (input) INTEGER +* The order of the block reflector H. N >= 0. +* +* K (input) INTEGER +* The order of the triangular factor T (= the number of +* elementary reflectors). K >= 1. +* +* V (input/output) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,N) if STOREV = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i). +* +* T (output) DOUBLE PRECISION array, dimension (LDT,K) +* The k by k triangular factor T of the block reflector. +* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +* lower triangular. The rest of the array is not used. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV + DOUBLE PRECISION VII +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO 20 I = 1, K + PREVLASTV = MAX( I, PREVLASTV ) + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) +* + CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T +* + CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + 20 CONTINUE + ELSE + PREVLASTV = 1 + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T +* + CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ZERO, T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END + SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* Purpose +* ======= +* +* DLARTG generate a plane rotation so that +* +* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. +* [ -SN CS ] [ G ] [ 0 ] +* +* This is a slower, more accurate version of the BLAS1 routine DROTG, +* with the following other differences: +* F and G are unchanged on return. +* If G=0, then CS=1 and SN=0. +* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any +* floating point operations (saves work in DBDSQR when +* there are zeros on the diagonal). +* +* If F exceeds G in magnitude, CS will be positive. +* +* Arguments +* ========= +* +* F (input) DOUBLE PRECISION +* The first component of vector to be rotated. +* +* G (input) DOUBLE PRECISION +* The second component of vector to be rotated. +* +* CS (output) DOUBLE PRECISION +* The cosine of the rotation. +* +* SN (output) DOUBLE PRECISION +* The sine of the rotation. +* +* R (output) DOUBLE PRECISION +* The nonzero component of the rotated vector. +* +* This version has a few statements commented out for thread safety +* (machine parameters are computed on each entry). 10 feb 03, SJH. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, SQRT +* .. +* .. Save statement .. +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. +* DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* IF( FIRST ) THEN + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 +* FIRST = .FALSE. +* END IF + IF( G.EQ.ZERO ) THEN + CS = ONE + SN = ZERO + R = F + ELSE IF( F.EQ.ZERO ) THEN + CS = ZERO + SN = ONE + R = G + ELSE + F1 = F + G1 = G + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) THEN + COUNT = 0 + 10 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMN2 + G1 = G1*SAFMN2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 20 I = 1, COUNT + R = R*SAFMX2 + 20 CONTINUE + ELSE IF( SCALE.LE.SAFMN2 ) THEN + COUNT = 0 + 30 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMX2 + G1 = G1*SAFMX2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.LE.SAFMN2 ) + $ GO TO 30 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 40 I = 1, COUNT + R = R*SAFMN2 + 40 CONTINUE + ELSE + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + END IF + IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN + CS = -CS + SN = -SN + R = -R + END IF + END IF + RETURN +* +* End of DLARTG +* + END + SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.3.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2010 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASCL multiplies the M by N real matrix A by the real scalar +* CTO/CFROM. This is done without over/underflow as long as the final +* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +* A may be full, upper triangular, lower triangular, upper Hessenberg, +* or banded. +* +* Arguments +* ========= +* +* TYPE (input) CHARACTER*1 +* TYPE indices the storage type of the input matrix. +* = 'G': A is a full matrix. +* = 'L': A is a lower triangular matrix. +* = 'U': A is an upper triangular matrix. +* = 'H': A is an upper Hessenberg matrix. +* = 'B': A is a symmetric band matrix with lower bandwidth KL +* and upper bandwidth KU and with the only the lower +* half stored. +* = 'Q': A is a symmetric band matrix with lower bandwidth KL +* and upper bandwidth KU and with the only the upper +* half stored. +* = 'Z': A is a band matrix with lower bandwidth KL and upper +* bandwidth KU. See DGBTRF for storage details. +* +* KL (input) INTEGER +* The lower bandwidth of A. Referenced only if TYPE = 'B', +* 'Q' or 'Z'. +* +* KU (input) INTEGER +* The upper bandwidth of A. Referenced only if TYPE = 'B', +* 'Q' or 'Z'. +* +* CFROM (input) DOUBLE PRECISION +* CTO (input) DOUBLE PRECISION +* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed +* without over/underflow if the final result CTO*A(I,J)/CFROM +* can be represented without over/underflow. CFROM must be +* nonzero. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* The matrix to be multiplied by CTO/CFROM. See TYPE for the +* storage type. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* INFO (output) INTEGER +* 0 - successful exit +* <0 - if INFO = -i, the i-th argument had an illegal value. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +* + IF( ITYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN + INFO = -4 + ELSE IF( DISNAN(CTO) ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. + $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN + INFO = -7 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -2 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -3 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -9 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASCL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* + CFROMC = CFROM + CTOC = CTO +* + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + IF( CFROM1.EQ.CFROMC ) THEN +! CFROMC is an inf. Multiply by a correctly signed zero for +! finite CTOC, or a NaN if CTOC is infinite. + MUL = CTOC / CFROMC + DONE = .TRUE. + CTO1 = CTOC + ELSE + CTO1 = CTOC / BIGNUM + IF( CTO1.EQ.CTOC ) THEN +! CTOC is either 0 or an inf. In both cases, CTOC itself +! serves as the correct multiplication factor. + MUL = CTOC + DONE = .TRUE. + CFROMC = ONE + ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF + END IF +* + IF( ITYPE.EQ.0 ) THEN +* +* Full matrix +* + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( ITYPE.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 J = 1, N + DO 60 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 J = 1, N + DO 80 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + K3 = KL + 1 + K4 = N + 1 + DO 110 J = 1, N + DO 100 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + K1 = KU + 2 + K3 = KU + 1 + DO 130 J = 1, N + DO 120 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( ITYPE.EQ.6 ) THEN +* +* Band matrix +* + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 150 J = 1, N + DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of DLASCL +* + END + SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASET initializes an m-by-n matrix A to BETA on the diagonal and +* ALPHA on the offdiagonals. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies the part of the matrix A to be set. +* = 'U': Upper triangular part is set; the strictly lower +* triangular part of A is not changed. +* = 'L': Lower triangular part is set; the strictly upper +* triangular part of A is not changed. +* Otherwise: All of the matrix A is set. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* ALPHA (input) DOUBLE PRECISION +* The constant to which the offdiagonal elements are to be set. +* +* BETA (input) DOUBLE PRECISION +* The constant to which the diagonal elements are to be set. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On exit, the leading m-by-n submatrix of A is set as follows: +* +* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, +* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, +* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, +* +* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Set the strictly upper triangular or trapezoidal part of the +* array to ALPHA. +* + DO 20 J = 2, N + DO 10 I = 1, MIN( J-1, M ) + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN +* +* Set the strictly lower triangular or trapezoidal part of the +* array to ALPHA. +* + DO 40 J = 1, MIN( M, N ) + DO 30 I = J + 1, M + A( I, J ) = ALPHA + 30 CONTINUE + 40 CONTINUE +* + ELSE +* +* Set the leading m-by-n submatrix to ALPHA. +* + DO 60 J = 1, N + DO 50 I = 1, M + A( I, J ) = ALPHA + 50 CONTINUE + 60 CONTINUE + END IF +* +* Set the first min(M,N) diagonal elements to BETA. +* + DO 70 I = 1, MIN( M, N ) + A( I, I ) = BETA + 70 CONTINUE +* + RETURN +* +* End of DLASET +* + END + SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, PIVOT, SIDE + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +* .. +* +* Purpose +* ======= +* +* DLASR applies a sequence of plane rotations to a real matrix A, +* from either the left or the right. +* +* When SIDE = 'L', the transformation takes the form +* +* A := P*A +* +* and when SIDE = 'R', the transformation takes the form +* +* A := A*P**T +* +* where P is an orthogonal matrix consisting of a sequence of z plane +* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', +* and P**T is the transpose of P. +* +* When DIRECT = 'F' (Forward sequence), then +* +* P = P(z-1) * ... * P(2) * P(1) +* +* and when DIRECT = 'B' (Backward sequence), then +* +* P = P(1) * P(2) * ... * P(z-1) +* +* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation +* +* R(k) = ( c(k) s(k) ) +* = ( -s(k) c(k) ). +* +* When PIVOT = 'V' (Variable pivot), the rotation is performed +* for the plane (k,k+1), i.e., P(k) has the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears as a rank-2 modification to the identity matrix in +* rows and columns k and k+1. +* +* When PIVOT = 'T' (Top pivot), the rotation is performed for the +* plane (1,k+1), so P(k) has the form +* +* P(k) = ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears in rows and columns 1 and k+1. +* +* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is +* performed for the plane (k,z), giving P(k) the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* +* where R(k) appears in rows and columns k and z. The rotations are +* performed without ever forming P(k) explicitly. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* Specifies whether the plane rotation matrix P is applied to +* A on the left or the right. +* = 'L': Left, compute A := P*A +* = 'R': Right, compute A:= A*P**T +* +* PIVOT (input) CHARACTER*1 +* Specifies the plane for which P(k) is a plane rotation +* matrix. +* = 'V': Variable pivot, the plane (k,k+1) +* = 'T': Top pivot, the plane (1,k+1) +* = 'B': Bottom pivot, the plane (k,z) +* +* DIRECT (input) CHARACTER*1 +* Specifies whether P is a forward or backward sequence of +* plane rotations. +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) +* +* M (input) INTEGER +* The number of rows of the matrix A. If m <= 1, an immediate +* return is effected. +* +* N (input) INTEGER +* The number of columns of the matrix A. If n <= 1, an +* immediate return is effected. +* +* C (input) DOUBLE PRECISION array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The cosines c(k) of the plane rotations. +* +* S (input) DOUBLE PRECISION array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The sines s(k) of the plane rotations. The 2-by-2 plane +* rotation part of the matrix P(k), R(k), has the form +* R(k) = ( c(k) s(k) ) +* ( -s(k) c(k) ). +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* The M-by-N matrix A. On exit, A is overwritten by P*A if +* SIDE = 'R' or by A*P**T if SIDE = 'L'. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION CTEMP, STEMP, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = 1 + ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, + $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN + INFO = 2 + ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) + $ THEN + INFO = 3 + ELSE IF( M.LT.0 ) THEN + INFO = 4 + ELSE IF( N.LT.0 ) THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = 9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASR ', INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form P * A +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 10 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 40 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 30 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 30 CONTINUE + END IF + 40 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 60 J = 2, M + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 50 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 80 J = M, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 70 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 70 CONTINUE + END IF + 80 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 100 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 90 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 120 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 110 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 110 CONTINUE + END IF + 120 CONTINUE + END IF + END IF + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form A * P**T +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 140 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 130 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 130 CONTINUE + END IF + 140 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 160 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 150 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 150 CONTINUE + END IF + 160 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 180 J = 2, N + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 170 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 200 J = N, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 190 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 190 CONTINUE + END IF + 200 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 220 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 210 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 210 CONTINUE + END IF + 220 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 240 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 230 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 230 CONTINUE + END IF + 240 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DLASR +* + END + SUBROUTINE DLASRT( ID, N, D, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER ID + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ) +* .. +* +* Purpose +* ======= +* +* Sort the numbers in D in increasing order (if ID = 'I') or +* in decreasing order (if ID = 'D' ). +* +* Use Quick Sort, reverting to Insertion sort on arrays of +* size <= 20. Dimension of STACK limits N to about 2**32. +* +* Arguments +* ========= +* +* ID (input) CHARACTER*1 +* = 'I': sort D in increasing order; +* = 'D': sort D in decreasing order. +* +* N (input) INTEGER +* The length of the array D. +* +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, the array to be sorted. +* On exit, D has been sorted into increasing order +* (D(1) <= ... <= D(N) ) or into decreasing order +* (D(1) >= ... >= D(N) ), depending on ID. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + INTEGER SELECT + PARAMETER ( SELECT = 20 ) +* .. +* .. Local Scalars .. + INTEGER DIR, ENDD, I, J, START, STKPNT + DOUBLE PRECISION D1, D2, D3, DMNMX, TMP +* .. +* .. Local Arrays .. + INTEGER STACK( 2, 32 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input paramters. +* + INFO = 0 + DIR = -1 + IF( LSAME( ID, 'D' ) ) THEN + DIR = 0 + ELSE IF( LSAME( ID, 'I' ) ) THEN + DIR = 1 + END IF + IF( DIR.EQ.-1 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASRT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + STKPNT = 1 + STACK( 1, 1 ) = 1 + STACK( 2, 1 ) = N + 10 CONTINUE + START = STACK( 1, STKPNT ) + ENDD = STACK( 2, STKPNT ) + STKPNT = STKPNT - 1 + IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN +* +* Do Insertion sort on D( START:ENDD ) +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + DO 30 I = START + 1, ENDD + DO 20 J = I, START + 1, -1 + IF( D( J ).GT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 30 + END IF + 20 CONTINUE + 30 CONTINUE +* + ELSE +* +* Sort into increasing order +* + DO 50 I = START + 1, ENDD + DO 40 J = I, START + 1, -1 + IF( D( J ).LT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE +* + END IF +* + ELSE IF( ENDD-START.GT.SELECT ) THEN +* +* Partition D( START:ENDD ) and stack parts, largest one first +* +* Choose partition entry as median of 3 +* + D1 = D( START ) + D2 = D( ENDD ) + I = ( START+ENDD ) / 2 + D3 = D( I ) + IF( D1.LT.D2 ) THEN + IF( D3.LT.D1 ) THEN + DMNMX = D1 + ELSE IF( D3.LT.D2 ) THEN + DMNMX = D3 + ELSE + DMNMX = D2 + END IF + ELSE + IF( D3.LT.D2 ) THEN + DMNMX = D2 + ELSE IF( D3.LT.D1 ) THEN + DMNMX = D3 + ELSE + DMNMX = D1 + END IF + END IF +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + I = START - 1 + J = ENDD + 1 + 60 CONTINUE + 70 CONTINUE + J = J - 1 + IF( D( J ).LT.DMNMX ) + $ GO TO 70 + 80 CONTINUE + I = I + 1 + IF( D( I ).GT.DMNMX ) + $ GO TO 80 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 60 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + ELSE +* +* Sort into increasing order +* + I = START - 1 + J = ENDD + 1 + 90 CONTINUE + 100 CONTINUE + J = J - 1 + IF( D( J ).GT.DMNMX ) + $ GO TO 100 + 110 CONTINUE + I = I + 1 + IF( D( I ).LT.DMNMX ) + $ GO TO 110 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 90 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + END IF + END IF + IF( STKPNT.GT.0 ) + $ GO TO 10 + RETURN +* +* End of DLASRT +* + END + SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLASSQ returns the values scl and smsq such that +* +* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, +* +* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is +* assumed to be non-negative and scl returns the value +* +* scl = max( scale, abs( x( i ) ) ). +* +* scale and sumsq must be supplied in SCALE and SUMSQ and +* scl and smsq are overwritten on SCALE and SUMSQ respectively. +* +* The routine makes only one pass through the vector x. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of elements to be used from the vector X. +* +* X (input) DOUBLE PRECISION array, dimension (N) +* The vector for which a scaled sum of squares is computed. +* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. +* +* INCX (input) INTEGER +* The increment between successive values of the vector X. +* INCX > 0. +* +* SCALE (input/output) DOUBLE PRECISION +* On entry, the value scale in the equation above. +* On exit, SCALE is overwritten with scl , the scaling factor +* for the sum of squares. +* +* SUMSQ (input/output) DOUBLE PRECISION +* On entry, the value sumsq in the equation above. +* On exit, SUMSQ is overwritten with smsq , the basic sum of +* squares from which scl has been factored out. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( X( IX ).NE.ZERO ) THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF + RETURN +* +* End of DLASSQ +* + END + SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK auxiliary routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* Purpose +* ======= +* +* DLATRD reduces NB rows and columns of a real symmetric matrix A to +* symmetric tridiagonal form by an orthogonal similarity +* transformation Q**T * A * Q, and returns the matrices V and W which are +* needed to apply the transformation to the unreduced part of A. +* +* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a +* matrix, of which the upper triangle is supplied; +* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a +* matrix, of which the lower triangle is supplied. +* +* This is an auxiliary routine called by DSYTRD. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. +* +* NB (input) INTEGER +* The number of rows and columns to be reduced. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n-by-n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n-by-n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* On exit: +* if UPLO = 'U', the last NB columns have been reduced to +* tridiagonal form, with the diagonal elements overwriting +* the diagonal elements of A; the elements above the diagonal +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors; +* if UPLO = 'L', the first NB columns have been reduced to +* tridiagonal form, with the diagonal elements overwriting +* the diagonal elements of A; the elements below the diagonal +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors. +* See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= (1,N). +* +* E (output) DOUBLE PRECISION array, dimension (N-1) +* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal +* elements of the last NB columns of the reduced matrix; +* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of +* the first NB columns of the reduced matrix. +* +* TAU (output) DOUBLE PRECISION array, dimension (N-1) +* The scalar factors of the elementary reflectors, stored in +* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. +* See Further Details. +* +* W (output) DOUBLE PRECISION array, dimension (LDW,NB) +* The n-by-nb matrix W required to update the unreduced part +* of A. +* +* LDW (input) INTEGER +* The leading dimension of the array W. LDW >= max(1,N). +* +* Further Details +* =============== +* +* If UPLO = 'U', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(n) H(n-1) . . . H(n-nb+1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), +* and tau in TAU(i-1). +* +* If UPLO = 'L', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(1) H(2) . . . H(nb). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), +* and tau in TAU(i). +* +* The elements of the vectors v together form the n-by-nb matrix V +* which is needed, with W, to apply the transformation to the unreduced +* part of the matrix, using a symmetric rank-2k update of the form: +* A := A - V*W**T - W*V**T. +* +* The contents of A on exit are illustrated by the following examples +* with n = 5 and nb = 2: +* +* if UPLO = 'U': if UPLO = 'L': +* +* ( a a a v4 v5 ) ( d ) +* ( a a v4 v5 ) ( 1 d ) +* ( a 1 v5 ) ( v1 1 a ) +* ( d 1 ) ( v1 v2 a a ) +* ( d ) ( v1 v2 a a a ) +* +* where d denotes a diagonal element of the reduced matrix, a denotes +* an element of the original matrix that is unchanged, and vi denotes +* an element of the vector defining H(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IW + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Reduce last NB columns of upper triangle +* + DO 10 I = N, N - NB + 1, -1 + IW = I - N + NB + IF( I.LT.N ) THEN +* +* Update A(1:i,i) +* + CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), + $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) + CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), + $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) + END IF + IF( I.GT.1 ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(1:i-2,i) +* + CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) + E( I-1 ) = A( I-1, I ) + A( I-1, I ) = ONE +* +* Compute W(1:i-1,i) +* + CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, + $ ZERO, W( 1, IW ), 1 ) + IF( I.LT.N ) THEN + CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), + $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, + $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, + $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + END IF + CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) + ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, + $ A( 1, I ), 1 ) + CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) + END IF +* + 10 CONTINUE + ELSE +* +* Reduce first NB columns of lower triangle +* + DO 20 I = 1, NB +* +* Update A(i:n,i) +* + CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), + $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) + CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), + $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) + IF( I.LT.N ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* Compute W(i+1:n,i) +* + CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), + $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) + ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, + $ A( I+1, I ), 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) + END IF +* + 20 CONTINUE + END IF +* + RETURN +* +* End of DLATRD +* + END + SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORG2L generates an m by n real matrix Q with orthonormal columns, +* which is defined as the last n columns of a product of k elementary +* reflectors of order m +* +* Q = H(k) . . . H(2) H(1) +* +* as returned by DGEQLF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the (n-k+i)-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQLF in the last k columns of its array +* argument A. +* On exit, the m by n matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQLF. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns 1:n-k to columns of the unit matrix +* + DO 20 J = 1, N - K + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( M-N+J, J ) = ONE + 20 CONTINUE +* + DO 40 I = 1, K + II = N - K + I +* +* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left +* + A( M-N+II, II ) = ONE + CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, + $ LDA, WORK ) + CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) +* +* Set A(m-k+i+1:m,n-k+i) to zero +* + DO 30 L = M - N + II + 1, M + A( L, II ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2L +* + END + SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORG2R generates an m by n real matrix Q with orthonormal columns, +* which is defined as the first n columns of a product of k elementary +* reflectors of order m +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the i-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQRF in the first k columns of its array +* argument A. +* On exit, the m-by-n matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2R +* + END + SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORGQL generates an M-by-N real matrix Q with orthonormal columns, +* which is defined as the last N columns of a product of K elementary +* reflectors of order M +* +* Q = H(k) . . . H(2) H(1) +* +* as returned by DGEQLF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the (n-k+i)-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQLF in the last k columns of its array +* argument A. +* On exit, the M-by-N matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQLF. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, + $ NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQL', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the first block. +* The last kk columns are handled by the block method. +* + KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) +* +* Set A(m-kk+1:m,1:n-kk) to zero. +* + DO 20 J = 1, N - KK + DO 10 I = M - KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the first or only block. +* + CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = K - KK + 1, K, NB + IB = MIN( NB, K-I+1 ) + IF( N-K+I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, + $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Backward', + $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, + $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, + $ WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows 1:m-k+i+ib-1 of current block +* + CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, + $ TAU( I ), WORK, IINFO ) +* +* Set rows m-k+i+ib:m of current block to zero +* + DO 40 J = N - K + I, N - K + I + IB - 1 + DO 30 L = M - K + I + IB, M + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQL +* + END + SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORGQR generates an M-by-N real matrix Q with orthonormal columns, +* which is defined as the first N columns of a product of K elementary +* reflectors of order M +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the i-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQRF in the first k columns of its array +* argument A. +* On exit, the M-by-N matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQR +* + END + SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORGTR generates a real orthogonal matrix Q which is defined as the +* product of n-1 elementary reflectors of order N, as returned by +* DSYTRD: +* +* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), +* +* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A contains elementary reflectors +* from DSYTRD; +* = 'L': Lower triangle of A contains elementary reflectors +* from DSYTRD. +* +* N (input) INTEGER +* The order of the matrix Q. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the vectors which define the elementary reflectors, +* as returned by DSYTRD. +* On exit, the N-by-N orthogonal matrix Q. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (N-1) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DSYTRD. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N-1). +* For optimum performance LWORK >= (N-1)*NB, where NB is +* the optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, J, LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORGQL, DORGQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( UPPER ) THEN + NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) + ELSE + NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) + END IF + LWKOPT = MAX( 1, N-1 )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGTR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( UPPER ) THEN +* +* Q was determined by a call to DSYTRD with UPLO = 'U' +* +* Shift the vectors which define the elementary reflectors one +* column to the left, and set the last row and column of Q to +* those of the unit matrix +* + DO 20 J = 1, N - 1 + DO 10 I = 1, J - 1 + A( I, J ) = A( I, J+1 ) + 10 CONTINUE + A( N, J ) = ZERO + 20 CONTINUE + DO 30 I = 1, N - 1 + A( I, N ) = ZERO + 30 CONTINUE + A( N, N ) = ONE +* +* Generate Q(1:n-1,1:n-1) +* + CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) +* + ELSE +* +* Q was determined by a call to DSYTRD with UPLO = 'L'. +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first row and column of Q to +* those of the unit matrix +* + DO 50 J = N, 2, -1 + A( 1, J ) = ZERO + DO 40 I = J + 1, N + A( I, J ) = A( I, J-1 ) + 40 CONTINUE + 50 CONTINUE + A( 1, 1 ) = ONE + DO 60 I = 2, N + A( I, 1 ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Generate Q(2:n,2:n) +* + CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGTR +* + END + SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a +* symmetric tridiagonal matrix using the implicit QL or QR method. +* The eigenvectors of a full or band symmetric matrix can also be found +* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to +* tridiagonal form. +* +* Arguments +* ========= +* +* COMPZ (input) CHARACTER*1 +* = 'N': Compute eigenvalues only. +* = 'V': Compute eigenvalues and eigenvectors of the original +* symmetric matrix. On entry, Z must contain the +* orthogonal matrix used to reduce the original matrix +* to tridiagonal form. +* = 'I': Compute eigenvalues and eigenvectors of the +* tridiagonal matrix. Z is initialized to the identity +* matrix. +* +* N (input) INTEGER +* The order of the matrix. N >= 0. +* +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, the diagonal elements of the tridiagonal matrix. +* On exit, if INFO = 0, the eigenvalues in ascending order. +* +* E (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, the (n-1) subdiagonal elements of the tridiagonal +* matrix. +* On exit, E has been destroyed. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) +* On entry, if COMPZ = 'V', then Z contains the orthogonal +* matrix used in the reduction to tridiagonal form. +* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the +* orthonormal eigenvectors of the original symmetric matrix, +* and if COMPZ = 'I', Z contains the orthonormal eigenvectors +* of the symmetric tridiagonal matrix. +* If COMPZ = 'N', then Z is not referenced. +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. LDZ >= 1, and if +* eigenvectors are desired, then LDZ >= max(1,N). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) +* If COMPZ = 'N', then WORK is not referenced. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: the algorithm has failed to find all the eigenvalues in +* a total of 30*N iterations; if INFO = i, then i +* elements of E have not converged to zero; on exit, D +* and E contain the elements of a symmetric tridiagonal +* matrix which is orthogonally similar to the original +* matrix. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, + $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, + $ NM1, NMAXIT + DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, + $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 + EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, + $ DLASRT, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ICOMPZ = 0 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ICOMPZ = 2 + ELSE + ICOMPZ = -1 + END IF + IF( ICOMPZ.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, + $ N ) ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEQR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ICOMPZ.EQ.2 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Determine the unit roundoff and over/underflow thresholds. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues and eigenvectors of the tridiagonal +* matrix. +* + IF( ICOMPZ.EQ.2 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* + NMAXIT = N*MAXIT + JTOT = 0 +* +* Determine where the matrix splits and choose QL or QR iteration +* for each block, according to whether top or bottom diagonal +* element is smaller. +* + L1 = 1 + NM1 = N - 1 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 160 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 20 M = L1, NM1 + TST = ABS( E( M ) ) + IF( TST.EQ.ZERO ) + $ GO TO 30 + IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + END IF + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) + ISCALE = 0 + IF( ANORM.EQ.ZERO ) + $ GO TO 10 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* +* Choose between QL and QR iteration +* + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF +* + IF( LEND.GT.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 40 CONTINUE + IF( L.NE.LEND ) THEN + LENDM1 = LEND - 1 + DO 50 M = L, LENDM1 + TST = ABS( E( M ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ + $ SAFMIN )GO TO 60 + 50 CONTINUE + END IF +* + M = LEND +* + 60 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 80 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L+1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) + WORK( L ) = C + WORK( N-1+L ) = S + CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), + $ WORK( N-1+L ), Z( 1, L ), LDZ ) + ELSE + CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) + END IF + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L+1 )-P ) / ( TWO*E( L ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + MM1 = M - 1 + DO 70 I = MM1, L, -1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M-1 ) + $ E( I+1 ) = R + G = D( I+1 ) - P + R = ( D( I )-G )*S + TWO*C*B + P = S*R + D( I+1 ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = -S + END IF +* + 70 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = M - L + 1 + CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), + $ Z( 1, L ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( L ) = G + GO TO 40 +* +* Eigenvalue found. +* + 80 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 90 CONTINUE + IF( L.NE.LEND ) THEN + LENDP1 = LEND + 1 + DO 100 M = L, LENDP1, -1 + TST = ABS( E( M-1 ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ + $ SAFMIN )GO TO 110 + 100 CONTINUE + END IF +* + M = LEND +* + 110 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 130 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L-1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) + WORK( M ) = C + WORK( N-1+M ) = S + CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), + $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) + ELSE + CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) + END IF + D( L-1 ) = RT1 + D( L ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + LM1 = L - 1 + DO 120 I = M, LM1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M ) + $ E( I-1 ) = R + G = D( I ) - P + R = ( D( I+1 )-G )*S + TWO*C*B + P = S*R + D( I ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = S + END IF +* + 120 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = L - M + 1 + CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), + $ Z( 1, M ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( LM1 ) = G + GO TO 90 +* +* Eigenvalue found. +* + 130 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 +* + END IF +* +* Undo scaling if necessary +* + 140 CONTINUE + IF( ISCALE.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + ELSE IF( ISCALE.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + END IF +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 150 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 150 CONTINUE + GO TO 190 +* +* Order eigenvalues and eigenvectors. +* + 160 CONTINUE + IF( ICOMPZ.EQ.0 ) THEN +* +* Use Quick Sort +* + CALL DLASRT( 'I', N, D, INFO ) +* + ELSE +* +* Use Selection Sort to minimize swaps of eigenvectors +* + DO 180 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 170 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 170 CONTINUE + IF( K.NE.I ) THEN + D( K ) = D( I ) + D( I ) = P + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) + END IF + 180 CONTINUE + END IF +* + 190 CONTINUE + RETURN +* +* End of DSTEQR +* + END + SUBROUTINE DSTERF( N, D, E, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* Purpose +* ======= +* +* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix +* using the Pal-Walker-Kahan variant of the QL or QR algorithm. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix. N >= 0. +* +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, the n diagonal elements of the tridiagonal matrix. +* On exit, if INFO = 0, the eigenvalues in ascending order. +* +* E (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, the (n-1) subdiagonal elements of the tridiagonal +* matrix. +* On exit, E has been destroyed. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: the algorithm failed to find all of the eigenvalues in +* a total of 30*N iterations; if INFO = i, then i +* elements of E have not converged to zero. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, + $ NMAXIT + DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, + $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, + $ SIGMA, SSFMAX, SSFMIN, RMAX +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 + EXTERNAL DLAMCH, DLANST, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DSTERF', -INFO ) + RETURN + END IF + IF( N.LE.1 ) + $ RETURN +* +* Determine the unit roundoff for this environment. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 + RMAX = DLAMCH( 'O' ) +* +* Compute the eigenvalues of the tridiagonal matrix. +* + NMAXIT = N*MAXIT + SIGMA = ZERO + JTOT = 0 +* +* Determine where the matrix splits and choose QL or QR iteration +* for each block, according to whether top or bottom diagonal +* element is smaller. +* + L1 = 1 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 170 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + DO 20 M = L1, N - 1 + IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) + ISCALE = 0 + IF( ANORM.EQ.ZERO ) + $ GO TO 10 + IF( (ANORM.GT.SSFMAX) ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* + DO 40 I = L, LEND - 1 + E( I ) = E( I )**2 + 40 CONTINUE +* +* Choose between QL and QR iteration +* + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF +* + IF( LEND.GE.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 50 CONTINUE + IF( L.NE.LEND ) THEN + DO 60 M = L, LEND - 1 + IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) + $ GO TO 70 + 60 CONTINUE + END IF + M = LEND +* + 70 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 90 +* +* If remaining matrix is 2 by 2, use DLAE2 to compute its +* eigenvalues. +* + IF( M.EQ.L+1 ) THEN + RTE = SQRT( E( L ) ) + CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 150 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* Form shift. +* + RTE = SQRT( E( L ) ) + SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* Inner loop +* + DO 80 I = M - 1, L, -1 + BB = E( I ) + R = P + BB + IF( I.NE.M-1 ) + $ E( I+1 ) = S*R + OLDC = C + C = P / R + S = BB / R + OLDGAM = GAMMA + ALPHA = D( I ) + GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM + D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) + IF( C.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 80 CONTINUE +* + E( L ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 50 +* +* Eigenvalue found. +* + 90 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 150 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 100 CONTINUE + DO 110 M = L, LEND + 1, -1 + IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) + $ GO TO 120 + 110 CONTINUE + M = LEND +* + 120 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 140 +* +* If remaining matrix is 2 by 2, use DLAE2 to compute its +* eigenvalues. +* + IF( M.EQ.L-1 ) THEN + RTE = SQRT( E( L-1 ) ) + CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) + D( L ) = RT1 + D( L-1 ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 150 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* Form shift. +* + RTE = SQRT( E( L-1 ) ) + SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* Inner loop +* + DO 130 I = M, L - 1 + BB = E( I ) + R = P + BB + IF( I.NE.M ) + $ E( I-1 ) = S*R + OLDC = C + C = P / R + S = BB / R + OLDGAM = GAMMA + ALPHA = D( I+1 ) + GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM + D( I ) = OLDGAM + ( ALPHA-GAMMA ) + IF( C.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 130 CONTINUE +* + E( L-1 ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 100 +* +* Eigenvalue found. +* + 140 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 150 +* + END IF +* +* Undo scaling if necessary +* + 150 CONTINUE + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + IF( ISCALE.EQ.2 ) + $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 160 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 160 CONTINUE + GO TO 180 +* +* Sort eigenvalues in increasing order. +* + 170 CONTINUE + CALL DLASRT( 'I', N, D, INFO ) +* + 180 CONTINUE + RETURN +* +* End of DSTERF +* + END + SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DSYEV computes all eigenvalues and, optionally, eigenvectors of a +* real symmetric matrix A. +* +* Arguments +* ========= +* +* JOBZ (input) CHARACTER*1 +* = 'N': Compute eigenvalues only; +* = 'V': Compute eigenvalues and eigenvectors. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) +* On entry, the symmetric matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of A contains the +* upper triangular part of the matrix A. If UPLO = 'L', +* the leading N-by-N lower triangular part of A contains +* the lower triangular part of the matrix A. +* On exit, if JOBZ = 'V', then if INFO = 0, A contains the +* orthonormal eigenvectors of the matrix A. +* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +* or the upper triangle (if UPLO='U') of A, including the +* diagonal, is destroyed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* W (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, the eigenvalues in ascending order. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The length of the array WORK. LWORK >= max(1,3*N-1). +* For optimal efficiency, LWORK >= (NB+2)*N, +* where NB is the blocksize for DSYTRD returned by ILAENV. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the algorithm failed to converge; i +* off-diagonal elements of an intermediate tridiagonal +* form did not converge to zero. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWKOPT, NB + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, ( NB+2 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + WORK( 1 ) = 2 + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call DSYTRD to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDWRK = INDTAU + N + LLWORK = LWORK - INDWRK + 1 + CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* DORGTR to generate the orthogonal matrix, then call DSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYEV +* + END + SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) +* .. +* +* Purpose +* ======= +* +* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal +* form T by an orthogonal similarity transformation: Q**T * A * Q = T. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n-by-n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n-by-n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* On exit, if UPLO = 'U', the diagonal and first superdiagonal +* of A are overwritten by the corresponding elements of the +* tridiagonal matrix T, and the elements above the first +* superdiagonal, with the array TAU, represent the orthogonal +* matrix Q as a product of elementary reflectors; if UPLO +* = 'L', the diagonal and first subdiagonal of A are over- +* written by the corresponding elements of the tridiagonal +* matrix T, and the elements below the first subdiagonal, with +* the array TAU, represent the orthogonal matrix Q as a product +* of elementary reflectors. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* D (output) DOUBLE PRECISION array, dimension (N) +* The diagonal elements of the tridiagonal matrix T: +* D(i) = A(i,i). +* +* E (output) DOUBLE PRECISION array, dimension (N-1) +* The off-diagonal elements of the tridiagonal matrix T: +* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +* +* TAU (output) DOUBLE PRECISION array, dimension (N-1) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value. +* +* Further Details +* =============== +* +* If UPLO = 'U', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(n-1) . . . H(2) H(1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +* A(1:i-1,i+1), and tau in TAU(i). +* +* If UPLO = 'L', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(1) H(2) . . . H(n-1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +* and tau in TAU(i). +* +* The contents of A on exit are illustrated by the following examples +* with n = 5: +* +* if UPLO = 'U': if UPLO = 'L': +* +* ( d e v2 v3 v4 ) ( d ) +* ( d e v3 v4 ) ( e d ) +* ( d e v4 ) ( v1 e d ) +* ( d e ) ( v1 v2 e d ) +* ( d ) ( v1 v2 v3 e d ) +* +* where d and e denote diagonal and off-diagonal elements of T, and vi +* denotes an element of the vector defining H(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, + $ HALF = 1.0D0 / 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION ALPHA, TAUI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTD2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A +* + DO 10 I = N - 1, 1, -1 +* +* Generate elementary reflector H(i) = I - tau * v * v**T +* to annihilate A(1:i-1,i+1) +* + CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) + E( I ) = A( I, I+1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(1:i,1:i) +* + A( I, I+1 ) = ONE +* +* Compute x := tau * A * v storing x in TAU(1:i) +* + CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, + $ TAU, 1 ) +* +* Compute w := x - 1/2 * tau * (x**T * v) * v +* + ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) + CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w**T - w * v**T +* + CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, + $ LDA ) +* + A( I, I+1 ) = E( I ) + END IF + D( I+1 ) = A( I+1, I+1 ) + TAU( I ) = TAUI + 10 CONTINUE + D( 1 ) = A( 1, 1 ) + ELSE +* +* Reduce the lower triangle of A +* + DO 20 I = 1, N - 1 +* +* Generate elementary reflector H(i) = I - tau * v * v**T +* to annihilate A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAUI ) + E( I ) = A( I+1, I ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(i+1:n,i+1:n) +* + A( I+1, I ) = ONE +* +* Compute x := tau * A * v storing y in TAU(i:n-1) +* + CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) +* +* Compute w := x - 1/2 * tau * (x**T * v) * v +* + ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), + $ 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w**T - w * v**T +* + CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, + $ A( I+1, I+1 ), LDA ) +* + A( I+1, I ) = E( I ) + END IF + D( I ) = A( I, I ) + TAU( I ) = TAUI + 20 CONTINUE + D( N ) = A( N, N ) + END IF +* + RETURN +* +* End of DSYTD2 +* + END + SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.3.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- April 2011 -- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), + $ WORK( * ) +* .. +* +* Purpose +* ======= +* +* DSYTRD reduces a real symmetric matrix A to real symmetric +* tridiagonal form T by an orthogonal similarity transformation: +* Q**T * A * Q = T. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* On exit, if UPLO = 'U', the diagonal and first superdiagonal +* of A are overwritten by the corresponding elements of the +* tridiagonal matrix T, and the elements above the first +* superdiagonal, with the array TAU, represent the orthogonal +* matrix Q as a product of elementary reflectors; if UPLO +* = 'L', the diagonal and first subdiagonal of A are over- +* written by the corresponding elements of the tridiagonal +* matrix T, and the elements below the first subdiagonal, with +* the array TAU, represent the orthogonal matrix Q as a product +* of elementary reflectors. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* D (output) DOUBLE PRECISION array, dimension (N) +* The diagonal elements of the tridiagonal matrix T: +* D(i) = A(i,i). +* +* E (output) DOUBLE PRECISION array, dimension (N-1) +* The off-diagonal elements of the tridiagonal matrix T: +* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +* +* TAU (output) DOUBLE PRECISION array, dimension (N-1) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 1. +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* If UPLO = 'U', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(n-1) . . . H(2) H(1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +* A(1:i-1,i+1), and tau in TAU(i). +* +* If UPLO = 'L', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(1) H(2) . . . H(n-1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v**T +* +* where tau is a real scalar, and v is a real vector with +* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +* and tau in TAU(i). +* +* The contents of A on exit are illustrated by the following examples +* with n = 5: +* +* if UPLO = 'U': if UPLO = 'L': +* +* ( d e v2 v3 v4 ) ( d ) +* ( d e v3 v4 ) ( e d ) +* ( d e v4 ) ( v1 e d ) +* ( d e ) ( v1 v2 e d ) +* ( d ) ( v1 v2 v3 e d ) +* +* where d and e denote diagonal and off-diagonal elements of T, and vi +* denotes an element of the vector defining H(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .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 = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NX = N + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.N ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code). +* + NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) + IF( NX.LT.N ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code by setting NX = N. +* + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) + IF( NB.LT.NBMIN ) + $ NX = N + END IF + ELSE + NX = N + END IF + ELSE + NB = 1 + END IF +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A. +* Columns 1:kk are handled by the unblocked method. +* + KK = N - ( ( N-NX+NB-1 ) / NB )*NB + DO 20 I = N - NB + 1, KK + 1, -NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, + $ LDWORK ) +* +* Update the unreduced submatrix A(1:i-1,1:i-1), using an +* update of the form: A := A - V*W**T - W*V**T +* + CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), + $ LDA, WORK, LDWORK, ONE, A, LDA ) +* +* Copy superdiagonal elements back into A, and diagonal +* elements into D +* + DO 10 J = I, I + NB - 1 + A( J-1, J ) = E( J-1 ) + D( J ) = A( J, J ) + 10 CONTINUE + 20 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) + ELSE +* +* Reduce the lower triangle of A +* + DO 40 I = 1, N - NX, NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), + $ TAU( I ), WORK, LDWORK ) +* +* Update the unreduced submatrix A(i+ib:n,i+ib:n), using +* an update of the form: A := A - V*W**T - W*V**T +* + CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, + $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, + $ A( I+NB, I+NB ), LDA ) +* +* Copy subdiagonal elements back into A, and diagonal +* elements into D +* + DO 30 J = I, I + NB - 1 + A( J+1, J ) = E( J ) + D( J ) = A( J, J ) + 30 CONTINUE + 40 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), + $ TAU( I ), IINFO ) + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYTRD +* + END +*> \brief \b DLAMCH +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAMCH determines double precision machine parameters. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CMACH +*> \verbatim +*> Specifies the value to be returned by DLAMCH: +*> = 'E' or 'e', DLAMCH := eps +*> = 'S' or 's , DLAMCH := sfmin +*> = 'B' or 'b', DLAMCH := base +*> = 'P' or 'p', DLAMCH := eps*base +*> = 'N' or 'n', DLAMCH := t +*> = 'R' or 'r', DLAMCH := rnd +*> = 'M' or 'm', DLAMCH := emin +*> = 'U' or 'u', DLAMCH := rmin +*> = 'L' or 'l', DLAMCH := emax +*> = 'O' or 'o', DLAMCH := rmax +*> where +*> eps = relative machine precision +*> sfmin = safe minimum, such that 1/sfmin does not overflow +*> base = base of the machine +*> prec = eps*base +*> t = number of (base) digits in the mantissa +*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +*> emin = minimum exponent before (gradual) underflow +*> rmin = underflow threshold - base**(emin-1) +*> emax = largest exponent before overflow +*> rmax = overflow threshold - (base**emax)*(1-eps) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, + $ MINEXPONENT, RADIX, TINY +* .. +* .. Executable Statements .. +* +* +* Assume rounding, not chopping. Always. +* + RND = ONE +* + IF( ONE.EQ.RND ) THEN + EPS = EPSILON(ZERO) * 0.5 + ELSE + EPS = EPSILON(ZERO) + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + SFMIN = TINY(ZERO) + SMALL = ONE / HUGE(ZERO) + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = EPS * RADIX(ZERO) + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = DIGITS(ZERO) + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = MINEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = tiny(zero) + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = MAXEXPONENT(ZERO) + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = HUGE(ZERO) + ELSE + RMACH = ZERO + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +************************************************************************ +*> \brief \b DLAMC3 +*> \details +*> \b Purpose: +*> \verbatim +*> DLAMC3 is intended to force A and B to be stored prior to doing +*> the addition of A and B , for use in situations where optimizers +*> might hold one of these in a register. +*> \endverbatim +*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +*> \date November 2015 +*> \ingroup auxOTHERauxiliary +*> +*> \param[in] A +*> \verbatim +*> A is a DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is a DOUBLE PRECISION +*> The values A and B. +*> \endverbatim +*> + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2010 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ +*> \brief \b IEEECK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IEEECK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* .. Scalar Arguments .. +* INTEGER ISPEC +* REAL ONE, ZERO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IEEECK is called from the ILAENV to verify that Infinity and +*> possibly NaN arithmetic is safe (i.e. will not trap). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies whether to test just for inifinity arithmetic +*> or whether to test for infinity and NaN arithmetic. +*> = 0: Verify infinity arithmetic only. +*> = 1: Verify infinity and NaN arithmetic. +*> \endverbatim +*> +*> \param[in] ZERO +*> \verbatim +*> ZERO is REAL +*> Must contain the value 0.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> \endverbatim +*> +*> \param[in] ONE +*> \verbatim +*> ONE is REAL +*> Must contain the value 1.0 +*> This is passed to prevent the compiler from optimizing +*> away this code. +*> +*> RETURN VALUE: INTEGER +*> = 0: Arithmetic failed to produce the correct answers +*> = 1: Arithmetic produced the correct answers +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*ZERO +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END +*> \brief \b ILADLC scans a matrix for its last non-zero column. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILADLC + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILADLC( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILADLC scans A for its last non-zero column. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILADLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILADLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILADLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILADLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END +*> \brief \b ILADLR scans a matrix for its last non-zero row. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILADLR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILADLR( M, N, A, LDA ) +* +* .. Scalar Arguments .. +* INTEGER M, N, LDA +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILADLR scans A for its last non-zero row. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The m by n matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date September 2012 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + INTEGER FUNCTION ILADLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* September 2012 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILADLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILADLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILADLR = 0 + DO J = 1, N + I=M + DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) + I=I-1 + ENDDO + ILADLR = MAX( ILADLR, I ) + END DO + END IF + RETURN + END +*> \brief \b ILAENV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ILAENV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* .. Scalar Arguments .. +* CHARACTER*( * ) NAME, OPTS +* INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ILAENV is called from the LAPACK routines to choose problem-dependent +*> parameters for the local environment. See ISPEC for a description of +*> the parameters. +*> +*> ILAENV returns an INTEGER +*> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC +*> if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. +*> +*> This version provides a set of parameters which should give good, +*> but not optimal, performance on many of the currently available +*> computers. Users are encouraged to modify this subroutine to set +*> the tuning parameters for their particular machine using the option +*> and problem size information in the arguments. +*> +*> This routine will not function correctly if it is converted to all +*> lower case. Converting it to all upper case is allowed. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is INTEGER +*> Specifies the parameter to be returned as the value of +*> ILAENV. +*> = 1: the optimal blocksize; if this value is 1, an unblocked +*> algorithm will give the best performance. +*> = 2: the minimum block size for which the block routine +*> should be used; if the usable block size is less than +*> this value, an unblocked routine should be used. +*> = 3: the crossover point (in a block routine, for N less +*> than this value, an unblocked routine should be used) +*> = 4: the number of shifts, used in the nonsymmetric +*> eigenvalue routines (DEPRECATED) +*> = 5: the minimum column dimension for blocking to be used; +*> rectangular blocks must have dimension at least k by m, +*> where k is given by ILAENV(2,...) and m by ILAENV(5,...) +*> = 6: the crossover point for the SVD (when reducing an m by n +*> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +*> this value, a QR factorization is used first to reduce +*> the matrix to a triangular form.) +*> = 7: the number of processors +*> = 8: the crossover point for the multishift QR method +*> for nonsymmetric eigenvalue problems (DEPRECATED) +*> = 9: maximum size of the subproblems at the bottom of the +*> computation tree in the divide-and-conquer algorithm +*> (used by xGELSD and xGESDD) +*> =10: ieee NaN arithmetic can be trusted not to trap +*> =11: infinity arithmetic can be trusted not to trap +*> 12 <= ISPEC <= 16: +*> xHSEQR or related subroutines, +*> see IPARMQ for detailed explanation +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is CHARACTER*(*) +*> The name of the calling subroutine, in either upper case or +*> lower case. +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is CHARACTER*(*) +*> The character options to the subroutine NAME, concatenated +*> into a single character string. For example, UPLO = 'U', +*> TRANS = 'T', and DIAG = 'N' for a triangular routine would +*> be specified as OPTS = 'UTN'. +*> \endverbatim +*> +*> \param[in] N1 +*> \verbatim +*> N1 is INTEGER +*> \endverbatim +*> +*> \param[in] N2 +*> \verbatim +*> N2 is INTEGER +*> \endverbatim +*> +*> \param[in] N3 +*> \verbatim +*> N3 is INTEGER +*> \endverbatim +*> +*> \param[in] N4 +*> \verbatim +*> N4 is INTEGER +*> Problem dimensions for the subroutine NAME; these may not all +*> be required. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date June 2016 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The following conventions have been used when calling ILAENV from the +*> LAPACK routines: +*> 1) OPTS is a concatenation of all of the character options to +*> subroutine NAME, in the same order that they appear in the +*> argument list for NAME, even if they are not used in determining +*> the value of the parameter specified by ISPEC. +*> 2) The problem dimensions N1, N2, N3, N4 are specified in the order +*> that they appear in the argument list for NAME. N1 is used +*> first, N2 second, and so on, and unused problem dimensions are +*> passed a value of -1. +*> 3) The parameter value returned by ILAENV is checked for validity in +*> the calling subroutine. For example, ILAENV is used to retrieve +*> the optimal blocksize for STRTRI as follows: +*> +*> NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +*> IF( NB.LE.1 ) NB = MAX( 1, N ) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.6.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* June 2016 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF ( C3.EQ.'EVC' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NB = 32 + IF( C3.EQ.'HD3' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NBMIN = 2 + IF( C3.EQ.'HD3' ) THEN + NBMIN = 2 + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'GG' ) THEN + NX = 128 + IF( C3.EQ.'HD3' ) THEN + NX = 128 + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or related subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END +*> \brief \b IPARMQ +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download IPARMQ + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, ISPEC, LWORK, N +* CHARACTER NAME*( * ), OPTS*( * ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> This program sets problem and machine dependent parameters +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever +*> IPARMQ is called with 12 <= ISPEC <= 16 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ISPEC +*> \verbatim +*> ISPEC is integer scalar +*> ISPEC specifies which tunable parameter IPARMQ should +*> return. +*> +*> ISPEC=12: (INMIN) Matrices of order nmin or less +*> are sent directly to xLAHQR, the implicit +*> double shift QR algorithm. NMIN must be +*> at least 11. +*> +*> ISPEC=13: (INWIN) Size of the deflation window. +*> This is best set greater than or equal to +*> the number of simultaneous shifts NS. +*> Larger matrices benefit from larger deflation +*> windows. +*> +*> ISPEC=14: (INIBL) Determines when to stop nibbling and +*> invest in an (expensive) multi-shift QR sweep. +*> If the aggressive early deflation subroutine +*> finds LD converged eigenvalues from an order +*> NW deflation window and LD.GT.(NW*NIBBLE)/100, +*> then the next QR sweep is skipped and early +*> deflation is applied immediately to the +*> remaining active diagonal block. Setting +*> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +*> multi-shift QR sweep whenever early deflation +*> finds a converged eigenvalue. Setting +*> IPARMQ(ISPEC=14) greater than or equal to 100 +*> prevents TTQRE from skipping a multi-shift +*> QR sweep. +*> +*> ISPEC=15: (NSHFTS) The number of simultaneous shifts in +*> a multi-shift QR iteration. +*> +*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +*> following meanings. +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the +*> far-from-diagonal matrix entries. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. +*> (If xTRMM is slower than xGEMM, then +*> IPARMQ(ISPEC=16)=1 may be more efficient than +*> IPARMQ(ISPEC=16)=2 despite the greater level of +*> arithmetic work implied by the latter choice.) +*> \endverbatim +*> +*> \param[in] NAME +*> \verbatim +*> NAME is character string +*> Name of the calling subroutine +*> \endverbatim +*> +*> \param[in] OPTS +*> \verbatim +*> OPTS is character string +*> This is a concatenation of the string arguments to +*> TTQRE. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is integer scalar +*> N is the order of the Hessenberg matrix H. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> It is assumed that H is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is integer scalar +*> The amount of workspace available. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2015 +* +*> \ingroup auxOTHERauxiliary +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Little is known about how best to choose these parameters. +*> It is possible to use different values of the parameters +*> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +*> +*> It is probably best to choose different parameters for +*> different matrices and different parameters at different +*> times during the iteration, but this has not been +*> implemented --- yet. +*> +*> +*> The best choices of most of the parameters depend +*> in an ill-understood way on the relative execution +*> rate of xLAQR3 and xLAQR5 and on the nature of each +*> particular eigenvalue problem. Experiment may be the +*> only practical way to determine which choices are most +*> effective. +*> +*> Following is a list of default values supplied by IPARMQ. +*> These defaults may be adjusted in order to attain better +*> performance in any particular computational environment. +*> +*> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +*> Default: 75. (Must be at least 11.) +*> +*> IPARMQ(ISPEC=13) Recommended deflation window size. +*> This depends on ILO, IHI and NS, the +*> number of simultaneous shifts returned +*> by IPARMQ(ISPEC=15). The default for +*> (IHI-ILO+1).LE.500 is NS. The default +*> for (IHI-ILO+1).GT.500 is 3*NS/2. +*> +*> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +*> +*> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +*> a multi-shift QR iteration. +*> +*> If IHI-ILO+1 is ... +*> +*> greater than ...but less ... the +*> or equal to ... than default is +*> +*> 0 30 NS = 2+ +*> 30 60 NS = 4+ +*> 60 150 NS = 10 +*> 150 590 NS = ** +*> 590 3000 NS = 64 +*> 3000 6000 NS = 128 +*> 6000 infinity NS = 256 +*> +*> (+) By default matrices of this order are +*> passed to the implicit double shift routine +*> xLAHQR. See IPARMQ(ISPEC=12) above. These +*> values of NS are used only in case of a rare +*> xLAHQR failure. +*> +*> (**) The asterisks (**) indicate an ad-hoc +*> function increasing from 10 to 64. +*> +*> IPARMQ(ISPEC=16) Select structured matrix multiply. +*> (See ISPEC=16 above for details.) +*> Default: 3. +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2015 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* +* +* Convert NAME to upper case if the first character is lower case. +* + IPARMQ = 0 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + END DO + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF + END IF +* + IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. + $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN + IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN + IF( NH.GE.KACMIN ) + $ IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. + $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + END IF +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME( CA, CB ) +* +* .. Scalar Arguments .. +* CHARACTER CA, CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA.EQ.CB + IF( LSAME ) + $ RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR( 'Z' ) +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR( CA ) + INTB = ICHAR( CB ) +* + IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 + IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 +* + ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.129 .AND. INTA.LE.137 .OR. + $ INTA.GE.145 .AND. INTA.LE.153 .OR. + $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 + IF( INTB.GE.129 .AND. INTB.LE.137 .OR. + $ INTB.GE.145 .AND. INTB.LE.153 .OR. + $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 +* + ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 + IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 + END IF + LSAME = INTA.EQ.INTB +* +* RETURN +* +* End of LSAME +* + END +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download XERBLA + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup auxOTHERauxiliary +* +* ===================================================================== + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 diff --git a/dataassim/math/numrec/dsymv.f b/dataassim/math/numrec/dsymv.f new file mode 100644 index 0000000..5fa4341 --- /dev/null +++ b/dataassim/math/numrec/dsymv.f @@ -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 diff --git a/dataassim/math/numrec/dsyr2.f b/dataassim/math/numrec/dsyr2.f new file mode 100644 index 0000000..b2b2f3d --- /dev/null +++ b/dataassim/math/numrec/dsyr2.f @@ -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 diff --git a/dataassim/math/numrec/dsyr2k.f b/dataassim/math/numrec/dsyr2k.f new file mode 100644 index 0000000..7289b05 --- /dev/null +++ b/dataassim/math/numrec/dsyr2k.f @@ -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 diff --git a/dataassim/math/numrec/dtrmm.f b/dataassim/math/numrec/dtrmm.f new file mode 100644 index 0000000..fc03769 --- /dev/null +++ b/dataassim/math/numrec/dtrmm.f @@ -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 diff --git a/dataassim/math/numrec/dtrmv.f b/dataassim/math/numrec/dtrmv.f new file mode 100644 index 0000000..5356cbb --- /dev/null +++ b/dataassim/math/numrec/dtrmv.f @@ -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 diff --git a/dataassim/math/numrec/f77_sources/d_svdfit.f b/dataassim/math/numrec/f77_sources/d_svdfit.f new file mode 100644 index 0000000..5902572 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/d_svdfit.f @@ -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 diff --git a/dataassim/math/optimization/CompassSearch.f b/dataassim/math/optimization/CompassSearch.f index 86e635f..ca93768 100644 --- a/dataassim/math/optimization/CompassSearch.f +++ b/dataassim/math/optimization/CompassSearch.f @@ -3,7 +3,7 @@ implicit none integer ndim double precision xbest(1:ndim),fbest, - & bmin(1:ndim),bmax(1:ndim),xtol + & bmin(1:ndim),bmax(1:ndim),xtol,f1dim double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim) integer i,n logical resetran2 @@ -62,7 +62,7 @@ ! =1 convergence criterion reached (minimum found) ! integer ndim - double precision xbest(1:ndim),fbest, + double precision xbest(1:ndim),fbest,f1dim, & bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2 external funkmin,f1dim !------------------------------- Locals ----------------------------------------------------------- @@ -71,10 +71,10 @@ & xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink, & direction(ndim),dmax,fcent0,ran2_reset,ran2 integer i,j,k,iter - parameter(shrink=0.618d0) + parameter(shrink=0.95d0) ! diftol=xtol - delta=0.618d0 + delta=0.95d0 do i=1,ndim xcent(i)=xbest(i) enddo diff --git a/dataassim/math/optimization/GenericOptim.f b/dataassim/math/optimization/GenericOptim.f new file mode 100644 index 0000000..b099c39 --- /dev/null +++ b/dataassim/math/optimization/GenericOptim.f @@ -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 +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/GenericRegres.f b/dataassim/math/optimization/GenericRegres.f index bd9c715..0ed4c2b 100644 --- a/dataassim/math/optimization/GenericRegres.f +++ b/dataassim/math/optimization/GenericRegres.f @@ -17,10 +17,11 @@ &beta_in_out(ndim0),betamin0(ndim0),betamax0(ndim0), &shorty0(npoints,ny),shortx0(npoints,nx),fatbeta ! - integer i,j,INFO,ndim,k + integer i,j,INFO,ndim,k,n,i2,icompete,isitnaninf,nave double precision xtol,beta(ndim0+nx*npoints), &betacp(ndim0+nx*npoints),fatbetacp,beta0(ndim0+nx*npoints), - &fatbeta0,ftol,gacontrol(12),ran2,ftol_relax + &fatbeta0,ftol,gacontrol(12),ran2,ftol_relax,term1,term2,discount, + &history(2000,ndim0+3),upper,lower,f1dim_generic,generic_pikaia parameter(xtol=1.0d-7,ftol=1.0d-7) external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia !----------------------------------------------------- @@ -97,26 +98,124 @@ c (default is 0) 10 call funkmin_generic(ndim,beta,fatbeta) do i=1,ndim beta0(i)=beta(i) + history(1,i)=beta(i) enddo fatbeta0=fatbeta + history(1,ndim+1)=fatbeta +!entrance counter + history(1,ndim+2)=1.0d0 +!failure counter + history(1,ndim+3)=0.0d0 +!Is it a competition among different initial guesses? + icompete=0 +!j the total number of calls to nongradopt; k is the number of returns to the current best and reset +!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function. +!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes +!from calls to nongradopt if they are significantly different from the current best. j=0 k=0 - ftol_relax=ftol*100.0d0 -30 call nongradopt(ndim,funkmin_generic, - &f1dim_generic,beta,betamin,betamax,ftol_relax,fatbeta) + n=1 + nave=1 + ftol_relax=ftol*1000.0d0 + discount=2.0d0 +!relax the convergence criterion for scouting +30 fatbetacp=fatbeta + do i=1,ndim + betacp(i)=beta(i) + enddo + INFO=iregrestype + call odr_leastsquare(ndim,FCN_generic,beta,nobs, + &xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars), + &nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars), + &iderivative,shortx(1:nobs,1:nxvars), + &shorty(1:nobs,1:nyvars),fatbeta,INFO) call funkmin_generic(ndim,beta,fatbeta) - if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then + if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then + fatbeta=fatbetacp do i=1,ndim + beta(i)=betacp(i) + enddo + else + fatbetacp=fatbeta + do i=1,ndim + betacp(i)=beta(i) + enddo + endif + call nongradopt(ndim,funkmin_generic,f1dim_generic, + &beta,betamin,betamax,ftol_relax,fatbeta) + if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then + fatbeta=fatbetacp + do i=1,ndim + beta(i)=betacp(i) + enddo + endif + if(fatbeta.gt.1.0d0)then + term1=fatbeta*ftol_relax + else + term1=ftol_relax*10.0d0 + endif + if(fatbeta.gt.fatbeta0)then +!failure + if((fatbeta-fatbeta0).gt.term1)then + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0 +!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so +!include it in the set if it has not already been included in the set. + i=1 + i2=1 +40 if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then + if(dabs(history(i2,ndim+1)-fatbeta).lt.term1)then + history(i2,ndim+3)=history(i2,ndim+3)+1.0d0 + goto 60 + endif + if(i2.ge.n)goto 50 + i2=i2+1 + i=1 + goto 40 + else + if(i.ge.ndim)goto 60 + i=i+1 + goto 40 + endif +50 n=n+1 + do i=1,ndim + history(n,i)=beta(i) + enddo + history(n,ndim+1)=fatbeta + history(n,ndim+2)=0.0d0 + history(n,ndim+3)=0.0d0 +!use average only when there is imporvement + nave=n + else +!the difference is minimal even though fatbeta is larger than fatbeta0. +!Increment the counter for arriving at the same minimum. + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0 + k=k+1 + endif +60 do i=1,ndim beta(i)=beta0(i) enddo fatbeta=fatbeta0 else - if((fatbeta0-fatbeta).lt.ftol_relax)then -!increment the counter for arriving at the same minimum +!success + if((fatbeta0-fatbeta).lt.term1)then +!negligible improvement. Increment the counter for arriving at the same minimum. +!no increment for the set of central initial guesses + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.5d0 k=k+1 else -!reset the counter for arriving at a better minimum +!reset the counter for arriving at a better minimum. +!Increment the set of central initial guesses + if(dabs(discount-2.0d0).lt.ftol)then + discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0) + endif k=0 + n=n+1 + do i=1,ndim + history(n,i)=beta(i) + enddo + history(n,ndim+1)=fatbeta + history(n,ndim+2)=0.0d0 + history(n,ndim+3)=0.0d0 endif do i=1,ndim beta0(i)=beta(i) @@ -124,54 +223,125 @@ c (default is 0) fatbeta0=fatbeta endif j=j+1 -!try different initial guesses - if(j.lt.100.and.k.lt.5)then - if(ran2().gt.0.3d0)then + if(j.lt.20.and.k.lt.2)then + if(j.lt.10)then + term1=0.01d0+dmin1(history(1,ndim+3)*0.025d0,0.9d0) + history(1,ndim+2)=history(1,ndim+2)+1.0d0 do i=1,ndim - if(ran2().gt.0.5d0)then - beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))* - &(betamax(i)-beta(i)) - else - beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))* - &(beta(i)-betamin(i)) + lower=history(1,i)-term1*(history(1,i)-betamin(i)) + upper=history(1,i)+term1*(betamax(i)-history(1,i)) + beta(i)=lower+ran2()*(upper-lower) + enddo + icompete=1 + goto 70 + endif +!try average + if(n.gt.nave)then + term1=1.0d0/(history(1,ndim+1)+1.0d-5) + do i=2,n + term1=term1+1.0d0/(history(i,ndim+1)+1.0d-5) + enddo + do i=1,ndim + beta(i)=history(1,i)/(term1*(history(1,ndim+1)+1.0d-5)) + do icompete=2,n + beta(i)=beta(i)+history(icompete,i)/ + &(term1*(history(icompete,ndim+1)+1.0d-5)) + enddo + enddo + nave=n + icompete=0 + goto 70 + endif +!try different initial guesses + if(ran2().gt.0.2d0)then +!guess around the best + icompete=1 + term1=history(1,ndim+1)+ + &discount*history(1,ndim+2)*history(1,ndim+3) + do i=2,n + term2=history(i,ndim+1)+ + &discount*history(i,ndim+2)*history(i,ndim+3) + if(term2.le.term1)then + term1=term2 + do i2=1,ndim+3 + history(n+1,i2)=history(i,i2) + history(i,i2)=history(1,i2) + history(1,i2)=history(n+1,i2) + enddo endif enddo + term1=0.01d0+dmin1(history(1,ndim+2)*history(1,ndim+3)* + &0.015d0,0.9d0) + history(1,ndim+2)=history(1,ndim+2)+1.0d0 + do i=1,ndim + lower=history(1,i)-term1*(history(1,i)-betamin(i)) + upper=history(1,i)+term1*(betamax(i)-history(1,i)) + beta(i)=lower+ran2()*(upper-lower) + enddo else +!completely random guess do i=1,ndim beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) enddo + icompete=0 endif - call funkmin_generic(ndim,beta,fatbeta) +70 call funkmin_generic(ndim,beta,fatbeta) goto 30 else if((ftol_relax-ftol).gt.ftol)then + if(k.le.1)then + n=n+1 + do i=1,ndim+3 + history(n,i)=history(1,i) + enddo + do i=1,ndim + history(1,i)=beta(i) + enddo + history(1,ndim+1)=fatbeta + history(1,ndim+2)=0.0d0 + history(1,ndim+3)=0.0d0 + do i=1,n + do icompete=1,ndim + betacp(icompete)=history(i,icompete) + enddo + fatbetacp=history(i,ndim+1) + call RepeatCompassSearch(ndim,betacp,fatbetacp, + &betamin,betamax,funkmin_generic,f1dim_generic,ftol_relax) + call funkmin_generic(ndim,betacp,fatbetacp) + if(isitnaninf(fatbetacp).eq.0.and.fatbetacp.lt. + &fatbeta)then + do icompete=1,ndim + beta(icompete)=betacp(icompete) + enddo + fatbeta=fatbetacp + endif + enddo + do i=1,ndim + beta0(i)=beta(i) + enddo + fatbeta0=fatbeta + icompete=1 + j=0 + else + icompete=0 + endif ftol_relax=ftol goto 30 endif endif + + goto 110 + call RepeatCompassSearch(ndim,beta,fatbeta, &betamin,betamax,funkmin_generic,f1dim_generic,xtol) call funkmin_generic(ndim,beta,fatbeta) - k=0 - if((fatbeta+1.0d0).eq.fatbeta)k=1 - do i=1,ndim - if((beta(i)+1.0d0).eq.beta(i))k=1 - enddo - if(k.eq.1)then - do i=1,ndim - beta(i)=betamin(i)+(betamax(i)-betamin(i))*ran2() - enddo - goto 10 - endif - if(fatbeta.ge.fatbeta0)then + if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then !if RepeatCompassSearch cannot improve, we end the search do i=1,ndim beta(i)=beta0(i) enddo fatbeta=fatbeta0 goto 110 - else - if((fatbeta0-fatbeta).lt.ftol)goto 40 endif do i=1,12 gacontrol(i)=-1.0d0 @@ -182,65 +352,40 @@ c (default is 0) do i=1,ndim beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) enddo - idobounded=0 + fatbeta0=fatbeta call pikaia(generic_pikaia,ndim,gacontrol,beta0,fatbeta0,j) fatbeta0=1.0d+100 if(j.eq.0)then do i=1,ndim beta0(i)=betamin(i)+beta0(i)*(betamax(i)-betamin(i)) enddo - idobounded=1 call funkmin_generic(ndim,beta0,fatbeta0) - k=0 - if((fatbeta0+1.0d0).eq.fatbeta0)k=1 - do i=1,ndim - if((beta0(i)+1.0d0).eq.beta0(i))k=1 - enddo - if(k.eq.1)fatbeta0=1.0d+100 endif - -40 if(fatbeta0.gt.fatbeta)then +80 if(isitnaninf(fatbeta0).eq.1.or.fatbeta0.gt.fatbeta)then fatbeta0=fatbeta do i=1,ndim beta0(i)=beta(i) enddo - endif - do i=1,ndim - beta(i)=beta0(i) - enddo - fatbeta=fatbeta0 -! - INFO=iregrestype - idobounded=0 - call odr_leastsquare(ndim,FCN_generic,beta,nobs, - &xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars), - &nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars), - &iderivative,shortx(1:nobs,1:nxvars), - &shorty(1:nobs,1:nyvars),fatbeta,INFO) - idobounded=1 - call funkmin_generic(ndim,beta,fatbeta) - k=0 - if((fatbeta+1.0d0).eq.fatbeta)k=1 - do i=1,ndim - if((beta(i)+1.0d0).eq.beta(i))k=1 - enddo - if(k.eq.1)fatbeta=1.0d+100 - if(dabs(fatbeta).le.dabs(fatbeta0))then else do i=1,ndim beta(i)=beta0(i) enddo fatbeta=fatbeta0 endif - do i=1,ndim - if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then - do j=1,ndim - beta(j)=beta0(j) - enddo - fatbeta=fatbeta0 - endif - enddo - fatbeta0=fatbeta +! + INFO=iregrestype + call odr_leastsquare(ndim,FCN_generic,beta,nobs, + &xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars), + &nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars), + &iderivative,shortx(1:nobs,1:nxvars), + &shorty(1:nobs,1:nyvars),fatbeta,INFO) + call funkmin_generic(ndim,beta,fatbeta) + if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbeta0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + fatbeta=fatbeta0 + endif iregrestype=iregrestype0 if(iregrestype.eq.2)then do i=1,npoints @@ -266,13 +411,7 @@ c (default is 0) call nongradopt(ndim,funkmin_generic, &f1dim_generic,beta,betamin,betamax,ftol,fatbeta) call funkmin_generic(ndim,beta,fatbeta) - k=0 - if((fatbeta+1.0d0).eq.fatbeta)k=1 - do i=1,ndim - if((beta(i)+1.0d0).eq.beta(i))k=1 - enddo - if(k.eq.1)fatbeta=1.0d+100 - if(dabs(fatbeta).ge.dabs(fatbeta0))then + if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then fatbeta=fatbeta0 do i=1,ndim beta(i)=beta0(i) @@ -286,19 +425,13 @@ c (default is 0) call RepeatCompassSearch(ndim,betacp,fatbetacp, &betamin,betamax,funkmin_generic,f1dim_generic,xtol) call funkmin_generic(ndim,betacp,fatbetacp) - k=0 - if((fatbetacp+1.0d0).eq.fatbetacp)k=1 - do i=1,ndim - if((betacp(i)+1.0d0).eq.betacp(i))k=1 - enddo - if(k.eq.1)fatbetacp=1.0d+100 - if(dabs(fatbetacp).lt.dabs(fatbeta))then + if(isitnaninf(fatbetacp).eq.1.or.fatbetacp.ge.fatbeta)then + goto 110 + else fatbeta=fatbetacp do i=1,ndim beta(i)=betacp(i) enddo - else - goto 110 endif if(j.ge.2.or.fatbeta.eq.fatbeta0)goto 110 if(dabs(fatbeta0-fatbeta).gt.ftol)then @@ -310,7 +443,7 @@ c (default is 0) call linmin(beta,betamin,betamax,betacp,ndim, &f1dim_generic,fatbeta) call funkmin_generic(ndim,beta,fatbeta) - if(dabs(fatbeta).lt.dabs(fatbeta0))goto 100 + if(isitnaninf(fatbeta).eq.0.and.fatbeta.lt.fatbeta0)goto 100 fatbeta=fatbeta0 do i=1,ndim beta(i)=beta0(i) diff --git a/dataassim/math/optimization/cpCompassSearch.f b/dataassim/math/optimization/cpCompassSearch.f index 186b50a..415f6a7 100644 --- a/dataassim/math/optimization/cpCompassSearch.f +++ b/dataassim/math/optimization/cpCompassSearch.f @@ -3,7 +3,7 @@ implicit none integer ndim double precision xbest(1:ndim),fbest, - & bmin(1:ndim),bmax(1:ndim),xtol + & bmin(1:ndim),bmax(1:ndim),xtol,f1dim double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim) parameter(ftol=1.0d-7) integer i,n @@ -62,7 +62,7 @@ ! =1 convergence criterion reached (minimum found) ! integer ndim - double precision xbest(1:ndim),fbest, + double precision xbest(1:ndim),fbest,f1dim, & bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2 external funkmin,f1dim !------------------------------- Locals ----------------------------------------------------------- diff --git a/dataassim/math/optimization/cpnongradopt.f b/dataassim/math/optimization/cpnongradopt.f index 7b7c460..25c8700 100644 --- a/dataassim/math/optimization/cpnongradopt.f +++ b/dataassim/math/optimization/cpnongradopt.f @@ -7,7 +7,7 @@ ! integer ndim double precision beta(1:ndim),bmin(1:ndim), - & bmax(1:ndim),ftol,fatbeta + &bmax(1:ndim),ftol,fatbeta,f1dim ! ! ------------------ Inputs ----------------------------- ! ndim: the total number of parameters to be estimated diff --git a/dataassim/math/optimization/cppowell.f b/dataassim/math/optimization/cppowell.f index f74ee1f..f49023d 100644 --- a/dataassim/math/optimization/cppowell.f +++ b/dataassim/math/optimization/cppowell.f @@ -4,7 +4,7 @@ implicit none INTEGER iter,n,np,NMAX,ITMAX double precision fret,ftol,p(np),xi(np,np),TINY, - & pmin(np),pmax(np) + & pmin(np),pmax(np),f1dim PARAMETER (NMAX=1000,TINY=1.0d-25) CU USES funkmin,linmin INTEGER i,ibig,j @@ -57,7 +57,7 @@ C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. SUBROUTINE cplinmin(p,pmin,pmax,xi,n,f1dim,fret) implicit none INTEGER n - double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n) + double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim PARAMETER (TOL=1.0d-8) CU USES brent,f1dim,mnbrak INTEGER j,k,ierr diff --git a/dataassim/math/optimization/lbfgsroutines.f b/dataassim/math/optimization/lbfgsroutines.f index 8cbfd39..ae2cf95 100644 --- a/dataassim/math/optimization/lbfgsroutines.f +++ b/dataassim/math/optimization/lbfgsroutines.f @@ -192,7 +192,7 @@ c ************ integer l1,l2,l3,lws,lr,lz,lt,ld,lwa,lwy,lsy,lss,lwt,lwn,lsnd - if (task .eq. 'START') then + if (task .eqv. 'START') then isave(1) = m*n isave(2) = m**2 isave(3) = 4*m**2 @@ -442,7 +442,7 @@ c ************ double precision one,zero parameter (one=1.0d0,zero=0.0d0) - if (task .eq. 'START') then + if (task .eqv. 'START') then call timer(time1) @@ -508,7 +508,7 @@ c open a summary file 'iterate.dat' c Check the input arguments for errors. call errclb(n,m,factr,l,u,nbd,task,info,k) - if (task(1:5) .eq. 'ERROR') then + if (task(1:5) .eqv. 'ERROR') then call prn3lb(n,x,f,task,iprint,info,itfile, + iter,nfgv,nintol,nskip,nact,sbgnrm, + zero,nint,word,iback,stp,xstep,k, @@ -571,11 +571,11 @@ c restore local variables. c After returning from the driver go to the point where execution c is to resume. - if (task(1:5) .eq. 'FG_LN') goto 666 - if (task(1:5) .eq. 'NEW_X') goto 777 - if (task(1:5) .eq. 'FG_ST') goto 111 - if (task(1:4) .eq. 'STOP') then - if (task(7:9) .eq. 'CPU') then + if (task(1:5) .eqv. 'FG_LN') goto 666 + if (task(1:5) .eqv. 'NEW_X') goto 777 + if (task(1:5) .eqv. 'FG_ST') goto 111 + if (task(1:4) .eqv. 'STOP') then + if (task(7:9) .eqv. 'CPU') then c restore the previous iterate. call dcopy(n,t,1,x,1) call dcopy(n,r,1,g,1) @@ -771,7 +771,7 @@ c refresh the lbfgs memory and restart the iteration. lnscht = lnscht + cpu2 - cpu1 goto 222 endif - else if (task(1:5) .eq. 'FG_LN') then + else if (task(1:5) .eqv. 'FG_LN') then c return to the driver for calculating f and g; reenter at 666. goto 1000 else @@ -2444,7 +2444,7 @@ c ********** double precision ftol,gtol,xtol parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0) - if (task(1:5) .eq. 'FG_LN') goto 556 + if (task(1:5) .eqv. 'FG_LN') goto 556 dtd = ddot(n,d,1,d,1) dnorm = sqrt(dtd) @@ -2789,7 +2789,7 @@ c ************ integer i - if (task(1:5) .eq. 'ERROR') goto 999 + if (task(1:5) .eqv. 'ERROR') goto 999 if (iprint .ge. 0) then write (6,3003) @@ -3271,7 +3271,7 @@ c c task = 'START' c 10 continue c call dcsrch( ... ) -c if (task .eq. 'FG') then +c if (task .eqv. 'FG') then c Evaluate the function and the gradient at stp c goto 10 c end if @@ -3377,7 +3377,7 @@ c ********** c Initialization block. - if (task(1:5) .eq. 'START') then + if (task(1:5) .eqv. 'START') then c Check the input arguments for errors. @@ -3392,7 +3392,7 @@ c Check the input arguments for errors. c Exit if there are errors on input. - if (task(1:5) .eq. 'ERROR') return + if (task(1:5) .eqv. 'ERROR') return c Initialize local variables. @@ -3479,7 +3479,7 @@ c Test for convergence. c Test for termination. - if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000 + if (task(1:4) .eqv. 'WARN' .or. task(1:4) .eqv. 'CONV') goto 1000 c A modified function is used to predict the step during the c first stage if a lower function value has been obtained but diff --git a/dataassim/math/optimization/mcts.f b/dataassim/math/optimization/mcts.f new file mode 100644 index 0000000..f47cfd3 --- /dev/null +++ b/dataassim/math/optimization/mcts.f @@ -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 +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/nongradopt.f b/dataassim/math/optimization/nongradopt.f index 2bb037d..e448ad8 100644 --- a/dataassim/math/optimization/nongradopt.f +++ b/dataassim/math/optimization/nongradopt.f @@ -6,7 +6,7 @@ ! integer ndim double precision beta(1:ndim),bmin(1:ndim), - & bmax(1:ndim),ftol,fatbeta + &bmax(1:ndim),ftol,fatbeta,f1dim ! ! ------------------ Inputs ----------------------------- ! ndim: the total number of parameters to be estimated @@ -24,7 +24,7 @@ integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX, & icycle - parameter(maxredo=10,ITMAX=10000) + parameter(maxredo=5,ITMAX=50000) double precision fbest,xbest(1:ndim),term, & xinidir(1:ndim,1:ndim),xbest0(1:ndim), & pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1) @@ -50,7 +50,7 @@ fatbeta=fbest goto 10 endif - if((fbest-fatbeta).gt.ftol)then + if((fbest-fatbeta).gt.100.0d0*ftol)then if(iredo.gt.maxredo)goto 10 iredo=iredo+1 goto 3 @@ -92,6 +92,9 @@ if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then term=term/3.0d0 fbest=fatbeta + do n=1,ndim + xbest(n)=beta(n) + enddo goto 30 endif do n=1,ndim @@ -144,7 +147,7 @@ return endif enddo - if((fbest-fatbeta).gt.ftol)then + if((fbest-fatbeta).gt.ftol*100.0d0)then if(iredo.gt.maxredo)then if(icycle.lt.maxredo)then icycle=icycle+1 @@ -167,15 +170,15 @@ external funkmin CU USES guamotry,funkmin INTEGER i,ihi,ilo,inhi,j,m,n - double precision rtol,sum,swap,ysave,ytry,psum(ndim), + double precision rtol,cumx,swap,ysave,ytry,pcumx(ndim), & guamotry,degen iter=0 1 do 12 n=1,ndim - sum=0.0d0 + cumx=0.0d0 do 11 m=1,ndim+1 - sum=sum+p(m,n) + cumx=cumx+p(m,n) 11 continue - psum(n)=sum + pcumx(n)=cumx 12 continue 2 ilo=1 if (y(1).gt.y(2)) then @@ -232,20 +235,20 @@ CU USES guamotry,funkmin endif if(iter.ge.ITMAX)return iter=iter+2 - ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0) + ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,-1.0d0) if (ytry.le.y(ilo))then - ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,2.0d0) + ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,2.0d0) else if (ytry.ge.y(inhi)) then ysave=y(ihi) - ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,0.5d0) + ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,0.5d0) if (ytry.ge.ysave) then do 16 i=1,ndim+1 if(i.ne.ilo)then do 15 j=1,ndim - psum(j)=0.5d0*(p(i,j)+p(ilo,j)) - p(i,j)=psum(j) + pcumx(j)=0.5d0*(p(i,j)+p(ilo,j)) + p(i,j)=pcumx(j) 15 continue - call funkmin(ndim,psum,y(i)) + call funkmin(ndim,pcumx,y(i)) endif 16 continue iter=iter+ndim diff --git a/dataassim/math/optimization/odr_leastsquare.f b/dataassim/math/optimization/odr_leastsquare.f index f9d6371..b9c88e0 100644 --- a/dataassim/math/optimization/odr_leastsquare.f +++ b/dataassim/math/optimization/odr_leastsquare.f @@ -24,7 +24,6 @@ C VARIABLE DECLARATIONS double precision weity(N,NQ),weitx(N,M),shorty(N,NQ), &shortx(N,M),fvalue,BETA(NP),X(N,M),Y(N,NQ) EXTERNAL FCN - LWORK=18+11*NP+NP**2+M+M**2+4*N*NQ+6*N*M+2*N*NQ*NP+ &2*N*NQ*M+NQ**2+5*NQ+NQ*(NP+M)+N*1*NQ LIWORK=20+NP+NQ*(NP+M) @@ -96,7 +95,7 @@ C VARIABLE DECLARATIONS + WORK(LWORK),X(N,M),Y(N,NQ) !------------For using information in WORK---------------------------- LOGICAL - + ISODR + +ISODR INTEGER + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, @@ -105,7 +104,7 @@ C VARIABLE DECLARATIONS + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + FSI,FJACBI,WE1I,DIFFI, + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, - + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + LWKMN c integer i1,i2,i3,i4,i5,iderivative @@ -230,7 +229,7 @@ C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + FSI,FJACBI,WE1I,DIFFI, + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, - + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + LWKMN) fvalue=0.0d0 do I=1,N diff --git a/dataassim/math/optimization/odrpack.f b/dataassim/math/optimization/odrpack.f index 82c2b84..8072c4a 100644 --- a/dataassim/math/optimization/odrpack.f +++ b/dataassim/math/optimization/odrpack.f @@ -6,7 +6,7 @@ *DMPREC DOUBLE PRECISION FUNCTION DMPREC() implicit none - integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp, + integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp, *maxexp double precision eps,epsneg,xmin,xmax @@ -209,146 +209,146 @@ c TD = I1MACH(14) c DMPREC = B ** (1-TD) call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp, - *minexp, maxexp,eps,epsneg,xmin,xmax) + *minexp,maxexp,eps,epsneg,xmin,xmax) DMPREC=eps RETURN END SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep, - *iexp,minexp, maxexp,eps,epsneg,xmin,xmax) + *iexp,minexp,maxexp,eps,epsneg,xmin,xmax) implicit none - INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd - double precision eps,epsneg,xmax,xmin - INTEGER i,itemp,iz,j,k,mx,nxres + INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd + double precision eps,epsneg,xmax,xmin + INTEGER i,itemp,iz,j,k,mx,nxres double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa, - &two,y,z,zero, CONV - CONV(i)=dble(i) - one=CONV(1) - two=one+one - zero=one-one - a=one -1 continue - a=a+a - temp=a+one - temp1=temp-a - if (temp1-one.eq.zero) goto 1 - b=one -2 continue - b=b+b - temp=a+b - itemp=int(temp-a) - if (itemp.eq.0) goto 2 - ibeta=itemp - beta=CONV(ibeta) - it=0 - b=one -3 continue - it=it+1 - b=b*beta - temp=b+one - temp1=temp-b - if (temp1-one.eq.zero) goto 3 - irnd=0 - betah=beta/two - temp=a+betah - if (temp-a.ne.zero) irnd=1 - tempa=a+beta - temp=tempa+betah - if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2 - negep=it+3 - betain=one/beta - a=one - do 11 i=1, negep - a=a*betain -11 continue - b=a -4 continue - temp=one-a - if (temp-one.ne.zero) goto 5 - a=a*beta - negep=negep-1 - goto 4 -5 negep=-negep - epsneg=a - machep=-it-3 - a=b -6 continue - temp=one+a - if (temp-one.ne.zero) goto 7 - a=a*beta - machep=machep+1 - goto 6 -7 eps=a - ngrd=0 - temp=one+eps - if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1 - i=0 - k=1 - z=betain - t=one+eps - nxres=0 -8 continue - y=z - z=y*y - a=z*one - temp=z*t - if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9 - temp1=temp*betain - if (temp1*beta.eq.z) goto 9 - i=i+1 - k=k+k - goto 8 -9 if (ibeta.ne.10) then - iexp=i+1 - mx=k+k - else - iexp=2 - iz=ibeta -10 if (k.ge.iz) then - iz=iz*ibeta - iexp=iexp+1 - goto 10 - endif - mx=iz+iz-1 - endif -20 xmin=y - y=y*betain - a=y*one - temp=y*t - if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then - k=k+1 - temp1=temp*betain - if ((temp1*beta.ne.y).or.(temp.eq.y)) then - goto 20 - else - nxres=3 - xmin=y - endif - endif - minexp=-k - if ((mx.le.k+k-3).and.(ibeta.ne.10)) then - mx=mx+mx - iexp=iexp+1 - endif - maxexp=mx+minexp - irnd=irnd+nxres - if (irnd.ge.2) maxexp=maxexp-2 - i=maxexp+minexp - if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1 - if (i.gt.20) maxexp=maxexp-1 - if (a.ne.y) maxexp=maxexp-2 - xmax=one-epsneg - if (xmax*one.ne.xmax) xmax=one-beta*epsneg - xmax=xmax/(beta*beta*beta*xmin) - i=maxexp+minexp+3 - do 12 j=1,i - if (ibeta.eq.2) xmax=xmax+xmax - if (ibeta.ne.2) xmax=xmax*beta -12 continue - return - END -C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + &two,y,z,zero,CONV + CONV(i)=dble(i) + one=CONV(1) + two=one+one + zero=one-one + a=one +1 continue + a=a+a + temp=a+one + temp1=temp-a + if (temp1-one.eq.zero) goto 1 + b=one +2 continue + b=b+b + temp=a+b + itemp=int(temp-a) + if (itemp.eq.0) goto 2 + ibeta=itemp + beta=CONV(ibeta) + it=0 + b=one +3 continue + it=it+1 + b=b*beta + temp=b+one + temp1=temp-b + if (temp1-one.eq.zero) goto 3 + irnd=0 + betah=beta/two + temp=a+betah + if (temp-a.ne.zero) irnd=1 + tempa=a+beta + temp=tempa+betah + if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2 + negep=it+3 + betain=one/beta + a=one + do 11 i=1, negep + a=a*betain +11 continue + b=a +4 continue + temp=one-a + if (temp-one.ne.zero) goto 5 + a=a*beta + negep=negep-1 + goto 4 +5 negep=-negep + epsneg=a + machep=-it-3 + a=b +6 continue + temp=one+a + if (temp-one.ne.zero) goto 7 + a=a*beta + machep=machep+1 + goto 6 +7 eps=a + ngrd=0 + temp=one+eps + if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1 + i=0 + k=1 + z=betain + t=one+eps + nxres=0 +8 continue + y=z + z=y*y + a=z*one + temp=z*t + if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9 + temp1=temp*betain + if (temp1*beta.eq.z) goto 9 + i=i+1 + k=k+k + goto 8 +9 if (ibeta.ne.10) then + iexp=i+1 + mx=k+k + else + iexp=2 + iz=ibeta +10 if (k.ge.iz) then + iz=iz*ibeta + iexp=iexp+1 + goto 10 + endif + mx=iz+iz-1 + endif +20 xmin=y + y=y*betain + a=y*one + temp=y*t + if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then + k=k+1 + temp1=temp*betain + if ((temp1*beta.ne.y).or.(temp.eq.y)) then + goto 20 + else + nxres=3 + xmin=y + endif + endif + minexp=-k + if ((mx.le.k+k-3).and.(ibeta.ne.10)) then + mx=mx+mx + iexp=iexp+1 + endif + maxexp=mx+minexp + irnd=irnd+nxres + if (irnd.ge.2) maxexp=maxexp-2 + i=maxexp+minexp + if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1 + if (i.gt.20) maxexp=maxexp-1 + if (a.ne.y) maxexp=maxexp-2 + xmax=one-epsneg + if (xmax*one.ne.xmax) xmax=one-beta*epsneg + xmax=xmax/(beta*beta*beta*xmin) + i=maxexp+minexp+3 + do 12 j=1,i + if (ibeta.eq.2) xmax=xmax+xmax + if (ibeta.ne.2) xmax=xmax*beta +12 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. *DODR SUBROUTINE DODR @@ -966,7 +966,6 @@ C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + LWKMN) - IF (ACCESS) THEN C SET STARTING LOCATIONS FOR WORK VECTORS @@ -1050,9 +1049,8 @@ C STORE VALUES INTO THE WORK VECTORS IWORK(NITERI) = NITER IWORK(NJEVI) = NJEV IWORK(IDFI) = IDF - IWORK(INT2I) = INT2 + IWORK(INT2I) = INT2 END IF - RETURN END *DESUBI @@ -5916,7 +5914,6 @@ C***FIRST EXECUTABLE STATEMENT DODMN C INITIALIZE NECESSARY VARIABLES - CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) ACCESS = .TRUE. @@ -5936,7 +5933,6 @@ C INITIALIZE NECESSARY VARIABLES DIDVCV = .FALSE. INTDBL = .FALSE. LSTEP = .TRUE. - C PRINT INITIAL SUMMARY IF DESIRED IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN @@ -6295,7 +6291,6 @@ C PRINT ITERATION REPORT END IF END IF END IF - C CHECK IF FINISHED IF (INFO.EQ.0) THEN @@ -6315,9 +6310,7 @@ C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET GO TO 110 END IF END IF - 150 CONTINUE - IF (ISTOP.GT.0) INFO = INFO + 100 C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER @@ -6329,12 +6322,9 @@ C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER END IF CALL DUNPAC(NP,BETAC,BETA,IFIXB) CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) - C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED - - IF (DOVCV .AND. ISTOP.EQ.0) THEN - + IF (DOVCV .AND. ISTOP.EQ.0) THEN C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED C TO COMPUTE COVARIANCE MATRIX @@ -6350,8 +6340,6 @@ C TO COMPUTE COVARIANCE MATRIX + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + NJEV,NFEV,ISTOP,INFO) - - IF (ISTOP.NE.0) THEN INFO = 51000 GO TO 200 @@ -6359,7 +6347,6 @@ C TO COMPUTE COVARIANCE MATRIX GO TO 200 END IF END IF - IF (IMPLCT) THEN CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1) @@ -6383,9 +6370,7 @@ C TO COMPUTE COVARIANCE MATRIX END IF DIDVCV = .TRUE. END IF - END IF - C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS 200 DO 210 I=0,NP-1 @@ -12072,15 +12057,23 @@ C***FIRST EXECUTABLE STATEMENT DNRM2_odr DNRM2_odr = ZERO GO TO 300 - 10 ASSIGN 30 TO NEXT +! 10 ASSIGN 30 TO NEXT + 10 NEXT=30 SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 C 20 GO TO NEXT,(30, 50, 70, 110) - 20 GO TO NEXT +! 20 GO TO NEXT +!------------------------------ +20 IF(NEXT.EQ.30) goto 30 + IF(NEXT.EQ.50) goto 50 + IF(NEXT.EQ.70) goto 70 + IF(NEXT.EQ.110) goto 110 + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT +! ASSIGN 50 TO NEXT + NEXT=50 XMAX = ZERO C PHASE 1. SUM IS ZERO @@ -12089,13 +12082,15 @@ C PHASE 1. SUM IS ZERO IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 C PREPARE FOR PHASE 2. - ASSIGN 70 TO NEXT +! ASSIGN 70 TO NEXT + NEXT=70 GO TO 105 C PREPARE FOR PHASE 4. 100 I = J - ASSIGN 110 TO NEXT +! ASSIGN 110 TO NEXT + NEXT=110 SUM = (SUM / DX(I)) / DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 diff --git a/dataassim/math/optimization/odrpack95/d_drive1.f b/dataassim/math/optimization/odrpack95/d_drive1.f new file mode 100644 index 0000000..53cbd6e --- /dev/null +++ b/dataassim/math/optimization/odrpack95/d_drive1.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/d_drive2.f b/dataassim/math/optimization/odrpack95/d_drive2.f new file mode 100644 index 0000000..d97e562 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/d_drive2.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/d_drive3.f b/dataassim/math/optimization/odrpack95/d_drive3.f new file mode 100644 index 0000000..ec2e4ef --- /dev/null +++ b/dataassim/math/optimization/odrpack95/d_drive3.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/d_lpkbls.f b/dataassim/math/optimization/odrpack95/d_lpkbls.f new file mode 100644 index 0000000..ca2e31e --- /dev/null +++ b/dataassim/math/optimization/odrpack95/d_lpkbls.f @@ -0,0 +1,2249 @@ +*DASUM + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +C***BEGIN PROLOGUE DASUM +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3A +C***KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE SUM OF MAGNITUDES OF D.P. VECTOR COMPONENTS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DASUM DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C RETURNS SUM OF MAGNITUDES OF DOUBLE PRECISION DX. +C DASUM = SUM FROM 0 TO N-1 OF DABS(DX(1+I*INCX)) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DASUM + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,MOD + + +C***FIRST EXECUTABLE STATEMENT DASUM + + + DASUM = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I=1,NS,INCX + DASUM = DASUM + DABS(DX(I)) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. + + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DASUM = DASUM + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) + 1 + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) + 50 CONTINUE + RETURN + END +*DAXPY + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DAXPY +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A7 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P COMPUTATION Y = A*X + Y +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALAR MULTIPLIER +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY DOUBLE PRECISION RESULT (UNCHANGED IF N .LE. 0) +C OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. +C FOR I = 0 TO N-1, REPLACE DY(LY+I*INCY) WITH DA*DX(LX+I*INCX) + +C DY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N +C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DAXPY + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DAXPY + + + IF(N.LE.0.OR.DA.EQ.0.D0) RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. + + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END +*DCHEX + SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) +C***BEGIN PROLOGUE DCHEX +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D7B +C***KEYWORDS CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE UPDATES THE CHOLESKY FACTORIZATION A=TRANS(R)*R OF A +C POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM TRANS(E)*A*E WHERE E IS A +C PERMUTATION MATRIX. +C***DESCRIPTION +C DCHEX UPDATES THE CHOLESKY FACTORIZATION +C A = TRANS(R)*R +C OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM +C TRANS(E)*A*E +C WHERE E IS A PERMUTATION MATRIX. SPECIFICALLY, GIVEN +C AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX +C E (WHICH IS SPECIFIED BY K, L, AND JOB), DCHEX DETERMINES +C AN ORTHOGONAL MATRIX U SUCH THAT +C U*R*E = RR, +C WHERE RR IS UPPER TRIANGULAR. AT THE USERS OPTION, THE +C TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z. +C IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X*E, I.E. X WITH ITS COLUMNS PERMUTED. +C FOR A LESS TERSE DESCRIPTION OF WHAT DCHEX DOES AND HOW +C IT MAY BE APPLIED, SEE THE LINPACK GUIDE. +C THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1) +C OF PLANE ROTATIONS OF THE FORM +C ( C(I) S(I) ) +C ( ) , +C ( -S(I) C(I) ) +C WHERE C(I) IS DOUBLE PRECISION. THE ROWS THESE ROTATIONS OPERATE +C ON ARE DESCRIBED BELOW. +C THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED +C BY THE VALUE OF JOB. +C 1. RIGHT CIRCULAR SHIFT (JOB = 1). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER. +C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (L-I,L-I+1)-PLANE. +C 2. LEFT CIRCULAR SHIFT (JOB = 2). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER +C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (K+I-1,K+I)-PLANE. +C ON ENTRY +C R DOUBLE PRECISION(LDR,P), WHERE LDR .GE. P. +C R CONTAINS THE UPPER TRIANGULAR FACTOR +C THAT IS TO BE UPDATED. ELEMENTS OF R +C BELOW THE DIAGONAL ARE NOT REFERENCED. +C LDR INTEGER. +C LDR IS THE LEADING DIMENSION OF THE ARRAY R. +C P INTEGER. +C P IS THE ORDER OF THE MATRIX R. +C K INTEGER. +C K IS THE FIRST COLUMN TO BE PERMUTED. +C L INTEGER. +C L IS THE LAST COLUMN TO BE PERMUTED. +C L MUST BE STRICTLY GREATER THAN K. +C Z DOUBLE PRECISION(LDZ,N)Z), WHERE LDZ .GE. P. +C Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE +C TRANSFORMATION U IS MULTIPLIED. Z IS +C NOT REFERENCED IF NZ = 0. +C LDZ INTEGER. +C LDZ IS THE LEADING DIMENSION OF THE ARRAY Z. +C NZ INTEGER. +C NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z. +C JOB INTEGER. +C JOB DETERMINES THE TYPE OF PERMUTATION. +C JOB = 1 RIGHT CIRCULAR SHIFT. +C JOB = 2 LEFT CIRCULAR SHIFT. +C ON RETURN +C R CONTAINS THE UPDATED FACTOR. +C Z CONTAINS THE UPDATED MATRIX Z. +C C DOUBLE PRECISION(P). +C C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS. +C S DOUBLE PRECISION(P). +C S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DROTG +C***END PROLOGUE DCHEX + +C...SCALAR ARGUMENTS + INTEGER + + JOB,K,L,LDR,LDZ,NZ,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + C(*),R(LDR,*),S(*),Z(LDZ,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,T1 + INTEGER + + I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DROTG + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MAX0,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DCHEX + + + KM1 = K - 1 + KP1 = K + 1 + LMK = L - K + LM1 = L - 1 + +C PERFORM THE APPROPRIATE TASK. + + GO TO (10,130), JOB + +C RIGHT CIRCULAR SHIFT. + + 10 CONTINUE + +C REORDER THE COLUMNS. + + DO 20 I = 1, L + II = L - I + 1 + S(I) = R(II,L) + 20 CONTINUE + DO 40 JJ = K, LM1 + J = LM1 - JJ + K + DO 30 I = 1, J + R(I,J+1) = R(I,J) + 30 CONTINUE + R(J+1,J+1) = 0.0D0 + 40 CONTINUE + IF (K .EQ. 1) GO TO 60 + DO 50 I = 1, KM1 + II = L - I + 1 + R(I,K) = S(II) + 50 CONTINUE + 60 CONTINUE + +C CALCULATE THE ROTATIONS. + + T = S(1) + DO 70 I = 1, LMK + T1 = S(I) + CALL DROTG(S(I+1),T,C(I),T1) + S(I) = T1 + T = S(I+1) + 70 CONTINUE + R(K,K) = T + DO 90 J = KP1, P + IL = MAX0(1,L-J+1) + DO 80 II = IL, LMK + I = L - II + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 80 CONTINUE + 90 CONTINUE + +C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. + + IF (NZ .LT. 1) GO TO 120 + DO 110 J = 1, NZ + DO 100 II = 1, LMK + I = L - II + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 260 + +C LEFT CIRCULAR SHIFT + + 130 CONTINUE + +C REORDER THE COLUMNS + + DO 140 I = 1, K + II = LMK + I + S(II) = R(I,K) + 140 CONTINUE + DO 160 J = K, LM1 + DO 150 I = 1, J + R(I,J) = R(I,J+1) + 150 CONTINUE + JJ = J - KM1 + S(JJ) = R(J+1,J+1) + 160 CONTINUE + DO 170 I = 1, K + II = LMK + I + R(I,L) = S(II) + 170 CONTINUE + DO 180 I = KP1, L + R(I,L) = 0.0D0 + 180 CONTINUE + +C REDUCTION LOOP. + + DO 220 J = K, P + IF (J .EQ. K) GO TO 200 + +C APPLY THE ROTATIONS. + + IU = MIN0(J-1,L-1) + DO 190 I = K, IU + II = I - K + 1 + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 190 CONTINUE + 200 CONTINUE + IF (J .GE. L) GO TO 210 + JJ = J - K + 1 + T = S(JJ) + CALL DROTG(R(J,J),T,C(JJ),S(JJ)) + 210 CONTINUE + 220 CONTINUE + +C APPLY THE ROTATIONS TO Z. + + IF (NZ .LT. 1) GO TO 250 + DO 240 J = 1, NZ + DO 230 I = K, LM1 + II = I - KM1 + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN + END +*DCOPY + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DCOPY +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,COPY,DOUBLE PRECISION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR COPY Y = X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY COPY OF VECTOR DX (UNCHANGED IF N .LE. 0) +C COPY DOUBLE PRECISION DX TO DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, COPY DX(LX+I*INCX) TO DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DCOPY + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DCOPY + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. + + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS=N*INCX + DO 70 I=1,NS,INCX + DY(I) = DX(I) + 70 CONTINUE + RETURN + END +*DDOT + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DDOT +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A4 +C***KEYWORDS BLAS,DOUBLE PRECISION,INNER PRODUCT,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. INNER PRODUCT OF D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DDOT DOUBLE PRECISION DOT PRODUCT (ZERO IF N .LE. 0) +C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. +C DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DDOT + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DDOT + + + DDOT = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOT = DDOT + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DDOT = DDOT + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + 1 DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + RETURN + +C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DDOT = DDOT + DX(I)*DY(I) + 70 CONTINUE + RETURN + END +*DNRM2 + DOUBLE PRECISION FUNCTION DNRM2(N,DX,INCX) +C***BEGIN PROLOGUE DNRM2 +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3B +C***KEYWORDS BLAS,DOUBLE PRECISION,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA, +C NORM,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE EUCLIDEAN LENGTH (L2 NORM) OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DNRM2 DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C IF N .LE. 0 RETURN WITH RESULT = 0. +C IF N .GE. 1 THEN INCX MUST BE .GE. 1 +C C.L. LAWSON, 1978 JAN 08 +C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE +C HOPEFULLY APPLICABLE TO ALL MACHINES. +C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. +C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. +C WHERE +C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. +C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) +C V = LARGEST NO. (OVERFLOW LIMIT) +C BRIEF OUTLINE OF ALGORITHM.. +C PHASE 1 SCANS ZERO COMPONENTS. +C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO +C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO +C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M +C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. + +C VALUES FOR CUTLO AND CUTHI.. +C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER +C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. +C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE +C UNIVAC AND DEC AT 2**(-103) +C THUS CUTLO = 2**(-51) = 4.44089E-16 +C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. +C THUS CUTHI = 2**(63.5) = 1.30438E19 +C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. +C THUS CUTLO = 2**(-33.5) = 8.23181D-11 +C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 +C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / +C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DNRM2 + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CUTHI,CUTLO,HITEST,ONE,SUM,XMAX,ZERO + INTEGER + + I,J,NEXT,NN + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT,FLOAT + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.0D0,1.0D0/ + DATA + + CUTLO,CUTHI/8.232D-11,1.304D19/ + + +C***FIRST EXECUTABLE STATEMENT DNRM2 + + + XMAX = ZERO + IF(N .GT. 0) GO TO 10 + DNRM2 = ZERO + GO TO 300 + + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 +C 20 GO TO NEXT,(30, 50, 70, 110) + 20 GO TO NEXT + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO + +C PHASE 1. SUM IS ZERO + + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 + +C PREPARE FOR PHASE 4. + + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 + +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. + + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 + +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. + + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 + + +C PREPARE FOR PHASE 3. + + 75 SUM = (SUM * XMAX) * XMAX + + +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) + + 85 HITEST = CUTHI/FLOAT( N ) + +C PHASE 3. SUM IS MID-RANGE. NO SCALING. + + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2 = DSQRT( SUM ) + GO TO 300 + + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 + +C END OF MAIN LOOP. + +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. + + DNRM2 = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END +*DPODI + SUBROUTINE DPODI(A,LDA,N,DET,JOB) +C***BEGIN PROLOGUE DPODI +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1B,D3B1B +C***KEYWORDS DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE +C PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C***DESCRIPTION +C DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN +C DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C ON ENTRY +C A DOUBLE PRECISION(LDA, N) +C THE OUTPUT A FROM DPOCO OR DPOFA +C OR THE OUTPUT X FROM DQRDC. +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C N INTEGER +C THE ORDER OF THE MATRIX A . +C JOB INTEGER +C = 11 BOTH DETERMINANT AND INVERSE. +C = 01 INVERSE ONLY. +C = 10 DETERMINANT ONLY. +C ON RETURN +C A IF DPOCO OR DPOFA WAS USED TO FACTOR A , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(A) . +C IF DQRDC WAS USED TO DECOMPOSE X , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X) +C WHERE TRANS(X) IS THE TRANSPOSE. +C ELEMENTS OF A BELOW THE DIAGONAL ARE UNCHANGED. +C IF THE UNITS DIGIT OF JOB IS ZERO, A IS UNCHANGED. +C DET DOUBLE PRECISION(2) +C DETERMINANT OF A OR OF TRANS(X)*X IF REQUESTED. +C OTHERWISE NOT REFERENCED. +C DETERMINANT = DET(1) * 10.0**DET(2) +C WITH 1.0 .LE. DET(1) .LT. 10.0 +C OR DET(1) .EQ. 0.0 . +C ERROR CONDITION +C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS +C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. +C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY +C AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 . +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DSCAL +C***END PROLOGUE DPODI + +C...SCALAR ARGUMENTS + INTEGER JOB,LDA,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,*),DET(*) + +C...LOCAL SCALARS + DOUBLE PRECISION S,T + INTEGER I,J,JM1,K,KP1 + +C...EXTERNAL SUBROUTINES + EXTERNAL DAXPY,DSCAL + +C...INTRINSIC FUNCTIONS + INTRINSIC MOD + + +C***FIRST EXECUTABLE STATEMENT DPODI + + + IF (JOB/10 .EQ. 0) GO TO 70 + DET(1) = 1.0D0 + DET(2) = 0.0D0 + S = 10.0D0 + DO 50 I = 1, N + DET(1) = A(I,I)**2*DET(1) +C ...EXIT + IF (DET(1) .EQ. 0.0D0) GO TO 60 + 10 IF (DET(1) .GE. 1.0D0) GO TO 20 + DET(1) = S*DET(1) + DET(2) = DET(2) - 1.0D0 + GO TO 10 + 20 CONTINUE + 30 IF (DET(1) .LT. S) GO TO 40 + DET(1) = DET(1)/S + DET(2) = DET(2) + 1.0D0 + GO TO 30 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + +C COMPUTE INVERSE(R) + + IF (MOD(JOB,10) .EQ. 0) GO TO 140 + DO 100 K = 1, N + A(K,K) = 1.0D0/A(K,K) + T = -A(K,K) + CALL DSCAL(K-1,T,A(1,K),1) + KP1 = K + 1 + IF (N .LT. KP1) GO TO 90 + DO 80 J = KP1, N + T = A(K,J) + A(K,J) = 0.0D0 + CALL DAXPY(K,T,A(1,K),1,A(1,J),1) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C FORM INVERSE(R) * TRANS(INVERSE(R)) + + DO 130 J = 1, N + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 120 + DO 110 K = 1, JM1 + T = A(K,J) + CALL DAXPY(K,T,A(1,J),1,A(1,K),1) + 110 CONTINUE + 120 CONTINUE + T = A(J,J) + CALL DSCAL(J,T,A(1,J),1) + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DQRDC + SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) +C***BEGIN PROLOGUE DQRDC +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D5 +C***KEYWORDS DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK, +C MATRIX,ORTHOGONAL TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR FACTORI- +C ZATION OF N BY P MATRIX X. COLUMN PIVOTING IS OPTIONAL. +C***DESCRIPTION +C DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR +C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING +C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE +C PERFORMED AT THE USER'S OPTION. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N. +C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE +C COMPUTED. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX X. +C P INTEGER. +C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. +C JPVT INTEGER(P). +C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION +C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X +C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE +C VALUE OF JPVT(K). +C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL +C COLUMN. +C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN. +C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN. +C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS +C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL +C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS +C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY +C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE +C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN +C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST +C REDUCED NORM. JPVT IS NOT REFERENCED IF +C JOB .EQ. 0. +C WORK DOUBLE PRECISION(P). +C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF +C JOB .EQ. 0. +C JOB INTEGER. +C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING. +C IF JOB .EQ. 0, NO PIVOTING IS DONE. +C IF JOB .NE. 0, PIVOTING IS DONE. +C ON RETURN +C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER +C TRIANGULAR MATRIX R OF THE QR FACTORIZATION. +C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM +C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION +C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS +C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT +C OF THE ORIGINAL MATRIX X BUT THAT OF X +C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER +C THE ORTHOGONAL PART OF THE DECOMPOSITION. +C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE +C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO +C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT,DNRM2,DSCAL,DSWAP +C***END PROLOGUE DQRDC + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDX,N,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + QRAUX(*),WORK(*),X(LDX,*) + INTEGER + + JPVT(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + MAXNRM,NRMXL,T,TT + INTEGER + + J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU + LOGICAL + + NEGJ,SWAPJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY,DSCAL,DSWAP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN,DSQRT,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DQRDC + + + PL = 1 + PU = 0 + IF (JOB .EQ. 0) GO TO 60 + +C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS +C ACCORDING TO JPVT. + + DO 20 J = 1, P + SWAPJ = JPVT(J) .GT. 0 + NEGJ = JPVT(J) .LT. 0 + JPVT(J) = J + IF (NEGJ) JPVT(J) = -J + IF (.NOT.SWAPJ) GO TO 10 + IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) + JPVT(J) = JPVT(PL) + JPVT(PL) = J + PL = PL + 1 + 10 CONTINUE + 20 CONTINUE + PU = P + DO 50 JJ = 1, P + J = P - JJ + 1 + IF (JPVT(J) .GE. 0) GO TO 40 + JPVT(J) = -JPVT(J) + IF (J .EQ. PU) GO TO 30 + CALL DSWAP(N,X(1,PU),1,X(1,J),1) + JP = JPVT(PU) + JPVT(PU) = JPVT(J) + JPVT(J) = JP + 30 CONTINUE + PU = PU - 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + +C COMPUTE THE NORMS OF THE FREE COLUMNS. + + IF (PU .LT. PL) GO TO 80 + DO 70 J = PL, PU + QRAUX(J) = DNRM2(N,X(1,J),1) + WORK(J) = QRAUX(J) + 70 CONTINUE + 80 CONTINUE + +C PERFORM THE HOUSEHOLDER REDUCTION OF X. + + LUP = MIN0(N,P) + DO 200 L = 1, LUP + IF (L .LT. PL .OR. L .GE. PU) GO TO 120 + +C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT +C INTO THE PIVOT POSITION. + + MAXNRM = 0.0D0 + MAXJ = L + DO 100 J = L, PU + IF (QRAUX(J) .LE. MAXNRM) GO TO 90 + MAXNRM = QRAUX(J) + MAXJ = J + 90 CONTINUE + 100 CONTINUE + IF (MAXJ .EQ. L) GO TO 110 + CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) + QRAUX(MAXJ) = QRAUX(L) + WORK(MAXJ) = WORK(L) + JP = JPVT(MAXJ) + JPVT(MAXJ) = JPVT(L) + JPVT(L) = JP + 110 CONTINUE + 120 CONTINUE + QRAUX(L) = 0.0D0 + IF (L .EQ. N) GO TO 190 + +C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. + + NRMXL = DNRM2(N-L+1,X(L,L),1) + IF (NRMXL .EQ. 0.0D0) GO TO 180 + IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L)) + CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1) + X(L,L) = 1.0D0 + X(L,L) + +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, +C UPDATING THE NORMS. + + LP1 = L + 1 + IF (P .LT. LP1) GO TO 170 + DO 160 J = LP1, P + T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) + CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) + IF (J .LT. PL .OR. J .GT. PU) GO TO 150 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 150 + TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2 + TT = DMAX1(TT,0.0D0) + T = TT + TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 + IF (TT .EQ. 1.0D0) GO TO 130 + QRAUX(J) = QRAUX(J)*DSQRT(T) + GO TO 140 + 130 CONTINUE + QRAUX(J) = DNRM2(N-L,X(L+1,J),1) + WORK(J) = QRAUX(J) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + +C SAVE THE TRANSFORMATION. + + QRAUX(L) = X(L,L) + X(L,L) = -NRMXL + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DQRSL + SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) +C***BEGIN PROLOGUE DQRSL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D9,D2A1 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX, +C ORTHOGONAL TRIANGULAR,SOLVE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C***DESCRIPTION +C DQRSL APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX +C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) +C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL +C N X P MATRIX X THAT WAS INPUT TO DQRDC (IF NO PIVOTING WAS +C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR +C ORIGINAL ORDER). DQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q +C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT +C XK = Q * (R) +C (0) +C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS +C X AND QRAUX. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P). +C X CONTAINS THE OUTPUT OF DQRDC. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST +C HAVE THE SAME VALUE AS N IN DQRDC. +C K INTEGER. +C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K +C MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE +C SAME AS IN THE CALLING SEQUENCE TO DQRDC. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM DQRDC. +C Y DOUBLE PRECISION(N) +C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED +C BY DQRSL. +C JOB INTEGER. +C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS +C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING +C MEANING. +C IF A .NE. 0, COMPUTE QY. +C IF B,C,D, OR E .NE. 0, COMPUTE QTY. +C IF C .NE. 0, COMPUTE B. +C IF D .NE. 0, COMPUTE RSD. +C IF E .NE. 0, COMPUTE XB. +C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB +C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR +C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING +C SEQUENCE. +C ON RETURN +C QY DOUBLE PRECISION(N). +C QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN +C REQUESTED. +C QTY DOUBLE PRECISION(N). +C QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS +C BEEN REQUESTED. HERE TRANS(Q) IS THE +C TRANSPOSE OF THE MATRIX Q. +C B DOUBLE PRECISION(K) +C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM +C MINIMIZE NORM2(Y - XK*B), +C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT +C IF PIVOTING WAS REQUESTED IN DQRDC, THE J-TH +C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J) +C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO DQRDC.) +C RSD DOUBLE PRECISION(N). +C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS +C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE +C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK. +C XB DOUBLE PRECISION(N). +C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO +C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE +C OF X. +C INFO INTEGER. +C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS +C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN +C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO +C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED. +C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED +C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE +C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM. +C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME +C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A +C FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE +C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS +C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE +C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE +C COMPUTED. THUS THE CALLING SEQUENCE +C CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) +C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD +C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING +C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR +C A SINGLE CALLING SEQUENCE. +C 1. (Y,QTY,B) (RSD) (XB) (QY) +C 2. (Y,QTY,RSD) (B) (XB) (QY) +C 3. (Y,QTY,XB) (B) (RSD) (QY) +C 4. (Y,QY) (QTY,B) (RSD) (XB) +C 5. (Y,QY) (QTY,RSD) (B) (XB) +C 6. (Y,QY) (QTY,XB) (B) (RSD) +C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO +C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DCOPY,DDOT +C***END PROLOGUE DQRSL + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,K,LDX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*), + + Y(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,TEMP + INTEGER + + I,J,JJ,JU,KP1 + LOGICAL + + CB,CQTY,CQY,CR,CXB + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY,DCOPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN0,MOD + + +C***FIRST EXECUTABLE STATEMENT DQRSL + + + INFO = 0 + +C DETERMINE WHAT IS TO BE COMPUTED. + + CQY = JOB/10000 .NE. 0 + CQTY = MOD(JOB,10000) .NE. 0 + CB = MOD(JOB,1000)/100 .NE. 0 + CR = MOD(JOB,100)/10 .NE. 0 + CXB = MOD(JOB,10) .NE. 0 + JU = MIN0(K,N-1) + +C SPECIAL ACTION WHEN N=1. + + IF (JU .NE. 0) GO TO 40 + IF (CQY) QY(1) = Y(1) + IF (CQTY) QTY(1) = Y(1) + IF (CXB) XB(1) = Y(1) + IF (.NOT.CB) GO TO 30 + IF (X(1,1) .NE. 0.0D0) GO TO 10 + INFO = 1 + GO TO 20 + 10 CONTINUE + B(1) = Y(1)/X(1,1) + 20 CONTINUE + 30 CONTINUE + IF (CR) RSD(1) = 0.0D0 + GO TO 250 + 40 CONTINUE + +C SET UP TO COMPUTE QY OR QTY. + + IF (CQY) CALL DCOPY(N,Y,1,QY,1) + IF (CQTY) CALL DCOPY(N,Y,1,QTY,1) + IF (.NOT.CQY) GO TO 70 + +C COMPUTE QY. + + DO 60 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 50 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1) + X(J,J) = TEMP + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IF (.NOT.CQTY) GO TO 100 + +C COMPUTE TRANS(Q)*Y. + + DO 90 J = 1, JU + IF (QRAUX(J) .EQ. 0.0D0) GO TO 80 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1) + X(J,J) = TEMP + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C SET UP TO COMPUTE B, RSD, OR XB. + + IF (CB) CALL DCOPY(K,QTY,1,B,1) + KP1 = K + 1 + IF (CXB) CALL DCOPY(K,QTY,1,XB,1) + IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1) + IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 + DO 110 I = KP1, N + XB(I) = 0.0D0 + 110 CONTINUE + 120 CONTINUE + IF (.NOT.CR) GO TO 140 + DO 130 I = 1, K + RSD(I) = 0.0D0 + 130 CONTINUE + 140 CONTINUE + IF (.NOT.CB) GO TO 190 + +C COMPUTE B. + + DO 170 JJ = 1, K + J = K - JJ + 1 + IF (X(J,J) .NE. 0.0D0) GO TO 150 + INFO = J +C ......EXIT + GO TO 180 + 150 CONTINUE + B(J) = B(J)/X(J,J) + IF (J .EQ. 1) GO TO 160 + T = -B(J) + CALL DAXPY(J-1,T,X(1,J),1,B,1) + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 + +C COMPUTE RSD OR XB AS REQUIRED. + + DO 230 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 220 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + IF (.NOT.CR) GO TO 200 + T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1) + 200 CONTINUE + IF (.NOT.CXB) GO TO 210 + T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1) + 210 CONTINUE + X(J,J) = TEMP + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN + END +*DROT + SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS) +C***BEGIN PROLOGUE DROT +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A8 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE APPLY D.P. GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C DC D.P. ELEMENT OF ROTATION MATRIX +C DS D.P. ELEMENT OF ROTATION MATRIX +C --OUTPUT-- +C DX ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C DY ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C MULTIPLY THE 2 X 2 MATRIX ( DC DS) TIMES THE 2 X N MATRIX (DX**T) +C (-DS DC) (DY**T) +C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN +C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +C LX = (-INCX)*N, AND SIMILARLY FOR DY USING LY AND INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DC,DS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,W,Z,ZERO + INTEGER + + I,KX,KY,NSTEPS + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.D0,1.D0/ + + +C***FIRST EXECUTABLE STATEMENT DROT + + + IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 + IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 + + NSTEPS=INCX*N + DO 10 I=1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=DC*W+DS*Z + DY(I)=-DS*W+DC*Z + 10 CONTINUE + GO TO 40 + + 20 CONTINUE + KX=1 + KY=1 + + IF(INCX .LT. 0) KX=1-(N-1)*INCX + IF(INCY .LT. 0) KY=1-(N-1)*INCY + + DO 30 I=1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=DC*W+DS*Z + DY(KY)=-DS*W+DC*Z + KX=KX+INCX + KY=KY+INCY + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DROTG + SUBROUTINE DROTG(DA,DB,DC,DS) +C***BEGIN PROLOGUE DROTG +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1B10 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE CONSTRUCT D.P. PLANE GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C DA DOUBLE PRECISION SCALAR +C DB DOUBLE PRECISION SCALAR +C --OUTPUT-- +C DA DOUBLE PRECISION RESULT R +C DB DOUBLE PRECISION RESULT Z +C DC DOUBLE PRECISION RESULT +C DS DOUBLE PRECISION RESULT +C DESIGNED BY C. L. LAWSON, JPL, 1977 SEPT 08 +C CONSTRUCT THE GIVENS TRANSFORMATION +C ( DC DS ) +C G = ( ) , DC**2 + DS**2 = 1 , +C (-DS DC ) +C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . +C THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN +C STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH +C ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM. +C IF Z=1 SET DC=0.D0 AND DS=1.D0 +C IF DABS(Z) .LT. 1 SET DC=DSQRT(1-Z**2) AND DS=Z +C IF DABS(Z) .GT. 1 SET DC=1/Z AND DS=DSQRT(1-DC**2) +C NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL +C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROTG + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA,DB,DC,DS + +C...LOCAL SCALARS + DOUBLE PRECISION + + R,U,V + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT + + +C***FIRST EXECUTABLE STATEMENT DROTG + + + IF (DABS(DA) .LE. DABS(DB)) GO TO 10 + +C *** HERE DABS(DA) .GT. DABS(DB) *** + + U = DA + DA + V = DB / U + +C NOTE THAT U AND R HAVE THE SIGN OF DA + + R = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DC IS POSITIVE + + DC = DA / R + DS = V * (DC + DC) + DB = DS + DA = R + RETURN + +C *** HERE DABS(DA) .LE. DABS(DB) *** + + 10 IF (DB .EQ. 0.D0) GO TO 20 + U = DB + DB + V = DA / U + +C NOTE THAT U AND R HAVE THE SIGN OF DB +C (R IS IMMEDIATELY STORED IN DA) + + DA = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DS IS POSITIVE + + DS = DB / DA + DC = V * (DS + DS) + IF (DC .EQ. 0.D0) GO TO 15 + DB = 1.D0 / DC + RETURN + 15 DB = 1.D0 + RETURN + +C *** HERE DA = DB = 0.D0 *** + + 20 DC = 1.D0 + DS = 0.D0 + RETURN + + END +*DSCAL + SUBROUTINE DSCAL(N,DA,DX,INCX) +C***BEGIN PROLOGUE DSCAL +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A6 +C***KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR SCALE X = A*X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALE FACTOR +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DX DOUBLE PRECISION RESULT (UNCHANGED IF N.LE.0) +C REPLACE DOUBLE PRECISION DX BY DOUBLE PRECISION DA*DX. +C FOR I = 0 TO N-1, REPLACE DX(1+I*INCX) WITH DA * DX(1+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSCAL + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSCAL + + + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I = 1,NS,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + END +*DSWAP + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DSWAP +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE INTERCHANGE D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DX INPUT VECTOR DY (UNCHANGED IF N .LE. 0) +C DY INPUT VECTOR DX (UNCHANGED IF N .LE. 0) +C INTERCHANGE DOUBLE PRECISION DX AND DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, INTERCHANGE DX(LX+I*INCX) AND DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSWAP + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DTEMP1,DTEMP2,DTEMP3 + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSWAP + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. + + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN + 60 CONTINUE + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + NS = N*INCX + DO 70 I=1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END +*DTRCO + SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB) +C***BEGIN PROLOGUE DTRCO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX,TRIANGULAR +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C***DESCRIPTION +C DTRCO ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C JOB INTEGER +C = 0 T IS LOWER TRIANGULAR. +C = NONZERO T IS UPPER TRIANGULAR. +C ON RETURN +C RCOND DOUBLE PRECISION +C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . +C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS +C IN T AND B OF SIZE EPSILON MAY CAUSE +C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . +C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION +C 1.0 + RCOND .EQ. 1.0 +C IS TRUE, THEN T MAY BE SINGULAR TO WORKING +C PRECISION. IN PARTICULAR, RCOND IS ZERO IF +C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE +C UNDERFLOWS. +C Z DOUBLE PRECISION(N) +C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. +C IF T IS CLOSE TO A SINGULAR MATRIX, THEN Z IS +C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DSCAL +C***END PROLOGUE DTRCO + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + RCOND + INTEGER + + JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,*),Z(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + EK,S,SM,TNORM,W,WK,WKM,YNORM + INTEGER + + I1,J,J1,J2,K,KK,L + LOGICAL + + LOWER + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DASUM + EXTERNAL + + DASUM + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY,DSCAL + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN + + +C***FIRST EXECUTABLE STATEMENT DTRCO + + + LOWER = JOB .EQ. 0 + +C COMPUTE 1-NORM OF T + + TNORM = 0.0D0 + DO 10 J = 1, N + L = J + IF (LOWER) L = N + 1 - J + I1 = 1 + IF (LOWER) I1 = J + TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1)) + 10 CONTINUE + +C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . +C TRANS(T) IS THE TRANSPOSE OF T . +C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL +C GROWTH IN THE ELEMENTS OF Y . +C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. + +C SOLVE TRANS(T)*Y = E + + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 KK = 1, N + K = KK + IF (LOWER) K = N + 1 - KK + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30 + S = DABS(T(K,K))/DABS(EK-Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (T(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/T(K,K) + WKM = WKM/T(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + IF (KK .EQ. N) GO TO 90 + J1 = K + 1 + IF (LOWER) J1 = 1 + J2 = N + IF (LOWER) J2 = K - 1 + DO 60 J = J1, J2 + SM = SM + DABS(Z(J)+WKM*T(K,J)) + Z(J) = Z(J) + WK*T(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + W = WKM - WK + WK = WKM + DO 70 J = J1, J2 + Z(J) = Z(J) + W*T(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + + YNORM = 1.0D0 + +C SOLVE T*Z = Y + + DO 130 KK = 1, N + K = N + 1 - KK + IF (LOWER) K = KK + IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110 + S = DABS(T(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 110 CONTINUE + IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K) + IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + I1 = 1 + IF (LOWER) I1 = K + 1 + IF (KK .GE. N) GO TO 120 + W = -Z(K) + CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1) + 120 CONTINUE + 130 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + + IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM + IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END +*DTRSL + SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO) +C***BEGIN PROLOGUE DTRSL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, +C TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE SOLVES SYSTEMS OF THE FORM T*X=B OR TRANS(T)*X=B WHERE T +C IS A TRIANGULAR MATRIX OF ORDER N. +C***DESCRIPTION +C DTRSL SOLVES SYSTEMS OF THE FORM +C T * X = B +C OR +C TRANS(T) * X = B +C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. HERE TRANS(T) +C DENOTES THE TRANSPOSE OF THE MATRIX T. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE MATRIX OF THE SYSTEM. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C B DOUBLE PRECISION(N). +C B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM. +C JOB INTEGER +C JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED. +C IF JOB IS +C 00 SOLVE T*X=B, T LOWER TRIANGULAR, +C 01 SOLVE T*X=B, T UPPER TRIANGULAR, +C 10 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 11 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C ON RETURN +C B B CONTAINS THE SOLUTION, IF INFO .EQ. 0. +C OTHERWISE B IS UNALTERED. +C INFO INTEGER +C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR. +C OTHERWISE INFO CONTAINS THE INDEX OF +C THE FIRST ZERO DIAGONAL ELEMENT OF T. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DTRSL + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),T(LDT,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP + INTEGER + + CASE,J,JJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DTRSL + + +C BEGIN BLOCK PERMITTING ...EXITS TO 150 + +C CHECK FOR ZERO DIAGONAL ELEMENTS. + + DO 10 INFO = 1, N +C ......EXIT + IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150 + 10 CONTINUE + INFO = 0 + +C DETERMINE THE TASK AND GO TO IT. + + CASE = 1 + IF (MOD(JOB,10) .NE. 0) CASE = 2 + IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 + GO TO (20,50,80,110), CASE + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + + 20 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 40 + DO 30 J = 2, N + TEMP = -B(J-1) + CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) + B(J) = B(J)/T(J,J) + 30 CONTINUE + 40 CONTINUE + GO TO 140 + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + + 50 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 70 + DO 60 JJ = 2, N + J = N - JJ + 1 + TEMP = -B(J+1) + CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1) + B(J) = B(J)/T(J,J) + 60 CONTINUE + 70 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + + 80 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 100 + DO 90 JJ = 2, N + J = N - JJ + 1 + B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1) + B(J) = B(J)/T(J,J) + 90 CONTINUE + 100 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + + 110 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 130 + DO 120 J = 2, N + B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) + B(J) = B(J)/T(J,J) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + RETURN + END +*IDAMAX + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C***BEGIN PROLOGUE IDAMAX +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A2 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE FIND LARGEST COMPONENT OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C IDAMAX SMALLEST INDEX (ZERO IF N .LE. 0) +C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX. +C IDAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(DX(1-INCX+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE IDAMAX + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DMAX,XMAG + INTEGER + + I,II,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS + + +C***FIRST EXECUTABLE STATEMENT IDAMAX + + + IDAMAX = 0 + IF(N.LE.0) RETURN + IDAMAX = 1 + IF(N.LE.1)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + DMAX = DABS(DX(1)) + NS = N*INCX + II = 1 + DO 10 I = 1,NS,INCX + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 5 + IDAMAX = II + DMAX = XMAG + 5 II = II + 1 + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = XMAG + 30 CONTINUE + RETURN + END diff --git a/dataassim/math/optimization/odrpack95/d_mprec0.f b/dataassim/math/optimization/odrpack95/d_mprec0.f new file mode 100644 index 0000000..edaa203 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/d_mprec0.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/d_odr.f b/dataassim/math/optimization/odrpack95/d_odr.f new file mode 100644 index 0000000..df0db44 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/d_odr.f @@ -0,0 +1,10985 @@ +*DODR + SUBROUTINE 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) +C***BEGIN PROLOGUE DODR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODR + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK, + + M,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,PARTOL,SSTOL,TAUFAC,ZERO + INTEGER + + IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1) + INTEGER + + IFIXB(1),IFIXX(1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NEGONE: THE VALUE -1.0D0. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODR + + +C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES + + IFIXB(1) = -1 + IFIXX(1,1) = -1 + LDIFX = 1 + NDIGIT = -1 + TAUFAC = NEGONE + SSTOL = NEGONE + PARTOL = NEGONE + MAXIT = -1 + STPB(1) = NEGONE + STPD(1,1) = NEGONE + LDSTPD = 1 + SCLB(1) = NEGONE + SCLD(1,1) = NEGONE + LDSCLD = 1 + + SHORT = .TRUE. + + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, 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) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + + RETURN + + END +*DODRC + SUBROUTINE 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) +C***BEGIN PROLOGUE DODRC +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (LONG CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODRC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,ZERO + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WD1(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODRC + + + SHORT = .FALSE. + + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, 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) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + + RETURN + + END +*DACCES + SUBROUTINE DACCES + + (N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) +C***BEGIN PROLOGUE DACCES +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DIWINF,DWINF +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS +C***END PROLOGUE DACESS + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + + RNORMS,RVAR,SSTOL,TAU,TAUFAC + INTEGER + + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, + + LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, + + NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WORK(LWORK),WSS(3) + INTEGER + + IWORK(LIWORK) + +C...LOCAL SCALARS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I, + + DELTAI,DELTNI,DELTSI,DIFFI,EPSI, + + EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, + + MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, + + NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIWINF,DWINF + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IDFI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPR1: THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORTS. +C IPR2F: THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE +C FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVT: THE PIVOT VECTOR. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT. +C LDTTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGA: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERS: THE SAVED PREDICTED RELATIVE REDUCTION IN THE +C SUM-OF-SQUARES. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORMS: THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVAR: THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES USED FOR BETA. +C SCLD: THE SCALING VALUES USED FOR DELTA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG- +C CALL (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSS: THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. +C WSSI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1). +C WSSDEI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2). +C WSSEPI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3). +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DACCES + + +C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + + IF (ACCESS) THEN + +C SET STARTING LOCATIONS FOR WORK VECTORS + + JPVT = JPVTI + OMEGA = OMEGAI + QRAUX = QRAUXI + SD = SDI + VCV = VCVI + U = UI + WRK1 = WRK1I + WRK2 = WRK2I + WRK3 = WRK3I + WRK4 = WRK4I + WRK5 = WRK5I + WRK6 = WRK6I + +C ACCESS VALUES FROM THE WORK VECTORS + + ACTRS = WORK(ACTRSI) + ALPHA = WORK(ALPHAI) + ETA = WORK(ETAI) + OLMAVG = WORK(OLMAVI) + PARTOL = WORK(PARTLI) + PNORM = WORK(PNORMI) + PRERS = WORK(PRERSI) + RCOND = WORK(RCONDI) + WSS(1) = WORK(WSSI) + WSS(2) = WORK(WSSDEI) + WSS(3) = WORK(WSSEPI) + RVAR = WORK(RVARI) + RNORMS = WORK(RNORSI) + SSTOL = WORK(SSTOLI) + TAU = WORK(TAUI) + TAUFAC = WORK(TAUFCI) + + NETA = IWORK(NETAI) + IRANK = IWORK(IRANKI) + JOB = IWORK(JOBI) + LUNRPT = IWORK(LUNRPI) + MAXIT = IWORK(MAXITI) + NFEV = IWORK(NFEVI) + NITER = IWORK(NITERI) + NJEV = IWORK(NJEVI) + NNZW = IWORK(NNZWI) + NPP = IWORK(NPPI) + IDF = IWORK(IDFI) + INT2 = IWORK(INT2I) + +C SET UP PRINT CONTROL VARIABLES + + IPRINT = IWORK(IPRINI) + + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + + ELSE + +C STORE VALUES INTO THE WORK VECTORS + + WORK(ACTRSI) = ACTRS + WORK(ALPHAI) = ALPHA + WORK(OLMAVI) = OLMAVG + WORK(PARTLI) = PARTOL + WORK(PNORMI) = PNORM + WORK(PRERSI) = PRERS + WORK(RCONDI) = RCOND + WORK(WSSI) = WSS(1) + WORK(WSSDEI) = WSS(2) + WORK(WSSEPI) = WSS(3) + WORK(RVARI) = RVAR + WORK(RNORSI) = RNORMS + WORK(SSTOLI) = SSTOL + WORK(TAUI) = TAU + + IWORK(IRANKI) = IRANK + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NITERI) = NITER + IWORK(NJEVI) = NJEV + IWORK(IDFI) = IDF + IWORK(INT2I) = INT2 + END IF + + RETURN + END +*DESUBI + SUBROUTINE DESUBI + + (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) +C***BEGIN PROLOGUE DESUBI +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE E = WD + ALPHA*TT**2 +C***END PROLOGUE DESUBI + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA + INTEGER + + LDTT,LDWD,LD2WD,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J,J1,J2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C E: THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2 +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF RESPONSES PER OBSERVATION. +C TT: THE SCALING VALUES USED FOR DELTA. +C WD: THE SQUARED DELTA WEIGHTS, D**2. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DESUBI + + +C N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE +C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS +C OF THE MULTIPLY SUBSCRIPTED ARRAYS. + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WD(1,1,1).GE.ZERO) THEN + IF (LDWD.GE.N) THEN +C THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED + + IF (LD2WD.EQ.1) THEN +C THE ARRAYS STORED IN WD ARE DIAGONAL + CALL DZERO(M,M,E,M) + DO 10 J=1,M + E(J,J) = WD(I,1,J) + 10 CONTINUE + ELSE +C THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES + DO 30 J1=1,M + DO 20 J2=1,M + E(J1,J2) = WD(I,J1,J2) + 20 CONTINUE + 30 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 110 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 110 CONTINUE + ELSE + DO 120 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 120 CONTINUE + END IF + ELSE + DO 130 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 130 CONTINUE + END IF + ELSE +C WD IS AN M BY M MATRIX + + IF (LD2WD.EQ.1) THEN +C THE ARRAY STORED IN WD IS DIAGONAL + CALL DZERO(M,M,E,M) + DO 140 J=1,M + E(J,J) = WD(1,1,J) + 140 CONTINUE + ELSE +C THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES + DO 160 J1=1,M + DO 150 J2=1,M + E(J1,J2) = WD(1,J1,J2) + 150 CONTINUE + 160 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 210 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 210 CONTINUE + ELSE + DO 220 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 220 CONTINUE + END IF + ELSE + DO 230 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 230 CONTINUE + END IF + END IF + ELSE +C WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1)) + CALL DZERO(M,M,E,M) + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 310 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 + 310 CONTINUE + ELSE + DO 320 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 + 320 CONTINUE + END IF + ELSE + DO 330 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 + 330 CONTINUE + END IF + END IF + + RETURN + END +*DETAF + SUBROUTINE DETAF + + (FCN, + + N,M,NP,NQ, + + XPLUSD,BETA,EPSMAC,NROW, + + PARTMP,PV0, + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WRK1,WRK2,WRK6,WRK7) +C***BEGIN PROLOGUE DETAF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS +C (ADAPTED FROM STARPAC SUBROUTINE ETAFUN) +C***END PROLOGUE DETAF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),PARTMP(NP),PV0(N,NQ), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO + INTEGER + + J,K,L + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10,MAX,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P1,P2,P5,ONE,TWO,HUNDRD + + /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: PARAMETERS OF THE LOCAL FIT. +C B: PARAMETERS OF THE LOCAL FIT. +C BETA: THE FUNCTION PARAMETERS. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE NOISE IN THE MODEL RESULTS. +C FAC: A FACTOR USED IN THE COMPUTATIONS. +C HUNDRD: THE VALUE 1.0D2. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C P1: THE VALUE 0.1D0. +C P2: THE VALUE 0.2D0. +C P5: THE VALUE 0.5D0. +C PARTMP: THE MODEL PARAMETERS. +C PV0: THE ORIGINAL PREDICTED VALUES. +C STP: A SMALL VALUE USED TO PERTURB THE PARAMETERS. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C WRK7: A WORK ARRAY OF (5 BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DETAF + + + STP = HUNDRD*EPSMAC + ETA = EPSMAC + + DO 40 J=-2,2 + IF (J.EQ.0) THEN + DO 10 L=1,NQ + WRK7(J,L) = PV0(NROW,L) + 10 CONTINUE + ELSE + DO 20 K=1,NP + IF (IFIXB(1).LT.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE IF (IFIXB(K).NE.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE + PARTMP(K) = BETA(K) + END IF + 20 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + PARTMP,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1,ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + WRK7(J,L) = WRK2(NROW,L) + 30 CONTINUE + END IF + 40 CONTINUE + + DO 100 L=1,NQ + A = ZERO + B = ZERO + DO 50 J=-2,2 + A = A + WRK7(J,L) + B = B + J*WRK7(J,L) + 50 CONTINUE + A = P2*A + B = P1*B + IF ((WRK7(0,L).NE.ZERO) .AND. + + (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN + FAC = ONE/ABS(WRK7(0,L)) + ELSE + FAC = ONE + END IF + DO 60 J=-2,2 + WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) + ETA = MAX(WRK7(J,L),ETA) + 60 CONTINUE + 100 CONTINUE + NETA = MAX(TWO,P5-LOG10(ETA)) + + RETURN + END +*DEVJAC + SUBROUTINE DEVJAC + + (FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN, + + STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) +C***BEGIN PROLOGUE DEVJAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA +C***END PROLOGUE DEVJAC + +C...SCALAR ARGUMENTS + INTEGER + + INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, + + M,N,NETA,NFEV,NJEV,NP,NQ + LOGICAL + + ANAJAC,CDJAC,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), + + WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + INTEGER + + IDEVAL,J,K,K1,L + DOUBLE PRECISION + + ZERO + LOGICAL + + ERROR + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...DATA STATEMENTS + DATA ZERO + + /0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C DELTA: THE ESTIMATED VALUES OF DELTA. +C ERROR: THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO +C VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER +C THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION +C BY COMPUTING FJACD IN THE OLS CASE. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER-SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISTOP: THE VARIABLE DESIGNATING THAT THE USER WISHES THE +C COMPUTATIONS STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWE: THE LEADING DIMENSION OF ARRAYS WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LD2WE: THE SECOND DIMENSION OF ARRAYS WE AND WE1. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C WE1: THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C X: THE INDEPENDENT VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DEVJAC + + +C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA + + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + +C COMPUTE XPLUSD = X + DELTA + + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND +C THE JACOBIAN WRT DELTA (FJACD) + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + IF (ANAJAC) THEN + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV+1 + END IF +C MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO + IF (ISODR) THEN + DO 10 L=1,NQ + CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) + 10 CONTINUE + END IF + ELSE IF (CDJAC) THEN + CALL DJACCD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + ELSE + CALL DJACFD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + END IF + IF (ISTOP.LT.0) THEN + RETURN + ELSE IF (.NOT.ISODR) THEN +C TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD +C WITHIN FCN IN THE OLS CASE + ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO + IF (ERROR) THEN + INFO = 50300 + RETURN + END IF + END IF + +C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS + + IF (IFIXB(1).LT.0) THEN + DO 20 K=1,NP + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP) + 20 CONTINUE + ELSE + K1 = 0 + DO 30 K=1,NP + IF (IFIXB(K).GE.1) THEN + K1 = K1 + 1 + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP) + END IF + 30 CONTINUE + END IF + +C WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE + + IF (ISODR) THEN + DO 40 J=1,M + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACD(1,J,1),N*M,FJACD(1,J,1),N*M) + 40 CONTINUE + END IF + + RETURN + END +*DFCTR + SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) +C***BEGIN PROLOGUE DFCTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT +C***DATE WRITTEN 910706 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A +C MODIFIED CHOLESKY FACTORIZATION +C (ADAPTED FROM LINPACK SUBROUTINE DPOFA) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DFCTR + +C...SCALAR ARGUMENTS + INTEGER INFO,LDA,N + LOGICAL OKSEMI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,N) + +C...LOCAL SCALARS + DOUBLE PRECISION XI,S,T,TEN,ZERO + INTEGER J,K + +C...EXTERNAL FUNCTIONS + EXTERNAL DMPREC,DDOT + DOUBLE PRECISION DMPREC,DDOT + +C...INTRINSIC FUNCTIONS + INTRINSIC SQRT + +C...DATA STATEMENTS + DATA + + ZERO,TEN + + /0.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE FACTORED. UPON RETURN, A CONTAINS THE +C UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R +C WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO +C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. +C I: AN INDEXING VARIABLE. +C INFO: AN IDICATOR VARIABLE, WHERE IF +C INFO = 0 THEN FACTORIZATION WAS COMPLETED +C INFO = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR +C OF ORDER K IS NOT POSITIVE (SEMI)DEFINITE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A. +C OKSEMI: THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE +C SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO +C BE POSITIVE DEFINITE (OKSEMI=FALSE). +C TEN: THE VALUE 10.0D0. +C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTR + + +C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS. + XI = -TEN*DMPREC() + +C COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A + DO 20 J=1,N + INFO = J + S = ZERO + DO 10 K=1,J-1 + IF (A(K,K).EQ.ZERO) THEN + T = ZERO + ELSE + T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) + T = T/A(K,K) + END IF + A(K,J) = T + S = S + T*T + 10 CONTINUE + S = A(J,J) - S +C ......EXIT + IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN + RETURN + ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN + RETURN + ELSE IF (S.LE.ZERO) THEN + A(J,J) = ZERO + ELSE + A(J,J) = SQRT(S) + END IF + 20 CONTINUE + INFO = 0 + +C ZERO OUT LOWER PORTION OF A + DO 40 J=2,N + DO 30 K=1,J-1 + A(J,K) = ZERO + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DFCTRW + SUBROUTINE DFCTRW + + (N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WRK0,WRK4, + + WE1,NNZW,INFO) +C***BEGIN PROLOGUE DFCTRW +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFCTR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE +C ODRPACK REFERENCE GUIDE +C***END PROLOGUE DFCTRW + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDWD,LDWE,LD2WD,LD2WE, + + M,N,NNZW,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), + + WRK0(NQ,NQ),WRK4(M,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,INF,J,J1,J2,L,L1,L2 + LOGICAL + + NOTZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFCTR + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NOTZRO: THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE +C WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) +C OR NOT (NOTZRO=TRUE). +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C WE: THE (SQUARED) EPSILON WEIGHTS. +C WE1: THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK0: A WORK ARRAY OF (NQ BY NQ) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTRW + + +C CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1 + + IF (WE(1,1,1).LT.ZERO) THEN +C WE CONTAINS A SCALAR + WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) + NNZW = N + + ELSE + NNZW = 0 + + IF (LDWE.EQ.1) THEN + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS A DIAGONAL MATRIX + DO 110 L=1,NQ + IF (WE(1,1,L).GT.ZERO) THEN + NNZW = N + WE1(1,1,L) = SQRT(WE(1,1,L)) + ELSE IF (WE(1,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 110 CONTINUE + ELSE + +C WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX + DO 130 L1=1,NQ + DO 120 L2=L1,NQ + WRK0(L1,L2) = WE(1,L1,L2) + 120 CONTINUE + 130 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + DO 150 L1=1,NQ + DO 140 L2=1,NQ + WE1(1,L1,L2) = WRK0(L1,L2) + 140 CONTINUE + IF (WE1(1,L1,L1).NE.ZERO) THEN + NNZW = N + END IF + 150 CONTINUE + END IF + END IF + + ELSE + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS AN ARRAY OF DIAGONAL MATRIX + DO 220 I=1,N + NOTZRO = .FALSE. + DO 210 L=1,NQ + IF (WE(I,1,L).GT.ZERO) THEN + NOTZRO = .TRUE. + WE1(I,1,L) = SQRT(WE(I,1,L)) + ELSE IF (WE(I,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 210 CONTINUE + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 220 CONTINUE + ELSE + +C WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES + DO 270 I=1,N + DO 240 L1=1,NQ + DO 230 L2=L1,NQ + WRK0(L1,L2) = WE(I,L1,L2) + 230 CONTINUE + 240 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + NOTZRO = .FALSE. + DO 260 L1=1,NQ + DO 250 L2=1,NQ + WE1(I,L1,L2) = WRK0(L1,L2) + 250 CONTINUE + IF (WE1(I,L1,L1).NE.ZERO) THEN + NOTZRO = .TRUE. + END IF + 260 CONTINUE + END IF + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 270 CONTINUE + END IF + END IF + END IF + +C CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS + + IF (NNZW.LT.NPP) THEN + INFO = 30020 + END IF + + +C CHECK DELTA WEIGHTS + + 300 CONTINUE + IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN +C PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR + RETURN + + ELSE + + IF (LDWD.EQ.1) THEN + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS A DIAGONAL MATRIX + DO 310 J=1,M + IF (WD(1,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 310 CONTINUE + ELSE + +C WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX + DO 330 J1=1,M + DO 320 J2=J1,M + WRK4(J1,J2) = WD(1,J1,J2) + 320 CONTINUE + 330 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + END IF + + ELSE + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS AN ARRAY OF DIAGONAL MATRICES + DO 420 I=1,N + DO 410 J=1,M + IF (WD(I,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 410 CONTINUE + 420 CONTINUE + ELSE + +C WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES + DO 470 I=1,N + DO 440 J1=1,M + DO 430 J2=J1,M + WRK4(J1,J2) = WD(I,J1,J2) + 430 CONTINUE + 440 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 470 CONTINUE + END IF + END IF + END IF + + RETURN + END +*DFLAGS + SUBROUTINE DFLAGS + + (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) +C***BEGIN PROLOGUE DFLAGS +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB +C***END PROLOGUE DFLAGS + +C...SCALAR ARGUMENTS + INTEGER + + JOB + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...LOCAL SCALARS + INTEGER + + J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF +C ARRAY WORK (INITD=FALSE). +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: THE VALUE OF A SPECIFIC DIGIT OF JOB. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). + + +C***FIRST EXECUTABLE STATEMENT DFLAGS + + + IF (JOB.GE.0) THEN + + RESTRT= JOB.GE.10000 + + INITD = MOD(JOB,10000)/1000.EQ.0 + + J = MOD(JOB,1000)/100 + IF (J.EQ.0) THEN + DOVCV = .TRUE. + REDOJ = .TRUE. + ELSE IF (J.EQ.1) THEN + DOVCV = .TRUE. + REDOJ = .FALSE. + ELSE + DOVCV = .FALSE. + REDOJ = .FALSE. + END IF + + J = MOD(JOB,100)/10 + IF (J.EQ.0) THEN + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.1) THEN + ANAJAC = .FALSE. + CDJAC = .TRUE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.2) THEN + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .TRUE. + ELSE + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + END IF + + J = MOD(JOB,10) + IF (J.EQ.0) THEN + ISODR = .TRUE. + IMPLCT = .FALSE. + ELSE IF (J.EQ.1) THEN + ISODR = .TRUE. + IMPLCT = .TRUE. + ELSE + ISODR = .FALSE. + IMPLCT = .FALSE. + END IF + + ELSE + + RESTRT = .FALSE. + INITD = .TRUE. + DOVCV = .TRUE. + REDOJ = .TRUE. + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ISODR = .TRUE. + IMPLCT = .FALSE. + + END IF + + RETURN + END +*DHSTEP + DOUBLE PRECISION FUNCTION DHSTEP + + (ITYPE,NETA,I,J,STP,LDSTP) +C***BEGIN PROLOGUE DHSTEP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES +C***END PROLOGUE DHSTEP + +C...SCALAR ARGUMENTS + INTEGER + + I,ITYPE,J,LDSTP,NETA + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + STP(LDSTP,J) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEN,THREE,TWO,ZERO + +C...DATA STATEMENTS + DATA + + ZERO,TWO,THREE,TEN + + /0.0D0,2.0D0,3.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C ITYPE: THE FINITE DIFFERENCE METHOD BEING USED, WHERE +C ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND +C ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES. +C J: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C LDSTP: THE LEADING DIMENSION OF ARRAY STP. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + + +C***FIRST EXECUTABLE STATEMENT DHSTEP + + +C SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE + + IF (STP(1,1).LE.ZERO) THEN + + IF (ITYPE.EQ.0) THEN +C USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/TWO - TWO) + + ELSE +C USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/THREE) + END IF + + ELSE IF (LDSTP.EQ.1) THEN + DHSTEP = STP(1,J) + + ELSE + DHSTEP = STP(I,J) + END IF + + RETURN + END +*DIFIX + SUBROUTINE DIFIX + + (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) +C***BEGIN PROLOGUE DIFIX +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 910612 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX +C***END PROLOGUE DIFIX + +C...SCALAR ARGUMENTS + INTEGER + + LDIFIX,LDT,LDTFIX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),TFIX(LDTFIX,M) + INTEGER + + IFIX(LDIFIX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE +C SET TO ZERO. +C J: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDIFIX: THE LEADING DIMENSION OF ARRAY IFIX. +C LDTFIX: THE LEADING DIMENSION OF ARRAY TFIX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE ARRAY. +C N: THE NUMBER OF ROWS OF DATA IN THE ARRAY. +C T: THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS +C OF IFIX. +C TFIX: THE RESULTING ARRAY. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DIFIX + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (IFIX(1,1).GE.ZERO) THEN + IF (LDIFIX.GE.N) THEN + DO 20 J=1,M + DO 10 I=1,N + IF (IFIX(I,J).EQ.0) THEN + TFIX(I,J) = ZERO + ELSE + TFIX(I,J) = T(I,J) + END IF + 10 CONTINUE + 20 CONTINUE + ELSE + DO 100 J=1,M + IF (IFIX(1,J).EQ.0) THEN + DO 30 I=1,N + TFIX(I,J) = ZERO + 30 CONTINUE + ELSE + DO 90 I=1,N + TFIX(I,J) = T(I,J) + 90 CONTINUE + END IF + 100 CONTINUE + END IF + END IF + + RETURN + END +*DINIWK + SUBROUTINE DINIWK + + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) +C***BEGIN PROLOGUE DINIWK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY +C***END PROLOGUE DINIWK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, + + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) + INTEGER + + IFIXX(LDIFX,M),IWORK(LIWORK) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,THREE,TWO,ZERO + INTEGER + + I,J + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY,DFLAGS,DSCLB,DSCLD,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C I: AN INDEXING VARIABLE. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C IWORK: THE INTEGER WORK SPACE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDTTI: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C THREE: THE VALUE 3.0D0. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT. +C TWO: THE VALUE 2.0D0. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DINIWK + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR + + WORK(EPSMAI) = DMPREC() + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C PARAMETERS (SEE ALSO SUBPROGRAM DODCNT) + + IF (PARTOL.LT.ZERO) THEN + WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) + ELSE + WORK(PARTLI) = MIN(PARTOL, ONE) + END IF + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS + + IF (SSTOL.LT.ZERO) THEN + WORK(SSTOLI) = SQRT(WORK(EPSMAI)) + ELSE + WORK(SSTOLI) = MIN(SSTOL, ONE) + END IF + +C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION + + IF (TAUFAC.LE.ZERO) THEN + WORK(TAUFCI) = ONE + ELSE + WORK(TAUFCI) = MIN(TAUFAC, ONE) + END IF + +C SET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.LT.0) THEN + IWORK(MAXITI) = 50 + ELSE + IWORK(MAXITI) = MAXIT + END IF + +C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL +C VARIABLE + + IF (JOB.LE.0) THEN + IWORK(JOBI) = 0 + ELSE + IWORK(JOBI) = JOB + END IF + +C SET PRINT CONTROL + + IF (IPRINT.LT.0) THEN + IWORK(IPRINI) = 2001 + ELSE + IWORK(IPRINI) = IPRINT + END IF + +C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES + + IF (LUNERR.LT.0) THEN + IWORK(LUNERI) = 6 + ELSE + IWORK(LUNERI) = LUNERR + END IF + +C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS + + IF (LUNRPT.LT.0) THEN + IWORK(LUNRPI) = 6 + ELSE + IWORK(LUNRPI) = LUNRPT + END IF + +C COMPUTE SCALING FOR BETA'S AND DELTA'S + + IF (SCLB(1).LE.ZERO) THEN + CALL DSCLB(NP,BETA,WORK(SSFI)) + ELSE + CALL DCOPY(NP,SCLB,1,WORK(SSFI),1) + END IF + IF (ISODR) THEN + IF (SCLD(1,1).LE.ZERO) THEN + IWORK(LDTTI) = N + CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) + ELSE + IF (LDSCLD.EQ.1) THEN + IWORK(LDTTI) = 1 + CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1) + ELSE + IWORK(LDTTI) = N + DO 10 J=1,M + CALL DCOPY(N,SCLD(1,J),1, + + WORK(TTI+(J-1)*IWORK(LDTTI)),1) + 10 CONTINUE + END IF + END IF + END IF + +C INITIALIZE DELTA'S AS NECESSARY + + IF (ISODR) THEN + IF (INITD) THEN + CALL DZERO(N,M,WORK(DELTAI),N) + ELSE + IF (IFIXX(1,1).GE.0) THEN + IF (LDIFX.EQ.1) THEN + DO 20 J=1,M + IF (IFIXX(1,J).EQ.0) THEN + CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) + END IF + 20 CONTINUE + ELSE + DO 40 J=1,M + DO 30 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + WORK(DELTAI-1+I+(J-1)*N) = ZERO + END IF + 30 CONTINUE + 40 CONTINUE + END IF + END IF + END IF + ELSE + CALL DZERO(N,M,WORK(DELTAI),N) + END IF + + RETURN + END +*DIWINF + SUBROUTINE DIWINF + + (M,NP,NQ, + + MSGBI,MSGDI,IFIX2I,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) +C***BEGIN PROLOGUE DIWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE +C***END PROLOGUE DIWINF + +C...SCALAR ARGUMENTS + INTEGER + + IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN, + + LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI, + + NNZWI,NP,NPPI,NQ,NROWI,NTOLI + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIX2I: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGBI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGDI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABEL NITER. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. + + +C***FIRST EXECUTABLE STATEMENT DIWINF + + + IF (NP.GE.1 .AND. M.GE.1) THEN + MSGBI = 1 + MSGDI = MSGBI + NQ*NP+1 + IFIX2I = MSGDI + NQ*M+1 + ISTOPI = IFIX2I + NP + NNZWI = ISTOPI + 1 + NPPI = NNZWI + 1 + IDFI = NPPI + 1 + JOBI = IDFI + 1 + IPRINI = JOBI + 1 + LUNERI = IPRINI + 1 + LUNRPI = LUNERI + 1 + NROWI = LUNRPI + 1 + NTOLI = NROWI + 1 + NETAI = NTOLI + 1 + MAXITI = NETAI + 1 + NITERI = MAXITI + 1 + NFEVI = NITERI + 1 + NJEVI = NFEVI + 1 + INT2I = NJEVI + 1 + IRANKI = INT2I + 1 + LDTTI = IRANKI + 1 + LIWKMN = LDTTI + ELSE + MSGBI = 1 + MSGDI = 1 + IFIX2I = 1 + ISTOPI = 1 + NNZWI = 1 + NPPI = 1 + IDFI = 1 + JOBI = 1 + IPRINI = 1 + LUNERI = 1 + LUNRPI = 1 + NROWI = 1 + NTOLI = 1 + NETAI = 1 + MAXITI = 1 + NITERI = 1 + NFEVI = 1 + NJEVI = 1 + INT2I = 1 + IRANKI = 1 + LDTTI = 1 + LIWKMN = 1 + END IF + + RETURN + END +*DJACCD + SUBROUTINE DJACCD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACCD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACCD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN +C BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT +C (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALING VALUES USED FOR BETA. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACCD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 60 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = WRK2(I,L) + 20 CONTINUE + 30 CONTINUE + END IF + + BETA(K) = BETAK - WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + DO 50 L=1,NQ + DO 40 I=1,N + FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) + 40 CONTINUE + 50 CONTINUE + BETA(K) = BETAK + END IF + 60 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + END IF + + DO 150 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) + 150 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJACFD + SUBROUTINE DJACFD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACFD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACFD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A +C GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) +C OR NOT (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACFD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 40 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) + 20 CONTINUE + 30 CONTINUE + BETA(K) = BETAK + END IF + 40 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJCK + SUBROUTINE DJCK + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + SSF,TT,LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + PV0,FJACB,FJACD, + + MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DJCKM +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS +C (ADAPTED FROM STARPAC SUBROUTINE DCKCNT) +C***END PROLOGUE DJCK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT, + + M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO + INTEGER + + IDEVAL,J,LQ,MSGB1,MSGD1 + LOGICAL + + ISFIXD,ISWRTB + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKM + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10 + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE + + /0.0D0,0.5D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISFIXD: THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED +C (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED. +C J: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER +C SET BY THE USER OR COMPUTED BY DETAF. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. +C ONE: THE VALUE 1.0D0. +C P5: THE VALUE 0.5D0. +C PV: THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR +C ROW NROW IS STORED. +C PV0: THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES. +C SSF: THE SCALING VALUES USED FOR BETA. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TOL: THE AGREEMENT TOLERANCE. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCK + + +C SET TOLERANCE FOR CHECKING DERIVATIVES + + TOL = ETA**(0.25D0) + NTOL = MAX(ONE,P5-LOG10(TOL)) + + +C COMPUTE USER SUPPLIED DERIVATIVE VALUES + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV + 1 + END IF + +C CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW + + MSGB1 = 0 + MSGD1 = 0 + + DO 30 LQ=1,NQ + +C SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES + PV = PV0(NROW,LQ) + + ISWRTB = .TRUE. + DO 10 J=1,NP + + IF (IFIXB(1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (IFIXB(J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGB(1+LQ+(J-1)*NQ) = -1 + ELSE + IF (BETA(J).EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(J) + END IF + ELSE + TYPJ = ABS(BETA(J)) + END IF + + H0 = DHSTEP(0,NETA,1,J,STPB,1) + HC0 = H0 + +C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACB(NROW,J,LQ), + + DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGB(1) = -1 + RETURN + ELSE + DIFF(LQ,J) = DIFFJ + END IF + END IF + + 10 CONTINUE + +C CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW + + IF (ISODR) THEN + ISWRTB = .FALSE. + DO 20 J=1,M + + IF (IFIXX(1,1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGD(1+LQ+(J-1)*NQ) = -1 + ELSE + + IF (XPLUSD(NROW,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(NROW,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(NROW,J)) + END IF + + H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) + HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) + +C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACD(NROW,J,LQ), + + DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGD(1) = -1 + RETURN + ELSE + DIFF(LQ,NP+J) = DIFFJ + END IF + END IF + + 20 CONTINUE + END IF + 30 CONTINUE + MSGB(1) = MSGB1 + MSGD(1) = MSGD1 + + RETURN + END +*DJCKC + SUBROUTINE DJCKC + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0, + + PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKF,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE +C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKCRV) +C***END PROLOGUE DJCKC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKF,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P01,ONE,TWO,TEN + + /0.01D0,1.0D0,2.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE OF THE MODEL FOR ROW NROW . +C PVMCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. +C PVPCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STP: A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STPCRV: THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. +C TEN: THE VALUE 10.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKC + + + IF (ISWRTB) THEN + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA + + STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL + + CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) + CURVE = CURVE + + + ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) + + +C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. + CALL DJCKF(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + IF (MSG(LQ,J).EQ.0) THEN + RETURN + END IF + +C CHECK IF HIGH CURVATURE COULD BE THE PROBLEM. + + STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) + IF (STP.LT.ABS(TEN*STP0)) THEN + STP = MIN(STP,P01*ABS(STP0)) + END IF + + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C COMPUTE THE NEW NUMERICAL DERIVATIVE + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN + MSG(LQ,J) = 0 + +C CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2) + ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) + + + CURVE*(EPSMAC*TYPJ)**2) THEN + MSG(LQ,J) = 5 + END IF + + RETURN + END +*DJCKF + SUBROUTINE DJCKF + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE +C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKFPA) +C***END PROLOGUE DJCKF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + HUNDRD,ONE,P1,STP,TWO + LOGICAL + + LARGE + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P1,ONE,TWO,HUNDRD + + /0.1D0,1.0D0,2.0D0,100.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LARGE: THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN +C THE STEP SIZE WOULD BE GREATER THAN TYPJ. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P1: THE VALUE 0.1D0. +C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKF + + +C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. +C TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR + + STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) + IF (STP.GT.ABS(P1*STP0)) THEN + STP = MAX(STP,HUNDRD*ABS(STP0)) + END IF + IF (STP.GT.TYPJ) THEN + STP = TYPJ + LARGE = .TRUE. + ELSE + LARGE = .FALSE. + END IF + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK FOR AGREEMENT + + IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN +C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE. + MSG(LQ,J) = 0 + + ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN +C CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2) + IF (LARGE) THEN + MSG(LQ,J) = 4 + ELSE + MSG(LQ,J) = 5 + END IF + END IF + + RETURN + END +*DJCKM + SUBROUTINE DJCKM + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,D, + + DIFFJ,MSG1,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL +C DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKMN) +C***END PROLOGUE DJCKM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, + + TEN,THREE,TOL2,TWO,ZERO + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKC,DJCKZ,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD + + /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/ + DATA + + BIG,TOL2 + + /1.0D19,5.0D-2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIG: A BIG VALUE, USED TO INITIALIZE DIFFJ. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C H: THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H1: THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC1: THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C MSG1: THE ERROR CHECKING RESULTS SUMMARY. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH +C PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C P1: THE VALUE 0.1D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TOL2: A MINIMUM AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKM + + +C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE +C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES + + H1 = SQRT(ETA) + HC1 = ETA**(ONE/THREE) + + MSG(LQ,J) = 7 + DIFFJ = BIG + + DO 10 I=1,3 + + IF (I.EQ.1) THEN +C TRY INITIAL RELATIVE STEP SIZE + H = H0 + HC = HC0 + + ELSE IF (I.EQ.2) THEN +C TRY LARGER RELATIVE STEP SIZE + H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) + HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) + + ELSE IF (I.EQ.3) THEN +C TRY SMALLER RELATIVE STEP SIZE + H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) + HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) + END IF + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + + - XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP0 + +C CHECK FOR AGREEMENT + + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN +C NUMERICAL AND ANALYTIC DERIVATIVES AGREE + +C SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + DIFFJ = ABS(FD-D) + ELSE + DIFFJ = ABS(FD-D)/ABS(D) + END IF + +C SET MSG FLAG. + IF (D.EQ.ZERO) THEN + +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO. + MSG(LQ,J) = 1 + + ELSE +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO. + MSG(LQ,J) = 0 + END IF + + ELSE + +C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE. CHECK WHY + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + CALL DJCKZ(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + ELSE + CALL DJCKC(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + END IF + IF (MSG(LQ,J).LE.2) THEN + GO TO 20 + END IF + END IF + 10 CONTINUE + +C SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS + 20 CONTINUE + IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 + IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN + MSG1 = MAX(MSG1,1) + ELSE IF (MSG(LQ,J).GE.7) THEN + MSG1 = 2 + END IF + + RETURN + END +*DJCKZ + SUBROUTINE DJCKZ + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKZ +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE +C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC +C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO +C (ADAPTED FROM STARPAC SUBROUTINE DCKZRO) +C***END PROLOGUE DJCKZ + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CD,ONE,PVMSTP,THREE,TWO,ZERO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CD: THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVMSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKZ + + +C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP +C SIZE OF 2*STP0 + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + CD = (PVPSTP-PVMSTP)/(TWO*STP0) + DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) + +C CHECK FOR AGREEMENT + + IF (DIFFJ.LE.TOL*ABS(D)) THEN + +C FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE. + IF (D.EQ.ZERO) THEN + MSG(LQ,J) = 1 + ELSE + MSG(LQ,J) = 0 + END IF + + ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN +C DERIVATIVES ARE BOTH CLOSE TO ZERO + MSG(LQ,J) = 2 + + ELSE +C DERIVATIVES ARE NOT BOTH CLOSE TO ZERO + MSG(LQ,J) = 3 + END IF + + RETURN + END +*DODCHK + SUBROUTINE DODCHK + + (N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) +C***BEGIN PROLOGUE DODCHK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO +C***END PROLOGUE DODCHK + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ + LOGICAL + + ANAJAC,IMPLCT,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M) + INTEGER + + IFIXB(NP) + +C...LOCAL SCALARS + INTEGER + + I,J,K,LAST,NPP + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY X. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUE FOR DELTA. +C STPB: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT BETA. +C STPD: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODCHK + + +C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED + + IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN + NPP = NP + ELSE + NPP = 0 + DO 10 K=1,NP + IF (IFIXB(K).NE.0) THEN + NPP = NPP + 1 + END IF + 10 CONTINUE + END IF + +C CHECK PROBLEM SPECIFICATION PARAMETERS + + IF (N.LE.0 .OR. + + M.LE.0 .OR. + + (NPP.LE.0 .OR. NPP.GT.N) .OR. + + (NQ.LE.0)) THEN + + INFO = 10000 + IF (N.LE.0) THEN + INFO = INFO + 1000 + END IF + IF (M.LE.0) THEN + INFO = INFO + 100 + END IF + IF (NPP.LE.0 .OR. NPP.GT.N) THEN + INFO = INFO + 10 + END IF + IF (NQ.LE.0) THEN + INFO = INFO + 1 + END IF + + RETURN + + END IF + +C CHECK DIMENSION SPECIFICATION PARAMETERS + + IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. + + (LDX.LT.N) .OR. + + (LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. + + (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. + + (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. + + (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. + + (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. + + (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. + + (LWORK.LT.LWKMN) .OR. + + (LIWORK.LT.LIWKMN)) THEN + + INFO = 20000 + IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN + INFO = INFO + 1000 + END IF + IF (LDX.LT.N) THEN + INFO = INFO + 2000 + END IF + + IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN + INFO = INFO + 100 + END IF + IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. + + (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN + INFO = INFO + 200 + END IF + + IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN + INFO = INFO + 10 + END IF + IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN + INFO = INFO + 20 + END IF + IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN + INFO = INFO + 40 + END IF + + IF (LWORK.LT.LWKMN) THEN + INFO = INFO + 1 + END IF + IF (LIWORK.LT.LIWKMN) THEN + INFO = INFO + 2 + END IF + RETURN + + END IF + +C CHECK DELTA SCALING + + IF (ISODR .AND. SCLD(1,1).GT.0) THEN + IF (LDSCLD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 120 J=1,M + DO 110 I=1,LAST + IF (SCLD(I,J).LE.0) THEN + INFO = 30200 + GO TO 130 + END IF + 110 CONTINUE + 120 CONTINUE + END IF + 130 CONTINUE + +C CHECK BETA SCALING + + IF (SCLB(1).GT.0) THEN + DO 210 K=1,NP + IF (SCLB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 30100 + ELSE + INFO = INFO + 100 + END IF + GO TO 220 + END IF + 210 CONTINUE + END IF + 220 CONTINUE + +C CHECK DELTA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN + IF (LDSTPD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 320 J=1,M + DO 310 I=1,LAST + IF (STPD(I,J).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 32000 + ELSE + INFO = INFO + 2000 + END IF + GO TO 330 + END IF + 310 CONTINUE + 320 CONTINUE + END IF + 330 CONTINUE + +C CHECK BETA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. STPB(1).GT.0) THEN + DO 410 K=1,NP + IF (STPB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 31000 + ELSE + INFO = INFO + 1000 + END IF + GO TO 420 + END IF + 410 CONTINUE + END IF + 420 CONTINUE + + RETURN + END +*DODCNT + SUBROUTINE DODCNT + + (SHORT, 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) +C***BEGIN PROLOGUE DODCNT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODDRV +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION +C***END PROLOGUE DODCNT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + LOGICAL + + SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO + INTEGER + + IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, + + MAXITI,MAXIT1 + LOGICAL + + DONE,FSTITR,HEAD,IMPLCT,PRTPEN + +C...LOCAL ARRAYS + DOUBLE PRECISION + + PNLTY(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODDRV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...DATA STATEMENTS + DATA + + PCHECK,PSTART,PFAC,ZERO,ONE,THREE + + /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CNVTOL: THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS. +C DONE: THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS +C BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE). +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLES. +C IPRNTI: THE PRINT CONTROL VARIABLES. +C IPR1: THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR2: THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR3: THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR4: THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB2: THE 2ND DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB3: THE 3RD DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB4: THE 4TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB5: THE 5TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE CURRENT PENALTY PARAMETER VALUE. +C MAXIT1: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE NEXT PENALTY PARAMETER VALUE. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C ONE: THE VALUE 1.0D0. +C PARTOL: THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PCHECK: THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED +C BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED. +C PFAC: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE +C PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C PSTART: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C THREE: THE VALUE 3.0D0. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODCNT + + + IMPLCT = MOD(JOB,10).EQ.1 + FSTITR = .TRUE. + HEAD = .TRUE. + PRTPEN = .FALSE. + + IF (IMPLCT) THEN + +C SET UP FOR IMPLICIT PROBLEM + + IF (IPRINT.GE.0) THEN + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + ELSE + IPR1 = 2 + IPR2 = 0 + IPR2F = 0 + IPR3 = 1 + END IF + IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 + + JOB5 = MOD(JOB,100000)/10000 + JOB4 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB2 = MOD(JOB,100)/10 + JOB1 = MOD(JOB,10) + JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 + + IF (WE(1,1,1).LE.ZERO) THEN + PNLTY(1,1,1) = -PSTART + ELSE + PNLTY(1,1,1) = -WE(1,1,1) + END IF + + IF (PARTOL.LT.ZERO) THEN + CNVTOL = DMPREC()**(ONE/THREE) + ELSE + CNVTOL = MIN(PARTOL,ONE) + END IF + + IF (MAXIT.GE.1) THEN + MAXITI = MAXIT + ELSE + MAXITI = 100 + END IF + + DONE = MAXITI.EQ.0 + PRTPEN = .TRUE. + + 10 CONTINUE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, + + IPRNTI,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) + + IF (DONE) THEN + RETURN + ELSE + DONE = MAXIT1.LE.0 .OR. + + (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. + + TSTIMP.LE.CNVTOL) + END IF + + IF (DONE) THEN + IF (TSTIMP.LE.CNVTOL) THEN + INFO = (INFO/10)*10 + 2 + ELSE + INFO = (INFO/10)*10 + 4 + END IF + JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 + MAXITI = 0 + IPRNTI = IPR3 + ELSE + PRTPEN = .TRUE. + PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) + JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 + MAXITI = MAXIT1 + IPRNTI = 0000 + IPR2*100 + IPR2F*10 + END IF + GO TO 10 + ELSE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + 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, + + MAXIT1,TSTIMP, INFO) + END IF + + RETURN + + END +*DODDRV + SUBROUTINE DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + 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, + + MAXIT1,TSTIMP, INFO) +C***BEGIN PROLOGUE DODDRV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS, +C DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN, +C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN +C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION +C (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) +C***END PROLOGUE DODDRV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC,TSTIMP + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, + + N,NDIGIT,NP,NQ + LOGICAL + + FSTITR,HEAD,PRTPEN,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + EPSMAC,ETA,P5,ONE,TEN,ZERO + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI, + + IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN, + + LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, + + NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, + + NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, + + DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE,TEN + + /0.0D0,0.5D0,1.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY F. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEX VARIABLE. +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2I: THE IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT. +C K: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXIT1: FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT +C PENALTY PARAMETER VALUE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, +C SET BY DJCK. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C P5: THE VALUE 0.5D0. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL +C (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TEN: THE VALUE 10.0D0. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C X: THE EXPLANATORY VARIABLE. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODDRV + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE +C (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF) + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE +C ARE HANDLED REASONABLY BY DWINF) + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,FI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + IF (ISODR) THEN + WRK = WRK1I + LWRK = N*M*NQ + N*NQ + ELSE + WRK = WRK2I + LWRK = N*NQ + END IF + +C UPDATE THE PENALTY PARAMETERS +C (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE) + IF (RESTRT .AND. IMPLCT) THEN + WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) + WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) + END IF + + IF (RESTRT) THEN + +C RESET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.GE.0) THEN + IWORK(MAXITI) = IWORK(NITERI) + MAXIT + ELSE + IWORK(MAXITI) = IWORK(NITERI) + 10 + END IF + + IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN + INFO = 0 + END IF + + IF (JOB.GE.0) IWORK(JOBI) = JOB + IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT + IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL + IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL + + WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + + ELSE + +C PERFORM ERROR CHECKING + + INFO = 0 + + CALL DODCHK(N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) + IF (INFO.GT.0) THEN + GO TO 50 + END IF + +C INITIALIZE WORK VECTORS AS NECESSARY + + DO 10 I=N*M+N*NQ+1,LWORK + WORK(I) = ZERO + 10 CONTINUE + DO 20 I=1,LIWORK + IWORK(I) = 0 + 20 CONTINUE + + CALL DINIWK(N,M,NP, + + WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) + + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + WORK(TAUI) = -WORK(TAUFCI) + +C SET UP FOR PARAMETER ESTIMATION - +C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES +C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY + + CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) + CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) + NPP = IWORK(NPPI) + +C CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, +C SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS + + CALL DFCTRW(N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WORK(WRK2I),WORK(WRK4I), + + WORK(WE1I),NNZW,INFO) + IWORK(NNZWI) = NNZW + + IF (INFO.NE.0) THEN + GO TO 50 + END IF + +C EVALUATE THE PREDICTED VALUES AND +C WEIGHTED EPSILONS AT THE STARTING POINT + + CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) + CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX, + + 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), + + ISTOP) + IWORK(ISTOPI) = ISTOP + IF (ISTOP.EQ.0) THEN + IWORK(NFEVI) = IWORK(NFEVI) + 1 + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + ELSE + INFO = 52000 + GO TO 50 + END IF + +C COMPUTE NORM OF THE INITIAL ESTIMATES + + CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP, + + WORK(WRK),NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N, + + WORK(WRK+NPP),N) + WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1) + ELSE + WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1) + END IF + +C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS + + WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N) + WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1) + ELSE + WORK(WSSDEI) = ZERO + END IF + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + +C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS + + NROW = -1 + CALL DSETN(N,M,WORK(XPLUSI),N,NROW) + IWORK(NROWI) = NROW + +C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS + + EPSMAC = WORK(EPSMAI) + IF (NDIGIT.LT.2) THEN + IWORK(NETAI) = -1 + NFEV = IWORK(NFEVI) + CALL DETAF(FCN, + + N,M,NP,NQ, + + WORK(XPLUSI),BETA,EPSMAC,NROW, + + WORK(BETANI),WORK(FNI), + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IF (ISTOP.NE.0) THEN + INFO = 53000 + IWORK(NETAI) = 0 + WORK(ETAI) = ZERO + GO TO 50 + ELSE + IWORK(NETAI) = -NETA + WORK(ETAI) = ETA + END IF + ELSE + IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) + WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) + END IF + +C CHECK DERIVATIVES IF NECESSARY + + IF (CHKJAC .AND. ANAJAC) THEN + NTOL = -1 + NFEV = IWORK(NFEVI) + NJEV = IWORK(NJEVI) + NETA = IWORK(NETAI) + LDTT = IWORK(LDTTI) + ETA = WORK(ETAI) + EPSMAC = WORK(EPSMAI) + CALL DJCK(FCN, + + N,M,NP,NQ, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + WORK(SSFI),WORK(TTI),LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + WORK(FNI),WORK(FJACBI),WORK(FJACDI), + + IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), + + ISTOP,NFEV,NJEV, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NJEVI) = NJEV + IWORK(NTOLI) = NTOL + IF (ISTOP.NE.0) THEN + INFO = 54000 + ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN + INFO = 40000 + END IF + ELSE + +C INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + END IF + +C PRINT APPROPRIATE ERROR MESSAGES + + 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN + IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN + CALL DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + WORK(FJACBI),WORK(FJACDI), + + WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), + + WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) + END IF + +C SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS + + IF (INFO.EQ.40000) THEN + IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN + IF (IWORK(MSGB).EQ.2) THEN + INFO = INFO + 1000 + END IF + IF (IWORK(MSGD).EQ.2) THEN + INFO = INFO + 100 + END IF + ELSE + INFO = 0 + END IF + END IF + IF (INFO.NE.0) THEN + RETURN + END IF + END IF + END IF + +C SAVE THE INITIAL VALUES OF BETA + CALL DCOPY(NP,BETA,1,WORK(BETA0I),1) + +C FIND LEAST SQUARES SOLUTION + + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1) + LDTT = IWORK(LDTTI) + CALL DODMN(HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), + + WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + + WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), + + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + + STPB,STPD,LDSTPD, + + WORK(XPLUSI),WORK(WRK),LWRK, + + WORK,LWORK,IWORK,LIWORK,INFO) + MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) + TSTIMP = ZERO + DO 100 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) + ELSE + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) + END IF + 100 CONTINUE + + RETURN + + END +*DODLM + SUBROUTINE DODLM + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,TAU,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,NLMS,RCOND,IRANK, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODLM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT,DNRM2,DODSTP,DSCALE,DWGHT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T +C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT +C ALGORITHM +C***END PROLOGUE DODLM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA2,EPSFCN,RCOND,TAU + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) + INTEGER + + JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO + INTEGER + + I,IWRK,J,K,L + LOGICAL + + FORVCV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODSTP,DSCALE,DWGHT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P001,P1 + + /0.0D0,0.001D0,0.1D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHAN: THE NEW LEVENBERG-MARQUARDT PARAMETER. +C ALPHA1: THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. +C ALPHA2: THE CURRENT LEVENBERG-MARQUARDT PARAMETER. +C BOT: THE LOWER LIMIT FOR SETTING ALPHA. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN +C SUBROUTINE DODSTP. +C IWRK: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2) WHERE +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C P001: THE VALUE 0.001D0 +C P1: THE VALUE 0.1D0 +C PHI1: THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C PHI2: THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C S: THE STEP FOR BETA. +C SA: THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TOP: THE UPPER LIMIT FOR SETTING ALPHA. +C TT: THE SCALE USED FOR THE DELTA'S. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODLM + + FORVCV = .FALSE. + ISTOPC = 0 + +C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) + + ALPHA1 = ZERO + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA1,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI1,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + +C INITIALIZE TAU IF NECESSARY + + IF (TAU.LT.ZERO) THEN + TAU = ABS(TAU)*PHI1 + END IF + +C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL + + IF ((PHI1-TAU).LE.P1*TAU) THEN + NLMS = 1 + ALPHA2 = ZERO + RETURN + END IF + +C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - +C FIND LOCALLY CONSTRAINED OPTIMAL STEP + + PHI1 = PHI1 - TAU + +C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA + + BOT = ZERO + + DO 30 K=1,NPP + DO 20 L=1,NQ + DO 10 I=1,N + TFJACB(I,L,K) = FJACB(I,K,L) + 10 CONTINUE + 20 CONTINUE + WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1) + 30 CONTINUE + CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) + + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N) + IWRK = NPP + DO 50 J=1,M + DO 40 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = WRK(IWRK) + + + DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N) + 40 CONTINUE + 50 CONTINUE + CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) + TOP = DNRM2(NPP+N*M,WRK,1)/TAU + ELSE + TOP = DNRM2(NPP,WRK,1)/TAU + END IF + + IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN + ALPHA2 = P001*TOP + END IF + +C MAIN LOOP + + DO 60 I=1,10 + +C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR +C CURRENT VALUE OF ALPHA + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI2,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + PHI2 = PHI2-TAU + +C CHECK WHETHER CURRENT STEP IS OPTIMAL + + IF (ABS(PHI2).LE.P1*TAU .OR. + + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN + NLMS = I+1 + RETURN + END IF + +C CURRENT STEP IS NOT OPTIMAL + +C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA + + IF (PHI1-PHI2.EQ.ZERO) THEN + NLMS = 12 + RETURN + END IF + SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) + IF (PHI2.LT.ZERO) THEN + TOP = MIN(TOP,ALPHA2) + ELSE + BOT = MAX(BOT,ALPHA2) + END IF + IF (PHI1*PHI2.GT.ZERO) THEN + BOT = MAX(BOT,ALPHA2-SA) + ELSE + TOP = MIN(TOP,ALPHA2-SA) + END IF + + ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU + IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN + ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) + END IF + +C GET READY FOR NEXT ITERATION + + ALPHA1 = ALPHA2 + ALPHA2 = ALPHAN + PHI1 = PHI2 + 60 CONTINUE + +C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS + + NLMS = 12 + + RETURN + END +*DODMN + SUBROUTINE DODMN + + (HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, + + T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, + + SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, + + XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO) +C***BEGIN PROLOGUE DODMN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM, +C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION +C***END PROLOGUE DODMN + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,LWRK,M,N,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + + DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + + F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), + + S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + T(N,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), + + WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + LOGICAL + + FSTITR,HEAD,PRTPEN + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, + + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + + RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, + + TEMP,TEMP1,TEMP2,TSNORM,ZERO + INTEGER + + I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, + + ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, + + MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX, + + SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, + + IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WSS(3) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DACCES,DCOPY,DEVJAC,DFLAGS, + + DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN,MOD,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P0001,P1,P25,P5,P75,ONE + + /0.0D0,0.00010D0,0.10D0,0.250D0, + + 0.50D0,0.750D0,1.0D0/ + DATA + + LUDFLT + + /6/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAN: THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAS: THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C CNVPAR: THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS +C ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE). +C CNVSS: THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE +C WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAN: THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAS: THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DIRDER: THE DIRECTIONAL DERIVATIVE. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX +C SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C FS: THE SAVED PREDICTED VALUES FROM THE FUNCTION. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. +C INTDBL: THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE +C USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE). +C IPR: THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT. +C IPR1: THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORT. +C IPR2F: THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. +C IWORK: THE INTEGER WORK SPACE. +C IWRK: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JPVT: THE STARTING LOCATION IN IWORK OF ARRAY JPVT. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE AND WE1. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LOOPED: A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP +C HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE +C ENOUGH THE COMPUTATIONS WILL BE STOPPED. +C LSTEP: THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS +C BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE). +C LUDFLT: THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION +C REPORTS TO THE SCREEN. +C LUNR: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPR: THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OMEGA: THE STARTING LOCATION IN WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C P0001: THE VALUE 0.0001D0. +C P1: THE VALUE 0.1D0. +C P25: THE VALUE 0.25D0. +C P5: THE VALUE 0.5D0. +C P75: THE VALUE 0.75D0. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRERS: THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO +C BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RATIO: THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED +C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORM: THE NORM OF THE WEIGHTED ERRORS. +C RNORMN: THE NEW NORM OF THE WEIGHTED ERRORS. +C RNORMS: THE SAVED NORM OF THE WEIGHTED ERRORS. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TEMP1: A TEMPORARY STORAGE LOCATION. +C TEMP2: A TEMPORARY STORAGE LOCATION. +C TSNORM: THE NORM OF THE SCALED STEP. +C TT: THE SCALING VALUES USED FOR DELTA. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE: THE EPSILON WEIGHTS. +C WE1: THE SQUARE ROOT OF THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C WRK: A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2 +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODMN + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + ACCESS = .TRUE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + RNORM = SQRT(WSS(1)) + + DIDVCV = .FALSE. + INTDBL = .FALSE. + LSTEP = .TRUE. + +C PRINT INITIAL SUMMARY IF DESIRED + + IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 1 + IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR1.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR1,2) + END IF + LUNR = LUNRPT + DO 10 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR1.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 10 CONTINUE + + END IF + +C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION + + IF (RNORM.EQ.ZERO) THEN + INFO = 1 + OLMAVG = ZERO + ISTOP = 0 + GO TO 150 + END IF + +C STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED + + IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN + ISTOP = 0 + GO TO 150 + ELSE IF (NITER.GE.MAXIT) THEN + INFO = 4 + ISTOP = 0 + GO TO 150 + END IF + +C MAIN LOOP + + 100 CONTINUE + + NITER = NITER + 1 + RNORMS = RNORM + LOOPED = 0 + +C EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS) + + IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN + ISTOP = 0 + ELSE + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + END IF + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + +C SUB LOOP FOR +C INTERNAL DOUBLING OR +C COMPUTING NEW STEP WHEN OLD FAILED + + 110 CONTINUE + +C COMPUTE STEPS S AND T + + IF (LOOPED.GT.100) THEN + INFO = 60000 + GO TO 200 + ELSE + LOOPED = LOOPED + 1 + CALL DODLM(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,TAU,ETA,ISODR, + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,NLMS,RCOND,IRANK, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + END IF + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + OLMAVG = OLMAVG+NLMS + +C COMPUTE BETAN = BETAC + S +C DELTAN = DELTA + T + + CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) + IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) + +C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + TSNORM = DNRM2(NPP+N*M,WRK,1) + ELSE + TSNORM = DNRM2(NPP,WRK,1) + END IF + +C COMPUTE SCALED PREDICTED REDUCTION + + IWRK = 0 + DO 130 L=1,NQ + DO 120 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1) + IF (ISODR) WRK(IWRK) = WRK(IWRK) + + + DDOT(M,FJACD(I,1,L),N,T(I,1),N) + 120 CONTINUE + 130 CONTINUE + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N) + TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1) + TEMP1 = SQRT(TEMP1)/RNORM + ELSE + TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM + END IF + TEMP2 = SQRT(ALPHA)*TSNORM/RNORM + PRERED = TEMP1**2+TEMP2**2/P5 + + DIRDER = -(TEMP1**2+TEMP2**2) + +C EVALUATE PREDICTED VALUES AT NEW POINT + + CALL DUNPAC(NP,BETAN,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 002,FN,WORK(WRK6),WORK(WRK1), + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + END IF + + IF (ISTOP.LT.0) THEN + +C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN + + INFO = 51000 + GO TO 200 + ELSE IF (ISTOP.GT.0) THEN + +C SET NORM TO INDICATE STEP SHOULD BE REJECTED + + RNORMN = RNORM/(P1*P75) + ELSE + +C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FN,1,WRK,1) + ELSE + CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N) + RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + + + DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1)) + ELSE + RNORMN = DNRM2(N*NQ,WRK,1) + END IF + END IF + +C COMPUTE SCALED ACTUAL REDUCTION + + IF (P1*RNORMN.LT.RNORM) THEN + ACTRED = ONE - (RNORMN/RNORM)**2 + ELSE + ACTRED = -ONE + END IF + +C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION + + IF(PRERED .EQ. ZERO) THEN + RATIO = ZERO + ELSE + RATIO = ACTRED/PRERED + END IF + +C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE + + IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN + ISTOP = 0 + TAU = TAU*P5 + ALPHA = ALPHA/P5 + CALL DCOPY(NPP,BETAS,1,BETAN,1) + CALL DCOPY(N*M,DELTAS,1,DELTAN,1) + CALL DCOPY(N*NQ,FS,1,FN,1) + ACTRED = ACTRS + PRERED = PRERS + RNORMN = RNORMS + RATIO = P5 + END IF + +C UPDATE STEP BOUND + + INTDBL = .FALSE. + IF (RATIO.LT.P25) THEN + IF (ACTRED.GE.ZERO) THEN + TEMP = P5 + ELSE + TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) + END IF + IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN + TEMP = P1 + END IF + TAU = TEMP*MIN(TAU,TSNORM/P1) + ALPHA = ALPHA/TEMP + + ELSE IF (ALPHA.EQ.ZERO) THEN + TAU = TSNORM/P5 + + ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN + +C STEP QUALIFIES FOR INTERNAL DOUBLING +C - UPDATE TAU AND ALPHA +C - SAVE INFORMATION FOR CURRENT POINT + + INTDBL = .TRUE. + + TAU = TSNORM/P5 + ALPHA = ALPHA*P5 + + CALL DCOPY(NPP,BETAN,1,BETAS,1) + CALL DCOPY(N*M,DELTAN,1,DELTAS,1) + CALL DCOPY(N*NQ,FN,1,FS,1) + ACTRS = ACTRED + PRERS = PRERED + RNORMS = RNORMN + END IF + +C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS + + IF (INTDBL .AND. TAU.GT.ZERO) THEN + INT2 = INT2+1 + GO TO 110 + END IF + +C CHECK ACCEPTANCE + + IF (RATIO.GE.P0001) THEN + CALL DCOPY(N*NQ,FN,1,FS,1) + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N) + CALL DCOPY(NPP,BETAN,1,BETAC,1) + CALL DCOPY(N*M,DELTAN,1,DELTA,1) + RNORM = RNORMN + CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N) + PNORM = DNRM2(NPP+N*M,WRK,1) + ELSE + PNORM = DNRM2(NPP,WRK,1) + END IF + LSTEP = .TRUE. + ELSE + LSTEP = .FALSE. + END IF + +C TEST CONVERGENCE + + INFO = 0 + CNVSS = RNORM.EQ.ZERO + + .OR. + + (ABS(ACTRED).LE.SSTOL .AND. + + PRERED.LE.SSTOL .AND. + + P5*RATIO.LE.ONE) + CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) + IF (CNVSS) INFO = 1 + IF (CNVPAR) INFO = 2 + IF (CNVSS .AND. CNVPAR) INFO = 3 + +C PRINT ITERATION REPORT + + IF (INFO.NE.0 .OR. LSTEP) THEN + IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN + IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN + IFLAG = 2 + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + WSS(1) = RNORM*RNORM + IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR2.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR2,2) + END IF + LUNR = LUNRPT + DO 140 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR2.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 140 CONTINUE + FSTITR = .FALSE. + PRTPEN = .FALSE. + END IF + END IF + END IF + +C CHECK IF FINISHED + + IF (INFO.EQ.0) THEN + IF (LSTEP) THEN + +C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET + + IF (NITER.GE.MAXIT) THEN + INFO = 4 + ELSE + GO TO 100 + END IF + ELSE + +C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET + + GO TO 110 + END IF + END IF + + 150 CONTINUE + + IF (ISTOP.GT.0) INFO = INFO + 100 + +C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED + + IF (DOVCV .AND. ISTOP.EQ.0) THEN + +C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED +C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED +C TO COMPUTE COVARIANCE MATRIX + + IF (REDOJ) THEN + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + + + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + END IF + + IF (IMPLCT) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + RSS = RNORM*RNORM + END IF + IF (REDOJ .OR. NITER.GE.1) THEN + CALL DODVCV(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + ETA,ISODR, + + WORK(VCV),WORK(SD), + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + DIDVCV = .TRUE. + END IF + + END IF + +C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS + + 200 DO 210 I=0,NP-1 + WORK(WRK3+I) = IWORK(JPVT+I) + IWORK(JPVT+I) = -2 + 210 CONTINUE + IF (REDOJ .OR. NITER.GE.1) THEN + DO 220 I=0,NPP-1 + J = WORK(WRK3+I) - 1 + IF (I.LE.NPP-IRANK-1) THEN + IWORK(JPVT+J) = 1 + ELSE + IWORK(JPVT+J) = -1 + END IF + 220 CONTINUE + IF (NPP.LT.NP) THEN + J = NPP-1 + DO 230 I=NP-1,0,-1 + IF (IFIXB(I+1).EQ.0) THEN + IWORK(JPVT+I) = 0 + ELSE + IWORK(JPVT+I) = IWORK(JPVT+J) + J = J - 1 + END IF + 230 CONTINUE + END IF + END IF + +C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER + + IF (NITER.GE.1) THEN + OLMAVG = OLMAVG/NITER + ELSE + OLMAVG = ZERO + END IF + +C COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER + + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N) + WSS(3) = DDOT(N*NQ,WRK,1,WRK,1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + WSS(2) = ZERO + END IF + WSS(1) = WSS(2) + WSS(3) + + ACCESS = .FALSE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + +C ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO + + IF (INFO.LE.9 .OR. INFO.GE.60000) THEN + IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN + INFO = INFO + 1000 + END IF + IF (ISTOP.NE.0) THEN + INFO = INFO + 100 + END IF + IF (IRANK.GE.1) THEN + IF (NPP.GT.IRANK) THEN + INFO = INFO + 10 + ELSE + INFO = INFO + 20 + END IF + END IF + END IF + +C PRINT FINAL SUMMARY + + IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 3 + + IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR3.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR3,2) + END IF + LUNR = LUNRPT + DO 240 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IWORK(JPVT),IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR3.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 240 CONTINUE + END IF + + RETURN + + END +*DODPC1 + SUBROUTINE DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB1,MSGB,MSGD1,MSGD, + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,WSSDEL,WSSEPS) +C***BEGIN PROLOGUE DODPC1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DHSTEP +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE INITIAL SUMMARY REPORT +C***END PROLOGUE DODPC1 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS + INTEGER + + IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M), + + Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP1,TEMP2,TEMP3,ZERO + INTEGER + + I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L + +C...LOCAL ARRAYS + CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES +C (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ITEMP: A TEMPORARY INTEGER VALUE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB2: THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB3: THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB4: THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB5: THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY +C ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED +C BY THE USER. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMPC0: A TEMPORARY CHARACTER*2 VALUE. +C TEMPC1: A TEMPORARY CHARACTER*5 VALUE. +C TEMPC2: A TEMPORARY CHARACTER*13 VALUE. +C TEMP1: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP2: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP3: A TEMPORARY DOUBLE PRECISION VALUE. +C TT: THE SCALING VALUES FOR DELTA. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE RESPONSE VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC1 + + +C PRINT PROBLEM SIZE SPECIFICATION + + WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP + + +C PRINT CONTROL VALUES + + JOB1 = JOB/10000 + JOB2 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB4 = MOD(JOB,100)/10 + JOB5 = MOD(JOB,10) + WRITE (LUNRPT,1100) JOB + IF (RESTRT) THEN + WRITE (LUNRPT,1110) JOB1 + ELSE + WRITE (LUNRPT,1111) JOB1 + END IF + IF (ISODR) THEN + IF (INITD) THEN + WRITE (LUNRPT,1120) JOB2 + ELSE + WRITE (LUNRPT,1121) JOB2 + END IF + ELSE + WRITE (LUNRPT,1122) JOB2,JOB5 + END IF + IF (DOVCV) THEN + WRITE (LUNRPT,1130) JOB3 + IF (REDOJ) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + ELSE + WRITE (LUNRPT,1133) JOB3 + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,1140) JOB4 + IF (CHKJAC) THEN + IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN + WRITE (LUNRPT,1141) + ELSE + WRITE (LUNRPT,1142) + END IF + ELSE + WRITE (LUNRPT,1143) + END IF + ELSE IF (CDJAC) THEN + WRITE (LUNRPT,1144) JOB4 + ELSE + WRITE (LUNRPT,1145) JOB4 + END IF + IF (ISODR) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1150) JOB5 + ELSE + WRITE (LUNRPT,1151) JOB5 + END IF + ELSE + WRITE (LUNRPT,1152) JOB5 + END IF + IF (NETA.LT.0) THEN + WRITE (LUNRPT,1200) -NETA + ELSE + WRITE (LUNRPT,1210) NETA + END IF + WRITE (LUNRPT,1300) TAUFAC + + +C PRINT STOPPING CRITERIA + + WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT + + +C PRINT INITIAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,1500) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,1600) WSS + IF (ISODR) THEN + WRITE (LUNRPT,1610) WSSDEL,WSSEPS + END IF + END IF + + + IF (IPR.GE.2) THEN + + +C PRINT FUNCTION PARAMETER DATA + + WRITE (LUNRPT,4000) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,4110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,4120) + ELSE + WRITE (LUNRPT,4200) + END IF + DO 130 J=1,NP + IF (IFIXB(1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (IFIXB(J).NE.0) THEN + TEMPC1 = ' NO' + ELSE + TEMPC1 = ' YES' + END IF + END IF + IF (ANAJAC) THEN + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + ITEMP = -1 + DO 110 L=1,NQ + ITEMP = MAX(ITEMP,MSGB(L,J)) + 110 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (SSF(1).LT.ZERO) THEN + TEMP1 = ABS(SSF(1)) + ELSE + TEMP1 = SSF(J) + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2 + ELSE + IF (CDJAC) THEN + TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) + ELSE + TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) + END IF + WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2 + END IF + 130 CONTINUE + +C PRINT EXPLANATORY VARIABLE DATA + + IF (ISODR) THEN + WRITE (LUNRPT,2010) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,2110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,2120) + ELSE + WRITE (LUNRPT,2130) + END IF + ELSE + WRITE (LUNRPT,2020) + WRITE (LUNRPT,2140) + END IF + IF (ISODR) THEN + DO 240 J = 1,M + TEMPC0 = '1,' + DO 230 I=1,N,N-1 + + IF (IFIXX(1,1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + ELSE + IF (IFIXX(I,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + END IF + END IF + + IF (TT(1,1).LT.ZERO) THEN + TEMP1 = ABS(TT(1,1)) + ELSE + IF (LDTT.EQ.1) THEN + TEMP1 = TT(1,J) + ELSE + TEMP1 = TT(I,J) + END IF + END IF + + IF (WD(1,1,1).LT.ZERO) THEN + TEMP2 = ABS(WD(1,1,1)) + ELSE + IF (LDWD.EQ.1) THEN + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(1,1,J) + ELSE + TEMP2 = WD(1,J,J) + END IF + ELSE + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(I,1,J) + ELSE + TEMP2 = WD(I,J,J) + END IF + END IF + END IF + + IF (ANAJAC) THEN + IF (CHKJAC .AND. + + (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. + + (I.EQ.1))) THEN + ITEMP = -1 + DO 210 L=1,NQ + ITEMP = MAX(ITEMP,MSGD(L,J)) + 210 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + END IF + ELSE + TEMPC2 = ' ' + IF (CDJAC) THEN + TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) + ELSE + TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5210) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + ELSE + WRITE (LUNRPT,5220) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + END IF + END IF + + TEMPC0 = 'N,' + + 230 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 240 CONTINUE + ELSE + + DO 260 J = 1,M + TEMPC0 = '1,' + DO 250 I=1,N,N-1 + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J) + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J) + END IF + TEMPC0 = 'N,' + 250 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 260 CONTINUE + END IF + +C PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS + + IF (.NOT.IMPLCT) THEN + WRITE (LUNRPT,3000) + WRITE (LUNRPT,3100) + DO 310 L=1,NQ + TEMPC0 = '1,' + DO 300 I=1,N,N-1 + IF (WE(1,1,1).LT.ZERO) THEN + TEMP1 = ABS(WE(1,1,1)) + ELSE IF (LDWE.EQ.1) THEN + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(1,1,L) + ELSE + TEMP1 = WE(1,L,L) + END IF + ELSE + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(I,1,L) + ELSE + TEMP1 = WE(I,L,L) + END IF + END IF + IF (NQ.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,L,Y(I,L),TEMP1 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,L,Y(I,L),TEMP1 + END IF + TEMPC0 = 'N,' + 300 CONTINUE + IF (L.LT.NQ) WRITE (LUNRPT,6000) + 310 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- PROBLEM SIZE:'/ + + ' N = ',I5, + + ' (NUMBER WITH NONZERO WEIGHT = ',I5,')'/ + + ' NQ = ',I5/ + + ' M = ',I5/ + + ' NP = ',I5, + + ' (NUMBER UNFIXED = ',I5,')') + 1100 FORMAT + + (/' --- CONTROL VALUES:'/ + + ' JOB = ',I5.5/ + + ' = ABCDE, WHERE') + 1110 FORMAT + + (' A=',I1,' ==> FIT IS A RESTART.') + 1111 FORMAT + + (' A=',I1,' ==> FIT IS NOT A RESTART.') + 1120 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' TO ZERO.') + 1121 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' BY USER.') + 1122 FORMAT + + (' B=',I1,' ==> DELTAS ARE FIXED AT', + + ' ZERO SINCE E=',I1,'.') + 1130 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' BE COMPUTED USING') + 1131 FORMAT + + (' DERIVATIVES RE-', + + 'EVALUATED AT THE SOLUTION.') + 1132 FORMAT + + (' DERIVATIVES FROM THE', + + ' LAST ITERATION.') + 1133 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' NOT BE COMPUTED.') + 1140 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' SUPPLIED BY USER.') + 1141 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR QUESTIONABLE.') + 1142 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR CORRECT.') + 1143 FORMAT + + (' DERIVATIVES WERE NOT', + + ' CHECKED.') + 1144 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY CENTRAL', + + ' DIFFERENCES.') + 1145 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY FORWARD', + + ' DIFFERENCES.') + 1150 FORMAT + + (' E=',I1,' ==> METHOD IS IMPLICIT ODR.') + 1151 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT ODR.') + 1152 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT OLS.') + 1200 FORMAT + + (' NDIGIT = ',I5,' (ESTIMATED BY ODRPACK)') + 1210 FORMAT + + (' NDIGIT = ',I5,' (SUPPLIED BY USER)') + 1300 FORMAT + + (' TAUFAC = ',1P,D12.2) + 1400 FORMAT + + (/' --- STOPPING CRITERIA:'/ + + ' SSTOL = ',1P,D12.2, + + ' (SUM OF SQUARES STOPPING TOLERANCE)'/ + + ' PARTOL = ',1P,D12.2, + + ' (PARAMETER STOPPING TOLERANCE)'/ + + ' MAXIT = ',I5, + + ' (MAXIMUM NUMBER OF ITERATIONS)') + 1500 FORMAT + + (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =', + + 17X,1P,D17.8) + 1510 FORMAT + + ( ' INITIAL PENALTY FUNCTION VALUE =',1P,D17.8/ + + ' PENALTY TERM =',1P,D17.8/ + + ' PENALTY PARAMETER =',1P,D10.1) + 1600 FORMAT + + (/' --- INITIAL WEIGHTED SUM OF SQUARES =', + + 17X,1P,D17.8) + 1610 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,D17.8) + 2010 FORMAT + + (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:') + 2020 FORMAT + + (/' --- EXPLANATORY VARIABLE SUMMARY:') + 2110 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2120 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT '/ + + ' ', + + ' '/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2130 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) (STPD)'/) + 2140 FORMAT + + (/' INDEX X(I,J)'/ + + ' (I,J) '/) + 3000 FORMAT + + (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT', + + ' SUMMARY:') + 3100 FORMAT + + (/' INDEX Y(I,L) WEIGHT'/ + + ' (I,L) (WE)'/) + 4000 FORMAT + + (/' --- FUNCTION PARAMETER SUMMARY:') + 4110 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4120 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' '/ + + ' ', + + ' '/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4200 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (K) (IFIXB) (SCLB)', + + ' (STPB)'/) + 4310 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13) + 4320 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5) + 5110 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5120 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5210 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 5220 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 6000 FORMAT + + (' ') + END +*DODPC2 + SUBROUTINE DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) +C***BEGIN PROLOGUE DODPC2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE GENERATE ITERATION REPORTS +C***END PROLOGUE DODPC2 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS + INTEGER + + IPR,LUNRPT,NFEV,NITER,NP + LOGICAL + + FSTITR,IMPLCT,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + RATIO,ZERO + INTEGER + + J,K,L + CHARACTER GN*3 + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C BETA: THE FUNCTION PARAMETERS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). +C GN: THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON +C STEP WAS TAKEN. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RATIO: THE RATIO OF TAU TO PNORM. +C TAU: THE TRUST REGION DIAMETER. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC2 + + + IF (FSTITR) THEN + IF (IPR.EQ.1) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1121) + ELSE + WRITE (LUNRPT,1122) + END IF + ELSE + IF (IMPLCT) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + END IF + END IF + IF (PRTPEN) THEN + WRITE (LUNRPT,1133) PNLTY + END IF + + IF (ALPHA.EQ.ZERO) THEN + GN = 'YES' + ELSE + GN = ' NO' + END IF + IF (PNORM.NE.ZERO) THEN + RATIO = TAU/PNORM + ELSE + RATIO = ZERO + END IF + IF (IPR.EQ.1) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN + ELSE + J = 1 + K = MIN(3,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,BETA(J) + ELSE + WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,K,(BETA(L),L=J,K) + END IF + IF (NP.GT.3) THEN + DO 10 J=4,NP,3 + K = MIN(J+2,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1151) J,BETA(J) + ELSE + WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) + END IF + 10 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1121 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----') + 1122 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----'/) + 1131 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----') + 1132 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----'/) + 1133 FORMAT + + (/' PENALTY PARAMETER VALUE = ', 1P,E10.1) + 1141 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) + 1142 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) + 1151 FORMAT + + (76X,I3,1P,D16.8) + 1152 FORMAT + + (70X,I3,' TO',I3,1P,3D16.8) + END +*DODPC3 + SUBROUTINE DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB2,F,DELTA) +C***BEGIN PROLOGUE DODPC3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE FINAL SUMMARY REPORT +C***END PROLOGUE DODPC3 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS + INTEGER + + IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, + + N,NFEV,NITER,NJEV,NP,NPP,NQ + LOGICAL + + ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP) + INTEGER + + IFIXB2(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TVAL + INTEGER + + D1,D2,D3,D4,D5,I,J,K,L,NPLM1 + CHARACTER FMT1*90 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPT + EXTERNAL + + DPPT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C D1: THE FIRST DIGIT OF INFO. +C D2: THE SECOND DIGIT OF INFO. +C D3: THE THIRD DIGIT OF INFO. +C D4: THE FOURTH DIGIT OF INFO. +C D5: THE FIFTH DIGIT OF INFO. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE ESTIMATED VALUES OF EPSILON. +C FMT1: A CHARACTER*90 VARIABLE USED FOR FORMATS. +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB2: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE +C ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK +C DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1, +C 0, AND -1, RESPECTIVELY. IF IFIXB2 IS -2, THEN NO ATTEMPT +C WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPR: THE VARIABLE INDICATING WHAT IS TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPLM1: THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS +C TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE +C MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. +C TVAL: THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE +C T DISTRIBUTION. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. + + +C***FIRST EXECUTABLE STATEMENT DODPC3 + + + D1 = INFO/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT STOPPING CONDITIONS + + WRITE (LUNRPT,1000) + IF (INFO.LE.9) THEN + IF (INFO.EQ.1) THEN + WRITE (LUNRPT,1011) INFO + ELSE IF (INFO.EQ.2) THEN + WRITE (LUNRPT,1012) INFO + ELSE IF (INFO.EQ.3) THEN + WRITE (LUNRPT,1013) INFO + ELSE IF (INFO.EQ.4) THEN + WRITE (LUNRPT,1014) INFO + ELSE IF (INFO.LE.9) THEN + WRITE (LUNRPT,1015) INFO + END IF + ELSE IF (INFO.LE.9999) THEN + +C PRINT WARNING DIAGNOSTICS + + WRITE (LUNRPT,1020) INFO + IF (D2.EQ.1) WRITE (LUNRPT,1021) + IF (D3.EQ.1) WRITE (LUNRPT,1022) + IF (D4.EQ.1) WRITE (LUNRPT,1023) + IF (D4.EQ.2) WRITE (LUNRPT,1024) + IF (D5.EQ.1) THEN + WRITE (LUNRPT,1031) + ELSE IF (D5.EQ.2) THEN + WRITE (LUNRPT,1032) + ELSE IF (D5.EQ.3) THEN + WRITE (LUNRPT,1033) + ELSE IF (D5.EQ.4) THEN + WRITE (LUNRPT,1034) + ELSE IF (D5.LE.9) THEN + WRITE (LUNRPT,1035) D5 + END IF + ELSE + +C PRINT ERROR MESSAGES + + WRITE (LUNRPT,1040) INFO + IF (D1.EQ.5) THEN + WRITE (LUNRPT,1042) + IF (D2.NE.0) WRITE (LUNRPT,1043) D2 + IF (D3.EQ.3) THEN + WRITE (LUNRPT,1044) D3 + ELSE IF (D3.NE.0) THEN + WRITE (LUNRPT,1045) D3 + END IF + ELSE IF (D1.EQ.6) THEN + WRITE (LUNRPT,1050) + ELSE + WRITE (LUNRPT,1060) D1 + END IF + END IF + +C PRINT MISC. STOPPING INFO + + WRITE (LUNRPT,1300) NITER + WRITE (LUNRPT,1310) NFEV + IF (ANAJAC) WRITE (LUNRPT,1320) NJEV + WRITE (LUNRPT,1330) IRANK + WRITE (LUNRPT,1340) RCOND + WRITE (LUNRPT,1350) ISTOP + +C PRINT FINAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,2000) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,2100) WSS + IF (ISODR) THEN + WRITE (LUNRPT,2110) WSSDEL,WSSEPS + END IF + END IF + IF (DIDVCV) THEN + WRITE (LUNRPT,2200) SQRT(RVAR),IDF + END IF + + NPLM1 = 3 + +C PRINT ESTIMATED BETA'S, AND, +C IF, FULL RANK, THEIR STANDARD ERRORS + + WRITE (LUNRPT,3000) + IF (DIDVCV) THEN + WRITE (LUNRPT,7300) + TVAL = DPPT(0.975D0,IDF) + DO 10 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J), + + BETA(J)-TVAL*SDBETA(J), + + BETA(J)+TVAL*SDBETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 10 CONTINUE + IF (.NOT.REDOJ) WRITE (LUNRPT,7310) + ELSE + IF (DOVCV) THEN + IF (D1.LE.5) THEN + WRITE (LUNRPT,7410) + ELSE + WRITE (LUNRPT,7420) + END IF + END IF + + IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN + IF (NP.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 20 J=1,NP,NPLM1+1 + K = MIN(J+NPLM1,NP) + IF (K.EQ.J) THEN + WRITE (LUNRPT,8100) J,BETA(J) + ELSE + WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) + END IF + 20 CONTINUE + IF (NITER.GE.1) THEN + WRITE (LUNRPT,8800) + ELSE + WRITE (LUNRPT,8900) + END IF + ELSE + WRITE (LUNRPT,7500) + DO 30 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8500) J,BETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 30 CONTINUE + END IF + END IF + + IF (IPR.EQ.1) RETURN + + +C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF +C COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE. + + IF (IMPLCT .AND. (M.LE.4)) THEN + WRITE (LUNRPT,4100) + WRITE (FMT1,9110) M + WRITE (LUNRPT,FMT1) (J,J=1,M) + DO 40 I=1,N + WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) + 40 CONTINUE + + ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN + WRITE (LUNRPT,4110) + WRITE (FMT1,9120) NQ,M + WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) + DO 50 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) + 50 CONTINUE + + ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN + WRITE (LUNRPT,4120) + WRITE (FMT1,9130) NQ + WRITE (LUNRPT,FMT1) (L,L=1,NQ) + DO 60 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) + 60 CONTINUE + ELSE + +C PRINT EPSILON'S AND DELTA'S SEPARATELY + + IF (.NOT.IMPLCT) THEN + +C PRINT EPSILON'S + + DO 80 J=1,NQ + WRITE (LUNRPT,4200) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 70 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,F(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) + END IF + 70 CONTINUE + 80 CONTINUE + END IF + +C PRINT DELTA'S + + IF (ISODR) THEN + DO 100 J=1,M + WRITE (LUNRPT,4300) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 90 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,DELTA(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) + END IF + 90 CONTINUE + 100 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- STOPPING CONDITIONS:') + 1011 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.') + 1012 FORMAT + + (' INFO = ',I5,' ==> PARAMETER CONVERGENCE.') + 1013 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND', + + ' PARAMETER CONVERGENCE.') + 1014 FORMAT + + (' INFO = ',I5,' ==> ITERATION LIMIT REACHED.') + 1015 FORMAT + + (' INFO = ',I5,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1020 FORMAT + + (' INFO = ',I5.4/ + + ' = ABCD, WHERE A NONZERO VALUE FOR DIGIT A,', + + ' B, OR C INDICATES WHY'/ + + ' THE RESULTS MIGHT BE QUESTIONABLE,', + + ' AND DIGIT D INDICATES'/ + + ' THE ACTUAL STOPPING CONDITION.') + 1021 FORMAT + + (' A=1 ==> DERIVATIVES ARE', + + ' QUESTIONABLE.') + 1022 FORMAT + + (' B=1 ==> USER SET ISTOP TO', + + ' NONZERO VALUE DURING LAST'/ + + ' CALL TO SUBROUTINE FCN.') + 1023 FORMAT + + (' C=1 ==> DERIVATIVES ARE NOT', + + ' FULL RANK AT THE SOLUTION.') + 1024 FORMAT + + (' C=2 ==> DERIVATIVES ARE ZERO', + + ' RANK AT THE SOLUTION.') + 1031 FORMAT + + (' D=1 ==> SUM OF SQUARES CONVERGENCE.') + 1032 FORMAT + + (' D=2 ==> PARAMETER CONVERGENCE.') + 1033 FORMAT + + (' D=3 ==> SUM OF SQUARES CONVERGENCE', + + ' AND PARAMETER CONVERGENCE.') + 1034 FORMAT + + (' D=4 ==> ITERATION LIMIT REACHED.') + 1035 FORMAT + + (' D=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1040 FORMAT + + (' INFO = ',I5.5/ + + ' = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN', + + ' DIGIT INDICATES AN'/ + + ' ABNORMAL STOPPING CONDITION.') + 1042 FORMAT + + (' A=5 ==> USER STOPPED COMPUTATIONS', + + ' IN SUBROUTINE FCN.') + 1043 FORMAT + + (' B=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' FUNCTION EVALUATION.') + 1044 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED BECAUSE'/ + + ' DERIVATIVES WITH', + + ' RESPECT TO DELTA WERE'/ + + ' COMPUTED BY', + + ' SUBROUTINE FCN WHEN'/ + + ' FIT IS OLS.') + 1045 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' JACOBIAN EVALUATION.') + 1050 FORMAT + + (' A=6 ==> NUMERICAL INSTABILITIES', + + ' HAVE BEEN DETECTED,'/ + + ' POSSIBLY INDICATING', + + ' A DISCONTINUITY IN THE'/ + + ' DERIVATIVES OR A POOR', + + ' POOR CHOICE OF PROBLEM'/ + + ' SCALE OR WEIGHTS.') + 1060 FORMAT + + (' A=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1300 FORMAT + + (' NITER = ',I5, + + ' (NUMBER OF ITERATIONS)') + 1310 FORMAT + + (' NFEV = ',I5, + + ' (NUMBER OF FUNCTION EVALUATIONS)') + 1320 FORMAT + + (' NJEV = ',I5, + + ' (NUMBER OF JACOBIAN EVALUATIONS)') + 1330 FORMAT + + (' IRANK = ',I5, + + ' (RANK DEFICIENCY)') + 1340 FORMAT + + (' RCOND = ',1P,D12.2, + + ' (INVERSE CONDITION NUMBER)') +*1341 FORMAT +* + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', +* + ' DIGITS IN RESULTS;'/ +* + ' SEE ODRPACK REFERENCE', +* + ' GUIDE, SECTION 4.C.') + 1350 FORMAT + + (' ISTOP = ',I5, + + ' (RETURNED BY USER FROM', + + ' SUBROUTINE FCN)') + 2000 FORMAT + + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ', + + 17X,1P,D17.8) + 2010 FORMAT + + ( ' FINAL PENALTY FUNCTION VALUE = ',1P,D17.8/ + + ' PENALTY TERM = ',1P,D17.8/ + + ' PENALTY PARAMETER = ',1P,D10.1) + 2100 FORMAT + + (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,D17.8) + 2110 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8) + 2200 FORMAT + + (/' --- RESIDUAL STANDARD DEVIATION = ', + + 17X,1P,D17.8/ + + ' DEGREES OF FREEDOM =',I5) + 3000 FORMAT + + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:') + 4100 FORMAT + + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:') + 4110 FORMAT + + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:') + 4120 FORMAT + + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:') + 4130 FORMAT(5X,I5,1P,5D16.8) + 4200 FORMAT + + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:') + 4300 FORMAT + + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:') + 7100 FORMAT + + (/' INDEX VALUE'/) + 7200 FORMAT + + (/' INDEX VALUE -------------->'/) + 7300 FORMAT + + (/' BETA S.D. BETA', + + ' ---- 95% CONFIDENCE INTERVAL ----'/) + 7310 FORMAT + + (/' N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE', + + ' COMPUTED USING'/ + + ' DERIVATIVES CALCULATED AT THE BEGINNING', + + ' OF THE LAST ITERATION,'/ + + ' AND NOT USING DERIVATIVES RE-EVALUATED AT THE', + + ' FINAL SOLUTION.') + 7410 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED BECAUSE'/ + + ' THE DERIVATIVES WERE NOT AVAILABLE. EITHER MAXIT', + + ' IS 0 AND THE THIRD'/ + + ' DIGIT OF JOB IS GREATER THAN 1, OR THE MOST', + + ' RECENTLY TRIED VALUES OF'/ + + ' BETA AND/OR X+DELTA WERE IDENTIFIED AS', + + ' UNACCEPTABLE BY USER SUPPLIED'/ + + ' SUBROUTINE FCN.') + 7420 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED.'/ + + ' (SEE INFO ABOVE.)') + 7500 FORMAT + + (/' BETA STATUS') + 8100 FORMAT + + (11X,I5,1P,D16.8) + 8200 FORMAT + + (3X,I5,' TO',I5,1P,7D16.8) + 8400 FORMAT + + (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8) + 8500 FORMAT + + (3X,I5,1X,1P,D16.8,6X,'ESTIMATED') + 8600 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' FIXED') + 8700 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' DROPPED') + 8800 FORMAT + + (/' N.B. NO PARAMETERS WERE FIXED BY THE USER OR', + + ' DROPPED AT THE LAST'/ + + ' ITERATION BECAUSE THEY CAUSED THE MODEL TO BE', + + ' RANK DEFICIENT.') + 8900 FORMAT + + (/' N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER', + + ' VALUES BECAUSE'/ + + ' MAXIT=0.') + 9110 FORMAT + + ('(/'' I'',', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9120 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')''),', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9130 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')'')/)') + + END +*DODPCR + SUBROUTINE DODPCR + + (IPR,LUNRPT, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,SDBETA, + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) +C***BEGIN PROLOGUE DODPCR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE COMPUTATION REPORTS +C***END PROLOGUE DODPCR + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + + SSTOL,TAU,TAUFAC + INTEGER + + IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, + + LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, + + NITER,NJEV,NNZW,NP,NPP,NQ + LOGICAL + + DIDVCV,FSTITR,HEAD,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP), + + STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + DOUBLE PRECISION + + PNLTY + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + CHARACTER TYP*3 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TT: THE SCALING VALUES FOR DELTA. +C TYP: THE CHARACTER*3 STRING "ODR" OR "OLS". +C WE: THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODPCR + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + PNLTY = ABS(WE(1,1,1)) + + IF (HEAD) THEN + CALL DODPHD(HEAD,LUNRPT) + END IF + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + +C PRINT INITIAL SUMMARY + + IF (IFLAG.EQ.1) THEN + WRITE (LUNRPT,1200) TYP + CALL DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB(1),MSGB(2),MSGD(1),MSGD(2), + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS(1),WSS(2),WSS(3)) + +C PRINT ITERATION REPORTS + + ELSE IF (IFLAG.EQ.2) THEN + + IF (FSTITR) THEN + WRITE (LUNRPT,1300) TYP + END IF + CALL DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) + +C PRINT FINAL SUMMARY + + ELSE IF (IFLAG.EQ.3) THEN + + WRITE (LUNRPT,1400) TYP + CALL DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB,F,DELTA) + END IF + + RETURN + +C FORMAT STATEMENTS + + 1200 FORMAT + + (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + 1300 FORMAT + + (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***') + 1400 FORMAT + + (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + + END +*DODPE1 + SUBROUTINE DODPE1 + + (UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) +C***BEGIN PROLOGUE DODPE1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS +C***END PROLOGUE DODPE1 + +C...SCALAR ARGUMENTS + INTEGER + + D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, + + LIWKMN,LWKMN,M,N,NQ,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE1 + + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION +C PARAMETERS + + IF (D1.EQ.1) THEN + IF (D2.NE.0) THEN + WRITE(UNIT,1100) + END IF + IF (D3.NE.0) THEN + WRITE(UNIT,1200) + END IF + IF (D4.NE.0) THEN + WRITE(UNIT,1300) + END IF + IF (D5.NE.0) THEN + WRITE(UNIT,1400) + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION +C PARAMETERS + + ELSE IF (D1.EQ.2) THEN + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + WRITE(UNIT,2110) + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,2120) + END IF + END IF + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN + WRITE(UNIT,2210) + END IF + IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2220) + END IF + IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2230) + END IF + END IF + + IF (D4.NE.0) THEN + IF (D4.EQ.1 .OR. D4.EQ.3) THEN + WRITE(UNIT,2310) + END IF + IF (D4.EQ.2 .OR. D4.EQ.3) THEN + WRITE(UNIT,2320) + END IF + END IF + + IF (D5.NE.0) THEN + IF (D5.EQ.1 .OR. D5.EQ.3) THEN + WRITE(UNIT,2410) LWKMN + END IF + IF (D5.EQ.2 .OR. D5.EQ.3) THEN + WRITE(UNIT,2420) LIWKMN + END IF + END IF + + ELSE IF (D1.EQ.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + IF (LDSCLD.GE.N) THEN + WRITE(UNIT,3110) + ELSE + WRITE(UNIT,3120) + END IF + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,3130) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3) THEN + IF (LDSTPD.GE.N) THEN + WRITE(UNIT,3210) + ELSE + WRITE(UNIT,3220) + END IF + END IF + IF (D3.EQ.2 .OR. D3.EQ.3) THEN + WRITE(UNIT,3230) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS + + IF (D4.NE.0) THEN + IF (D4.EQ.1) THEN + IF (LDWE.GE.N) THEN + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3310) + ELSE + WRITE(UNIT,3320) + END IF + ELSE + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3410) + ELSE + WRITE(UNIT,3420) + END IF + END IF + END IF + IF (D4.EQ.2) THEN + WRITE(UNIT,3500) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS + + IF (D5.NE.0) THEN + IF (LDWD.GE.N) THEN + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4310) + ELSE + WRITE(UNIT,4320) + END IF + ELSE + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4410) + ELSE + WRITE(UNIT,4420) + END IF + END IF + END IF + + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (/' ERROR : N IS LESS THAN ONE.') + 1200 FORMAT + + (/' ERROR : M IS LESS THAN ONE.') + 1300 FORMAT + + (/' ERROR : NP IS LESS THAN ONE'/ + + ' OR NP IS GREATER THAN N.') + 1400 FORMAT + + (/' ERROR : NQ IS LESS THAN ONE.') + 2110 FORMAT + + (/' ERROR : LDX IS LESS THAN N.') + 2120 FORMAT + + (/' ERROR : LDY IS LESS THAN N.') + 2210 FORMAT + + (/' ERROR : LDIFX IS LESS THAN N'/ + + ' AND LDIFX IS NOT EQUAL TO ONE.') + 2220 FORMAT + + (/' ERROR : LDSCLD IS LESS THAN N'/ + + ' AND LDSCLD IS NOT EQUAL TO ONE.') + 2230 FORMAT + + (/' ERROR : LDSTPD IS LESS THAN N'/ + + ' AND LDSTPD IS NOT EQUAL TO ONE.') + 2310 FORMAT + + (/' ERROR : LDWE IS LESS THAN N'/ + + ' AND LDWE IS NOT EQUAL TO ONE OR'/ + + ' OR'/ + + ' LD2WE IS LESS THAN NQ'/ + + ' AND LD2WE IS NOT EQUAL TO ONE.') + 2320 FORMAT + + (/' ERROR : LDWD IS LESS THAN N'/ + + ' AND LDWD IS NOT EQUAL TO ONE.') + 2410 FORMAT + + (/' ERROR : LWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') + 2420 FORMAT + + (/' ERROR : LIWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', + + ' IWORK.') + 3110 FORMAT + + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3120 FORMAT + + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3130 FORMAT + + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' SCLB MUST BE GREATER THAN ZERO.') + 3210 FORMAT + + (/' ERROR : STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3220 FORMAT + + (/' ERROR : STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3230 FORMAT + + (/' ERROR : STPB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' STPB MUST BE GREATER THAN ZERO.') + 3310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' SEMIDEFINITE. WHEN WE(1,1,1) IS GREATER THAN'/ + + ' OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/ + + ' EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/ + + ' TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/ + + ' MUST BE POSITIVE SEMIDEFINITE.') + 3320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/ + + ' ELEMENT. WHEN WE(1,1,1) IS GREATER THAN OR'/ + + ' EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/ + + ' TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/ + + ' (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/ + + ' NEGATIVE ELEMENTS.') + 3410 FORMAT + + (/' ERROR : THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/ + + ' NOT POSITIVE SEMIDEFINITE. WHEN WE(1,1,1) IS'/ + + ' GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/ + + ' TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/ + + ' THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/ + + ' SEMIDEFINITE.') + 3420 FORMAT + + (/' ERROR : THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/ + + ' A NEGATIVE ELEMENT. WHEN WE(1,1,1) IS GREATER'/ + + ' THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/ + + ' AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/ + + ' ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.') + 3500 FORMAT + + (/' ERROR : THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/ + + ' LESS THAN NP.') + 4310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' DEFINITE. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/ + + ' OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/ + + ' DEFINITE.') + 4320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/ + + ' ELEMENT. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/ + + ' ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.') + 4410 FORMAT + + (/' ERROR : THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/ + + ' NOT POSITIVE DEFINITE. WHEN WD(1,1,1) IS'/ + + ' GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/ + + ' (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.') + 4420 FORMAT + + (/' ERROR : THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/ + + ' NONPOSITIVE ELEMENT. WHEN WD(1,1,1) IS GREATER'/ + + ' THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/ + + ' EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/ + + ' HAVE ONLY POSITIVE ELEMENTS.') + END +*DODPE2 + SUBROUTINE DODPE2 + + (UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPE2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT +C***END PROLOGUE DODPE2 + +C...SCALAR ARGUMENTS + INTEGER + + M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + INTEGER + + I,J,K,L + CHARACTER FLAG*1,TYP*3 + +C...LOCAL ARRAYS + LOGICAL + + FTNOTE(0:7) + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FLAG: THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS. +C FTNOTE: THE ARRAY CONTROLING FOOTNOTES. +C I: AN INDEX VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C TYP: THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPE2 + + +C SET UP FOR FOOTNOTES + + DO 10 I=0,7 + FTNOTE(I) = .FALSE. + 10 CONTINUE + + DO 40 L=1,NQ + IF (MSGB1.GE.1) THEN + DO 20 I=1,NP + IF (MSGB(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGB(L,I)) = .TRUE. + END IF + 20 CONTINUE + END IF + + IF (MSGD1.GE.1) THEN + DO 30 I=1,M + IF (MSGD(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGD(L,I)) = .TRUE. + END IF + 30 CONTINUE + END IF + 40 CONTINUE + +C PRINT REPORT + + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + WRITE (UNIT,1000) TYP + + DO 70 L=1,NQ + + WRITE (UNIT,2100) L,NROW + WRITE (UNIT,2200) + + DO 50 I=1,NP + K = MSGB(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,3100) I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K + END IF + 50 CONTINUE + IF (ISODR) THEN + DO 60 I=1,M + K = MSGD(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,4100) NROW,I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,4200) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,4300) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K + END IF + 60 CONTINUE + END IF + 70 CONTINUE + +C PRINT FOOTNOTES + + IF (FTNOTE(0)) THEN + + WRITE (UNIT,5000) + IF (FTNOTE(1)) WRITE (UNIT,5100) + IF (FTNOTE(2)) WRITE (UNIT,5200) + IF (FTNOTE(3)) WRITE (UNIT,5300) + IF (FTNOTE(4)) WRITE (UNIT,5400) + IF (FTNOTE(5)) WRITE (UNIT,5500) + IF (FTNOTE(6)) WRITE (UNIT,5600) + IF (FTNOTE(7)) WRITE (UNIT,5700) + END IF + + IF (NETA.LT.0) THEN + WRITE (UNIT,6000) -NETA + ELSE + WRITE (UNIT,6100) NETA + END IF + WRITE (UNIT,7000) NTOL + +C PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED. + + WRITE (UNIT,8100) NROW + + DO 80 J=1,M + WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) + 80 CONTINUE + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3, + + ' ***'/) + 2100 FORMAT (/' FOR RESPONSE ',I2,' OF OBSERVATION ', I5/) + 2200 FORMAT (' ',' USER', + + ' ',' '/ + + ' ',' SUPPLIED', + + ' RELATIVE',' DERIVATIVE '/ + + ' DERIVATIVE WRT',' VALUE', + + ' DIFFERENCE',' ASSESSMENT '/) + 3100 FORMAT (' BETA(',I3,')', ' --- ', + + ' --- ',' UNCHECKED') + 3200 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 3300 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', + + ' --- ',' UNCHECKED') + 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 5000 FORMAT + + (/' NOTES:') + 5100 FORMAT + + (/' (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.') + 5200 FORMAT + + (/' (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS ONLY APPROXIMATELY ZERO.') + 5300 FORMAT + + (/' (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS NOT.') + 5400 FORMAT + + (/' (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE EITHER'/ + + ' THE RATIO OF RELATIVE CURVATURE TO RELATIVE', + + ' SLOPE IS TOO HIGH'/ + + ' OR THE SCALE IS WRONG.') + 5500 FORMAT + + (/' (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE THE'/ + + ' RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS', + + ' TOO HIGH.') + 5600 FORMAT + + (/' (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' HAVE AT LEAST 2 DIGITS IN COMMON.') + 5700 FORMAT + + (/' (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, AND'/ + + ' HAVE FEWER THAN 2 DIGITS IN COMMON. DERIVATIVE', + + ' CHECKING MUST'/ + + ' BE TURNED OFF IN ORDER TO PROCEED.') + 6000 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (ESTIMATED BY ODRPACK)') + 6100 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (SUPPLIED BY USER)') + 7000 FORMAT + + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ + + ' USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ + + ' USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED ', + + I5) + 8100 FORMAT + + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ', + + I5// + + ' -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/) + 8110 FORMAT + + (10X,'X(',I2,',',I2,')',1X,1P,3D16.8) + END +*DODPE3 + SUBROUTINE DODPE3 + + (UNIT,D2,D3) +C***BEGIN PROLOGUE DODPE3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE +C STOPPED IN USER SUPPLIED SUBROUTINES FCN +C***END PROLOGUE DODPE3 + +C...SCALAR ARGUMENTS + INTEGER + + D2,D3,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE3 + + +C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE +C STOPPED + + IF (D2.EQ.2) THEN + WRITE(UNIT,1100) + ELSE IF (D2.EQ.3) THEN + WRITE(UNIT,1200) + ELSE IF (D2.EQ.4) THEN + WRITE(UNIT,1300) + END IF + IF (D3.EQ.2) THEN + WRITE(UNIT,1400) + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/ + + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + + ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE '/ + + ' REGRESSION PROCEDURE CAN CONTINUE.') + 1200 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/ + + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ + + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ + + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ + + ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. THE '/ + + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1300 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ + + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ + + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ + + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ + + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ + + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, '/ + + ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. '/ + + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1400 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/ + + ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/ + + ' BETA AND DELTA SUPPLIED BY THE USER. THE INITIAL '/ + + ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/ + + ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/ + + ' CONTINUE.') + END +*DODPER + SUBROUTINE DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + FJACB,FJACD, + + DIFF,MSGB,ISODR,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPER +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS +C***END PROLOGUE DODPER + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, + + M,N,NETA,NP,NQ,NROW,NTOL + LOGICAL + + ISODR,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + INTEGER + + D1,D2,D3,D4,D5,UNIT + LOGICAL + + HEAD + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODPE1,DODPE2,DODPE3,DODPHD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C XPLUSD: THE VALUES X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPER + + +C SET LOGICAL UNIT NUMBER FOR ERROR REPORT + + IF (LUNERR.EQ.0) THEN + RETURN + ELSE IF (LUNERR.LT.0) THEN + UNIT = 6 + ELSE + UNIT = LUNERR + END IF + +C PRINT HEADING + + HEAD = .TRUE. + CALL DODPHD(HEAD,UNIT) + +C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO + + D1 = MOD(INFO,100000)/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP + + IF (D1.GE.1 .AND. D1.LE.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN +C PROBLEM SPECIFICATION PARAMETERS +C DIMENSION SPECIFICATION PARAMETERS +C NUMBER OF GOOD DIGITS IN X +C WEIGHTS + + CALL DODPE1(UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) + + ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN + +C PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING + + CALL DODPE2(UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), + + XPLUSD,NROW,NETA,NTOL) + + ELSE IF (D1.EQ.5) THEN + +C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN + + CALL DODPE3(UNIT,D2,D3) + + END IF + +C PRINT CORRECT FORM OF CALL STATEMENT + + IF ((D1.GE.1 .AND. D1.LE.3) .OR. + + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + + (D1.EQ.5)) THEN + IF (SHORT) THEN + WRITE (UNIT,1100) + ELSE + WRITE (UNIT,1200) + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' 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)') + 1200 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' 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 +*DODPHD + SUBROUTINE DODPHD + + (HEAD,UNIT) +C***BEGIN PROLOGUE DODPHD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ODRPACK HEADING +C***END PROLOGUE DODPHD + +C...SCALAR ARGUMENTS + INTEGER + + UNIT + LOGICAL + + HEAD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. + + +C***FIRST EXECUTABLE STATEMENT DODPHD + + + IF (HEAD) THEN + WRITE(UNIT,1000) + HEAD = .FALSE. + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT ( + + ' ******************************************************* '/ + + ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/ + + ' ******************************************************* '/) + END +*DODSTP + SUBROUTINE DODSTP + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,KPVT, + + S,T,PHI,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODSTP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT, +C DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) +C***END PROLOGUE DODSTP + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA,EPSFCN,PHI,RCOND + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) + INTEGER + + KPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CO,ONE,SI,TEMP,ZERO + INTEGER + + I,IMAX,INF,IPVT,J,K,K1,K2,KP,L + LOGICAL + + ELIM,FORVCV + +C...LOCAL ARRAYS + DOUBLE PRECISION + + DUM(2) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DNRM2 + INTEGER + + IDAMAX + EXTERNAL + + DNRM2,IDAMAX + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, + + DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C CO: THE COSINE FROM THE PLANE ROTATION. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DUM: A DUMMY ARRAY. +C ELIM: THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN +C WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT +C (ELIM=FALSE). +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C INF: THE RETURN CODE FROM LINPACK ROUTINES. +C IPVT: THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C K2: AN INDEXING VARIABLE. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C KPVT: THE PIVOT VECTOR. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C ONE: THE VALUE 1.0D0. +C PHI: THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C S: THE STEP FOR BETA. +C SI: THE SINE FROM THE PLANE ROTATION. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODSTP + + +C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE + +C SET UP KPVT IF ALPHA = 0 + + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + DO 10 K=1,NP + KPVT(K) = K + 10 CONTINUE + ELSE + IF (NPP.GE.1) THEN + KP = NPP-IRANK + ELSE + KP = NPP + END IF + END IF + + IF (ISODR) THEN + +C T = WD * DELTA = D*G2 + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N) + + DO 300 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE OMEGA, SUCH THAT +C TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD) +C INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD) + CALL DVEVTR(M,NQ,I, + + FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) + DO 110 L=1,NQ + OMEGA(L,L) = ONE + OMEGA(L,L) + 110 CONTINUE + CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) +C = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA) + DO 130 J=1,M + DO 120 L=1,NQ + WRK1(I,L,J) = FJACD(I,J,L) + 120 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4) + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2) + 130 CONTINUE + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 140 J=1,M + WRK5(J) = T(I,J) + 140 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + +C COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB + DO 170 K=1,KP + DO 150 L=1,NQ + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + 150 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4) + DO 160 L=1,NQ + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 160 CONTINUE + 170 CONTINUE + +C COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1) + DO 190 L=1,NQ + WRK2(I,L) = ZERO + DO 180 J=1,M + WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) + 180 CONTINUE + WRK2(I,L) = WRK2(I,L) - F(I,L) + 190 CONTINUE + +C COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1) + CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4) + 300 CONTINUE + + ELSE + DO 360 I=1,N + DO 350 L=1,NQ + DO 340 K=1,KP + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 340 CONTINUE + WRK2(I,L) = -F(I,L) + 350 CONTINUE + 360 CONTINUE + END IF + +C COMPUTE S + +C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) + + IF (ALPHA.EQ.ZERO) THEN + IPVT = 1 + DO 410 K=1,NP + KPVT(K) = 0 + 410 CONTINUE + ELSE + IPVT = 0 + END IF + + CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) + CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, + + QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C ELIMINATE ALPHA PART USING GIVENS ROTATIONS + + IF (ALPHA.NE.ZERO) THEN + CALL DZERO(NPP,1,S,NPP) + DO 430 K1=1,KP + CALL DZERO(KP,1,WRK3,KP) + WRK3(K1) = SQRT(ALPHA) + DO 420 K2=K1,KP + CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) + IF (KP-K2.GE.1) THEN + CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, + + WRK3(K2+1),1,CO,SI) + END IF + TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) + S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) + WRK2(K2,1) = TEMP + 420 CONTINUE + 430 CONTINUE + END IF + +C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY + + IF (NPP.GE.1) THEN + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + +C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR + + 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) + IF (RCOND.LE.EPSFCN) THEN + ELIM = .TRUE. + IMAX = IDAMAX(KP,U,1) + +C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT + + IF (IMAX.NE.KP) THEN + CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, + + QRAUX,WRK3,2) + K = KPVT(IMAX) + DO 450 I=IMAX,KP-1 + KPVT(I) = KPVT(I+1) + 450 CONTINUE + KPVT(KP) = K + END IF + KP = KP-1 + ELSE + ELIM = .FALSE. + END IF + IF (ELIM .AND. KP.GE.1) THEN + GO TO 440 + ELSE + IRANK = NPP-KP + END IF + END IF + END IF + + IF (FORVCV) RETURN + +C BACKSOLVE AND UNSCRAMBLE + + IF (NPP.GE.1) THEN + DO 510 I=KP+1,NPP + WRK2(I,1) = ZERO + 510 CONTINUE + IF (KP.GE.1) THEN + CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + END IF + DO 520 I=1,NPP + IF (SS(1).GT.ZERO) THEN + S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) + ELSE + S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) + END IF + 520 CONTINUE + END IF + + IF (ISODR) THEN + +C NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE, +C WHERE T = WD * DELTA = D*G2 +C WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) + + DO 670 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 610 J=1,M + WRK5(J) = T(I,J) + 610 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + + DO 640 L=1,NQ + WRK2(I,L) = F(I,L) + DO 620 K=1,NPP + WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) + 620 CONTINUE + DO 630 J=1,M + WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) + 630 CONTINUE + 640 CONTINUE + + DO 660 J=1,M + WRK5(J) = ZERO + DO 650 L=1,NQ + WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) + 650 CONTINUE + T(I,J) = -(WRK5(J) + T(I,J)) + 660 CONTINUE + CALL DSOLVE(M,WRK4,M,T(I,1),N,4) + CALL DSOLVE(M,WRK4,M,T(I,1),N,2) + 670 CONTINUE + + END IF + +C COMPUTE PHI(ALPHA) FROM SCALED S AND T + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + PHI = DNRM2(NPP+N*M,WRK,1) + ELSE + PHI = DNRM2(NPP,WRK,1) + END IF + + RETURN + END +*DODVCV + SUBROUTINE DODVCV + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + EPSFCN,ISODR, + + VCV,SD, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODVCV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPODI,DODSTP +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C***END PROLOGUE DODVCV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSFCN,RCOND,RSS,RVAR + INTEGER + + IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ), + + FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), + + T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), + + WRK6(N*NQ,NP),WRK(LWRK) + INTEGER + + IFIXB(NP),JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,IUNFIX,J,JUNFIX,KP,L + LOGICAL + + FORVCV + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPODI,DODSTP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C IUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C J: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C JUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR FJACB. +C VCV: THE COVARIANCE MATRIX OF THE ESTIMATED BETAS. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C WRK6: A WORK ARRAY OF (N*NQ BY P) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODVCV + + + FORVCV = .TRUE. + ISTOPC = 0 + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ZERO,EPSFCN,ISODR, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,TEMP,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + KP = NPP - IRANK + CALL DPODI (WRK6,N*NQ,KP,WRK3,1) + + IDF = 0 + DO 150 I=1,N + DO 120 J=1,NPP + DO 110 L=1,NQ + IF (FJACB(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 110 CONTINUE + 120 CONTINUE + IF (ISODR) THEN + DO 140 J=1,M + DO 130 L=1,NQ + IF (FJACD(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 130 CONTINUE + 140 CONTINUE + END IF + 150 CONTINUE + + IF (IDF.GT.KP) THEN + IDF = IDF - KP + RVAR = RSS/IDF + ELSE + IDF = 0 + RVAR = RSS + END IF + +C STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER + + DO 200 I=1,NP + SD(I) = ZERO + 200 CONTINUE + DO 210 I=1,KP + SD(JPVT(I)) = WRK6(I,I) + 210 CONTINUE + IF (NP.GT.NPP) THEN + JUNFIX = NPP + DO 220 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + SD(J) = ZERO + ELSE + SD(J) = SD(JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 220 CONTINUE + END IF + +C STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER + + DO 310 I=1,NP + DO 300 J=1,I + VCV(I,J) = ZERO + 300 CONTINUE + 310 CONTINUE + DO 330 I=1,KP + DO 320 J=I+1,KP + IF (JPVT(I).GT.JPVT(J)) THEN + VCV(JPVT(I),JPVT(J))=WRK6(I,J) + ELSE + VCV(JPVT(J),JPVT(I))=WRK6(I,J) + END IF + 320 CONTINUE + 330 CONTINUE + IF (NP.GT.NPP) THEN + IUNFIX = NPP + DO 360 I=NP,1,-1 + IF (IFIXB(I).EQ.0) THEN + DO 340 J=I,1,-1 + VCV(I,J) = ZERO + 340 CONTINUE + ELSE + JUNFIX = NPP + DO 350 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + VCV(I,J) = ZERO + ELSE + VCV(I,J) = VCV(IUNFIX,JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 350 CONTINUE + IUNFIX = IUNFIX - 1 + END IF + 360 CONTINUE + END IF + + DO 380 I=1,NP + VCV(I,I) = SD(I) + SD(I) = SQRT(RVAR*SD(I)) + DO 370 J=1,I + VCV(J,I) = VCV(I,J) + 370 CONTINUE + 380 CONTINUE + +C UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX + DO 410 I=1,NP + IF (SSF(1).GT.ZERO) THEN + SD(I) = SD(I)/SSF(I) + ELSE + SD(I) = SD(I)/ABS(SSF(1)) + END IF + DO 400 J=1,NP + IF (SSF(1).GT.ZERO) THEN + VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) + ELSE + VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) + END IF + 400 CONTINUE + 410 CONTINUE + + RETURN + END +*DPACK + SUBROUTINE DPACK + + (N2,N1,V1,V2,IFIX) +C***BEGIN PROLOGUE DPACK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 +C***END PROLOGUE DPACK + +C...SCALAR ARGUMENTS + INTEGER + + N1,N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS FROM V2. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE +C UNFIXED ELEMENTS ARE TO BE EXTRACTED. + + +C***FIRST EXECUTABLE STATEMENT DPACK + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I=1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1+1 + V1(N1) = V2(I) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY(N2,V2,1,V1,1) + END IF + + RETURN + END +*DPPNML + DOUBLE PRECISION FUNCTION DPPNML + + (P) +C***BEGIN PROLOGUE DPPNML +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--JUNE 1972. +C (UPDATED --SEPTEMBER 1975, +C NOVEMBER 1975, AND +C OCTOBER 1976. +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD +C DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION +C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --THE CODING AS PRESENTED BELOW IS ESSENTIALLY +C IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS +C AS ALGORTIHM 70 OF APPLIED STATISTICS. +C --AS POINTED OUT BY ODEH AND EVANS IN APPLIED +C STATISTICS, THEIR ALGORITHM REPRESENTES A +C SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED +C HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT +C FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4) +C TO 1.5*(10**-8). +C***REFERENCES ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL +C DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, +C PAGES 96-97. +C EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND +C RATIONAL APPROXIMATION, M. SC. THESIS, 1972, +C UNIVERSITY OF VICTORIA, B. C., CANADA. +C HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, +C PAGES 113, 191, 192. +C NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS +C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. +C FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE +C LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION +C (UNPUBLISHED PH.D. DISSERTATION, PRINCETON +C UNIVERSITY), 1969, PAGES 21-44, 229-231. +C FILLIBEN, "THE PERCENT POINT FUNCTION", +C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 1, 1970, PAGES 40-111. +C KELLEY STATISTICAL TABLES, 1948. +C OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16. +C PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR +C STATISTICIANS, VOLUME 1, 1954, PAGES 104-113. +C***END PROLOGUE DPPNML + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + +C...LOCAL SCALARS + DOUBLE PRECISION + + ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + LOG,SQRT + +C...DATA STATEMENTS + DATA + + P0,P1,P2,P3,P4 + + /-0.322232431088D0,-1.0D0,-0.342242088547D0, + + -0.204231210245D-1,-0.453642210148D-4/ + DATA + + Q0,Q1,Q2,Q3,Q4 + + /0.993484626060D-1,0.588581570495D0, + + 0.531103462366D0,0.103537752850D0,0.38560700634D-2/ + DATA + + ZERO,HALF,ONE,TWO + + /0.0D0,0.5D0,1.0D0,2.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ADEN: A VALUE USED IN THE APPROXIMATION. +C ANUM: A VALUE USED IN THE APPROXIMATION. +C HALF: THE VALUE 0.5D0. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. +C P0: A PARAMETER USED IN THE APPROXIMATION. +C P1: A PARAMETER USED IN THE APPROXIMATION. +C P2: A PARAMETER USED IN THE APPROXIMATION. +C P3: A PARAMETER USED IN THE APPROXIMATION. +C P4: A PARAMETER USED IN THE APPROXIMATION. +C Q0: A PARAMETER USED IN THE APPROXIMATION. +C Q1: A PARAMETER USED IN THE APPROXIMATION. +C Q2: A PARAMETER USED IN THE APPROXIMATION. +C Q3: A PARAMETER USED IN THE APPROXIMATION. +C Q4: A PARAMETER USED IN THE APPROXIMATION. +C R: THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED. +C T: A VALUE USED IN THE APPROXIMATION. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + IF (P.EQ.HALF) THEN + DPPNML = ZERO + + ELSE + R = P + IF (P.GT.HALF) R = ONE - R + T = SQRT(-TWO*LOG(R)) + ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) + ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) + DPPNML = T + (ANUM/ADEN) + + IF (P.LT.HALF) DPPNML = -DPPNML + END IF + + RETURN + + END +*DPPT + DOUBLE PRECISION FUNCTION DPPT + + (P, IDF) +C***BEGIN PROLOGUE DPPT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPNML +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--OCTOBER 1975.) +C (UPDATED --NOVEMBER 1975.) +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM. +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION +C FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM +C AND SO THE COMPUTED PERCENT POINTS ARE EXACT. +C --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION +C IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO +C IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1. +C***REFERENCES NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS +C SERIES 55, 1964, PAGE 949, FORMULA 26.7.5. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 2, 1970, PAGE 102, FORMULA 11. +C FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS +C OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN +C STATISTICAL ASSOCIATION, 1969, PAGES 683-688. +C HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A +C HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975, +C PAGES 120-123. +C***END PROLOGUE DPPT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + INTEGER + + IDF + +C...LOCAL SCALARS + DOUBLE PRECISION + + ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, + + B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, + + HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, + + Z,ZERO + INTEGER + + IPASS,MAXIT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPNML + EXTERNAL + + DPPNML + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ATAN,COS,SIN,SQRT + +C...DATA STATEMENTS + DATA + + B21 + + /4.0D0/ + DATA + + B31, B32, B33, B34 + + /96.0D0,5.0D0,16.0D0,3.0D0/ + DATA + + B41, B42, B43, B44, B45 + + /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ + DATA + + B51,B52,B53,B54,B55,B56 + + /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ + DATA + + ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN + + /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ARG: A VALUE USED IN THE APPROXIMATION. +C B21: A PARAMETER USED IN THE APPROXIMATION. +C B31: A PARAMETER USED IN THE APPROXIMATION. +C B32: A PARAMETER USED IN THE APPROXIMATION. +C B33: A PARAMETER USED IN THE APPROXIMATION. +C B34: A PARAMETER USED IN THE APPROXIMATION. +C B41: A PARAMETER USED IN THE APPROXIMATION. +C B42: A PARAMETER USED IN THE APPROXIMATION. +C B43: A PARAMETER USED IN THE APPROXIMATION. +C B44: A PARAMETER USED IN THE APPROXIMATION. +C B45: A PARAMETER USED IN THE APPROXIMATION. +C B51: A PARAMETER USED IN THE APPROXIMATION. +C B52: A PARAMETER USED IN THE APPROXIMATION. +C B53: A PARAMETER USED IN THE APPROXIMATION. +C B54: A PARAMETER USED IN THE APPROXIMATION. +C B55: A PARAMETER USED IN THE APPROXIMATION. +C B56: A PARAMETER USED IN THE APPROXIMATION. +C C: A VALUE USED IN THE APPROXIMATION. +C CON: A VALUE USED IN THE APPROXIMATION. +C DF: THE DEGREES OF FREEDOM. +C D1: A VALUE USED IN THE APPROXIMATION. +C D3: A VALUE USED IN THE APPROXIMATION. +C D5: A VALUE USED IN THE APPROXIMATION. +C D7: A VALUE USED IN THE APPROXIMATION. +C D9: A VALUE USED IN THE APPROXIMATION. +C EIGHT: THE VALUE 8.0D0. +C FIFTN: THE VALUE 15.0D0. +C HALF: THE VALUE 0.5D0. +C IDF: THE (POSITIVE INTEGER) DEGREES OF FREEDOM. +C IPASS: A VALUE USED IN THE APPROXIMATION. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE. +C PI: THE VALUE OF PI. +C PPFN: THE NORMAL PERCENT POINT VALUE. +C S: A VALUE USED IN THE APPROXIMATION. +C TERM1: A VALUE USED IN THE APPROXIMATION. +C TERM2: A VALUE USED IN THE APPROXIMATION. +C TERM3: A VALUE USED IN THE APPROXIMATION. +C TERM4: A VALUE USED IN THE APPROXIMATION. +C TERM5: A VALUE USED IN THE APPROXIMATION. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C Z: A VALUE USED IN THE APPROXIMATION. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + PI = 3.141592653589793238462643383279D0 + DF = IDF + MAXIT = 5 + + IF (IDF.LE.0) THEN + +C TREAT THE IDF < 1 CASE + DPPT = ZERO + + ELSE IF (IDF.EQ.1) THEN + +C TREAT THE IDF = 1 (CAUCHY) CASE + ARG = PI*P + DPPT = -COS(ARG)/SIN(ARG) + + ELSE IF (IDF.EQ.2) THEN + +C TREAT THE IDF = 2 CASE + TERM1 = SQRT(TWO)/TWO + TERM2 = TWO*P - ONE + TERM3 = SQRT(P*(ONE-P)) + DPPT = TERM1*TERM2/TERM3 + + ELSE IF (IDF.GE.3) THEN + +C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE + PPFN = DPPNML(P) + D1 = PPFN + D3 = PPFN**3 + D5 = PPFN**5 + D7 = PPFN**7 + D9 = PPFN**9 + TERM1 = D1 + TERM2 = (ONE/B21)*(D3+D1)/DF + TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) + TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) + TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) + DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 + + IF (IDF.EQ.3) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 3 CASE + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 70 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+S*C-CON)/(TWO*C**2) + 70 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.4) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 4 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 90 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) + 90 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.5) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 5 CASE + + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 110 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ + + ((EIGHT/THREE)*C**4) + 110 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.6) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 6 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 130 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ + + ((FIFTN/EIGHT)*C**5) + 130 CONTINUE + DPPT = SQRT(DF)*S/C + END IF + END IF + + RETURN + + END +*DPVB + SUBROUTINE DPVB + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVB, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP +C***END PROLOGUE DPVB + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVB,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAJ: THE CURRENT ESTIMATE OF THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVB: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVB + + +C COMPUTE PREDICTED VALUES + + BETAJ = BETA(J) + BETA(J) = BETA(J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + BETA(J) = BETAJ + + PVB = WRK2(NROW,LQ) + + RETURN + END +*DPVD + SUBROUTINE DPVD + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVD, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING +C X(NROW,J) + DELTA(NROW,J) + STP +C***END PROLOGUE DPVD + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVD,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + XPDJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVD: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPDJ: THE (NROW,J)TH ELEMENT OF XPLUSD. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVD + + +C COMPUTE PREDICTED VALUES + + XPDJ = XPLUSD(NROW,J) + XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + XPLUSD(NROW,J) = XPDJ + + PVD = WRK2(NROW,LQ) + + RETURN + END +*DSCALE + SUBROUTINE DSCALE + + (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) +C***BEGIN PROLOGUE DSCALE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL +C***END PROLOGUE DSCALE + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDSCL,LDSCLT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEMP,ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ONE,ZERO + + /1.0D0,0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDSCL: THE LEADING DIMENSION OF ARRAY SCL. +C LDSCLT: THE LEADING DIMENSION OF ARRAY SCLT. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C ONE: THE VALUE 1.0D0. +C SCL: THE SCALE VALUES. +C SCLT: THE INVERSELY SCALED MATRIX. +C T: THE ARRAY TO BE INVERSELY SCALED BY SCL. +C TEMP: A TEMPORARY SCALAR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCALE + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (SCL(1,1).GE.ZERO) THEN + IF (LDSCL.GE.N) THEN + DO 80 J=1,M + DO 70 I=1,N + SCLT(I,J) = T(I,J)/SCL(I,J) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J=1,M + TEMP = ONE/SCL(1,J) + DO 90 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 90 CONTINUE + 100 CONTINUE + END IF + ELSE + TEMP = ONE/ABS(SCL(1,1)) + DO 120 J=1,M + DO 110 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + END IF + + RETURN + END +*DSCLB + SUBROUTINE DSCLB + + (NP,BETA,SSF) +C***BEGIN PROLOGUE DSCLB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR BETA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLB + +C...SCALAR ARGUMENTS + INTEGER + + NP + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SSF(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + BMAX,BMIN,ONE,TEN,ZERO + INTEGER + + K + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C BMAX: THE LARGEST NONZERO MAGNITUDE. +C BMIN: THE SMALLEST NONZERO MAGNITUDE. +C K: AN INDEXING VARIABLE. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SSF: THE SCALING VALUES FOR BETA. +C TEN: THE VALUE 10.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLB + + + BMAX = ABS(BETA(1)) + DO 10 K=2,NP + BMAX = MAX(BMAX,ABS(BETA(K))) + 10 CONTINUE + + IF (BMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF BETA ARE ZERO + + DO 20 K=1,NP + SSF(K) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + BMIN = BMAX + DO 30 K=1,NP + IF (BETA(K).NE.ZERO) THEN + BMIN = MIN(BMIN,ABS(BETA(K))) + END IF + 30 CONTINUE + BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE + DO 40 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + SSF(K) = TEN/BMIN + ELSE + IF (BIGDIF) THEN + SSF(K) = ONE/ABS(BETA(K)) + ELSE + SSF(K) = ONE/BMAX + END IF + END IF + 40 CONTINUE + + END IF + + RETURN + END +*DSCLD + SUBROUTINE DSCLD + + (N,M,X,LDX,TT,LDTT) +C***BEGIN PROLOGUE DSCLD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR DELTA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLD + +C...SCALAR ARGUMENTS + INTEGER + + LDTT,LDX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + TT(LDTT,M),X(LDX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEN,XMAX,XMIN,ZERO + INTEGER + + I,J + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C ONE: THE VALUE 1.0D0. +C TT: THE SCALING VALUES FOR DELTA. +C X: THE INDEPENDENT VARIABLE. +C XMAX: THE LARGEST NONZERO MAGNITUDE. +C XMIN: THE SMALLEST NONZERO MAGNITUDE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLD + + + DO 50 J=1,M + XMAX = ABS(X(1,J)) + DO 10 I=2,N + XMAX = MAX(XMAX,ABS(X(I,J))) + 10 CONTINUE + + IF (XMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO + + DO 20 I=1,N + TT(I,J) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + XMIN = XMAX + DO 30 I=1,N + IF (X(I,J).NE.ZERO) THEN + XMIN = MIN(XMIN,ABS(X(I,J))) + END IF + 30 CONTINUE + BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE + DO 40 I=1,N + IF (X(I,J).NE.ZERO) THEN + IF (BIGDIF) THEN + TT(I,J) = ONE/ABS(X(I,J)) + ELSE + TT(I,J) = ONE/XMAX + END IF + ELSE + TT(I,J) = TEN/XMIN + END IF + 40 CONTINUE + END IF + 50 CONTINUE + + RETURN + END +*DSETN + SUBROUTINE DSETN + + (N,M,X,LDX,NROW) +C***BEGIN PROLOGUE DSETN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED +C***END PROLOGUE DSETN + +C...SCALAR ARGUMENTS + INTEGER + + LDX,M,N,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NROW: THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE. +C X: THE INDEPENDENT VARIABLE. + + +C***FIRST EXECUTABLE STATEMENT DSETN + + + IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN + +C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS +C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. + + DO 20 I = 1, N + DO 10 J = 1, M + IF (X(I,J).EQ.0.0) GO TO 20 + 10 CONTINUE + NROW = I + RETURN + 20 CONTINUE + + NROW = 1 + + RETURN + END +*DSOLVE + SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB) +C***BEGIN PROLOGUE DSOLVE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DAXPY,DDOT +C***DATE WRITTEN 920220 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SOLVE SYSTEMS OF THE FORM +C T * X = B OR TRANS(T) * X = B +C WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N, +C AND THE SOLUTION X OVERWRITES THE RHS B. +C (ADAPTED FROM LINPACK SUBROUTINE DTRSL) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DSOLVE + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(LDB,N),T(LDT,N) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + J1,J,JN + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C B: ON INPUT: THE RIGHT HAND SIDE; ON EXIT: THE SOLUTION +C J1: THE FIRST NONZERO ENTRY IN T. +C J: AN INDEXING VARIABLE. +C JN: THE LAST NONZERO ENTRY IN T. +C JOB: WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS +C 1 SOLVE T*X=B, T LOWER TRIANGULAR, +C 2 SOLVE T*X=B, T UPPER TRIANGULAR, +C 3 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 4 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C LDB: THE LEADING DIMENSION OF ARRAY B. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T. +C T: THE UPPER OR LOWER TRIDIAGONAL SYSTEM. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSOLVE + + +C FIND FIRST NONZERO DIAGONAL ENTRY IN T + J1 = 0 + DO 10 J=1,N + IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN + J1 = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 10 CONTINUE + IF (J1.EQ.0) RETURN + +C FIND LAST NONZERO DIAGONAL ENTRY IN T + JN = 0 + DO 20 J=N,J1,-1 + IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN + JN = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 20 CONTINUE + + IF (JOB.EQ.1) THEN + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + B(1,J1) = B(1,J1)/T(J1,J1) + DO 30 J = J1+1, JN + TEMP = -B(1,J-1) + CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 30 CONTINUE + + ELSE IF (JOB.EQ.2) THEN + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 40 J = JN-1,J1,-1 + TEMP = -B(1,J+1) + CALL DAXPY(J,TEMP,T(1,J+1),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 40 CONTINUE + + ELSE IF (JOB.EQ.3) THEN + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 50 J = JN-1,J1,-1 + B(1,J) = B(1,J) - DDOT(JN-J+1,T(J+1,J),1,B(1,J+1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 50 CONTINUE + + ELSE IF (JOB.EQ.4) THEN + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + B(1,J1) = B(1,J1)/T(J1,J1) + DO 60 J = J1+1,JN + B(1,J) = B(1,J) - DDOT(J-1,T(1,J),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 60 CONTINUE + END IF + + RETURN + END +*DUNPAC + SUBROUTINE DUNPAC + + (N2,V1,V2,IFIX) +C***BEGIN PROLOGUE DUNPAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE +C UNFIXED +C***END PROLOGUE DUNPAC + +C...SCALAR ARGUMENTS + INTEGER + + N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I,N1 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ODRPACK REFERENCE GUIDE.) +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE +C ELEMENTS OF V1 ARE TO BE INSERTED. + + +C***FIRST EXECUTABLE STATEMENT DUNPAC + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I = 1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1 + 1 + V2(I) = V1(N1) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY(N2,V1,1,V2,1) + END IF + + RETURN + END +*DVEVTR + SUBROUTINE DVEVTR + + (M,NQ,INDX, + + V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, + + WRK5) +C***BEGIN PROLOGUE DVEVTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DSOLVE +C***DATE WRITTEN 910613 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V +C***END PROLOGUE DVEVTR + +C...SCALAR ARGUMENTS + INTEGER + + INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + J,L1,L2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DSOLVE + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C INDX: THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED. +C J: AN INDEXING VARIABLE. +C LDE: THE LEADING DIMENSION OF ARRAY E. +C LDV: THE LEADING DIMENSION OF ARRAY V. +C LDVE: THE LEADING DIMENSION OF ARRAY VE. +C LDVEV: THE LEADING DIMENSION OF ARRAY VEV. +C LD2V: THE SECOND DIMENSION OF ARRAY V. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C E: THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2). +C V: AN ARRAY OF NQ BY M MATRICES. +C VE: THE NQ BY M ARRAY VE = V * INV(E) +C VEV: THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V). +C WRK5: AN M WORK VECTOR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DVEVTR + + + IF (NQ.EQ.0 .OR. M.EQ.0) RETURN + + DO 140 L1 = 1,NQ + DO 110 J = 1,M + WRK5(J) = V(INDX,J,L1) + 110 CONTINUE + CALL DSOLVE(M,E,LDE,WRK5,1,4) + DO 120 J = 1,M + VE(INDX,L1,J) = WRK5(J) + 120 CONTINUE + 140 CONTINUE + + DO 230 L1 = 1,NQ + DO 220 L2 = 1,L1 + VEV(L1,L2) = ZERO + DO 210 J = 1,M + VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) + 210 CONTINUE + VEV(L2,L1) = VEV(L1,L2) + 220 CONTINUE + 230 CONTINUE + + RETURN + END +*DWGHT + SUBROUTINE DWGHT + + (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT) +C***BEGIN PROLOGUE DWGHT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T +C***END PROLOGUE DWGHT + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDWT,LDWTT,LD2WT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,J,K + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDWT: THE LEADING DIMENSION OF ARRAY WT. +C LDWTT: THE LEADING DIMENSION OF ARRAY WTT. +C LD2WT: THE SECOND DIMENSION OF ARRAY WT. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C T: THE ARRAY BEING SCALED BY WT. +C TEMP: A TEMPORARY SCALAR. +C WT: THE WEIGHTS. +C WTT: THE RESULTS OF WEIGHTING ARRAY T BY WT. +C ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT +C ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DWGHT + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WT(1,1,1).GE.ZERO) THEN + IF (LDWT.GE.N) THEN + IF (LD2WT.GE.M) THEN +C WT IS AN N-ARRAY OF M BY M MATRICES + DO 130 I=1,N + DO 120 J=1,M + TEMP = ZERO + DO 110 K=1,M + TEMP = TEMP + WT(I,J,K)*T(I,K) + 110 CONTINUE + WTT(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE +C WT IS AN N-ARRAY OF DIAGONAL MATRICES + DO 230 I=1,N + DO 220 J=1,M + WTT(I,J) = WT(I,1,J)*T(I,J) + 220 CONTINUE + 230 CONTINUE + END IF + ELSE + IF (LD2WT.GE.M) THEN +C WT IS AN M BY M MATRIX + DO 330 I=1,N + DO 320 J=1,M + TEMP = ZERO + DO 310 K=1,M + TEMP = TEMP + WT(1,J,K)*T(I,K) + 310 CONTINUE + WTT(I,J) = TEMP + 320 CONTINUE + 330 CONTINUE + ELSE +C WT IS A DIAGONAL MATRICE + DO 430 I=1,N + DO 420 J=1,M + WTT(I,J) = WT(1,1,J)*T(I,J) + 420 CONTINUE + 430 CONTINUE + END IF + END IF + ELSE +C WT IS A SCALAR + DO 520 J=1,M + DO 510 I=1,N + WTT(I,J) = ABS(WT(1,1,1))*T(I,J) + 510 CONTINUE + 520 CONTINUE + END IF + + RETURN + END +*DWINF + SUBROUTINE DWINF + + (N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) +C***BEGIN PROLOGUE DWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C***END PROLOGUE DWINF + +C...SCALAR ARGUMENTS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN, + + M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI, + + WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ISODR + +C...LOCAL SCALARS + INTEGER + + NEXT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NEXT: THE NEXT AVAILABLE LOCATION WITH WORK. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DWINF + + + IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. + + LDWE.GE.1 .AND. LD2WE.GE.1) THEN + + DELTAI = 1 + EPSI = DELTAI + N*M + XPLUSI = EPSI + N*NQ + FNI = XPLUSI + N*M + SDI = FNI + N*NQ + VCVI = SDI + NP + RVARI = VCVI + NP*NP + + WSSI = RVARI + 1 + WSSDEI = WSSI + 1 + WSSEPI = WSSDEI + 1 + RCONDI = WSSEPI + 1 + ETAI = RCONDI + 1 + OLMAVI = ETAI + 1 + + TAUI = OLMAVI + 1 + ALPHAI = TAUI + 1 + ACTRSI = ALPHAI + 1 + PNORMI = ACTRSI + 1 + RNORSI = PNORMI + 1 + PRERSI = RNORSI + 1 + PARTLI = PRERSI + 1 + SSTOLI = PARTLI + 1 + TAUFCI = SSTOLI + 1 + EPSMAI = TAUFCI + 1 + BETA0I = EPSMAI + 1 + + BETACI = BETA0I + NP + BETASI = BETACI + NP + BETANI = BETASI + NP + SI = BETANI + NP + SSI = SI + NP + SSFI = SSI + NP + QRAUXI = SSFI + NP + UI = QRAUXI + NP + FSI = UI + NP + + FJACBI = FSI + N*NQ + + WE1I = FJACBI + N*NP*NQ + + DIFFI = WE1I + LDWE*LD2WE*NQ + + NEXT = DIFFI + NQ*(NP+M) + + IF (ISODR) THEN + DELTSI = NEXT + DELTNI = DELTSI + N*M + TI = DELTNI + N*M + TTI = TI + N*M + OMEGAI = TTI + N*M + FJACDI = OMEGAI + NQ*NQ + WRK1I = FJACDI + N*M*NQ + NEXT = WRK1I + N*M*NQ + ELSE + DELTSI = DELTAI + DELTNI = DELTAI + TI = DELTAI + TTI = DELTAI + OMEGAI = DELTAI + FJACDI = DELTAI + WRK1I = DELTAI + END IF + + WRK2I = NEXT + WRK3I = WRK2I + N*NQ + WRK4I = WRK3I + NP + WRK5I = WRK4I + M*M + WRK6I = WRK5I + M + WRK7I = WRK6I + N*NQ*NP + NEXT = WRK7I + 5*NQ + + LWKMN = NEXT + ELSE + DELTAI = 1 + EPSI = 1 + XPLUSI = 1 + FNI = 1 + SDI = 1 + VCVI = 1 + RVARI = 1 + WSSI = 1 + WSSDEI = 1 + WSSEPI = 1 + RCONDI = 1 + ETAI = 1 + OLMAVI = 1 + TAUI = 1 + ALPHAI = 1 + ACTRSI = 1 + PNORMI = 1 + RNORSI = 1 + PRERSI = 1 + PARTLI = 1 + SSTOLI = 1 + TAUFCI = 1 + EPSMAI = 1 + BETA0I = 1 + BETACI = 1 + BETASI = 1 + BETANI = 1 + SI = 1 + SSI = 1 + SSFI = 1 + QRAUXI = 1 + FSI = 1 + UI = 1 + FJACBI = 1 + WE1I = 1 + DIFFI = 1 + DELTSI = 1 + DELTNI = 1 + TI = 1 + TTI = 1 + FJACDI = 1 + OMEGAI = 1 + WRK1I = 1 + WRK2I = 1 + WRK3I = 1 + WRK4I = 1 + WRK5I = 1 + WRK6I = 1 + WRK7I = 1 + LWKMN = 1 + END IF + + RETURN + END +*DXMY + SUBROUTINE DXMY + + (N,M,X,LDX,Y,LDY,XMY,LDXMY) +C***BEGIN PROLOGUE DXMY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XMY = X - Y +C***END PROLOGUE DXMY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXMY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XMY(LDXMY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXMY: THE LEADING DIMENSION OF ARRAY XMY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS. +C XMY: THE VALUES OF X-Y. +C Y: THE SECOND OF THE TWO ARRAYS. + + +C***FIRST EXECUTABLE STATEMENT DXMY + + + DO 20 J=1,M + DO 10 I=1,N + XMY(I,J) = X(I,J) - Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DXPY + SUBROUTINE DXPY + + (N,M,X,LDX,Y,LDY,XPY,LDXPY) +C***BEGIN PROLOGUE DXPY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XPY = X + Y +C***END PROLOGUE DXPY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXPY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXPY: THE LEADING DIMENSION OF ARRAY XPY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. +C XPY: THE VALUES OF X+Y. +C Y: THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. + + +C***FIRST EXECUTABLE STATEMENT DXPY + + + DO 20 J=1,M + DO 10 I=1,N + XPY(I,J) = X(I,J) + Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DZERO + SUBROUTINE DZERO + + (N,M,A,LDA) +C***BEGIN PROLOGUE DZERO +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET A = ZERO +C***END PROLOGUE DZERO + +C...SCALAR ARGUMENTS + INTEGER + + LDA,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + A(LDA,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE SET TO ZERO. +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C M: THE NUMBER OF COLUMNS TO BE SET TO ZERO. +C N: THE NUMBER OF ROWS TO BE SET TO ZERO. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DZERO + + + DO 20 J=1,M + DO 10 I=1,N + A(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + + RETURN + END diff --git a/dataassim/math/optimization/odrpack95/data1.dat b/dataassim/math/optimization/odrpack95/data1.dat new file mode 100644 index 0000000..25b8f35 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/data1.dat @@ -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 diff --git a/dataassim/math/optimization/odrpack95/data2.dat b/dataassim/math/optimization/odrpack95/data2.dat new file mode 100644 index 0000000..b47dde3 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/data2.dat @@ -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 diff --git a/dataassim/math/optimization/odrpack95/data3.dat b/dataassim/math/optimization/odrpack95/data3.dat new file mode 100644 index 0000000..70c4040 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/data3.dat @@ -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 diff --git a/dataassim/math/optimization/odrpack95/drive1.f b/dataassim/math/optimization/odrpack95/drive1.f new file mode 100644 index 0000000..ed834a1 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/drive1.f @@ -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 + + + + diff --git a/dataassim/math/optimization/odrpack95/drive2.f b/dataassim/math/optimization/odrpack95/drive2.f new file mode 100644 index 0000000..08e448b --- /dev/null +++ b/dataassim/math/optimization/odrpack95/drive2.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/drive3.f b/dataassim/math/optimization/odrpack95/drive3.f new file mode 100644 index 0000000..62f89d0 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/drive3.f @@ -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 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dataassim/math/optimization/odrpack95/drive4.f b/dataassim/math/optimization/odrpack95/drive4.f new file mode 100644 index 0000000..6f87365 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/drive4.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/lpkbls.f b/dataassim/math/optimization/odrpack95/lpkbls.f new file mode 100644 index 0000000..f35cb5e --- /dev/null +++ b/dataassim/math/optimization/odrpack95/lpkbls.f @@ -0,0 +1,2355 @@ +*DASUM + FUNCTION DASUM(N,DX,INCX) RESULT(DASUMR) +C***Begin Prologue DASUM +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A3A +C***Keywords Add,BLAS,REAL (KIND=R8),Linear Algebra,Magnitude,Sum, +C Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. OF TEXAS) +C Krogh, F. T., (JPL) +C***Purpose Sum of Magnitudes of D.P. Vector Components +C***Description +C B L A S Subprogram +C Description of parameters +C --Input-- +C N Number of elements in input vector(s) +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C --Output-- +C DASUM REAL (KIND=R8) result (Zero IF N .LE. 0) +C Returns sum of magnitudes of Real (Kind=R8) DX. +C DASUM = Sum from 0 to N-1 of DABS(DX(1+I*INCX)) +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms For FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines called (none) +C***End Prologue DASUM + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INCX,N + +C...Array arguments + REAL (KIND=R8) + & DX(*) + +C...Result + REAL (KIND=R8) + & DASUMR + +C...Local scalars + INTEGER + & I,M,MP1,NS + +C...Intrinsic functions + INTRINSIC + & DABS,MOD + + +C***First executable statement DASUM + + + DASUMR = 0.E0_R8 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C Code for increments not equal to 1. + + NS = N*INCX + DO 10 I=1,NS,INCX + DASUMR = DASUMR + DABS(DX(I)) + 10 CONTINUE + RETURN + +C Code for increments equal to 1. + +C Clean-up loop so remaining vector length is a multiple of 6. + + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DASUMR = DASUMR + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUMR = DASUMR + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) + 1 + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) + 50 CONTINUE + RETURN + END +*DAXPY + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +C***Begin Prologue DAXPY +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A7 +C***Keywords BLAS,REAL (KIND=R8),Linear Algebra,Triad,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose D.P Computation Y = A*X + Y +C***Description +C B L A S Subprogram +C Description of parameters +C --Input-- +C N Number of elements in input vector(s) +C DA REAL (KIND=R8) scalar multiplier +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C DY REAL (KIND=R8) vector with N elements +C INCY Storage spacing between elements of DY +C --Output-- +C DY REAL (KIND=R8) result (unchanged IF N .LE. 0) +C Overwrite REAL (KIND=R8) DY with REAL (KIND=R8) DA*DX + DY. +C For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + +C DY(LY+I*INCY), where LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N +C and LY is defined in a similar way using INCY. +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines called (none) +C***End Prologue DAXPY + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & DA + INTEGER + & INCX,INCY,N + +C...Array arguments + REAL (KIND=R8) + & DX(*),DY(*) + +C...Local scalars + INTEGER + & I,IX,IY,M,MP1,NS + +C...Intrinsic functions + INTRINSIC + & MOD + + +C***First executable statement DAXPY + + + IF(N.LE.0.OR.DA.EQ.0.E0_R8) RETURN + IF(INCX.EQ.INCY) THEN + IF(INCX-1.LT.0) THEN + GOTO 5 + ELSE IF (INCX-1.EQ.0) THEN + GOTO 20 + ELSE IF (INCX-1.GT.0) THEN + GOTO 60 + END IF + END IF + 5 CONTINUE + +C Code for nonequal or nonpositive increments. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C Code for both increments equal to 1 + + +C Clean-up loop so remaining vector length is a multiple of 4. + + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + +C Code for equal, positive, nonunit increments. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END +*DCHEX + SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) +C***Begin Prologue DCHEX +C***Date Written 780814 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D7B +C***Keywords Cholesky Decomposition,REAL (KIND=R8),Exchange, +C Linear Algebra,LINPACK,Matrix,Positive Definite +C***Author Stewart, G. W., (U. of Maryland) +C***Purpose Updates the Cholesky Factorization A=TRANS(R)*R of a +C positive definite matrix A of order P under diagonal +C permutations of the form TRANS(E)*A*E where E is a +C permutation matrix. +C***Description +C DCHEX updates the Cholesky Factorization +C A = TRANS(R)*R +C of a positive definite matrix A of order P under diagonal +C permutations of the form +C TRANS(E)*A*E +C where E is a permutation matrix. Specifically, given +C an upper triangular matrix R and a permutation matrix +C E (which is specified by K, L, and JOB), DCHEX determines +C an orthogonal matrix U such that +C U*R*E = RR, +C where RR is upper triangular. At the users option, the +C transformation U will be multiplied into the array Z. +C If A = TRANS(X)*X, so that R is the triangular part of the +C QR factorization of X, then RR is the triangular part of the +C QR factorization of X*E, i.e. X with its columns permuted. +C For a less terse description of what DCHEX does and how +C it may be applied, see the LINPACK guide. +C The matrix Q is determined as the product U(L-K)*...*U(1) +C of plane rotations of the form +C ( C(I) S(I) ) +C ( ) , +C ( -S(I) C(I) ) +C where C(I) is REAL (KIND=R8). The rows these rotations operate +C on are described below. +C There are two types of permutations, which are determined +C By the value of JOB. +C 1. Right circular shift (JOB = 1). +C The columns are rearranged in the following order. +C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. +C U is the product of L-K rotations U(I), where U(I) +C acts in the (L-I,L-I+1)-plane. +C 2. Left circular shift (JOB = 2). +C The columns are rearranged in the following order +C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. +C U is the product of L-K rotations U(I), where U(I) +C Acts in the (K+I-1,K+I)-plane. +C On entry +C R REAL (KIND=R8)(LDR,P), where LDR .GE. P. +C R contains the upper triangular factor +C that is to be updated. Elements of R +C below the diagonal are not referenced. +C LDR INTEGER. +C LDR is the leading dimension of the array R. +C P INTEGER. +C P is the order of the matrix R. +C K INTEGER. +C K is the first column to be permuted. +C L INTEGER. +C L is the last column to be permuted. +C L must be strictly greater than K. +C Z REAL (KIND=R8)(LDZ,N)Z), where LDZ .GE. P. +C Z is an array of NZ P-vectors into which the +C transformation U is multiplied. Z is +C not referenced if NZ = 0. +C LDZ INTEGER. +C LDZ is the leading dimension of the array Z. +C NZ INTEGER. +C NZ is the number of columns of the matrix Z. +C JOB INTEGER. +C JOB determines the type of permutation. +C JOB = 1 Right circular shift. +C JOB = 2 Left circular shift. +C On return +C R Contains the updated factor. +C Z Contains the updated matrix Z. +C C REAL (KIND=R8)(P). +C C contains the cosines of the transforming rotations. +C S REAL (KIND=R8)(P). +C S contains the sines of the transforming rotations. +C LINPACK. This version dated 08/14/78 . +C G. W. Stewart, University of Maryland, Argonne National Lab. +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***Routines called DROTG +C***End Prologue DCHEX + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & JOB,K,L,LDR,LDZ,NZ,P + +C...Array arguments + REAL (KIND=R8) + & C(*),R(LDR,*),S(*),Z(LDZ,*) + +C...Local scalars + REAL (KIND=R8) + & T,T1 + INTEGER + & I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK + +C...External subroutines + EXTERNAL + & DROTG + +C...Intrinsic functions + INTRINSIC + & MAX0,MIN0 + + +C***First executable statement DCHEX + + + KM1 = K - 1 + KP1 = K + 1 + LMK = L - K + LM1 = L - 1 + +C Perform the appropriate task. + + IF (JOB.EQ.1) THEN + GOTO 10 + ELSE IF (JOB.EQ.2) THEN + GOTO 130 + END IF + +C Right circular shift. + + 10 CONTINUE + +C Reorder the columns. + + DO 20 I = 1, L + II = L - I + 1 + S(I) = R(II,L) + 20 CONTINUE + DO 40 JJ = K, LM1 + J = LM1 - JJ + K + DO 30 I = 1, J + R(I,J+1) = R(I,J) + 30 CONTINUE + R(J+1,J+1) = 0.0E0_R8 + 40 CONTINUE + IF (K .EQ. 1) GO TO 60 + DO 50 I = 1, KM1 + II = L - I + 1 + R(I,K) = S(II) + 50 CONTINUE + 60 CONTINUE + +C Calculate the rotations. + + T = S(1) + DO 70 I = 1, LMK + T1 = S(I) + CALL DROTG(S(I+1),T,C(I),T1) + S(I) = T1 + T = S(I+1) + 70 CONTINUE + R(K,K) = T + DO 90 J = KP1, P + IL = MAX0(1,L-J+1) + DO 80 II = IL, LMK + I = L - II + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 80 CONTINUE + 90 CONTINUE + +C If required, apply the transformations to Z. + + IF (NZ .LT. 1) GO TO 120 + DO 110 J = 1, NZ + DO 100 II = 1, LMK + I = L - II + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 260 + +C Left circular shift + + 130 CONTINUE + +C Reorder the columns + + DO 140 I = 1, K + II = LMK + I + S(II) = R(I,K) + 140 CONTINUE + DO 160 J = K, LM1 + DO 150 I = 1, J + R(I,J) = R(I,J+1) + 150 CONTINUE + JJ = J - KM1 + S(JJ) = R(J+1,J+1) + 160 CONTINUE + DO 170 I = 1, K + II = LMK + I + R(I,L) = S(II) + 170 CONTINUE + DO 180 I = KP1, L + R(I,L) = 0.0E0_R8 + 180 CONTINUE + +C Reduction loop. + + DO 220 J = K, P + IF (J .EQ. K) GO TO 200 + +C Apply the rotations. + + IU = MIN0(J-1,L-1) + DO 190 I = K, IU + II = I - K + 1 + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 190 CONTINUE + 200 CONTINUE + IF (J .GE. L) GO TO 210 + JJ = J - K + 1 + T = S(JJ) + CALL DROTG(R(J,J),T,C(JJ),S(JJ)) + 210 CONTINUE + 220 CONTINUE + +C Apply the rotations to Z. + + IF (NZ .LT. 1) GO TO 250 + DO 240 J = 1, NZ + DO 230 I = K, LM1 + II = I - KM1 + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN + END +*DCOPY + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +C***Begin Prologue DCOPY +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A5 +C***Keywords BLAS,Copy,REAL (KIND=R8),Linear Algebra,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose D.P. Vector Copy Y = X +C***Description +C B L A S Subprogram +C Description of parameters +C --Input-- +C N Number of elements in input vector(s) +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C DY REAL (KIND=R8) vector with N elements +C INCY Storage spacing between elements of DY +C --Output-- +C DY Copy of vector DX (unchanged if N .LE. 0) +C Copy REAL (KIND=R8) DX to REAL (KIND=R8) DY. +C For I = 0 to N-1, copy DX(LX+I*INCX) to DY(LY+I*INCY), +C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is +C defined in a similar way using INCY. +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines called (none) +C***End Prologue DCOPY + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INCX,INCY,N + +C...Array arguments + REAL (KIND=R8) + & DX(*),DY(*) + +C...Local scalars + INTEGER + & I,IX,IY,M,MP1,NS + +C...Intrinsic functions + INTRINSIC + & MOD + + +C***First executable statement DCOPY + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) THEN + IF(INCX-1.LT.0) THEN + GOTO 5 + ELSE IF(INCX-1.EQ.0) THEN + GOTO 20 + ELSE IF(INCX-1.GT.0) THEN + GOTO 60 + END IF + END IF + 5 CONTINUE + +C Code for unequal or nonpositive increments. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C Code for both increments equal to 1 + + +C Clean-up loop so remaining vector length is a multiple of 7. + + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + +C Code for equal, positive, nonunit increments. + + 60 CONTINUE + NS=N*INCX + DO 70 I=1,NS,INCX + DY(I) = DX(I) + 70 CONTINUE + RETURN + END +*DDOT + FUNCTION DDOT(N,DX,INCX,DY,INCY) RESULT(DDOTR) +C***Begin Prologue DDOT +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A4 +C***Keywords BLAS,REAL (KIND=R8),Inner Product,Linear Algebra,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose D.P. Inner Product of D.P. Vectors +C***Description +C B L A S Subprogram +C Description of parameters +C --Input-- +C N Number of elements in input vector(s) +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C DY REAL (KIND=R8) vector with N elements +C INCY Storage spacing between elements of DY +C --Output-- +C DDOT REAL (KIND=R8) dot product (zero if N .LE. 0) +C returns the dot product of REAL (KIND=R8) DX and DY. +C DDOT = SUM for I = 0 to N-1 of DX(LX+I*INCX) * DY(LY+I*INCY) +C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is +C defined in a similar way using INCY. +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines called (none) +C***End Prologue DDOT + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INCX,INCY,N + +C...Array arguments + REAL (KIND=R8) + & DX(*),DY(*) + +C...Result + REAL (KIND=R8) + & DDOTR + +C...Local scalars + INTEGER + & I,IX,IY,M,MP1,NS + +C...Intrinsic functions + INTRINSIC + & MOD + + +C***First executable statement DDOT + + + DDOTR = 0.E0_R8 + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) THEN + IF(INCX-1.LT.0) THEN + GOTO 5 + ELSE IF(INCX-1.EQ.0) THEN + GOTO 20 + ELSE IF(INCX-1.GT.0) THEN + GOTO 60 + END IF + END IF + 5 CONTINUE + +C Code for unequal or nonpositive increments. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOTR = DDOTR + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C Code for both increments equal to 1. + + +C Clean-up loop so remaining vector length is a multiple of 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DDOTR = DDOTR + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOTR = DDOTR + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + 1 DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + RETURN + +C Code for positive equal increments .NE.1. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DDOTR = DDOTR + DX(I)*DY(I) + 70 CONTINUE + RETURN + END +*DNRM2 + FUNCTION DNRM2(N,DX,INCX) RESULT(DNRM2R) +C***Begin Prologue DNRM2 +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A3B +C***Keywords BLAS,REAL (KIND=R8),Euclidean,L2,Length,Linear Algebra, +C Norm,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C KROGH, F. T., (JPL) +C***Purpose Euclidean Length (L2 Norm) of D.P. Vector +C***Description +C B L A S Subprogram +C Description of parameters +C --Input-- +C N Number of elements in input vector(s) +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C --Output-- +C DNRM2 REAL (KIND=R8) result (zero if N .LE. 0) +C Euclidean norm of the N-vector stored in DX() with storage +C increment INCX . +C If N .LE. 0 return with result = 0. +C If N .GE. 1 then INCX must be .GE. 1 +C C.L. Lawson, 1978 Jan 08 +C Four Phase Method Using two built-in constants that are +C hopefully applicable to all machines. +C CUTLO = Maximum of DSQRT(U/EPS) over all known machines. +C CUTHI = Minimum of DSQRT(V) over all known machines. +C where +C EPS = smallest no. such that EPS + 1. .GT. 1. +C U = smallest positive no. (underflow limit) +C V = largest no. (overflow limit) +C Brief outline of algorithm.. +C Phase 1 Scans zero components. +C Move to Phase 2 when a component is nonzero and .LE. CUTLO +C Move to Phase 3 when a component is .GT. CUTLO +C Move to Phase 4 when a component is .GE. CUTHI/M +C where M = N for X() REAL and M = 2*N for COMPLEX. + +C Values for CUTLO and CUTHI.. +C From the environmental parameters listed in the IMSL converter +C document the limiting values are as follows.. +C CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are +C UNIVAC and DEC at 2**(-103) +C thus CUTLO = 2**(-51) = 4.44089E-16_R8 +C CUTHI, S.P. V = 2**127 for UNIVAC, Honeywell, and DEC. +C thus CUTHI = 2**(63.5) = 1.30438E19_R8 +C CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. +C thus CUTLO = 2**(-33.5) = 8.23181E-11_R8 +C CUTHI, D.P. Same as S.P. CUTHI = 1.30438E19_R8 +C DATA CUTLO, CUTHI / 8.232E-11_R8, 1.304E19_R8 / +C DATA CUTLO, CUTHI / 4.441E-16_R8, 1.304E19_R8 / +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines called (none) +C***End Prologue DNRM2 + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INCX,N + +C...Array arguments + REAL (KIND=R8) + & DX(*) + +C...Result + REAL (KIND=R8) + & DNRM2R + +C...Local scalars + REAL (KIND=R8) + & CUTHI,CUTLO,HITEST,ONE,SUM,XMAX,ZERO + INTEGER + & I,J,NEXT,NN + +C...Intrinsic functions + INTRINSIC + & DABS,DSQRT,FLOAT + +C...Data statements + DATA + & ZERO,ONE/0.0E0_R8,1.0E0_R8/ + DATA + & CUTLO,CUTHI/8.232E-11_R8,1.304E19_R8/ + + +C***First executable statement DNRM2 + + + XMAX = ZERO + IF(N .GT. 0) GO TO 10 + DNRM2R = ZERO + GO TO 300 + + 10 NEXT=30 + SUM = ZERO + NN = N * INCX +C Begin main loop + I = 1 + 20 IF (NEXT.EQ.30) THEN; GOTO 30; END IF + IF (NEXT.EQ.50) THEN; GOTO 50; END IF + IF (NEXT.EQ.70) THEN; GOTO 70; END IF + IF (NEXT.EQ.110) THEN; GOTO 110; END IF + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + NEXT=50 + XMAX = ZERO + +C Phase 1. Sum is zero + + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + +C Prepare for Phase 2. + NEXT=70 + GO TO 105 + +C Prepare for Phase 4. + + 100 I = J + NEXT=110 + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 + +C Phase 2. Sum is small. +C Scale to avoid destructive underflow. + + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 + +C Common code for Phases 2 and 4. +C In Phase 4 sum is large. Scale to avoid overflow. + + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 + + +C Prepare for Phase 3. + + 75 SUM = (SUM * XMAX) * XMAX + + +C For REAL OR D.P. set HITEST = CUTHI/N +C For COMPLEX set HITEST = CUTHI/(2*N) + + 85 HITEST = CUTHI/FLOAT( N ) + +C Phase 3. Sum is mid-range. No scaling. + + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + SUM = SUM + DX(J)**2 + 95 CONTINUE + DNRM2R = DSQRT( SUM ) + GO TO 300 + + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 + +C End of main loop. + +C Compute square root and adjust for scaling. + + DNRM2R = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END +*DPODI + SUBROUTINE DPODI(A,LDA,N,DET,JOB) +C***Begin Prologue DPODI +C***Date Written 780814 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D2B1B,D3B1B +C***Keywords Determinant,REAL (KIND=R8),Factor,Inverse, +C Linear Algebra,LINPACK,Matrix,Positive Definite +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***PURPOSE Computes the determinant and inverse of a certain double +C precision symmetric positive definite matrix (see abstract) +C using the factors computed by DPOCO, DPOFA or DQRDC. +C***Description +C DPODI computes the determinant and inverse of a certain +C REAL (KIND=R8) symmetric positive definite matrix (see below) +C using the factors computed by DPOCO, DPOFA or DQRDC. +C On entry +C A REAL (KIND=R8)(LDA, N) +C The output A from DPOCO or DPOFA +C or the output X from DQRDC. +C LDA INTEGER +C The leading dimension of the array A . +C N INTEGER +C The order of the matrix A . +C JOB INTEGER +C = 11 Both determinant and inverse. +C = 01 Inverse only. +C = 10 Determinant only. +C On return +C A If DPOCO or DPOFA was used to factor A , then +C DPODI produces the upper half of inverse(A) . +C If DQRDC was used to decompose X , then +C DPODI produces the upper half of inverse(trans(X)*X) +C where trans(x) is the transpose. +C Elements of A below the diagonal are unchanged. +C If the units digit of JOB is zero, A is unchanged. +C DET REAL (KIND=R8)(2) +C Determinant of A or of trans(X)*X if requested. +C Otherwise not referenced. +C Determinant = DET(1) * 10.0**DET(2) +C with 1.0 .LE. DET(1) .LT. 10.0 +C or DET(1) .EQ. 0.0 . +C Error condition +C A division by zero will occur if the input factor contains +C a zero on the diagonal and the inverse is requested. +C It will not occur if the subroutines are called correctly +C and if DPOCO or DPOFA has set info .EQ. 0 . +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University Of New Mexico, Argonne National Lab. +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***Routines called DAXPY,DSCAL +C***End Prologue DPODI + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER JOB,LDA,N + +C...Array arguments + REAL (KIND=R8) A(LDA,*),DET(*) + +C...Local scalars + REAL (KIND=R8) S,T + INTEGER I,J,JM1,K,KP1 + +C...External subroutines + EXTERNAL DAXPY,DSCAL + +C...Intrinsic functions + INTRINSIC MOD + + +C***First executable statement DPODI + + + IF (JOB/10 .EQ. 0) GO TO 70 + DET(1) = 1.0E0_R8 + DET(2) = 0.0E0_R8 + S = 10.0E0_R8 + DO 50 I = 1, N + DET(1) = A(I,I)**2*DET(1) +C ...Exit + IF (DET(1) .EQ. 0.0E0_R8) GO TO 60 + 10 IF (DET(1) .GE. 1.0E0_R8) GO TO 20 + DET(1) = S*DET(1) + DET(2) = DET(2) - 1.0E0_R8 + GO TO 10 + 20 CONTINUE + 30 IF (DET(1) .LT. S) GO TO 40 + DET(1) = DET(1)/S + DET(2) = DET(2) + 1.0E0_R8 + GO TO 30 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + +C Compute inverse(R) + + IF (MOD(JOB,10) .EQ. 0) GO TO 140 + DO 100 K = 1, N + A(K,K) = 1.0E0_R8/A(K,K) + T = -A(K,K) + CALL DSCAL(K-1,T,A(1,K),1) + KP1 = K + 1 + IF (N .LT. KP1) GO TO 90 + DO 80 J = KP1, N + T = A(K,J) + A(K,J) = 0.0E0_R8 + CALL DAXPY(K,T,A(1,K),1,A(1,J),1) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C Form inverse(R) * trans(inverse(R)) + + DO 130 J = 1, N + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 120 + DO 110 K = 1, JM1 + T = A(K,J) + CALL DAXPY(K,T,A(1,J),1,A(1,K),1) + 110 CONTINUE + 120 CONTINUE + T = A(J,J) + CALL DSCAL(J,T,A(1,J),1) + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DQRDC + SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) +C***Begin Prologue DQRDC +C***Date Written 780814 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D5 +C***Keywords Decomposition,REAL (KIND=R8),Linear Algebra,LINPACK, +C Matrix,Orthogonal Triangular +C***Author Stewart, G. W., (U. of Maryland) +C***Purpose Uses Householder Transformations to Compute the QR Factori- +C zation of N by P matrix X. Column pivoting is optional. +C***Description +C DQRDC uses householder transformations to compute the QR +C factorization of an N by P matrix X. Column pivoting +C based on the 2-norms of the reduced columns may be +C performed at the user's option. +C On Entry +C X REAL (KIND=R8)(LDX,P), where LDX .GE. N. +C X contains the matrix whose decomposition is to be +C computed. +C LDX INTEGER. +C LDX is the leading dimension of the array X. +C N INTEGER. +C N is the number of rows of the matrix X. +C P INTEGER. +C P is the number of columns of the matrix X. +C JPVT INTEGER(P). +C JPVT contains integers that control the selection +C of the pivot columns. The K-th column X(K) of X +C is placed in one of three classes according to the +C value of JPVT(K). +C If JPVT(K) .GT. 0, then X(K) is an initial +C column. +C If JPVT(K) .EQ. 0, then X(K) is a free column. +C If JPVT(K) .LT. 0, then X(K) is a final column. +C Before the decomposition is computed, initial columns +C are moved to the beginning of the array X and final +C columns to the end. Both initial and final columns +C are frozen in place during the computation and only +C free columns are moved. At the K-th stage of the +C reduction, if X(K) is occupied by a free column +C it is interchanged with the free column of largest +C reduced norm. JPVT is not referenced if +C JOB .EQ. 0. +C WORK REAL (KIND=R8)(P). +C WORK is a work array. WORK is not referenced if +C JOB .EQ. 0. +C JOB INTEGER. +C JOB is an integer that initiates column pivoting. +C If JOB .EQ. 0, no pivoting is done. +C If JOB .NE. 0, pivoting is done. +C On Return +C X X contains in its upper triangle the upper +C triangular matrix R of the QR factorization. +C Below its diagonal X contains information from +C which the orthogonal part of the decomposition +C can be recovered. Note that if pivoting has +C been requested, the decomposition is not that +C of the original matrix X but that of X +C with its columns permuted as described by JPVT. +C QRAUX REAL (KIND=R8)(P). +C QRAUX contains further information required to recover +C the orthogonal part of the decomposition. +C JPVT JPVT(K) contains the index of the column of the +C original matrix that has been interchanged into +C the K-th column, if pivoting was requested. +C LINPACK. This version dated 08/14/78 . +C G. W. Stewart, University of Maryland, Argonne National Lab. +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***Routines Called DAXPY,DDOT,DNRM2,DSCAL,DSWAP +C***End Prologue DQRDC + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & JOB,LDX,N,P + +C...Array arguments + REAL (KIND=R8) + & QRAUX(*),WORK(*),X(LDX,*) + INTEGER + & JPVT(*) + +C...Local scalars + REAL (KIND=R8) + & MAXNRM,NRMXL,T,TT + INTEGER + & J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU + LOGICAL + & NEGJ,SWAPJ + +C...External functions + REAL (KIND=R8) + & DDOT,DNRM2 + EXTERNAL + & DDOT,DNRM2 + +C...External subroutines + EXTERNAL + & DAXPY,DSCAL,DSWAP + +C...Intrinsic functions + INTRINSIC + & DABS,DMAX1,DSIGN,DSQRT,MIN0 + + +C***First executable statement DQRDC + + + PL = 1 + PU = 0 + IF (JOB .EQ. 0) GO TO 60 + +C Pivoting has been requested. Rearrange the columns +C according to JPVT. + + DO 20 J = 1, P + SWAPJ = JPVT(J) .GT. 0 + NEGJ = JPVT(J) .LT. 0 + JPVT(J) = J + IF (NEGJ) JPVT(J) = -J + IF (.NOT.SWAPJ) GO TO 10 + IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) + JPVT(J) = JPVT(PL) + JPVT(PL) = J + PL = PL + 1 + 10 CONTINUE + 20 CONTINUE + PU = P + DO 50 JJ = 1, P + J = P - JJ + 1 + IF (JPVT(J) .GE. 0) GO TO 40 + JPVT(J) = -JPVT(J) + IF (J .EQ. PU) GO TO 30 + CALL DSWAP(N,X(1,PU),1,X(1,J),1) + JP = JPVT(PU) + JPVT(PU) = JPVT(J) + JPVT(J) = JP + 30 CONTINUE + PU = PU - 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + +C Compute the norms of the free columns. + + IF (PU .LT. PL) GO TO 80 + DO 70 J = PL, PU + QRAUX(J) = DNRM2(N,X(1,J),1) + WORK(J) = QRAUX(J) + 70 CONTINUE + 80 CONTINUE + +C Perform the Householder Reduction of X. + + LUP = MIN0(N,P) + DO 200 L = 1, LUP + IF (L .LT. PL .OR. L .GE. PU) GO TO 120 + +C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT +C INTO THE PIVOT POSITION. + + MAXNRM = 0.0E0_R8 + MAXJ = L + DO 100 J = L, PU + IF (QRAUX(J) .LE. MAXNRM) GO TO 90 + MAXNRM = QRAUX(J) + MAXJ = J + 90 CONTINUE + 100 CONTINUE + IF (MAXJ .EQ. L) GO TO 110 + CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) + QRAUX(MAXJ) = QRAUX(L) + WORK(MAXJ) = WORK(L) + JP = JPVT(MAXJ) + JPVT(MAXJ) = JPVT(L) + JPVT(L) = JP + 110 CONTINUE + 120 CONTINUE + QRAUX(L) = 0.0E0_R8 + IF (L .EQ. N) GO TO 190 + +C Compute the Householder Transformation for column L. + + NRMXL = DNRM2(N-L+1,X(L,L),1) + IF (NRMXL .EQ. 0.0E0_R8) GO TO 180 + IF (X(L,L) .NE. 0.0E0_R8) NRMXL = DSIGN(NRMXL,X(L,L)) + CALL DSCAL(N-L+1,1.0E0_R8/NRMXL,X(L,L),1) + X(L,L) = 1.0E0_R8 + X(L,L) + +C Apply the transformation to the remaining columns, +C updating the norms. + + LP1 = L + 1 + IF (P .LT. LP1) GO TO 170 + DO 160 J = LP1, P + T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) + CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) + IF (J .LT. PL .OR. J .GT. PU) GO TO 150 + IF (QRAUX(J) .EQ. 0.0E0_R8) GO TO 150 + TT = 1.0E0_R8 - (DABS(X(L,J))/QRAUX(J))**2 + TT = DMAX1(TT,0.0E0_R8) + T = TT + TT = 1.0E0_R8 + 0.05E0_R8*TT*(QRAUX(J)/WORK(J))**2 + IF (TT .EQ. 1.0E0_R8) GO TO 130 + QRAUX(J) = QRAUX(J)*DSQRT(T) + GO TO 140 + 130 CONTINUE + QRAUX(J) = DNRM2(N-L,X(L+1,J),1) + WORK(J) = QRAUX(J) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + +C Save the transformation. + + QRAUX(L) = X(L,L) + X(L,L) = -NRMXL + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DQRSL + SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) +C***Begin Prologue DQRSL +C***Date Written 780814 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D9,D2A1 +C***Keywords REAL (KIND=R8),Linear Algebra,LINPACK,Matrix, +C Orthogonal Triangular,Solve +C***Author Stewart, G. W., (U. Of Maryland) +C***Purpose Applies the output of DQRDC to compute coordinate +C transformations, projections, and least squares solutions. +C***Description +C DQRSL applies the output of DQRDC to compute coordinate +C transformations, projections, and least squares solutions. +C for K .LE. MIN(N,P), let XK be the matrix +C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) +C formed from columnns JPVT(1), ... ,JPVT(K) of the original +C N x P matrix X that was input to DQRDC (if no pivoting was +C done, XK consists of the first K columns of X in their +C original order). DQRDC produces a factored orthogonal matrix Q +C and an upper triangular matrix R such that +C XK = Q * (R) +C (0) +C This information is contained in coded form in the arrays +C X and QRAUX. +C On Entry +C X REAL (KIND=R8)(LDX,P). +C X contains the output of DQRDC. +C LDX INTEGER. +C LDX is the leading dimension of the array X. +C N INTEGER. +C N is the number of rows of the matrix XK. It must +C have the same value as N in DQRDC. +C K INTEGER. +C K is the number of columns of the matrix XK. K +C must not be greater than min(N,P), where P is the +C same as in the calling sequence to DQRDC. +C QRAUX REAL (KIND=R8)(P). +C QRAUX contains the auxiliary output from DQRDC. +C Y REAL (KIND=R8)(N) +C Y contains an N-vector that is to be manipulated +C by DQRSL. +C JOB INTEGER. +C JOB specifies what is to be computed. JOB has +C the decimal expansion ABCDE, with the following +C meaning. +C If A .NE. 0, compute QY. +C If B,C,D, OR E .NE. 0, compute QTY. +C If C .NE. 0, compute B. +C If D .NE. 0, compute RSD. +C If E .NE. 0, compute XB. +C Note that a request to compute B, RSD, or XB +C automatically triggers the computation of QTY, for +C which an array must be provided in the calling +C sequence. +C On Return +C QY REAL (KIND=R8)(N). +C QY contains Q*Y, if its computation has been +C requested. +C QTY REAL (KIND=R8)(N). +C QTY contains trans(Q)*Y, if its computation has +C been requested. Here trans(Q) is the +C transpose of the matrix Q. +C B REAL (KIND=R8)(K) +C B contains the solution of the least squares problem +C Minimize NORM2(Y - XK*B), +C if its computation has been requested. (Note that +C if pivoting was requested in DQRDC, the J-th +C component of B will be associated with column JPVT(J) +C of the original matrix X that was input into DQRDC.) +C RSD REAL (KIND=R8)(N). +C RSD contains the least squares residual Y - XK*B, +C if its computation has been requested. RSD is +C also the orthogonal projection of Y onto the +C orthogonal complement of the column space of XK. +C XB REAL (KIND=R8)(N). +C XB contains the least squares approximation XK*B, +C if its computation has been requested. XB is also +C the orthogonal projection of Y onto the column space +C of X. +C INFO INTEGER. +C INFO is zero unless the computation of B has +C been requested and R is exactly singular. In +C this case, INFO is the index of the first zero +C diagonal element of R and B is left unaltered. +C The parameters QY, QTY, B, RSD, and XB are not referenced +C if their computation is not requested and in this case +C can be replaced by dummy variables in the calling program. +C To save storage, the user may in some cases use the same +C array for different parameters in the calling sequence. A +C frequently occuring example is when one wishes to compute +C any of B, RSD, or XB and does not need Y or QTY. In this +C case one may identify Y, QTY, and one of B, RSD, or XB, while +C providing separate arrays for anything else that is to be +C computed. Thus the calling sequence +c CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) +C will result in the computation of B and RSD, with RSD +C overwriting Y. More generally, each item in the following +C list contains groups of permissible identifications for +C a single calling sequence. +C 1. (Y,QTY,B) (RSD) (XB) (QY) +C 2. (Y,QTY,RSD) (B) (XB) (QY) +C 3. (Y,QTY,XB) (B) (RSD) (QY) +C 4. (Y,QY) (QTY,B) (RSD) (XB) +C 5. (Y,QY) (QTY,RSD) (B) (XB) +C 6. (Y,QY) (QTY,XB) (B) (RSD) +C In any group the value returned in the array allocated to +C the group corresponds to the last member of the group. +C LINPACK. This version dated 08/14/78 . +C G. W. Stewart, University of Maryland, Argonne National Lab. +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***Routines Called DAXPY,DCOPY,DDOT +C***End Prologue DQRSL + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INFO,JOB,K,LDX,N + +C...Array arguments + REAL (KIND=R8) + & B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*), + & Y(*) + +C...Local scalars + REAL (KIND=R8) + & T,TEMP + INTEGER + & I,J,JJ,JU,KP1 + LOGICAL + & CB,CQTY,CQY,CR,CXB + +C...External functions + REAL (KIND=R8) + & DDOT + EXTERNAL + & DDOT + +C...External subroutines + EXTERNAL + & DAXPY,DCOPY + +C...Intrinsic functions + INTRINSIC + & MIN0,MOD + + +C***First executable statement DQRSL + + + INFO = 0 + +C Determine what is to be computed. + + CQY = JOB/10000 .NE. 0 + CQTY = MOD(JOB,10000) .NE. 0 + CB = MOD(JOB,1000)/100 .NE. 0 + CR = MOD(JOB,100)/10 .NE. 0 + CXB = MOD(JOB,10) .NE. 0 + JU = MIN0(K,N-1) + +C Special action when N=1. + + IF (JU .NE. 0) GO TO 40 + IF (CQY) QY(1) = Y(1) + IF (CQTY) QTY(1) = Y(1) + IF (CXB) XB(1) = Y(1) + IF (.NOT.CB) GO TO 30 + IF (X(1,1) .NE. 0.0E0_R8) GO TO 10 + INFO = 1 + GO TO 20 + 10 CONTINUE + B(1) = Y(1)/X(1,1) + 20 CONTINUE + 30 CONTINUE + IF (CR) RSD(1) = 0.0E0_R8 + GO TO 250 + 40 CONTINUE + +C Set up to compute QY or QTY. + + IF (CQY) CALL DCOPY(N,Y,1,QY,1) + IF (CQTY) CALL DCOPY(N,Y,1,QTY,1) + IF (.NOT.CQY) GO TO 70 + +C Compute QY. + + DO 60 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0E0_R8) GO TO 50 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1) + X(J,J) = TEMP + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IF (.NOT.CQTY) GO TO 100 + +C Compute trans(Q)*Y. + + DO 90 J = 1, JU + IF (QRAUX(J) .EQ. 0.0E0_R8) GO TO 80 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1) + X(J,J) = TEMP + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C Set up to compute B, RSD, or XB. + + IF (CB) CALL DCOPY(K,QTY,1,B,1) + KP1 = K + 1 + IF (CXB) CALL DCOPY(K,QTY,1,XB,1) + IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1) + IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 + DO 110 I = KP1, N + XB(I) = 0.0E0_R8 + 110 CONTINUE + 120 CONTINUE + IF (.NOT.CR) GO TO 140 + DO 130 I = 1, K + RSD(I) = 0.0E0_R8 + 130 CONTINUE + 140 CONTINUE + IF (.NOT.CB) GO TO 190 + +C Compute B. + + DO 170 JJ = 1, K + J = K - JJ + 1 + IF (X(J,J) .NE. 0.0E0_R8) GO TO 150 + INFO = J +C ......EXIT + GO TO 180 + 150 CONTINUE + B(J) = B(J)/X(J,J) + IF (J .EQ. 1) GO TO 160 + T = -B(J) + CALL DAXPY(J-1,T,X(1,J),1,B,1) + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 + +C Compute RSD or XB as required. + + DO 230 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0E0_R8) GO TO 220 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + IF (.NOT.CR) GO TO 200 + T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1) + 200 CONTINUE + IF (.NOT.CXB) GO TO 210 + T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1) + 210 CONTINUE + X(J,J) = TEMP + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN + END +*DROT + SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS) +C***Begin Prologue DROT +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A8 +C***Keywords BLAS,Givens Rotation,Linear Algebra,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose Apply D.P. Givens Rotation +C***Description +C B L A S Subprogram +C Description of Parameters +C --Input-- +C N Number of elements in input vector(s) +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C DY REAL (KIND=R8) vector with N elements +C INCY Storage spacing between elements of DY +C DC D.P. element of rotation matrix +C DS D.P. element of rotation matrix +C --Output-- +C DX Rotated vector (unchanged if N .LE. 0) +C DY Rotated vector (unchanged if N .LE. 0) +C Multiply the 2 x 2 matrix ( DC DS) times the 2 x N matrix (DX**T) +C (-DS DC) (DY**T) +C where **T indicates transpose. The elements of DX are in +C DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else +C LX = (-INCX)*N, and similarly for DY using LY and INCY. +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines Called (NONE) +C***End Prologue DROT + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & DC,DS + INTEGER + & INCX,INCY,N + +C...Array arguments + REAL (KIND=R8) + & DX(*),DY(*) + +C...Local scalars + REAL (KIND=R8) + & ONE,W,Z,ZERO + INTEGER + & I,KX,KY,NSTEPS + +C...Data statements + DATA + & ZERO,ONE/0.E0_R8,1.E0_R8/ + + +C***First executable statement DROT + + + IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 + IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 + + NSTEPS=INCX*N + DO 10 I=1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=DC*W+DS*Z + DY(I)=-DS*W+DC*Z + 10 CONTINUE + GO TO 40 + + 20 CONTINUE + KX=1 + KY=1 + + IF(INCX .LT. 0) KX=1-(N-1)*INCX + IF(INCY .LT. 0) KY=1-(N-1)*INCY + + DO 30 I=1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=DC*W+DS*Z + DY(KY)=-DS*W+DC*Z + KX=KX+INCX + KY=KY+INCY + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DROTG + SUBROUTINE DROTG(DA,DB,DC,DS) +C***Begin Prologue DROTG +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1B10 +C***Keywords BLAS,Givens Rotation,Linear Algebra,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose Construct D.P. Plane Givens Rotation +C***Description +C B L A S Subprogram +C Description of Parameters +C --Input-- +C DA REAL (KIND=R8) scalar +C DB REAL (KIND=R8) scalar +C --Output-- +C DA REAL (KIND=R8) result R +C DB REAL (KIND=R8) result Z +C DC REAL (KIND=R8) result +C DS REAL (KIND=R8) result +C Designed By C. L. Lawson, JPL, 1977 Sept 08 +C Construct the Givens Transformation +C ( DC DS ) +C G = ( ) , DC**2 + DS**2 = 1 , +C (-DS DC ) +C which zeros the second entry of the 2-vector (DA,DB)**T . +C the quantity R = (+/-)DSQRT(DA**2 + DB**2) overwrites DA in +C storage. The value of DB is overwritten by a value Z which +C allows DC and DS to be recovered by the following algorithm. +C If Z=1 set DC=0.E0_R8 and DS=1.E0_R8 +C If DABS(Z) .LT. 1 set DC=DSQRT(1-Z**2) and DS=Z +C If DABS(Z) .GT. 1 set DC=1/Z and DS=DSQRT(1-DC**2) +C Normally, the subprogram DROT(N,DX,INCX,DY,INCY,DC,DS) will +C next be called to apply the transformation to a 2 by N matrix. +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines Called (None) +C***End Prologue DROTG + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & DA,DB,DC,DS + +C...Local scalars + REAL (KIND=R8) + & R,U,V + +C...Intrinsic functions + INTRINSIC + & DABS,DSQRT + + +C***First executable statement DROTG + + + IF (DABS(DA) .LE. DABS(DB)) GO TO 10 + +C *** Here DABS(DA) .GT. DABS(DB) *** + + U = DA + DA + V = DB / U + +C Note that U and R have the sign of DA + + R = DSQRT(.25E0_R8 + V**2) * U + +C Note that DC is positive + + DC = DA / R + DS = V * (DC + DC) + DB = DS + DA = R + RETURN + +C *** Here DABS(DA) .LE. DABS(DB) *** + + 10 IF (DB .EQ. 0.E0_R8) GO TO 20 + U = DB + DB + V = DA / U + +C Note that U and R have the sign of DB +C (R is immediately stored in DA) + + DA = DSQRT(.25E0_R8 + V**2) * U + +C Note that DS is positive + + DS = DB / DA + DC = V * (DS + DS) + IF (DC .EQ. 0.E0_R8) GO TO 15 + DB = 1.E0_R8 / DC + RETURN + 15 DB = 1.E0_R8 + RETURN + +C *** Here DA = DB = 0.E0_R8 *** + + 20 DC = 1.E0_R8 + DS = 0.E0_R8 + RETURN + + END +*DSCAL + SUBROUTINE DSCAL(N,DA,DX,INCX) +C***Begin Prologue DSCAL +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A6 +C***Keywords BLAS,Linear Algebra,Scale,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose D.P. Vector Scale X = A*X +C***Description +C B L A S Subprogram +C Description of Parameters +C --Input-- +C N Number of elements in input vector(s) +C DA REAL (KIND=R8) scale factor +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C --Output-- +C DX REAL (KIND=R8) result (unchanged if N.LE.0) +C Replace REAL (KIND=R8) DX by REAL (KIND=R8) DA*DX. +C For I = 0 to N-1, replace DX(1+I*INCX) with DA * DX(1+I*INCX) +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines Called (None) +C***End Prologue DSCAL + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & DA + INTEGER + & INCX,N + +C...Array arguments + REAL (KIND=R8) + & DX(*) + +C...Local scalars + INTEGER + & I,M,MP1,NS + +C...Intrinsic functions + INTRINSIC + & MOD + + +C***First executable statement DSCAL + + + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C Code for increments not equal to 1. + + NS = N*INCX + DO 10 I = 1,NS,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN + +C Code for increments equal to 1. + + +C Clean-up loop so remaining vector length is a multiple of 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + END +*DSWAP + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +C***Begin Prologue DSWAP +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A5 +C***Keywords BLAS,REAL (KIND=R8),Interchange,Linear Algebra,Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose Interchange D.P. vectors +C***Description +C B L A S Subprogram +C Description of Parameters +C --Input-- +C N Number of elements in input vector(s) +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C DY REAL (KIND=R8) vector with N elements +C INCY Storage spacing between elements of DY +C --Output-- +C DX Input vector DY (unchanged if N .LE. 0) +C DY Input vector DX (unchanged if N .LE. 0) +C Interchange REAL (KIND=R8) DX and REAL (KIND=R8) DY. +C For I = 0 TO N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), +C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is +C defined in a similar way using INCY. +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines Called (None) +C***End Prologue DSWAP + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INCX,INCY,N + +C...Array arguments + REAL (KIND=R8) + & DX(*),DY(*) + +C...Local scalars + REAL (KIND=R8) + & DTEMP1,DTEMP2,DTEMP3 + INTEGER + & I,IX,IY,M,MP1,NS + +C...Intrinsic functions + INTRINSIC + & MOD + + +C***First executable statement DSWAP + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) THEN + IF(INCX-1.LT.0) THEN + GOTO 5 + ELSE IF(INCX-1.EQ.0) THEN + GOTO 20 + ELSE IF(INCX-1.GT.0) THEN + GOTO 60 + END IF + END IF + 5 CONTINUE + +C Code for unequal or nonpositive increments. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C Code for both increments equal to 1 + + +C Clean-up loop so remaining vector length is a multiple of 3. + + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN + 60 CONTINUE + +C Code for equal, positive, nonunit increments. + + NS = N*INCX + DO 70 I=1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END +*DTRCO + SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB) +C***Begin Prologue DTRCO +C***Date Written 780814 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D2A3 +C***Keywords Condition,REAL (KIND=R8),Factor,Linear Algebra,LINPACK, +C Matrix,Triangular +C***Author Moler, C. B., (U. of New Mexico) +C***Purpose Estimates the condition of a REAL (KIND=R8) triangular +C matrix. +C***Description +C DTRCO estimates the condition of a REAL (KIND=R8) triangular +C matrix. +C On Entry +C T REAL (KIND=R8)(LDT,N) +C T contains the triangular matrix. The zero +C elements of the matrix are not referenced, and +C the corresponding elements of the array can be +C used to store other information. +C LDT INTEGER +C LDT is the leading dimension of the array T. +C N INTEGER +C N is the order of the system. +C JOB INTEGER +C = 0 T is lower triangular. +C = NONZERO T is upper triangular. +C On Return +C RCOND REAL (KIND=R8) +C An estimate of the reciprocal condition of T . +C for the system T*X = B , relative perturbations +C in T and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then T may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C Z REAL (KIND=R8)(N) +C A work vector whose contents are usually unimportant. +C If T is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C norm(A*Z) = RCOND*norm(A)*norm(Z) . +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***Routines Called DASUM,DAXPY,DSCAL +C***End Prologue DTRCO + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & RCOND + INTEGER + & JOB,LDT,N + +C...Array arguments + REAL (KIND=R8) + & T(LDT,*),Z(*) + +C...Local scalars + REAL (KIND=R8) + & EK,S,SM,TNORM,W,WK,WKM,YNORM + INTEGER + & I1,J,J1,J2,K,KK,L + LOGICAL + & LOWER + +C...External functions + REAL (KIND=R8) + & DASUM + EXTERNAL + & DASUM + +C...External subroutines + EXTERNAL + & DAXPY,DSCAL + +C...Intrinsic functions + INTRINSIC + & DABS,DMAX1,DSIGN + + +C***First executable statement DTRCO + + + LOWER = JOB .EQ. 0 + +C Compute 1-norm of T + + TNORM = 0.0E0_R8 + DO 10 J = 1, N + L = J + IF (LOWER) L = N + 1 - J + I1 = 1 + IF (LOWER) I1 = J + TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1)) + 10 CONTINUE + +C RCOND = 1/(norm(T)*(estimate of norm(inverse(T)))) . +C Estimate = norm(Z)/norm(Y) where T*Z = Y and trans(T)*Y = E . +C Trans(T) is the transpose of T . +C The components of E are chosen to cause maximum local +C growth in the elements of Y . +C The vectors are frequently rescaled to avoid overflow. + +C Solve trans(T)*Y = E + + EK = 1.0E0_R8 + DO 20 J = 1, N + Z(J) = 0.0E0_R8 + 20 CONTINUE + DO 100 KK = 1, N + K = KK + IF (LOWER) K = N + 1 - KK + IF (Z(K) .NE. 0.0E0_R8) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30 + S = DABS(T(K,K))/DABS(EK-Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (T(K,K) .EQ. 0.0E0_R8) GO TO 40 + WK = WK/T(K,K) + WKM = WKM/T(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0E0_R8 + WKM = 1.0E0_R8 + 50 CONTINUE + IF (KK .EQ. N) GO TO 90 + J1 = K + 1 + IF (LOWER) J1 = 1 + J2 = N + IF (LOWER) J2 = K - 1 + DO 60 J = J1, J2 + SM = SM + DABS(Z(J)+WKM*T(K,J)) + Z(J) = Z(J) + WK*T(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + W = WKM - WK + WK = WKM + DO 70 J = J1, J2 + Z(J) = Z(J) + W*T(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0E0_R8/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + + YNORM = 1.0E0_R8 + +C Solve T*Z = Y + + DO 130 KK = 1, N + K = N + 1 - KK + IF (LOWER) K = KK + IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110 + S = DABS(T(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 110 CONTINUE + IF (T(K,K) .NE. 0.0E0_R8) Z(K) = Z(K)/T(K,K) + IF (T(K,K) .EQ. 0.0E0_R8) Z(K) = 1.0E0_R8 + I1 = 1 + IF (LOWER) I1 = K + 1 + IF (KK .GE. N) GO TO 120 + W = -Z(K) + CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1) + 120 CONTINUE + 130 CONTINUE +C Make ZNORM = 1.0 + S = 1.0E0_R8/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + + IF (TNORM .NE. 0.0E0_R8) RCOND = YNORM/TNORM + IF (TNORM .EQ. 0.0E0_R8) RCOND = 0.0E0_R8 + RETURN + END +*DTRSL + SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO) +C***Begin Prologue DTRSL +C***Date Written 780814 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D2A3 +C***Keywords REAL (KIND=R8),Linear Algebra,LINPACK,Matrix,Solve, +C Triangular +C***Author Stewart, G. W., (U. of Maryland) +C***Purpose Solves systems of the form T*X=B or trans(T)*X=B where T +C is a triangular matrix of order N. +C***Description +C DTRSL solves systems of the form +C T * X = B +C or +C trans(T) * X = B +C where T is a triangular matrix of order N. Here trans(T) +C denotes the transpose of the matrix T. +C On Entry +C T REAL (KIND=R8)(LDT,N) +C T contains the matrix of the system. The zero +C elements of the matrix are not referenced, and +C the corresponding elements of the array can be +C used to store other information. +C LDT INTEGER +C LDT is the leading dimension of the array T. +C N INTEGER +C N is the order of the system. +C B REAL (KIND=R8)(N). +C B contains the right hand side of the system. +C JOB INTEGER +C JOB specifies what kind of system is to be solved. +C If JOB is +C 00 solve T*X=B, T lower triangular, +C 01 solve T*X=B, T upper triangular, +C 10 solve trans(T)*X=B, T lower triangular, +C 11 solve trans(T)*X=B, T upper triangular. +C On Return +C B B contains the solution, if INFO .EQ. 0. +C otherwise B is unaltered. +C INFO INTEGER +C INFO contains zero if the system is nonsingular. +C otherwise INFO contains the index of +C the first zero diagonal element of T. +C LINPACK. This version dated 08/14/78 . +C G. W. Stewart, University of Maryland, Argonne National Lab. +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***Routines Called DAXPY,DDOT +C***End Prologue DTRSL + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INFO,JOB,LDT,N + +C...Array arguments + REAL (KIND=R8) + & B(*),T(LDT,*) + +C...Local scalars + REAL (KIND=R8) + & TEMP + INTEGER + & CASE,J,JJ + +C...External functions + REAL (KIND=R8) + & DDOT + EXTERNAL + & DDOT + +C...External subroutines + EXTERNAL + & DAXPY + +C...Intrinsic functions + INTRINSIC + & MOD + + +C***First executable statement DTRSL + + +C Begin block permitting ...exits to 150 + +C Check for zero diagonal elements. + + DO 10 INFO = 1, N +C ......Exit + IF (T(INFO,INFO) .EQ. 0.0E0_R8) GO TO 150 + 10 CONTINUE + INFO = 0 + +C Determine the task and go to it. + + CASE = 1 + IF (MOD(JOB,10) .NE. 0) CASE = 2 + IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 + IF (CASE.EQ.1) THEN; GOTO 20; END IF + IF (CASE.EQ.2) THEN; GOTO 50; END IF + IF (CASE.EQ.3) THEN; GOTO 80; END IF + IF (CASE.EQ.4) THEN; GOTO 110; END IF + +C Solve T*X=B for T lower triangular + + 20 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 40 + DO 30 J = 2, N + TEMP = -B(J-1) + CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) + B(J) = B(J)/T(J,J) + 30 CONTINUE + 40 CONTINUE + GO TO 140 + +C Solve T*X=B for T upper triangular. + + 50 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 70 + DO 60 JJ = 2, N + J = N - JJ + 1 + TEMP = -B(J+1) + CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1) + B(J) = B(J)/T(J,J) + 60 CONTINUE + 70 CONTINUE + GO TO 140 + +C Solve trans(T)*X=B for T lower triangular. + + 80 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 100 + DO 90 JJ = 2, N + J = N - JJ + 1 + B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1) + B(J) = B(J)/T(J,J) + 90 CONTINUE + 100 CONTINUE + GO TO 140 + +C Solve trans(T)*X=B for T upper triangular. + + 110 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 130 + DO 120 J = 2, N + B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) + B(J) = B(J)/T(J,J) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + RETURN + END +*IDAMAX + FUNCTION IDAMAX(N,DX,INCX) RESULT(IDAMAXR) +C***Begin Prologue IDAMAX +C***Date Written 791001 (YYMMDD) +C***Revision Date 820801 (YYMMDD) +C***Category No. D1A2 +C***Keywords BLAS,REAL (KIND=R8),Linear Algebra,Maximum Component, +C Vector +C***Author Lawson, C. L., (JPL) +C Hanson, R. J., (SNLA) +C Kincaid, D. R., (U. of Texas) +C Krogh, F. T., (JPL) +C***Purpose Find largest component of D.P. vector +C***Description +C B L A S Subprogram +C Description of parameters +C --Input-- +C N Number of elements in input vector(s) +C DX REAL (KIND=R8) vector with N elements +C INCX Storage spacing between elements of DX +C --Output-- +C IDAMAX Smallest index (zero if N .LE. 0) +C Find smallest index of maximum magnitude of REAL (KIND=R8) DX. +C IDAMAX = first I, I = 1 to N, to minimize ABS(DX(1-INCX+I*INCX) +C***References Lawson C.L., Hanson R.J., Kincaid D.R., Krogh F.T., +C *Basic Linear Algebra Subprograms for FORTRAN Usage*, +C Algorithm No. 539, Transactions on Mathematical +C Software, Volume 5, Number 3, September 1979, 308-323 +C***Routines Called (None) +C***End Prologue IDAMAX + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INCX,N + +C...Array arguments + REAL (KIND=R8) + & DX(*) + +C...Result + INTEGER + & IDAMAXR + +C...Local scalars + REAL (KIND=R8) + & DMAX,XMAG + INTEGER + & I,II,NS + +C...Intrinsic functions + INTRINSIC + & DABS + + +C***First executable statement IDAMAX + + + IDAMAXR = 0 + IF(N.LE.0) RETURN + IDAMAXR = 1 + IF(N.LE.1)RETURN + IF(INCX.EQ.1)GOTO 20 + +C Code for increments not equal to 1. + + DMAX = DABS(DX(1)) + NS = N*INCX + II = 1 + DO 10 I = 1,NS,INCX + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 5 + IDAMAXR = II + DMAX = XMAG + 5 II = II + 1 + 10 CONTINUE + RETURN + +C Code for increments equal to 1. + + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 30 + IDAMAXR = I + DMAX = XMAG + 30 CONTINUE + RETURN + END diff --git a/dataassim/math/optimization/odrpack95/makefile.txt b/dataassim/math/optimization/odrpack95/makefile.txt new file mode 100644 index 0000000..a5fe584 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/makefile.txt @@ -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 + diff --git a/dataassim/math/optimization/odrpack95/odr.f b/dataassim/math/optimization/odrpack95/odr.f new file mode 100644 index 0000000..3996337 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/odr.f @@ -0,0 +1,12136 @@ +*ODRPACK95 + MODULE ODRPACK95 +C***Begin Prologue ODRPACK95 +C***Refer to ODR +C***Date Written 20040524 (YYYYMMDD) +C***Revision Date N/A +C***Purpose: Define the interface to the ODR subroutine +C***End Prologue ODRPACK95 + + USE REAL_PRECISION + +C A temporary work array for holding return values before copying to a lower +C rank array. + REAL (KIND=R8), ALLOCATABLE :: TEMPRET(:,:) + + CONTAINS +*ODR + SUBROUTINE ODR + & (FCN, + & N,M,NP,NQ, + & BETA, + & Y,X, + & DELTA, + & WE,WD, + & IFIXB,IFIXX, + & JOB,NDIGIT,TAUFAC, + & SSTOL,PARTOL,MAXIT, + & IPRINT,LUNERR,LUNRPT, + & STPB,STPD, + & SCLB,SCLD, + & WORK,IWORK, + & INFO, + & LOWER,UPPER) +C***Begin Prologue ODR +C***Date Written 860529 (YYMMDD) +C***Revision Date 20040301 (YYYYMMDD) +C***Category No. G2E,I1B1 +C***Keywords Orthogonal distance regression, +C Nonlinear least squares, +C Measurement error models, +C Errors in variables +C***Author Boggs, Paul T. +C Applied and Computational Mathematics Division +C National Institute of Standards and Technology +C Gaithersburg, MD 20899 +C Byrd, Richard H. +C Department of Computer Science +C University of Colorado, Boulder, CO 80309 +C Rogers, Janet E. +C Applied and Computational Mathematics Division +C National Institute of Standards and Technology +C Boulder, CO 80303-3328 +C Schnabel, Robert B. +C Department of Computer Science +C University of Colorado, Boulder, CO 80309 +C and +C Applied and Computational Mathematics Division +C National Institute of Standards and Technology +C Boulder, CO 80303-3328 +C***Purpose REAL (KIND=R8) driver routine for finding +C the weighted explicit or implicit orthogonal distance +C regression (ODR) or ordinary linear or nonlinear least +C squares (OLS) solution (long call statement) +C***Description +C For details, see ODRPACK95 User's Reference Guide. +C***References Boggs, P. T., R. H. Byrd, J. R. Donaldson, and +C R. B. Schnabel (1989), +C "Algorithm 676 --- ODRPACK: Software for Weighted +C Orthogonal Distance Regression," +C ACM Trans. Math. Software., 15(4):348-364. +C Boggs, P. T., R. H. Byrd, J. E. Rogers, and +C R. B. Schnabel (1992), +C "User's Reference Guide for ODRPACK Version 2.01, +C Software for Weighted Orthogonal Distance Regression," +C National Institute of Standards and Technology +C Internal Report Number 92-4834. +C Boggs, P. T., R. H. Byrd, and R. B. Schnabel (1987), +C "A Stable and Efficient Algorithm for Nonlinear +C Orthogonal Distance Regression," +C SIAM J. Sci. Stat. Comput., 8(6):1052-1078. +C***Routines Called DODCNT +C***End Prologue ODR + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & PARTOL,SSTOL,TAUFAC + INTEGER + & INFO,IPRINT,JOB,LUNERR,LUNRPT,M,MAXIT,N,NDIGIT,NP,NQ + +C...Array arguments + REAL (KIND=R8) + & BETA(:),DELTA(:,:),LOWER(:),SCLB(:),SCLD(:,:), + & STPB(:),STPD(:,:),UPPER(:),WD(:,:,:),WE(:,:,:), + & WORK(:),X(:,:),Y(:,:) + INTEGER + & IFIXB(:),IFIXX(:,:),IWORK(:) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Optional arguments + OPTIONAL + & DELTA,IFIXB,IFIXX,INFO,IPRINT,IWORK,JOB,LOWER,LUNERR, + & LUNRPT,MAXIT,NDIGIT,PARTOL,SCLB,SCLD,SSTOL,STPB, + & STPD,TAUFAC,UPPER,WE,WD,WORK + +C...Pointers + POINTER + & DELTA,IWORK,WORK + +C...Local scalars + REAL (KIND=R8) + & NEGONE,ZERO,LTAUFAC,LSSTOL,LPARTOL + INTEGER + & LDWE,LD2WE,LDWD,LD2WD,LDIFX,LDSCLD,LDSTPD, + & LJOB,LNDIGIT,LMAXIT,LIPRINT,LLUNERR,LLUNRPT,LINFO, + & LENWORK,LENIWORK,LINFO1,LINFO2,LINFO3,LINFO4,LINFO5 + LOGICAL + & HEAD + +C...Local arrays + REAL (KIND=R8) + & LDELTA(:,:),LLOWER(NP),LWE(N,NQ,NQ),LWD(N,M,M), + & LSTPB(NP),LSTPD(N,M),LSCLB(NP), + & LSCLD(N,M),LUPPER(NP),LWORK(:),WD1(1,1,1) + INTEGER + & LIFIXB(NP),LIWORK(:),LIFIXX(N,M) + +C...Pointer + POINTER + & LDELTA,LIWORK,LWORK + +C...Saved variables + SAVE + & LDELTA,LIWORK,LWORK + +C...External subroutines + EXTERNAL + & DODCNT + +C...Data statements + DATA + & NEGONE,ZERO + & /-1.0E0_R8,0.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user-supplied subroutine for evaluating the model. + +C...Variable definitions (alphabetically) +C BETA: The function parameters. +C DELTA: The initial error in the X data +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C INFO: The variable designating why the computations were stopped. +C IPRINT: The print control variable. +C IWORK: The integer work space. +C JOB: The variable controlling problem initialization and +C computational method. +C LOWER: The lower bound on BETA. +C LUNERR: The logical unit number for error messages. +C LUNRPT: The logical unit number for computation reports. +C M: The number of columns of data in the explanatory variable. +C MAXIT: The maximum number of iterations allowed. +C N: The number of observations. +C NDIGIT: The number of accurate digits in the function results, as +C supplied by the user. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C PARTOL: The parameter convergence stopping tolerance. +C SCLB: The scaling values for BETA. +C SCLD: The scaling values for DELTA. +C STPB: The relative step for computing finite difference +C derivatives with respect to BETA. +C STPD: The relative step for computing finite difference +C derivatives with respect to DELTA. +C SSTOL: The sum-of-squares convergence stopping tolerance. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C UPPER: The upper bound on BETA. +C WD: The DELTA weights. +C WD1: A dummy array used when WD(1,1,1)=0.0E0_R8. +C WE: The EPSILON weights. +C WORK: The REAL (KIND=R8) work space. +C X: The explanatory variable. +C Y: The dependent variable. Unused when the model is implicit. + + +C***First executable statement ODR + + +C Set LINFO to zero indicating no errors have been found thus far + + LINFO = 0 + LINFO1 = 0 + LINFO2 = 0 + LINFO3 = 0 + LINFO4 = 0 + LINFO5 = 0 + +C Set all scalar variable defaults except JOB + + LDWE = 1 + LD2WE = 1 + LDWD = 1 + LD2WD = 1 + LDIFX = 1 + LDSCLD = 1 + LDSTPD = 1 + LIPRINT = -1 + LLUNERR = -1 + LLUNRPT = -1 + LMAXIT = -1 + LNDIGIT = -1 + LPARTOL = NEGONE + LSSTOL = NEGONE + LTAUFAC = NEGONE + HEAD = .TRUE. + +C Check for the option arguments for printing (so error messages can be +C printed appropriately from here on out + + IF (PRESENT(IPRINT)) THEN + LIPRINT = IPRINT + END IF + + IF (PRESENT(LUNRPT)) THEN + LLUNRPT = LUNRPT + END IF + IF (LLUNRPT.LT.0) THEN + LLUNRPT = 6 + END IF + + IF (PRESENT(LUNERR)) THEN + LLUNERR = LUNERR + END IF + IF (LLUNERR.LT.0) THEN + LLUNERR = 6 + END IF + +C Ensure the problem size is valid + + IF (N.LE.0) THEN + LINFO5 = 1 + LINFO4 = 1 + END IF + + IF (M.LE.0) THEN + LINFO5 = 1 + LINFO3 = 1 + END IF + + IF (NP.LE.0) THEN + LINFO5 = 1 + LINFO2 = 1 + END IF + + IF (NQ.LE.0) THEN + LINFO5 = 1 + LINFO1 = 1 + END IF + + IF (LINFO5.NE.0) THEN + LINFO = 10000*LINFO5+1000*LINFO4+100*LINFO3+10*LINFO2+LINFO1 + IF (LLUNERR.GT.0.AND.LIPRINT.NE.0) THEN + CALL DODPHD(HEAD,LLUNRPT) + CALL DODPE1( + & LLUNERR,LINFO,LINFO5,LINFO4,LINFO3,LINFO2,LINFO1, + & N,M,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LENWORK,LENIWORK + & ) + END IF + IF (PRESENT(INFO)) THEN + INFO = LINFO + END IF + RETURN + END IF + +C Define LJOB and check that necessary arguments are passed for JOB + + IF (PRESENT(JOB)) THEN + LJOB = JOB + IF (MOD(JOB,10000)/1000.GE.1) THEN + IF (.NOT.PRESENT(DELTA)) THEN + LINFO5 = 7 + LINFO4 = 1 + ELSE IF (.NOT.ASSOCIATED(DELTA)) THEN + LINFO5 = 7 + LINFO4 = 1 + END IF + END IF + IF (JOB.GE.10000) THEN + IF (.NOT.PRESENT(IWORK)) THEN + LINFO5 = 7 + LINFO2 = 1 + ELSE IF (.NOT.ASSOCIATED(IWORK)) THEN + LINFO5 = 7 + LINFO2 = 1 + END IF + END IF + IF (JOB.GE.10000) THEN + IF (.NOT.PRESENT(WORK)) THEN + LINFO5 = 7 + LINFO3 = 1 + ELSE IF (.NOT.ASSOCIATED(WORK)) THEN + LINFO5 = 7 + LINFO3 = 1 + END IF + END IF + ELSE + LJOB = -1 + END IF + + IF (LINFO5.NE.0) THEN + LINFO = 10000*LINFO5+1000*LINFO4+100*LINFO3+10*LINFO2+LINFO1 + IF (LLUNERR.GT.0.AND.LIPRINT.NE.0) THEN + CALL DODPHD(HEAD,LLUNRPT) + CALL DODPE1( + & LLUNERR,LINFO,LINFO5,LINFO4,LINFO3,LINFO2,LINFO1, + & N,M,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LENWORK,LENIWORK + & ) + END IF + IF (PRESENT(INFO)) THEN + INFO = LINFO + END IF + RETURN + END IF + +C Determine the size of WORK + + IF (LJOB.LT.0.OR.MOD(LJOB,10).LE.1) THEN + LENWORK = 18+13*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*NQ*NQ + ELSE + LENWORK = 18+13*NP+NP**2+M+M**2+4*N*NQ+2*N*M+2*N*NQ*NP+ + & 5*NQ+NQ*(NP+M)+N*NQ*NQ + END IF + +C Determine the size of IWORK + + LENIWORK = 20+2*NP+NQ*(NP+M) + +C Allocate the work arrays + + ALLOCATE(LWORK(LENWORK),TEMPRET(MAX(N,NP),MAX(NQ,M)),STAT=LINFO3) + ALLOCATE(LIWORK(LENIWORK),STAT=LINFO2) + LWORK(:) = 0.0_R8 + LIWORK(:) = 0 + IF (PRESENT(DELTA)) THEN + IF (.NOT.ASSOCIATED(DELTA)) THEN + ALLOCATE(LDELTA(N,M),STAT=LINFO4) + END IF + END IF + IF (LINFO4.NE.0.OR.LINFO3.NE.0.OR.LINFO2.NE.0) THEN + LINFO5 = 8 + END IF + + IF (LINFO5.NE.0) THEN + LINFO = 10000*MOD(LINFO5,10)+1000*MOD(LINFO4,10)+ + & 100*MOD(LINFO3,10)+10*MOD(LINFO2,10)+MOD(LINFO1,10) + IF (LLUNERR.GT.0.AND.LIPRINT.NE.0) THEN + CALL DODPHD(HEAD,LLUNRPT) + CALL DODPE1( + & LLUNERR,LINFO,LINFO5,LINFO4,LINFO3,LINFO2,LINFO1, + & N,M,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LENWORK,LENIWORK + & ) + END IF + IF (PRESENT(INFO)) THEN + INFO = LINFO + END IF + RETURN + END IF + +C Set array variable defaults except IWORK + + LWORK(1:N*M) = ZERO + LIFIXB(1) = -1 + LIFIXX(1,1) = -1 + LLOWER(1:NP) = -HUGE(ZERO) + LSCLB(1) = NEGONE + LSCLD(1,1) = NEGONE + LSTPB(1) = NEGONE + LSTPD(1,1) = NEGONE + LUPPER(1:NP) = HUGE(ZERO) + LWE(1,1,1) = NEGONE + LWD(1,1,1) = NEGONE + +C Check the size of required arguments and return errors if they are too small + + IF (SIZE(BETA).LT.NP) THEN + LINFO1 = LINFO1 + 1 + END IF + + IF (ANY(SIZE(Y).LT.(/N,NQ/))) THEN + LINFO1 = LINFO1 + 2 + END IF + + IF (ANY(SIZE(X).LT.(/N,M/))) THEN + LINFO1 = LINFO1 + 4 + END IF + +C Check the presence of optional arguments and copy their values internally or +C report errors as necessary + + IF (PRESENT(IFIXB)) THEN + IF (SIZE(IFIXB).LT.NP) THEN + LINFO1 = LINFO1 + 64 + END IF + IF (IFIXB(1).LT.0.0_R8) THEN + LIFIXB(1) = IFIXB(1) + ELSE + LIFIXB(1:NP) = IFIXB(1:NP) + END IF + END IF + + IF (PRESENT(IFIXX)) THEN + LDIFX = SIZE(IFIXX,1) + IF (ANY(SIZE(IFIXX).LE.(/0,0/))) THEN + LINFO1 = LINFO1 + 128 + END IF + IF (.NOT.(IFIXX(1,1).LT.ZERO.OR.LDIFX.EQ.1.OR.LDIFX.GE.N).OR. + & SIZE(IFIXX,2).LT.M) THEN + LINFO1 = LINFO1 + 128 + END IF + IF (LDIFX.GT.N) THEN + LDIFX = N + END IF + IF (IFIXX(1,1).LT.0.0_R8) THEN + LIFIXX(1,1) = IFIXX(1,1) + ELSE + LIFIXX(1:LDIFX,1:M) = IFIXX(1:LDIFX,1:M) + END IF + END IF + + IF (PRESENT(IWORK)) THEN + IF (ASSOCIATED(IWORK)) THEN + IF (SIZE(IWORK).LT.LENIWORK) THEN + LINFO1 = LINFO1 + 8192 + END IF + ! This is a restart, copy IWORK. + IF (MOD(LJOB/10000,10).GE.1) THEN + LIWORK(1:LENIWORK) = IWORK(1:LENIWORK) + END IF + END IF + END IF + + IF (PRESENT(MAXIT)) THEN + LMAXIT = MAXIT + END IF + + IF (PRESENT(NDIGIT)) THEN + LNDIGIT = NDIGIT + END IF + + IF (PRESENT(PARTOL)) THEN + LPARTOL = PARTOL + END IF + + IF (PRESENT(SCLB)) THEN + IF (SIZE(SCLB).LT.NP) THEN + LINFO1 = LINFO1 + 1024 + END IF + IF (SCLB(1).LE.0.0_R8) THEN + LSCLB(1) = SCLB(1) + ELSE + LSCLB(1:NP) = SCLB(1:NP) + END IF + END IF + + IF (PRESENT(SCLD)) THEN + LDSCLD = SIZE(SCLD,1) + IF (ANY(SIZE(SCLD).LE.(/0,0/))) THEN + LINFO1 = LINFO1 + 2048 + END IF + IF (.NOT.(SCLD(1,1).LE.ZERO.OR.LDSCLD.EQ.1.OR.LDSCLD.GE.N).OR. + & SIZE(SCLD,2).LT.M) THEN + LINFO1 = LINFO1 + 2048 + END IF + IF (LDSCLD.GT.N) THEN + LDSCLD = N + END IF + IF (SCLD(1,1).LE.0.0_R8) THEN + LSCLD(1,1) = SCLD(1,1) + ELSE + LSCLD(1:LDSCLD,1:M) = SCLD(1:LDSCLD,1:M) + END IF + END IF + + IF (PRESENT(SSTOL)) THEN + LSSTOL = SSTOL + END IF + + IF (PRESENT(STPB)) THEN + IF (SIZE(STPB).LT.NP) THEN + LINFO1 = LINFO1 + 256 + END IF + IF (STPB(1).LE.0.0_R8) THEN + LSTPB(1) = STPB(1) + ELSE + LSTPB(1:NP) = STPB(1:NP) + END IF + END IF + + IF (PRESENT(STPD)) THEN + LDSTPD = SIZE(STPD,1) + IF (ANY(SIZE(STPD).LE.(/0,0/))) THEN + LINFO1 = LINFO1 + 512 + END IF + IF (.NOT.(STPD(1,1).LE.ZERO.OR.LDSTPD.EQ.1.OR.LDSTPD.GE.N).OR. + & SIZE(STPD,2).LT.M) THEN + LINFO1 = LINFO1 + 512 + END IF + IF (LDSTPD.GT.N) THEN + LDSTPD = N + END IF + IF (STPD(1,1).LE.0.0_R8) THEN + LSTPD(1,1) = STPD(1,1) + ELSE + LSTPD(1:LDSTPD,1:M) = STPD(1:LDSTPD,1:M) + END IF + END IF + + IF (PRESENT(TAUFAC)) THEN + LTAUFAC = TAUFAC + END IF + + IF (PRESENT(WE)) THEN + LDWE = SIZE(WE,1) + LD2WE = SIZE(WE,2) + IF (ANY(SIZE(WE).LE.(/0,0,0/))) THEN + LINFO1 = LINFO1 + 16 + END IF + IF (.NOT.(WE(1,1,1).LT.ZERO.OR.((LDWE.EQ.1.OR.LDWE.GE.N) + & .AND.(LD2WE.EQ.1.OR.LD2WE.GE.NQ))).OR.SIZE(WE,3).LT.NQ) THEN + LINFO1 = LINFO1 + 16 + END IF + IF (LDWE.GT.N) THEN + LDWE = N + END IF + IF (LD2WE.GT.NQ) THEN + LD2WE = NQ + END IF + IF (WE(1,1,1).LT.0.0_R8) THEN + LWE(1,1,1) = WE(1,1,1) + ELSE + LWE(1:LDWE,1:LD2WE,1:NQ) = WE(1:LDWE,1:LD2WE,1:NQ) + END IF + END IF + + IF (PRESENT(WD)) THEN + LDWD = SIZE(WD,1) + LD2WD = SIZE(WD,2) + IF (ANY(SIZE(WD).LE.(/0,0,0/))) THEN + LINFO1 = LINFO1 + 32 + END IF + IF (.NOT.(WD(1,1,1).LT.ZERO.OR.((LDWD.EQ.1.OR.LDWD.GE.N) + & .AND.(LD2WD.EQ.1.OR.LD2WD.GE.M))).OR.SIZE(WD,3).LT.M) THEN + LINFO1 = LINFO1 + 32 + END IF + IF (LDWD.GT.N) THEN + LDWD = N + END IF + IF (LD2WD.GT.M) THEN + LD2WD = M + END IF + IF (WD(1,1,1).LE.0.0_R8) THEN + LWD(1,1,1) = WD(1,1,1) + ELSE + LWD(1:LDWD,1:LD2WD,1:M) = WD(1:LDWD,1:LD2WD,1:M) + END IF + END IF + + IF (PRESENT(WORK)) THEN + IF (ASSOCIATED(WORK)) THEN + IF (SIZE(WORK).LT.LENWORK) THEN + LINFO1 = LINFO1 + 4096 + END IF + ! Deltas are in WORK, copy them. + IF (MOD(LJOB/1000,10).GE.1.AND..NOT.PRESENT(DELTA)) THEN + LWORK(1:N*M) = WORK(1:N*M) + END IF + ! This is a restart, copy WORK. + IF (MOD(LJOB/10000,10).GE.1) THEN + LWORK(1:LENWORK) = WORK(1:LENWORK) + END IF + END IF + END IF + + IF (PRESENT(DELTA)) THEN + IF (ASSOCIATED(DELTA)) THEN + IF (ANY(SHAPE(DELTA).LT.(/N,M/))) THEN + LINFO1 = LINFO1 + 8 + END IF + LWORK(1:N*M) = RESHAPE(DELTA(1:N,1:M),(/N*M/)) + END IF + END IF + + IF (PRESENT(LOWER)) THEN + IF (SIZE(LOWER).LT.NP) THEN + LINFO1 = LINFO1 + 32768 + END IF + LLOWER(1:NP) = LOWER(1:NP) + END IF + + IF (PRESENT(UPPER)) THEN + IF (SIZE(UPPER).LT.NP) THEN + LINFO1 = LINFO1 + 16384 + END IF + LUPPER(1:NP) = UPPER(1:NP) + END IF + +C Report an error if any of the array sizes didn't match. + + IF (LINFO1.NE.0) THEN + LINFO = 100000 + LINFO1 + LINFO1 = 0 + IF (LLUNERR.GT.0.AND.LIPRINT.NE.0) THEN + CALL DODPHD(HEAD,LLUNRPT) + CALL DODPE1( + & LLUNERR,LINFO,LINFO5,LINFO4,LINFO3,LINFO2,LINFO1, + & N,M,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LENWORK,LENIWORK + & ) + END IF + IF (PRESENT(INFO)) THEN + INFO = LINFO + END IF + RETURN + END IF + + + IF (LWD(1,1,1).NE.ZERO) THEN + CALL DODCNT + & (FCN, + & N,M,NP,NQ, + & BETA(1:NP), + & Y(1:N,1:NQ),N,X(1:N,1:M),N, + & LWE(1:LDWE,1:LD2WE,1:NQ),LDWE,LD2WE, + & LWD(1:LDWD,1:LD2WD,1:M),LDWD,LD2WD, + & LIFIXB,LIFIXX(1:LDIFX,1:M),LDIFX, + & LJOB,LNDIGIT,LTAUFAC, + & LSSTOL,LPARTOL,LMAXIT, + & LIPRINT,LLUNERR,LLUNRPT, + & LSTPB,LSTPD(1:LDSTPD,1:M),LDSTPD, + & LSCLB,LSCLD(1:LDSCLD,1:M),LDSCLD, + & LWORK,LENWORK,LIWORK,LENIWORK, + & LINFO, + & LLOWER,LUPPER) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + & (FCN, + & N,M,NP,NQ, + & BETA(1:NP), + & Y(1:N,1:NQ),N,X(1:N,1:M),N, + & LWE(1:LDWE,1:LD2WE,1:NQ),LDWE,LD2WE, + & WD1,1,1, + & LIFIXB,LIFIXX(1:LDIFX,1:M),LDIFX, + & LJOB,LNDIGIT,LTAUFAC, + & LSSTOL,LPARTOL,LMAXIT, + & LIPRINT,LLUNERR,LLUNRPT, + & LSTPB,LSTPD(1:LDSTPD,1:M),LDSTPD, + & LSCLB,LSCLD(1:LDSCLD,1:M),LDSCLD, + & LWORK,LENWORK,LIWORK,LENIWORK, + & LINFO, + & LLOWER,LUPPER) + END IF + + IF (PRESENT(DELTA)) THEN + IF (ASSOCIATED(DELTA)) THEN + DELTA(1:N,1:M) = RESHAPE(LWORK(1:N*M),(/N,M/)) + ELSE + LDELTA(1:N,1:M) = RESHAPE(LWORK(1:N*M),(/N,M/)) + DELTA => LDELTA + END IF + END IF + + IF (PRESENT(INFO)) THEN + INFO = LINFO + END IF + + IF (PRESENT(IWORK)) THEN + IF (.NOT.ASSOCIATED(IWORK)) THEN + IWORK => LIWORK + ELSE + IWORK(1:LENIWORK) = LIWORK(1:LENIWORK) + DEALLOCATE(LIWORK) + END IF + ELSE + DEALLOCATE(LIWORK) + END IF + + IF (PRESENT(WORK)) THEN + IF (.NOT.ASSOCIATED(WORK)) THEN + WORK => LWORK + ELSE + WORK(1:LENWORK) = LWORK(1:LENWORK) + DEALLOCATE(LWORK) + END IF + ELSE + DEALLOCATE(LWORK) + END IF + + DEALLOCATE(TEMPRET) + + RETURN + + END SUBROUTINE ODR + END MODULE ODRPACK95 +*DACCES + SUBROUTINE DACCES + & (N,M,NP,NQ,LDWE,LD2WE, + & WORK,LWORK,IWORK,LIWORK, + & ACCESS,ISODR, + & JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + & NNZW,NPP, + & JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + & LUNRPT,IPR1,IPR2,IPR2F,IPR3, + & WSS,RVAR,IDF, + & TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + & RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) +C***Begin Prologue DACCES +C***Refer to ODR +C***Routines Called DIWINF,DWINF +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Access or store values in the work arrays +C***End Prologue DACESS + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + & RNORMS,RVAR,SSTOL,TAU,TAUFAC + INTEGER + & IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, + & LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, + & NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + & ACCESS,ISODR + +C...Array arguments + REAL (KIND=R8) + & WORK(LWORK),WSS(3) + INTEGER + & IWORK(LIWORK) + +C...Local scalars + INTEGER + & ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,BOUNDI, + & DELTAI,DELTNI,DELTSI,DIFFI,EPSI, + & EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + & IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LOWERI,LUNERI,LUNRPI,LWKMN, + & MAXITI, + & MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, + & NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + & RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + & UPPERI, + & VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + & WSSI,WSSDEI,WSSEPI,XPLUSI +C...External subroutines + EXTERNAL + & DIWINF,DWINF + +C...Variable Definitions (alphabetically) +C ACCESS: The variable designating whether information is to be +C accessed from the work arrays (ACCESS=TRUE) or stored in +C them (ACCESS=FALSE). +C ACTRS: The saved actual relative reduction in the sum-of-squares. +C ACTRSI: The location in array WORK of variable ACTRS. +C ALPHA: The Levenberg-Marquardt parameter. +C ALPHAI: The location in array WORK of variable ALPHA. +C BETACI: The starting location in array WORK of array BETAC. +C BETANI: The starting location in array WORK of array BETAN. +C BETASI: The starting location in array WORK of array BETAS. +C BETA0I: The starting location in array WORK of array BETA0. +C DELTAI: The starting location in array WORK of array DELTA. +C DELTNI: The starting location in array WORK of array DELTAN. +C DELTSI: The starting location in array WORK of array DELTAS. +C DIFFI: The starting location in array WORK of array DIFF. +C EPSI: The starting location in array WORK of array EPS. +C EPSMAI: The location in array WORK of variable EPSMAC. +C ETA: The relative noise in the function results. +C ETAI: The location in array WORK of variable ETA. +C FJACBI: The starting location in array WORK of array FJACB. +C FJACDI: The starting location in array WORK of array FJACD. +C FNI: The starting location in array WORK of array FN. +C FSI: The starting location in array WORK of array FS. +C IDF: The degrees of freedom of the fit, equal to the number of +C observations with nonzero weighted derivatives minus the +C number of parameters being estimated. +C IDFI: The starting location in array IWORK of variable IDF. +C INT2: The number of internal doubling steps. +C INT2I: The location in array IWORK of variable INT2. +C IPR1: The value of the fourth digit (from the right) of IPRINT, +C which controls the initial summary report. +C IPR2: The value of the third digit (from the right) of IPRINT, +C which controls the iteration reports. +C IPR2F: The value of the second digit (from the right) of IPRINT, +C which controls the frequency of the iteration reports. +C IPR3: The value of the first digit (from the right) of IPRINT, +C which controls the final summary report. +C IPRINI: The location in array IWORK of variable IPRINT. +C IPRINT: The print control variable. +C IRANK: The rank deficiency of the Jacobian wrt BETA. +C IRANKI: The location in array IWORK of variable IRANK. +C ISODR: The variable designating whether the solution is to be +C found by ODR (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C ISTOPI: The location in array IWORK of variable ISTOP. +C IWORK: The integer work space. +C JOB: The variable controling problem initialization and +C computational method. +C JOBI: The location in array IWORK of variable JOB. +C JPVT: The pivot vector. +C JPVTI: The starting location in array IWORK of variable JPVT. +C LDTTI: The starting location in array IWORK of variable LDTT. +C LDWE: The leading dimension of array WE. +C LD2WE: The second dimension of array WE. +C LIWORK: The length of vector IWORK. +C LUNERI: The location in array IWORK of variable LUNERR. +C LUNERR: The logical unit number used for error messages. +C LUNRPI: The location in array IWORK of variable LUNRPT. +C LUNRPT: The logical unit number used for computation reports. +C LWKMN: The minimum acceptable length of array WORK. +C LWORK: The length of vector WORK. +C M: The number of columns of data in the explanatory variable. +C MAXIT: The maximum number of iterations allowed. +C MAXITI: The location in array IWORK of variable MAXIT. +C MSGB: The starting location in array IWORK of array MSGB. +C MSGD: The starting location in array IWORK of array MSGD. +C N: The number of observations. +C NETA: The number of accurate digits in the function results. +C NETAI: The location in array IWORK of variable NETA. +C NFEV: The number of function evaluations. +C NFEVI: The location in array IWORK of variable NFEV. +C NITER: The number of iterations taken. +C NITERI: The location in array IWORK of variable NITER. +C NJEV: The number of Jacobian evaluations. +C NJEVI: The location in array IWORK of variable NJEV. +C NNZW: The number of nonzero weighted observations. +C NNZWI: The location in array IWORK of variable NNZW. +C NP: The number of function parameters. +C NPP: The number of function parameters actually estimated. +C NPPI: The location in array IWORK of variable NPP. +C NQ: The number of responses per observation. +C NROWI: The location in array IWORK of variable NROW. +C NTOLI: The location in array IWORK of variable NTOL. +C OLMAVG: The average number of Levenberg-Marquardt steps per +C iteration. +C OLMAVI: The location in array WORK of variable OLMAVG. +C OMEGA: The starting location in array WORK of array OMEGA. +C OMEGAI: The starting location in array WORK of array OMEGA. +C PARTLI: The location in array work of variable PARTOL. +C PARTOL: The parameter convergence stopping tolerance. +C PNORM: The norm of the scaled estimated parameters. +C PNORMI: The location in array WORK of variable PNORM. +C PRERS: The saved predicted relative reduction in the +C sum-of-squares. +C PRERSI: The location in array WORK of variable PRERS. +C QRAUX: The starting location in array WORK of array QRAUX. +C QRAUXI: The starting location in array WORK of array QRAUX. +C RCOND: The approximate reciprocal condition of FJACB. +C RCONDI: The location in array WORK of variable RCOND. +C RESTRT: The variable designating whether the call is a restart +C (RESTRT=TRUE) or not (RESTRT=FALSE). +C RNORMS: The norm of the saved weighted EPSILONS and DELTAS. +C RNORSI: The location in array WORK of variable RNORMS. +C RVAR: The residual variance, i.e. standard deviation squared. +C RVARI: The location in array WORK of variable RVAR. +C SCLB: The scaling values used for BETA. +C SCLD: The scaling values used for DELTA. +C SD: The starting location in array WORK of array SD. +C SDI: The starting location in array WORK of array SD. +C SI: The starting location in array WORK of array S. +C SSFI: The starting location in array WORK of array SSF. +C SSI: The starting location in array WORK of array SS. +C SSTOL: The sum-of-squares convergence stopping tolerance. +C SSTOLI: The location in array WORK of variable SSTOL. +C TAU: The trust region diameter. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C TAUFCI: The location in array WORK of variable TAUFAC. +C TAUI: the location in array WORK of variable TAU. +C TI: The starting location in array WORK of array T. +C TTI: The starting location in array WORK of array TT. +C U: The starting location in array WORK of array U. +C UI: The starting location in array WORK of array U. +C VCV: The starting location in array WORK of array VCV. +C VCVI: The starting location in array WORK of array VCV. +C WE1I: The starting location in array WORK of array WE1. +C WORK: The REAL (KIND=R8) work space. +C WRK1: The starting location in array WORK of array WRK1. +C WRK1I: The starting location in array WORK of array WRK1. +C WRK2: The starting location in array WORK of array WRK2. +C WRK2I: The starting location in array WORK of array WRK2. +C WRK3: The starting location in array WORK of array wrk3. +C WRK3I: The starting location in array WORK of array wrk3. +C WRK4: The starting location in array WORK of array wrk4. +C WRK4I: The starting location in array WORK of array wrk4. +C WRK5: The starting location in array WORK of array wrk5. +C WRK5I: The starting location in array WORK of array wrk5. +C WRK6: The starting location in array WORK of array wrk6. +C WRK6I: The starting location in array WORK of array wrk6. +C WRK7I: The starting location in array WORK of array wrk7. +C WSS: The sum of the squares of the weighted EPSILONS and DELTAS, +C the sum of the squares of the weighted DELTAS, and +C the sum of the squares of the weighted EPSILONS. +C WSSI: The starting location in array WORK of variable WSS(1). +C WSSDEI: The starting location in array WORK of variable WSS(2). +C WSSEPI: The starting location in array WORK of variable WSS(3). +C XPLUSI: The starting location in array WORK of array XPLUSD. + + +C***First executable statement DACCES + + +C Find starting locations within integer workspace + + CALL DIWINF(M,NP,NQ, + & MSGB,MSGD,JPVTI,ISTOPI, + & NNZWI,NPPI,IDFI, + & JOBI,IPRINI,LUNERI,LUNRPI, + & NROWI,NTOLI,NETAI, + & MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + & BOUNDI, + & LIWKMN) + +C Find starting locations within REAL (KIND=R8) work space + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + & DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + & RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + & OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + & PARTLI,SSTOLI,TAUFCI,EPSMAI, + & BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + & FSI,FJACBI,WE1I,DIFFI, + & DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + & WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + & LOWERI,UPPERI, + & LWKMN) + + IF (ACCESS) THEN + +C Set starting locations for work vectors + + JPVT = JPVTI + OMEGA = OMEGAI + QRAUX = QRAUXI + SD = SDI + VCV = VCVI + U = UI + WRK1 = WRK1I + WRK2 = WRK2I + WRK3 = WRK3I + WRK4 = WRK4I + WRK5 = WRK5I + WRK6 = WRK6I + +C Access values from the work vectors + + ACTRS = WORK(ACTRSI) + ALPHA = WORK(ALPHAI) + ETA = WORK(ETAI) + OLMAVG = WORK(OLMAVI) + PARTOL = WORK(PARTLI) + PNORM = WORK(PNORMI) + PRERS = WORK(PRERSI) + RCOND = WORK(RCONDI) + WSS(1) = WORK(WSSI) + WSS(2) = WORK(WSSDEI) + WSS(3) = WORK(WSSEPI) + RVAR = WORK(RVARI) + RNORMS = WORK(RNORSI) + SSTOL = WORK(SSTOLI) + TAU = WORK(TAUI) + TAUFAC = WORK(TAUFCI) + + NETA = IWORK(NETAI) + IRANK = IWORK(IRANKI) + JOB = IWORK(JOBI) + LUNRPT = IWORK(LUNRPI) + MAXIT = IWORK(MAXITI) + NFEV = IWORK(NFEVI) + NITER = IWORK(NITERI) + NJEV = IWORK(NJEVI) + NNZW = IWORK(NNZWI) + NPP = IWORK(NPPI) + IDF = IWORK(IDFI) + INT2 = IWORK(INT2I) + +C Set up print control variables + + IPRINT = IWORK(IPRINI) + + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + + ELSE + +C Store values into the work vectors + + WORK(ACTRSI) = ACTRS + WORK(ALPHAI) = ALPHA + WORK(OLMAVI) = OLMAVG + WORK(PARTLI) = PARTOL + WORK(PNORMI) = PNORM + WORK(PRERSI) = PRERS + WORK(RCONDI) = RCOND + WORK(WSSI) = WSS(1) + WORK(WSSDEI) = WSS(2) + WORK(WSSEPI) = WSS(3) + WORK(RVARI) = RVAR + WORK(RNORSI) = RNORMS + WORK(SSTOLI) = SSTOL + WORK(TAUI) = TAU + + IWORK(IRANKI) = IRANK + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NITERI) = NITER + IWORK(NJEVI) = NJEV + IWORK(IDFI) = IDF + IWORK(INT2I) = INT2 + END IF + + RETURN + END SUBROUTINE +*DESUBI + SUBROUTINE DESUBI + & (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) +C***Begin Prologue DESUBI +C***Refer to ODR +C***Routines Called DZERO +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Compute E = WD + ALPHA*TT**2 +C***End Prologue DESUBI + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & ALPHA + INTEGER + & LDTT,LDWD,LD2WD,M,N + +C...Array arguments + REAL (KIND=R8) + & E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) + +C...Local scalars + REAL (KIND=R8) + & ZERO + INTEGER + & I,J,J1,J2 + +C...External subroutines + EXTERNAL + & DZERO + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C ALPHA: The Levenberg-Marquardt parameter. +C E: The value of the array E = WD + ALPHA*TT**2 +C I: An indexing variable. +C J: An indexing variable. +C J1: An indexing variable. +C J2: An indexing variable. +C LDWD: The leading dimension of array WD. +C LD2WD: The second dimension of array WD. +C M: The number of columns of data in the independent variable. +C N: The number of observations. +C NP: The number of responses per observation. +C TT: The scaling values used for DELTA. +C WD: The squared DELTA weights, D**2. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DESUBI + + +C N.B. the locations of WD and TT accessed depend on the value +C of the first element of each array and the leading dimensions +C of the multiply subscripted arrays. + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WD(1,1,1).GE.ZERO) THEN + IF (LDWD.GE.N) THEN +C The elements of WD have been individually specified + + IF (LD2WD.EQ.1) THEN +C The arrays stored in WD are diagonal + CALL DZERO(M,M,E,M) + DO 10 J=1,M + E(J,J) = WD(I,1,J) + 10 CONTINUE + ELSE +C The arrays stored in WD are full positive semidefinite matrices + DO 30 J1=1,M + DO 20 J2=1,M + E(J1,J2) = WD(I,J1,J2) + 20 CONTINUE + 30 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 110 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 110 CONTINUE + ELSE + DO 120 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 120 CONTINUE + END IF + ELSE + DO 130 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 130 CONTINUE + END IF + ELSE +C WD is an M by M matrix + + IF (LD2WD.EQ.1) THEN +C The array stored in WD is diagonal + CALL DZERO(M,M,E,M) + DO 140 J=1,M + E(J,J) = WD(1,1,J) + 140 CONTINUE + ELSE +C The array stored in WD is a full positive semidefinite matrices + DO 160 J1=1,M + DO 150 J2=1,M + E(J1,J2) = WD(1,J1,J2) + 150 CONTINUE + 160 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 210 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 210 CONTINUE + ELSE + DO 220 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 220 CONTINUE + END IF + ELSE + DO 230 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 230 CONTINUE + END IF + END IF + ELSE +C WD is a diagonal matrix with elements ABS(WD(1,1,1)) + CALL DZERO(M,M,E,M) + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 310 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 + 310 CONTINUE + ELSE + DO 320 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 + 320 CONTINUE + END IF + ELSE + DO 330 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 + 330 CONTINUE + END IF + END IF + + RETURN + END SUBROUTINE +*DETAF + SUBROUTINE DETAF + & (FCN, + & N,M,NP,NQ, + & XPLUSD,BETA,EPSMAC,NROW, + & PARTMP,PV0, + & IFIXB,IFIXX,LDIFX, + & ISTOP,NFEV,ETA,NETA, + & WRK1,WRK2,WRK6,WRK7, + & INFO, + & LOWER,UPPER) +C***Begin Prologue DETAF +C***Refer to ODR +C***Routines Called FCN +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute noise and number of good digits in function results +C (Adapted from STARPAC subroutine ETAFUN) +C***End Prologue DETAF + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & EPSMAC,ETA + INTEGER + & INFO,ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),LOWER(NP),PARTMP(NP),PV0(N,NQ),UPPER(NP), + & WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & A,B,FAC,HUNDRD,ONE,P1,P2,P5,SHIFT,STP,TWO,ZERO + INTEGER + & J,K,L,SBK + +C...Local arrays + REAL (KIND=R8) + & PARPTS(-2:2,NP) + +C...Data statements + DATA + & ZERO,P1,P2,P5,ONE,TWO,HUNDRD + & /0.0E0_R8,0.1E0_R8,0.2E0_R8,0.5E0_R8,1.0E0_R8,2.0E0_R8, + & 1.0E2_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (ALPHABETICALLY) +C A: Parameters of the local fit. +C B: Parameters of the local fit. +C BETA: The function parameters. +C EPSMAC: The value of machine precision. +C ETA: The noise in the model results. +C FAC: A factor used in the computations. +C HUNDRD: The value 1.0E2_R8. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C ISTOP: The variable designating whether there are problems +C Computing the function at the current BETA and DELTA. +C J: An index variable. +C K: An index variable. +C L: AN INDEX VARIABLE. +C LDIFX: The leading dimension of array IFIXX. +C LOWER: The lower bound of BETA. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NETA: The number of accurate digits in the model results. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number at which the derivative is to be checked. +C ONE: The value 1.0E0_R8. +C P1: The value 0.1E0_R8. +C P2: The value 0.2E0_R8. +C P5: The value 0.5E0_R8. +C PARPTS: The points that PARTMP will take on during FCN evaluations. +C PARTMP: The model parameters. +C PV0: The original predicted values. +C SHIFT: When PARPTS cross the parameter bounds they are shifted by SHIFT. +C SBK: The sign of BETA(K). +C STP: A small value used to perturb the parameters. +C UPPER: The upper bound of BETA. +C WRK1: A work array of (N BY M BY NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C WRK7: A work array of (5 BY NQ) elements. +C XPLUSD: The values of X + DELTA. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DETAF + + + STP = HUNDRD*EPSMAC + ETA = EPSMAC + +C Create points to use in calculating FCN for ETA and NETA. + DO J=-2,2 + IF (J.EQ.0) THEN + PARPTS(0,:) = BETA(:) + ELSE + DO K=1,NP + IF (IFIXB(1).LT.0) THEN + PARPTS(J,K) = BETA(K) + J*STP*BETA(K) + ELSE IF (IFIXB(K).NE.0) THEN + PARPTS(J,K) = BETA(K) + J*STP*BETA(K) + ELSE + PARPTS(J,K) = BETA(K) + END IF + END DO + END IF + END DO + +C Adjust the points used in calculating FCN to uphold the boundary +C constraints. + DO K=1,NP + SBK = SIGN(ONE,PARPTS(2,K)-PARPTS(-2,K)) + IF (PARPTS(SBK*2,K).GT.UPPER(K)) THEN + SHIFT = UPPER(K) - PARPTS(SBK*2,K) + PARPTS(SBK*2,K) = UPPER(K) + DO J=-SBK*2,SBK*1,SBK + PARPTS(J,K) = PARPTS(J,K) + SHIFT + END DO + IF (PARPTS(-SBK*2,K).LT.LOWER(K)) THEN + INFO = 90010 + RETURN + END IF + END IF + IF (PARPTS(-SBK*2,K).LT.LOWER(K)) THEN + SHIFT = LOWER(K) - PARPTS(-SBK*2,K) + PARPTS(-SBK*2,K) = LOWER(K) + DO J=-SBK*1,SBK*2,SBK + PARPTS(J,K) = PARPTS(J,K) + SHIFT + END DO + IF (PARPTS(SBK*2,K).GT.UPPER(K)) THEN + INFO = 90010 + RETURN + END IF + END IF + END DO + +C Evaluate FCN for all points in PARPTS. + DO J=-2,2 + IF (ALL(PARPTS(J,:).EQ.BETA(:))) THEN + DO L=1,NQ + WRK7(J,L) = PV0(NROW,L) + END DO + ELSE + PARTMP(:) = PARPTS(J,:) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & PARTMP(:),XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 003,WRK2,WRK6,WRK1,ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO L=1,NQ + WRK7(J,L) = WRK2(NROW,L) + END DO + END IF + END DO + +C Calculate ETA and NETA. + DO 100 L=1,NQ + A = ZERO + B = ZERO + DO 50 J=-2,2 + A = A + WRK7(J,L) + B = B + J*WRK7(J,L) + 50 CONTINUE + A = P2*A + B = P1*B + IF ((WRK7(0,L).NE.ZERO) .AND. + & (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN + FAC = ONE/ABS(WRK7(0,L)) + ELSE + FAC = ONE + END IF + DO 60 J=-2,2 + WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) + ETA = MAX(WRK7(J,L),ETA) + 60 CONTINUE + 100 CONTINUE + NETA = MAX(TWO,P5-LOG10(ETA)) + + RETURN + END SUBROUTINE +*DEVJAC + SUBROUTINE DEVJAC + & (FCN, + & ANAJAC,CDJAC, + & N,M,NP,NQ, + & BETAC,BETA,STPB, + & IFIXB,IFIXX,LDIFX, + & X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + & SSF,TT,LDTT,NETA,FN, + & STP,WRK1,WRK2,WRK3,WRK6, + & FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + & NJEV,NFEV,ISTOP,INFO, + & LOWER,UPPER) +C***Begin Prologue DEVJAC +C***Refer to ODR +C***Routines Called FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Compute the weighted Jacobians wrt BETA and DELTA +C***End Prologue DEVJAC + +C...Used modules + USE REAL_PRECISION + USE ODRPACK95, ONLY : TEMPRET + +C...Scalar arguments + INTEGER + & INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, + & M,N,NETA,NFEV,NJEV,NP,NQ + LOGICAL + & ANAJAC,CDJAC,ISODR + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + & FN(N,NQ),LOWER(NP),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M), + & TT(LDTT,M),UPPER(NP), + & WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), + & WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + INTEGER + & IDEVAL,J,K,K1,L + REAL (KIND=R8) + & ZERO + LOGICAL + & ERROR + +C...External subroutines + EXTERNAL + & DIFIX,DJACCD,DJACFD,DUNPAC,DXPY + +C...External functions + REAL (KIND=R8) + & DDOT + EXTERNAL + & DDOT + +C...Data statements + DATA ZERO + & /0.0E0_R8/ + +C...Interface blocks + INTERFACE + SUBROUTINE DWGHT + & (N,M,WT,LDWT,LD2WT,T,WTT) + USE REAL_PRECISION + INTEGER + & LDWT,LD2WT,M,N + REAL (KIND=R8) + & T(:,:),WT(:,:,:),WTT(:,:) + END SUBROUTINE + END INTERFACE + +C...Routine names used as subprogram arguments +C FCN: The user-supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C ANAJAC: The variable designating whether the Jacobians are +C computed by finite differences (ANAJAC=FALSE) or not +C (ANAJAC=TRUE). +C BETA: The function parameters. +C BETAC: The current estimated values of the unfixed BETA's. +C CDJAC: The variable designating whether the Jacobians are +C computed by central differences (CDJAC=TRUE) or by forward +C differences (CDJAC=FALSE). +C DELTA: The estimated values of DELTA. +C ERROR: The variable designating whether ODRPACK95 detected nonzero +C values in array DELTA in the OLS case, and thus whether +C the user may have overwritten important information +C by computing FJACD in the OLS case. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FN: The predicted values of the function at the current point. +C IDEVAL: The variable designating what computations are to be +C performed by user-supplied subroutine FCN. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of DELTA are +C fixed at their input values or not. +C INFO: The variable designating why the computations were stopped. +C ISTOP: The variable designating that the user wishes the +C computations stopped. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or OLS (ISODR=FALSE). +C J: An indexing variable. +C K: An indexing variable. +C K1: An indexing variable. +C L: An indexing variable. +C LDIFX: The leading dimension of array IFIXX. +C LDSTPD: The leading dimension of array STPD. +C LDTT: The leading dimension of array TT. +C LDWE: The leading dimension of arrays WE and WE1. +C LDX: The leading dimension of array X. +C LD2WE: The second dimension of arrays WE and WE1. +C M: The number of columns of data in the independent variable. +C N: The number of observations. +C NETA: The number of accurate digits in the function results. +C NFEV: The number of function evaluations. +C NJEV: The number of Jacobian evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C SSF: The scale used for the BETA's. +C STP: The step used for computing finite difference +C derivatives with respect to DELTA. +C STPB: The relative step used for computing finite difference +C derivatives with respect to BETA. +C STPD: The relative step used for computing finite difference +C derivatives with respect to DELTA. +C TT: The scaling values used for DELTA. +C WE1: The square roots of the EPSILON weights in array WE. +C WRK1: A work array of (N by M by NQ) elements. +C WRK2: A work array of (N by NQ) elements. +C WRK3: A work array of (NP) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C X: The independent variable. +C XPLUSD: The values of X + DELTA. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DEVJAC + + +C Insert current unfixed BETA estimates into BETA + + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + +C Compute XPLUSD = X + DELTA + + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C Compute the Jacobian wrt the estimated BETAS (FJACB) and +C the Jacobian wrt DELTA (FJACD) + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + IF (ANAJAC) THEN + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & IDEVAL,WRK2,FJACB,FJACD, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV+1 + END IF +C Make sure fixed elements of FJACD are zero + IF (ISODR) THEN + DO 10 L=1,NQ + CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) + 10 CONTINUE + END IF + ELSE IF (CDJAC) THEN + CALL DJACCD(FCN, + & N,M,NP,NQ, + & BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + & STPB,STPD,LDSTPD, + & SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + & FJACB,ISODR,FJACD,NFEV,ISTOP,INFO, + & LOWER,UPPER) + ELSE + CALL DJACFD(FCN, + & N,M,NP,NQ, + & BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + & STPB,STPD,LDSTPD, + & SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + & FJACB,ISODR,FJACD,NFEV,ISTOP,INFO, + & LOWER,UPPER) + END IF + IF (ISTOP.LT.0.OR.INFO.GE.10000) THEN + RETURN + ELSE IF (.NOT.ISODR) THEN +C Try to detect whether the user has computed JFACD +C Within FCN in the OLS case + ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO + IF (ERROR) THEN + INFO = 50300 + RETURN + END IF + END IF + +C Weight the Jacobian wrt the estimated BETAS + + IF (IFIXB(1).LT.0) THEN + DO 20 K=1,NP + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + & FJACB(1:N,K,1:NQ),TEMPRET(1:N,1:NQ)) + FJACB(1:N,K,1:NQ) = TEMPRET(1:N,1:NQ) + 20 CONTINUE + ELSE + K1 = 0 + DO 30 K=1,NP + IF (IFIXB(K).GE.1) THEN + K1 = K1 + 1 + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + & FJACB(1:N,K,1:NQ),TEMPRET(1:N,1:NQ)) + FJACB(1:N,K1,1:NQ) = TEMPRET(1:N,1:NQ) + END IF + 30 CONTINUE + END IF + +C Weight the Jacobian's wrt DELTA as appropriate + + IF (ISODR) THEN + DO 40 J=1,M + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + & FJACD(1:N,J,1:NQ),TEMPRET(1:N,1:NQ)) + FJACD(1:N,J,1:NQ) = TEMPRET(1:N,1:NQ) + 40 CONTINUE + END IF + + RETURN + END SUBROUTINE +*DFCTR + SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) +C***Begin Prologue DFCTR +C***Refer to ODR +C***Routines Called DDOT +C***Date Written 910706 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Factor the positive (semi)definite matrix A using a +C modified Cholesky factorization +C (adapted from LINPACK subroutine DPOFA) +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***End PROLOGUE DFCTR + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER INFO,LDA,N + LOGICAL OKSEMI + +C...Array arguments + REAL (KIND=R8) A(LDA,N) + +C...Local scalars + REAL (KIND=R8) XI,S,T,TEN,ZERO + INTEGER J,K + +C...External functions + EXTERNAL DDOT + REAL (KIND=R8) DDOT + + DATA + & ZERO,TEN + & /0.0E0_R8,10.0E0_R8/ + +C...Variable Definitions (alphabetically) +C A: The array to be factored. Upon return, A contains the +C upper triangular matrix R so that A = trans(R)*R +C where the strict lower triangle is set to zero +C if INFO .NE. 0 , the factorization is not complete. +C I: An indexing variable. +C INFO: An idicator variable, where if +C INFO = 0 then factorization was completed +C INFO = K signals an error condition. The leading minor +C of order K is not positive (semi)definite. +C J: An indexing variable. +C LDA: The leading dimension of array A. +C N: The number of rows and columns of data in array A. +C OKSEMI: The indicating whether the factored array can be positive +C semidefinite (OKSEMI=TRUE) or whether it must be found to +C be positive definite (OKSEMI=FALSE). +C TEN: The value 10.0E0_R8. +C XI: A value used to test for non positive semidefiniteness. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DFCTR + + +C Set relative tolerance for detecting non positive semidefiniteness. + XI = -TEN*EPSILON(ZERO) + +C Compute factorization, storing in upper triangular portion of A + DO 20 J=1,N + INFO = J + S = ZERO + DO 10 K=1,J-1 + IF (A(K,K).EQ.ZERO) THEN + T = ZERO + ELSE + T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) + T = T/A(K,K) + END IF + A(K,J) = T + S = S + T*T + 10 CONTINUE + S = A(J,J) - S +C ......Exit + IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN + RETURN + ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN + RETURN + ELSE IF (S.LE.ZERO) THEN + A(J,J) = ZERO + ELSE + A(J,J) = SQRT(S) + END IF + 20 CONTINUE + INFO = 0 + +C Zero out lower portion of A + DO 40 J=2,N + DO 30 K=1,J-1 + A(J,K) = ZERO + 30 CONTINUE + 40 CONTINUE + + RETURN + END SUBROUTINE +*DFCTRW + SUBROUTINE DFCTRW + & (N,M,NQ,NPP, + & ISODR, + & WE,LDWE,LD2WE,WD,LDWD,LD2WD, + & WRK0,WRK4, + & WE1,NNZW,INFO) +C***Begin Prologue DFCTRW +C***Refer to ODR +C***Routines Called DFCTR +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Check input parameters, indicating errors found using +C nonzero values of argument INFO as described in the +C ODRPACK95 reference guide +C***End Prologue DFCTRW + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INFO,LDWD,LDWE,LD2WD,LD2WE, + & M,N,NNZW,NPP,NQ + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), + & WRK0(NQ,NQ),WRK4(M,M) + +C...Local scalars + REAL (KIND=R8) + & ZERO + INTEGER + & I,INF,J,J1,J2,L,L1,L2 + LOGICAL + & NOTZRO + +C...External subroutines + EXTERNAL + & DFCTR + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C I: An indexing variable. +C INFO: The variable designating why the computations were stopped. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C J: An indexing variable. +C J1: An indexing variable. +C J2: An indexing variable. +C L: An indexing variable. +C L1: An indexing variable. +C L2: An indexing variable. +C LAST: The last row of the array to be accessed. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NNZW: The number of nonzero weighted observations. +C NOTZRO: The variable designating whether a given component of the +C weight array WE contains a nonzero element (NOTZRO=FALSE) +C or not (NOTZRO=TRUE). +C NPP: The number of function parameters being estimated. +C NQ: The number of responses per observations. +C WE: The (squared) EPSILON weights. +C WE1: The factored EPSILON weights, S.T. trans(WE1)*WE1 = WE. +C WD: The (squared) DELTA weights. +C WRK0: A work array of (NQ BY NQ) elements. +C WRK4: A work array of (M BY M) elements. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DFCTRW + + +C Check EPSILON weights, and store factorization in WE1 + + IF (WE(1,1,1).LT.ZERO) THEN +C WE contains a scalar + WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) + NNZW = N + + ELSE + NNZW = 0 + + IF (LDWE.EQ.1) THEN + + IF (LD2WE.EQ.1) THEN +C WE contains a diagonal matrix + DO 110 L=1,NQ + IF (WE(1,1,L).GT.ZERO) THEN + NNZW = N + WE1(1,1,L) = SQRT(WE(1,1,L)) + ELSE IF (WE(1,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 110 CONTINUE + ELSE + +C WE contains a full NQ by NQ semidefinite matrix + DO 130 L1=1,NQ + DO 120 L2=L1,NQ + WRK0(L1,L2) = WE(1,L1,L2) + 120 CONTINUE + 130 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + DO 150 L1=1,NQ + DO 140 L2=1,NQ + WE1(1,L1,L2) = WRK0(L1,L2) + 140 CONTINUE + IF (WE1(1,L1,L1).NE.ZERO) THEN + NNZW = N + END IF + 150 CONTINUE + END IF + END IF + + ELSE + + IF (LD2WE.EQ.1) THEN +C WE contains an array of diagonal matrix + DO 220 I=1,N + NOTZRO = .FALSE. + DO 210 L=1,NQ + IF (WE(I,1,L).GT.ZERO) THEN + NOTZRO = .TRUE. + WE1(I,1,L) = SQRT(WE(I,1,L)) + ELSE IF (WE(I,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 210 CONTINUE + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 220 CONTINUE + ELSE + +C WE contains an array of full NQ by NQ semidefinite matrices + DO 270 I=1,N + DO 240 L1=1,NQ + DO 230 L2=L1,NQ + WRK0(L1,L2) = WE(I,L1,L2) + 230 CONTINUE + 240 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + NOTZRO = .FALSE. + DO 260 L1=1,NQ + DO 250 L2=1,NQ + WE1(I,L1,L2) = WRK0(L1,L2) + 250 CONTINUE + IF (WE1(I,L1,L1).NE.ZERO) THEN + NOTZRO = .TRUE. + END IF + 260 CONTINUE + END IF + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 270 CONTINUE + END IF + END IF + END IF + +C Check for a sufficient number of nonzero EPSILON weights + + IF (NNZW.LT.NPP) THEN + INFO = 30020 + END IF + + +C Check DELTA weights + + 300 CONTINUE + IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN +C Problem is not ODR, or WD contains a scalar + RETURN + + ELSE + + IF (LDWD.EQ.1) THEN + + IF (LD2WD.EQ.1) THEN +C WD contains a diagonal matrix + DO 310 J=1,M + IF (WD(1,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 310 CONTINUE + ELSE + +C WD contains a full M by M positive definite matrix + DO 330 J1=1,M + DO 320 J2=J1,M + WRK4(J1,J2) = WD(1,J1,J2) + 320 CONTINUE + 330 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + END IF + + ELSE + + IF (LD2WD.EQ.1) THEN +C WD contains an array of diagonal matrices + DO 420 I=1,N + DO 410 J=1,M + IF (WD(I,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 410 CONTINUE + 420 CONTINUE + ELSE + +C WD contains an array of full M by M positive definite matrices + DO 470 I=1,N + DO 440 J1=1,M + DO 430 J2=J1,M + WRK4(J1,J2) = WD(I,J1,J2) + 430 CONTINUE + 440 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 470 CONTINUE + END IF + END IF + END IF + + RETURN + END SUBROUTINE +*DFLAGS + SUBROUTINE DFLAGS + & (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) +C***Begin Prologue DFLAGS +C***Refer to ODR +C***Routines Called (None) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Set flags indicating conditions specified by JOB +C***End Prologue DFLAGS + +C...Scalar arguments + INTEGER + & JOB + LOGICAL + & ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...Local scalars + INTEGER + & J + +C...Variable Definitions (alphabetically) +C ANAJAC: The variable designating whether the Jacobians are computed +C by finite differences (ANAJAC=FALSE) or not (ANAJAC=TRUE). +C CDJAC: The variable designating whether the Jacobians are computed +C by central differences (CDJAC=TRUE) or by forward +C differences (CDJAC=FALSE). +C CHKJAC: The variable designating whether the user-supplied +c Jacobians are to be checked (CHKJAC=TRUE) or not +C (CHKJAC=FALSE). +C DOVCV: The variable designating whether the covariance matrix is +C to be computed (DOVCV=TRUE) or not (DOVCV=FALSE). +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INITD: The variable designating whether DELTA is to be initialized +C to zero (INITD=TRUE) or to the first N by M elements of +C array WORK (INITD=FALSE). +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C J: The value of a specific digit of JOB. +C JOB: The variable controling problem initialization and +C computational method. +C REDOJ: The variable designating whether the Jacobian matrix is to +C be recomputed for the computation of the covariance matrix +C (REDOJ=TRUE) or not (REDOJ=FALSE). +C RESTRT: The variable designating whether the call is a restart +C (RESTRT=TRUE) or not (RESTRT=FALSE). + + +C***First executable statement DFLAGS + + + IF (JOB.GE.0) THEN + + RESTRT= JOB.GE.10000 + + INITD = MOD(JOB,10000)/1000.EQ.0 + + J = MOD(JOB,1000)/100 + IF (J.EQ.0) THEN + DOVCV = .TRUE. + REDOJ = .TRUE. + ELSE IF (J.EQ.1) THEN + DOVCV = .TRUE. + REDOJ = .FALSE. + ELSE + DOVCV = .FALSE. + REDOJ = .FALSE. + END IF + + J = MOD(JOB,100)/10 + IF (J.EQ.0) THEN + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.1) THEN + ANAJAC = .FALSE. + CDJAC = .TRUE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.2) THEN + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .TRUE. + ELSE + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + END IF + + J = MOD(JOB,10) + IF (J.EQ.0) THEN + ISODR = .TRUE. + IMPLCT = .FALSE. + ELSE IF (J.EQ.1) THEN + ISODR = .TRUE. + IMPLCT = .TRUE. + ELSE + ISODR = .FALSE. + IMPLCT = .FALSE. + END IF + + ELSE + + RESTRT = .FALSE. + INITD = .TRUE. + DOVCV = .TRUE. + REDOJ = .TRUE. + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ISODR = .TRUE. + IMPLCT = .FALSE. + + END IF + + RETURN + END SUBROUTINE +*DHSTEP + FUNCTION DHSTEP + & (ITYPE,NETA,I,J,STP,LDSTP) + & RESULT(DHSTEPR) +C***Begin Prologue DHSTEP +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Set relative step size for finite difference derivatives +C***End Prologue DHSTEP + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & I,ITYPE,J,LDSTP,NETA + +C...Array arguments + REAL (KIND=R8) + & STP(LDSTP,J) + +C...Result + REAL (KIND=R8) + & DHSTEPR + +C...Local scalars + REAL (KIND=R8) + & TEN,THREE,TWO,ZERO + +C...Data statements + DATA + & ZERO,TWO,THREE,TEN + & /0.0E0_R8,2.0E0_R8,3.0E0_R8,10.0E0_R8/ + +C...Variable Definitions (alphabetically) +C I: An identifier for selecting user supplied step sizes. +C ITYPE: The finite difference method being used, where +C ITYPE = 0 indicates forward finite differences, and +C ITYPE = 1 indicates central finite differences. +C J: An identifier for selecting user supplied step sizes. +C LDSTP: The leading dimension of array STP. +C NETA: The number of good digits in the function results. +C STP: The step size for the finite difference derivative. +C TEN: The value 10.0E0_R8. +C THREE: The value 3.0E0_R8. +C TWO: The value 2.0E0_R8. +C ZERO: The value 0.0E0_R8. + + + +C***First executable statement DHSTEP + + +C Set DHSTEP to relative finite difference step size + + IF (STP(1,1).LE.ZERO) THEN + + IF (ITYPE.EQ.0) THEN +C Use default forward finite difference step size + DHSTEPR = TEN**(-ABS(NETA)/TWO - TWO) + + ELSE +C Use default central finite difference step size + DHSTEPR = TEN**(-ABS(NETA)/THREE) + END IF + + ELSE IF (LDSTP.EQ.1) THEN + DHSTEPR = STP(1,J) + + ELSE + DHSTEPR = STP(I,J) + END IF + + RETURN + END FUNCTION +*DIFIX + SUBROUTINE DIFIX + & (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) +C***Begin Prologue DIFIX +C***Refer to ODR +C***Routines Called (None) +C***Date Written 910612 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Set elements of T to zero according to IFIX +C***End Prologue DIFIX + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDIFIX,LDT,LDTFIX,M,N + +C...Array arguments + REAL (KIND=R8) + & T(LDT,M),TFIX(LDTFIX,M) + INTEGER + & IFIX(LDIFIX,M) + +C...Local scalars + REAL (KIND=R8) + & ZERO + INTEGER + & I,J + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C I: An indexing variable. +C IFIX: The array designating whether an element of T is to be +C set to zero. +C J: an indexing variable. +C LDT: The leading dimension of array T. +C LDIFIX: The leading dimension of array IFIX. +C LDTFIX: The leading dimension of array TFIX. +C M: The number of columns of data in the array. +C N: The number of rows of data in the array. +C T: The array being set to zero according to the elements +C of IFIX. +C TFIX: The resulting array. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DIFIX + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (IFIX(1,1).GE.ZERO) THEN + IF (LDIFIX.GE.N) THEN + DO 20 J=1,M + DO 10 I=1,N + IF (IFIX(I,J).EQ.0) THEN + TFIX(I,J) = ZERO + ELSE + TFIX(I,J) = T(I,J) + END IF + 10 CONTINUE + 20 CONTINUE + ELSE + DO 100 J=1,M + IF (IFIX(1,J).EQ.0) THEN + DO 30 I=1,N + TFIX(I,J) = ZERO + 30 CONTINUE + ELSE + DO 90 I=1,N + TFIX(I,J) = T(I,J) + 90 CONTINUE + END IF + 100 CONTINUE + END IF + END IF + + RETURN + END SUBROUTINE +*DINIWK + SUBROUTINE DINIWK + & (N,M,NP,WORK,LWORK,IWORK,LIWORK, + & X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + & BETA,SCLB, + & SSTOL,PARTOL,MAXIT,TAUFAC, + & JOB,IPRINT,LUNERR,LUNRPT, + & LOWER,UPPER, + & EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + & JOBI,IPRINI,LUNERI,LUNRPI, + & SSFI,TTI,LDTTI,DELTAI, + & LOWERI,UPPERI,BOUNDI) +C***Begin Prologue DINIWK +C***Refer to ODR +C***Routines Called DFLAGS,DSCLB,DSCLD,DZERO +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Initialize work vectors as necessary +C***End Prologue DINIWK + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & PARTOL,SSTOL,TAUFAC + INTEGER + & BOUNDI,DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + & LDSCLD,LDTTI,LDX,LIWORK,LOWERI,LUNERI,LUNERR,LUNRPI,LUNRPT, + & LWORK,M,MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI, + & UPPERI + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),LOWER(NP),SCLB(NP),SCLD(LDSCLD,M),UPPER(NP), + & WORK(LWORK),X(LDX,M) + INTEGER + & IFIXX(LDIFX,M),IWORK(LIWORK) + +C...Local scalars + REAL (KIND=R8) + & ONE,THREE,TWO,ZERO + INTEGER + & I,J + LOGICAL + & ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...External functions + +C...External subroutines + EXTERNAL + & DCOPY,DFLAGS,DSCLB,DSCLD,DZERO + +C...Data statements + DATA + & ZERO,ONE,TWO,THREE + & /0.0E0_R8,1.0E0_R8,2.0E0_R8,3.0E0_R8/ + +C...Variable Definitions (alphabetically) +C ANAJAC: The variable designating whether the Jacobians are +C computed by finite differences (ANAJAC=FALSE) or not +C (ANAJAC=TRUE). +C BETA: The function parameters. +C CDJAC: The variable designating whether the Jacobians are +C computed by central differences (CDJAC=TRUE) or by forward +C differences (CDJAC=FALSE). +C CHKJAC: The variable designating whether the user-supplied +C Jacobians are to be checked (CHKJAC=TRUE) or not +C (CHKJAC=FALSE). +C DELTAI: The starting location in array WORK of array DELTA. +C DOVCV: The variable designating whether the covariance matrix is +C to be computed (DOVCV=TRUE) or not (DOVCV=FALSE). +C EPSMAI: The location in array WORK of variable EPSMAC. +C I: An indexing variable. +C IFIXX: The values designating whether the elements of X are fixed +C at their input values or not. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INITD: The variable designating whether DELTA is to be initialized +C to zero (INITD=TRUE) or to the values in the first N by M +C elements of array WORK (INITD=FALSE). +C IPRINI: The location in array IWORK of variable IPRINT. +C IPRINT: The print control variable. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C IWORK: The integer work space. +C J: An indexing variable. +C JOB: The variable controling problem initialization and +C computational method. +C JOBI: The location in array IWORK of variable JOB. +C LDIFX: The leading dimension of array IFIXX. +C LDSCLD: The leading dimension of array SCLD. +C LDTTI: The leading dimension of array TT. +C LDX: The leading dimension of array X. +C LIWORK: The length of vector IWORK. +C LUNERI: The location in array IWORK of variable LUNERR. +C LUNERR: The logical unit number used for error messages. +C LUNRPI: The location in array iwork of variable LUNRPT. +C LUNRPT: The logical unit number used for computation reports. +C LWORK: The length of vector WORK. +C M: The number of columns of data in the independent variable. +C MAXIT: The maximum number of iterations allowed. +C MAXITI: The location in array IWORK of variable MAXIT. +C N: The number of observations. +C NP: The number of function parameters. +C ONE: The value 1.0E0_R8. +C PARTLI: The location in array work of variable partol. +C PARTOL: The parameter convergence stopping criteria. +C REDOJ: The variable designating whether the Jacobian matrix is to +C be recomputed for the computation of the covariance matrix +C (REDOJ=TRUE) or not (REDOJ=FALSE). +C RESTRT: The variable designating whether the call is a restart +C (RESTRT=TRUE) or not (RESTRT=FALSE). +C SCLB: The scaling values for BETA. +C SCLD: The scaling values for DELTA. +C SSFI: The starting location in array WORK of array SSF. +C SSTOL: The sum-of-squares convergence stopping criteria. +C SSTOLI: The location in array WORK of variable SSTOL. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C TAUFCI: The location in array WORK of variable TAUFAC. +C THREE: The value 3.0E0_R8. +C TTI: The starting location in array WORK of the ARRAY TT. +C TWO: The value 2.0E0_R8. +C WORK: The REAL (KIND=R8) work space. +C X: The independent variable. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DINIWK + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + & ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C Store value of machine precision in work vector + + WORK(EPSMAI) = EPSILON(ZERO) + +C Set tolerance for stopping criteria based on the change in the +C parameters (see also subprogram DODCNT) + + IF (PARTOL.LT.ZERO) THEN + WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) + ELSE + WORK(PARTLI) = MIN(PARTOL, ONE) + END IF + +C Set tolerance for stopping criteria based on the change in the +C sum of squares of the weighted observational errors + + IF (SSTOL.LT.ZERO) THEN + WORK(SSTOLI) = SQRT(WORK(EPSMAI)) + ELSE + WORK(SSTOLI) = MIN(SSTOL, ONE) + END IF + +C Set factor for computing trust region diameter at first iteration + + IF (TAUFAC.LE.ZERO) THEN + WORK(TAUFCI) = ONE + ELSE + WORK(TAUFCI) = MIN(TAUFAC, ONE) + END IF + +C Set maximum number of iterations + + IF (MAXIT.LT.0) THEN + IWORK(MAXITI) = 50 + ELSE + IWORK(MAXITI) = MAXIT + END IF + +C Store problem initialization and computational method control +C variable + + IF (JOB.LE.0) THEN + IWORK(JOBI) = 0 + ELSE + IWORK(JOBI) = JOB + END IF + +C Set print control + + IF (IPRINT.LT.0) THEN + IWORK(IPRINI) = 2001 + ELSE + IWORK(IPRINI) = IPRINT + END IF + +C Set logical unit number for error messages + + IF (LUNERR.LT.0) THEN + IWORK(LUNERI) = 6 + ELSE + IWORK(LUNERI) = LUNERR + END IF + +C Set logical unit number for computation reports + + IF (LUNRPT.LT.0) THEN + IWORK(LUNRPI) = 6 + ELSE + IWORK(LUNRPI) = LUNRPT + END IF + +C Compute scaling for BETA's and DELTA's + + IF (SCLB(1).LE.ZERO) THEN + CALL DSCLB(NP,BETA,WORK(SSFI)) + ELSE + CALL DCOPY(NP,SCLB,1,WORK(SSFI),1) + END IF + IF (ISODR) THEN + IF (SCLD(1,1).LE.ZERO) THEN + IWORK(LDTTI) = N + CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) + ELSE + IF (LDSCLD.EQ.1) THEN + IWORK(LDTTI) = 1 + CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1) + ELSE + IWORK(LDTTI) = N + DO 10 J=1,M + CALL DCOPY(N,SCLD(1,J),1, + & WORK(TTI+(J-1)*IWORK(LDTTI)),1) + 10 CONTINUE + END IF + END IF + END IF + +C Initialize DELTA's as necessary + + IF (ISODR) THEN + IF (INITD) THEN + CALL DZERO(N,M,WORK(DELTAI),N) + ELSE + IF (IFIXX(1,1).GE.0) THEN + IF (LDIFX.EQ.1) THEN + DO 20 J=1,M + IF (IFIXX(1,J).EQ.0) THEN + CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) + END IF + 20 CONTINUE + ELSE + DO 40 J=1,M + DO 30 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + WORK(DELTAI-1+I+(J-1)*N) = ZERO + END IF + 30 CONTINUE + 40 CONTINUE + END IF + END IF + END IF + ELSE + CALL DZERO(N,M,WORK(DELTAI),N) + END IF + +C Copy bounds into WORK + + WORK(LOWERI:LOWERI+NP-1) = LOWER(1:NP) + WORK(UPPERI:UPPERI+NP-1) = UPPER(1:NP) + +C Initialize parameters on bounds in IWORK + + IWORK(BOUNDI:BOUNDI+NP-1) = 0 + + RETURN + END SUBROUTINE +*DIWINF + SUBROUTINE DIWINF + & (M,NP,NQ, + & MSGBI,MSGDI,IFIX2I,ISTOPI, + & NNZWI,NPPI,IDFI, + & JOBI,IPRINI,LUNERI,LUNRPI, + & NROWI,NTOLI,NETAI, + & MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + & BOUNDI, + & LIWKMN) +C***Begin Prologue DIWINF +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Set storage locations within integer work space +C***End Prologue DIWINF + +C...Scalar arguments + INTEGER + & BOUNDI,IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI, + & LIWKMN,LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI, + & NJEVI,NNZWI,NP,NPPI,NQ,NROWI,NTOLI + +C...Variable Definitions (alphabetically) +C IDFI: The location in array IWORK of variable IDF. +C IFIX2I: The starting location in array IWORK of array IFIX2. +C INT2I: The location in array IWORK of variable INT2. +C IPRINI: The location in array IWORK of variable IPRINT. +C IRANKI: The location in array IWORK of variable IRANK. +C ISTOPI: The location in array IWORK of variable ISTOP. +C JOBI: The location in array IWORK of variable JOB. +C LDTTI: The location in array IWORK of variable LDTT. +C LIWKMN: The minimum acceptable length of array IWORK. +C LUNERI: The location in array IWORK of variable LUNERR. +C LUNRPI: The location in array IWORK of variable LUNRPT. +C M: The number of columns of data in the independent variable. +C MAXITI: The location in array iwork of variable MAXIT. +C MSGBI: The starting location in array IWORK of array MSGB. +C MSGDI: The starting location in array IWORK of array MSGD. +C NETAI: The location in array IWORK of variable NETA. +C NFEVI: The location in array IWORK of variable NFEV. +C NITERI: The location in array IWORK of variabel NITER. +C NJEVI: The location in array IWORK of variable NJEV. +C NNZWI: The location in array IWORK of variable NNZW. +C NP: The number of function parameters. +C NPPI: The location in array IWORK of variable NPP. +C NQ: The number of responses per observation. +C NROWI: The location in array IWORK of variable NROW. +C NTOLI: The location in array IWORK of variable NTOL. + + +C***First executable statement DIWINF + + + IF (NP.GE.1 .AND. M.GE.1) THEN + MSGBI = 1 + MSGDI = MSGBI + NQ*NP+1 + IFIX2I = MSGDI + NQ*M+1 + ISTOPI = IFIX2I + NP + NNZWI = ISTOPI + 1 + NPPI = NNZWI + 1 + IDFI = NPPI + 1 + JOBI = IDFI + 1 + IPRINI = JOBI + 1 + LUNERI = IPRINI + 1 + LUNRPI = LUNERI + 1 + NROWI = LUNRPI + 1 + NTOLI = NROWI + 1 + NETAI = NTOLI + 1 + MAXITI = NETAI + 1 + NITERI = MAXITI + 1 + NFEVI = NITERI + 1 + NJEVI = NFEVI + 1 + INT2I = NJEVI + 1 + IRANKI = INT2I + 1 + LDTTI = IRANKI + 1 + BOUNDI = LDTTI + 1 + LIWKMN = BOUNDI + NP - 1 + ELSE + MSGBI = 1 + MSGDI = 1 + IFIX2I = 1 + ISTOPI = 1 + NNZWI = 1 + NPPI = 1 + IDFI = 1 + JOBI = 1 + IPRINI = 1 + LUNERI = 1 + LUNRPI = 1 + NROWI = 1 + NTOLI = 1 + NETAI = 1 + MAXITI = 1 + NITERI = 1 + NFEVI = 1 + NJEVI = 1 + INT2I = 1 + IRANKI = 1 + LDTTI = 1 + BOUNDI = 1 + LIWKMN = 1 + END IF + + RETURN + END SUBROUTINE +*DJACCD + SUBROUTINE DJACCD + & (FCN, + & N,M,NP,NQ, + & BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + & STPB,STPD,LDSTPD, + & SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + & FJACB,ISODR,FJACD,NFEV,ISTOP,INFO, + & LOWER,UPPER) +C***Begin Prologue DJACCD +C***Refer to ODR +C***Routines Called FCN,DHSTEP,DZERO +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute central difference approximations to the +C Jacobian wrt the estimated BETAS and wrt the DELTAS +C***End Prologue DJACCD + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), + & LOWER(NP), + & SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + & UPPER(NP), + & WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + & X(LDX,M),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & BETAK,ONE,TYPJ,ZERO + INTEGER + & I,J,K,L + LOGICAL + & DOIT,SETZRO + +C...External subroutines + EXTERNAL + & DZERO + +C...External functions + REAL (KIND=R8) + & DHSTEP,DERSTEP + EXTERNAL + & DHSTEP,DERSTEP + +C...Data statements + DATA + & ZERO,ONE + & /0.0E0_R8,1.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C BETAK: The K-th function parameter. +C DELTA: The estimated errors in the explanatory variables. +C DOIT: The variable designating whether the derivative wrt a given +C BETA or DELTA needs to be computed (DOIT=TRUE) or not +C (DOIT=FALSE). +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FN: The new predicted values from the function. Used when parameter is +C on a boundary. +C I: An indexing variable. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are fixed +C at their input values or not. +C INFO: The variable designating why the computations were stopped. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C J: An indexing variable. +C K: An indexing variable. +C L: An indexing variable. +C LDIFX: The leading dimension of array IFIXX. +C LDSTPD: The leading dimension of array STPD. +C LDTT: The leading dimension of array TT. +C LDX: The leading dimension of array X. +C LOWER: The lower bound on BETA. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NETA: The number of good digits in the function results. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C ONE: The value 1.0E0_R8. +C SETZRO: The variable designating whether the derivative wrt some +C DELTA needs to be set to zero (SETZRO=TRUE) or not +C (SETZRO=FALSE). +C SSF: The scaling values used for BETA. +C STP: The step used for computing finite difference +C derivatives with respect to each DELTA. +C STPB: the relative step used for computing finite difference +C derivatives with respect to each BETA. +C STPD: The relative step used for computing finite difference +C derivatives with respect to each DELTA. +C TT: The scaling values used for DELTA. +C TYPJ: The typical size of the J-th unknown BETA or DELTA. +C UPPER: The upper bound on BETA. +C X: The explanatory variable. +C XPLUSD: The values of X + DELTA. +C WRK1: A work array of (N BY M BY NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK3: A work array of (NP) elements. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) elements. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DJACCD + + +C Compute the Jacobian wrt the estimated BETAS + + DO 60 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + WRK3(K) = BETAK + & + DERSTEP(1,K,BETAK,SSF,STPB,NETA) + WRK3(K) = WRK3(K) - BETAK + + BETA(K) = BETAK + WRK3(K) + IF (BETA(K).GT.UPPER(K)) THEN + BETA(K) = UPPER(K) + ELSE IF (BETA(K).LT.LOWER(K)) THEN + BETA(K) = LOWER(K) + END IF + IF (BETA(K)-2*WRK3(K).LT.LOWER(K)) THEN + BETA(K) = LOWER(K) + 2*WRK3(K) + ELSE IF (BETA(K)-2*WRK3(K).GT.UPPER(K)) THEN + BETA(K) = UPPER(K) + 2*WRK3(K) + END IF + IF (BETA(K).GT.UPPER(K).OR.BETA(K).LT.LOWER(K)) THEN + INFO = 60001 + RETURN + END IF + ISTOP = 0 + IF (BETA(K).EQ.BETAK) THEN + WRK2(1:N,1:NQ) = FN(1:N,1:NQ) + ELSE + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 001,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + END IF + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = WRK2(I,L) + 20 CONTINUE + 30 CONTINUE + + BETA(K) = BETA(K) - 2*WRK3(K) + IF (BETA(K).GT.UPPER(K)) THEN + INFO = 60001 + RETURN + END IF + IF (BETA(K).LT.LOWER(K)) THEN + INFO = 60001 + RETURN + END IF + ISTOP = 0 + IF (BETA(K).EQ.BETAK) THEN + WRK2(1:N,1:NQ) = FN(1:N,1:NQ) + ELSE + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 001,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + END IF + + DO 50 L=1,NQ + DO 40 I=1,N + FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) + 40 CONTINUE + 50 CONTINUE + BETA(K) = BETAK + END IF + 60 CONTINUE + +C Compute the Jacobian wrt the X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + STP(I) = XPLUSD(I,J) + & + SIGN(ONE,XPLUSD(I,J)) + & *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 001,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + END IF + + DO 150 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) + 150 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 001,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + & (2*STP(I)) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + & (2*STP(I)) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END SUBROUTINE +*MBFB + SUBROUTINE MBFB + & (NP,BETA,LOWER,UPPER,SSF,STPB,NETA,ETA,INTERVAL) +C***BEGIN PROLOGUE MBFB +C***REFER TO ODR +C***ROUTINES CALLED DHSTEP +C***DATE WRITTEN 20040624 (YYYYMMDD) +C***REVISION DATE 20040624 (YYYYMMDD) +C***PURPOSE ENSURE RANGE OF BOUNDS IS LARGE ENOUGH FOR DERIVATIVE CHECKING. +C*** MOVE BETA AWAY FROM BOUNDS SO THAT DERIVATIVES CAN BE CALCULATED. +C***END PROLOGUE MBFB + +C...USED MODULES + USE REAL_PRECISION + +C...SCALAR ARGUMENTS + INTEGER + & NETA,NP + REAL (KIND=R8) + & ETA + +C...ARRAY ARGUMENTS + INTEGER + & INTERVAL(NP) + REAL (KIND=R8) + & BETA(NP),LOWER(NP),SSF(NP),STPB(NP),UPPER(NP) + +C...LOCAL SCALARS + INTEGER + & K + REAL (KIND=R8) + & H,H0,H1,HC,HC0,HC1,HUNDRED,ONE,STPR,STPL,TEN,THREE,TYPJ,ZERO + +C...EXTERNAL FUNCTIONS + REAL (KIND=R8) + & DHSTEP + EXTERNAL + & DHSTEP + +C...DATA STATEMENTS + DATA + & ZERO,ONE,TEN,HUNDRED,THREE + & /0.0E0_R8,1.0E0_R8,10.0E0_R8,100.0E0_R8,3.0E0_R8/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: BETA for the jacobian checker. BETA will be moved far enough from +C the bounds so that the derivative checker may proceed. +C H: Relative step size for forward differences. +C H0: Initial relative step size for forward differences. +C H1: Default relative step size for forward differences. +C HC: Relative step size for center differences. +C HC0: Initial relative step size for center differences. +C HC1: Default relative step size for center differences. +C HUNDRED: 100.0E0_R8 +C INTERVAL: Specifies which difference methods and step sizes are supported by +C the current intervale UPPER-LOWER. +C K: Index variable for BETA. +C NETA: Number of good digits in the function results. +C ONE: The value 1.0E0_R8. +C SSF: The scale used for the BETA'S. +C STPB: The relative step used for computing finite difference derivatives +C with respect to BETA. +C STPL: Maximum step to the left of BETA (-) the derivative checker will +C use. +C STPR: Maximum step to the right of BETA (+) the derivative checker will +C use. +C TEN: 10.0E0_R8 +C THREE: 3.0E0_R8 +C TYPJ: The typical size of the J-th unkonwn BETA. +C ZERO: The value 0.0E0_R8. + + INTERVAL(:) = 111 + DO K=1,NP + H0 = DHSTEP(0,NETA,1,K,STPB,1) + HC0 = H0 + H1 = SQRT(ETA) + HC1 = ETA**(ONE/THREE) + H = MAX(TEN*H1,MIN(HUNDRED*H0,ONE)) + HC = MAX(TEN*HC1,MIN(HUNDRED*HC0,ONE)) + IF (BETA(K).EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETA(K)) + END IF + STPR = (H*TYPJ*SIGN(ONE,BETA(K))+BETA(K))-BETA(K) + STPL = (HC*TYPJ*SIGN(ONE,BETA(K))+BETA(K))-BETA(K) +C Check outer interval. + IF (LOWER(K)+2*ABS(STPL).GT.UPPER(K)) THEN + IF (INTERVAL(K).GE.100) THEN + INTERVAL(K) = INTERVAL(K) - 100 + END IF + ELSE IF (BETA(K)+STPL.GT.UPPER(K).OR.BETA(K)-STPL.GT.UPPER(K)) + & THEN + BETA(K) = UPPER(K) - ABS(STPL) + ELSE IF (BETA(K)+STPL.LT.LOWER(K).OR.BETA(K)-STPL.LT.LOWER(K)) + & THEN + BETA(K) = LOWER(K) + ABS(STPL) + END IF +C Check middle interval. + IF (LOWER(K)+2*ABS(STPR).GT.UPPER(K)) THEN + IF (MOD(INTERVAL(K),100).GE.10) THEN + INTERVAL(K) = INTERVAL(K) - 10 + END IF + ELSE IF (BETA(K)+STPR.GT.UPPER(K).OR.BETA(K)-STPR.GT.UPPER(K)) + & THEN + BETA(K) = UPPER(K) - ABS(STPR) + ELSE IF (BETA(K)+STPR.LT.LOWER(K).OR.BETA(K)-STPR.LT.LOWER(K)) + & THEN + BETA(K) = LOWER(K) + ABS(STPR) + END IF +C Check inner interval + IF (LOWER(K)+ABS(STPR).GT.UPPER(K)) THEN + INTERVAL(K) = 0 + ELSE IF (BETA(K)+STPR.GT.UPPER(K)) THEN + BETA(K) = UPPER(K) - STPR + ELSE IF (BETA(K)+STPR.LT.LOWER(K)) THEN + BETA(K) = LOWER(K) - STPR + END IF + END DO + + END SUBROUTINE +*DERSTEP + FUNCTION DERSTEP + & (ITYPE,K,BETAK,SSF,STPB,NETA) + & RESULT(DERSTEPR) +C***Begin Prologue DERSTEP +C***Refer to ODR +C***Routines Called DHSTEP +C***Date Written 20040616 (YYYYMMDD) +C***Revision Date 20040616 (YYYYMMDD) +C***Purpose Compute step size for center and forward difference calculations +C***End Prologue DERSTEP + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & ITYPE,K,NETA + REAL (KIND=R8) + & BETAK + +C...Array arguments + REAL (KIND=R8) + & SSF(K),STPB(K) + +C...Result + REAL (KIND=R8) + & DERSTEPR + +C...Local scalars + REAL (KIND=R8) + & ONE,TYPJ,ZERO + +C...External functions + REAL (KIND=R8) + & DHSTEP + EXTERNAL + & DHSTEP + +C...Data statements + DATA + & ZERO,ONE + & /0.0E0_R8,1.0E0_R8/ + +C...Variable definitions (alphabetically) +C BETAK: The K-th function parameter. +C ITYPE: 0 - calc foward difference step, 1 - calc center difference step. +C K: Index into beta where BETAK resides. +C NETA: Number of good digits in the function results. +C ONE: The value 1.0E0_R8. +C SSF: The scale used for the BETA'S. +C STPB: The relative step used for computing finite difference derivatives +C with respect to BETA. +C TYPJ: The typical size of the J-th unkonwn BETA. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DERSTEP + + + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + DERSTEPR = SIGN(ONE,BETAK)*TYPJ*DHSTEP(ITYPE,NETA,1,K,STPB,1) + + RETURN + END FUNCTION +*DJACFD + SUBROUTINE DJACFD + & (FCN, + & N,M,NP,NQ, + & BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + & STPB,STPD,LDSTPD, + & SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + & FJACB,ISODR,FJACD,NFEV,ISTOP,INFO, + & LOWER,UPPER) +C***Begin Prologue DJACFD +C***Refer to ODR +C***Routines Called FCN,DHSTEP,DZERO,DERSTEP +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute forward difference approximations to the +C Jacobian wrt the estimated BETAS and wrt the DELTAS +C***End Prologue DJACFD + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), + & LOWER(NP), + & SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + & UPPER(NP), + & WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + & X(LDX,M),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & BETAK,ONE,STEP,TYPJ,ZERO + INTEGER + & I,J,K,L + LOGICAL + & DOIT,SETZRO + +C...External subroutines + EXTERNAL + & DZERO + +C...External functions + REAL (KIND=R8) + & DHSTEP,DERSTEP + EXTERNAL + & DHSTEP,DERSTEP + +C...Data statements + DATA + & ZERO,ONE + & /0.0E0_R8,1.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C BETAK: The K-th function parameter. +C DELTA: The estimated errors in the explanatory variables. +C DOIT: The variable designating whether the derivative wrt a +C given BETA or DELTA needs to be computed (DOIT=TRUE) +C or not (DOIT=FALSE). +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FN: The new predicted values from the function. +C I: An indexing variable. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C J: An indexing variable. +C K: An indexing variable. +C L: An indexing variable. +C LDIFX: The leading dimension of array IFIXX. +C LDSTPD: The leading dimension of array STPD. +C LDTT: The leading dimension of array TT. +C LDX: The leading dimension of array X. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NETA: The number of good digits in the function results. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C ONE: The value 1.0E0_R8. +C SETZRO: The variable designating whether the derivative wrt some +C DELTA needs to be set to zero (SETZRO=TRUE) or not +C (SETZRO=FALSE). +C SSF: The scale used for the BETA'S. +C STP: The step used for computing finite difference +C derivatives with respect to DELTA. +C STPB: The relative step used for computing finite difference +C derivatives with respect to BETA. +C STPD: The relative step used for computing finite difference +C derivatives with respect to DELTA. +C TT: The scaling values used for DELTA. +C TYPJ: The typical size of the J-th unknown BETA or DELTA. +C X: The explanatory variable. +C XPLUSD: The values of X + DELTA. +C WRK1: A work array of (N by M by NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK3: A work array of (NP) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DJACFD + + +C Compute the Jacobian wrt the estimated BETAS + + DO 40 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + STEP = DERSTEP(0,K,BETAK,SSF,STPB,NETA) + WRK3(K) = BETAK + STEP + WRK3(K) = WRK3(K) - BETAK + BETA(K) = BETAK + WRK3(K) + IF (BETA(K).GT.UPPER(K)) THEN + STEP = -STEP + WRK3(K) = BETAK + STEP + WRK3(K) = WRK3(K) - BETAK + BETA(K) = BETAK + WRK3(K) + END IF + IF (BETA(K).LT.LOWER(K)) THEN + STEP = -STEP + WRK3(K) = BETAK + STEP + WRK3(K) = WRK3(K) - BETAK + BETA(K) = BETAK + WRK3(K) + IF (BETA(K).GT.UPPER(K)) THEN + INFO = 60001 + RETURN + END IF + END IF + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 001,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) + 20 CONTINUE + 30 CONTINUE + BETA(K) = BETAK + END IF + 40 CONTINUE + +C Compute the Jacobian wrt the X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + + STP(I) = XPLUSD(I,J) + & + SIGN(ONE,XPLUSD(I,J)) + & *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 001,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END SUBROUTINE +*DJCK + SUBROUTINE DJCK + & (FCN, + & N,M,NP,NQ, + & BETA,BETAJ,XPLUSD, + & IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + & SSF,TT,LDTT, + & ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + & PV0I,FJACB,FJACD, + & MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, + & WRK1,WRK2,WRK6, + & INTERVAL) +C***Begin Prologue DJCK +C***Refer to ODR +C***Routines Called FCN,DHSTEP,DJCKM +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Driver routine for the derivative checking process +C (adapted from STARPAC subroutine DCKCNT) +C***End Prologue DJCK + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & EPSMAC,ETA + INTEGER + & ISTOP,LDIFX,LDSTPD,LDTT, + & M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),BETAJ(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + & PV0I(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + & WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),INTERVAL(NP),MSGB(1+NQ*NP), + & MSGD(1+NQ*M) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO + INTEGER + & IDEVAL,J,LQ,MSGB1,MSGD1 + LOGICAL + & ISFIXD,ISWRTB + +C...Local arrays + REAL (KIND=R8) + & PV0(N,NQ) + +C...External subroutines + EXTERNAL + & DJCKM + +C...External functions + REAL (KIND=R8) + & DHSTEP + EXTERNAL + & DHSTEP + +C...Data statements + DATA + & ZERO,P5,ONE + & /0.0E0_R8,0.5E0_R8,1.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C BETAJ: The function parameters offset such that steps don't cross +C bounds. +C DIFF: The relative differences between the user supplied and +C finite difference derivatives for each derivative checked. +C DIFFJ: The relative differences between the user supplied and +C finite difference derivatives for the derivative being +C checked. +C EPSMAC: The value of machine precision. +C ETA: The relative noise in the function results. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C H0: The initial relative step size for forward differences. +C HC0: The initial relative step size for central differences. +C IDEVAL: The variable designating what computations are to be +C performed by user supplied subroutine FCN. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C INTERVAL: Specifies which checks can be performed when checking derivatives +C based on the interval of the bound constraints. +C ISFIXD: The variable designating whether the parameter is fixed +C (ISFIXD=TRUE) or not (ISFIXD=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=.TRUE.) or by OLS (ISODR=.FALSE.). +C ISWRTB: The variable designating whether the derivatives wrt BETA +C (ISWRTB=TRUE) or DELTA (ISWRTB=FALSE) are being checked. +C J: An index variable. +C LDIFX: The leading dimension of array IFIXX. +C LDSTPD: The leading dimension of array STPD. +C LDTT: The leading dimension of array TT. +C LQ: The response currently being examined. +C M: The number of columns of data in the explanatory variable. +C MSGB: The error checking results for the Jacobian wrt BETA. +C MSGB1: The error checking results for the Jacobian wrt BETA. +C MSGD: The error checking results for the Jacobian wrt DELTA. +C MSGD1: The error checking results for the Jacobian wrt DELTA. +C N: The number of observations. +C NETA: The number of reliable digits in the model results, either +C set by the user or computed by DETAF. +C NFEV: The number of function evaluations. +C NJEV: The number of Jacobian evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the explanatory variable array at which +C the derivative is checked. +C NTOL: The number of digits of agreement required between the +C numerical derivatives and the user supplied derivatives. +C ONE: The value 1.0E0_R8. +C P5: The value 0.5E0_R8. +C PV: The scalar in which the predicted value from the model for +C row NROW is stored. +C PV0: The predicted values using the current parameter estimates +C (possibly offset from the user supplied estimates to create +C distance between parameters and the bounds on the parameters). +C PV0I: The predicted values using the user supplied parameter estimates. +C SSF: The scaling values used for BETA. +C STPB: The step size for finite difference derivatives wrt BETA. +C STPD: The step size for finite difference derivatives wrt DELTA. +C TOL: The agreement tolerance. +C TT: The scaling values used for DELTA. +C TYPJ: The typical size of the J-th unknown BETA or DELTA. +C WRK1: A work array of (N BY M BY NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C XPLUSD: The values of X + DELTA. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DJCK + + +C Set tolerance for checking derivatives + + TOL = ETA**(0.25E0_R8) + NTOL = MAX(ONE,P5-LOG10(TOL)) + + +C Compute, if necessary, PV0 + + PV0 = PV0I + IF ( ANY(BETA(:).NE.BETAJ(:)) ) THEN + ISTOP = 0 + IDEVAL = 001 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETAJ,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & IDEVAL,PV0,FJACB,FJACD, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV + 1 + END IF + END IF + + +C Compute user supplied derivative values + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETAJ,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & IDEVAL,WRK2,FJACB,FJACD, + & ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV + 1 + END IF + +C Check derivatives wrt BETA for each response of observation NROW + + MSGB1 = 0 + MSGD1 = 0 + + DO 30 LQ=1,NQ + +C Set predicted value of model at current parameter estimates + PV = PV0(NROW,LQ) + + ISWRTB = .TRUE. + DO 10 J=1,NP + + IF (IFIXB(1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (IFIXB(J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGB(1+LQ+(J-1)*NQ) = -1 + ELSE + IF (BETA(J).EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(J) + END IF + ELSE + TYPJ = ABS(BETA(J)) + END IF + + H0 = DHSTEP(0,NETA,1,J,STPB,1) + HC0 = H0 + +C Check derivative wrt the J-th parameter at the NROW-th row + + IF (INTERVAL(J).GE.1) THEN + CALL DJCKM(FCN, + & N,M,NP,NQ, + & BETAJ,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + & ISWRTB,PV,FJACB(NROW,J,LQ), + & DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, + & WRK1,WRK2,WRK6,INTERVAL) + IF (ISTOP.NE.0) THEN + MSGB(1) = -1 + RETURN + ELSE + DIFF(LQ,J) = DIFFJ + END IF + ELSE + MSGB(1+J) = 9 + END IF + END IF + + 10 CONTINUE + +C Check derivatives wrt X for each response of observation NROW + + IF (ISODR) THEN + ISWRTB = .FALSE. + DO 20 J=1,M + + IF (IFIXX(1,1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGD(1+LQ+(J-1)*NQ) = -1 + ELSE + + IF (XPLUSD(NROW,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(NROW,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(NROW,J)) + END IF + + H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) + HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) + +C Check derivative wrt the J-th column of DELTA at row NROW + + CALL DJCKM(FCN, + & N,M,NP,NQ, + & BETAJ,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + & ISWRTB,PV,FJACD(NROW,J,LQ), + & DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, + & WRK1,WRK2,WRK6,INTERVAL) + IF (ISTOP.NE.0) THEN + MSGD(1) = -1 + RETURN + ELSE + DIFF(LQ,NP+J) = DIFFJ + END IF + END IF + + 20 CONTINUE + END IF + 30 CONTINUE + MSGB(1) = MSGB1 + MSGD(1) = MSGD1 + + RETURN + END SUBROUTINE +*DJCKC + SUBROUTINE DJCKC + & (FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + & FD,TYPJ,PVPSTP,STP0, + & PV,D, + & DIFFJ,MSG,ISTOP,NFEV, + & WRK1,WRK2,WRK6) +C***Begin Prologue DJCKC +C***Refer to ODR +C***Routines Called DJCKF,DPVB,DPVD +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Check whether high curvature could be the cause of the +C disagreement between the numerical and analytic derviatives +C (adapted from STARPAC subroutine DCKCRV) +C***End prologue DJCKC + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + & ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + & ISWRTB + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO + +C...External subroutines + EXTERNAL + & DJCKF,DPVB,DPVD + +C...Data statements + DATA + & P01,ONE,TWO,TEN + & /0.01E0_R8,1.0E0_R8,2.0E0_R8,10.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C CURVE: A measure of the curvature in the model. +C D: The derivative with respect to the Jth unknown parameter. +C DIFFJ: The relative differences between the user supplied and +C finite difference derivatives for the derivative being +C checked. +C EPSMAC: The value of machine precision. +C ETA: The relative noise in the model +C FD: The forward difference derivative wrt the Jth parameter. +C HC: The relative step size for central finite differences. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C ISWRTB: The variable designating whether the derivatives wrt BETA +C (ISWRTB=TRUE) or DELTA(ISWRTB=FALSE) are being checked. +C J: The index of the partial derivative being examined. +C LDIFX: The leading dimension of array IFIXX. +C LQ: The response currently being examined. +C M: The number of columns of data in the explanatory variable. +C MSG: The error checking results. +C N: The number of observations. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the explanatory variable array at which +C the derivative is to be checked. +C ONE: The value 1.0E0_R8. +C PV: The predicted value of the model for row NROW . +C PVMCRV: The predicted value for row NROW of the model +C based on the current parameter estimates for all but the +C Jth parameter value, which is BETA(J)-STPCRV. +C PVPCRV: The predicted value for row NROW of the model +C based on the current parameter estimates for all but the +C Jth parameter value, which is BETA(J)+STPCRV. +C PVPSTP: The predicted value for row NROW of the model +C based on the current parameter estimates for all but the +C Jth parameter value, which is BETA(J) + STP0. +C P01: The value 0.01E0_R8. +C STP0: The initial step size for the finite difference derivative. +C STP: A step size for the finite difference derivative. +C STPCRV: The step size selected to check for curvature in the model. +C TEN: The value 10.0E0_R8. +C TOL: The agreement tolerance. +C TWO: The value 2.0E0_R8. +C TYPJ: The typical size of the J-th unknown BETA or DELTA. +C WRK1: A work array of (N BY M BY NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C XPLUSD: The values of X + DELTA. + + +C***First executable statement DJCKC + + + IF (ISWRTB) THEN + +C Perform central difference computations for derivatives wrt BETA + + STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STPCRV, + & ISTOP,NFEV,PVPCRV, + & WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVB(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,-STPCRV, + & ISTOP,NFEV,PVMCRV, + & WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C Perform central difference computations for derivatives wrt DELTA + + STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - + & XPLUSD(NROW,J) + CALL DPVD(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STPCRV, + & ISTOP,NFEV,PVPCRV, + & WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVD(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,-STPCRV, + & ISTOP,NFEV,PVMCRV, + & WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C Estimate curvature by second derivative of model + + CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) + CURVE = CURVE + + & ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) + + +C Check if finite precision arithmetic could be the culprit. + CALL DJCKF(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & ETA,TOL,NROW,J,LQ,ISWRTB, + & FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + & DIFFJ,MSG,ISTOP,NFEV, + & WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + IF (MSG(LQ,J).EQ.0) THEN + RETURN + END IF + +C Check if high curvature could be the problem. + + STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) + IF (STP.LT.ABS(TEN*STP0)) THEN + STP = MIN(STP,P01*ABS(STP0)) + END IF + + + IF (ISWRTB) THEN + +C Perform computations for derivatives wrt BETA + STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) + CALL DPVB(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP, + & ISTOP,NFEV,PVPSTP, + & WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C Perform computations for derivatives wrt DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + & XPLUSD(NROW,J) + CALL DPVD(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP, + & ISTOP,NFEV,PVPSTP, + & WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C Compute the new numerical derivative + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C Check whether the new numerical derivative is ok + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN + MSG(LQ,J) = 0 + +C Check if finite precision may be the culprit (fudge factor = 2) + ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) + & + CURVE*(EPSMAC*TYPJ)**2) THEN + MSG(LQ,J) = 5 + END IF + + RETURN + END SUBROUTINE +*DJCKF + SUBROUTINE DJCKF + & (FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & ETA,TOL,NROW,J,LQ,ISWRTB, + & FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + & DIFFJ,MSG,ISTOP,NFEV, + & WRK1,WRK2,WRK6) +C***Begin Prologue DJCKF +C***Refer to ODR +C***Routines Called DPVB,DPVD +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Check whether finite precision arithmetic could be the +C cause of the disagreement between the derivatives +C (adapted from STARPAC subroutine DCKFPA) +C***End Prologue DJCKF + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + & ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + & ISWRTB + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & HUNDRD,ONE,P1,STP,TWO + LOGICAL + & LARGE + +C...External subroutines + EXTERNAL + & DPVB,DPVD + +C...Data statements + DATA + & P1,ONE,TWO,HUNDRD + & /0.1E0_R8,1.0E0_R8,2.0E0_R8,100.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C CURVE: A measure of the curvature in the model. +C D: The derivative with respect to the Jth unknown parameter. +C DIFFJ: The relative differences between the user supplied and +C finite difference derivatives for the derivative being +C checked. +C ETA: The relative noise in the model +C FD: The forward difference derivative wrt the Jth parameter. +C HUNDRD: The value 100.0E0_R8. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C ISTOP: The variable designating whether there are problems +c computing the function at the current BETA and DELTA. +C ISWRTB: The variable designating whether the derivatives wrt BETA +C (ISWRTB=TRUE) or DELTA(ISWRTB=FALSE) are being checked. +C J: The index of the partial derivative being examined. +C LARGE: The value designating whether the recommended increase in +C the step size would be greater than TYPJ. +C LDIFX: The leading dimension of array IFIXX. +C LQ: The response currently being examined. +C M: The number of columns of data in the explanatory variable. +C MSG: The error checking results. +C N: The number of observations. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the explanatory variable array at which +C the derivative is to be checked. +C ONE: The value 1.0E0_R8. +C PV: The predicted value for row NROW . +C PVPSTP: The predicted value for row NROW of the model +C based on the current parameter estimates for all but the +C Jth parameter value, which is BETA(J) + STP0. +C P1: The value 0.1E0_R8. +C STP0: The step size for the finite difference derivative. +C TOL: The agreement tolerance. +C TWO: The value 2.0E0_R8. +C TYPJ: The typical size of the J-th unknown BETA or DELTA. +C WRK1: A work array of (N BY M BY NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C XPLUSD: The values of X + DELTA. + + +C***First executable statement DJCKF + + +C Finite precision arithmetic could be the problem. +C Try a larger step size based on estimate of condition error + + STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) + IF (STP.GT.ABS(P1*STP0)) THEN + STP = MAX(STP,HUNDRD*ABS(STP0)) + END IF + IF (STP.GT.TYPJ) THEN + STP = TYPJ + LARGE = .TRUE. + ELSE + LARGE = .FALSE. + END IF + + IF (ISWRTB) THEN + +C Perform computations for derivatives wrt BETA + STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP, + & ISTOP,NFEV,PVPSTP, + & WRK1,WRK2,WRK6) + ELSE + +C Perform computations for derivatives wrt DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + & XPLUSD(NROW,J) + CALL DPVD(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP, + & ISTOP,NFEV,PVPSTP, + & WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C Check for agreement + + IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN +C Forward difference quotient and analytic derivatives agree. + MSG(LQ,J) = 0 + + ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN +C Curvature may be the culprit (fudge factor = 2) + IF (LARGE) THEN + MSG(LQ,J) = 4 + ELSE + MSG(LQ,J) = 5 + END IF + END IF + + RETURN + END SUBROUTINE +*DJCKM + SUBROUTINE DJCKM + & (FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + & ISWRTB,PV,D, + & DIFFJ,MSG1,MSG,ISTOP,NFEV, + & WRK1,WRK2,WRK6,INTERVAL) +C***Begin Prologue DJCKM +C***Refer to ODR +C***Routines Called DJCKC,DJCKZ,DPVB,DPVD +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Check user supplied analytic derivatives against numerical +C derivatives +C (adapted from STARPAC subroutine DCKMN) +C***End prologue DJCKM + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ + INTEGER + & ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW + LOGICAL + & ISWRTB + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),INTERVAL(NP),MSG(NQ,J) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, + & TEN,THREE,TOL2,TWO,ZERO + INTEGER + & I + +C...External subroutines + EXTERNAL + & DJCKC,DJCKZ,DPVB,DPVD + +C...Data statements + DATA + & ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD + & /0.0E0_R8,0.01E0_R8,0.1E0_R8,1.0E0_R8,2.0E0_R8,3.0E0_R8, + & 1.0E1_R8,1.0E2_R8/ + DATA + & BIG,TOL2 + & /1.0E19_R8,5.0E-2_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C BIG: A big value, used to initialize DIFFJ. +C D: The derivative with respect to the Jth unknown parameter. +C DIFFJ: The relative differences between the user supplied and +C finite difference derivatives for the derivative being +C checked. +C EPSMAC: The value of machine precision. +C ETA: The relative noise in the function results. +C FD: The forward difference derivative wrt the Jth parameter. +C H: The relative step size for forward differences. +C H0: The initial relative step size for forward differences. +C H1: The default relative step size for forward differences. +C HC: The relative step size for central differences. +C HC0: The initial relative step size for central differences. +C HC1: The default relative step size for central differences. +C HUNDRD: The value 100.0E0_R8. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C INTERVAL: Specifies which checks can be performed when checking derivatives +C based on the interval of the bound constraints. +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C ISWRTB: The variable designating whether the derivatives wrt BETA +C (ISWRTB=TRUE) or DELTAS (ISWRTB=FALSE) are being checked. +C J: The index of the partial derivative being examined. +C LDIFX: The leading dimension of array IFIXX. +C LQ: The response currently being examined. +C M: The number of columns of data in the explanatory variable. +C MSG: The error checking results. +C MSG1: The error checking results summary. +C N: The number of observations. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the explanatory variable array at which +C the derivative is to be checked. +C ONE: The value 1.0E0_R8. +C PV: The predicted value from the model for row NROW . +C PVPSTP: The predicted value for row NROW of the model +C Using the current parameter estimates for all but the Jth +C parameter value, which is BETA(J) + STP0. +C P01: The value 0.01E0_R8. +C P1: The value 0.1E0_R8. +C STP0: The initial step size for the finite difference derivative. +C TEN: The value 10.0E0_R8. +C THREE: The value 3.0E0_R8. +C TWO: The value 2.0E0_R8. +C TOL: The agreement tolerance. +C TOL2: A minimum agreement tolerance. +C TYPJ: The typical size of the J-th unknown BETA or DELTA. +C WRK1: A work array of (N BY M BY NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C XPLUSD: The values of X + DELTA. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DJCKM + + +C Calculate the Jth partial derivative using forward difference +C quotients and decide if it agrees with user supplied values + + H1 = SQRT(ETA) + HC1 = ETA**(ONE/THREE) + + MSG(LQ,J) = 7 + DIFFJ = BIG + + DO 10 I=1,3 + + IF (I.EQ.1) THEN +C Try initial relative step size + H = H0 + HC = HC0 + + ELSE IF (I.EQ.2) THEN +C Try larger relative step size + H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) + HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) + + ELSE IF (I.EQ.3) THEN +C Try smaller relative step size + H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) + HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) + END IF + + IF (ISWRTB) THEN + +C Perform computations for derivatives wrt BETA + + STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP0, + & ISTOP,NFEV,PVPSTP, + & WRK1,WRK2,WRK6) + ELSE + +C Perform computations for derivatives wrt DELTA + + STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + & - XPLUSD(NROW,J) + CALL DPVD(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP0, + & ISTOP,NFEV,PVPSTP, + & WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP0 + +C Check for agreement + + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN +C Numerical and analytic derivatives agree + +C Set relative difference for derivative checking report + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + DIFFJ = ABS(FD-D) + ELSE + DIFFJ = ABS(FD-D)/ABS(D) + END IF + +C Set MSG flag. + IF (D.EQ.ZERO) THEN + +C JTH analytic and numerical derivatives are both zero. + MSG(LQ,J) = 1 + + ELSE +C JTH analytic and numerical derivatives are both nonzero. + MSG(LQ,J) = 0 + END IF + + ELSE + +C Numerical and analytic derivatives disagree. Check why + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + IF (INTERVAL(J).GE.10.OR..NOT.ISWRTB) THEN + CALL DJCKZ(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,EPSMAC,J,LQ,ISWRTB, + & TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + & DIFFJ,MSG,ISTOP,NFEV, + & WRK1,WRK2,WRK6) + ELSE + MSG(LQ,J) = 8 + END IF + ELSE + IF (INTERVAL(J).GE.100.OR..NOT.ISWRTB) THEN + CALL DJCKC(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + & FD,TYPJ,PVPSTP,STP0,PV,D, + & DIFFJ,MSG,ISTOP,NFEV, + & WRK1,WRK2,WRK6) + ELSE + MSG(LQ,J) = 8 + END IF + END IF + IF (MSG(LQ,J).LE.2) THEN + GO TO 20 + END IF + END IF + 10 CONTINUE + +C Set summary flag to indicate questionable results + 20 CONTINUE + IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 + IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN + MSG1 = MAX(MSG1,1) + ELSE IF (MSG(LQ,J).GE.7) THEN + MSG1 = 2 + END IF + + RETURN + END SUBROUTINE +*DJCKZ + SUBROUTINE DJCKZ + & (FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,EPSMAC,J,LQ,ISWRTB, + & TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + & DIFFJ,MSG,ISTOP,NFEV, + & WRK1,WRK2,WRK6) +C***Begin Prologue DJCKZ +C***Refer to ODR +C***Routines Called DPVB,DPVD +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Recheck the derivatives in the case where the finite +C difference derivative disagrees with the analytic +C derivative and the analytic derivative is zero +C (adapted from STARPAC subroutine DCKZRO) +C***End Prologue DJCKZ + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + & ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + & ISWRTB + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & CD,ONE,PVMSTP,THREE,TWO,ZERO + +C...External subroutines + EXTERNAL + & DPVB,DPVD + +C...Data statements + DATA + & ZERO,ONE,TWO,THREE + & /0.0E0_R8,1.0E0_R8,2.0E0_R8,3.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C CD: The central difference derivative wrt the Jth parameter. +C D: The derivative with respect to the Jth unknown parameter. +C DIFFJ: The relative differences between the user supplied and +C finite difference derivatives for the derivative being +C checked. +C EPSMAC: The value of machine precision. +C FD: The forward difference derivative wrt the Jth parameter. +C IFIXB: The values designating whether the elements of BETA are +C Fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C ISWRTB: The variable designating whether the derivatives wrt BETA +C (ISWRTB=TRUE) or X (ISWRTB=FALSE) are being checked. +C J: The index of the partial derivative being examined. +C LDIFX: The leading dimension of array IFIXX. +C LQ: The response currently being examined. +C M: The number of columns of data in the explanatory variable. +C MSG: The error checking results. +C N: The number of observations. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the explanatory variable array at which +C The derivative is to be checked. +C ONE: The value 1.0E0_R8. +C PV: The predicted value from the model for row NROW . +C PVMSTP: The predicted value for row NROW of the model +C using the current parameter estimates for all but the +C Jth parameter value, which is BETA(J) - STP0. +C PVPSTP: The predicted value for row NROW of the model +C using the current parameter estimates for all but the +C JTH parameter value, which is BETA(J) + STP0. +C STP0: The initial step size for the finite difference derivative. +C THREE: The value 3.0E0_R8. +C TWO: The value 2.0E0_R8. +C TOL: The agreement tolerance. +C TYPJ: The typical size of the J-th unknown BETA or DELTA. +C WRK1: A work array of (N BY M BY NQ) elements. +C WRK2: A work array of (N BY NQ) elements. +C WRK6: A work array of (N BY NP BY NQ) elements. +C XPLUSD: The values of X + DELTA. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DJCKZ + + +C Recalculate numerical derivative using central difference and step +C size of 2*STP0 + + IF (ISWRTB) THEN + +C Perform computations for derivatives wrt BETA + + CALL DPVB(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,-STP0, + & ISTOP,NFEV,PVMSTP, + & WRK1,WRK2,WRK6) + ELSE + +C Perform computations for derivatives wrt DELTA + + CALL DPVD(FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,-STP0, + & ISTOP,NFEV,PVMSTP, + & WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + CD = (PVPSTP-PVMSTP)/(TWO*STP0) + DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) + +C Check for agreement + + IF (DIFFJ.LE.TOL*ABS(D)) THEN + +C Finite difference and analytic derivatives now agree. + IF (D.EQ.ZERO) THEN + MSG(LQ,J) = 1 + ELSE + MSG(LQ,J) = 0 + END IF + + ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN +C Derivatives are both close to zero + MSG(LQ,J) = 2 + + ELSE +C Derivatives are not both close to zero + MSG(LQ,J) = 3 + END IF + + RETURN + END SUBROUTINE +*DODCHK + SUBROUTINE DODCHK + & (N,M,NP,NQ, + & ISODR,ANAJAC,IMPLCT, + & BETA,IFIXB, + & LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LDY, + & LWORK,LWKMN,LIWORK,LIWKMN, + & SCLB,SCLD,STPB,STPD, + & INFO, + & LOWER,UPPER) +C***Begin Prologue DODCHK +C***Refer to ODR +C***Routines Called (None) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Check input parameters, indicating errors found using +C nonzero values of argument INFO +C***End Prologue DODCHK + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + & LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ + LOGICAL + & ANAJAC,IMPLCT,ISODR + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),LOWER(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP), + & STPD(LDSTPD,M),UPPER(NP) + INTEGER + & IFIXB(NP) + +C...Local scalars + INTEGER + & I,J,K,LAST,NPP + +C...Variable Definitions (alphabetically) +C ANAJAC: The variable designating whether the Jacobians are +C computed by finite differences (ANAJAC=FALSE) or not +C (ANAJAC=TRUE). +C I: An indexing variable. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INFO: The variable designating why the computations were stopped. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C J: An indexing variable. +C K: An indexing variable. +C LAST: The last row of the array to be accessed. +C LDIFX: The leading dimension of array IFIXX. +C LDSCLD: The leading dimension of array SCLD. +C LDSTPD: The leading dimension of array STPD. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LDX: The leading dimension of array X. +C LDY: The leading dimension of array X. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C LIWKMN: The minimum acceptable length of array IWORK. +C LIWORK: The length of vector IWORK. +C LWKMN: The minimum acceptable length of array WORK. +C LWORK: The length of vector WORK. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NP: The number of function parameters. +C NPP: The number of function parameters being estimated. +C NQ: The number of responses per observations. +C SCLB: The scaling values for BETA. +C SCLD: The scaling value for DELTA. +C STPB: The step for the finite difference derivitive wrt BETA. +C STPD: The step for the finite difference derivitive wrt DELTA. + + +C***First executable statement DODCHK + + +C Find actual number of parameters being estimated + + IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN + NPP = NP + ELSE + NPP = 0 + DO 10 K=1,NP + IF (IFIXB(K).NE.0) THEN + NPP = NPP + 1 + END IF + 10 CONTINUE + END IF + +C Check problem specification parameters + + IF (N.LE.0 .OR. + & M.LE.0 .OR. + & (NPP.LE.0 .OR. NPP.GT.N) .OR. + & (NQ.LE.0)) THEN + + INFO = 10000 + IF (N.LE.0) THEN + INFO = INFO + 1000 + END IF + IF (M.LE.0) THEN + INFO = INFO + 100 + END IF + IF (NPP.LE.0 .OR. NPP.GT.N) THEN + INFO = INFO + 10 + END IF + IF (NQ.LE.0) THEN + INFO = INFO + 1 + END IF + + RETURN + + END IF + +C Check dimension specification parameters + + IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. + & (LDX.LT.N) .OR. + & (LDWE.NE.1 .AND. LDWE.LT.N) .OR. + & (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. + & (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. + & (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. + & (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. + & (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. + & (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. + & (LWORK.LT.LWKMN) .OR. + & (LIWORK.LT.LIWKMN)) THEN + + INFO = 20000 + IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN + INFO = INFO + 1000 + END IF + IF (LDX.LT.N) THEN + INFO = INFO + 2000 + END IF + + IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. + & (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN + INFO = INFO + 100 + END IF + IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. + & (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN + INFO = INFO + 200 + END IF + + IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN + INFO = INFO + 10 + END IF + IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN + INFO = INFO + 20 + END IF + IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN + INFO = INFO + 40 + END IF + + IF (LWORK.LT.LWKMN) THEN + INFO = INFO + 1 + END IF + IF (LIWORK.LT.LIWKMN) THEN + INFO = INFO + 2 + END IF + RETURN + + END IF + +C Check DELTA scaling + + IF (ISODR .AND. SCLD(1,1).GT.0) THEN + IF (LDSCLD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 120 J=1,M + DO 110 I=1,LAST + IF (SCLD(I,J).LE.0) THEN + INFO = 30200 + GO TO 130 + END IF + 110 CONTINUE + 120 CONTINUE + END IF + 130 CONTINUE + +C Check BETA scaling + + IF (SCLB(1).GT.0) THEN + DO 210 K=1,NP + IF (SCLB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 30100 + ELSE + INFO = INFO + 100 + END IF + GO TO 220 + END IF + 210 CONTINUE + END IF + 220 CONTINUE + +C Check DELTA finite difference step sizes + + IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN + IF (LDSTPD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 320 J=1,M + DO 310 I=1,LAST + IF (STPD(I,J).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 32000 + ELSE + INFO = INFO + 2000 + END IF + GO TO 330 + END IF + 310 CONTINUE + 320 CONTINUE + END IF + 330 CONTINUE + +C Check BETA finite difference step sizes + + IF (ANAJAC .AND. STPB(1).GT.0) THEN + DO 410 K=1,NP + IF (STPB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 31000 + ELSE + INFO = INFO + 1000 + END IF + GO TO 420 + END IF + 410 CONTINUE + END IF + 420 CONTINUE + +C Check bounds + + IF (ANY(UPPER(1:NP).LT.LOWER(1:NP))) THEN + IF (INFO.EQ.0) THEN + INFO = 91000 + END IF + END IF + + IF (ANY((UPPER(1:NP).LT.BETA(1:NP).OR.LOWER(1:NP).GT.BETA(1:NP)) + & .AND..NOT.UPPER(1:NP).LT.LOWER(1:NP))) THEN + IF (INFO.GE.90000) THEN + INFO = INFO + 100 + ELSE + INFO = 90100 + END IF + END IF + + RETURN + END SUBROUTINE +*DODCNT + SUBROUTINE DODCNT + & (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, + & LOWER,UPPER) +C***Begin Prologue DODCNT +C***Refer to ODR +C***Routines Called DODDRV +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose REAL (KIND=R8) driver routine for finding +C the weighted explicit or implicit orthogonal distance +C regression (ODR) or ordinary linear or nonlinear least +C squares (OLS) solution +C***End Prologue DODCNT + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & PARTOL,SSTOL,TAUFAC + INTEGER + & INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + & LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),LOWER(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP), + & STPD(LDSTPD,M),UPPER(NP),WD(LDWD,LD2WD,M), + & WE(LDWE,LD2WE,NQ),WORK(LWORK),X(LDX,M),Y(LDY,NQ) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO + INTEGER + & IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, + & MAXITI,MAXIT1 + LOGICAL + & DONE,FSTITR,HEAD,IMPLCT,PRTPEN + +C...Local arrays + REAL (KIND=R8) + & PNLTY(1,1,1) + +C...External subroutines + EXTERNAL + & DODDRV + +C...External functions + +C...Data statements + DATA + & PCHECK,PSTART,PFAC,ZERO,ONE,THREE + & /1.0E3_R8,1.0E1_R8,1.0E1_R8,0.0E0_R8,1.0E0_R8,3.0E0_R8/ + +C...Routine names used as subprogram arguments +C FCN: The user-supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C CNVTOL: The convergence tolerance for implicit models. +C DONE: The variable designating whether the inplicit solution has +C been found (DONE=TRUE) or not (DONE=FALSE). +C FSTITR: The variable designating whether this is the first +C iteration (FSTITR=TRUE) or not (FSTITR=FALSE). +C HEAD: The variable designating whether the heading is to be +C printed (HEAD=TRUE) or not (HEAD=FALSE). +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INFO: The variable designating why the computations were stopped. +C IPRINT: The print control variables. +C IPRNTI: The print control variables. +C IPR1: The 1st digit of the print control variable. +C IPR2: The 2nd digit of the print control variable. +C IPR3: The 3rd digit of the print control variable. +C IPR4: The 4th digit of the print control variable. +C IWORK: The integer work space. +C JOB: The variable controling problem initialization and +C computational method. +C JOBI: The variable controling problem initialization and +C computational method. +C JOB1: The 1st digit of the variable controling problem +C initialization and computational method. +C JOB2: The 2nd digit of the variable controling problem +C initialization and computational method. +C JOB3: The 3rd digit of the variable controling problem +C initialization and computational method. +C JOB4: The 4th digit of the variable controling problem +C initialization and computational method. +C JOB5: The 5th digit of the variable controling problem +C initialization and computational method. +C LDIFX: The leading dimension of array IFIXX. +C LDSCLD: The leading dimension of array SCLD. +C LDSTPD: The leading dimension of array STPD. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LDX: The leading dimension of array X. +C LDY: The leading dimension of array Y. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C LIWORK: The length of vector IWORK. +C LOWER: The lower bound for BETA. +C LUNERR: The logical unit number used for error messages. +C LUNRPT: The logical unit number used for computation reports. +C LWORK: The length of vector work. +C M: The number of columns of data in the independent variable. +C MAXIT: The maximum number of iterations allowed. +C MAXITI: For implicit models, the number of iterations allowed for +C The current penalty parameter value. +C MAXIT1: For implicit models, the number of iterations allowed for +C the next penalty parameter value. +C N: The number of observations. +C NDIGIT: The number of accurate digits in the function results, as +C supplied by the user. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C ONE: The value 1.0E0_R8. +C PARTOL: The user supplied parameter convergence stopping tolerance. +C PCHECK: The value designating the minimum penalty parameter allowed +C before the implicit problem can be considered solved. +C PFAC: The factor for increasing the penalty parameter. +C PNLTY: The penalty parameter for an implicit model. +C PRTPEN: The value designating whether the penalty parameter is to be +C printed in the iteration report (PRTPEN=TRUE) or not +C (PRTPEN=FALSE). +C PSTART: The factor for increasing the penalty parameter. +C SCLB: The scaling values for BETA. +C SCLD: The scaling values for DELTA. +C STPB: The relative step for computing finite difference +C Derivatives with respect to BETA. +C STPD: The relative step for computing finite difference +C Derivatives with respect to DELTA. +C SSTOL: The sum-of-squares convergence stopping tolerance. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C THREE: The value 3.0E0_R8. +C TSTIMP: The relative change in the parameters between the initial +C values and the solution. +C UPPER: The upper bound for BETA. +C WD: The DELTA weights. +C WE: The EPSILON weights. +C WORK: The REAL (KIND=R8) work space. +C X: The independent variable. +C Y: The dependent variable. Unused when the model is implicit. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODCNT + + + IMPLCT = MOD(JOB,10).EQ.1 + FSTITR = .TRUE. + HEAD = .TRUE. + PRTPEN = .FALSE. + + IF (IMPLCT) THEN + +C Set up for implicit problem + + IF (IPRINT.GE.0) THEN + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + ELSE + IPR1 = 2 + IPR2 = 0 + IPR2F = 0 + IPR3 = 1 + END IF + IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 + + JOB5 = MOD(JOB,100000)/10000 + JOB4 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB2 = MOD(JOB,100)/10 + JOB1 = MOD(JOB,10) + JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 + + IF (WE(1,1,1).LE.ZERO) THEN + PNLTY(1,1,1) = -PSTART + ELSE + PNLTY(1,1,1) = -WE(1,1,1) + END IF + + IF (PARTOL.LT.ZERO) THEN + CNVTOL = EPSILON(ZERO)**(ONE/THREE) + ELSE + CNVTOL = MIN(PARTOL,ONE) + END IF + + IF (MAXIT.GE.1) THEN + MAXITI = MAXIT + ELSE + MAXITI = 100 + END IF + + DONE = MAXITI.EQ.0 + PRTPEN = .TRUE. + + 10 CONTINUE + CALL DODDRV + & (HEAD,FSTITR,PRTPEN, + & FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + & PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + & JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, + & IPRNTI,LUNERR,LUNRPT, + & STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + & WORK,LWORK,IWORK,LIWORK, + & MAXIT1,TSTIMP, INFO, LOWER,UPPER) + + IF (DONE) THEN + RETURN + ELSE + DONE = MAXIT1.LE.0 .OR. + & (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. + & TSTIMP.LE.CNVTOL) + END IF + + IF (DONE) THEN + IF (TSTIMP.LE.CNVTOL) THEN + INFO = (INFO/10)*10 + 2 + ELSE + INFO = (INFO/10)*10 + 4 + END IF + JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 + MAXITI = 0 + IPRNTI = IPR3 + ELSE + PRTPEN = .TRUE. + PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) + JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 + MAXITI = MAXIT1 + IPRNTI = 0000 + IPR2*100 + IPR2F*10 + END IF + GO TO 10 + ELSE + CALL DODDRV + & (HEAD,FSTITR,PRTPEN, + & 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, + & MAXIT1,TSTIMP, INFO, LOWER,UPPER) + END IF + + RETURN + + END SUBROUTINE +*DODDRV + SUBROUTINE DODDRV + & (HEAD,FSTITR,PRTPEN, + & 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, + & MAXIT1,TSTIMP, INFO, LOWER,UPPER) +C***Begin Prologue DODDRV +C***Refer to ODR +C***Routines Called FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS, +C DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN, +C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY, +C DERSTEP +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Perform error checking and initialization, and begin +C procedure for performing orthogonal distance regression +C (ODR) or ordinary linear or nonlinear least squares (OLS) +C***End Prologue DODDRV + +C...Used modules + USE REAL_PRECISION + USE ODRPACK95, ONLY : TEMPRET + +C...Scalar arguments + REAL (KIND=R8) + & PARTOL,SSTOL,TAUFAC,TSTIMP + INTEGER + & INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + & LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, + & N,NDIGIT,NP,NQ + LOGICAL + & FSTITR,HEAD,PRTPEN + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),LOWER(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP), + & STPD(LDSTPD,M),UPPER(NP),WE(LDWE,LD2WE,NQ), + & WD(LDWD,LD2WD,M),WORK(LWORK),X(LDX,M),Y(LDY,NQ) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & EPSMAC,ETA,P5,ONE,TEN,ZERO + INTEGER + & ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,BOUNDI,DELTAI,DELTNI, + & DELTSI, + & DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I, + & IPRINI, + & IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN,LOWERI, + & LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, + & NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, + & NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + & RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + & UPPERI, + & VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, + & WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + & ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...Local arrays + REAL (KIND=R8) + & BETAJ(NP) + INTEGER + & INTERVAL(NP) + +C...External functions + REAL (KIND=R8) + & DDOT,DNRM2,DERSTEP + EXTERNAL + & DDOT,DNRM2,DERSTEP + +C...External subroutines + EXTERNAL + & DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, + & DODMN,DODPER,DPACK,DSETN,DUNPAC,DWINF,DXMY,DXPY + +C...Data statements + DATA + & ZERO,P5,ONE,TEN + & /0.0E0_R8,0.5E0_R8,1.0E0_R8,10.0E0_R8/ + +C...Interface blocks + INTERFACE + SUBROUTINE DWGHT + & (N,M,WT,LDWT,LD2WT,T,WTT) + USE REAL_PRECISION + INTEGER + & LDWT,LD2WT,M,N + REAL (KIND=R8) + & T(:,:),WT(:,:,:),WTT(:,:) + END SUBROUTINE + END INTERFACE + +C...Routine names used as subprogram arguments +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...Variable Definitions (alphabetically) +C ACTRSI: The location in array work of variable ACTRS. +C ALPHAI: The location in array work of variable ALPHA. +C ANAJAC: The variable designating whether the Jacobians are +C computed by finite differences (ANAJAC=FALSE) or not +C (ANAJAC=TRUE). +C BETA: The function parameters. +C BETACI: The starting location in array WORK of array BETAC. +C BETAJ: The parameters to use in the derivative checking algorithm. +C BETANI: The starting location in array WORK of array BETAN. +C BETASI: The starting location in array WORK of array BETAS. +C BETA0I: The starting location in array WORK of array BETA0. +C CDJAC: The variable designating whether the Jacobians are +C Computed by central differences (CDJAC=TRUE) or forward +C differences (CDJAC=FALSE). +C CHKJAC: The variable designating whether the user supplied +C Jacobians are to be checked (CHKJAC=TRUE) or not +C (CHKJAC=FALSE). +C DELTAI: The starting location in array WORK of array DELTA. +C DELTNI: The starting location in array WORK of array DELTAN. +C DELTSI: The starting location in array WORK of array DELTAS. +C DIFFI: The starting location in array WORK of array DIFF. +C DOVCV: The variable designating whether the covariance matrix is +C to be computed (DOVCV=TRUE) or not (DOVCV=FALSE). +C EPSMAI: The location in array WORK of variable EPSMAC. +C ETA: The relative noise in the function results. +C ETAI: The location in array WORK of variable ETA. +C FI: The starting location in array WORK of array F. +C FJACBI: The starting location in array WORK of array FJACB. +C FJACDI: The starting location in array WORK of array FJACD. +C FNI: The starting location in array WORK of array FN. +C FSI: The starting location in array WORK of array FS. +C FSTITR: The variable designating whether this is the first +C iteration (FSTITR=TRUE) or not (FSTITR=FALSE). +C HEAD: The variable designating whether the heading is to be +C printed (HEAD=TRUE) or not (HEAD=FALSE). +C I: An index variable. +C IDFI: The location in array iwork of variable IDF. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INFO: The variable designating why the computations were stopped. +C INITD: The variable designating whether DELTA is to be initialized +C to zero (INITD=TRUE) or to the values in the first N by M +C elements of array WORK (INITD=FALSE). +C INT2I: The location in array IWORK of variable INT2. +C INTERVAL: Specifies which checks can be performed when checking derivatives +C based on the interval of the bound constraints. +C IPRINI: The location in array iwork of variable IPRINT. +C IPRINT: The print control variable. +C IRANKI: The location in array IWORK of variable IRANK. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C ISTOPI: The location in array IWORK of variable ISTOP. +C IWORK: The integer work space. +C JOB: The variable controling problem initialization and +C computational method. +C JOBI: The location in array IWORK of variable JOB. +C JPVTI: The starting location in array IWORK of array JPVT. +C K: An index variable. +C LDIFX: The leading dimension of array IFIXX. +C LDSCLD: The leading dimension of array SCLD. +C LDSTPD: The leading dimension of array STPD. +C LDTT: The leading dimension of array TT. +C LDTTI: The location in array IWORK of variable LDTT. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LDX: The leading dimension of array X. +C LDY: The leading dimension of array Y. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C LIWKMN: The minimum acceptable length of array IWORK. +C LIWORK: The length of vector IWORK. +C LOWER: The lower bound for BETA. +C LUNERI: The location in array IWORK of variable LUNERR. +C LUNERR: The logical unit number used for error messages. +C LUNRPI: The location in array IWORK of variable LUNRPT. +C LUNRPT: The logical unit number used for computation reports. +C LWKMN: The minimum acceptable length of array WORK. +C LWORK: The length of vector WORK. +C LWRK: The length of vector WRK. +C M: The number of columns of data in the explanatory variable. +C MAXIT: The maximum number of iterations allowed. +C MAXIT1: For implicit models, the iterations allowed for the next +C penalty parameter value. +C MAXITI: The location in array IWORK of variable MAXIT. +C MSGB: The starting location in array IWORK of array MSGB. +C MSGD: The starting location in ARRAY IWORK of array MSGD. +C N: The number of observations. +C NDIGIT: The number of accurate digits in the function results, as +C supplied by the user. +C NETA: The number of accurate digits in the function results. +C NETAI: The location in array IWORK of variable NETA. +C NFEV: The number of function evaluations. +C NFEVI: The location in array IWORK of variable NFEV. +C NITERI: The location in array IWORK of variable NITER. +C NJEV: The number of Jacobian evaluations. +C NJEVI: The location in array IWORK of variable NJEV. +C NNZW: The number of nonzero observational error weights. +C NNZWI: The location in array IWORK of variable NNZW. +C NP: The number of function parameters. +C NPP: The number of function parameters being estimated. +C NPPI: The location in array IWORK of variable NPP. +C NQ: The number of responses per observation. +C NROW: The row number at which the derivative is to be checked. +C NROWI: The location in array IWORK of variable NROW. +C NTOL: The number of digits of agreement required between the +C numerical derivatives and the user supplied derivatives, +C set by DJCK. +C NTOLI: The location in array IWORK of variable NTOL. +C OLMAVI: The location in array WORK of variable OLMAVG. +C OMEGAI: The starting location in array WORK of array OMEGA. +C ONE: The value 1.0E0_R8. +C PARTLI: The location in array WORK of variable PARTOL. +C PARTOL: The parameter convergence stopping tolerance. +C PNORM: The norm of the scaled estimated parameters. +C PNORMI: The location in array WORK of variable PNORM. +C PRERSI: The location in array WORK of variable PRERS. +C PRTPEN: The variable designating whether the penalty parameter is +C to be printed in the iteration report (PRTPEN=TRUE) or not +C (PRTPEN=FALSE). +C P5: The value 0.5E0_R8. +C QRAUXI: The starting location in array WORK of array QRAUX. +C RCONDI: The location in array WORK of variable RCOND. +C REDOJ: The variable designating whether the Jacobian matrix is to +C be recomputed for the computation of the covariance matrix +C (REDOJ=TRUE) or not (REDOJ=FALSE). +C RESTRT: The variable designating whether the call is a restart +C (RESTRT=TRUE) or not (RESTRT=FALSE). +C RNORSI: The location in array WORK of variable RNORMS. +C RVARI: The location in array WORK of variable RVAR. +C SCLB: The scaling values for BETA. +C SCLD: The scaling values for DELTA. +C SDI: The starting location in array WORK of array SD. +C SI: The starting location in array WORK of array S. +C SSFI: The starting location in array WORK of array SSF. +C SSI: The starting location in array WORK of array SS. +C SSTOL: The sum-of-squares convergence stopping tolerance. +C SSTOLI: The location in array WORK of variable SSTOL. +C STPB: The step size for finite difference derivatives wrt BETA. +C STPD: The step size for finite difference derivatives wrt DELTA. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C TAUFCI: The location in array WORK of variable TAUFAC. +C TAUI: The location in array WORK of variable TAU. +C TEN: The value 10.0E0_R8. +C TI: The starting location in array WORK of array T. +C TSTIMP: The relative change in the parameters between the initial +C values and the solution. +C TTI: The starting location in array WORK of array TT. +C UI: The starting location in array WORK of array U. +C UPPER: The upper bound for BETA. +C VCVI: The starting location in array WORK of array VCV. +C WD: The DELTA weights. +C WE: The EPSILON weights. +C WE1I: The starting location in array WORK of array WE1. +C WORK: The REAL (KIND=R8) work space. +C WRK: The starting location in array WORK of array WRK, +C equivalenced to WRK1 and WRK2. +C WRK1I: The starting location in array WORK of array WRK1. +C WRK2I: The starting location in array WORK of array WRK2. +C WRK3I: The starting location in array WORK of array WRK3. +C WRK4I: The starting location in array WORK of array WRK4. +C WRK5I: The starting location in array WORK of array WRK5. +C WRK6I: The starting location in array WORK of array WRK6. +C WRK7I: The starting location in array WORK of array WRK7. +C WSSI: The location in array WORK of variable wss. +C WSSDEI: The location in array WORK of variable WSSDEL. +C WSSEPI: The location in array WORK of variable WSSEPS. +C X: The explanatory variable. +C XPLUSI: The starting location in array WORK of array XPLUSD. +C Y: The dependent variable. Unused when the model is implicit. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODDRV + + +C Initialize necessary variables + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + & ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C Set starting locations within integer workspace +C (invalid values of M, NP and/or NQ are handled reasonably by DIWINF) + + CALL DIWINF(M,NP,NQ, + & MSGB,MSGD,JPVTI,ISTOPI, + & NNZWI,NPPI,IDFI, + & JOBI,IPRINI,LUNERI,LUNRPI, + & NROWI,NTOLI,NETAI, + & MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + & BOUNDI, + & LIWKMN) + +C Set starting locations within REAL (KIND=R8) work space +C (invalid values of N, M, NP, NQ, LDWE and/or LD2WE +C are handled reasonably by DWINF) + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + & DELTAI,FI,XPLUSI,FNI,SDI,VCVI, + & RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + & OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + & PARTLI,SSTOLI,TAUFCI,EPSMAI, + & BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + & FSI,FJACBI,WE1I,DIFFI, + & DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + & WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + & LOWERI,UPPERI, + & LWKMN) + IF (ISODR) THEN + WRK = WRK1I + LWRK = N*M*NQ + N*NQ + ELSE + WRK = WRK2I + LWRK = N*NQ + END IF + +C Update the penalty parameters +C (WE(1,1,1) is not a user supplied array in this case) + IF (RESTRT .AND. IMPLCT) THEN + WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) + WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) + END IF + + IF (RESTRT) THEN + +C Reset maximum number of iterations + + IF (MAXIT.GE.0) THEN + IWORK(MAXITI) = IWORK(NITERI) + MAXIT + ELSE + IWORK(MAXITI) = IWORK(NITERI) + 10 + END IF + + IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN + INFO = 0 + END IF + + IF (JOB.GE.0) IWORK(JOBI) = JOB + IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT + IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL + IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL + + WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ, + & RESHAPE(WORK(WE1I:WE1I+LDWE*LD2WE*NQ-1),(/LDWE,LD2WE,NQ/)), + & LDWE,LD2WE, + & RESHAPE(WORK(FI:FI+N*NQ-1),(/N,NQ/)), + & TEMPRET(1:N,1:NQ)) + WORK(FI:FI+N*NQ-1) = RESHAPE(TEMPRET(1:N,1:NQ),(/N*NQ/)) + WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + + ELSE + +C Perform error checking + + INFO = 0 + + CALL DODCHK(N,M,NP,NQ, + & ISODR,ANAJAC,IMPLCT, + & BETA,IFIXB, + & LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LDY, + & LWORK,LWKMN,LIWORK,LIWKMN, + & SCLB,SCLD,STPB,STPD, + & INFO, + & LOWER,UPPER) + IF (INFO.GT.0) THEN + GO TO 50 + END IF + +C Initialize work vectors as necessary + + DO 10 I=N*M+N*NQ+1,LWORK + WORK(I) = ZERO + 10 CONTINUE + DO 20 I=1,LIWORK + IWORK(I) = 0 + 20 CONTINUE + + CALL DINIWK(N,M,NP, + & WORK,LWORK,IWORK,LIWORK, + & X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + & BETA,SCLB, + & SSTOL,PARTOL,MAXIT,TAUFAC, + & JOB,IPRINT,LUNERR,LUNRPT, + & LOWER,UPPER, + & EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + & JOBI,IPRINI,LUNERI,LUNRPI, + & SSFI,TTI,LDTTI,DELTAI, + & LOWERI,UPPERI,BOUNDI) + + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + WORK(TAUI) = -WORK(TAUFCI) + +C Set up for parameter estimation - +C Pull BETA's to be estimated and corresponding scale values +C and store in WORK(BETACI) and WORK(SSI), respectively + + CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) + CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) + NPP = IWORK(NPPI) + +C Check that WD is positive definite and WE is positive semidefinite, +C saving factorization of WE, and counting number of nonzero weights + + CALL DFCTRW(N,M,NQ,NPP, + & ISODR, + & WE,LDWE,LD2WE,WD,LDWD,LD2WD, + & WORK(WRK2I),WORK(WRK4I), + & WORK(WE1I),NNZW,INFO) + IWORK(NNZWI) = NNZW + + IF (INFO.NE.0) THEN + GO TO 50 + END IF + +C Evaluate the predicted values and +C weighted EPSILONS at the starting point + + CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) + CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,WORK(XPLUSI), + & IFIXB,IFIXX,LDIFX, + & 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), + & ISTOP) + IWORK(ISTOPI) = ISTOP + IF (ISTOP.EQ.0) THEN + IWORK(NFEVI) = IWORK(NFEVI) + 1 + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ, + & RESHAPE(WORK(WE1I:WE1I+LDWE*LD2WE*NQ-1), + & (/LDWE,LD2WE,NQ/)),LDWE,LD2WE, + & RESHAPE(WORK(FI:FI+N*NQ-1),(/N,NQ/)), + & TEMPRET(1:N,1:NQ)) + WORK(FI:FI+N*NQ-1) = RESHAPE(TEMPRET(1:N,1:NQ),(/N*NQ/)) + ELSE + INFO = 52000 + GO TO 50 + END IF + +C Compute norm of the initial estimates + + CALL DWGHT(NPP,1,RESHAPE(WORK(SSI:SSI+NPP-1),(/NPP,1,1/)), + & NPP,1,RESHAPE(WORK(BETACI:BETACI+NPP-1),(/NPP,1/)), + & TEMPRET(1:NPP,1:1)) + WORK(WRK:WRK+NPP-1) = TEMPRET(1:NPP,1) + IF (ISODR) THEN + CALL DWGHT(N,M,RESHAPE(WORK(TTI:TTI+IWORK(LDTTI)*1*M-1), + & (/IWORK(LDTTI),1,M/)),IWORK(LDTTI),1, + & RESHAPE(WORK(DELTAI:DELTAI+N*M-1),(/N,M/)), + & TEMPRET(1:N,1:M)) + WORK(WRK+NPP:WRK+NPP+N*M-1) = + & RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1) + ELSE + WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1) + END IF + +C Compute sum of squares of the weighted EPSILONS and weighted DELTAS + + WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD, + & RESHAPE(WORK(DELTAI:DELTAI+N*M),(/N,M/)), + & TEMPRET(1:N,1:M)) + WORK(WRK:WRK+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1) + ELSE + WORK(WSSDEI) = ZERO + END IF + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + +C Select first row of X + DELTA that contains no zeros + + NROW = -1 + CALL DSETN(N,M,WORK(XPLUSI),N,NROW) + IWORK(NROWI) = NROW + +C Set number of good digits in function results + + EPSMAC = WORK(EPSMAI) + IF (NDIGIT.LT.2) THEN + IWORK(NETAI) = -1 + NFEV = IWORK(NFEVI) + CALL DETAF(FCN, + & N,M,NP,NQ, + & WORK(XPLUSI),BETA,EPSMAC,NROW, + & WORK(BETANI),WORK(FNI), + & IFIXB,IFIXX,LDIFX, + & ISTOP,NFEV,ETA,NETA, + & WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I), + & INFO, + & LOWER,UPPER) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IF (ISTOP.NE.0.OR.INFO.NE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 53000 + END IF + IWORK(NETAI) = 0 + WORK(ETAI) = ZERO + GO TO 50 + ELSE + IWORK(NETAI) = -NETA + WORK(ETAI) = ETA + END IF + ELSE + IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) + WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) + END IF + +C Check bounds are large enough for derivative calculations. + + IF (.NOT.ANAJAC .OR. CHKJAC) THEN + IF (CDJAC) THEN + DO K=1,NP + IF (UPPER(K)- + & ABS(2*DERSTEP(1,K,UPPER(K),WORK(SSFI),STPB,NETA)) + & .LT.LOWER(K) + & ) THEN + INFO = 90020 + GO TO 50 + END IF + END DO + ELSE + DO K=1,NP + IF (UPPER(K)- + & ABS(2*DERSTEP(0,K,UPPER(K),WORK(SSFI),STPB,NETA)) + & .LT.LOWER(K) + & ) THEN + INFO = 90020 + GO TO 50 + END IF + END DO + END IF + END IF + +C CHECK DERIVATIVES IF NECESSARY + + IF (CHKJAC .AND. ANAJAC) THEN + NTOL = -1 + NFEV = IWORK(NFEVI) + NJEV = IWORK(NJEVI) + NETA = IWORK(NETAI) + LDTT = IWORK(LDTTI) + ETA = WORK(ETAI) + EPSMAC = WORK(EPSMAI) +C ENSURE BETA IS NOT TOO CLOSE TO BOUNDS FOR THE DERIVATIVE CHECK. + BETAJ(:) = BETA(:) + CALL MBFB(NP,BETAJ,LOWER,UPPER,WORK(SSFI),STPB,NETA,ETA, + & INTERVAL) +C CHECK THE DERIVATIVES. + CALL DJCK(FCN, + & N,M,NP,NQ, + & BETA,BETAJ,WORK(XPLUSI), + & IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + & WORK(SSFI),WORK(TTI),LDTT, + & ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + & WORK(FNI),WORK(FJACBI),WORK(FJACDI), + & IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), + & ISTOP,NFEV,NJEV, + & WORK(WRK1I),WORK(WRK2I),WORK(WRK6I), + & INTERVAL) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NJEVI) = NJEV + IWORK(NTOLI) = NTOL + IF (ISTOP.NE.0) THEN + INFO = 54000 + ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN + INFO = 40000 + END IF + ELSE + +C Indicate user supplied derivatives were not checked + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + END IF + +C Print appropriate error messages + + 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN + IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN + CALL DODPER + & (INFO,LUNERR, + & N,M,NP,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LWKMN,LIWKMN, + & WORK(FJACBI),WORK(FJACDI), + & WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), + & WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) + END IF + +C Set INFO to reflect errors in the user supplied Jacobians + + IF (INFO.EQ.40000) THEN + IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN + IF (IWORK(MSGB).EQ.2) THEN + INFO = INFO + 1000 + END IF + IF (IWORK(MSGD).EQ.2) THEN + INFO = INFO + 100 + END IF + ELSE + INFO = 0 + END IF + END IF + IF (INFO.NE.0) THEN + RETURN + END IF + END IF + END IF + +C Save the initial values of BETA + CALL DCOPY(NP,BETA,1,WORK(BETA0I),1) + +C Find least squares solution + + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1) + LDTT = IWORK(LDTTI) + CALL DODMN(HEAD,FSTITR,PRTPEN, + & FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + & WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, + & IFIXB,IFIXX,LDIFX, + & WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), + & WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + & WORK(LOWERI),WORK(UPPERI), + & WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + & WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), + & WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + & STPB,STPD,LDSTPD, + & WORK(XPLUSI),WORK(WRK),LWRK, + & WORK,LWORK,IWORK,LIWORK,INFO, + & IWORK(BOUNDI)) + MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) + TSTIMP = ZERO + DO 100 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + TSTIMP = MAX(TSTIMP, + & ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) + ELSE + TSTIMP = MAX(TSTIMP, + & ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) + END IF + 100 CONTINUE + + RETURN + + END SUBROUTINE +*DODLM + SUBROUTINE DODLM + & (N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + & ALPHA2,TAU,EPSFCN,ISODR, + & TFJACB,OMEGA,U,QRAUX,JPVT, + & S,T,NLMS,RCOND,IRANK, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***Begin Prologue DODLM +C***Refer to ODR +C***Routines Called DDOT,DNRM2,DODSTP,DSCALE,DWGHT +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute Levenberg-Marquardt parameter and steps S AND T +C using analog of the trust-region Levenberg-Marquardt +C algorithm +C***End Prologue DODLM + +C...Used modules + USE REAL_PRECISION + USE ODRPACK95, ONLY : TEMPRET + +C...Scalar arguments + REAL (KIND=R8) + & ALPHA2,EPSFCN,RCOND,TAU + INTEGER + & IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + & OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + & T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + & WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) + INTEGER + & JPVT(NP) + +C...Local scalars + REAL (KIND=R8) + & ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO + INTEGER + & I,IWRK,J,K,L + LOGICAL + & FORVCV + +C...External functions + REAL (KIND=R8) + & DDOT,DNRM2 + EXTERNAL + & DDOT,DNRM2 + +C...External subroutines + EXTERNAL + & DODSTP,DSCALE + +C...Data statements + DATA + & ZERO,P001,P1 + & /0.0E0_R8,0.001E0_R8,0.1E0_R8/ + +C...Interface blocks + INTERFACE + SUBROUTINE DWGHT + & (N,M,WT,LDWT,LD2WT,T,WTT) + USE REAL_PRECISION + INTEGER + & LDWT,LD2WT,M,N + REAL (KIND=R8) + & T(:,:),WT(:,:,:),WTT(:,:) + END SUBROUTINE + END INTERFACE + +C...Variable Definitions (alphabetically) +C ALPHAN: The new Levenberg-Marquardt parameter. +C ALPHA1: The previous Levenberg-Marquardt parameter. +C ALPHA2: The current Levenberg-Marquardt parameter. +C BOT: The lower limit for setting ALPHA. +C DELTA: The estimated errors in the explanatory variables. +C EPSFCN: The function's precision. +C F: The (weighted) estimated values of EPSILON. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FORVCV: The variable designating whether this subroutine was +C called to set up for the covariance matrix computations +C (FORVCV=TRUE) or not (FORVCV=FALSE). +C I: An indexing variable. +C IRANK: The rank deficiency of the Jacobian wrt BETA. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOPC: The variable designating whether the computations were +C stoped due to some numerical error detected within +C subroutine DODSTP. +C IWRK: An indexing variable. +C J: An indexing variable. +C K: An indexing variable. +C L: An indexing variable. +C JPVT: The pivot vector. +C LDTT: The leading dimension of array TT. +C LDWD: The leading dimension of array WD. +C LD2WD: The second dimension of array WD. +C LWRK: The length of vector WRK. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NLMS: The number of Levenberg-Marquardt steps taken. +C NP: The number of function parameters. +C NPP: The number of function parameters being estimated. +C NQ: The number of responses per observation. +C OMEGA: The array (I-FJACD*INV(P)*trans(FJACD))**(-1/2) where +C P = trans(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C P001: The value 0.001E0_R8 +C P1: The value 0.1E0_R8 +C PHI1: The previous difference between the norm of the scaled step +C and the trust region diameter. +C PHI2: The current difference between the norm of the scaled step +C and the trust region diameter. +C QRAUX: The array required to recover the orthogonal part of the +C Q-R decomposition. +C RCOND: The approximate reciprocal condition of TFJACB. +C S: The step for BETA. +C SA: The scalar PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). +C SS: The scaling values used for the unfixed BETAS. +C T: The step for DELTA. +C TAU: The trust region diameter. +C TFJACB: The array OMEGA*FJACB. +C TOP: The upper limit for setting ALPHA. +C TT: The scale used for the DELTA'S. +C U: The approximate null vector for TFJACB. +C WD: The DELTA weights. +C WRK: A work array of (LWRK) elements, +C equivalenced to WRK1 and WRK2. +C WRK1: A work array of (N by NQ by M) elements. +C WRK2: A work array of (N by NQ) elements. +C WRK3: A work array of (NP) elements. +C WRK4: A work array of (M by M) elements. +C WRK5: A work array of (M) elements. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODLM + + FORVCV = .FALSE. + ISTOPC = 0 + +C Compute full Gauss-Newton step (ALPHA=0) + + ALPHA1 = ZERO + CALL DODSTP(N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + & ALPHA1,EPSFCN,ISODR, + & TFJACB,OMEGA,U,QRAUX,JPVT, + & S,T,PHI1,IRANK,RCOND,FORVCV, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + +C Initialize TAU if necessary + + IF (TAU.LT.ZERO) THEN + TAU = ABS(TAU)*PHI1 + END IF + +C Check if full Gauss-Newton step is optimal + + IF ((PHI1-TAU).LE.P1*TAU) THEN + NLMS = 1 + ALPHA2 = ZERO + RETURN + END IF + +C Full Gauss-Newton step is outside trust region - +C find locally constrained optimal step + + PHI1 = PHI1 - TAU + +C Initialize upper and lower bounds for ALPHA + + BOT = ZERO + + DO 30 K=1,NPP + DO 20 L=1,NQ + DO 10 I=1,N + TFJACB(I,L,K) = FJACB(I,K,L) + 10 CONTINUE + 20 CONTINUE + WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1) + 30 CONTINUE + CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) + + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,TEMPRET(1:N,1:M)) + WRK(NPP+1:NPP+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + IWRK = NPP + DO 50 J=1,M + DO 40 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = WRK(IWRK) + + & DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N) + 40 CONTINUE + 50 CONTINUE + CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) + TOP = DNRM2(NPP+N*M,WRK,1)/TAU + ELSE + TOP = DNRM2(NPP,WRK,1)/TAU + END IF + + IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN + ALPHA2 = P001*TOP + END IF + +C Main loop + + DO 60 I=1,10 + +C Compute locally constrained steps S and T and PHI(ALPHA) for +C current value of ALPHA + + CALL DODSTP(N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + & ALPHA2,EPSFCN,ISODR, + & TFJACB,OMEGA,U,QRAUX,JPVT, + & S,T,PHI2,IRANK,RCOND,FORVCV, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + PHI2 = PHI2-TAU + +C Check whether current step is optimal + + IF (ABS(PHI2).LE.P1*TAU .OR. + & (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN + NLMS = I+1 + RETURN + END IF + +C Current step is not optimaL + +C Update bounds for ALPHA and compute new ALPHA + + IF (PHI1-PHI2.EQ.ZERO) THEN + NLMS = 12 + RETURN + END IF + SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) + IF (PHI2.LT.ZERO) THEN + TOP = MIN(TOP,ALPHA2) + ELSE + BOT = MAX(BOT,ALPHA2) + END IF + IF (PHI1*PHI2.GT.ZERO) THEN + BOT = MAX(BOT,ALPHA2-SA) + ELSE + TOP = MIN(TOP,ALPHA2-SA) + END IF + + ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU + IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN + ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) + END IF + +C Get ready for next iteration + + ALPHA1 = ALPHA2 + ALPHA2 = ALPHAN + PHI1 = PHI2 + 60 CONTINUE + +C Set NLMS to indicate an optimal step could not be found in 10 trys + + NLMS = 12 + + RETURN + END SUBROUTINE +*DODMN + SUBROUTINE DODMN + & (HEAD,FSTITR,PRTPEN, + & FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + & WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, + & IFIXB,IFIXX,LDIFX, + & BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, + & LOWER,UPPER, + & T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, + & SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, + & XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO, + & BOUND) +C***Begin Prologue DODMN +C***Refer to ODR +C***Routines Called FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM, +C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Iteratively compute least squares solution +C***End Prologue DODMN + +C...Used modules + USE REAL_PRECISION + USE ODRPACK95, ONLY : TEMPRET + +C...Scalar arguments + INTEGER + & INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + & LIWORK,LWORK,LWRK,M,N,NP,NQ + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + & DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + & F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), + & LOWER(NP), + & S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), + & T(N,M),TT(LDTT,M), + & UPPER(NP), + & WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), + & WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) + INTEGER + & BOUND(NP),IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), + & MSGB(NQ*NP+1),MSGD(NQ*M+1) + LOGICAL + & FSTITR,HEAD,PRTPEN + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, + & P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + & RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, + & TEMP,TEMP1,TEMP2,TSNORM,ZERO + INTEGER + & I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, + & ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, + & MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,NPU,OMEGA,QRAUX, + & SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + & ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, + & IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT + +C...Local arrays + REAL (KIND=R8) + & LOWERU(NP),UPPERU(NP),WSS(3) + +C...External functions + REAL (KIND=R8) + & DDOT,DNRM2 + EXTERNAL + & DDOT,DNRM2 + +C...External subroutines + EXTERNAL + & DACCES,DCOPY,DEVJAC,DFLAGS, + & DODLM,DODPCR,DODVCV,DUNPAC,DXMY,DXPY + +C...Data statements + DATA + & ZERO,P0001,P1,P25,P5,P75,ONE + & /0.0E0_R8,0.00010E0_R8,0.10E0_R8,0.250E0_R8, + & 0.50E0_R8,0.750E0_R8,1.0E0_R8/ + DATA + & LUDFLT + & /6/ + +C...Interface blocks + INTERFACE + SUBROUTINE DWGHT + & (N,M,WT,LDWT,LD2WT,T,WTT) + USE REAL_PRECISION + INTEGER + & LDWT,LD2WT,M,N + REAL (KIND=R8) + & T(:,:),WT(:,:,:),WTT(:,:) + END SUBROUTINE + END INTERFACE + +C...Routine names used as subprogram arguments +C FCN: The user supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C ACCESS: The variable designating whether information is to be +C accessed from the work arrays (ACCESS=TRUE) or stored in +C them (ACCESS=FALSE). +C ACTRED: The actual relative reduction in the sum-of-squares. +C ACTRS: The saved actual relative reduction in the sum-of-squares. +C ALPHA: The Levenberg-Marquardt parameter. +C ANAJAC: The variable designating whether the Jacobians are computed +C by finite differences (ANAJAC=FALSE) or not (ANAJAC=TRUE). +C BETA: The function parameters. +C BETAC: The current estimated values of the unfixed BETA'S. +C BETAN: The new estimated values of the unfixed BETA'S. +C BETAS: The saved estimated values of the unfixed BETA'S. +C CDJAC: The variable designating whether the Jacobians are computed +C by central differences (cdjac=true) or by forward +C differences (CDJAC=FALSE). +C CHKJAC: The variable designating whether the user supplied +C Jacobians are to be checked (CHKJAC=TRUE) or not +C (CHKJAC=FALSE). +C CNVPAR: The variable designating whether parameter convergence was +C attained (CNVPAR=TRUE) or not (CNVPAR=FALSE). +C CNVSS: The variable designating whether sum-of-squares convergence +C was attained (CNVSS=TRUE) or not (CNVSS=FALSE). +C DELTA: The estimated errors in the explanatory variables. +C DELTAN: The new estimated errors in the explanatory variables. +C DELTAS: The saved estimated errors in the explanatory variables. +C DIDVCV: The variable designating whether the covariance matrix was +C computed (DIDVCV=TRUE) or not (DIDVCV=FALSE). +C DIRDER: The directional derivative. +C DOVCV: The variable designating whether the covariance matrix +C should to be computed (DOVCV=TRUE) or not (DOVCV=FALSE). +C ETA: The relative noise in the function results. +C F: The (weighted) estimated values of EPSILON. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FN: The new predicted values from the function. +C FS: The saved predicted values from the function. +C FSTITR: The variable designating whether this is the first +C iteration (FSTITR=TRUE) or not (FSTITR=FALSE). +C HEAD: The variable designating whether the heading is to be +C printed (HEAD=TRUE) or not (HEAD=FALSE). +C I: An indexing variable. +C IDF: The degrees of freedom of the fit, equal to the number of +C observations with nonzero weighted derivatives minus the +C number of parameters being estimated. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C IFLAG: The variable designating which report is to be printed. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INFO: The variable designating why the computations were stopped. +C INITD: The variable designating whether delta is initialized to +C zero (INITD=TRUE) or to the values in the first N by M +C elements of array work (INITD=FALSE). +C INT2: The number of internal doubling steps taken. +C INTDBL: The variable designating whether internal doubling is to be +C used (INTDBL=TRUE) or NOT (INTDBL=FALSE). +C IPR: The values designating the length of the printed report. +C IPR1: The value of the 4th digit (from the right) of iprint, +C which controls the initial summary report. +C IPR2: The value of the 3rd digit (from the right) of iprint, +C which controls the iteration report. +C IPR2F: The value of the 2nd digit (from the right) of iprint, +C which controls the frequency of the iteration reports. +C IPR3: The value of the 1st digit (from the right) of iprint, +C which controls the final summary report. +C IRANK: The rank deficiency of the Jacobian wrt BETA. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or OLS (ISODR=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C ISTOPC: The variable designating whether the computations were +C stoped due to some numerical error within routine DODSTP. +C IWORK: The integer work space. +C IWRK: An index variable. +C J: An index variable. +C JOB: The variable controling problem initialization and +C computational method. +C JPVT: The starting location in IWORK of array JPVT. +C L: An index variable. +C LDIFX: The leading dimension of array IFIXX. +C LDTT: The leading dimension of array TT. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE and WE1. +C LDX: The leading dimension of array X. +C LDY: The leading dimension of array Y. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE and WE1. +C LIWORK: The length of vector IWORK. +C LOOPED: A counter used to determine how many times the subloop +C has been executed, where if the count becomes large +C enough the computations will be stopped. +C LOWERU: The lower bound for unfixed BETAs. +C LSTEP: The variable designating whether a successful step has +C been found (LSTEP=TRUE) or not (LSTEP=FALSE). +C LUDFLT: The default logical unit number, used for computation +C reports to the screen. +C LUNR: The logical unit number used for computation reports. +C LUNRPT: The logical unit number used for computation reports. +C LWORK: The length of vector WORK. +C LWRK: The length of vector WRK. +C M: The number of columns of data in the explanatory variable. +C MAXIT: The maximum number of iterations allowed. +C MSGB: The error checking results for the Jacobian wrt BETA. +C MSGD: The error checking results for the Jacobian wrt DELTA. +C N: The number of observations. +C NETA: The number of accurate digits in the function results. +C NFEV: The number of function evaluations. +C NITER: The number of iterations taken. +C NJEV: The number of Jacobian evaluations. +C NLMS: The number of Levenberg-Marquardt steps taken. +C NNZW: The number of nonzero weighted observations. +C NP: The number of function parameters. +C NPP: The number of function parameters being estimated. +C NPR: The number of times the report is to be written. +C NPU: The number of unfixed parameters. +C NQ: The number of responses per observation. +C OLMAVG: The average number of Levenberg-Marquardt steps per +C iteration. +C OMEGA: The starting location in WORK of array OMEGA. +C ONE: The value 1.0E0_R8. +C P0001: The value 0.0001E0_R8. +C P1: The value 0.1E0_R8. +C P25: The value 0.25E0_R8. +C P5: The value 0.5E0_R8. +C P75: The value 0.75E0_R8. +C PARTOL: The parameter convergence stopping tolerance. +C PNORM: The norm of the scaled estimated parameters. +C PRERED: The predicted relative reduction in the sum-of-squares. +C PRERS: The old predicted relative reduction in the sum-of-squares. +C PRTPEN: The value designating whether the penalty parameter is to +C be printed in the iteration report (PRTPEN=TRUE) or not +C (PRTPEN=FALSE). +C QRAUX: The starting location in array WORK of array QRAUX. +C RATIO: The ratio of the actual relative reduction to the predicted +C relative reduction in the sum-of-squares. +C RCOND: The approximate reciprocal condition of FJACB. +C REDOJ: The variable designating whether the Jacobian matrix is to +C be recomputed for the computation of the covariance matrix +C (REDOJ=TRUE) or not (REDOJ=FALSE). +C RESTRT: The variable designating whether the call is a restart +C (RESTRT=TRUE) or not (RESTRT=FALSE). +C RNORM: The norm of the weighted errors. +C RNORMN: The new norm of the weighted errors. +C RNORMS: The saved norm of the weighted errors. +C RSS: The residual sum of squares. +C RVAR: The residual variance. +C S: The step for BETA. +C SD: The starting location in array work of array SD. +C SS: The scaling values used for the unfixed BETAS. +C SSF: The scaling values used for BETA. +C SSTOL: The sum-of-squares convergence stopping tolerance. +C STPB: The relative step used for computing finite difference +C derivatives with respect to each BETA. +C STPD: The relative step used for computing finite difference +C derivatives with respect to DELTA. +C T: The step for DELTA. +C TAU: The trust region diameter. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C TEMP: A temporary storage location. +C TEMP1: A temporary storage location. +C TEMP2: A temporary storage location. +C TSNORM: The norm of the scaled step. +C TT: The scaling values used for DELTA. +C U: The starting location in array WORK of array U. +C UPPERU: The upper bound for unfixed BETAs. +C VCV: The starting location in array WORK of array VCV. +C WE: The EPSILON weights. +C WE1: The square root of the EPSILON weights. +C WD: The DELTA weights. +C WORK: The REAL (KIND=R8) work space. +C WSS: The sum-of-squares of the weighted EPSILONS and DELTAS, +C the sum-of-squares of the weighted DELTAS, and +C the sum-of-squares of the weighted EPSILONS. +C WRK: A work array, equivalenced to WRK1 and WRK2 +C WRK1: The starting location in array WORK of array WRK1. +C WRK2: The starting location in array WORK of array WRK2. +C WRK3: The starting location in array WORK of array WRK3. +C WRK4: The starting location in array WORK of array WRK4. +C WRK5: The starting location in array WORK of array WRK5. +C WRK6: The starting location in array WORK of array WRK6. +C X: The explanatory variable. +C XPLUSD: The values of X + DELTA. +C Y: The dependent variable. Unused when the model is implicit. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODMN + + +C Initialize necessary variables + + CALL DPACK(NP,NPU,LOWERU,LOWER,IFIXB) + CALL DPACK(NP,NPU,UPPERU,UPPER,IFIXB) + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + & ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + ACCESS = .TRUE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + & WORK,LWORK,IWORK,LIWORK, + & ACCESS,ISODR, + & JPVT,OMEGA,U,QRAUX,SD,VCV, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + & NNZW,NPP, + & JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + & LUNRPT,IPR1,IPR2,IPR2F,IPR3, + & WSS,RVAR,IDF, + & TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + & RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + RNORM = SQRT(WSS(1)) + + DIDVCV = .FALSE. + INTDBL = .FALSE. + LSTEP = .TRUE. + +C Print initial summary if desired + + IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 1 + IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR1.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR1,2) + END IF + LUNR = LUNRPT + DO 10 I=1,NPR + CALL DODPCR(IPR,LUNR, + & HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + & N,M,NP,NQ,NPP,NNZW, + & MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + & WE,LDWE,LD2WE,WD,LDWD,LD2WD, + & IFIXB,IFIXX,LDIFX, + & LOWER,UPPER, + & SSF,TT,LDTT,STPB,STPD,LDSTPD, + & JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + & WSS,RVAR,IDF,WORK(SD), + & NITER,NFEV,NJEV,ACTRED,PRERED, + & TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR1.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 10 CONTINUE + + END IF + +C Stop if initial estimates are exact solution + + IF (RNORM.EQ.ZERO) THEN + INFO = 1 + OLMAVG = ZERO + ISTOP = 0 + GO TO 150 + END IF + +C Stop if number of iterations already equals maximum permitted + + IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN + ISTOP = 0 + GO TO 150 + ELSE IF (NITER.GE.MAXIT) THEN + INFO = 4 + ISTOP = 0 + GO TO 150 + END IF + +C Main loop + + 100 CONTINUE + + NITER = NITER + 1 + RNORMS = RNORM + LOOPED = 0 + +C Evaluate jacobian using best estimate of function (FS) + + IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN + ISTOP = 0 + ELSE + CALL DEVJAC(FCN, + & ANAJAC,CDJAC, + & N,M,NP,NQ, + & BETAC,BETA,STPB, + & IFIXB,IFIXX,LDIFX, + & X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + & SSF,TT,LDTT,NETA,FS, + & T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + & FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + & NJEV,NFEV,ISTOP,INFO, + & LOWER,UPPER) + END IF + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + +C Sub loop for +C internal doubling or +C computing new step when old failed + + 110 CONTINUE + +C Compute steps S and T + + IF (LOOPED.GT.100) THEN + INFO = 60000 + GO TO 200 + ELSE + LOOPED = LOOPED + 1 + CALL DODLM(N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + & ALPHA,TAU,ETA,ISODR, + & WORK(WRK6),WORK(OMEGA), + & WORK(U),WORK(QRAUX),IWORK(JPVT), + & S,T,NLMS,RCOND,IRANK, + & WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + & WORK(WRK5),WRK,LWRK,ISTOPC) + END IF + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + OLMAVG = OLMAVG+NLMS + +C Compute BETAN = BETAC + S +C DELTAN = DELTA + T + + CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) + IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) + +C Project the step wrt the bounds + DO I = 1, NPU + IF (LOWERU(I).EQ.UPPERU(I)) THEN + BETAN(I) = UPPERU(I) + S(I) = UPPERU(I)-BETAC(I) + BOUND(I) = 3 + ELSE IF (BETAN(I).LE.LOWERU(I)) THEN + BETAN(I) = LOWERU(I) + S(I) = LOWERU(I)-BETAC(I) + BOUND(I) = 2 + ELSE IF (BETAN(I).GE.UPPERU(I)) THEN + BETAN(I) = UPPERU(I) + S(I) = UPPERU(I)-BETAC(I) + BOUND(I) = 1 + ELSE + BOUND(I) = 0 + END IF + END DO + +C Compute norm of scaled steps S and T (TSNORM) + + CALL DWGHT(NPP,1,RESHAPE(SS,(/NPP,1,1/)),NPP,1, + & RESHAPE(S,(/NPP,1/)),TEMPRET(1:NPP,1:1)) + WRK(1:NPP) = TEMPRET(1:NPP,1) + IF (ISODR) THEN + CALL DWGHT(N,M,RESHAPE(TT,(/LDTT,1,M/)),LDTT,1, + & T,TEMPRET(1:N,1:M)) + WRK(NPP+1:NPP+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + TSNORM = DNRM2(NPP+N*M,WRK,1) + ELSE + TSNORM = DNRM2(NPP,WRK,1) + END IF + +C Compute scaled predicted reduction + + IWRK = 0 + DO 130 L=1,NQ + DO 120 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1) + IF (ISODR) WRK(IWRK) = WRK(IWRK) + + & DDOT(M,FJACD(I,1,L),N,T(I,1),N) + 120 CONTINUE + 130 CONTINUE + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,T,TEMPRET(1:N,1:M)) + WRK(N*NQ+1:N*NQ+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1) + TEMP1 = SQRT(TEMP1)/RNORM + ELSE + TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM + END IF + TEMP2 = SQRT(ALPHA)*TSNORM/RNORM + PRERED = TEMP1**2+TEMP2**2/P5 + + DIRDER = -(TEMP1**2+TEMP2**2) + +C Evaluate predicted values at new point + + CALL DUNPAC(NP,BETAN,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 002,FN,WORK(WRK6),WORK(WRK1), + & ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + END IF + + IF (ISTOP.LT.0) THEN + +C Set INFO to indicate user has stopped the computations in FCN + + INFO = 51000 + GO TO 200 + ELSE IF (ISTOP.GT.0) THEN + +C Set norm to indicate step should be rejected + + RNORMN = RNORM/(P1*P75) + ELSE + +C Compute norm of new weighted EPSILONS and weighted DELTAS (RNORMN) + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FN,1,WRK,1) + ELSE + CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,RESHAPE(WRK,(/N,NQ/)), + & TEMPRET(1:N,1:NQ)) + WRK(1:N*NQ) = RESHAPE(TEMPRET(1:N,1:NQ),(/N*NQ/)) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,TEMPRET(1:N,1:M)) + WRK(N*NQ+1:N*NQ+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + + & DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1)) + ELSE + RNORMN = DNRM2(N*NQ,WRK,1) + END IF + END IF + +C Compute scaled actual reduction + + IF (P1*RNORMN.LT.RNORM) THEN + ACTRED = ONE - (RNORMN/RNORM)**2 + ELSE + ACTRED = -ONE + END IF + +C Compute ratio of actual reduction to predicted reduction + + IF(PRERED .EQ. ZERO) THEN + RATIO = ZERO + ELSE + RATIO = ACTRED/PRERED + END IF + +C Check on lack of reduction in internal doubling case + + IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN + ISTOP = 0 + TAU = TAU*P5 + ALPHA = ALPHA/P5 + CALL DCOPY(NPP,BETAS,1,BETAN,1) + CALL DCOPY(N*M,DELTAS,1,DELTAN,1) + CALL DCOPY(N*NQ,FS,1,FN,1) + ACTRED = ACTRS + PRERED = PRERS + RNORMN = RNORMS + RATIO = P5 + END IF + +C Update step bound + + INTDBL = .FALSE. + IF (RATIO.LT.P25) THEN + IF (ACTRED.GE.ZERO) THEN + TEMP = P5 + ELSE + TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) + END IF + IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN + TEMP = P1 + END IF + TAU = TEMP*MIN(TAU,TSNORM/P1) + ALPHA = ALPHA/TEMP + + ELSE IF (ALPHA.EQ.ZERO) THEN + TAU = TSNORM/P5 + + ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN + +C Step qualifies for internal doubling +C - Update TAU and ALPHA +C - Save information for current point + + INTDBL = .TRUE. + + TAU = TSNORM/P5 + ALPHA = ALPHA*P5 + + CALL DCOPY(NPP,BETAN,1,BETAS,1) + CALL DCOPY(N*M,DELTAN,1,DELTAS,1) + CALL DCOPY(N*NQ,FN,1,FS,1) + ACTRS = ACTRED + PRERS = PRERED + RNORMS = RNORMN + END IF + +C If internal doubling, skip convergence checks + + IF (INTDBL .AND. TAU.GT.ZERO) THEN + INT2 = INT2+1 + GO TO 110 + END IF + +C Check acceptance + + IF (RATIO.GE.P0001) THEN + CALL DCOPY(N*NQ,FN,1,FS,1) + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,TEMPRET(1:N,1:NQ)) + F(1:N,1:NQ) = TEMPRET(1:N,1:NQ) + CALL DCOPY(NPP,BETAN,1,BETAC,1) + CALL DCOPY(N*M,DELTAN,1,DELTA,1) + RNORM = RNORMN + CALL DWGHT(NPP,1,RESHAPE(SS,(/NPP,1,1/)),NPP,1, + & RESHAPE(BETAC,(/NPP,1/)),TEMPRET(1:NPP,1:1)) + WRK(1:NPP) = TEMPRET(1:NPP,1) + IF (ISODR) THEN + CALL DWGHT(N,M,RESHAPE(TT,(/LDTT,1,M/)),LDTT,1, + & DELTA,TEMPRET(1:N,1:M)) + WRK(NPP+1:NPP+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + PNORM = DNRM2(NPP+N*M,WRK,1) + ELSE + PNORM = DNRM2(NPP,WRK,1) + END IF + LSTEP = .TRUE. + ELSE + LSTEP = .FALSE. + END IF + +C TEST CONVERGENCE + + INFO = 0 + CNVSS = RNORM.EQ.ZERO + & .OR. + & (ABS(ACTRED).LE.SSTOL .AND. + & PRERED.LE.SSTOL .AND. + & P5*RATIO.LE.ONE) + CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) + IF (CNVSS) INFO = 1 + IF (CNVPAR) INFO = 2 + IF (CNVSS .AND. CNVPAR) INFO = 3 + +C Print iteration report + + IF (INFO.NE.0 .OR. LSTEP) THEN + IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN + IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN + IFLAG = 2 + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + WSS(1) = RNORM*RNORM + IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR2.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR2,2) + END IF + LUNR = LUNRPT + DO 140 I=1,NPR + CALL DODPCR(IPR,LUNR, + & HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + & N,M,NP,NQ,NPP,NNZW, + & MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + & WE,LDWE,LD2WE,WD,LDWD,LD2WD, + & IFIXB,IFIXX,LDIFX, + & LOWER,UPPER, + & SSF,TT,LDTT,STPB,STPD,LDSTPD, + & JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + & WSS,RVAR,IDF,WORK(SD), + & NITER,NFEV,NJEV,ACTRED,PRERED, + & TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR2.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 140 CONTINUE + FSTITR = .FALSE. + PRTPEN = .FALSE. + END IF + END IF + END IF + +C Check if finished + + IF (INFO.EQ.0) THEN + IF (LSTEP) THEN + +C Begin next interation unless a stopping criteria has been met + + IF (NITER.GE.MAXIT) THEN + INFO = 4 + ELSE + GO TO 100 + END IF + ELSE + +C Step failed - recompute unless a stopping criteria has been met + + GO TO 110 + END IF + END IF + + 150 CONTINUE + + IF (ISTOP.GT.0) INFO = INFO + 100 + +C Store unweighted EPSILONS and X+DELTA to return to user + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C Compute covariance matrix of estimated parameters +C in upper NP by NP portion of WORK(VCV) if requested + + IF (DOVCV .AND. ISTOP.EQ.0) THEN + +C Re-evaluate Jacobian at final solution, if requested +C Otherwise, Jacobian from beginning of last iteration will be used +C to compute covariance matrix + + IF (REDOJ) THEN + CALL DEVJAC(FCN, + & ANAJAC,CDJAC, + & N,M,NP,NQ, + & BETAC,BETA,STPB, + & IFIXB,IFIXX,LDIFX, + & X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + & SSF,TT,LDTT,NETA,FS, + & T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + & FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + & NJEV,NFEV,ISTOP,INFO, + & LOWER,UPPER) + + + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + END IF + + IF (IMPLCT) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,TEMPRET(1:N,1:M)) + WRK(N*NQ+1:N*NQ+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + RSS = RNORM*RNORM + END IF + IF (REDOJ .OR. NITER.GE.1) THEN + CALL DODVCV(N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + & ETA,ISODR, + & WORK(VCV),WORK(SD), + & WORK(WRK6),WORK(OMEGA), + & WORK(U),WORK(QRAUX),IWORK(JPVT), + & S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + & WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + & WORK(WRK5),WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + DIDVCV = .TRUE. + END IF + + END IF + +C Set JPVT to indicate dropped, fixed and estimated parameters + + 200 DO 210 I=0,NP-1 + WORK(WRK3+I) = IWORK(JPVT+I) + IWORK(JPVT+I) = -2 + 210 CONTINUE + IF (REDOJ .OR. NITER.GE.1) THEN + DO 220 I=0,NPP-1 + J = WORK(WRK3+I) - 1 + IF (I.LE.NPP-IRANK-1) THEN + IWORK(JPVT+J) = 1 + ELSE + IWORK(JPVT+J) = -1 + END IF + 220 CONTINUE + IF (NPP.LT.NP) THEN + J = NPP-1 + DO 230 I=NP-1,0,-1 + IF (IFIXB(I+1).EQ.0) THEN + IWORK(JPVT+I) = 0 + ELSE + IWORK(JPVT+I) = IWORK(JPVT+J) + J = J - 1 + END IF + 230 CONTINUE + END IF + END IF + +C Store various scalars in work arrays for return to user + + IF (NITER.GE.1) THEN + OLMAVG = OLMAVG/NITER + ELSE + OLMAVG = ZERO + END IF + +C Compute weighted sums of squares for return to user + + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,TEMPRET(1:N,1:NQ)) + WRK(1:N*NQ) = RESHAPE(TEMPRET(1:N,1:NQ),(/N*NQ/)) + WSS(3) = DDOT(N*NQ,WRK,1,WRK,1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,TEMPRET(1:N,1:M)) + WRK(N*NQ+1:N*NQ+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + WSS(2) = ZERO + END IF + WSS(1) = WSS(2) + WSS(3) + + ACCESS = .FALSE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + & WORK,LWORK,IWORK,LIWORK, + & ACCESS,ISODR, + & JPVT,OMEGA,U,QRAUX,SD,VCV, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + & NNZW,NPP, + & JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + & LUNRPT,IPR1,IPR2,IPR2F,IPR3, + & WSS,RVAR,IDF, + & TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + & RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + +C Encode existance of questionable results into info + + IF (INFO.LE.9 .OR. INFO.GE.60000) THEN + IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN + INFO = INFO + 1000 + END IF + IF (ISTOP.NE.0) THEN + INFO = INFO + 100 + END IF + IF (IRANK.GE.1) THEN + IF (NPP.GT.IRANK) THEN + INFO = INFO + 10 + ELSE + INFO = INFO + 20 + END IF + END IF + END IF + +C Print final summary + + IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 3 + + IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR3.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR3,2) + END IF + LUNR = LUNRPT + DO 240 I=1,NPR + CALL DODPCR(IPR,LUNR, + & HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + & N,M,NP,NQ,NPP,NNZW, + & MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + & WE,LDWE,LD2WE,WD,LDWD,LD2WD, + & IWORK(JPVT),IFIXX,LDIFX, + & LOWER,UPPER, + & SSF,TT,LDTT,STPB,STPD,LDSTPD, + & JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + & WSS,RVAR,IDF,WORK(SD), + & NITER,NFEV,NJEV,ACTRED,PRERED, + & TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR3.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 240 CONTINUE + END IF + + RETURN + + END SUBROUTINE +*DODPC1 + SUBROUTINE DODPC1 + & (IPR,LUNRPT, + & ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + & MSGB1,MSGB,MSGD1,MSGD, + & N,M,NP,NQ,NPP,NNZW, + & X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + & Y,LDY,WE,LDWE,LD2WE,PNLTY, + & BETA,IFIXB,SSF,STPB,LOWER,UPPER, + & JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + & WSS,WSSDEL,WSSEPS) +C***Begin Prologue DODPC1 +C***Refer to ODR +C***Routines Called DHSTEP +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Generate initial summary report +C***End Prologue DODPC1 + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS + INTEGER + & IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + & LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ + LOGICAL + & ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),DELTA(N,M),LOWER(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), + & TT(LDTT,M),UPPER(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ), + & X(LDX,M),Y(LDY,NQ) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) + +C...Local scalars + REAL (KIND=R8) + & TEMP1,TEMP2,TEMP3,ZERO + INTEGER + & I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L + +C...Local arrays + CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 + +C...External functions + REAL (KIND=R8) + & DHSTEP + EXTERNAL + & DHSTEP + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C ANAJAC: The variable designating whether the Jacobians are computed +C by finite differences (ANAJAC=FALSE) or not (ANAJAC=TRUE). +C BETA: The function parameters. +C CDJAC: The variable designating whether the Jacobians are computed +C by central differences (CDJAC=TRUE) or forward differences +C (CDJAC=FALSE). +C CHKJAC: The variable designating whether the user supplied +C Jacobians are to be checked (CHKJAC=TRUE) or not +C (CHKJAC=FALSE). +C DELTA: The estimated errors in the explanatory variables. +C DOVCV: The variable designating whether the covariance matrix is +C to be computed (DOVCV=TRUE) or not (DOVCV=FALSE). +C I: An indexing variable. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INITD: The variable designating whether DELTA is initialized to +C zero (INITD=TRUE) or to the values in the first N by M +C elements of array WORK (INITD=FALSE). +C IPR: The value indicating the report to be printed. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ITEMP: A temporary integer value. +C J: An indexing variable. +C JOB: The variable controling problem initialization and +C computational method. +C JOB1: The 1st digit (from the left) of variable JOB. +C JOB2: The 2nd digit (from the left) of variable JOB. +C JOB3: The 3rd digit (from the left) of variable JOB. +C JOB4: The 4th digit (from the left) of variable JOB. +C JOB5: The 5th digit (from the left) of variable JOB. +C L: An indexing variable. +C LDIFX: The leading dimension of array IFIXX. +C LDTT: The leading dimension of array TT. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LDX: The leading dimension of array X. +C LDY: The leading dimension of array Y. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C LUNRPT: The logical unit number for the computation reports. +C M: The number of columns of data in the explanatory variable. +C MAXIT: The maximum number of iterations allowed. +C MSGB: The error checking results for the Jacobian wrt beta. +C MSGB1: The error checking results for the Jacobian wrt BETA. +C MSGD: The error checking results for the Jacobian wrt DELTA. +C MSGD1: The error checking results for the Jacobian wrt DELTA. +C N: The number of observations. +C NETA: The number of accurate digits in the function results. +C A negative value indicates that NETA was estimated by +C ODRPACK95. A positive value indictes the value was supplied +C by the user. +C NNZW: The number of nonzero observational error weights. +C NP: The number of function parameters. +C NPP: The number of function parameters being estimated. +C NQ: The number of responses per observation. +C PARTOL: The parameter convergence stopping tolerance. +C PNLTY: The penalty parameter for an implicit model. +C REDOJ: The variable designating whether the Jacobian matrix is to +C be recomputed for the computation of the covariance matrix +C (REDOJ=TRUE) or not (REDOJ=FALSE). +C RESTRT: The variable designating whether the call is a restart +C (RESTRT=TRUE) or not (RESTRT=FALSE). +C SSF: The scaling values for BETA. +C SSTOL: The sum-of-squares convergence stopping tolerance. +C STPB: The relative step used for computing finite difference +C derivatives with respect to BETA. +C STPD: The relative step used for computing finite difference +C derivatives with respect to DELTA. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C TEMPC0: A temporary CHARACTER*2 value. +C TEMPC1: A temporary CHARACTER*5 value. +C TEMPC2: A temporary CHARACTER*13 value. +C TEMP1: A temporary REAL (KIND=R8) value. +C TEMP2: A temporary REAL (KIND=R8) value. +C TEMP3: A temporary REAL (KIND=R8) value. +C TT: The scaling values for DELTA. +C WD: The DELTA weights. +C WE: The EPSILON weights. +C WSS: The sum-of-squares of the weighted EPSILONS and DELTAS. +C WSSDEL: The sum-of-squares of the weighted DELTAS. +C WSSEPS: The sum-of-squares of the weighted EPSILONS. +C X: The explanatory variable. +C Y: The response variable. Unused when the model is implicit. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODPC1 + + +C Print problem size specification + + WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP + + +C Print control values + + JOB1 = JOB/10000 + JOB2 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB4 = MOD(JOB,100)/10 + JOB5 = MOD(JOB,10) + WRITE (LUNRPT,1100) JOB + IF (RESTRT) THEN + WRITE (LUNRPT,1110) JOB1 + ELSE + WRITE (LUNRPT,1111) JOB1 + END IF + IF (ISODR) THEN + IF (INITD) THEN + WRITE (LUNRPT,1120) JOB2 + ELSE + WRITE (LUNRPT,1121) JOB2 + END IF + ELSE + WRITE (LUNRPT,1122) JOB2,JOB5 + END IF + IF (DOVCV) THEN + WRITE (LUNRPT,1130) JOB3 + IF (REDOJ) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + ELSE + WRITE (LUNRPT,1133) JOB3 + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,1140) JOB4 + IF (CHKJAC) THEN + IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN + WRITE (LUNRPT,1141) + ELSE + WRITE (LUNRPT,1142) + END IF + ELSE + WRITE (LUNRPT,1143) + END IF + ELSE IF (CDJAC) THEN + WRITE (LUNRPT,1144) JOB4 + ELSE + WRITE (LUNRPT,1145) JOB4 + END IF + IF (ISODR) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1150) JOB5 + ELSE + WRITE (LUNRPT,1151) JOB5 + END IF + ELSE + WRITE (LUNRPT,1152) JOB5 + END IF + IF (NETA.LT.0) THEN + WRITE (LUNRPT,1200) -NETA + ELSE + WRITE (LUNRPT,1210) NETA + END IF + WRITE (LUNRPT,1300) TAUFAC + + +C Print stopping criteria + + WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT + + +C Print initial sum of squares + + IF (IMPLCT) THEN + WRITE (LUNRPT,1500) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,1600) WSS + IF (ISODR) THEN + WRITE (LUNRPT,1610) WSSDEL,WSSEPS + END IF + END IF + + + IF (IPR.GE.2) THEN + + +C Print function parameter data + + WRITE (LUNRPT,4000) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,4110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,4120) + ELSE + WRITE (LUNRPT,4200) + END IF + DO 130 J=1,NP + IF (IFIXB(1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (IFIXB(J).NE.0) THEN + TEMPC1 = ' NO' + ELSE + TEMPC1 = ' YES' + END IF + END IF + IF (ANAJAC) THEN + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + ITEMP = -1 + DO 110 L=1,NQ + ITEMP = MAX(ITEMP,MSGB(L,J)) + 110 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (SSF(1).LT.ZERO) THEN + TEMP1 = ABS(SSF(1)) + ELSE + TEMP1 = SSF(J) + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,LOWER(J), + & UPPER(J),TEMPC2 + ELSE + IF (CDJAC) THEN + TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) + ELSE + TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) + END IF + WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1, + & LOWER(J),UPPER(J),TEMP2 + END IF + 130 CONTINUE + +C Print explanatory variable data + + IF (ISODR) THEN + WRITE (LUNRPT,2010) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,2110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,2120) + ELSE + WRITE (LUNRPT,2130) + END IF + ELSE + WRITE (LUNRPT,2020) + WRITE (LUNRPT,2140) + END IF + IF (ISODR) THEN + DO 240 J = 1,M + TEMPC0 = '1,' + DO 230 I=1,N,N-1 + + IF (IFIXX(1,1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + ELSE + IF (IFIXX(I,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + END IF + END IF + + IF (TT(1,1).LT.ZERO) THEN + TEMP1 = ABS(TT(1,1)) + ELSE + IF (LDTT.EQ.1) THEN + TEMP1 = TT(1,J) + ELSE + TEMP1 = TT(I,J) + END IF + END IF + + IF (WD(1,1,1).LT.ZERO) THEN + TEMP2 = ABS(WD(1,1,1)) + ELSE + IF (LDWD.EQ.1) THEN + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(1,1,J) + ELSE + TEMP2 = WD(1,J,J) + END IF + ELSE + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(I,1,J) + ELSE + TEMP2 = WD(I,J,J) + END IF + END IF + END IF + + IF (ANAJAC) THEN + IF (CHKJAC .AND. + & (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. + & (I.EQ.1))) THEN + ITEMP = -1 + DO 210 L=1,NQ + ITEMP = MAX(ITEMP,MSGD(L,J)) + 210 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + & TEMPC0,J,X(I,J), + & DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + ELSE + WRITE (LUNRPT,5120) + & TEMPC0,J,X(I,J), + & DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + END IF + ELSE + TEMPC2 = ' ' + IF (CDJAC) THEN + TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) + ELSE + TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5210) + & TEMPC0,J,X(I,J), + & DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + ELSE + WRITE (LUNRPT,5220) + & TEMPC0,J,X(I,J), + & DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + END IF + END IF + + TEMPC0 = 'N,' + + 230 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 240 CONTINUE + ELSE + + DO 260 J = 1,M + TEMPC0 = '1,' + DO 250 I=1,N,N-1 + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + & TEMPC0,J,X(I,J) + ELSE + WRITE (LUNRPT,5120) + & TEMPC0,J,X(I,J) + END IF + TEMPC0 = 'N,' + 250 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 260 CONTINUE + END IF + +C Print response variable data and observation error weights + + IF (.NOT.IMPLCT) THEN + WRITE (LUNRPT,3000) + WRITE (LUNRPT,3100) + DO 310 L=1,NQ + TEMPC0 = '1,' + DO 300 I=1,N,N-1 + IF (WE(1,1,1).LT.ZERO) THEN + TEMP1 = ABS(WE(1,1,1)) + ELSE IF (LDWE.EQ.1) THEN + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(1,1,L) + ELSE + TEMP1 = WE(1,L,L) + END IF + ELSE + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(I,1,L) + ELSE + TEMP1 = WE(I,L,L) + END IF + END IF + IF (NQ.LE.9) THEN + WRITE (LUNRPT,5110) + & TEMPC0,L,Y(I,L),TEMP1 + ELSE + WRITE (LUNRPT,5120) + & TEMPC0,L,Y(I,L),TEMP1 + END IF + TEMPC0 = 'N,' + 300 CONTINUE + IF (L.LT.NQ) WRITE (LUNRPT,6000) + 310 CONTINUE + END IF + END IF + + RETURN + +C Format statements + + 1000 FORMAT + & (/' --- Problem Size:'/ + & ' N = ',I5, + & ' (number with nonzero weight = ',I5,')'/ + & ' NQ = ',I5/ + & ' M = ',I5/ + & ' NP = ',I5, + & ' (number unfixed = ',I5,')') + 1100 FORMAT + & (/' --- Control Values:'/ + & ' JOB = ',I5.5/ + & ' = ABCDE, where') + 1110 FORMAT + & (' A=',I1,' ==> fit is a restart.') + 1111 FORMAT + & (' A=',I1,' ==> fit is not a restart.') + 1120 FORMAT + & (' B=',I1,' ==> deltas are initialized', + & ' to zero.') + 1121 FORMAT + & (' B=',I1,' ==> deltas are initialized', + & ' by user.') + 1122 FORMAT + & (' B=',I1,' ==> deltas are fixed at', + & ' zero since E=',I1,'.') + 1130 FORMAT + & (' C=',I1,' ==> covariance matrix will', + & ' be computed using') + 1131 FORMAT + & (' derivatives re-', + & 'evaluated at the solution.') + 1132 FORMAT + & (' derivatives from the', + & ' last iteration.') + 1133 FORMAT + & (' C=',I1,' ==> covariance matrix will', + & ' not be computed.') + 1140 FORMAT + & (' D=',I1,' ==> derivatives are', + & ' supplied by user.') + 1141 FORMAT + & (' derivatives were checked.'/ + & ' results appear questionable.') + 1142 FORMAT + & (' derivatives were checked.'/ + & ' results appear correct.') + 1143 FORMAT + & (' derivatives were not', + & ' checked.') + 1144 FORMAT + & (' D=',I1,' ==> derivatives are', + & ' estimated by central', + & ' differences.') + 1145 FORMAT + & (' D=',I1,' ==> derivatives are', + & ' estimated by forward', + & ' differences.') + 1150 FORMAT + & (' E=',I1,' ==> method is implicit ODR.') + 1151 FORMAT + & (' E=',I1,' ==> method is explicit ODR.') + 1152 FORMAT + & (' E=',I1,' ==> method is explicit OLS.') + 1200 FORMAT + & (' NDIGIT = ',I5,' (estimated by ODRPACK95)') + 1210 FORMAT + & (' NDIGIT = ',I5,' (supplied by user)') + 1300 FORMAT + & (' TAUFAC = ',1P,E12.2) + 1400 FORMAT + & (/' --- Stopping Criteria:'/ + & ' SSTOL = ',1P,E12.2, + & ' (sum of squares stopping tolerance)'/ + & ' PARTOL = ',1P,E12.2, + & ' (parameter stopping tolerance)'/ + & ' MAXIT = ',I5, + & ' (maximum number of iterations)') + 1500 FORMAT + & (/' --- Initial Sum of Squared Weighted Deltas =', + & 17X,1P,E17.8) + 1510 FORMAT + & ( ' Initial Penalty Function Value =',1P,E17.8/ + & ' Penalty Term =',1P,E17.8/ + & ' Penalty Parameter =',1P,E10.1) + 1600 FORMAT + & (/' --- Initial Weighted Sum of Squares =', + & 17X,1P,E17.8) + 1610 FORMAT + & ( ' Sum of Squared Weighted Deltas =',1P,E17.8/ + & ' Sum of Squared Weighted Epsilons =',1P,E17.8) + 2010 FORMAT + & (/' --- Explanatory Variable and Delta Weight Summary:') + 2020 FORMAT + & (/' --- Explanatory Variable Summary:') + 2110 FORMAT + & (/' Index X(I,J) DELTA(I,J) Fixed', + & ' Scale Weight Derivative'/ + & ' ', + & ' Assessment'/, + & ' (I,J) (IFIXX)', + & ' (SCLD) (WD) '/) + 2120 FORMAT + & (/' Index X(I,J) DELTA(I,J) Fixed', + & ' Scale Weight '/ + & ' ', + & ' '/, + & ' (I,J) (IFIXX)', + & ' (SCLD) (WD) '/) + 2130 FORMAT + & (/' Index X(I,J) DELTA(I,J) Fixed', + & ' Scale Weight Derivative'/ + & ' ', + & ' Step Size'/, + & ' (I,J) (IFIXX)', + & ' (SCLD) (WD) (STPD)'/) + 2140 FORMAT + & (/' Index X(I,J)'/ + & ' (I,J) '/) + 3000 FORMAT + & (/' --- Response Variable and Epsilon Error Weight', + & ' Summary:') + 3100 FORMAT + & (/' Index Y(I,L) Weight'/ + & ' (I,L) (WE)'/) + 4000 FORMAT + & (/' --- Function Parameter Summary:') + 4110 FORMAT + & (/' Index BETA(K) Fixed Scale LOWER(K)', + & ' UPPER(K) Derivative'/ + & ' ', + & ' Assessment'/, + & ' (K) (IFIXB) (SCLB) ', + & ' '/) + 4120 FORMAT + & (/' Index BETA(K) Fixed Scale LOWER(K)', + & ' UPPER(K) '/ + & ' ', + & ' '/, + & ' (K) (IFIXB) (SCLB) ', + & ' '/) + 4200 FORMAT + & (/' Index BETA(K) Fixed Scale LOWER(K)', + & ' UPPER(K) Derivative'/ + & ' ', + & ' Step Size'/, + & ' (K) (IFIXB) (SCLB) ', + & ' (STPB)'/) + 4310 FORMAT + & (7X,I5,1P,E10.2,4X,A5,E10.2,E11.2E3,E11.2E3,1X,A13) + 4320 FORMAT + & (7X,I5,1P,E10.2,4X,A5,E10.2,E11.2E3,E11.2E3,1X,E13.5) + 5110 FORMAT + & (9X,A2,I1,1P,2E12.3,4X,A5,2E10.2,1X,A13) + 5120 FORMAT + & (8X,A2,I2,1P,2E12.3,4X,A5,2E10.2,1X,A13) + 5210 FORMAT + & (9X,A2,I1,1P,2E12.3,4X,A5,2E10.2,1X,E13.5) + 5220 FORMAT + & (8X,A2,I2,1P,2E12.3,4X,A5,2E10.2,1X,E13.5) + 6000 FORMAT + & (' ') + END SUBROUTINE +*DODPC2 + SUBROUTINE DODPC2 + & (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + & PNLTY, + & NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) +C***Begin Prologue DODPC2 +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Generate iteration reports +C***End Prologue DODPC2 + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS + INTEGER + & IPR,LUNRPT,NFEV,NITER,NP + LOGICAL + & FSTITR,IMPLCT,PRTPEN + +C...Array arguments + REAL (KIND=R8) + & BETA(NP) + +C...Local scalars + REAL (KIND=R8) + & RATIO,ZERO + INTEGER + & J,K,L + CHARACTER GN*3 + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C ACTRED: The actual relative reduction in the sum-of-squares. +C ALPHA: The Levenberg-Marquardt parameter. +C BETA: The function parameters. +C FSTITR: The variable designating whether this is the first +C iteration (FSTITR=.TRUE.) or not (FSTITR=.FALSE.). +C GN: The CHARACTER*3 variable indicating whether a Gauss-Newton +C step was taken. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C IPR: The value indicating the report to be printed. +C J: An indexing variable. +C K: An indexing variable. +C L: An indexing variable. +C LUNRPT: The logical unit number used for computation reports. +C NFEV: The number of function evaluations. +C NITER: The number of iterations. +C NP: The number of function parameters. +C PNLTY: The penalty parameter for an implicit model. +C PNORM: The norm of the scaled estimated parameters. +C PRERED: The predicted relative reduction in the sum-of-squares. +C PRTPEN: The variable designating whether the penalty parameter is +C to be printed in the iteration report (PRTPEN=TRUE) or not +C (PRTPEN=FALSE). +C RATIO: The ratio of TAU to PNORM. +C TAU: The trust region diameter. +C WSS: The sum-of-squares of the weighted EPSILONS and DELTAS. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODPC2 + + + IF (FSTITR) THEN + IF (IPR.EQ.1) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1121) + ELSE + WRITE (LUNRPT,1122) + END IF + ELSE + IF (IMPLCT) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + END IF + END IF + IF (PRTPEN) THEN + WRITE (LUNRPT,1133) PNLTY + END IF + + IF (ALPHA.EQ.ZERO) THEN + GN = 'YES' + ELSE + GN = ' NO' + END IF + IF (PNORM.NE.ZERO) THEN + RATIO = TAU/PNORM + ELSE + RATIO = ZERO + END IF + IF (IPR.EQ.1) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + & RATIO,GN + ELSE + J = 1 + K = MIN(3,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + & RATIO,GN,J,BETA(J) + ELSE + WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + & RATIO,GN,J,K,(BETA(L),L=J,K) + END IF + IF (NP.GT.3) THEN + DO 10 J=4,NP,3 + K = MIN(J+2,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1151) J,BETA(J) + ELSE + WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) + END IF + 10 CONTINUE + END IF + END IF + + RETURN + +C Format statements + + 1121 FORMAT + & (// + & ' Cum. Penalty Act. Rel. Pred. Rel.'/ + & ' It. No. FN Function Sum-of-Sqs Sum-of-Sqs', + & ' G-N'/ + & ' Num. Evals Value Reduction Reduction', + & ' TAU/PNORM Step'/ + & ' ---- ------ ----------- ----------- -----------', + & ' --------- ----') + 1122 FORMAT + & (// + & ' Cum. Act. Rel. Pred. Rel.'/ + & ' It. No. FN Weighted Sum-of-Sqs Sum-of-Sqs', + & ' G-N'/ + & ' Num. Evals Sum-of-Sqs Reduction Reduction', + & ' TAU/PNORM Step'/ + & ' ---- ------ ----------- ----------- -----------', + & ' --------- ----'/) + 1131 FORMAT + & (// + & ' Cum. Penalty Act. Rel. Pred. Rel.'/ + & ' It. No. FN Function Sum-of-Sqs Sum-of-Sqs', + & ' G-N BETA -------------->'/ + & ' Num. Evals Value Reduction Reduction', + & ' TAU/PNORM Step Index Value'/ + & ' ---- ------ ----------- ----------- -----------', + & ' --------- ---- ----- -----') + 1132 FORMAT + & (// + & ' Cum. Act. Rel. Pred. Rel.'/ + & ' It. No. FN Weighted Sum-of-Sqs Sum-of-Sqs', + & ' G-N BETA -------------->'/ + & ' Num. Evals Sum-of-Sqs Reduction Reduction', + & ' TAU/PNORM Step Index Value'/ + & ' ---- ------ ----------- ----------- -----------', + & ' --------- ---- ----- -----'/) + 1133 FORMAT + & (/' Penalty Parameter Value = ', 1P,E10.1) + 1141 FORMAT + & (1X,I4,I8,1X,1P,E12.5,2E13.4,E11.3,3X,A3,7X,I3,3E16.8) + 1142 FORMAT + & (1X,I4,I8,1X,1P,E12.5,2E13.4,E11.3,3X,A3,1X,I3,' To',I3,3E16.8) + 1151 FORMAT + & (76X,I3,1P,E16.8) + 1152 FORMAT + & (70X,I3,' To',I3,1P,3E16.8) + END SUBROUTINE +*DODPC3 + SUBROUTINE DODPC3 + & (IPR,LUNRPT, + & ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + & N,M,NP,NQ,NPP, + & INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + & WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, + & BETA,SDBETA,IFIXB2,F,DELTA, + & LOWER,UPPER) +C***Begin Prologue DODPC3 +C***Refer to ODR +C***Routines Called DPPT +C***Date Written 860529 (YYMMDD) +C***REvision Date 920619 (YYMMDD) +C***Purpose Generate final summary report +C***End Prologue DODPC3 + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS + INTEGER + & IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, + & N,NFEV,NITER,NJEV,NP,NPP,NQ + LOGICAL + & ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),DELTA(N,M),F(N,NQ),LOWER(NP),UPPER(NP),SDBETA(NP) + INTEGER + & IFIXB2(NP) + +C...Local scalars + REAL (KIND=R8) + & TVAL + INTEGER + & D1,D2,D3,D4,D5,I,J,K,L,NPLM1 + CHARACTER FMT1*90 + +C...External functions + REAL (KIND=R8) + & DPPT + EXTERNAL + & DPPT + +C...Variable Definitions (alphabetically) +C ANAJAC: The variable designating whether the JACOBIANS are computed +c by finite differences (ANAJAC=FALSE) or not (ANAJAC=TRUE). +C BETA: The function parameters. +C D1: The first digit of INFO. +C D2: The second digit of INFO. +C D3: The third digit of INFO. +C D4: The fourth digit of INFO. +C D5: The fifth digit of INFO. +C DELTA: The estimated errors in the explanatory variables. +C DIDVCV: The variable designating whether the covariance matrix was +C computed (DIDVCV=TRUE) or not (DIDVCV=FALSE). +C DOVCV: The variable designating whether the covariance matrix was +C to be computed (DOVCV=TRUE) or not (DOVCV=FALSE). +C F: The estimated values of EPSILON. +C FMT1: A CHARACTER*90 variable used for formats. +C I: An indexing variable. +C IDF: The degrees of freedom of the fit, equal to the number of +C observations with nonzero weighted derivatives minus the +C number of parameters being estimated. +C IFIXB2: The values designating whether the elements of BETA were +C estimated, fixed, or dropped because they caused rank +C deficiency, corresponding to values of IFIXB2 equaling 1, +C 0, and -1, respectively. If IFIXB2 is -2, then no attempt +C was made to estimate the parameters because MAXIT = 0. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INFO: The variable designating why the computations were stopped. +C IPR: The variable indicating what is to be printed. +C IRANK: The rank deficiency of the Jacobian wrt BETA. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C J: An indexing variable. +C K: An indexing variable. +C L: An indexing variable. +C LOWER: Lower bound on BETA. +C LUNRPT: The logical unit number used for computation reports. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NFEV: The number of function evaluations. +C NITER: The number of iterations. +C NJEV: The number of Jacobian evaluations. +C NP: The number of function parameters. +C NPLM1: The number of items to be printed per line, minus one. +C NPP: The number of function parameters being estimated. +C NQ: The number of responses per observation. +C PNLTY: The penalty parameter for an implicit model. +C RCOND: The approximate reciprocal condition of TFJACB. +C REDOJ: The variable designating whether the Jacobian matrix is +C to be recomputed for the computation of the covariance +C matrix (REDOJ=TRUE) or not (REDOJ=FALSE). +C RVAR: The residual variance. +C SDBETA: The standard errors of the estimated parameters. +C TVAL: The value of the 97.5 percent point function for the +C T distribution. +C UPPER: Upper bound on BETA. +C WSS: The sum-of-squares of the weighted EPSILONS and DELTAS. +C WSSDEL: The sum-of-squares of the weighted DELTAS. +C WSSEPS: The sum-of-squares of the weighted EPSILONS. + + +C***First executable statement DODPC3 + + + D1 = INFO/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C Print stopping conditions + + WRITE (LUNRPT,1000) + IF (INFO.LE.9) THEN + IF (INFO.EQ.1) THEN + WRITE (LUNRPT,1011) INFO + ELSE IF (INFO.EQ.2) THEN + WRITE (LUNRPT,1012) INFO + ELSE IF (INFO.EQ.3) THEN + WRITE (LUNRPT,1013) INFO + ELSE IF (INFO.EQ.4) THEN + WRITE (LUNRPT,1014) INFO + ELSE IF (INFO.LE.9) THEN + WRITE (LUNRPT,1015) INFO + END IF + ELSE IF (INFO.LE.9999) THEN + +C Print warning diagnostics + + WRITE (LUNRPT,1020) INFO + IF (D2.EQ.1) WRITE (LUNRPT,1021) + IF (D3.EQ.1) WRITE (LUNRPT,1022) + IF (D4.EQ.1) WRITE (LUNRPT,1023) + IF (D4.EQ.2) WRITE (LUNRPT,1024) + IF (D5.EQ.1) THEN + WRITE (LUNRPT,1031) + ELSE IF (D5.EQ.2) THEN + WRITE (LUNRPT,1032) + ELSE IF (D5.EQ.3) THEN + WRITE (LUNRPT,1033) + ELSE IF (D5.EQ.4) THEN + WRITE (LUNRPT,1034) + ELSE IF (D5.LE.9) THEN + WRITE (LUNRPT,1035) D5 + END IF + ELSE + +C Print error messages + + WRITE (LUNRPT,1040) INFO + IF (D1.EQ.5) THEN + WRITE (LUNRPT,1042) + IF (D2.NE.0) WRITE (LUNRPT,1043) D2 + IF (D3.EQ.3) THEN + WRITE (LUNRPT,1044) D3 + ELSE IF (D3.NE.0) THEN + WRITE (LUNRPT,1045) D3 + END IF + ELSE IF (D1.EQ.6) THEN + WRITE (LUNRPT,1050) + ELSE + WRITE (LUNRPT,1060) D1 + END IF + END IF + +C Print misc. stopping info + + WRITE (LUNRPT,1300) NITER + WRITE (LUNRPT,1310) NFEV + IF (ANAJAC) WRITE (LUNRPT,1320) NJEV + WRITE (LUNRPT,1330) IRANK + WRITE (LUNRPT,1340) RCOND + WRITE (LUNRPT,1350) ISTOP + +C Print final sum of squares + + IF (IMPLCT) THEN + WRITE (LUNRPT,2000) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,2100) WSS + IF (ISODR) THEN + WRITE (LUNRPT,2110) WSSDEL,WSSEPS + END IF + END IF + IF (DIDVCV) THEN + WRITE (LUNRPT,2200) SQRT(RVAR),IDF + END IF + + NPLM1 = 3 + +C Print estimated BETA's, and, +C if, full rank, their standard errors + + WRITE (LUNRPT,3000) + IF (DIDVCV) THEN + WRITE (LUNRPT,7300) + TVAL = DPPT(0.975E0_R8,IDF) + DO 10 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8400) J,BETA(J), + & LOWER(J),UPPER(J), + & SDBETA(J), + & BETA(J)-TVAL*SDBETA(J), + & BETA(J)+TVAL*SDBETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J),LOWER(J),UPPER(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J),LOWER(J),UPPER(J) + END IF + 10 CONTINUE + IF (.NOT.REDOJ) WRITE (LUNRPT,7310) + ELSE + IF (DOVCV) THEN + IF (D1.LE.5) THEN + WRITE (LUNRPT,7410) + ELSE + WRITE (LUNRPT,7420) + END IF + END IF + + IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN + IF (NP.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 20 J=1,NP,NPLM1+1 + K = MIN(J+NPLM1,NP) + IF (K.EQ.J) THEN + WRITE (LUNRPT,8100) J,BETA(J) + ELSE + WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) + END IF + 20 CONTINUE + IF (NITER.GE.1) THEN + WRITE (LUNRPT,8800) + ELSE + WRITE (LUNRPT,8900) + END IF + ELSE + WRITE (LUNRPT,7500) + DO 30 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8500) J,BETA(J),LOWER(J),UPPER(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J),LOWER(J),UPPER(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J),LOWER(J),UPPER(J) + END IF + 30 CONTINUE + END IF + END IF + + IF (IPR.EQ.1) RETURN + + +C Print EPSILON's and DELTA's together in a column if the number of +C columns of data in EPSILON and DELTA is less than or equal to three. + + IF (IMPLCT .AND. (M.LE.4)) THEN + WRITE (LUNRPT,4100) + WRITE (FMT1,9110) M + WRITE (LUNRPT,FMT1) (J,J=1,M) + DO 40 I=1,N + WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) + 40 CONTINUE + + ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN + WRITE (LUNRPT,4110) + WRITE (FMT1,9120) NQ,M + WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) + DO 50 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) + 50 CONTINUE + + ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN + WRITE (LUNRPT,4120) + WRITE (FMT1,9130) NQ + WRITE (LUNRPT,FMT1) (L,L=1,NQ) + DO 60 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) + 60 CONTINUE + ELSE + +C Print EPSILON's and DELTA's separately + + IF (.NOT.IMPLCT) THEN + +C Print EPSILON'S + + DO 80 J=1,NQ + WRITE (LUNRPT,4200) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 70 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,F(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) + END IF + 70 CONTINUE + 80 CONTINUE + END IF + +C Print DELTA'S + + IF (ISODR) THEN + DO 100 J=1,M + WRITE (LUNRPT,4300) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 90 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,DELTA(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) + END IF + 90 CONTINUE + 100 CONTINUE + END IF + END IF + + RETURN + +C Format statements + + 1000 FORMAT + & (/' --- Stopping Conditions:') + 1011 FORMAT + & (' INFO = ',I5,' ==> sum of squares convergence.') + 1012 FORMAT + & (' INFO = ',I5,' ==> parameter convergence.') + 1013 FORMAT + & (' INFO = ',I5,' ==> sum of squares convergence and', + & ' parameter convergence.') + 1014 FORMAT + & (' INFO = ',I5,' ==> iteration limit reached.') + 1015 FORMAT + & (' INFO = ',I5,' ==> unexpected value,', + & ' probably indicating'/ + & ' incorrectly specified', + & ' user input.') + 1020 FORMAT + & (' INFO = ',I5.4/ + & ' = ABCD, where a nonzero value for digit A,', + & ' B, or C indicates why'/ + & ' the results might be questionable,', + & ' and digit D indicates'/ + & ' the actual stopping condition.') + 1021 FORMAT + & (' A=1 ==> derivatives are', + & ' questionable.') + 1022 FORMAT + & (' B=1 ==> user set ISTOP to', + & ' nonzero value during last'/ + & ' call to subroutine FCN.') + 1023 FORMAT + & (' C=1 ==> derivatives are not', + & ' full rank at the solution.') + 1024 FORMAT + & (' C=2 ==> derivatives are zero', + & ' rank at the solution.') + 1031 FORMAT + & (' D=1 ==> sum of squares convergence.') + 1032 FORMAT + & (' D=2 ==> parameter convergence.') + 1033 FORMAT + & (' D=3 ==> sum of squares convergence', + & ' and parameter convergence.') + 1034 FORMAT + & (' D=4 ==> iteration limit reached.') + 1035 FORMAT + & (' D=',I1,' ==> unexpected value,', + & ' probably indicating'/ + & ' incorrectly specified', + & ' user input.') + 1040 FORMAT + & (' INFO = ',I5.5/ + & ' = ABCDE, where a nonzero value for a given', + & ' digit indicates an'/ + & ' abnormal stopping condition.') + 1042 FORMAT + & (' A=5 ==> user stopped computations', + & ' in subroutine FCN.') + 1043 FORMAT + & (' B=',I1,' ==> computations were', + & ' stopped during the'/ + & ' function evaluation.') + 1044 FORMAT + & (' C=',I1,' ==> computations were', + & ' stopped because'/ + & ' derivatives with', + & ' respect to delta were'/ + & ' computed by', + & ' subroutine FCN when'/ + & ' fit is OLS.') + 1045 FORMAT + & (' C=',I1,' ==> computations were', + & ' stopped during the'/ + & ' jacobian evaluation.') + 1050 FORMAT + & (' A=6 ==> numerical instabilities', + & ' have been detected,'/ + & ' possibly indicating', + & ' a discontinuity in the'/ + & ' derivatives or a poor', + & ' poor choice of problem'/ + & ' scale or weights.') + 1060 FORMAT + & (' A=',I1,' ==> unexpected value,', + & ' probably indicating'/ + & ' incorrectly specified', + & ' user input.') + 1300 FORMAT + & (' NITER = ',I5, + & ' (number of iterations)') + 1310 FORMAT + & (' NFEV = ',I5, + & ' (number of function evaluations)') + 1320 FORMAT + & (' NJEV = ',I5, + & ' (number of jacobian evaluations)') + 1330 FORMAT + & (' IRANK = ',I5, + & ' (rank deficiency)') + 1340 FORMAT + & (' RCOND = ',1P,E12.2, + & ' (inverse condition number)') +*1341 FORMAT +* + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', +* + ' DIGITS IN RESULTS;'/ +* + ' SEE ODRPACK95 REFERENCE', +* + ' GUIDE, SECTION 4.C.') + 1350 FORMAT + & (' ISTOP = ',I5, + & ' (returned by user from', + & ' subroutine FCN)') + 2000 FORMAT + & (/' --- Final Sum of Squared Weighted Deltas = ', + & 17X,1P,E17.8) + 2010 FORMAT + & ( ' Final Penalty Function Value = ',1P,E17.8/ + & ' Penalty Term = ',1P,E17.8/ + & ' Penalty Parameter = ',1P,E10.1) + 2100 FORMAT + & (/' --- Final Weighted Sums of Squares = ',17X,1P,E17.8) + 2110 FORMAT + & ( ' Sum of Squared Weighted Deltas = ',1P,E17.8/ + & ' Sum of Squared Weighted Epsilons = ',1P,E17.8) + 2200 FORMAT + & (/' --- Residual Standard Deviation = ', + & 17X,1P,E17.8/ + & ' Degrees of Freedom =',I5) + 3000 FORMAT + & (/' --- Estimated BETA(J), J = 1, ..., NP:') + 4100 FORMAT + & (/' --- Estimated DELTA(I,*), I = 1, ..., N:') + 4110 FORMAT + & (/' --- Estimated EPSILON(I) and DELTA(I,*), I = 1, ..., N:') + 4120 FORMAT + & (/' --- Estimated EPSILON(I), I = 1, ..., N:') + 4130 FORMAT(5X,I5,1P,5E16.8) + 4200 FORMAT + & (/' --- Estimated EPSILON(I,',I3,'), I = 1, ..., N:') + 4300 FORMAT + & (/' --- Estimated DELTA(I,',I3,'), I = 1, ..., N:') + 7100 FORMAT + & (/' Index Value'/) + 7200 FORMAT + & (/' Index Value -------------->'/) + 7300 FORMAT + & (/' BETA LOWER UPPER S.D. ', + & ' ___ 95% Confidence ___'/ + & ' BETA ', + & ' Interval'/) + 7310 FORMAT + & (/' N.B. standard errors and confidence intervals are', + & ' computed using'/ + & ' derivatives calculated at the beginning', + & ' of the last iteration,'/ + & ' and not using derivatives re-evaluated at the', + & ' final solution.') + 7410 FORMAT + & (/' N.B. the standard errors of the estimated betas were', + & ' not computed because'/ + & ' the derivatives were not available. Either MAXIT', + & ' is 0 and the third'/ + & ' digit of JOB is greater than 1, or the most', + & ' recently tried values of'/ + & ' BETA and/or X+DELTA were identified as', + & ' unacceptable by user supplied'/ + & ' subroutine FCN.') + 7420 FORMAT + & (/' N.B. the standard errors of the estimated betas were', + & ' not computed.'/ + & ' (see info above.)') + 7500 FORMAT + & (/' BETA Status') + 8100 FORMAT + & (11X,I5,1P,E16.8) + 8200 FORMAT + & (3X,I5,' to',I5,1P,7E16.8) + 8400 FORMAT + & (3X,I5,1X,1P,E16.8,1X,E10.2,E10.2,E10.2,1X,E10.2,1X,'to',E10.2) + 8500 FORMAT + & (3X,I5,1X,1P,E16.8,1X,E10.2,E10.2,4X,'Estimated') + 8600 FORMAT + & (3X,I5,1X,1P,E16.8,1X,E10.2,E10.2,4X,' Fixed') + 8700 FORMAT + & (3X,I5,1X,1P,E16.8,1X,E10.2,E10.2,4X,' Dropped') + 8800 FORMAT + & (/' N.B. no parameters were fixed by the user or', + & ' dropped at the last'/ + & ' iteration because they caused the model to be', + & ' rank deficient.') + 8900 FORMAT + & (/' N.B. no change was made to the user supplied parameter', + & ' values because'/ + & ' MAXIT=0.') + 9110 FORMAT + & ('(/'' I'',', + & I2,'('' DELTA(I,'',I1,'')'')/)') + 9120 FORMAT + & ('(/'' I'',', + & I2,'('' EPSILON(I,'',I1,'')''),', + & I2,'('' DELTA(I,'',I1,'')'')/)') + 9130 FORMAT + & ('(/'' I'',', + & I2,'('' EPSILON(I,'',I1,'')'')/)') + + END SUBROUTINE +*DODPCR + SUBROUTINE DODPCR + & (IPR,LUNRPT, + & HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + & N,M,NP,NQ,NPP,NNZW, + & MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + & WE,LDWE,LD2WE,WD,LDWD,LD2WD, + & IFIXB,IFIXX,LDIFX, + & LOWER,UPPER, + & SSF,TT,LDTT,STPB,STPD,LDSTPD, + & JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + & WSS,RVAR,IDF,SDBETA, + & NITER,NFEV,NJEV,ACTRED,PRERED, + & TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) +C***Begin Prologue DODPCR +C***Refer to ODR +C***Routines Called DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Generate computation reports +C***End Prologue DODPCR + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + & SSTOL,TAU,TAUFAC + INTEGER + & IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, + & LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, + & NITER,NJEV,NNZW,NP,NPP,NQ + LOGICAL + & DIDVCV,FSTITR,HEAD,PRTPEN + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),DELTA(N,M),F(N,NQ),LOWER(NP),SDBETA(NP),SSF(NP), + & STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),UPPER(NP), + & WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...Local scalars + REAL (KIND=R8) + & PNLTY + LOGICAL + & ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + CHARACTER TYP*3 + +C...External subroutines + EXTERNAL + & DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD + +C...Variable Definitions (alphabetically) +C ACTRED: The actual relative reduction in the sum-of-squares. +C ALPHA: The Levenberg-Marquardt parameter. +C ANAJAC: The variable designating whether the Jacobians are computed +C by finite differences (ANAJAC=FALSE) or not (ANAJAC=TRUE). +C BETA: The function parameters. +C CDJAC: The variable designating whether the jacobians are computed +C by central differences (CDJAC=TRUE) or by forward +C differences (CDJAC=FALSE). +C CHKJAC: The variable designating whether the user supplied +C Jacobians are to be checked (CHKJAC=TRUE) or not +C (CHKJAC=FALSE). +C DELTA: The estimated errors in the explanatory variables. +C DIDVCV: The variable designating whether the covariance matrix was +C computed (DIDVCV=TRUE) or not (DIDVCV=FALSE). +C DOVCV: The variable designating whether the covariance matrix is +C to be computed (DOVCV=TRUE) or not (DOVCV=FALSE). +C F: The (weighted) estimated values of EPSILON. +C FSTITR: The variable designating whether this is the first +C iteration (FSTITR=TRUE) or not (FSTITR=FALSE). +C HEAD: The variable designating whether the heading is to be +C printed (HEAD=TRUE) or not (HEAD=FALSE). +C IDF: The degrees of freedom of the fit, equal to the number of +C observations with nonzero weighted derivatives minus the +C number of parameters being estimated. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C IFLAG: The variable designating what is to be printed. +C IMPLCT: The variable designating whether the solution is by +C implicit ODR (IMPLCT=TRUE) or explicit ODR (IMPLCT=FALSE). +C INFO: The variable designating why the computations were stopped. +C INITD: The variable designating whether DELTA is initialized to +C zero (INITD=TRUE) or to the values in the first N by M +C elements of array WORK (INITD=FALSE). +C IPR: The value indicating the report to be printed. +C IRANK: The rank deficiency of the Jacobian wrt BETA. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C JOB: The variable controling problem initialization and +C computational method. +C LDIFX: The leading dimension of array IFIXX. +C LDSTPD: The leading dimension of array STPD. +C LDTT: The leading dimension of array TT. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LDX: The leading dimension of array X. +C LDY: The leading dimension of array Y. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C LOWER: Lower bound on BETA. +C LUNRPT: The logical unit number for computation reports. +C M: The number of columns of data in the explanatory variable. +C MAXIT: The maximum number of iterations allowed. +C MSGB: The error checking results for the Jacobian wrt BETA. +C MSGD: The error checking results for the Jacobian wrt DELTA. +C N: The number of observations. +C NETA: The number of accurate digits in the function results. +C NFEV: The number of function evaluations. +C NITER: The number of iterations. +C NJEV: The number of Jacobian evaluations. +C NNZW: The number of nonzero weighted observations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NPP: The number of function parameters being estimated. +C PARTOL: The parameter convergence stopping tolerance. +C PNLTY: The penalty parameter for an implicit model. +C PNORM: The norm of the scaled estimated parameters. +C PRERED: The predicted relative reduction in the sum-of-squares. +C PRTPEN: The variable designating whether the penalty parameter is +C to be printed in the iteration report (PRTPEN=TRUE) or not +C (PRTPEN=FALSE). +C RCOND: The approximate reciprocal condition number of TFJACB. +C REDOJ: The variable designating whether the Jacobian matrix is to +C be recomputed for the computation of the covariance matrix +C (REDOJ=TRUE) or not (REDOJ=FALSE). +C RESTRT: The variable designating whether the call is a restart +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RVAR: The residual variance. +C SDBETA: The standard deviations of the estimated BETA'S. +C SSF: The scaling values for BETA. +C SSTOL: The sum-of-squares convergence stopping tolerance. +C STPB: The relative step for computing finite difference +C derivatives with respect to BETA. +C STPD: The relative step for computing finite difference +C derivatives with respect to DELTA. +C TAU: The trust region diameter. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C TT: The scaling values for DELTA. +C TYP: The CHARACTER*3 string "ODR" or "OLS". +C UPPER: Upper bound on BETA. +C WE: The EPSILON weights. +C WD: The DELTA weights. +C WSS: The sum-of-squares of the weighted EPSILONS and DELTAS, +C the sum-of-squares of the weighted DELTAS, and +C the sum-of-squares of the weighted EPSILONS. +C X: The explanatory variable. +C Y: The dependent variable. Unused when the model is implicit. + + +C***First executable statement DODPCR + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + & ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + PNLTY = ABS(WE(1,1,1)) + + IF (HEAD) THEN + CALL DODPHD(HEAD,LUNRPT) + END IF + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + +C Print initial summary + + IF (IFLAG.EQ.1) THEN + WRITE (LUNRPT,1200) TYP + CALL DODPC1 + & (IPR,LUNRPT, + & ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + & MSGB(1),MSGB(2),MSGD(1),MSGD(2), + & N,M,NP,NQ,NPP,NNZW, + & X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + & Y,LDY,WE,LDWE,LD2WE,PNLTY, + & BETA,IFIXB,SSF,STPB,LOWER,UPPER, + & JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + & WSS(1),WSS(2),WSS(3)) + +C Print iteration reports + + ELSE IF (IFLAG.EQ.2) THEN + + IF (FSTITR) THEN + WRITE (LUNRPT,1300) TYP + END IF + CALL DODPC2 + & (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + & PNLTY, + & NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) + +C Print final summary + + ELSE IF (IFLAG.EQ.3) THEN + + WRITE (LUNRPT,1400) TYP + CALL DODPC3 + & (IPR,LUNRPT, + & ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + & N,M,NP,NQ,NPP, + & INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + & WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, + & BETA,SDBETA,IFIXB,F,DELTA,LOWER,UPPER) + END IF + + RETURN + +C Format statements + + 1200 FORMAT + & (/' *** Initial summary for fit by method of ',A3, ' ***') + 1300 FORMAT + & (/' *** Iteration reports for fit by method of ',A3, ' ***') + 1400 FORMAT + & (/' *** Final summary for fit by method of ',A3, ' ***') + + END SUBROUTINE +*DODPE1 + SUBROUTINE DODPE1 + & (UNIT,INFO,D1,D2,D3,D4,D5, + & N,M,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LWKMN,LIWKMN) +C***Begin Prologue DODPE1 +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Print error reports +C***End Prologue DODPE1 + +C...Scalar arguments + INTEGER + & D1,D2,D3,D4,D5,INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, + & LIWKMN,LWKMN,M,N,NQ,UNIT + +C...Variable Definitions (alphabetically) +C D1: The 1st digit (from the left) of INFO. +C D2: The 2nd digit (from the left) of INFO. +C D3: The 3rd digit (from the left) of INFO. +C D4: The 4th digit (from the left) of INFO. +C D5: The 5th digit (from the left) of INFO. +C INFO: The variable designating why the computations were stopped. +C LDSCLD: The leading dimension of array SCLD. +C LDSTPD: The leading dimension of array STPD. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LIWKMN: The minimum acceptable length of array IWORK. +C LWKMN: The minimum acceptable length of array WORK. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NQ: The number of responses per observation. +C UNIT: The logical unit number used for error messages. + + +C***First executable statement DODPE1 + + +C Print appropriate messages for errors in problem specification +C parameters + + IF (D1.EQ.1) THEN + IF (D2.NE.0) THEN + WRITE(UNIT,1100) + END IF + IF (D3.NE.0) THEN + WRITE(UNIT,1200) + END IF + IF (D4.NE.0) THEN + WRITE(UNIT,1300) + END IF + IF (D5.NE.0) THEN + WRITE(UNIT,1400) + END IF + +C Print appropriate messages for errors in dimension specification +C parameters + + ELSE IF (D1.EQ.2) THEN + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + WRITE(UNIT,2110) + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,2120) + END IF + END IF + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN + WRITE(UNIT,2210) + END IF + IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2220) + END IF + IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2230) + END IF + END IF + + IF (D4.NE.0) THEN + IF (D4.EQ.1 .OR. D4.EQ.3) THEN + WRITE(UNIT,2310) + END IF + IF (D4.EQ.2 .OR. D4.EQ.3) THEN + WRITE(UNIT,2320) + END IF + END IF + + IF (D5.NE.0) THEN + IF (D5.EQ.1 .OR. D5.EQ.3) THEN + WRITE(UNIT,2410) LWKMN + END IF + IF (D5.EQ.2 .OR. D5.EQ.3) THEN + WRITE(UNIT,2420) LIWKMN + END IF + END IF + + ELSE IF (D1.EQ.3) THEN + +C Print appropriate messages for errors in scale values + + IF (D3.NE.0) THEN + IF (D3.EQ.2 .OR. D3.EQ.3) THEN + IF (LDSCLD.GE.N) THEN + WRITE(UNIT,3110) + ELSE + WRITE(UNIT,3120) + END IF + END IF + IF (D3.EQ.1 .OR. D3.EQ.3) THEN + WRITE(UNIT,3130) + END IF + END IF + +C Print appropriate messages for errors in derivative step values + + IF (D2.NE.0) THEN + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + IF (LDSTPD.GE.N) THEN + WRITE(UNIT,3210) + ELSE + WRITE(UNIT,3220) + END IF + END IF + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + WRITE(UNIT,3230) + END IF + END IF + +C Print appropriate messages for errors in observational error weights + + IF (D4.NE.0) THEN + IF (D4.EQ.1) THEN + IF (LDWE.GE.N) THEN + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3310) + ELSE + WRITE(UNIT,3320) + END IF + ELSE + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3410) + ELSE + WRITE(UNIT,3420) + END IF + END IF + END IF + IF (D4.EQ.2) THEN + WRITE(UNIT,3500) + END IF + END IF + +C Print appropriate messages for errors in DELTA weights + + IF (D5.NE.0) THEN + IF (LDWD.GE.N) THEN + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4310) + ELSE + WRITE(UNIT,4320) + END IF + ELSE + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4410) + ELSE + WRITE(UNIT,4420) + END IF + END IF + END IF + + ELSE IF (D1.EQ.7) THEN + +C Print the appropriate messages for errors in JOB + + IF (D2.NE.0) THEN + WRITE(UNIT,5000) + END IF + + IF (D3.NE.0) THEN + WRITE(UNIT,5100) + END IF + + IF (D4.NE.0) THEN + WRITE(UNIT,5200) + END IF + + ELSE IF (D1.EQ.8) THEN + +C Print the appropriate messages for errors in array allocation + + IF (D2.NE.0) THEN + WRITE(UNIT,7200) + END IF + + IF (D3.NE.0) THEN + WRITE(UNIT,7300) + END IF + + IF (D4.NE.0) THEN + WRITE(UNIT,7400) + END IF + + ELSE IF (D1.EQ.9) THEN + +C Print the appropriate messages for errors in bounds + + IF (D2.NE.0) THEN + WRITE(UNIT,6000) + END IF + + IF (D3.NE.0) THEN + WRITE(UNIT,6100) + END IF + + IF (D4.EQ.1) THEN + WRITE(UNIT,6210) + END IF + + IF (D4.EQ.2) THEN + WRITE(UNIT,6220) + END IF + + END IF + +C Print error messages for array sizes incorrect + + IF (INFO/100000.EQ.1) THEN + INFO = INFO - 100000 + IF (INFO.GE.32768) THEN + INFO = INFO - 32768 + WRITE(UNIT,8015) + END IF + IF (INFO.GE.16384) THEN + INFO = INFO - 16384 + WRITE(UNIT,8014) + END IF + IF (INFO.GE.8192) THEN + INFO = INFO - 8192 + WRITE(UNIT,8013) + END IF + IF (INFO.GE.4096) THEN + INFO = INFO - 4096 + WRITE(UNIT,8012) + END IF + IF (INFO.GE.2048) THEN + INFO = INFO - 2048 + WRITE(UNIT,8011) + END IF + IF (INFO.GE.1024) THEN + INFO = INFO - 1024 + WRITE(UNIT,8010) + END IF + IF (INFO.GE.512) THEN + INFO = INFO - 512 + WRITE(UNIT,8009) + END IF + IF (INFO.GE.256) THEN + INFO = INFO - 256 + WRITE(UNIT,8008) + END IF + IF (INFO.GE.128) THEN + INFO = INFO - 128 + WRITE(UNIT,8007) + END IF + IF (INFO.GE.64) THEN + INFO = INFO - 64 + WRITE(UNIT,8006) + END IF + IF (INFO.GE.32) THEN + INFO = INFO - 32 + WRITE(UNIT,8005) + END IF + IF (INFO.GE.16) THEN + INFO = INFO - 16 + WRITE(UNIT,8004) + END IF + IF (INFO.GE.8) THEN + INFO = INFO - 8 + WRITE(UNIT,8003) + END IF + IF (INFO.GE.4) THEN + INFO = INFO - 4 + WRITE(UNIT,8002) + END IF + IF (INFO.GE.2) THEN + INFO = INFO - 2 + WRITE(UNIT,8001) + END IF + IF (INFO.GE.1) THEN + INFO = INFO - 1 + WRITE(UNIT,8000) + END IF + END IF + +C Format statements + + 1100 FORMAT + & (/' ERROR : N is less than one.') + 1200 FORMAT + & (/' ERROR : M is less than one.') + 1300 FORMAT + & (/' ERROR : NP is less than one'/ + & ' or NP is greater than N.') + 1400 FORMAT + & (/' ERROR : NQ is less than one.') + 2110 FORMAT + & (/' ERROR : LDX is less than N.') + 2120 FORMAT + & (/' ERROR : LDY is less than N.') + 2210 FORMAT + & (/' ERROR : LDIFX is less than N'/ + & ' and LDIFX is not equal to one.') + 2220 FORMAT + & (/' ERROR : LDSCLD is less than N'/ + & ' and LDSCLD is not equal to one.') + 2230 FORMAT + & (/' ERROR : LDSTPD is less than N'/ + & ' and LDSTPD is not equal to one.') + 2310 FORMAT + & (/' ERROR : LDWE is less than N'/ + & ' and LDWE is not equal to one or'/ + & ' or'/ + & ' LD2WE is less than NQ'/ + & ' and LD2WE is not equal to one.') + 2320 FORMAT + & (/' ERROR : LDWD is less than N'/ + & ' and LDWD is not equal to one.') + 2410 FORMAT + & (/' ERROR : LWORK is less than ',I7, ','/ + & ' the smallest acceptable dimension of array WORK.') + 2420 FORMAT + & (/' ERROR : LIWORK is less than ',I7, ','/ + & ' the smallest acceptable dimension of array', + & ' IWORK.') + 3110 FORMAT + & (/' ERROR : SCLD(I,J) is less than or equal to zero'/ + & ' for some I = 1, ..., N and J = 1, ..., M.'// + & ' when SCLD(1,1) is greater than zero'/ + & ' and LDSCLD is greater than or equal to N then'/ + & ' each of the N by M elements of'/ + & ' SCLD must be greater than zero.') + 3120 FORMAT + & (/' ERROR : SCLD(1,J) is less than or equal to zero'/ + & ' for some J = 1, ..., M.'// + & ' when SCLD(1,1) is greater than zero'/ + & ' and LDSCLD is equal to one then'/ + & ' each of the 1 by M elements of'/ + & ' SCLD must be greater than zero.') + 3130 FORMAT + & (/' ERROR : SCLB(K) is less than or equal to zero'/ + & ' for some K = 1, ..., NP.'// + & ' all NP elements of', + & ' SCLB must be greater than zero.') + 3210 FORMAT + & (/' ERROR : STPD(I,J) is less than or equal to zero'/ + & ' for some I = 1, ..., N and J = 1, ..., M.'// + & ' when STPD(1,1) is greater than zero'/ + & ' and LDSTPD is greater than or equal to N then'/ + & ' each of the N by M elements of'/ + & ' STPD must be greater than zero.') + 3220 FORMAT + & (/' ERROR : STPD(1,J) is less than or equal to zero'/ + & ' for some J = 1, ..., M.'// + & ' when STPD(1,1) is greater than zero'/ + & ' and LDSTPD is equal to one then'/ + & ' each of the 1 by M elements of'/ + & ' STPD must be greater than zero.') + 3230 FORMAT + & (/' ERROR : STPB(K) is less than or equal to zero'/ + & ' for some K = 1, ..., NP.'// + & ' all NP elements of', + & ' STPB must be greater than zero.') + 3310 FORMAT + & (/' ERROR : At least one of the (NQ by NQ) arrays starting'/ + & ' in WE(I,1,1), I = 1, ..., N, is not positive'/ + & ' semidefinite. When WE(1,1,1) is greater than'/ + & ' or equal to zero, and LDWE is greater than or'/ + & ' equal to N, and LD2WE is greater than or equal'/ + & ' to NQ, then each of the (NQ by NQ) arrays in WE'/ + & ' must be positive semidefinite.') + 3320 FORMAT + & (/' ERROR : At least one of the (1 by NQ) arrays starting'/ + & ' in WE(I,1,1), I = 1, ..., N, has a negative'/ + & ' element. When WE(1,1,1) is greater than or'/ + & ' equal to zero, and LDWE is greater than or equal'/ + & ' to N, and LD2WE is equal to 1, then each of the'/ + & ' (1 by NQ) arrays in WE must have only non-'/ + & ' negative elements.') + 3410 FORMAT + & (/' ERROR : The (NQ by NQ) array starting in WE(1,1,1) is'/ + & ' not positive semidefinite. When WE(1,1,1) is'/ + & ' greater than or equal to zero, and LDWE is equal'/ + & ' to 1, and LD2WE is greater than or equal to NQ,'/ + & ' then the (NQ by NQ) array in WE must be positive'/ + & ' semidefinite.') + 3420 FORMAT + & (/' ERROR : The (1 by NQ) array starting in WE(1,1,1) has'/ + & ' a negative element. When WE(1,1,1) is greater'/ + & ' than or equal to zero, and LDWE is equal to 1,'/ + & ' and LD2WE is equal to 1, then the (1 by NQ)'/ + & ' array in WE must have only nonnegative elements.') + 3500 FORMAT + & (/' ERROR : The number of nonzero arrays in array WE is'/ + & ' less than NP.') + 4310 FORMAT + & (/' ERROR : At least one of the (M by M) arrays starting'/ + & ' in WD(I,1,1), I = 1, ..., N, is not positive'/ + & ' definite. When WD(1,1,1) is greater than zero,'/ + & ' and LDWD is greater than or equal to N, and'/ + & ' LD2WD is greater than or equal to M, then each'/ + & ' of the (M by M) arrays in WD must be positive'/ + & ' definite.') + 4320 FORMAT + & (/' ERROR : At least one of the (1 by M) arrays starting'/ + & ' in WD(I,1,1), I = 1, ..., N, has a nonpositive'/ + & ' element. When WD(1,1,1) is greater than zero,'/ + & ' and LDWD is greater than or equal to N, and'/ + & ' LD2WD is equal to 1, then each of the (1 by M)'/ + & ' arrays in WD must have only positive elements.') + 4410 FORMAT + & (/' ERROR : The (M by M) array starting in WD(1,1,1) is'/ + & ' not positive definite. When WD(1,1,1) is'/ + & ' greater than zero, and LDWD is equal to 1, and'/ + & ' LD2WD is greater than or equal to M, then the'/ + & ' (M by M) array in WD must be positive definite.') + 4420 FORMAT + & (/' ERROR : The (1 by M) array starting in WD(1,1,1) has a'/ + & ' nonpositive element. When WD(1,1,1) is greater'/ + & ' than zero, and LDWD is equal to 1, and LD2WD is'/ + & ' equal to 1, then the (1 by M) array in WD must'/ + & ' have only positive elements.') + 5000 FORMAT + & (/' ERROR : JOB requires the optional argument DELTA and'/ + & ' DELTA is not present or not associated.') + 5100 FORMAT + & (/' ERROR : JOB requires the optional argument WORK and'/ + & ' WORK is not present or not associated.') + 5200 FORMAT + & (/' ERROR : JOB requires the optional argument IWORK and'/ + & ' IWORK is not present or not associated.') + 6000 FORMAT + & (/' ERROR : LOWER(K).GT.UPPER(K) for some K. Adjust the'/ + & ' the bounds so that LOWER(K).LE.UPPER(K) holds'/ + & ' for all K.') + 6100 FORMAT + & (/' ERROR : BETA(K).GT.UPPER(K) or BETA(K).LT.LOWER(K) '/ + & ' for some K. Adjust the bounds or BETA so '/ + & ' that LOWER(K).LE.BETA(K).LE.UPPER(K) holds'/ + & ' for all K.') + 6210 FORMAT + & (/' ERROR : UPPER(K)-LOWER(K) .LT. 400*BETA(K)*EPSMAC '/ + & ' for some K and EPSMAC having the largest '/ + & ' value such that 1+EPSMAC.NE.1. This '/ + & ' constraint on UPPER and LOWER is necessary'/ + & ' for the calculation of NDIGIT. Increase the'/ + & ' range of the bounds or specify NDIGIT '/ + & ' explicitly.') + 6220 FORMAT + & (/' ERROR : UPPER(K)-LOWER(K) .LT. ABS(STEP) for some'/ + & ' K where step is the step size for numeric'/ + & ' derivatives. Increase the bounds or supply'/ + & ' an analytic jacobian.') + 7200 FORMAT + & (/' ERROR : DELTA could not be allocated. ') + 7300 FORMAT + & (/' ERROR : WORK could not be allocated. ') + 7400 FORMAT + & (/' ERROR : IWORK could not be allocated. ') + 8000 FORMAT + & (/' ERROR : BETA has incorrect size. ') + 8001 FORMAT + & (/' ERROR : Y has incorrect size. ') + 8002 FORMAT + & (/' ERROR : X has incorrect size. ') + 8003 FORMAT + & (/' ERROR : DELTA has incorrect size. ') + 8004 FORMAT + & (/' ERROR : WE has incorrect size. ') + 8005 FORMAT + & (/' ERROR : WD has incorrect size. ') + 8006 FORMAT + & (/' ERROR : IFIXB has incorrect size. ') + 8007 FORMAT + & (/' ERROR : IFIXX has incorrect size. ') + 8008 FORMAT + & (/' ERROR : STPB has incorrect size. ') + 8009 FORMAT + & (/' ERROR : STPD has incorrect size. ') + 8010 FORMAT + & (/' ERROR : SCLB has incorrect size. ') + 8011 FORMAT + & (/' ERROR : SCLD has incorrect size. ') + 8012 FORMAT + & (/' ERROR : WORK has incorrect size. ') + 8013 FORMAT + & (/' ERROR : IWORK has incorrect size. ') + 8014 FORMAT + & (/' ERROR : UPPER has incorrect size. ') + 8015 FORMAT + & (/' ERROR : LOWER has incorrect size. ') + END SUBROUTINE +*DODPE2 + SUBROUTINE DODPE2 + & (UNIT, + & N,M,NP,NQ, + & FJACB,FJACD, + & DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, + & XPLUSD,NROW,NETA,NTOL) +C***Begin Prologue DODPE2 +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Generate the derivative checking report +C***End Prologue DODPE2 + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + & MSGB(NQ,NP),MSGD(NQ,M) + +C...Local scalars + INTEGER + & I,J,K,L + CHARACTER FLAG*1,TYP*3 + +C...Local arrays + LOGICAL + & FTNOTE(0:9) + +C...Variable Definitions (alphabetically) +C DIFF: The relative differences between the user supplied and +C finite difference derivatives for each derivative checked. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FLAG: The character string indicating highly questionable results. +C FTNOTE: The array controling footnotes. +C I: An index variable. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=.TRUE.) or by OLS (ISODR=.FALSE.). +C J: An index variable. +C K: An index variable. +C L: An index variable. +C M: The number of columns of data in the explanatory variable. +C MSGB: The error checking results for the Jacobian wrt BETA. +C MSGB1: The error checking results for the Jacobian wrt BETA. +C MSGD: The error checking results for the Jacobian wrt DELTA. +C MSGD1: The error checking results for the Jacobian wrt DELTA. +C N: The number of observations. +C NETA: The number of reliable digits in the model. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the explanatory variable array at +C which the derivative is to be checked. +C NTOL: The number of digits of agreement required between the +C finite difference and the user supplied derivatives. +C TYP: The character string indicating solution type, ODR or OLS. +C UNIT: The logical unit number used for error messages. +C XPLUSD: The values of X + DELTA. + + +C***First executable statement DODPE2 + + +C Set up for footnotes + + DO 10 I=0,9 + FTNOTE(I) = .FALSE. + 10 CONTINUE + + DO 40 L=1,NQ + IF (MSGB1.GE.1) THEN + DO 20 I=1,NP + IF (MSGB(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGB(L,I)) = .TRUE. + END IF + 20 CONTINUE + END IF + + IF (MSGD1.GE.1) THEN + DO 30 I=1,M + IF (MSGD(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGD(L,I)) = .TRUE. + END IF + 30 CONTINUE + END IF + 40 CONTINUE + +C Print report + + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + WRITE (UNIT,1000) TYP + + DO 70 L=1,NQ + + WRITE (UNIT,2100) L,NROW + WRITE (UNIT,2200) + + DO 50 I=1,NP + K = MSGB(L,I) + IF (K.EQ.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,3100) I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG + ELSE IF (K.EQ.8) THEN + WRITE (UNIT,3400) I,FJACB(NROW,I,L),FLAG,K + ELSE IF (K.EQ.9) THEN + WRITE (UNIT,3500) I,FLAG,K + ELSE IF (K.GE.1) THEN + WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K + END IF + 50 CONTINUE + IF (ISODR) THEN + DO 60 I=1,M + K = MSGD(L,I) + IF (K.EQ.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,4100) NROW,I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,4200) NROW,I, + & FJACD(NROW,I,L),DIFF(L,NP+I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,4300) NROW,I, + & FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K + END IF + 60 CONTINUE + END IF + 70 CONTINUE + +C Print footnotes + + IF (FTNOTE(0)) THEN + + WRITE (UNIT,5000) + IF (FTNOTE(1)) WRITE (UNIT,5100) + IF (FTNOTE(2)) WRITE (UNIT,5200) + IF (FTNOTE(3)) WRITE (UNIT,5300) + IF (FTNOTE(4)) WRITE (UNIT,5400) + IF (FTNOTE(5)) WRITE (UNIT,5500) + IF (FTNOTE(6)) WRITE (UNIT,5600) + IF (FTNOTE(7)) WRITE (UNIT,5700) + IF (FTNOTE(8)) WRITE (UNIT,5800) + IF (FTNOTE(9)) WRITE (UNIT,5900) + END IF + + IF (NETA.LT.0) THEN + WRITE (UNIT,6000) -NETA + ELSE + WRITE (UNIT,6100) NETA + END IF + WRITE (UNIT,7000) NTOL + +C Print out row of explanatory variable which was checked. + + WRITE (UNIT,8100) NROW + + DO 80 J=1,M + WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) + 80 CONTINUE + + RETURN + +C Format statements + + 1000 FORMAT + & (//' *** Derivative checking report for fit by method of ',A3, + & ' ***'/) + 2100 FORMAT (/' For response ',I2,' of observation ', I5/) + 2200 FORMAT (' ',' User', + & ' ',' '/ + & ' ',' Supplied', + & ' Relative',' Derivative '/ + & ' Derivative WRT',' Value', + & ' Difference',' Assessment '/) + 3100 FORMAT (' BETA(',I3,')', ' --- ', + & ' --- ',' Unchecked') + 3200 FORMAT (' BETA(',I3,')', 1P,2E13.2,3X,A1, + & 'Verified') + 3300 FORMAT (' BETA(',I3,')', 1P,2E13.2,3X,A1, + & 'Questionable (see note ',I1,')') + 3400 FORMAT (' BETA(',I3,')', 1P,1E13.2,13X,3X,A1, + & 'Questionable (see note ',I1,')') + 3500 FORMAT (' BETA(',I3,')', 1P,13X,13X,3X,A1, + & 'Small bounds (see note ',I1,')') + 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', + & ' --- ',' Unchecked') + 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2E13.2,3X,A1, + & 'Verified') + 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2E13.2,3X,A1, + & 'Questionable (see note ',I1,')') + 5000 FORMAT + & (/' NOTES:') + 5100 FORMAT + & (/' (1) User supplied and finite difference derivatives', + & ' agree, but'/ + & ' results are questionable because both are zero.') + 5200 FORMAT + & (/' (2) User supplied and finite difference derivatives', + & ' agree, but'/ + & ' results are questionable because one is', + & ' identically zero'/ + & ' and the other is only approximately zero.') + 5300 FORMAT + & (/' (3) User supplied and finite difference derivatives', + & ' disagree, but'/ + & ' results are questionable because one is', + & ' identically zero'/ + & ' and the other is not.') + 5400 FORMAT + & (/' (4) User supplied and finite difference derivatives', + & ' disagree, but'/ + & ' finite difference derivative is questionable', + & ' because either'/ + & ' the ratio of relative curvature to relative', + & ' slope is too high'/ + & ' or the scale is wrong.') + 5500 FORMAT + & (/' (5) User supplied and finite difference derivatives', + & ' disagree, but'/ + & ' finite difference derivative is questionable', + & ' because the'/ + & ' ratio of relative curvature to relative slope is', + & ' too high.') + 5600 FORMAT + & (/' (6) User supplied and finite difference derivatives', + & ' disagree, but'/ + & ' have at least 2 digits in common.') + 5700 FORMAT + & (/' (7) User supplied and finite difference derivatives', + & ' disagree, and'/ + & ' have fewer than 2 digits in common. derivative', + & ' checking must'/ + & ' be turned off in order to proceed.') + 5800 FORMAT + & (/' (8) User supplied and finite difference derivatives', + & ' disagree, and'/ + & ' bound constraints are too small to calculate', + & ' further'/ + & ' information.') + 5900 FORMAT + & (/' (9) Bound constraints too small to check derivative.') + 6000 FORMAT + & (/' Number of reliable digits in function results ', + & I5/ + & ' (estimated by ODRPACK95)') + 6100 FORMAT + & (/' Number of reliable digits in function results ', + & I5/ + & ' (supplied by user)') + 7000 FORMAT + & (/' Number of digits of agreement required between '/ + & ' user supplied and finite difference derivative for '/ + & ' user supplied derivative to be considered verified ', + & I5) + 8100 FORMAT + & (/' Row number at which derivatives were checked ', + & I5// + & ' -values of the explanatory variables at this row'/) + 8110 FORMAT + & (10X,'X(',I2,',',I2,')',1X,1P,3E16.8) + END SUBROUTINE +*DODPE3 + SUBROUTINE DODPE3 + & (UNIT,D2,D3) +C***Begin Prologue DODPE3 +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Print error reports indicating that computations were +C stopped in user supplied subroutines FCN +C***End Prologue DODPE3 + +C...Scalar arguments + INTEGER + & D2,D3,UNIT + +C...Variable Definitions (alphabetically) +C D2: The 2nd digit (from the left) of INFO. +C D3: The 3rd digit (from the left) of INFO. +C UNIT: The logical unit number used for error messages. + + +C***First executable statement DODPE3 + + +C Print appropriate messages to indicate where computations were +C stopped + + IF (D2.EQ.2) THEN + WRITE(UNIT,1100) + ELSE IF (D2.EQ.3) THEN + WRITE(UNIT,1200) + ELSE IF (D2.EQ.4) THEN + WRITE(UNIT,1300) + END IF + IF (D3.EQ.2) THEN + WRITE(UNIT,1400) + END IF + +C Format statements + + 1100 FORMAT + & (//' Variable ISTOP has been returned with a nonzero value '/ + & ' from user supplied subroutine FCN when invoked using the'/ + & ' initial estimates of BETA and DELTA supplied by the '/ + & ' user. The initial estimates must be adjusted to allow '/ + & ' proper evaluation of subroutine FCN before the '/ + & ' regression procedure can continue.') + 1200 FORMAT + & (//' Variable ISTOP has been returned with a nonzero value '/ + & ' from user supplied subroutine FCN. This occurred during'/ + & ' the computation of the number of reliable digits in the '/ + & ' predicted values (F) returned from subroutine FCN, indi-'/ + & ' cating that changes in the initial estimates of BETA(K),'/ + & ' K=1,NP, as small as 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + & ' where MACHINE PRECISION is defined as the smallest value'/ + & ' E such that 1+E>1 on the computer being used, prevent '/ + & ' subroutine FCN from being properly evaluated. The '/ + & ' initial estimates must be adjusted to allow proper '/ + & ' evaluation of subroutine FCN during these computations '/ + & ' before the regression procedure can continue.') + 1300 FORMAT + & (//' Variable ISTOP has been returned with a nonzero value '/ + & ' from user supplied subroutine FCN. This occurred during'/ + & ' the derivative checking procedure, indicating that '/ + & ' changes in the initial estimates of BETA(K), K=1,NP, as '/ + & ' small as MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), and/or '/ + & ' of DELTA(I,J), I=1,N and J=1,M, as small as '/ + & ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), where NETA '/ + & ' is defined to be the number of reliable digits in '/ + & ' predicted values (F) returned from subroutine FCN, '/ + & ' prevent subroutine FCN from being properly evaluated. '/ + & ' the initial estimates must be adjusted to allow proper '/ + & ' evaluation of subroutine FCN during these computations '/ + & ' before the regression procedure can continue.') + 1400 FORMAT + & (//' Variable ISTOP has been returned with a nonzero value '/ + & ' from user supplied subroutine FCN when invoked for '/ + & ' derivative evaluations using the initial estimates of '/ + & ' BETA and DELTA supplied by the user. The initial '/ + & ' estimates must be adjusted to allow proper evaluation '/ + & ' of subroutine FCN before the regression procedure can '/ + & ' continue.') + END SUBROUTINE +*DODPER + SUBROUTINE DODPER + & (INFO,LUNERR, + & N,M,NP,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LWKMN,LIWKMN, + & FJACB,FJACD, + & DIFF,MSGB,ISODR,MSGD, + & XPLUSD,NROW,NETA,NTOL) +C***Begin Prologue DODPER +C***Refer to ODR +C***Routines Called DODPE1,DODPE2,DODPE3,DODPHD +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Controlling routine for printing error reports +C***End Prologue DODPER + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, + & M,N,NETA,NP,NQ,NROW,NTOL + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + & MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...Local scalars + INTEGER + & D1,D2,D3,D4,D5,UNIT + LOGICAL + & HEAD + +C...External subroutines + EXTERNAL + & DODPE1,DODPE2,DODPE3,DODPHD + +C...Variable Definitions (alphabetically) +C D1: The 1st digit (from the left) of INFO. +C D2: The 2nd digit (from the left) of INFO. +C D3: The 3rd digit (from the left) of INFO. +C D4: The 4th digit (from the left) of INFO. +C D5: The 5th digit (from the left) of INFO. +C DIFF: The relative differences between the user supplied and +C finite difference derivatives for each derivative checked. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C HEAD: The variable designating whether the heading is to be +C printed (HEAD=.TRUE.) or not (HEAD=.FALSE.). +C INFO: The variable designating why the computations were stopped. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=.TRUE.) or by OLS (ISODR=.FALSE.). +C LDSCLD: The leading dimension of array SCLD. +C LDSTPD: The leading dimension of array STPD. +C LDWD: The leading dimension of array WD. +C LDWE: The leading dimension of array WE. +C LD2WD: The second dimension of array WD. +C LD2WE: The second dimension of array WE. +C LIWKMN: The minimum acceptable length of array IWORK. +C LUNERR: The logical unit number used for error messages. +C LWKMN: The minimum acceptable length of array WORK. +C M: The number of columns of data in the explanatory variable. +C MSGB: The error checking results for the Jacobian wrt BETA. +C MSGD: The error checking results for the Jacobian wrt DELTA. +C N: The number of observations. +C NETA: The number of reliable digits in the model. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the explanatory variable array at +C which the derivative is to be checked. +C NTOL: The number of digits of agreement required between the +C finite difference and the user supplied derivatives. +C UNIT: The logical unit number for error messages. +C XPLUSD: The values X + DELTA. + + +C***First executable statement DODPER + + +C Set logical unit number for error report + + IF (LUNERR.EQ.0) THEN + RETURN + ELSE IF (LUNERR.LT.0) THEN + UNIT = 6 + ELSE + UNIT = LUNERR + END IF + +C Print heading + + HEAD = .TRUE. + CALL DODPHD(HEAD,UNIT) + +C Extract individual digits from variable INFO + + D1 = MOD(INFO,100000)/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C Print appropriate error messages for ODRPACK95 invoked stop + + IF ( + & (D1.GE.1 .AND. D1.LE.3) .OR. + & (D1.EQ.7 .OR. D1.EQ.9) + & ) THEN + +C Print appropriate messages for errors in +C problem specification parameters +C dimension specification parameters +C number of good digits in X +C weights + + CALL DODPE1(UNIT,INFO,D1,D2,D3,D4,D5, + & N,M,NQ, + & LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + & LWKMN,LIWKMN) + + ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN + +C Print appropriate messages for derivative checking + + CALL DODPE2(UNIT, + & N,M,NP,NQ, + & FJACB,FJACD, + & DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), + & XPLUSD,NROW,NETA,NTOL) + + ELSE IF (D1.EQ.5) THEN + +C Print appropriate error message for user invoked stop from FCN + + CALL DODPE3(UNIT,D2,D3) + + END IF + +C Print correct form of call statement + + IF ((D1.GE.1 .AND. D1.LE.3) .OR. + & (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + & (D1.EQ.5)) THEN + WRITE (UNIT,1100) + END IF + + RETURN + +C Format statements + + 1100 FORMAT + & (//' The correct form of the call statement is '// + & ' CALL ODR'/ + & ' + (FCN,'/ + & ' + N,M,NP,NQ,'/ + & ' + BETA,'/ + & ' + Y,X,'/ + & ' + DELTA*,'/ + & ' + WE*,WD*,'/ + & ' + IFIXB*,IFIXX*,'/ + & ' + JOB*,NDIGIT*,TAUFAC*,'/ + & ' + SSTOL*,PARTOL*,MAXIT*,'/ + & ' + IPRINT*,LUNERR*,LUNRPT*,'/ + & ' + STPB*,STPD*,'/ + & ' + SCLB*,SCLD*,'/ + & ' + WORK*,IWORK*,'/ + & ' + INFO*,'/ + & ' + LOWER*,UPPER*)'/ + & ' * optional argument') + + END SUBROUTINE +*DODPHD + SUBROUTINE DODPHD + & (HEAD,UNIT) +C***Begin Prologue DODPHD +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Print ODRPACK95 heading +C***End Prologue DODPHD + +C...Scalar arguments + INTEGER + & UNIT + LOGICAL + & HEAD + +C...Variable Definitions (alphabetically) +C HEAD: The variable designating whether the heading is to be +C printed (HEAD=.TRUE.) or not (HEAD=.FALSE.). +C UNIT: The logical unit number to which the heading is written. + + +C***First executable statement DODPHD + + + IF (HEAD) THEN + WRITE(UNIT,1000) + HEAD = .FALSE. + END IF + + RETURN + +C Format statements + + 1000 FORMAT ( + & ' ********************************************************* '/ + & ' * ODRPACK95 version 1.00 of 12-27-2005 (REAL (KIND=R8)) * '/ + & ' ********************************************************* '/) + END SUBROUTINE +*DODSTP + SUBROUTINE DODSTP + & (N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + & ALPHA,EPSFCN,ISODR, + & TFJACB,OMEGA,U,QRAUX,KPVT, + & S,T,PHI,IRANK,RCOND,FORVCV, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***Begin Prologue DODSTP +C***Refer to ODR +C***Routines Called IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT, +C DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute locally constrained steps S and T, and PHI(ALPHA) +C***End Prologue DODSTP + +C...Used modules + USE REAL_PRECISION + USE ODRPACK95, ONLY : TEMPRET + +C...Scalar arguments + REAL (KIND=R8) + & ALPHA,EPSFCN,PHI,RCOND + INTEGER + & IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + & OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + & T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + & WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) + INTEGER + & KPVT(NP) + +C...Local scalars + REAL (KIND=R8) + & CO,ONE,SI,TEMP,ZERO + INTEGER + & I,IMAX,INF,IPVT,J,K,K1,K2,KP,L + LOGICAL + & ELIM,FORVCV + +C...LOCAL ARRAYS + REAL (KIND=R8) + & DUM(2) + +C...External functions + REAL (KIND=R8) + & DNRM2 + INTEGER + & IDAMAX + EXTERNAL + & DNRM2,IDAMAX + +C...External subroutines + EXTERNAL + & DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, + & DSOLVE,DTRCO,DTRSL,DVEVTR,DZERO + +C...Data statements + DATA + & ZERO,ONE + & /0.0E0_R8,1.0E0_R8/ + +C...Interface blocks + INTERFACE + SUBROUTINE DWGHT + & (N,M,WT,LDWT,LD2WT,T,WTT) + USE REAL_PRECISION + INTEGER + & LDWT,LD2WT,M,N + REAL (KIND=R8) + & T(:,:),WT(:,:,:),WTT(:,:) + END SUBROUTINE + END INTERFACE + +C...Variable definitions (alphabetically) +C ALPHA: The Levenberg-Marquardt parameter. +C CO: The cosine from the plane rotation. +C DELTA: The estimated errors in the explanatory variables. +C DUM: A dummy array. +C ELIM: The variable designating whether columns of the Jacobian +C wrt BETA have been eliminated (ELIM=TRUE) or not +C (ELIM=FALSE). +C EPSFCN: The function's precision. +C F: The (weighted) estimated values of EPSILON. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FORVCV: The variable designating whether this subroutine was +C called to set up for the covariance matrix computations +C (FORVCV=TRUE) or not (FORVCV=FALSE). +C I: An indexing variable. +C IMAX: The index of the element of U having the largest absolute +C value. +C INF: The return code from LINPACK routines. +C IPVT: The variable designating whether pivoting is to be done. +C IRANK: The rank deficiency of the Jacobian wrt BETA. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOPC: The variable designating whether the computations were +C stoped due to a numerical error within subroutine DODSTP. +C J: An indexing variable. +C K: An indexing variable. +C K1: An indexing variable. +C K2: An indexing variable. +C KP: The rank of the Jacobian wrt BETA. +C KPVT: The pivot vector. +C L: An indexing variable. +C LDTT: The leading dimension of array TT. +C LDWD: The leading dimension of array WD. +C LD2WD: The second dimension of array WD. +C LWRK: The length of vector WRK. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NP: The number of function parameters. +C NPP: The number of function parameters being estimated. +C OMEGA: The array defined S.T. +C OMEGA*trans(OMEGA) = inv(I+FJACD*inv(E)*trans(FJACD)) +C = (I-FJACD*inv(P)*trans(FJACD)) +C where E = D**2 + ALPHA*TT**2 +C P = trans(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C ONE: The value 1.0E0_R8. +C PHI: The difference between the norm of the scaled step +C And the trust region diameter. +C QRAUX: The array required to recover the orthogonal part of the +C Q-R decomposition. +C RCOND: The approximate reciprocal condition number of TFJACB. +C S: The step for BETA. +C SI: The sine from the plane rotation. +C SS: The scaling values for the unfixed BETAS. +C T: The step for DELTA. +C TEMP: A temporary storage LOCATION. +C TFJACB: The array OMEGA*FJACB. +C TT: The scaling values for DELTA. +C U: The approximate null vector for TFJACB. +C WD: The (squared) DELTA weights. +C WRK: A work array of (LWRK) elements, +C equivalenced to WRK1 and WRK2. +C WRK1: A work array of (N by NQ by M) elements. +C WRK2: A work array of (N by NQ) elements. +C WRK3: A work array of (NP) elements. +C WRK4: A work array of (M by M) elements. +C WRK5: A work array of (M) elements. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODSTP + + +C Compute loop parameters which depend on weight structure + +C Set up KPVT if ALPHA = 0 + + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + DO 10 K=1,NP + KPVT(K) = K + 10 CONTINUE + ELSE + IF (NPP.GE.1) THEN + KP = NPP-IRANK + ELSE + KP = NPP + END IF + END IF + + IF (ISODR) THEN + +C T = WD * DELTA = D*G2 + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,T) + + DO 300 I=1,N + +C Compute WRK4, such that +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C Compute OMEGA, such that +C trans(OMEGA)*OMEGA = I+FJACD*inv(E)*trans(FJACD) +C inv(trans(OMEGA)*OMEGA) = I-FJACD*inv(P)*trans(FJACD) + CALL DVEVTR(M,NQ,I, + & FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) + DO 110 L=1,NQ + OMEGA(L,L) = ONE + OMEGA(L,L) + 110 CONTINUE + CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C Compute WRK1 = trans(FJACD)*(I-FJACD*inv(P)*trans(JFACD)) +C = trans(FJACD)*inv(trans(OMEGA)*OMEGA) + DO 130 J=1,M + DO 120 L=1,NQ + WRK1(I,L,J) = FJACD(I,J,L) + 120 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1:NQ,J),4) + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1:NQ,J),2) + 130 CONTINUE + +C Compute WRK5 = inv(E)*D*G2 + DO 140 J=1,M + WRK5(J) = T(I,J) + 140 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,4) + CALL DSOLVE(M,WRK4,M,WRK5,2) + +C Compute TFJACB = inv(trans(OMEGA))*FJACB + DO 170 K=1,KP + DO 150 L=1,NQ + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + 150 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1:NQ,K),4) + DO 160 L=1,NQ + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 160 CONTINUE + 170 CONTINUE + +C Compute WRK2 = (V*inv(E)*D**2*G2 - G1) + DO 190 L=1,NQ + WRK2(I,L) = ZERO + DO 180 J=1,M + WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) + 180 CONTINUE + WRK2(I,L) = WRK2(I,L) - F(I,L) + 190 CONTINUE + +C Compute WRK2 = inv(trans(OMEGA))*(V*inv(E)*D**2*G2 - G1) + CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1:NQ),4) + 300 CONTINUE + + ELSE + DO 360 I=1,N + DO 350 L=1,NQ + DO 340 K=1,KP + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 340 CONTINUE + WRK2(I,L) = -F(I,L) + 350 CONTINUE + 360 CONTINUE + END IF + +C Compute S + +C Do QR factorization (with column pivoting of TFJACB if ALPHA = 0) + + IF (ALPHA.EQ.ZERO) THEN + IPVT = 1 + DO 410 K=1,NP + KPVT(K) = 0 + 410 CONTINUE + ELSE + IPVT = 0 + END IF + + CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) + CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, + & QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C Eliminate alpha part using givens rotations + + IF (ALPHA.NE.ZERO) THEN + CALL DZERO(NPP,1,S,NPP) + DO 430 K1=1,KP + CALL DZERO(KP,1,WRK3,KP) + WRK3(K1) = SQRT(ALPHA) + DO 420 K2=K1,KP + CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) + IF (KP-K2.GE.1) THEN + CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, + & WRK3(K2+1),1,CO,SI) + END IF + TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) + S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) + WRK2(K2,1) = TEMP + 420 CONTINUE + 430 CONTINUE + END IF + +C Compute solution - eliminate variables if necessary + + IF (NPP.GE.1) THEN + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + +C Estimate RCOND - U will contain approx null vector + + 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) + IF (RCOND.LE.EPSFCN) THEN + ELIM = .TRUE. + IMAX = IDAMAX(KP,U,1) + +C IMAX is the column to remove - use DCHEX and fix KPVT + + IF (IMAX.NE.KP) THEN + CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, + & QRAUX,WRK3,2) + K = KPVT(IMAX) + DO 450 I=IMAX,KP-1 + KPVT(I) = KPVT(I+1) + 450 CONTINUE + KPVT(KP) = K + END IF + KP = KP-1 + ELSE + ELIM = .FALSE. + END IF + IF (ELIM .AND. KP.GE.1) THEN + GO TO 440 + ELSE + IRANK = NPP-KP + END IF + END IF + END IF + + IF (FORVCV) RETURN + +C Backsolve and unscramble + + IF (NPP.GE.1) THEN + DO 510 I=KP+1,NPP + WRK2(I,1) = ZERO + 510 CONTINUE + IF (KP.GE.1) THEN + CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + END IF + DO 520 I=1,NPP + IF (SS(1).GT.ZERO) THEN + S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) + ELSE + S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) + END IF + 520 CONTINUE + END IF + + IF (ISODR) THEN + +C NOTE: T and WRK1 have been initialized above, +C where T = WD * DELTA = D*G2 +C WRK1 = trans(FJACD)*(I-FJACD*inv(P)*trans(JFACD)) + + DO 670 I=1,N + +C Compute WRK4, such that +C trans(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C Compute WRK5 = inv(E)*D*G2 + DO 610 J=1,M + WRK5(J) = T(I,J) + 610 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,4) + CALL DSOLVE(M,WRK4,M,WRK5,2) + + DO 640 L=1,NQ + WRK2(I,L) = F(I,L) + DO 620 K=1,NPP + WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) + 620 CONTINUE + DO 630 J=1,M + WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) + 630 CONTINUE + 640 CONTINUE + + DO 660 J=1,M + WRK5(J) = ZERO + DO 650 L=1,NQ + WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) + 650 CONTINUE + T(I,J) = -(WRK5(J) + T(I,J)) + 660 CONTINUE + CALL DSOLVE(M,WRK4,M,T(I,1:M),4) + CALL DSOLVE(M,WRK4,M,T(I,1:M),2) + 670 CONTINUE + + END IF + +C Compute PHI(ALPHA) from scaled S and T + + CALL DWGHT(NPP,1,RESHAPE(SS,(/NPP,1,1/)),NPP,1, + & RESHAPE(S,(/NPP,1/)),TEMPRET(1:NPP,1:1)) + WRK(1:NPP) = TEMPRET(1:NPP,1) + IF (ISODR) THEN + CALL DWGHT(N,M,RESHAPE(TT,(/LDTT,1,M/)),LDTT,1, + & T,TEMPRET(1:N,1:M)) + WRK(NPP+1:NPP+1+N*M-1) = RESHAPE(TEMPRET(1:N,1:M),(/N*M/)) + PHI = DNRM2(NPP+N*M,WRK,1) + ELSE + PHI = DNRM2(NPP,WRK,1) + END IF + + RETURN + END SUBROUTINE +*DODVCV + SUBROUTINE DODVCV + & (N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + & EPSFCN,ISODR, + & VCV,SD, + & WRK6,OMEGA,U,QRAUX,JPVT, + & S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***Begin Prologue DODVCV +C***Refer to ODR +C***Routines Called DPODI,DODSTP +C***Date Written 901207 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute covariance matrix of estimated parameters +C***End Prologue DODVCV + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & EPSFCN,RCOND,RSS,RVAR + INTEGER + & IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + & ISODR + +C...Array arguments + REAL (KIND=R8) + & DELTA(N,M),F(N,NQ), + & FJACB(N,NP,NQ),FJACD(N,M,NQ), + & OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), + & T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), + & WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), + & WRK6(N*NQ,NP),WRK(LWRK) + INTEGER + & IFIXB(NP),JPVT(NP) + +C...Local scalars + REAL (KIND=R8) + & TEMP,ZERO + INTEGER + & I,IUNFIX,J,JUNFIX,KP,L + LOGICAL + & FORVCV + +C...External subroutines + EXTERNAL + & DPODI,DODSTP + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable definitions (alphabetically) +C DELTA: The estimated errors in the explanatory variables. +C EPSFCN: The function's precision. +C F: The (weighted) estimated values of EPSILON. +C FJACB: The Jacobian with respect to BETA. +C FJACD: The Jacobian with respect to DELTA. +C FORVCV: The variable designating whether subroutine DODSTP is +C called to set up for the covariance matrix computations +C (FORVCV=TRUE) or not (FORVCV=FALSE). +C I: An indexing variable. +C IDF: The degrees of freedom of the fit, equal to the number of +C observations with nonzero weighted derivatives minus the +C number of parameters being estimated. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IMAX: The index of the element of U having the largest absolute +C value. +C IRANK: The rank deficiency of the Jacobian wrt BETA. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C ISTOPC: The variable designating whether the computations were +C stoped due to a numerical error within subroutine DODSTP. +C IUNFIX: The index of the next unfixed parameter. +C J: An indexing variable. +C JPVT: The pivot vector. +C JUNFIX: The index of the next unfixed parameter. +C KP: The rank of the Jacobian wrt BETA. +C L: An indexing variable. +C LDTT: The leading dimension of array TT. +C LDWD: The leading dimension of array WD. +C LD2WD: The second dimension of array WD. +C LWRK: The length of vector WRK. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NP: The number of function parameters. +C NPP: The number of function parameters being estimated. +C NQ: The number of responses per observation. +C OMEGA: The array defined S.T. +C OMEGA*trans(OMEGA) = inv(I+FJACD*inv(E)*trans(FJACD)) +C = (I-FJACD*inv(P)*trans(FJACD)) +C where E = D**2 + ALPHA*TT**2 +C P = trans(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C QRAUX: The array required to recover the orthogonal part of the +C Q-R decomposition. +C RCOND: The approximate reciprocal condition of FJACB. +C RSS: The residual sum of squares. +C RVAR: The residual variance. +C S: The step for BETA. +C SD: The standard deviations of the estimated BETAS. +C SS: The scaling values for the unfixed BETAS. +C SSF: The scaling values used for BETA. +C T: The step for DELTA. +C TEMP: A temporary storage location +C TT: The scaling values for DELTA. +C U: The approximate null vector for FJACB. +C VCV: The covariance matrix of the estimated BETAS. +C WD: The DELTA weights. +C WRK: A work array of (LWRK) elements, +C equivalenced to WRK1 and WRK2. +C WRK1: A work array of (N by NQ by M) elements. +C WRK2: A work array of (N by NQ) elements. +C WRK3: A work array of (NP) elements. +C WRK4: A work array of (M by M) elements. +C WRK5: A work array of (M) elements. +C WRK6: A work array of (N*NQ by P) elements. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODVCV + + + FORVCV = .TRUE. + ISTOPC = 0 + + CALL DODSTP(N,M,NP,NQ,NPP, + & F,FJACB,FJACD, + & WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + & ZERO,EPSFCN,ISODR, + & WRK6,OMEGA,U,QRAUX,JPVT, + & S,T,TEMP,IRANK,RCOND,FORVCV, + & WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + KP = NPP - IRANK + CALL DPODI (WRK6,N*NQ,KP,WRK3,1) + + IDF = 0 + DO 150 I=1,N + DO 120 J=1,NPP + DO 110 L=1,NQ + IF (FJACB(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 110 CONTINUE + 120 CONTINUE + IF (ISODR) THEN + DO 140 J=1,M + DO 130 L=1,NQ + IF (FJACD(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 130 CONTINUE + 140 CONTINUE + END IF + 150 CONTINUE + + IF (IDF.GT.KP) THEN + IDF = IDF - KP + RVAR = RSS/IDF + ELSE + IDF = 0 + RVAR = RSS + END IF + +C Store variances in SD, restoring original order + + DO 200 I=1,NP + SD(I) = ZERO + 200 CONTINUE + DO 210 I=1,KP + SD(JPVT(I)) = WRK6(I,I) + 210 CONTINUE + IF (NP.GT.NPP) THEN + JUNFIX = NPP + DO 220 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + SD(J) = ZERO + ELSE + SD(J) = SD(JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 220 CONTINUE + END IF + +C Store covariance matrix in VCV, restoring original order + + DO 310 I=1,NP + DO 300 J=1,I + VCV(I,J) = ZERO + 300 CONTINUE + 310 CONTINUE + DO 330 I=1,KP + DO 320 J=I+1,KP + IF (JPVT(I).GT.JPVT(J)) THEN + VCV(JPVT(I),JPVT(J))=WRK6(I,J) + ELSE + VCV(JPVT(J),JPVT(I))=WRK6(I,J) + END IF + 320 CONTINUE + 330 CONTINUE + IF (NP.GT.NPP) THEN + IUNFIX = NPP + DO 360 I=NP,1,-1 + IF (IFIXB(I).EQ.0) THEN + DO 340 J=I,1,-1 + VCV(I,J) = ZERO + 340 CONTINUE + ELSE + JUNFIX = NPP + DO 350 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + VCV(I,J) = ZERO + ELSE + VCV(I,J) = VCV(IUNFIX,JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 350 CONTINUE + IUNFIX = IUNFIX - 1 + END IF + 360 CONTINUE + END IF + + DO 380 I=1,NP + VCV(I,I) = SD(I) + SD(I) = SQRT(RVAR*SD(I)) + DO 370 J=1,I + VCV(J,I) = VCV(I,J) + 370 CONTINUE + 380 CONTINUE + +C Unscale standard errors and covariance matrix + DO 410 I=1,NP + IF (SSF(1).GT.ZERO) THEN + SD(I) = SD(I)/SSF(I) + ELSE + SD(I) = SD(I)/ABS(SSF(1)) + END IF + DO 400 J=1,NP + IF (SSF(1).GT.ZERO) THEN + VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) + ELSE + VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) + END IF + 400 CONTINUE + 410 CONTINUE + + RETURN + END SUBROUTINE +*DPACK + SUBROUTINE DPACK + & (N2,N1,V1,V2,IFIX) +C***Begin Prologue DPACK +C***Refer to ODR +C***Routines Called DCOPY +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Select the unfixed elements of V2 and return them in V1 +C***End Prologue DPACK + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & N1,N2 + +C...Array arguments + REAL (KIND=R8) + & V1(N2),V2(N2) + INTEGER + & IFIX(N2) + +C...Local scalars + INTEGER + & I + +C...External subroutines + EXTERNAL + & DCOPY + +C...Variable definitions (alphabetically) +C I: An indexing variable. +C IFIX: The values designating whether the elements of V2 are +C fixed at their input values or not. +C N1: The number of items in V1. +C N2: The number of items in V2. +C V1: The vector of the unfixed items from V2. +C V2: The vector of the fixed and unfixed items from which the +C unfixed elements are to be extracted. + + +C***First executable statement DPACK + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I=1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1+1 + V1(N1) = V2(I) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY(N2,V2,1,V1,1) + END IF + + RETURN + END SUBROUTINE +*DPPNML + FUNCTION DPPNML + & (P) + & RESULT(DPPNMLR) +C***Begin Prologue DPPNML +C***Refer to ODR +C***Routines Called (None) +C***Date Written 901207 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Author Filliben, James J., +C Statistical Engineering Division +C National Bureau of Standards +C Washington, D. C. 20234 +C (Original Version--June 1972. +C (Updated --September 1975, +C November 1975, AND +C October 1976. +C***Purpose Compute the percent point function value for the +C normal (Gaussian) distribution with mean 0 and standard +C deviation 1, and with probability density function +C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). +C (Adapted from DATAPAC subroutine TPPF, with modifications +C to facilitate conversion to REAL (KIND=R8) automatically) +C***Description +C --The coding as presented below is essentially +C identical to that presented by Odeh and Evans +C as Algortihm 70 of Applied Statistics. +C --As pointed out by Odeh and Evans in Applied +C Statistics, their algorithm representes a +C substantial improvement over the previously employed +C Hastings approximation for the normal percent point +C function, with accuracy improving from 4.5*(10**-4) +C to 1.5*(10**-8). +C***References Odeh and Evans, the Percentage Points of the Normal +C Distribution, Algortihm 70, Applied Statistics, 1974, +C Pages 96-97. +C Evans, Algorithms for Minimal Degree Polynomial and +C Rational Approximation, M. Sc. Thesis, 1972, +C University of Victoria, B. C., Canada. +C Hastings, Approximations for Digital Computers, 1955, +C Pages 113, 191, 192. +C National Bureau of Standards Applied Mathematics +C Series 55, 1964, Page 933, Formula 26.2.23. +C Filliben, Simple and Robust Linear Estimation of the +C Location Parameter of a Symmetric Distribution +C (Unpublished Ph.D. Dissertation, Princeton +C University), 1969, Pages 21-44, 229-231. +C Filliben, "The Percent Point Function", +C (Unpublished Manuscript), 1970, Pages 28-31. +C Johnson and Kotz, Continuous Univariate Distributions, +C Volume 1, 1970, Pages 40-111. +C Kelley Statistical Tables, 1948. +C Owen, Handbook of Statistical Tables, 1962, Pages 3-16. +C Pearson and Hartley, Biometrika Tables for +C Statisticians, Volume 1, 1954, Pages 104-113. +C***End Prologue DPPNML + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & P + +C...Result + REAL (KIND=R8) + & DPPNMLR + +C...Local scalars + REAL (KIND=R8) + & ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO + +C...Data statements + DATA + & P0,P1,P2,P3,P4 + & /-0.322232431088E0_R8,-1.0E0_R8,-0.342242088547E0_R8, + & -0.204231210245E-1_R8,-0.453642210148E-4_R8/ + DATA + & Q0,Q1,Q2,Q3,Q4 + & /0.993484626060E-1_R8,0.588581570495E0_R8, + & 0.531103462366E0_R8,0.103537752850E0_R8,0.38560700634E-2_R8/ + DATA + & ZERO,HALF,ONE,TWO + & /0.0E0_R8,0.5E0_R8,1.0E0_R8,2.0E0_R8/ + +C...Variable Definitions (alphabetically) +C ADEN: A value used in the approximation. +C ANUM: A value used in the approximation. +C HALF: The value 0.5E0_R8. +C ONE: The value 1.0E0_R8. +C P: The probability at which the percent point is to be +C evaluated. P must be between 0.0E0_R8 and 1.0E0_R8, exclusive. +C P0: A parameter used in the approximation. +C P1: A parameter used in the approximation. +C P2: A parameter used in the approximation. +C P3: A parameter used in the approximation. +C P4: A parameter used in the approximation. +C Q0: A parameter used in the approximation. +C Q1: A parameter used in the approximation. +C Q2: A parameter used in the approximation. +C Q3: A parameter used in the approximation. +C Q4: A parameter used in the approximation. +C R: The probability at which the percent point is evaluated. +C T: A value used in the approximation. +C TWO: The value 2.0E0_R8. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DPPT + + + IF (P.EQ.HALF) THEN + DPPNMLR = ZERO + + ELSE + R = P + IF (P.GT.HALF) R = ONE - R + T = SQRT(-TWO*LOG(R)) + ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) + ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) + DPPNMLR = T + (ANUM/ADEN) + + IF (P.LT.HALF) DPPNMLR = -DPPNMLR + END IF + + RETURN + + END FUNCTION +*DPPT + FUNCTION DPPT + & (P, IDF) + & RESULT (DPPTR) +C***Begin Prologue DPPT +C***Refer to ODR +C***Routines Called DPPNML +C***Date Written 901207 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Author Filliben, James J., +C Statistical Engineering Division +C National Bureau of Standards +C Washington, D. C. 20234 +C (Original Version--October 1975.) +C (Updated --November 1975.) +C***Purpose Compute the percent point function value for the +C student's T distribution with IDF degrees of freedom. +C (Adapted from DATAPAC subroutine TPPF, with modifications +C to facilitate conversion to REAL (KIND=R8) automatically) +C***Description +C --For IDF = 1 AND IDF = 2, the percent point function +C for the T distribution exists in simple closed form +C and so the computed percent points are exact. +C --For IDF between 3 and 6, inclusively, the approximation +C is augmented by 3 iterations of Newton's method to +C improve the accuracy, especially for P near 0 or 1. +C***References National Bureau of Standards Applied Mathmatics +C Series 55, 1964, Page 949, Formula 26.7.5. +C Johnson and Kotz, Continuous Univariate Distributions, +C Volume 2, 1970, Page 102, Formula 11. +C Federighi, "Extended Tables of the Percentage Points +C of Student"S T Distribution, Journal of the American +C Statistical Association, 1969, Pages 683-688. +C Hastings and Peacock, Statistical Distributions, A +C Handbook for Students and Practitioners, 1975, +C Pages 120-123. +C***End Prologue DPPT + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & P + INTEGER + & IDF + +C...Result + REAL (KIND=R8) + & DPPTR + +C...Local scalars + REAL (KIND=R8) + & ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, + & B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, + & HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, + & Z,ZERO + INTEGER + & IPASS,MAXIT + +C...External functions + REAL (KIND=R8) + & DPPNML + EXTERNAL + & DPPNML + +C...Data statements + DATA + & B21 + & /4.0E0_R8/ + DATA + & B31, B32, B33, B34 + & /96.0E0_R8,5.0E0_R8,16.0E0_R8,3.0E0_R8/ + DATA + & B41, B42, B43, B44, B45 + & /384.0E0_R8,3.0E0_R8,19.0E0_R8,17.0E0_R8,-15.0E0_R8/ + DATA + & B51,B52,B53,B54,B55,B56 + & /9216.0E0_R8,79.0E0_R8,776.0E0_R8,1482.0E0_R8,-1920.0E0_R8, + & -945.0E0_R8/ + DATA + & ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN + & /0.0E0_R8,0.5E0_R8,1.0E0_R8,2.0E0_R8,3.0E0_R8,8.0E0_R8, + & 15.0E0_R8/ + +C...Variable definitions (alphabetically) +C ARG: A value used in the approximation. +C B21: A parameter used in the approximation. +C B31: A parameter used in the approximation. +C B32: A parameter used in the approximation. +C B33: A parameter used in the approximation. +C B34: A parameter used in the approximation. +C B41: A parameter used in the approximation. +C B42: A parameter used in the approximation. +C B43: A parameter used in the approximation. +C B44: A parameter used in the approximation. +C B45: A parameter used in the approximation. +C B51: A parameter used in the approximation. +C B52: A parameter used in the approximation. +C B53: A parameter used in the approximation. +C B54: A parameter used in the approximation. +C B55: A parameter used in the approximation. +C B56: A parameter used in the approximation. +C C: A value used in the approximation. +C CON: A value used in the approximation. +C DF: The degrees of freedom. +C D1: A value used in the approximation. +C D3: A value used in the approximation. +C D5: A value used in the approximation. +C D7: A value used in the approximation. +C D9: A value used in the approximation. +C EIGHT: The value 8.0E0_R8. +C FIFTN: The value 15.0E0_R8. +C HALF: The value 0.5E0_R8. +C IDF: The (positive integer) degrees of freedom. +C IPASS: A value used in the approximation. +C MAXIT: The maximum number of iterations allowed for the approx. +C ONE: The value 1.0E0_R8. +C P: The probability at which the percent point is to be +C evaluated. P must lie between 0.0DO and 1.0E0_R8, exclusive. +C PI: The value of pi. +C PPFN: The normal percent point value. +C S: A value used in the approximation. +C TERM1: A value used in the approximation. +C TERM2: A value used in the approximation. +C TERM3: A value used in the approximation. +C TERM4: A value used in the approximation. +C TERM5: A value used in the approximation. +C THREE: The value 3.0E0_R8. +C TWO: The value 2.0E0_R8. +C Z: A value used in the approximation. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DPPT + + + PI = 3.141592653589793238462643383279E0_R8 + DF = IDF + MAXIT = 5 + + IF (IDF.LE.0) THEN + +C Treat the IDF < 1 case + DPPTR = ZERO + + ELSE IF (IDF.EQ.1) THEN + +C Treat the IDF = 1 (Cauchy) case + ARG = PI*P + DPPTR = -COS(ARG)/SIN(ARG) + + ELSE IF (IDF.EQ.2) THEN + +C Treat the IDF = 2 case + TERM1 = SQRT(TWO)/TWO + TERM2 = TWO*P - ONE + TERM3 = SQRT(P*(ONE-P)) + DPPTR = TERM1*TERM2/TERM3 + + ELSE IF (IDF.GE.3) THEN + +C Treat the IDF greater than or equal to 3 case + PPFN = DPPNML(P) + D1 = PPFN + D3 = PPFN**3 + D5 = PPFN**5 + D7 = PPFN**7 + D9 = PPFN**9 + TERM1 = D1 + TERM2 = (ONE/B21)*(D3+D1)/DF + TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) + TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) + TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) + DPPTR = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 + + IF (IDF.EQ.3) THEN + +C Augment the results for the IDF = 3 case + CON = PI*(P-HALF) + ARG = DPPTR/SQRT(DF) + Z = ATAN(ARG) + DO 70 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+S*C-CON)/(TWO*C**2) + 70 CONTINUE + DPPTR = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.4) THEN + +C Augment the results for the IDF = 4 case + CON = TWO*(P-HALF) + ARG = DPPTR/SQRT(DF) + Z = ATAN(ARG) + DO 90 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) + 90 CONTINUE + DPPTR = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.5) THEN + +C Augment the results for the IDF = 5 case + + CON = PI*(P-HALF) + ARG = DPPTR/SQRT(DF) + Z = ATAN(ARG) + DO 110 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ + & ((EIGHT/THREE)*C**4) + 110 CONTINUE + DPPTR = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.6) THEN + +C Augment the results for the IDF = 6 case + CON = TWO*(P-HALF) + ARG = DPPTR/SQRT(DF) + Z = ATAN(ARG) + DO 130 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ + & ((FIFTN/EIGHT)*C**5) + 130 CONTINUE + DPPTR = SQRT(DF)*S/C + END IF + END IF + + RETURN + + END FUNCTION +*DPVB + SUBROUTINE DPVB + & (FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP, + & ISTOP,NFEV,PVB, + & WRK1,WRK2,WRK6) +C***Begin Prologue DPVB +C***Refer to ODR +C***Routines Called FCN +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Compute the NROW-th function value using BETA(J) + STP +C***End Prologue DPVB + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & PVB,STP + INTEGER + & ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & BETAJ + +C...Routine names used as subprogram arguments +C FCN: The user-supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C BETAJ: The current estimate of the jth parameter. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C J: The index of the partial derivative being examined. +C LDIFX: The leading dimension of array IFIXX. +C LQ: The response currently being examined. +C M: The number of columns of data in the independent variable. +C N: The number of observations. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the independent variable array at +C which the derivative is to be checked. +C PVB: The function value for the selected observation & response. +C STP: The step size for the finite difference derivative. +C XPLUSD: The values of X + DELTA. + + +C***First executable statement DPVB + + +C Compute predicted values + + BETAJ = BETA(J) + BETA(J) = BETA(J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 003,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + BETA(J) = BETAJ + + PVB = WRK2(NROW,LQ) + + RETURN + END SUBROUTINE +*DPVD + SUBROUTINE DPVD + & (FCN, + & N,M,NP,NQ, + & BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + & NROW,J,LQ,STP, + & ISTOP,NFEV,PVD, + & WRK1,WRK2,WRK6) +C***Begin Prologue DPVD +C***Refer to ODR +C***Routines Called FCN +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Compute NROW-th function value using +C X(NROW,J) + DELTA(NROW,J) + STP +C***End Prologue DPVD + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + REAL (KIND=R8) + & PVD,STP + INTEGER + & ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + & IFIXB(NP),IFIXX(LDIFX,M) + +C...Subroutine arguments + EXTERNAL + & FCN + +C...Local scalars + REAL (KIND=R8) + & XPDJ + +C...Routine names used as subprogram arguments +C FCN: The user-supplied subroutine for evaluating the model. + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of X are +C fixed at their input values or not. +C ISTOP: The variable designating whether there are problems +C computing the function at the current BETA and DELTA. +C J: The index of the partial derivative being examined. +C LDIFX: The leading dimension of array IFIXX. +C LQ: The response currently being examined. +C M: The number of columns of data in the independent variable. +C N: The number of observations. +C NFEV: The number of function evaluations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C NROW: The row number of the independent variable array at +C which the derivative is to be checked. +C PVD: The function value for the selected observation & response. +C STP: The step size for the finite difference derivative. +C XPDJ: The (NROW,J)th element of XPLUSD. +C XPLUSD: The values of X + DELTA. + + +C***First executable statement DPVD + + +C Compute predicted values + + XPDJ = XPLUSD(NROW,J) + XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + & N,M,NP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & 003,WRK2,WRK6,WRK1, + & ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + XPLUSD(NROW,J) = XPDJ + + PVD = WRK2(NROW,LQ) + + RETURN + END SUBROUTINE +*DSCALE + SUBROUTINE DSCALE + & (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) +C***Begin Prologue DSCALE +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Scale T by the inverse of SCL, I.E., compute T/SCL +C***End Prologue DSCALE + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDT,LDSCL,LDSCLT,M,N + +C...Array arguments + REAL (KIND=R8) + & T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) + +C...Local scalars + REAL (KIND=R8) + & ONE,TEMP,ZERO + INTEGER + & I,J + +C...Data statements + DATA + & ONE,ZERO + & /1.0E0_R8,0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C I: An indexing variable. +C J: An indexing variable. +C LDSCL: The leading dimension of array SCL. +C LDSCLT: The leading dimension of array SCLT. +C LDT: The leading dimension of array T. +C M: The number of columns of data in T. +C N: The number of rows of data in T. +C ONE: The value 1.0E0_R8. +C SCL: The scale values. +C SCLT: The inversely scaled matrix. +C T: The array to be inversely scaled by SCL. +C TEMP: A temporary scalar. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DSCALE + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (SCL(1,1).GE.ZERO) THEN + IF (LDSCL.GE.N) THEN + DO 80 J=1,M + DO 70 I=1,N + SCLT(I,J) = T(I,J)/SCL(I,J) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J=1,M + TEMP = ONE/SCL(1,J) + DO 90 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 90 CONTINUE + 100 CONTINUE + END IF + ELSE + TEMP = ONE/ABS(SCL(1,1)) + DO 120 J=1,M + DO 110 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + END IF + + RETURN + END SUBROUTINE +*DSCLB + SUBROUTINE DSCLB + & (NP,BETA,SSF) +C***Begin Prologue DSCLB +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Select scaling values for BETA according to the +C algorithm given in the ODRPACK95 reference guide +C***End Prologue DSCLB + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & NP + +C...Array arguments + REAL (KIND=R8) + & BETA(NP),SSF(NP) + +C...Local scalars + REAL (KIND=R8) + & BMAX,BMIN,ONE,TEN,ZERO + INTEGER + & K + LOGICAL + & BIGDIF + +C...Data statements + DATA + & ZERO,ONE,TEN + & /0.0E0_R8,1.0E0_R8,10.0E0_R8/ + +C...Variable Definitions (alphabetically) +C BETA: The function parameters. +C BIGDIF: The variable designating whether there is a significant +C difference in the magnitudes of the nonzero elements of +C BETA (BIGDIF=.TRUE.) or not (BIGDIF=.FALSE.). +C BMAX: The largest nonzero magnitude. +C BMIN: The smallest nonzero magnitude. +C K: An indexing variable. +C NP: The number of function parameters. +C ONE: The value 1.0E0_R8. +C SSF: The scaling values for BETA. +C TEN: The value 10.0E0_R8. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DSCLB + + + BMAX = ABS(BETA(1)) + DO 10 K=2,NP + BMAX = MAX(BMAX,ABS(BETA(K))) + 10 CONTINUE + + IF (BMAX.EQ.ZERO) THEN + +C All input values of BETA are zero + + DO 20 K=1,NP + SSF(K) = ONE + 20 CONTINUE + + ELSE + +C Some of the input values are nonzero + + BMIN = BMAX + DO 30 K=1,NP + IF (BETA(K).NE.ZERO) THEN + BMIN = MIN(BMIN,ABS(BETA(K))) + END IF + 30 CONTINUE + BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE + DO 40 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + SSF(K) = TEN/BMIN + ELSE + IF (BIGDIF) THEN + SSF(K) = ONE/ABS(BETA(K)) + ELSE + SSF(K) = ONE/BMAX + END IF + END IF + 40 CONTINUE + + END IF + + RETURN + END SUBROUTINE +*DSCLD + SUBROUTINE DSCLD + & (N,M,X,LDX,TT,LDTT) +C***Begin Prologue DSCLD +C***Refer to ODR +C***Routines Called (None) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Select scaling values for DELTA according to the +C algorithm given in the ODRPACK95 reference guide +C***End Prologue DSCLD + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDTT,LDX,M,N + +C...Array arguments + REAL (KIND=R8) + & TT(LDTT,M),X(LDX,M) + +C...Local scalars + REAL (KIND=R8) + & ONE,TEN,XMAX,XMIN,ZERO + INTEGER + & I,J + LOGICAL + & BIGDIF + +C...Data statements + DATA + & ZERO,ONE,TEN + & /0.0E0_R8,1.0E0_R8,10.0E0_R8/ + +C...Variable Definitions (alphabetically) +C BIGDIF: The variable designating whether there is a significant +C difference in the magnitudes of the nonzero elements of +C X (BIGDIF=.TRUE.) or not (BIGDIF=.FALSE.). +C I: An indexing variable. +C J: An indexing variable. +C LDTT: The leading dimension of array TT. +C LDX: The leading dimension of array X. +C M: The number of columns of data in the independent variable. +C N: The number of observations. +C ONE: The value 1.0E0_R8. +C TT: THE SCALING VALUES FOR DELTA. +C X: The independent variable. +C XMAX: The largest nonzero magnitude. +C XMIN: THE SMALLEST NONZERO MAGNITUDE. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DSCLD + + + DO 50 J=1,M + XMAX = ABS(X(1,J)) + DO 10 I=2,N + XMAX = MAX(XMAX,ABS(X(I,J))) + 10 CONTINUE + + IF (XMAX.EQ.ZERO) THEN + +C All input values of X(I,J), I=1,...,N, are zero + + DO 20 I=1,N + TT(I,J) = ONE + 20 CONTINUE + + ELSE + +C Some of the input values are nonzero + + XMIN = XMAX + DO 30 I=1,N + IF (X(I,J).NE.ZERO) THEN + XMIN = MIN(XMIN,ABS(X(I,J))) + END IF + 30 CONTINUE + BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE + DO 40 I=1,N + IF (X(I,J).NE.ZERO) THEN + IF (BIGDIF) THEN + TT(I,J) = ONE/ABS(X(I,J)) + ELSE + TT(I,J) = ONE/XMAX + END IF + ELSE + TT(I,J) = TEN/XMIN + END IF + 40 CONTINUE + END IF + 50 CONTINUE + + RETURN + END SUBROUTINE +*DSETN + SUBROUTINE DSETN + & (N,M,X,LDX,NROW) +C***Begin Prologue DSETN +C***Refer to ODR +C***Routines Called (None) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Select the row at which the derivative will be checked +C***End Prologue DSETN + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDX,M,N,NROW + +C...Array arguments + REAL (KIND=R8) + & X(LDX,M) + +C...Local scalars + INTEGER + & I,J + +C...Variable Definitions (alphabetically) +C I: An index variable. +C J: An index variable. +C LDX: The leading dimension of array X. +C M: The number of columns of data in the independent variable. +C N: The number of observations. +C NROW: The selected row number of the independent variable. +C X: The independent variable. + + +C***First executable statement DSETN + + + IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN + +C Select first row of independent variables which contains no zeros +C if there is one, otherwise first row is used. + + DO 20 I = 1, N + DO 10 J = 1, M + IF (X(I,J).EQ.0.0) GO TO 20 + 10 CONTINUE + NROW = I + RETURN + 20 CONTINUE + + NROW = 1 + + RETURN + END SUBROUTINE +*DSOLVE + SUBROUTINE DSOLVE(N,T,LDT,B,JOB) +C***Begin Prologue DSOLVE +C***Refer to ODR +C***Routines Called DAXPY,DDOT +C***Date Written 920220 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Solve systems of the form +C T * X = B or trans(T) * X = B +C where T is an upper or lower triangular matrix of order N, +C and the solution X overwrites the RHS B. +C (adapted from LINPACK subroutine DTRSL) +C***References Dongarra J.J., Bunch J.R., Moler C.B., Stewart G.W., +C *LINPACK Users Guide*, SIAM, 1979. +C***End Prologue DSOLVE + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & JOB,LDT,N + +C...Array arguments + REAL (KIND=R8) + & B(N),T(LDT,N) + +C...Local scalars + REAL (KIND=R8) + & TEMP,ZERO + INTEGER + & J1,J,JN + +C...External functions + REAL (KIND=R8) + & DDOT + EXTERNAL + & DDOT + +C...External subroutines + EXTERNAL + & DAXPY + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C B: On input: the right hand side; On exit: the solution +C J1: The first nonzero entry in T. +C J: An indexing variable. +C JN: The last nonzero entry in T. +C JOB: What kind of system is to be solved, where if JOB is +C 1 Solve T*X=B, T lower triangular, +C 2 Solve T*X=B, T upper triangular, +C 3 Solve trans(T)*X=B, T lower triangular, +C 4 Solve trans(T)*X=B, T upper triangular. +C LDT: The leading dimension of array T. +C N: The number of rows and columns of data in array T. +C T: The upper or lower tridiagonal system. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DSOLVE + + +C Find first nonzero diagonal entry in T + J1 = 0 + DO 10 J=1,N + IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN + J1 = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(J) = ZERO + END IF + 10 CONTINUE + IF (J1.EQ.0) RETURN + +C Find last nonzero diagonal entry in T + JN = 0 + DO 20 J=N,J1,-1 + IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN + JN = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(J) = ZERO + END IF + 20 CONTINUE + + IF (JOB.EQ.1) THEN + +C Solve T*X=B for T lower triangular + B(J1) = B(J1)/T(J1,J1) + DO 30 J = J1+1, JN + TEMP = -B(J-1) + CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(J),1) + IF (T(J,J).NE.ZERO) THEN + B(J) = B(J)/T(J,J) + ELSE + B(J) = ZERO + END IF + 30 CONTINUE + + ELSE IF (JOB.EQ.2) THEN + +C Solve T*X=B for T upper triangular. + B(JN) = B(JN)/T(JN,JN) + DO 40 J = JN-1,J1,-1 + TEMP = -B(J+1) + CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1) + IF (T(J,J).NE.ZERO) THEN + B(J) = B(J)/T(J,J) + ELSE + B(J) = ZERO + END IF + 40 CONTINUE + + ELSE IF (JOB.EQ.3) THEN + +C Solve trans(T)*X=B for T lower triangular. + B(JN) = B(JN)/T(JN,JN) + DO 50 J = JN-1,J1,-1 + B(J) = B(J) - DDOT(JN-J+1,T(J+1,J),1,B(J+1),1) + IF (T(J,J).NE.ZERO) THEN + B(J) = B(J)/T(J,J) + ELSE + B(J) = ZERO + END IF + 50 CONTINUE + + ELSE IF (JOB.EQ.4) THEN + +C Solve trans(T)*X=B for T upper triangular. + B(J1) = B(J1)/T(J1,J1) + DO 60 J = J1+1,JN + B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) + IF (T(J,J).NE.ZERO) THEN + B(J) = B(J)/T(J,J) + ELSE + B(J) = ZERO + END IF + 60 CONTINUE + END IF + + RETURN + END SUBROUTINE +*DUNPAC + SUBROUTINE DUNPAC + & (N2,V1,V2,IFIX) +C***Begin Prologue DUNPAC +C***Refer to ODR +C***Routines Called DCOPY +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Copy the elements of V1 into the locations of V2 which are +C unfixed +C***End Prologue DUNPAC + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & N2 + +C...Array arguments + REAL (KIND=R8) + & V1(N2),V2(N2) + INTEGER + & IFIX(N2) + +C...Local scalars + INTEGER + & I,N1 + +C...External subroutines + EXTERNAL + & DCOPY + +C...Variable Definitions (alphabetically) +C I: An indexing variable. +C IFIX: The values designating whether the elements of V2 are +C fixed at their input values or not. +C ODRPACK95 reference guide.) +C N1: The number of items in V1. +C N2: The number of items in V2. +C V1: The vector of the unfixed items. +C V2: The vector of the fixed and unfixed items into which the +C elements of V1 are to be inserted. + + +C***First executable statement DUNPAC + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I = 1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1 + 1 + V2(I) = V1(N1) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY(N2,V1,1,V2,1) + END IF + + RETURN + END SUBROUTINE +*DVEVTR + SUBROUTINE DVEVTR + & (M,NQ,INDX, + & V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, + & WRK5) +C***Begin Prologue DVEVTR +C***Refer to ODR +C***Routines Called DSOLVE +C***Date Written 910613 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Compute V*E*trans(V) for the (INDX)TH M by NQ array in V +C***End Prologue DVEVTR + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ + +C...Array arguments + REAL (KIND=R8) + & E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) + +C...Local scalars + REAL (KIND=R8) + & ZERO + INTEGER + & J,L1,L2 + +C...External subroutines + EXTERNAL + & DSOLVE + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C INDX: The row in V in which the M by NQ array is stored. +C J: An indexing variable. +C LDE: The leading dimension of array E. +C LDV: The leading dimension of array V. +C LDVE: The leading dimension of array VE. +C LDVEV: The leading dimension of array VEV. +C LD2V: The second dimension of array V. +C L1: An indexing variable. +C L2: An indexing variable. +C M: The number of columns of data in the independent variable. +C NQ: The number of responses per observation. +C E: The M by M matrix of the factors so ETE = (D**2 + ALPHA*T**2). +C V: An array of NQ by M matrices. +C VE: The NQ by M array VE = V * inv(E) +C VEV: The NQ by NQ array VEV = V * inv(ETE) * trans(V). +C WRK5: An M work vector. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DVEVTR + + + IF (NQ.EQ.0 .OR. M.EQ.0) RETURN + + DO 140 L1 = 1,NQ + DO 110 J = 1,M + WRK5(J) = V(INDX,J,L1) + 110 CONTINUE + CALL DSOLVE(M,E,LDE,WRK5,4) + DO 120 J = 1,M + VE(INDX,L1,J) = WRK5(J) + 120 CONTINUE + 140 CONTINUE + + DO 230 L1 = 1,NQ + DO 220 L2 = 1,L1 + VEV(L1,L2) = ZERO + DO 210 J = 1,M + VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) + 210 CONTINUE + VEV(L2,L1) = VEV(L1,L2) + 220 CONTINUE + 230 CONTINUE + + RETURN + END SUBROUTINE +*DWGHT + SUBROUTINE DWGHT + & (N,M,WT,LDWT,LD2WT,T,WTT) +C***Begin Prologue DWGHT +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Scale matrix T using WT, i.e., compute WTT = WT*T +C***End Prologue DWGHT + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDWT,LD2WT,M,N + +C...Array arguments + REAL (KIND=R8) + & T(:,:),WT(:,:,:),WTT(:,:) + +C...Local scalars + REAL (KIND=R8) + & TEMP,ZERO + INTEGER + & I,J,K + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C I: An indexing variable. +C J: An indexing variable. +C K: An indexing variable. +C LDWT: The leading dimension of array WT. +C LD2WT: The second dimension of array WT. +C M: The number of columns of data in T. +C N: The number of rows of data in T. +C T: The array being scaled by WT. +C TEMP: A temporary scalar. +C WT: The weights. +C WTT: The results of weighting array T by WT. +C Array WTT can be the same as T only if the arrays in WT +C are upper triangular with zeros below the diagonal. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DWGHT + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WT(1,1,1).GE.ZERO) THEN + IF (LDWT.GE.N) THEN + IF (LD2WT.GE.M) THEN +C WT is an N-array of M by M matrices + DO 130 I=1,N + DO 120 J=1,M + TEMP = ZERO + DO 110 K=1,M + TEMP = TEMP + WT(I,J,K)*T(I,K) + 110 CONTINUE + WTT(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE +C WT is an N-array of diagonal matrices + DO 230 I=1,N + DO 220 J=1,M + WTT(I,J) = WT(I,1,J)*T(I,J) + 220 CONTINUE + 230 CONTINUE + END IF + ELSE + IF (LD2WT.GE.M) THEN +C WT is an M by M matrix + DO 330 I=1,N + DO 320 J=1,M + TEMP = ZERO + DO 310 K=1,M + TEMP = TEMP + WT(1,J,K)*T(I,K) + 310 CONTINUE + WTT(I,J) = TEMP + 320 CONTINUE + 330 CONTINUE + ELSE +C WT is a diagonal matrice + DO 430 I=1,N + DO 420 J=1,M + WTT(I,J) = WT(1,1,J)*T(I,J) + 420 CONTINUE + 430 CONTINUE + END IF + END IF + ELSE +C WT is a scalar + DO 520 J=1,M + DO 510 I=1,N + WTT(I,J) = ABS(WT(1,1,1))*T(I,J) + 510 CONTINUE + 520 CONTINUE + END IF + + RETURN + END SUBROUTINE +*DWINF + SUBROUTINE DWINF + & (N,M,NP,NQ,LDWE,LD2WE,ISODR, + & DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + & RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + & OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + & PARTLI,SSTOLI,TAUFCI,EPSMAI, + & BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + & FSI,FJACBI,WE1I,DIFFI, + & DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + & WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + & LOWERI,UPPERI, + & LWKMN) +C***Begin Prologue DWINF +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Set storage locations within REAL (KIND=R8) work space +C***End Prologue DWINF + +C...Scalar arguments + INTEGER + & ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + & DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LOWERI, + & LWKMN,M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI, + & RCONDI,RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI, + & UI,UPPERI,VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + & WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + & ISODR + +C...Local scalars + INTEGER + & NEXT + +C...Variable Definitions (alphabetically) +C ACTRSI: The location in array WORK of variable ACTRS. +C ALPHAI: The location in array WORK of variable ALPHA. +C BETACI: The starting location in array WORK of array BETAC. +C BETANI: The starting location in array WORK of array BETAN. +C BETASI: The starting location in array WORK of array BETAS. +C BETA0I: The starting location in array WORK of array BETA0. +C DELTAI: The starting location in array WORK of array DELTA. +C DELTNI: The starting location in array WORK of array DELTAN. +C DELTSI: The starting location in array WORK of array DELTAS. +C DIFFI: The starting location in array WORK of array DIFF. +C EPSI: The starting location in array WORK of array EPS. +C EPSMAI: The location in array WORK of variable EPSMAC. +C ETAI: The location in array WORK of variable ETA. +C FJACBI: The starting location in array WORK of array FJACB. +C FJACDI: The starting location in array WORK of array FJACD. +C FNI: The starting location in array WORK of array FN. +C FSI: The starting location in array WORK of array FS. +C ISODR: The variable designating whether the solution is by ODR +C (ISODR=TRUE) or by OLS (ISODR=FALSE). +C LDWE: The leading dimension of array WE. +C LD2WE: The second dimension of array WE. +C LWKMN: The minimum acceptable length of vector work. +C M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NEXT: The next available location with WORK. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C OLMAVI: The location in array WORK of variable OLMAVG. +C OMEGAI: The starting location in array WORK of array OMEGA. +C PARTLI: The location in array WORK of variable PARTOL. +C PNORMI: The location in array WORK of variable PNORM. +C PRERSI: The location in array WORK of variable PRERS. +C QRAUXI: The starting location in array WORK of array QRAUX. +C RCONDI: The location in array WORK of variable RCONDI. +C RNORSI: The location in array WORK of variable RNORMS. +C RVARI: The location in array WORK of variable RVAR. +C SDI: The starting location in array WORK of array SD. +C SI: The starting location in array WORK of array S. +C SSFI: The starting location in array WORK of array SSF. +C SSI: The starting location in array WORK of array SS. +C SSTOLI: The location in array WORK of variable SSTOL. +C TAUFCI: The location in array WORK of variable TAUFAC. +C TAUI: The location in array WORK of variable TAU. +C TI: The starting location in array WORK of array T. +C TTI: The starting location in array WORK of array TT. +C UI: The starting location in array WORK of array U. +C VCVI: The starting location in array WORK of array VCV. +C WE1I: The starting location in array WORK of array WE1. +C WRK1I: The starting location in array WORK of array WRK1. +C WRK2I: The starting location in array WORK of array WRK2. +C WRK3I: The starting location in array WORK of array WRK3. +C WRK4I: The starting location in array WORK of array WRK4. +C WRK5I: The starting location in array WORK of array WRK5. +C WRK6I: The starting location in array WORK of array WRK6. +C WRK7I: The starting location in array WORK of array WRK7. +C WSSI: The location in array WORK of variable WSS. +C WSSDEI: The location in array WORK of variable WSSDEL. +C WSSEPI: The location in array work of variable WSSEPS. +C XPLUSI: The starting location in array WORK of array XPLUSD. + + +C***First executable statement DWINF + + + IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. + & LDWE.GE.1 .AND. LD2WE.GE.1) THEN + + DELTAI = 1 + EPSI = DELTAI + N*M + XPLUSI = EPSI + N*NQ + FNI = XPLUSI + N*M + SDI = FNI + N*NQ + VCVI = SDI + NP + RVARI = VCVI + NP*NP + + WSSI = RVARI + 1 + WSSDEI = WSSI + 1 + WSSEPI = WSSDEI + 1 + RCONDI = WSSEPI + 1 + ETAI = RCONDI + 1 + OLMAVI = ETAI + 1 + + TAUI = OLMAVI + 1 + ALPHAI = TAUI + 1 + ACTRSI = ALPHAI + 1 + PNORMI = ACTRSI + 1 + RNORSI = PNORMI + 1 + PRERSI = RNORSI + 1 + PARTLI = PRERSI + 1 + SSTOLI = PARTLI + 1 + TAUFCI = SSTOLI + 1 + EPSMAI = TAUFCI + 1 + BETA0I = EPSMAI + 1 + + BETACI = BETA0I + NP + BETASI = BETACI + NP + BETANI = BETASI + NP + SI = BETANI + NP + SSI = SI + NP + SSFI = SSI + NP + QRAUXI = SSFI + NP + UI = QRAUXI + NP + FSI = UI + NP + + FJACBI = FSI + N*NQ + + WE1I = FJACBI + N*NP*NQ + + DIFFI = WE1I + LDWE*LD2WE*NQ + + NEXT = DIFFI + NQ*(NP+M) + + IF (ISODR) THEN + DELTSI = NEXT + DELTNI = DELTSI + N*M + TI = DELTNI + N*M + TTI = TI + N*M + OMEGAI = TTI + N*M + FJACDI = OMEGAI + NQ*NQ + WRK1I = FJACDI + N*M*NQ + NEXT = WRK1I + N*M*NQ + ELSE + DELTSI = DELTAI + DELTNI = DELTAI + TI = DELTAI + TTI = DELTAI + OMEGAI = DELTAI + FJACDI = DELTAI + WRK1I = DELTAI + END IF + + WRK2I = NEXT + WRK3I = WRK2I + N*NQ + WRK4I = WRK3I + NP + WRK5I = WRK4I + M*M + WRK6I = WRK5I + M + WRK7I = WRK6I + N*NQ*NP + LOWERI = WRK7I + 5*NQ + UPPERI = LOWERI + NP + NEXT = UPPERI + NP + + LWKMN = NEXT + ELSE + DELTAI = 1 + EPSI = 1 + XPLUSI = 1 + FNI = 1 + SDI = 1 + VCVI = 1 + RVARI = 1 + WSSI = 1 + WSSDEI = 1 + WSSEPI = 1 + RCONDI = 1 + ETAI = 1 + OLMAVI = 1 + TAUI = 1 + ALPHAI = 1 + ACTRSI = 1 + PNORMI = 1 + RNORSI = 1 + PRERSI = 1 + PARTLI = 1 + SSTOLI = 1 + TAUFCI = 1 + EPSMAI = 1 + BETA0I = 1 + BETACI = 1 + BETASI = 1 + BETANI = 1 + SI = 1 + SSI = 1 + SSFI = 1 + QRAUXI = 1 + FSI = 1 + UI = 1 + FJACBI = 1 + WE1I = 1 + DIFFI = 1 + DELTSI = 1 + DELTNI = 1 + TI = 1 + TTI = 1 + FJACDI = 1 + OMEGAI = 1 + WRK1I = 1 + WRK2I = 1 + WRK3I = 1 + WRK4I = 1 + WRK5I = 1 + WRK6I = 1 + WRK7I = 1 + LOWERI = 1 + UPPERI = 1 + LWKMN = 1 + END IF + + RETURN + END SUBROUTINE +*DXMY + SUBROUTINE DXMY + & (N,M,X,LDX,Y,LDY,XMY,LDXMY) +C***Begin Prologue DXMY +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Compute XMY = X - Y +C***End Prologue DXMY + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDX,LDXMY,LDY,M,N + +C...Array arguments + REAL (KIND=R8) + & X(LDX,M),XMY(LDXMY,M),Y(LDY,M) + +C...Local scalars + INTEGER + & I,J + +C...Variable Definitions (alphabetically) +C I: An indexing variable. +C J: An indexing variable. +C LDX: The leading dimension of array X. +C LDXMY: The leading dimension of array XMY. +C LDY: The leading dimension of array Y. +C M: The number of columns of data in arrays X and Y. +C N: The number of rows of data in arrays X and Y. +C X: The first of the two arrays. +C XMY: The values of X-Y. +C Y: The second of the two arrays. + + +C***First executable statement DXMY + + + DO 20 J=1,M + DO 10 I=1,N + XMY(I,J) = X(I,J) - Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END SUBROUTINE +*DXPY + SUBROUTINE DXPY + & (N,M,X,LDX,Y,LDY,XPY,LDXPY) +C***Begin Prologue DXPY +C***Refer to ODR +C***Routines Called (None) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Compute XPY = X + Y +C***End Prologue DXPY + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDX,LDXPY,LDY,M,N + +C...Array arguments + REAL (KIND=R8) + & X(LDX,M),XPY(LDXPY,M),Y(LDY,M) + +C...Local scalars + INTEGER + & I,J + +C...Variable Definitions (alphabetically) +C I: An indexing variable. +C J: An indexing variable. +C LDX: The leading dimension of array X. +C LDXPY: The leading dimension of array XPY. +C LDY: The leading dimension of array Y. +C M: The number of columns of data in arrays X and Y. +C N: The number of rows of data in arrays X and Y. +C X: The first of the two arrays to be added together. +C XPY: The values of X+Y. +C Y: The second of the two arrays to be added together. + + +C***First executable statement DXPY + + + DO 20 J=1,M + DO 10 I=1,N + XPY(I,J) = X(I,J) + Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END SUBROUTINE +*DZERO + SUBROUTINE DZERO + & (N,M,A,LDA) +C***Begin Prologue DZERO +C***Refer to ODR +C***Routines Called (None) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920304 (YYMMDD) +C***Purpose Set A = ZERO +C***End Prologue DZERO + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDA,M,N + +C...Array arguments + REAL (KIND=R8) + & A(LDA,M) + +C...Local scalars + REAL (KIND=R8) + & ZERO + INTEGER + & I,J + +C...Data statements + DATA + & ZERO + & /0.0E0_R8/ + +C...Variable Definitions (alphabetically) +C A: The array to be set to zero. +C I: An indexing variable. +C J: An indexing variable. +C LDA: The leading dimension of array A. +C M: The number of columns to be set to zero. +C N: The number of rows to be set to zero. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DZERO + + + DO 20 J=1,M + DO 10 I=1,N + A(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + + RETURN + END SUBROUTINE diff --git a/dataassim/math/optimization/odrpack95/real_precision.f b/dataassim/math/optimization/odrpack95/real_precision.f new file mode 100644 index 0000000..63d727d --- /dev/null +++ b/dataassim/math/optimization/odrpack95/real_precision.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/restart_example.f b/dataassim/math/optimization/odrpack95/restart_example.f new file mode 100644 index 0000000..a42c029 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/restart_example.f @@ -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 diff --git a/dataassim/math/optimization/odrpack95/simple_example.f90 b/dataassim/math/optimization/odrpack95/simple_example.f90 new file mode 100644 index 0000000..bce96a9 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/simple_example.f90 @@ -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 diff --git a/dataassim/math/optimization/odrpack95/test.f b/dataassim/math/optimization/odrpack95/test.f new file mode 100644 index 0000000..a1565b7 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/test.f @@ -0,0 +1,2742 @@ +*DTEST + PROGRAM DTEST +C***Begin Prologue DTEST +C***Refer to ODR +C***Routines Called DODRX +C***Date Written 861229 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose EXERCISE FEATURES OF ODRPACK95 SOFTWARE +C***End Prologue DTEST + +C...Used modules + USE REAL_PRECISION + +C...Scalars in common + INTEGER + & NTEST + +C...Local scalars + REAL (KIND=R8) + & TSTFAC + INTEGER + & LUNERR,LUNRPT,LUNSUM + LOGICAL + & PASSED + +C...External subroutines + EXTERNAL + & DODRX + +C...Common blocks + COMMON /TSTSET/ NTEST + +C***Variable declarations (alphabetically) + +C LUNERR: The logical unit number used for error messages. +C LUNRPT: The logical unit number used for computation reports. +C LUNSUM: The logical unit number used for a summary report listing +C only the test comparisons and not the odrpack generated +C reports. +C NTEST: The number of tests to be run. +C PASSED: The variable designating whether the results of all of the +C tests agree with those from the cray ymp using double +C precision (PASSED=TRUE), or whether some of the results +C disagreed (PASSED=FALSE). +C TSTFAC: The user-supplied factor for scaling the test tolerances +C used to check for agreement between computed results and +C results obtained using REAL (KIND=R8) version on cray +C YMP. Values of TSTFAC greater than one increase the +C test tolerances, making the tests easier to pass and +C allowing small discrepancies between the computed and +C expected results to be automatically discounted. + + +C***First executable statement TEST + + +C Set up necessary files + +C NOTE: ODRPACK95 generates computation and error reports on +C logical unit 6 by default; +C logical unit 'LUNSUM' used to summarize results of comparisons +C from exercise routine DODRX. + + LUNRPT = 18 + LUNERR = 18 + LUNSUM = 19 + + OPEN(UNIT=LUNRPT,FILE='REPORT') + OPEN(UNIT=LUNERR,FILE='REPORT') + OPEN(UNIT=LUNSUM,FILE='SUMMARY') + +C Exercise REAL (KIND=R8) version of ODRPACK95 +C (test reports generated on file 'RESULTS' and +C summarized in file 'SUMMARY') + + NTEST = 23 + TSTFAC = 1.0E0_R8 + CALL DODRX(TSTFAC,PASSED,LUNSUM) + + END +*DODRX + SUBROUTINE DODRX + & (TSTFAC,PASSED,LUNSUM) +C***Begin Prologue DODRX +C***Refer to ODR +C***Routines Called DDOT,DNRM2,ODR,DODRXD, +C DODRXF,DODRXW,DWGHT,DZERO +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Exercise features of ODRPACK95 software +C***End Prologue DODRX + +C...Used modules + USE ODRPACK95 + USE REAL_PRECISION + +C...Parameters + INTEGER + & LDWD,LDWE,LD2WD,LD2WE,LIWORK,LWORK,MAXN,MAXM,MAXNP,MAXNQ,NTESTS + REAL (KIND=R8) + & BASE + PARAMETER + & (MAXN=50, MAXM=3, MAXNP=10, MAXNQ=2, NTESTS=23, + & LDWE=MAXN, LD2WE=MAXNQ, LDWD=MAXN, LD2WD=MAXM, + & 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), + & BASE = RADIX(1.0E0_R8)) + +C...Scalar arguments + REAL (KIND=R8) + & TSTFAC + INTEGER + & LUNSUM + LOGICAL + & PASSED + +C...Scalars in common + INTEGER + & NTEST,SETNO + +C...Local scalars + INTEGER + & I,INFO,IPRINT,ITEST,JOB,L,LDIFX,LDSCLD,LDSTPD,LDWD1,LDWE1, + & LDX,LDY,LD2WD1,LD2WE1,LIWMIN,LUN,LUNERR,LUNRPT,LWMIN, + & M,MAXIT,MSG,N,NDIGIT,NP,NQ + REAL (KIND=R8) + & BNRM,EPSMAC,EWRT,EWRT2,HUNDRD,ONE,P01,P2,PARTOL,SSTOL, + & TAUFAC,THREE,TSTTOL,TWO,WSS,WSSDEL,WSSEPS,ZERO + LOGICAL + & FAILED,FAILS,ISODR,SHORT + CHARACTER TITLE*80 + +C...Arrays in common + REAL (KIND=R8) + & LOWER(MAXNP),UPPER(MAXNP) + +C...Local arrays + REAL (KIND=R8) + & BETA(MAXNP),DELTA(:,:),DPYMP(2,NTESTS), + & SCLB(MAXNP),SCLD(MAXN,MAXM), + & STPB(MAXNP),STPD(MAXN,MAXM), + & WE(MAXN,MAXNQ,MAXNQ),WD(MAXN,MAXM,MAXM),WORK(:), + & WRK(MAXN*MAXM+MAXN*MAXNQ),X(MAXN,MAXM),Y(MAXN,MAXNQ), + & TEMPRETL(MAXN,MAXM) + INTEGER + & IDPYMP(NTESTS),IFIXB(MAXNP),IFIXX(MAXN,MAXM),IWORK(:) + +C...Pointers + POINTER + & DELTA,IWORK,WORK + +C...External functions + REAL (KIND=R8) + & DDOT,DNRM2 + EXTERNAL + & DDOT,DNRM2 + +C...External subroutines + EXTERNAL + & DODRXD,DODRXF,DODRXW,DZERO + +C...Intrinsic functions + INTRINSIC + & ABS,MOD + +C...Common blocks + COMMON /SETID/SETNO + COMMON /TSTSET/ NTEST + COMMON /BOUNDS/ LOWER,UPPER + +C...Data statements + DATA + & ZERO,P01,P2,ONE,TWO,THREE,HUNDRD + & /0.0E0_R8,0.01E0_R8,0.2E0_R8,1.0E0_R8,2.0E0_R8,3.0E0_R8, + & 100.0E0_R8/ + + DATA + & (DPYMP(I,1),I=1,2) + & /2.762733195780256808978449342964E+04_R8, + & 7.532639569022918943695104672512E-04_R8/ + DATA + & (DPYMP(I,2),I=1,2) + & /2.762732630143673024399942947263E+04_R8, + & 7.538467722687131506874279314940E-04_R8/ + DATA + & (DPYMP(I,3),I=1,2) + & /1.069944100000000027940905194068E+09_R8, + & 1.212808593256056359629660672046E-05_R8/ + DATA + & (DPYMP(I,4),I=1,2) + & /1.069944100000000026623461142867E+09_R8, + & 5.452084633790606017572015067556E-07_R8/ + DATA + & (DPYMP(I,5),I=1,2) + & /1.426988156377258617521571734503E+00_R8, + & 1.084728687127432219753903919409E+00_R8/ + DATA + & (DPYMP(I,6),I=1,2) + & /4.261321829513978871872508874025E+00_R8, + & 1.477967210398420733565424329280E-02_R8/ + DATA + & (DPYMP(I,7),I=1,2) + & /4.261272307142888464011486769858E+00_R8, + & 1.477966125465374336804138554559E-02_R8/ + DATA + & (DPYMP(I,8),I=1,2) + & /4.371487317909745009110272283622E+01_R8, + & 1.144419474408286067112233592550E-03_R8/ + DATA + & (DPYMP(I,9),I=1,2) + & /3.099048849376848610380977303924E+00_R8, + & 8.824708863783850023783338218501E-02_R8/ + DATA + & (DPYMP(I,10),I=1,2) + & /9.469917836739932584221023234527E+00_R8, + & 4.205389215588104651198536809880E-01_R8/ + DATA + & (DPYMP(I,11),I=1,2) + & /3.950949253027682207109233363651E+01_R8, + & 6.651838750834910819636881506915E+01_R8/ + DATA + & (DPYMP(I,12),I=1,2) + & /3.950949253027682207109233363651E+01_R8, + & 6.651838750834910819636881506915E+01_R8/ + DATA + & (DPYMP(I,13),I=1,2) + & /1.414213562373095000000000000000E+00_R8, + & 5.250825926608277346013642256883E-26_R8/ + DATA + & (DPYMP(I,14),I=1,2) + & /1.414213562373095000000000000000E+00_R8, + & 8.159081600696301507018019048968E-26_R8/ + DATA + & (DPYMP(I,15),I=1,2) + & /1.486588477064952451556223422813E+00_R8, + & 1.841690442255357083922717720270E+03_R8/ + DATA + & (DPYMP(I,16),I=1,2) + & /2.001224625073357401561224833131E+02_R8, + & 0.000000000000000000000000000000E+00_R8/ + DATA + & (DPYMP(I,17),I=1,2) + & /2.000099997500125000000000000000E+02_R8, + & 0.000000000000000000000000000000E+00_R8/ + DATA + & (DPYMP(I,18),I=1,2) + & /1.414213562373095000000000000000E+00_R8, + & 5.816277809383742531415846947805E-26_R8/ + DATA + & (DPYMP(I,19),I=1,2) + & /2.000624902374255782433465356007E+02_R8, + & 4.568236947482152283374593507328E+30_R8/ + + DATA + & (DPYMP(I,20),I=1,2) + & /2.000624902374255782433465356007E+02_R8, + & 1.848525209410256939008831977844E+05_R8/ + + DATA + & (DPYMP(I,21),I=1,2) + & /2.000624902374255782433465356007E+02_R8, + & 1.848525209410256939008831977844E+05_R8/ + + DATA + & (DPYMP(I,22),I=1,2) + & /2.731300056749532689792659000000E+00_R8, + & 3.378975642596100806258619000000E+05_R8/ + + DATA + & (DPYMP(I,23),I=1,2) + & /2.675757304209387399396291584708E+00_R8, + & 5.174484505019630309341494012187E-02_R8/ + + DATA + & (IDPYMP(I),I=1,23) + & /1,1,3,1,1,4,1,1,2,1,1023,40100,2,2,3,90100,91000,2,90010, + & 90020,90010,21,1/ + +C...Interface blocks + INTERFACE + SUBROUTINE DWGHT + & (N,M,WT,LDWT,LD2WT,T,WTT) + USE REAL_PRECISION + INTEGER + & LDWT,LD2WT,M,N + REAL (KIND=R8) + & T(:,:),WT(:,:,:),WTT(:,:) + END SUBROUTINE + END INTERFACE + +C...Routine names used as subprogram arguments +C DODRXF: The user-supplied routine for evaluating the model. + +C...Variable definitions (alphabetically) +C BASE: The base of floating point numbers on the current machine +C BETA: The function parameters. +C BNRM: The norm of BETA. +C DELTA: The error in the X data. +C DPYMP: The floating point results from a cray YMP using +C REAL (KIND=R8). +C EPSMAC: The value of machine precision. +C EWRT: A temporary variable for the denominator of the relative error +C calculations (error with respect to). +C EWRT2: A temporary variable for the denominator of the relative error +C calculations (error with respect to). +C FAILED: The variable designating whether the results of all of the +C demonstration runs agreed with those from the cray YMP +C using REAL (KIND=R8) (FAILED=FALSE) or whether some of +C the tests disagreed (FAILED=TRUE). +C FAILS: The variable designating whether the results of an +C individual demonstration run agreed with those from the +C cray YMP using REAL (KIND=R8) (FAILS=FALSE) or +C disagree (FAILS=TRUE). +C HUNDRD: The value 100.0E0_R8. +C I: An index variable. +C IDPYMP: The integer results from a cray YMP using +C REAL (KIND=R8). +C IFIXB: The values designating whether the elements of BETA are +C fixed at their input values or not. +C IFIXX: The values designating whether the elements of DELTA are +C fixed at their input values or not. +C INFO: The variable designating why the computations stopped. +C IPRINT: The print control variable. +C ISODR: The variable designating whether the solution is by odr +C (ISODR=TRUE) or by ols (ISODR=FALSE). +C ITEST: The number of the current test being run. +C IWORK: The integer work space. +C J: An index variable. +C JOB: The variable controlling problem initialization and +C computational method. +C LDIFX: The leading dimension of array IFIXX. +C LDSCLD: The leading dimension of array SCLD. +C LDWD: The leading dimension of array WD. +C LDWD1: The leading dimension of array WD as passed to ODRPACK95. +C LDWE: The leading dimension of array WE. +C LDWE1: The leading dimension of array WE as passed to ODRPACK95. +C LDX: The leading dimension of array X. +C LDY: The leading dimension of array Y. +C LD2WD: The second dimension of array WD. +C LD2WD1: The second dimension of array WD as passed to ODRPACK95. +C LD2WE: The second dimension of array WE. +C LD2WE1: The second dimension of array WE as passed to ODRPACK95. +C LIWKMN: The minimum acceptable length of array IWORK. +C LIWMIN: The minimum length of vector IWORK for a given problem. +C LIWORK: The length of vector IWORK. +C LUN: The logical unit number currently being used. +C LUNERR: The logical unit number used for error messages. +C LUNRPT: The logical unit number used for computation reports. +C LUNSUM: The logical unit number used for a summary report. +C LWKMN: The minimum acceptable length of array WORK. +C LWMIN: The minimum length of vector WORK for a given problem. +C LWORK: The length of vector WORK. +C M: The number of columns of data in the explanatory variable. +C MAXIT: The maximum number of iterations allowed. +C MSG: The variable designating which message is to be printed as +C a result of the comparison with the cray YMP or x86 (Linux) +C results. +C N: The number of observations. +C NDIGIT: The number of accurate digits in the function results, as +C supplied by the user. +C NP: The number of function parameters. +C NTEST: The number of tests to be run. +C NTESTS: The number of different tests available. +C ONE: The value 1.0E0_R8. +C PASSED: The variable designating whether the results of all of the +C demonstration runs agreed with those from the cray YMP +C using REAL (KIND=R8) (PASSED=TRUE), or whether some of +C the results disagreed (PASSED=FALSE). +C P01: The value 0.01E0_R8. +C P2: The value 0.2E0_R8. +C PARTOL: The parameter convergence stopping criteria. +C SCLB: The scaling values for BETA. +C SCLD: The scaling values for DELTA. +C SETNO: The number of the data set being analyzed. +C SHORT: The variable designating whether ODRPACK95 is invoked by the +C short-call (SHORT=.TRUE.) or the long-call (SHORT=.FALSE.). +C SSTOL: The sum-of-squares convergence stopping tolerance. +C TAUFAC: The factor used to compute the initial trust region +C diameter. +C THREE: The value 3.0E0_R8. +C TITLE: The reference for the data set being analyzed. +C TSTFAC: The user-supplied factor for scaling the test tolerances +C used to check for agreement between computed results and +C results obtained using REAL (KIND=R8) version on cray +C YMP. +C TSTTOL: The test tolerance used in checking computed values for +C purposes of determining proper installation. +C TWO: The value 2.0E0_R8. +C WD: The DELTA weights. +C WE: The EPSILON weights. +C WORK: The REAL (KIND=R8) work space. +C WRK: The REAL (KIND=R8) work space for computing test results. +C WSS: The sum of the squared weighted errors. +C WSSDEL: The sum of the squared weighted errors in X. +C WSSEPS: The sum of the squared weighted errors in Y. +C X: The explanatory variable. +C Y: The response variable. +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODRX + + +C Allocate work arrays and DELTA + + ALLOCATE(DELTA(MAXN,MAXM),IWORK(LIWORK),WORK(LWORK)) + +C Set logical units for error and computation reports + + LUNERR = 18 + LUNRPT = 18 + +C Initialize test tolerance + + IF (TSTFAC.GT.ONE) THEN + TSTTOL = TSTFAC + ELSE + TSTTOL = ONE + END IF + +C Initialize machine precision + + EPSMAC = BASE**(1-DIGITS(BASE)) + +C Initialize leading dimension of X + + LDX = MAXN + LDY = MAXN + +C Initialize miscellaneous variables used in the exercise procedure + + FAILED = .FALSE. + SHORT = .TRUE. + ISODR = .TRUE. + N = 0 + +C Begin exercising ODRPACK95 + + DO 400 ITEST=1,NTEST + +C Set control values to invoke default values + + WE(1,1,1) = -ONE + LDWE1 = LDWE + LD2WE1 = LD2WE + WD(1,1,1) = -ONE + LDWD1 = LDWD + LD2WD1 = LD2WD + + IFIXB(1) = -1 + IFIXX(1,1) = -1 + LDIFX = MAXN + + NDIGIT = -1 + TAUFAC = -ONE + + SSTOL = -ONE + PARTOL = -ONE + MAXIT = -1 + + IPRINT = 2112 +C IPRINT = 6616 + + STPB(1) = -ONE + STPD(1,1) = -ONE + LDSTPD = 1 + + SCLB(1) = -ONE + SCLD(1,1) = -ONE + LDSCLD = 1 + + UPPER(:) = HUGE(ONE) + LOWER(:) = -HUGE(ONE) + + + IF (ITEST.EQ.1) THEN + +C Test simple odr problem +C with analytic derivatives. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 10 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + 10 CONTINUE + SETNO = 5 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00020 + SHORT = .TRUE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.2) THEN + +C Test simple ols problem +C with forward difference derivatives. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 20 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1020) + LUN = LUNSUM + 20 CONTINUE + SETNO = 5 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00002 + SHORT = .TRUE. + ISODR = .FALSE. + + ELSE IF (ITEST.EQ.3) THEN + +C Test parameter fixing capabilities for poorly scaled ols problem +C with analytic derivatives. +C (derivative checking turned off.) + + LUN = LUNRPT + WRITE (LUN,1000) + DO 30 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1030) + LUN = LUNSUM + 30 CONTINUE + SETNO = 3 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + IFIXB(1) = 1 + IFIXB(2) = 1 + IFIXB(3) = 1 + IFIXB(4) = 0 + IFIXB(5) = 1 + IFIXB(6) = 0 + IFIXB(7) = 0 + IFIXB(8) = 0 + IFIXB(9) = 0 + JOB = 00042 + SHORT = .FALSE. + ISODR = .FALSE. + + ELSE IF (ITEST.EQ.4) THEN + +C Test weighting capabilities for odr problem with +C analytic derivatives. +C Also shows solution of poorly scaled odr problem. +C (derivative checking turned off.) +C N.B., this run continues from where test 3 left off. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 40 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1040) + LUN = LUNSUM + 40 CONTINUE + SETNO = 3 + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + LDWD1 = LDWD + LDWE1 = LDWE + LD2WD1 = LD2WD + LD2WE1 = LD2WE + DO 45 I=1,N + WD(I,1,1) = (P01/ABS(X(I,1)))**2 + WE(I,1,1) = ONE + 45 CONTINUE + WE(28,1,1) = ZERO + IFIXB(1) = 1 + IFIXB(2) = 1 + IFIXB(3) = 1 + IFIXB(4) = 0 + IFIXB(5) = 1 + IFIXB(6) = 1 + IFIXB(7) = 1 + IFIXB(8) = 0 + IFIXB(9) = 0 + JOB = 00030 + IPRINT = 2232 + SHORT = .FALSE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.5) THEN + +C Test DELTA initialization capabilities and user-supplied scaling +C and use of istop to restrict parameter values +C for odr problem with analytic derivatives. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 50 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1050) + LUN = LUNSUM + 50 CONTINUE + SETNO = 1 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 01020 + LDSCLD = 1 + SCLD(1,1) = TWO + SCLB(1) = P2 + SCLB(2) = ONE + LDWE1 = 1 + LD2WE1 = 1 + WE(1,1,1) = -ONE + LDWD1 = 1 + LD2WD1 = 1 + WD(1,1,1) = -ONE + DO 55 I=20,21 + DELTA(I,1) = BETA(1)/Y(I,1) + BETA(2) - X(I,1) + 55 CONTINUE + SHORT = .FALSE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.6) THEN + +C Test stiff stopping conditions for unscaled odr problem +C with analytic derivatives. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 60 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1060) + LUN = LUNSUM + 60 CONTINUE + SETNO = 4 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00020 + SSTOL = HUNDRD*EPSMAC + PARTOL = EPSMAC + MAXIT = 2 + SHORT = .FALSE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.7) THEN + +C Test restart for unscaled odr problem +C with analytic derivatives. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 70 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1070) + LUN = LUNSUM + 70 CONTINUE + SETNO = 4 + JOB = 20220 + SSTOL = HUNDRD*EPSMAC + PARTOL = EPSMAC + MAXIT = 50 + SHORT = .FALSE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.8) THEN + +C Test use of TAUFAC to restrict first step +C for odr problem with central difference derivatives. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 80 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1080) + LUN = LUNSUM + 80 CONTINUE + SETNO = 6 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00210 + TAUFAC = P01 + SHORT = .FALSE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.9) THEN + +C Test implicit odr problem +C with forward finite difference derivatives +C and covariance matrix constructed with recomputed derivatives. + + + LUN = LUNRPT + WRITE (LUN,1000) + DO 90 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1090) + LUN = LUNSUM + 90 CONTINUE + SETNO = 7 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00001 + PARTOL = EPSMAC**(ONE/THREE) + SHORT = .TRUE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.10) THEN + +C Test multiresponse odr problem +C with central difference derivatives , +C DELTA initialized to nonzero values, +C variable fixing, and weighting. + + LUN = LUNRPT + WRITE (LUN,1000) + DO 100 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1100) + LUN = LUNSUM + 100 CONTINUE + SETNO = 8 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + + LDWD1 = LDWD + LDWE1 = LDWE + LD2WD1 = LD2WD + LD2WE1 = LD2WE + DO 105 I=1,N +C Initialize DELTA, and specify first decade of frequencies as fixed + 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 + +C Set weights + 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) + 105 CONTINUE + JOB = 00210 + SHORT = .FALSE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.11) THEN + +C Test detection of incorrect derivatives + + LUN = LUNRPT + WRITE (LUN,1000) + DO 110 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1110) + LUN = LUNSUM + 110 CONTINUE + SETNO = 6 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00022 + SHORT = .FALSE. + ISODR = .FALSE. + + ELSE IF (ITEST.EQ.12) THEN + +C Test detection of incorrect derivatives + + LUN = LUNRPT + WRITE (LUN,1000) + DO 120 I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1120) + LUN = LUNSUM + 120 CONTINUE + SETNO = 6 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00020 + SHORT = .FALSE. + ISODR = .TRUE. + + ELSE IF (ITEST.EQ.13) THEN + +C Test bounded odr problem where +C parameters start on bound, move away, hit bound, move away, find minimum. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00000 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + BETA(1:2) = (/ 200.0_R8, 5.0_R8 /) + LOWER(1:2) = (/ 0.1_R8, 0.0_R8 /) + UPPER(1:2) = (/ 200.0_R8, 5.0_R8 /) + + ELSE IF (ITEST.EQ.14) THEN + +C Test bounded odr problem where +C bounds are never hit. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00000 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + LOWER(1:2) = (/ 0.0_R8, 0.0_R8 /) + UPPER(1:2) = (/ 400.0_R8, 6.0_R8 /) + + ELSE IF (ITEST.EQ.15) THEN + +C Test bounded odr problem where +C minimum is on boundary. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00000 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 1000 + BETA(1:2) = (/ 200.0_R8, 3.0_R8 /) + LOWER(1:2) = (/ 1.1_R8, 0.0_R8 /) + UPPER(1:2) = (/ 400.0_R8, 6.0_R8 /) + TSTTOL = 500.0_R8 + + ELSE IF (ITEST.EQ.16) THEN + +C Test bounded odr problem where +C initial BETA is outside bounds. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00000 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 1000 + BETA(1:2) = (/ 200.0_R8, 7.0_R8 /) + LOWER(1:2) = (/ 1.1_R8, 0.0_R8 /) + UPPER(1:2) = (/ 200.0_R8, 5.0_R8 /) + + ELSE IF (ITEST.EQ.17) THEN + +C Test bounded odr problem where +C bounds are ill defined. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00000 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 1000 + BETA(1:2) = (/ 200.0_R8, 2.0_R8 /) + LOWER(1:2) = (/ 10.0_R8, 0.0_R8 /) + UPPER(1:2) = (/ 2.0_R8, 5.0_R8 /) + + ELSE IF (ITEST.EQ.18) THEN + +C Test bounded odr problem using centered differences where +C parameters start on bound, move away, hit bound, move away, find minimum. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00010 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + BETA(1:2) = (/ 200.0_R8, 5.0_R8 /) + LOWER(1:2) = (/ 0.1_R8, 0.0_R8 /) + UPPER(1:2) = (/ 200.0_R8, 5.0_R8 /) + + ELSE IF (ITEST.EQ.19) THEN + +C Test bounded odr problem when bounds are too small. +C Parameters start on bound. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00010 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + BETA(1:2) = (/ 200.0_R8, 5.0_R8 /) + UPPER(1) = 200.0_R8 + LOWER(2) = 5.0_R8 + LOWER(1) = UPPER(1) - 400*UPPER(1)*EPSMAC + & + UPPER(1)*EPSMAC + + UPPER(2) = LOWER(2) + 400*LOWER(2)*EPSMAC + & - LOWER(2)*EPSMAC + + ELSE IF (ITEST.EQ.20) THEN + +C Test bounded odr problem when bounds are just big enough for ndigit +C calculation but too small for difference calculation. +C Parameters start on bound. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00000 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + BETA(1:2) = (/ -200.0_R8, -5.0_R8 /) + UPPER(1) = -200.0_R8 + LOWER(2) = -5.0_R8 + LOWER(1) = UPPER(1) + 400*UPPER(1)*EPSMAC + UPPER(2) = LOWER(2) - 400*LOWER(2)*EPSMAC + + ELSE IF (ITEST.EQ.21) THEN + +C Test bounded odr problem when bounds are too small for derivative +C step sizes using forward differences. Parameters start on bound. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 9 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00000 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + BETA(1:2) = (/ -200.0_R8, -5.0_R8 /) + UPPER(1) = -200.0_R8 + LOWER(2) = -5.0_R8 + LOWER(1) = UPPER(1) + UPPER(1)*EPSMAC + UPPER(2) = LOWER(2) - LOWER(2)*EPSMAC + + ELSE IF (ITEST.EQ.22) THEN + +C Test bounded odr problem when first parameter is fixed and second is bounded. +C However, set the bounds on the first parameter to exclude the correct value +C of the second parameter. This will exercise the packing and unpacking of +C parameters and ensure that bounds and fixed parameters can be mixed. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 10 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00010 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + BETA(1:2) = (/ 2.5_R8, 1.5_R8 /) + LOWER(1:2) = (/ 2.5_R8, 1.1_R8 /) + UPPER(1:2) = (/ 10.0_R8, 5.0_R8 /) + IFIXB(1:2) = (/ 0, 1 /) + + ELSE IF (ITEST.EQ.23) THEN + +C Similar to test 22 but without bounds. + + LUN = LUNRPT + WRITE (LUN,1000) + DO I=1,2 + WRITE (LUN,1001) ITEST + WRITE (LUN,1010) + LUN = LUNSUM + END DO + SETNO = 10 + CALL DODRXD(TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) + CALL DZERO(LWORK,1,WORK,LWORK) + DELTA(:,:) = ZERO + JOB = 00010 + SHORT = .FALSE. + ISODR = .TRUE. + MAXIT = 100 + BETA(1:2) = (/ 2.5_R8, 1.5_R8 /) + LOWER(1:2) = -HUGE(1.0_R8) + UPPER(1:2) = HUGE(1.0_R8) + IFIXB(1:2) = (/ 0, 1 /) + + END IF + + CALL DODRXW + & (N,M,NP,NQ,LDWE1,LD2WE1,ISODR,LIWMIN,LWMIN) + +C Compute solution + + WRITE (LUNRPT,2200) TITLE + WRITE (LUNSUM,2200) TITLE + IF (SHORT) THEN + CALL ODR(FCN=DODRXF, + & N=N,M=M,NP=NP,NQ=NQ, + & BETA=BETA, + & Y=Y,X=X, + & DELTA=DELTA, + & WE=WE(1:LDWE1,1:LD2WE1,:), + & WD=WD(1:LDWD1,1:LD2WD1,:), + & JOB=JOB, + & IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT, + & WORK=WORK,IWORK=IWORK, + & INFO=INFO) + ELSE + CALL ODR(FCN=DODRXF, + & N=N,M=M,NP=NP,NQ=NQ, + & BETA=BETA, + & Y=Y,X=X, + & DELTA=DELTA, + & WE=WE(1:LDWE1,1:LD2WE1,:), + & WD=WD(1:LDWD1,1:LD2WD1,:), + & IFIXB=IFIXB,IFIXX=IFIXX(1:LDIFX,:), + & JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC, + & SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT, + & IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT, + & STPB=STPB,STPD=STPD(1:LDSTPD,:), + & SCLB=SCLB,SCLD=SCLD(1:LDSCLD,:), + & WORK=WORK,IWORK=IWORK, + & LOWER=LOWER(1:NP),UPPER=UPPER(1:NP), + & INFO=INFO) + END IF + +C Compare results with those obtained on the cray ymp or the intel xeon running +C Linux using REAL (KIND=R8) version of ODRPACK95 + + BNRM = DNRM2(NP,BETA,1) + CALL DWGHT(N,M,WD,LDWD1,LD2WD1,RESHAPE(WORK(1:N*M),(/N,M/)), + & TEMPRETL(1:N,1:M)) + WRK(1:N*M) = RESHAPE(TEMPRETL(1:N,1:M),(/N*M/)) + WSSDEL = DDOT(N*M,WORK(1:N*M),1,WRK(1),1) + CALL DWGHT(N,NQ,WE,LDWE1,LD2WE1, + & RESHAPE(WORK(N*M+1:N*M+1+N*NQ-1),(/N,NQ/)), + & TEMPRETL(1:N,1:NQ)) + WRK(N*M+1:N*M+1+N*NQ-1) = RESHAPE(TEMPRETL(1:N,1:NQ),(/N*NQ/)) + WSSEPS = DDOT(N*NQ,WORK(N*M+1:N*M+1+N*NQ-1),1, + & WRK(N*M+1:N*M+1+N*NQ-1),1) + WSS = WSSEPS + WSSDEL + + IF (SSTOL.LT.ZERO) THEN + SSTOL = SQRT(EPSMAC) + ELSE + SSTOL = MIN(SSTOL, ONE) + END IF + + IF (PARTOL.LT.ZERO) THEN + PARTOL = EPSMAC**(TWO/THREE) + ELSE + PARTOL = MIN(PARTOL, ONE) + END IF + + IF (INFO.GE.10000) THEN + IF (IDPYMP(ITEST).EQ.INFO) THEN + FAILS = .FALSE. + MSG = 1 + ELSE + FAILS = .TRUE. + MSG = 3 + END IF + + ELSE IF (MOD(INFO,10).EQ.1) THEN + FAILS = ABS(WSS-DPYMP(2,ITEST)).GT. + & DPYMP(2,ITEST)*SSTOL*TSTTOL + MSG = 2 + + ELSE IF (MOD(INFO,10).EQ.2) THEN + FAILS = ABS(BNRM-DPYMP(1,ITEST)).GT. + & DPYMP(1,ITEST)*PARTOL*TSTTOL + MSG = 2 + + ELSE IF (MOD(INFO,10).EQ.3) THEN + FAILS = (ABS(WSS-DPYMP(2,ITEST)).GT. + & DPYMP(2,ITEST)*SSTOL*TSTTOL) + & .AND. + & (ABS(BNRM-DPYMP(1,ITEST)).GT. + & DPYMP(1,ITEST)*PARTOL*TSTTOL) + MSG = 2 + + ELSE IF ((MOD(INFO,10).EQ.4) .AND. (IDPYMP(ITEST).EQ.4)) THEN + FAILS = .FALSE. + MSG = 1 + + ELSE IF (INFO.EQ.IDPYMP(ITEST)) THEN + FAILS = .TRUE. + MSG = 4 + ELSE + FAILS = .TRUE. + MSG = 3 + END IF + + FAILED = FAILED .OR. FAILS + + LUN = LUNRPT + DO 300 L=1,2 + WRITE (LUN,3100) + WRITE (LUN,3210) + & ' CRAY YMP OR X86 RESULT = ', + & DPYMP(1,ITEST),DPYMP(2,ITEST),IDPYMP(ITEST) + WRITE (LUN,3210) ' NEW TEST RESULT = ', + & BNRM,WSS,INFO + WRITE (LUN,3220) ' DIFFERENCE = ', + & ABS(DPYMP(1,ITEST)-BNRM),ABS(DPYMP(2,ITEST)-WSS) + EWRT = ABS(DPYMP(1,ITEST)) + EWRT2 = ABS(DPYMP(2,ITEST)) + IF (EWRT.EQ.ZERO) THEN + EWRT = ONE + END IF + IF (EWRT2.EQ.ZERO) THEN + EWRT2 = ONE + END IF + WRITE (LUN,3220) ' RELATIVE ERROR = ', + & ABS(DPYMP(1,ITEST)-BNRM)/EWRT, + & ABS(DPYMP(2,ITEST)-WSS)/EWRT2 + + IF (MSG.EQ.1) THEN + WRITE (LUN,3310) + ELSE IF (MSG.EQ.2) THEN + IF (FAILS) THEN + WRITE (LUN,3320) + ELSE + WRITE (LUN,3330) + END IF + ELSE IF (MSG.EQ.3) THEN + WRITE (LUN,3340) + ELSE IF (MSG.EQ.4) THEN + WRITE (LUN,3350) + END IF + + LUN = LUNSUM + 300 CONTINUE + 400 CONTINUE + + WRITE (LUNRPT,1000) + IF (FAILED) THEN + WRITE (LUNRPT,4100) + WRITE (LUNSUM,4100) + PASSED = .FALSE. + ELSE + WRITE (LUNRPT,4200) + WRITE (LUNSUM,4200) + PASSED = .TRUE. + END IF + +C Format statements + + 1000 FORMAT('1') + 1001 FORMAT(' Example ', I2/) + 1010 FORMAT(' Test simple odr problem'/ + & ' with analytic derivatives', + & ' using ODR.') + 1020 FORMAT(' Test simple OLS problem'/ + & ' with finite difference derivatives', + & ' using ODR.') + 1030 FORMAT(' Test parameter fixing capabilities', + & ' for poorly scaled OLS problem'/ + & ' with analytic derivatives', + & ' using ODR.') + 1040 FORMAT(' Test weighting capabilities', + & ' for ODR problem'/ + & ' with analytic derivatives', + & ' using ODR. '/ + & ' also shows solution of poorly scaled', + & ' ODR problem.'/ + & ' (derivative checking turned off.)') + 1050 FORMAT(' Test DELTA initialization capabilities'/ + & ' and use of ISTOP to restrict parameter values', + & ' for ODR problem'/ + & ' with analytic derivatives', + & ' using ODR.') + 1060 FORMAT(' Test stiff stopping conditions', + & ' for unscaled ODR problem'/ + & ' with analytic derivatives', + & ' using ODR.') + 1070 FORMAT(' Test restart', + & ' for unscaled ODR problem'/ + & ' with analytic derivatives', + & ' using ODR.') + 1080 FORMAT(' Test use of TAUFAC to restrict first step', + & ' for ODR problem'/ + & ' with finite difference derivatives', + & ' using ODR.') + 1090 FORMAT(' Test implicit model', + & ' for OLS problem'/ + & ' using ODR.') + 1100 FORMAT(' Test multiresponse model', + & ' for ODR problem'/ + & ' with finite difference derivatives', + & ' using ODR.') + 1110 FORMAT(' Test detection of questionable analytic derivatives', + & ' for OLS problem'/ + & ' using ODR.') + 1120 FORMAT(' Test detection of incorrect analytic derivatives', + & ' for ODR problem'/ + & ' with analytic derivatives', + & ' using ODR.') + 2200 FORMAT (' Data Set Reference: ', A80) + 3100 FORMAT + & (/' Comparison of new results with', + & ' REAL (KIND=R8) Cray YMP or Intel X86 (Linux) '/ + & ' Result:'// + & ' Norm of BETA', + & ' Sum of Squared WTD OBS Errors INFO') + 3210 FORMAT + & (/A25/1P,2E37.30,I6) + 3220 FORMAT + & (/A25,1P,D12.5,25X,D12.5,I6) + 3310 FORMAT + & (/' *** Stopping conditions', + & ' show convergence not attained. ***'/ + & ' no further comparisons made between results.'//) + 3320 FORMAT + & (//' *** WARNING ***', + & ' results do not agree to within stopping tolerance. ***'//) + 3330 FORMAT + & (//' *** Results agree to within stopping tolerance. ***'//) + 3340 FORMAT + & (//' *** WARNING ***', + & ' stopping conditions do not agree. ***'//) + 3350 FORMAT + & (//' *** WARNING ***', + & ' unexpected stopping condition.', + & ' please contact package authors. ***'//) + 4100 FORMAT + & (/// + & ' *** Summary:', + & ' one or more tests do not agree with expected results. ***') + 4200 FORMAT + & (/// + & ' *** Summary:', + & ' all tests agree with expected results. ***') + + END +*DODRXD + SUBROUTINE DODRXD + & (TITLE,N,M,NP,NQ,LDX,X,LDY,Y,BETA) +C***Begin Prologue DODRXD +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Set up data for ODRPACK95 exerciser +C***End Prologue DODRXD + +C...Used modules + USE REAL_PRECISION + +C...Parameters + INTEGER + & MAXN,MAXM,MAXNP,MAXNQ,MAXSET + PARAMETER + & (MAXN=50,MAXM=3,MAXNP=10,MAXNQ=3,MAXSET=16) + +C...Scalar arguments + INTEGER + & LDX,LDY,M,N,NP,NQ + CHARACTER TITLE*80 + +C...Array arguments + REAL (KIND=R8) + & BETA(*),X(LDX,*),Y(LDY,*) + +C...Scalars in common + INTEGER + & SETNO + +C...Local scalars + INTEGER + & I,J,K,L + +C...Local arrays + REAL (KIND=R8) + & BDATA(MAXNP,MAXSET),XDATA(MAXN,MAXM,MAXSET), + & YDATA(MAXN,MAXNQ,MAXSET) + INTEGER + & MDATA(MAXSET),NDATA(MAXSET),NPDATA(MAXSET),NQDATA(MAXSET) + CHARACTER TDATA(MAXSET)*80 + +C...Common blocks + COMMON /SETID/SETNO + +C...Data statements + DATA + & TDATA(1) + & /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1'/ + DATA + & NDATA(1), MDATA(1), NPDATA(1), NQDATA(1) + & /40, 1, 2, 1/ + DATA + & (BDATA(K,1),K=1,2) + & /1.0E+0_R8, 1.0E+0_R8/ + DATA + & YDATA( 1,1,1), XDATA( 1,1,1) + & /-0.119569795672791172E+1_R8, -0.213701920211315155E-1_R8/ + DATA + & YDATA( 2,1,1), XDATA( 2,1,1) + & /-0.128023349509594288E+1_R8, 0.494813247025012969E-1_R8/ + DATA + & YDATA( 3,1,1), XDATA( 3,1,1) + & /-0.125270693343174591E+1_R8, 0.127889194935560226E+0_R8/ + DATA + & YDATA( 4,1,1), XDATA( 4,1,1) + & /-0.996698267935287383E+0_R8, 0.128615394085645676E+0_R8/ + DATA + & YDATA( 5,1,1), XDATA( 5,1,1) + & /-0.104681033065801934E+1_R8, 0.232544285655021667E+0_R8/ + DATA + & YDATA( 6,1,1), XDATA( 6,1,1) + & /-0.146724952092847308E+1_R8, 0.268151108026504516E+0_R8/ + DATA + & YDATA( 7,1,1), XDATA( 7,1,1) + & /-0.123366891873487528E+1_R8, 0.309041029810905456E+0_R8/ + DATA + & YDATA( 8,1,1), XDATA( 8,1,1) + & /-0.165665097907185554E+1_R8, 0.405991539210081099E+0_R8/ + DATA + & YDATA( 9,1,1), XDATA( 9,1,1) + & /-0.168476460930907119E+1_R8, 0.376611424833536147E+0_R8/ + DATA + & YDATA(10,1,1), XDATA(10,1,1) + & /-0.198571971169224491E+1_R8, 0.475875890851020811E+0_R8/ + DATA + & YDATA(11,1,1), XDATA(11,1,1) + & /-0.195691696638051344E+1_R8, 0.499246935397386550E+0_R8/ + DATA + & YDATA(12,1,1), XDATA(12,1,1) + & /-0.211871342665769836E+1_R8, 0.536615037024021147E+0_R8/ + DATA + & YDATA(13,1,1), XDATA(13,1,1) + & /-0.268642932558671020E+1_R8, 0.581830765902996060E+0_R8/ + DATA + & YDATA(14,1,1), XDATA(14,1,1) + & /-0.281123260058024347E+1_R8, 0.684512710422277446E+0_R8/ + DATA + & YDATA(15,1,1), XDATA(15,1,1) + & /-0.328704486581785920E+1_R8, 0.660219819694757458E+0_R8/ + DATA + & YDATA(16,1,1), XDATA(16,1,1) + & /-0.423062993461887032E+1_R8, 0.766990323960781092E+0_R8/ + DATA + & YDATA(17,1,1), XDATA(17,1,1) + & /-0.512043906552226903E+1_R8, 0.808270426690578456E+0_R8/ + DATA + & YDATA(18,1,1), XDATA(18,1,1) + & /-0.731032616379005535E+1_R8, 0.897410020083189004E+0_R8/ + DATA + & YDATA(19,1,1), XDATA(19,1,1) + & /-0.109002759485608993E+2_R8, 0.959199774116277687E+0_R8/ + DATA + & YDATA(20,1,1), XDATA(20,1,1) + & /-0.251810238510370206E+2_R8, 0.914675474762916558E+0_R8/ + DATA + & YDATA(21,1,1), XDATA(21,1,1) + & /0.100123028650879944E+3_R8, 0.997759691476821892E+0_R8/ + DATA + & YDATA(22,1,1), XDATA(22,1,1) + & /0.168225085871915048E+2_R8, 0.107136870384216308E+1_R8/ + DATA + & YDATA(23,1,1), XDATA(23,1,1) + & /0.894830510866913009E+1_R8, 0.108033321037888526E+1_R8/ + DATA + & YDATA(24,1,1), XDATA(24,1,1) + & /0.645853815227747004E+1_R8, 0.116064198672771453E+1_R8/ + DATA + & YDATA(25,1,1), XDATA(25,1,1) + & /0.498218564760117328E+1_R8, 0.119080889359116553E+1_R8/ + DATA + & YDATA(26,1,1), XDATA(26,1,1) + & /0.382971664718710476E+1_R8, 0.129418875187635420E+1_R8/ + DATA + & YDATA(27,1,1), XDATA(27,1,1) + & /0.344116492497344184E+1_R8, 0.135594148099422453E+1_R8/ + DATA + & YDATA(28,1,1), XDATA(28,1,1) + & /0.276840496973858949E+1_R8, 0.135302808716893195E+1_R8/ + DATA + & YDATA(29,1,1), XDATA(29,1,1) + & /0.259521665196956666E+1_R8, 0.137994666010141371E+1_R8/ + DATA + & YDATA(30,1,1), XDATA(30,1,1) + & /0.205996022794557661E+1_R8, 0.147630019545555113E+1_R8/ + DATA + & YDATA(31,1,1), XDATA(31,1,1) + & /0.197939614345337836E+1_R8, 0.153450708076357840E+1_R8/ + DATA + & YDATA(32,1,1), XDATA(32,1,1) + & /0.156739340562905589E+1_R8, 0.152805351451039313E+1_R8/ + DATA + & YDATA(33,1,1), XDATA(33,1,1) + & /0.159032057073028366E+1_R8, 0.157147316247224806E+1_R8/ + DATA + & YDATA(34,1,1), XDATA(34,1,1) + & /0.173102268158937949E+1_R8, 0.166649596005678175E+1_R8/ + DATA + & YDATA(35,1,1), XDATA(35,1,1) + & /0.155512561664824758E+1_R8, 0.166505665838718412E+1_R8/ + DATA + & YDATA(36,1,1), XDATA(36,1,1) + & /0.149635994944133260E+1_R8, 0.175214128553867338E+1_R8/ + DATA + & YDATA(37,1,1), XDATA(37,1,1) + & /0.147487601463073568E+1_R8, 0.180567992463707922E+1_R8/ + DATA + & YDATA(38,1,1), XDATA(38,1,1) + & /0.117244575233306998E+1_R8, 0.184624404296278952E+1_R8/ + DATA + & YDATA(39,1,1), XDATA(39,1,1) + & /0.910931336069172580E+0_R8, 0.195568727388978002E+1_R8/ + DATA + & YDATA(40,1,1), XDATA(40,1,1) + & /0.126172980914513272E+1_R8, 0.199326394036412237E+1_R8/ + + DATA + & TDATA(2) + & /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2'/ + DATA + & NDATA(2), MDATA(2), NPDATA(2), NQDATA(2) + & /50, 2, 3, 1/ + DATA + & (BDATA(K,2),K=1,3) + & /-1.0E+0_R8, 1.0E+0_R8, 1.0E+0_R8/ + DATA + & YDATA( 1,1,2), XDATA( 1,1,2), XDATA( 1,2,2) + & /0.680832777217942900E+0_R8, + & 0.625474598833994800E-1_R8, 0.110179064209783100E+0_R8/ + DATA + & YDATA( 2,1,2), XDATA( 2,1,2), XDATA( 2,2,2) + & /0.122183594595302200E+1_R8, + & 0.202500343620642400E+0_R8, -0.196140862891327600E-1_R8/ + DATA + & YDATA( 3,1,2), XDATA( 3,1,2), XDATA( 3,2,2) + & /0.118958678734608200E+1_R8, + & 0.164943738599876500E+0_R8, 0.166514874750996600E+0_R8/ + DATA + & YDATA( 4,1,2), XDATA( 4,1,2), XDATA( 4,2,2) + & /0.146982623764094600E+1_R8, + & 0.304874137610506100E+0_R8, 0.612908688041490500E-2_R8/ + DATA + & YDATA( 5,1,2), XDATA( 5,1,2), XDATA( 5,2,2) + & /0.167775338189355300E+1_R8, + & 0.532727445580665100E+0_R8, 0.938248787552444600E-1_R8/ + DATA + & YDATA( 6,1,2), XDATA( 6,1,2), XDATA( 6,2,2) + & /0.202485721906026200E+1_R8, + & 0.508823707598910200E+0_R8, 0.499605775020505400E-2_R8/ + DATA + & YDATA( 7,1,2), XDATA( 7,1,2), XDATA( 7,2,2) + & /0.258912851935938800E+1_R8, + & 0.704227041878554000E+0_R8, 0.819354849092326200E-1_R8/ + DATA + & YDATA( 8,1,2), XDATA( 8,1,2), XDATA( 8,2,2) + & /0.366894203254154800E+1_R8, + & 0.592077736111512000E+0_R8, 0.127113960672389100E-1_R8/ + DATA + & YDATA( 9,1,2), XDATA( 9,1,2), XDATA( 9,2,2) + & /0.574609583351347300E+1_R8, + & 0.104940945646421600E+1_R8, 0.258095243658316100E-1_R8/ + DATA + & YDATA(10,1,2), XDATA(10,1,2), XDATA(10,2,2) + & /0.127676424026489300E+2_R8, + & 0.979382517558619200E+0_R8, 0.124280755181027900E+0_R8/ + DATA + & YDATA(11,1,2), XDATA(11,1,2), XDATA(11,2,2) + & /0.123473079693623100E+1_R8, + & 0.637870453165538700E-1_R8, 0.304856401137196400E+0_R8/ + DATA + & YDATA(12,1,2), XDATA(12,1,2), XDATA(12,2,2) + & /0.142256120864082800E+1_R8, + & 0.176123312906025700E+0_R8, 0.262387028078896900E+0_R8/ + DATA + & YDATA(13,1,2), XDATA(13,1,2), XDATA(13,2,2) + & /0.169889534013024700E+1_R8, + & 0.310965082300263000E+0_R8, 0.226430765474758800E+0_R8/ + DATA + & YDATA(14,1,2), XDATA(14,1,2), XDATA(14,2,2) + & /0.173485577901204400E+1_R8, + & 0.311394269116782100E+0_R8, 0.271375840410281800E+0_R8/ + DATA + & YDATA(15,1,2), XDATA(15,1,2), XDATA(15,2,2) + & /0.277761263972834600E+1_R8, + & 0.447076126190612500E+0_R8, 0.255000858902618300E+0_R8/ + DATA + & YDATA(16,1,2), XDATA(16,1,2), XDATA(16,2,2) + & /0.339163324662617300E+1_R8, + & 0.384786230998211100E+0_R8, 0.154958003178364000E+0_R8/ + DATA + & YDATA(17,1,2), XDATA(17,1,2), XDATA(17,2,2) + & /0.589615137312147500E+1_R8, + & 0.649093176450780500E+0_R8, 0.258301685463773200E+0_R8/ + DATA + & YDATA(18,1,2), XDATA(18,1,2), XDATA(18,2,2) + & /0.124415625214576800E+2_R8, + & 0.685612005372525500E+0_R8, 0.107391260603228600E+0_R8/ + DATA + & YDATA(19,1,2), XDATA(19,1,2), XDATA(19,2,2) + & /-0.498491739153861600E+2_R8, + & 0.968747139425088400E+0_R8, 0.151932526135740700E+0_R8/ + DATA + & YDATA(20,1,2), XDATA(20,1,2), XDATA(20,2,2) + & /-0.832795509000618600E+1_R8, + & 0.869789367989532900E+0_R8, 0.625507500586400000E-1_R8/ + DATA + & YDATA(21,1,2), XDATA(21,1,2), XDATA(21,2,2) + & /0.184934617774239900E+1_R8, + & -0.465309930332736600E-2_R8, 0.546795662595375200E+0_R8/ + DATA + & YDATA(22,1,2), XDATA(22,1,2), XDATA(22,2,2) + & /0.175192979176839200E+1_R8, + & 0.604753397196646000E-2_R8, 0.230905749473922700E+0_R8/ + DATA + & YDATA(23,1,2), XDATA(23,1,2), XDATA(23,2,2) + & /0.253949381238535800E+1_R8, + & 0.239418809621756000E+0_R8, 0.190752069681170700E+0_R8/ + DATA + & YDATA(24,1,2), XDATA(24,1,2), XDATA(24,2,2) + & /0.373500774928501700E+1_R8, + & 0.456662468911699800E+0_R8, 0.328870615170984400E+0_R8/ + DATA + & YDATA(25,1,2), XDATA(25,1,2), XDATA(25,2,2) + & /0.548408128950331000E+1_R8, + & 0.371115320522079500E+0_R8, 0.439978556640660500E+0_R8/ + DATA + & YDATA(26,1,2), XDATA(26,1,2), XDATA(26,2,2) + & /0.125256880521774300E+2_R8, + & 0.586442107042503000E+0_R8, 0.490689043752286700E+0_R8/ + DATA + & YDATA(27,1,2), XDATA(27,1,2), XDATA(27,2,2) + & /-0.493587797164916600E+2_R8, + & 0.579796274973298000E+0_R8, 0.521860998203383100E+0_R8/ + DATA + & YDATA(28,1,2), XDATA(28,1,2), XDATA(28,2,2) + & /-0.801158974965412700E+1_R8, + & 0.805008094903899900E+0_R8, 0.292283538955391600E+0_R8/ + DATA + & YDATA(29,1,2), XDATA(29,1,2), XDATA(29,2,2) + & /-0.437399487061934100E+1_R8, + & 0.637242340835710000E+0_R8, 0.402261740352486000E+0_R8/ + DATA + & YDATA(30,1,2), XDATA(30,1,2), XDATA(30,2,2) + & /-0.297800103425979600E+1_R8, + & 0.982132817936118700E+0_R8, 0.392546836419047000E+0_R8/ + DATA + & YDATA(31,1,2), XDATA(31,1,2), XDATA(31,2,2) + & /0.271811057454661300E+1_R8, + & -0.223515657121262700E-1_R8, 0.650479019708978800E+0_R8/ + DATA + & YDATA(32,1,2), XDATA(32,1,2), XDATA(32,2,2) + & /0.377035865613392400E+1_R8, + & 0.136081427545033600E+0_R8, 0.753020101897661800E+0_R8/ + DATA + & YDATA(33,1,2), XDATA(33,1,2), XDATA(33,2,2) + & /0.560111053917143100E+1_R8, + & 0.145367053019870600E+0_R8, 0.611153532003093100E+0_R8/ + DATA + & YDATA(34,1,2), XDATA(34,1,2), XDATA(34,2,2) + & /0.128152376174926800E+2_R8, + & 0.308221919576435500E+0_R8, 0.455217283290423900E+0_R8/ + DATA + & YDATA(35,1,2), XDATA(35,1,2), XDATA(35,2,2) + & /-0.498709177732467200E+2_R8, + & 0.432658769133528300E+0_R8, 0.678607663414113000E+0_R8/ + DATA + & YDATA(36,1,2), XDATA(36,1,2), XDATA(36,2,2) + & /-0.815797696908314300E+1_R8, + & 0.477785501079980300E+0_R8, 0.536178207572157000E+0_R8/ + DATA + & YDATA(37,1,2), XDATA(37,1,2), XDATA(37,2,2) + & /-0.440240491195158600E+1_R8, + & 0.727986827616619000E+0_R8, 0.668497920573493900E+0_R8/ + DATA + & YDATA(38,1,2), XDATA(38,1,2), XDATA(38,2,2) + & /-0.276723957061767500E+1_R8, + & 0.745950385588265100E+0_R8, 0.786077589007263700E+0_R8/ + DATA + & YDATA(39,1,2), XDATA(39,1,2), XDATA(39,2,2) + & /-0.223203667288734800E+1_R8, + & 0.732537503527113500E+0_R8, 0.582625164046828400E+0_R8/ + DATA + & YDATA(40,1,2), XDATA(40,1,2), XDATA(40,2,2) + & /-0.169728270310622000E+1_R8, + & 0.967352361433846300E+0_R8, 0.460779396016832800E+0_R8/ + DATA + & YDATA(41,1,2), XDATA(41,1,2), XDATA(41,2,2) + & /0.551015652153227000E+1_R8, + & 0.129761784310891100E-1_R8, 0.700009537931860000E+0_R8/ + DATA + & YDATA(42,1,2), XDATA(42,1,2), XDATA(42,2,2) + & /0.128036180496215800E+2_R8, + & 0.170163243950629700E+0_R8, 0.853131830764348700E+0_R8/ + DATA + & YDATA(43,1,2), XDATA(43,1,2), XDATA(43,2,2) + & /-0.498257683396339000E+2_R8, + & 0.162768461906274000E+0_R8, 0.865315129048175000E+0_R8/ + DATA + & YDATA(44,1,2), XDATA(44,1,2), XDATA(44,2,2) + & /-0.877334550221761900E+1_R8, + & 0.222914807946165800E+0_R8, 0.797511758502094500E+0_R8/ + DATA + & YDATA(45,1,2), XDATA(45,1,2), XDATA(45,2,2) + & /-0.453820192156867600E+1_R8, + & 0.402910095604624900E+0_R8, 0.761492958727023100E+0_R8/ + DATA + & YDATA(46,1,2), XDATA(46,1,2), XDATA(46,2,2) + & /-0.297499315738677900E+1_R8, + & 0.233770812593443200E+0_R8, 0.896000095844223500E+0_R8/ + DATA + & YDATA(47,1,2), XDATA(47,1,2), XDATA(47,2,2) + & /-0.212743255978538900E+1_R8, + & 0.646528693486914700E+0_R8, 0.968574333700755700E+0_R8/ + DATA + & YDATA(48,1,2), XDATA(48,1,2), XDATA(48,2,2) + & /-0.209703205365401000E+1_R8, + & 0.802811658568969400E+0_R8, 0.904866450476711600E+0_R8/ + DATA + & YDATA(49,1,2), XDATA(49,1,2), XDATA(49,2,2) + & /-0.155287292042086200E+1_R8, + & 0.837137859891222900E+0_R8, 0.835684424990021900E+0_R8/ + DATA + & YDATA(50,1,2), XDATA(50,1,2), XDATA(50,2,2) + & /-0.161356673770480700E+1_R8, + & 0.103165980756526600E+1_R8, 0.793902191912346100E+0_R8/ + + DATA + & TDATA(3) + & /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3'/ + DATA + & NDATA(3), MDATA(3), NPDATA(3), NQDATA(3) + & /44, 1, 9, 1/ + DATA + & (BDATA(K,3),K=1,9) + & /0.281887509408440189E-5_R8, + & -0.231290549212363845E-2_R8, 0.583035555572801965E+1_R8, + & 0.000000000000000000E+0_R8, 0.406910776203121026E+8_R8, + & 0.138001105225000000E-2_R8, 0.596038513209999999E-1_R8, + & 0.670582099359999998E+1_R8, 0.106994410000000000E+10_R8/ + DATA + & YDATA( 1,1,3), XDATA( 1,1,3) + & /0.988227696721327788E+0_R8, 0.25E-8_R8/ + DATA + & YDATA( 2,1,3), XDATA( 2,1,3) + & /0.988268083998559958E+0_R8, 0.64E-8_R8/ + DATA + & YDATA( 3,1,3), XDATA( 3,1,3) + & /0.988341022958438831E+0_R8, 1.0E-8_R8/ + DATA + & YDATA( 4,1,3), XDATA( 4,1,3) + & /0.988380557606306446E+0_R8, 0.9E-7_R8/ + DATA + & YDATA( 5,1,3), XDATA( 5,1,3) + & /0.988275062411751338E+0_R8, 1.0E-6_R8/ + DATA + & YDATA( 6,1,3), XDATA( 6,1,3) + & /0.988326680176446987E+0_R8, 0.4E-5_R8/ + DATA + & YDATA( 7,1,3), XDATA( 7,1,3) + & /0.988306058860433439E+0_R8, 0.9E-5_R8/ + DATA + & YDATA( 8,1,3), XDATA( 8,1,3) + & /0.988292880079125555E+0_R8, 0.16E-4_R8/ + DATA + & YDATA( 9,1,3), XDATA( 9,1,3) + & /0.988305279259496905E+0_R8, 0.36E-4_R8/ + DATA + & YDATA(10,1,3), XDATA(10,1,3) + & /0.988278142019574202E+0_R8, 0.64E-4_R8/ + DATA + & YDATA(11,1,3), XDATA(11,1,3) + & /0.988224953369819946E+0_R8, 1.0E-4_R8/ + DATA + & YDATA(12,1,3), XDATA(12,1,3) + & /0.988111989169778223E+0_R8, 0.144E-3_R8/ + DATA + & YDATA(13,1,3), XDATA(13,1,3) + & /0.988045627103840613E+0_R8, 0.225E-3_R8/ + DATA + & YDATA(14,1,3), XDATA(14,1,3) + & /0.987913715667047655E+0_R8, 0.400E-3_R8/ + DATA + & YDATA(15,1,3), XDATA(15,1,3) + & /0.987841994238525678E+0_R8, 0.625E-3_R8/ + DATA + & YDATA(16,1,3), XDATA(16,1,3) + & /0.987638450432434270E+0_R8, 0.900E-3_R8/ + DATA + & YDATA(17,1,3), XDATA(17,1,3) + & /0.987587364331771395E+0_R8, 0.1225E-2_R8/ + DATA + & YDATA(18,1,3), XDATA(18,1,3) + & /0.987576264149633684E+0_R8, 0.1600E-2_R8/ + DATA + & YDATA(19,1,3), XDATA(19,1,3) + & /0.987539209110983643E+0_R8, 0.2025E-2_R8/ + DATA + & YDATA(20,1,3), XDATA(20,1,3) + & /0.987621143807705698E+0_R8, 0.25E-2_R8/ + DATA + & YDATA(21,1,3), XDATA(21,1,3) + & /0.988023229785526217E+0_R8, 0.36E-2_R8/ + DATA + & YDATA(22,1,3), XDATA(22,1,3) + & /0.988558376710994197E+0_R8, 0.49E-2_R8/ + DATA + & YDATA(23,1,3), XDATA(23,1,3) + & /0.989304775352439885E+0_R8, 0.64E-2_R8/ + DATA + & YDATA(24,1,3), XDATA(24,1,3) + & /0.990210452265710472E+0_R8, 0.81E-2_R8/ + DATA + & YDATA(25,1,3), XDATA(25,1,3) + & /0.991095950592263900E+0_R8, 1.00E-2_R8/ + DATA + & YDATA(26,1,3), XDATA(26,1,3) + & /0.991475677297119272E+0_R8, 0.11025E-1_R8/ + DATA + & YDATA(27,1,3), XDATA(27,1,3) + & /0.991901306250746771E+0_R8, 0.12100E-1_R8/ + DATA + & YDATA(28,1,3), XDATA(28,1,3) + & /0.992619222425303263E+0_R8, 0.14400E-1_R8/ + DATA + & YDATA(29,1,3), XDATA(29,1,3) + & /0.993617037631973475E+0_R8, 0.16900E-1_R8/ + DATA + & YDATA(30,1,3), XDATA(30,1,3) + & /0.994727321698030676E+0_R8, 0.19600E-1_R8/ + DATA + & YDATA(31,1,3), XDATA(31,1,3) + & /0.996523114720326189E+0_R8, 0.25600E-1_R8/ + DATA + & YDATA(32,1,3), XDATA(32,1,3) + & /0.998036909563764020E+0_R8, 0.32400E-1_R8/ + DATA + & YDATA(33,1,3), XDATA(33,1,3) + & /0.999151968626971372E+0_R8, 0.40000E-1_R8/ + DATA + & YDATA(34,1,3), XDATA(34,1,3) + & /0.100017083706131769E+1_R8, 0.50625E-1_R8/ + DATA + & YDATA(35,1,3), XDATA(35,1,3) + & /0.100110046382923523E+1_R8, 0.75625E-1_R8/ + DATA + & YDATA(36,1,3), XDATA(36,1,3) + & /0.100059103180404652E+1_R8, 0.12250E+0_R8/ + DATA + & YDATA(37,1,3), XDATA(37,1,3) + & /0.999211829791257561E+0_R8, 0.16000E+0_R8/ + DATA + & YDATA(38,1,3), XDATA(38,1,3) + & /0.994711451526761862E+0_R8, 0.25000E+0_R8/ + DATA + & YDATA(39,1,3), XDATA(39,1,3) + & /0.989844132928847109E+0_R8, 0.33640E+0_R8/ + DATA + & YDATA(40,1,3), XDATA(40,1,3) + & /0.987234104554490439E+0_R8, 0.38440E+0_R8/ + DATA + & YDATA(41,1,3), XDATA(41,1,3) + & /0.980928240178404887E+0_R8, 0.49E+0_R8/ + DATA + & YDATA(42,1,3), XDATA(42,1,3) + & /0.970888680366055576E+0_R8, 0.64E+0_R8/ + DATA + & YDATA(43,1,3), XDATA(43,1,3) + & /0.960043769857327398E+0_R8, 0.81E+0_R8/ + DATA + & YDATA(44,1,3), XDATA(44,1,3) + & /0.947277159259551068E+0_R8, 1.00E+0_R8/ + + DATA + & TDATA(4) + & /' HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188'/ + DATA + & NDATA(4), MDATA(4), NPDATA(4), NQDATA(4) + & /13, 2, 3, 1/ + DATA + & (BDATA(K,4),K=1,3) + & /3.0E+0_R8, 3.0E+0_R8, -0.5E+0_R8/ + DATA + & YDATA( 1,1,4), XDATA( 1,1,4), XDATA( 1,2,4) + & /2.93E+0_R8, 0.0E+0_R8, 0.0E+0_R8/ + DATA + & YDATA( 2,1,4), XDATA( 2,1,4), XDATA( 2,2,4) + & /1.95E+0_R8, 0.0E+0_R8, 1.0E+0_R8/ + DATA + & YDATA( 3,1,4), XDATA( 3,1,4), XDATA( 3,2,4) + & /0.81E+0_R8, 0.0E+0_R8, 2.0E+0_R8/ + DATA + & YDATA( 4,1,4), XDATA( 4,1,4), XDATA( 4,2,4) + & /0.58E+0_R8, 0.0E+0_R8, 3.0E+0_R8/ + DATA + & YDATA( 5,1,4), XDATA( 5,1,4), XDATA( 5,2,4) + & /5.90E+0_R8, 1.0E+0_R8, 0.0E+0_R8/ + DATA + & YDATA( 6,1,4), XDATA( 6,1,4), XDATA( 6,2,4) + & /4.74E+0_R8, 1.0E+0_R8, 1.0E+0_R8/ + DATA + & YDATA( 7,1,4), XDATA( 7,1,4), XDATA( 7,2,4) + & /4.18E+0_R8, 1.0E+0_R8, 2.0E+0_R8/ + DATA + & YDATA( 8,1,4), XDATA( 8,1,4), XDATA( 8,2,4) + & /4.05E+0_R8, 1.0E+0_R8, 2.0E+0_R8/ + DATA + & YDATA( 9,1,4), XDATA( 9,1,4), XDATA( 9,2,4) + & /9.03E+0_R8, 2.0E+0_R8, 0.0E+0_R8/ + DATA + & YDATA(10,1,4), XDATA(10,1,4), XDATA(10,2,4) + & /7.85E+0_R8, 2.0E+0_R8, 1.0E+0_R8/ + DATA + & YDATA(11,1,4), XDATA(11,1,4), XDATA(11,2,4) + & /7.22E+0_R8, 2.0E+0_R8, 2.0E+0_R8/ + DATA + & YDATA(12,1,4), XDATA(12,1,4), XDATA(12,2,4) + & /8.50E+0_R8, 2.5E+0_R8, 2.0E+0_R8/ + DATA + & YDATA(13,1,4), XDATA(13,1,4), XDATA(13,2,4) + & /9.81E+0_R8, 2.9E+0_R8, 1.8E+0_R8/ + + DATA + & TDATA(5) + & /' DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522'/ + DATA + & NDATA(5), MDATA(5), NPDATA(5), NQDATA(5) + & /8, 2, 2, 1/ + DATA + & (BDATA(K,5),K=1,2) + & /0.01155E+0_R8, 5000.0E+0_R8/ + DATA + & YDATA(1,1,5), XDATA(1,1,5), XDATA(1,2,5) + & /0.912E+0_R8, 109.0E+0_R8, 600.0E+0_R8/ + DATA + & YDATA(2,1,5), XDATA(2,1,5), XDATA(2,2,5) + & /0.382E+0_R8, 65.0E+0_R8, 640.0E+0_R8/ + DATA + & YDATA(3,1,5), XDATA(3,1,5), XDATA(3,2,5) + & /0.397E+0_R8, 1180.0E+0_R8, 600.0E+0_R8/ + DATA + & YDATA(4,1,5), XDATA(4,1,5), XDATA(4,2,5) + & /0.376E+0_R8, 66.0E+0_R8, 640.0E+0_R8/ + DATA + & YDATA(5,1,5), XDATA(5,1,5), XDATA(5,2,5) + & /0.342E+0_R8, 1270.0E+0_R8, 600.0E+0_R8/ + DATA + & YDATA(6,1,5), XDATA(6,1,5), XDATA(6,2,5) + & /0.358E+0_R8, 69.0E+0_R8, 640.0E+0_R8/ + DATA + & YDATA(7,1,5), XDATA(7,1,5), XDATA(7,2,5) + & /0.348E+0_R8, 1230.0E+0_R8, 600.0E+0_R8/ + DATA + & YDATA(8,1,5), XDATA(8,1,5), XDATA(8,2,5) + & /0.376E+0_R8, 68.0E+0_R8, 640.0E+0_R8/ + + DATA + & TDATA(6) + & /' POWELL AND MACDONALD, 1972, TABLES 7 AND 8, PAGES 153-154'/ + DATA + & NDATA(6), MDATA(6), NPDATA(6), NQDATA(6) + & /14, 1, 3, 1/ + DATA + & (BDATA(K,6),K=1,3) + & /25.0E+0_R8, 30.0E+0_R8, 6.0E+0_R8/ + DATA + & YDATA( 1,1,6), XDATA( 1,1,6) + & /26.38E+0_R8, 1.0E+0_R8/ + DATA + & YDATA( 2,1,6), XDATA( 2,1,6) + & /25.79E+0_R8, 2.0E+0_R8/ + DATA + & YDATA( 3,1,6), XDATA( 3,1,6) + & /25.29E+0_R8, 3.0E+0_R8/ + DATA + & YDATA( 4,1,6), XDATA( 4,1,6) + & /24.86E+0_R8, 4.0E+0_R8/ + DATA + & YDATA( 5,1,6), XDATA( 5,1,6) + & /24.46E+0_R8, 5.0E+0_R8/ + DATA + & YDATA( 6,1,6), XDATA( 6,1,6) + & /24.10E+0_R8, 6.0E+0_R8/ + DATA + & YDATA( 7,1,6), XDATA( 7,1,6) + & /23.78E+0_R8, 7.0E+0_R8/ + DATA + & YDATA( 8,1,6), XDATA( 8,1,6) + & /23.50E+0_R8, 8.0E+0_R8/ + DATA + & YDATA( 9,1,6), XDATA( 9,1,6) + & /23.24E+0_R8, 9.0E+0_R8/ + DATA + & YDATA(10,1,6), XDATA(10,1,6) + & /23.00E+0_R8, 10.0E+0_R8/ + DATA + & YDATA(11,1,6), XDATA(11,1,6) + & /22.78E+0_R8, 11.0E+0_R8/ + DATA + & YDATA(12,1,6), XDATA(12,1,6) + & /22.58E+0_R8, 12.0E+0_R8/ + DATA + & YDATA(13,1,6), XDATA(13,1,6) + & /22.39E+0_R8, 13.0E+0_R8/ + DATA + & YDATA(14,1,6), XDATA(14,1,6) + & /22.22E+0_R8, 14.0E+0_R8/ + + DATA + & TDATA(7) + & /' FULLER, 1987, TABLE 3.2.10, PAGES 244-245'/ + DATA + & NDATA(7), MDATA(7), NPDATA(7), NQDATA(7) + & /20, 2, 5, 1/ + DATA + & (BDATA(K,7),K=1,5) + & /-1.0E+0_R8, -3.0E+0_R8, 0.09E+0_R8, 0.02E+0_R8, 0.08E+0_R8/ + DATA + & YDATA( 1,1,7), XDATA( 1,1,7), XDATA( 1,2,7) + & /0.0E+0_R8, 0.50E+0_R8, -0.12E+0_R8/ + DATA + & YDATA( 2,1,7), XDATA( 2,1,7), XDATA( 2,2,7) + & /0.0E+0_R8, 1.20E+0_R8, -0.60E+0_R8/ + DATA + & YDATA( 3,1,7), XDATA( 3,1,7), XDATA( 3,2,7) + & /0.0E+0_R8, 1.60E+0_R8, -1.00E+0_R8/ + DATA + & YDATA( 4,1,7), XDATA( 4,1,7), XDATA( 4,2,7) + & /0.0E+0_R8, 1.86E+0_R8, -1.40E+0_R8/ + DATA + & YDATA( 5,1,7), XDATA( 5,1,7), XDATA( 5,2,7) + & /0.0E+0_R8, 2.12E+0_R8, -2.54E+0_R8/ + DATA + & YDATA( 6,1,7), XDATA( 6,1,7), XDATA( 6,2,7) + & /0.0E+0_R8, 2.36E+0_R8, -3.36E+0_R8/ + DATA + & YDATA( 7,1,7), XDATA( 7,1,7), XDATA( 7,2,7) + & /0.0E+0_R8, 2.44E+0_R8, -4.00E+0_R8/ + DATA + & YDATA( 8,1,7), XDATA( 8,1,7), XDATA( 8,2,7) + & /0.0E+0_R8, 2.36E+0_R8, -4.75E+0_R8/ + DATA + & YDATA( 9,1,7), XDATA( 9,1,7), XDATA( 9,2,7) + & /0.0E+0_R8, 2.06E+0_R8, -5.25E+0_R8/ + DATA + & YDATA(10,1,7), XDATA(10,1,7), XDATA(10,2,7) + & /0.0E+0_R8, 1.74E+0_R8, -5.64E+0_R8/ + DATA + & YDATA(11,1,7), XDATA(11,1,7), XDATA(11,2,7) + & /0.0E+0_R8, 1.34E+0_R8, -5.97E+0_R8/ + DATA + & YDATA(12,1,7), XDATA(12,1,7), XDATA(12,2,7) + & /0.0E+0_R8, 0.90E+0_R8, -6.32E+0_R8/ + DATA + & YDATA(13,1,7), XDATA(13,1,7), XDATA(13,2,7) + & /0.0E+0_R8, -0.28E+0_R8, -6.44E+0_R8/ + DATA + & YDATA(14,1,7), XDATA(14,1,7), XDATA(14,2,7) + & /0.0E+0_R8, -0.78E+0_R8, -6.44E+0_R8/ + DATA + & YDATA(15,1,7), XDATA(15,1,7), XDATA(15,2,7) + & /0.0E+0_R8, -1.36E+0_R8, -6.41E+0_R8/ + DATA + & YDATA(16,1,7), XDATA(16,1,7), XDATA(16,2,7) + & /0.0E+0_R8, -1.90E+0_R8, -6.25E+0_R8/ + DATA + & YDATA(17,1,7), XDATA(17,1,7), XDATA(17,2,7) + & /0.0E+0_R8, -2.50E+0_R8, -5.88E+0_R8/ + DATA + & YDATA(18,1,7), XDATA(18,1,7), XDATA(18,2,7) + & /0.0E+0_R8, -2.88E+0_R8, -5.50E+0_R8/ + DATA + & YDATA(19,1,7), XDATA(19,1,7), XDATA(19,2,7) + & /0.0E+0_R8, -3.18E+0_R8, -5.24E+0_R8/ + DATA + & YDATA(20,1,7), XDATA(20,1,7), XDATA(20,2,7) + & /0.0E+0_R8, -3.44E+0_R8, -4.86E+0_R8/ + + DATA + & TDATA(8) + & /' BATES AND WATTS, 1988, TABLE A1.13, PAGES 280-281'/ + DATA + & NDATA(8), MDATA(8), NPDATA(8), NQDATA(8) + & /23, 1, 5, 2/ + DATA + & (BDATA(K,8),K=1,5) + & /4.0E+0_R8, 2.0E+0_R8, 7.0E+0_R8, 0.40E+0_R8, 0.50E+0_R8/ + DATA + & YDATA( 1,1,8), YDATA( 1,2,8), XDATA( 1,1,8) + & /4.220E+0_R8, 0.136E+0_R8, 30.0E+0_R8/ + DATA + & YDATA( 2,1,8), YDATA( 2,2,8), XDATA( 2,1,8) + & /4.167E+0_R8, 0.167E+0_R8, 50.0E+0_R8/ + DATA + & YDATA( 3,1,8), YDATA( 3,2,8), XDATA( 3,1,8) + & /4.132E+0_R8, 0.188E+0_R8, 70.0E+0_R8/ + DATA + & YDATA( 4,1,8), YDATA( 4,2,8), XDATA( 4,1,8) + & /4.038E+0_R8, 0.212E+0_R8, 100.0E+0_R8/ + DATA + & YDATA( 5,1,8), YDATA( 5,2,8), XDATA( 5,1,8) + & /4.019E+0_R8, 0.236E+0_R8, 150.0E+0_R8/ + DATA + & YDATA( 6,1,8), YDATA( 6,2,8), XDATA( 6,1,8) + & /3.956E+0_R8, 0.257E+0_R8, 200.0E+0_R8/ + DATA + & YDATA( 7,1,8), YDATA( 7,2,8), XDATA( 7,1,8) + & /3.884E+0_R8, 0.276E+0_R8, 300.0E+0_R8/ + DATA + & YDATA( 8,1,8), YDATA( 8,2,8), XDATA( 8,1,8) + & /3.784E+0_R8, 0.297E+0_R8, 500.0E+0_R8/ + DATA + & YDATA( 9,1,8), YDATA( 9,2,8), XDATA( 9,1,8) + & /3.713E+0_R8, 0.309E+0_R8, 700.0E+0_R8/ + DATA + & YDATA(10,1,8), YDATA(10,2,8), XDATA(10,1,8) + & /3.633E+0_R8, 0.311E+0_R8, 1000.0E+0_R8/ + DATA + & YDATA(11,1,8), YDATA(11,2,8), XDATA(11,1,8) + & /3.540E+0_R8, 0.314E+0_R8, 1500.0E+0_R8/ + DATA + & YDATA(12,1,8), YDATA(12,2,8), XDATA(12,1,8) + & /3.433E+0_R8, 0.311E+0_R8, 2000.0E+0_R8/ + DATA + & YDATA(13,1,8), YDATA(13,2,8), XDATA(13,1,8) + & /3.358E+0_R8, 0.305E+0_R8, 3000.0E+0_R8/ + DATA + & YDATA(14,1,8), YDATA(14,2,8), XDATA(14,1,8) + & /3.258E+0_R8, 0.289E+0_R8, 5000.0E+0_R8/ + DATA + & YDATA(15,1,8), YDATA(15,2,8), XDATA(15,1,8) + & /3.193E+0_R8, 0.277E+0_R8, 7000.0E+0_R8/ + DATA + & YDATA(16,1,8), YDATA(16,2,8), XDATA(16,1,8) + & /3.128E+0_R8, 0.255E+0_R8, 10000.0E+0_R8/ + DATA + & YDATA(17,1,8), YDATA(17,2,8), XDATA(17,1,8) + & /3.059E+0_R8, 0.240E+0_R8, 15000.0E+0_R8/ + DATA + & YDATA(18,1,8), YDATA(18,2,8), XDATA(18,1,8) + & /2.984E+0_R8, 0.218E+0_R8, 20000.0E+0_R8/ + DATA + & YDATA(19,1,8), YDATA(19,2,8), XDATA(19,1,8) + & /2.934E+0_R8, 0.202E+0_R8, 30000.0E+0_R8/ + DATA + & YDATA(20,1,8), YDATA(20,2,8), XDATA(20,1,8) + & /2.876E+0_R8, 0.182E+0_R8, 50000.0E+0_R8/ + DATA + & YDATA(21,1,8), YDATA(21,2,8), XDATA(21,1,8) + & /2.838E+0_R8, 0.168E+0_R8, 70000.0E+0_R8/ + DATA + & YDATA(22,1,8), YDATA(22,2,8), XDATA(22,1,8) + & /2.798E+0_R8, 0.153E+0_R8, 100000.0E+0_R8/ + DATA + & YDATA(23,1,8), YDATA(23,2,8), XDATA(23,1,8) + & /2.759E+0_R8, 0.139E+0_R8, 150000.0E+0_R8/ + + DATA + & TDATA(9) + & /' ZWOLAK, WATSON, AND TYSON, 2004.'/ + DATA + & NDATA(9), MDATA(9), NPDATA(9), NQDATA(9) + & /4, 1, 2, 1/ + DATA + & (BDATA(K,9),K=1,2) + & /200.0_R8, 5.0_R8/ + DATA + & YDATA( 1,1,9), XDATA( 1,1,9) + & /2.718281828459045_R8, 1.0_R8/ + DATA + & YDATA( 2,1,9), XDATA( 2,1,9) + & /7.389056098930650_R8, 2.0_R8/ + DATA + & YDATA( 3,1,9), XDATA( 3,1,9) + & /148.4131591025766_R8, 5.0_R8/ + DATA + & YDATA( 4,1,9), XDATA( 4,1,9) + & /403.4287934927353_R8, 6.0_R8/ + + DATA + & TDATA(10) + & /' ZWOLAK, WATSON, AND TYSON, 2005.'/ + DATA + & NDATA(10), MDATA(10), NPDATA(10), NQDATA(10) + & /4, 1, 2, 1/ + DATA + & (BDATA(K,10),K=1,2) + & /200.0_R8, 5.0_R8/ + DATA + & YDATA( 1,1,10), XDATA( 1,1,10) + & /2.718281828459045_R8, 1.0_R8/ + DATA + & YDATA( 2,1,10), XDATA( 2,1,10) + & /7.389056098930650_R8, 2.0_R8/ + DATA + & YDATA( 3,1,10), XDATA( 3,1,10) + & /148.4131591025766_R8, 5.0_R8/ + DATA + & YDATA( 4,1,10), XDATA( 4,1,10) + & /403.4287934927353_R8, 6.0_R8/ + +C...Variable definitions (alphabetically) +C BDATA: The function parameter for each data set. +C BETA: The function parameters. +C I: An indexing variable. +C J: An indexing variable. +C L: An indexing variable. +C LDX: The leading dimension of array X. +C M: The number of columns of data in the explanatory variable. +C MDATA: The number of columns of data in the explanatory variable +C in each data set. +C N: The number of observations. +C NDATA: The number of observations per data set. +C NP: The number of function parameters. +C NPDATA: The number of function parameters in each data set. +C NQDATA: The number of responses per observation in each data set. +C SETNO: The number of the data set being analyzed. +C TDATA: The reference for the each of the data sets. +C TITLE: The reference for the data set being analyzed. +C X: The explanatory variables. +C XDATA: The explanatory variables for each data set. +C Y: The response variable. +C YDATA: The response variables for each data set. + + +C***First executable statement DODRXD + + + TITLE = TDATA(SETNO) + + N = NDATA(SETNO) + M = MDATA(SETNO) + NP = NPDATA(SETNO) + NQ = NQDATA(SETNO) + + DO 20 L=1,NQ + DO 10 I=1,N + Y(I,L) = YDATA(I,L,SETNO) + 10 CONTINUE + 20 CONTINUE + + DO 40 J=1,M + DO 30 I=1,N + X(I,J) = XDATA(I,J,SETNO) + 30 CONTINUE + 40 CONTINUE + + DO 50 K=1,NP + BETA(K) = BDATA(K,SETNO) + 50 CONTINUE + + RETURN + + END +*DODRXF + SUBROUTINE DODRXF + & (N,M,NP,NQ, + & LDN,LDM,LDNP, + & BETA,XPLUSD, + & IFIXB,IFIXX,LDIFX, + & IDEVAL,F,FJACB,FJACD, + & ISTOP) +C***Begin Prologue DODRXF +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 860529 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute jacobian matricies for ODRPACK95 exerciser +C***End Prologue DODRXF + +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...Scalar parameters + INTEGER, PARAMETER :: MAXNP=10 + +C...Scalars in common + INTEGER + & SETNO + +C...Arrays in common + REAL (KIND=R8) + & LOWER(MAXNP),UPPER(MAXNP) + +C...Local scalars + REAL (KIND=R8) + & CTHETA,FAC1,FAC2,FAC3,FAC4,FREQ, + & OMEGA,ONE,PHI,PI,R,STHETA,THETA,ZERO + INTEGER + & I,J,K + +C...Intrinsic functions + INTRINSIC + & ATAN2,COS,EXP,SIN,SQRT + +C...Common blocks + COMMON /SETID/SETNO + COMMON /BOUNDS/ LOWER,UPPER + +C...Data statements + DATA + & ZERO,ONE + & /0.0E0_R8,1.0E0_R8/ + +C...Variable definitions (alphabetically) +C BETA: Current values of parameters +C F: Predicted function values +C FAC1: A factors or terms used in computing the jacobians. +C FAC2: A factors or terms used in computing the jacobians. +C FAC3: A factors or terms used in computing the jacobians. +C FAC4: A factors or terms used in computing the jacobians. +C FJACB: Jacobian with respect to BETA +C FJACD: Jacobian with respect to errors DELTA +C IDEVAL: Indicator for selecting computation to be performed +C IFIXB: Indicators for "fixing" parameters (BETA) +C IFIXX: Indicators for "fixing" explanatory variable (X) +C LDIFX: Leading dimension of array IFIXX +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 +C values closer to most recently used values +C -1 means current BETA and X+DELTA are +C not acceptable; ODRPACK95 should stop +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 M: The number of columns of data in the explanatory variable. +C N: The number of observations. +C NP: The number of function parameters. +C NQ: The number of responses per observation. +C ONE: The value 1.0E0_R8. +C SETNO: The number of the data set being analyzed. +C XPLUSD: Current value of explanatory variable, i.e., X + DELTA +C ZERO: The value 0.0E0_R8. + + +C***First executable statement DODRXF + + +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 BETA outside bounds. Return with error if BETA outside bounds. + + IF (ANY(LOWER(1:NP).GT.BETA(1:NP))) THEN + ISTOP = -1 + RETURN + END IF + + IF (ANY(UPPER(1:NP).LT.BETA(1:NP))) THEN + ISTOP = -2 + RETURN + END IF + + + IF (SETNO.EQ.1) THEN + +C Setno. 1: Boggs, Byrd and Schnabel, 1985, example 1 + + IF (BETA(1).LE.1.01E0_R8) THEN + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + DO 100 I=1,N + F(I,1) = BETA(1)/(XPLUSD(I,1)-BETA(2)) + 100 CONTINUE + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + DO 110 I=1,N + FJACB(I,1,1) = ONE/(XPLUSD(I,1)-BETA(2)) + FJACB(I,2,1) = BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) + 110 CONTINUE + END IF + + IF (MOD(IDEVAL/100,10).NE.0) THEN + DO 120 I=1,N + FJACD(I,1,1) = -BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) + 120 CONTINUE + END IF + + ELSE + ISTOP = 1 + END IF + + ELSE IF (SETNO.EQ.2) THEN + +C Setno. 2: Boggs, Byrd and Schnabel, 1985, example 2 + + ISTOP = 0 + + DO 200 I=1,N + FAC1 = (BETA(2)*XPLUSD(I,1)+BETA(3)*XPLUSD(I,2)-ONE) + + IF (MOD(IDEVAL,10).NE.0) THEN + F(I,1) = BETA(1)/FAC1 + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + FJACB(I,1,1) = ONE/FAC1 + FJACB(I,2,1) = -BETA(1)*(FAC1**(-2))*XPLUSD(I,1) + FJACB(I,3,1) = -BETA(1)*(FAC1**(-2))*XPLUSD(I,2) + END IF + + IF (MOD(IDEVAL/100,10).NE.0) THEN + FJACD(I,1,1) = -BETA(1)*(FAC1**(-2))*BETA(2) + FJACD(I,2,1) = -BETA(1)*(FAC1**(-2))*BETA(3) + END IF + 200 CONTINUE + + ELSE IF (SETNO.EQ.3) THEN + +C Setno. 3: Boggs, Byrd and Schnabel, 1985, example 3 + + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + DO 310 I=1,N + F(I,1) = ZERO + DO 300 J=1,4 + F(I,1) = F(I,1) + BETA(J)/(XPLUSD(I,1)+BETA(J+5)) + 300 CONTINUE + F(I,1) = F(I,1) + BETA(5) + 310 CONTINUE + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + DO 330 I=1,N + FJACB(I,5,1) = ONE + DO 320 K=1,4 + FJACB(I,K,1) = ONE/(XPLUSD(I,1)+BETA(K+5)) + FJACB(I,K+5,1) = -BETA(K)* + & (XPLUSD(I,1)+BETA(K+5))**(-2) + 320 CONTINUE + 330 CONTINUE + END IF + + IF (MOD(IDEVAL/100,10).NE.0) THEN + DO 350 I=1,N + FJACD(I,1,1) = ZERO + DO 340 K=4,1,-1 + FJACD(I,1,1) = FJACD(I,1,1) - + & BETA(K)*(XPLUSD(I,1)+BETA(K+5))**(-2) + 340 CONTINUE + 350 CONTINUE + END IF + + ELSE IF (SETNO.EQ.4) THEN + +C Setno. 4: Himmelblau, 1970, example 6.2-4, page 188 + + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + DO 400 I = 1, N + F(I,1) = BETA(1)*XPLUSD(I,1) + + & BETA(2)*EXP(BETA(3)*XPLUSD(I,2)) + 400 CONTINUE + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + DO 410 I=1,N + FJACB(I,1,1) = XPLUSD(I,1) + FJACB(I,2,1) = EXP(BETA(3)*XPLUSD(I,2)) + FJACB(I,3,1) = BETA(2)* + & EXP(BETA(3)*XPLUSD(I,2))*XPLUSD(I,2) + 410 CONTINUE + END IF + + IF (MOD(IDEVAL/100,10).NE.0) THEN + DO 420 I=1,N + FJACD(I,1,1) = BETA(1) + FJACD(I,2,1) = BETA(2)*EXP(BETA(3)*XPLUSD(I,2))*BETA(3) + 420 CONTINUE + END IF + + ELSE IF (SETNO.EQ.5) THEN + +C Setno. 5: Draper and Smith, 1981, exercise i, page 521-522 + + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + DO 500 I=1,N + F(I,1) = EXP(-BETA(1)*XPLUSD(I,1)* + & EXP(-BETA(2)*(ONE/XPLUSD(I,2) - ONE/620.0E0_R8))) + 500 CONTINUE + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + DO 510 I=1,N + FAC1 = ONE/XPLUSD(I,2) - ONE/620.0E0_R8 + FAC2 = EXP(-BETA(2)*FAC1) + FAC3 = BETA(1)*XPLUSD(I,1) + FAC4 = EXP(-FAC3*FAC2) + + FJACB(I,1,1) = -FAC4*XPLUSD(I,1)*FAC2 + FJACB(I,2,1) = FAC4*FAC3*FAC2*FAC1 + + IF (MOD(IDEVAL/100,10).NE.0) THEN + FJACD(I,1,1) = -FAC4*BETA(1)*FAC2 + FJACD(I,2,1) = -FAC4*FAC3*FAC2* + & BETA(2)/XPLUSD(I,2)**2 + END IF + 510 CONTINUE + END IF + + ELSE IF (SETNO.EQ.6) THEN + +C Setno. 6: Powell and Macdonald, 1972, tables 7 and 8, page 153-154 +C N.B. this derivative is intentionally coded incorrectly + + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + DO 600 I=1,N + F(I,1) = BETA(1)* + & (ONE+BETA(3)*XPLUSD(I,1)/BETA(2))**(-ONE/BETA(3)) + 600 CONTINUE + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + DO 610 I=1,N + FJACB(I,1,1) = ZERO + FJACB(I,2,1) = ZERO + FJACB(I,3,1) = ZERO + + IF (MOD(IDEVAL/100,10).NE.0) THEN + FJACD(I,1,1) = XPLUSD(I,1) + END IF + 610 CONTINUE + END IF + + ELSE IF (SETNO.EQ.7) THEN + +C Setno. 7: Fuller, 1987, table 3.2.10, pages 244-245 +C N.B. this derivative is intentionally coded incorrectly + + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + DO 700 I=1,N + F(I,1) = 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 + 700 CONTINUE + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + DO 710 I=1,N + FJACB(I,1,1) = ZERO + FJACB(I,2,1) = ZERO + FJACB(I,3,1) = ZERO + FJACB(I,4,1) = ZERO + FJACB(I,5,1) = ZERO + + IF (MOD(IDEVAL/100,10).NE.0) THEN + FJACD(I,1,1) = ZERO + FJACD(I,2,1) = ZERO + END IF + 710 CONTINUE + END IF + + ELSE IF (SETNO.EQ.8) THEN + +C Setno. 8: Bates and Watts, 1988, table A1.13, pages 280-281 +C N.B. This derivative is intentionally coded incorrectly + + DO 800 I=1,N + IF (XPLUSD(I,1).LT.0.0E0_R8) THEN + ISTOP = 1 + RETURN + END IF + 800 CONTINUE + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + PI = 3.141592653589793238462643383279E0_R8 + THETA = PI*BETA(4)*0.5E0_R8 + CTHETA = COS(THETA) + STHETA = SIN(THETA) + DO 810 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) + 810 CONTINUE + END IF + + IF (MOD(IDEVAL/10,10).NE.0) THEN + DO 820 I=1,N + FJACB(I,1,1) = ZERO + FJACB(I,2,1) = ZERO + FJACB(I,3,1) = ZERO + FJACB(I,4,1) = ZERO + FJACB(I,5,1) = ZERO + + FJACB(I,1,2) = ZERO + FJACB(I,2,2) = ZERO + FJACB(I,3,2) = ZERO + FJACB(I,4,2) = ZERO + FJACB(I,5,2) = ZERO + + IF (MOD(IDEVAL/100,10).NE.0) THEN + FJACD(I,1,1) = ZERO + FJACD(I,1,2) = ZERO + END IF + 820 CONTINUE + END IF + + ELSE IF (SETNO.EQ.9) THEN + +C Setno. 9: Zwolak, Watson, and Tyson, 2004. + + 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 + + ELSE IF (SETNO.EQ.10) THEN + +C Setno. 10: Zwolak, Watson, and Tyson, 2005. + + ISTOP = 0 + + IF (MOD(IDEVAL,10).NE.0) THEN + DO I=1,N + F(I,1) = BETA(1)/2.0_R8*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))/2.0_R8 + FJACB(I,2,1) = BETA(1)/2.0_R8*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)/2.0_R8*BETA(2)*EXP(BETA(2)* + & XPLUSD(I,1)) + END DO + END IF + + END IF + + RETURN + + END +*DODRXW + SUBROUTINE DODRXW + & (MAXN,MAXM,MAXNP,MAXNQ,LDWE,LD2WE,ISODR,LIWMIN,LWMIN) +C***Begin Prologue DODRXW +C***Refer to ODR +C***Routines Called (NONE) +C***Date Written 890205 (YYMMDD) +C***Revision Date 920619 (YYMMDD) +C***Purpose Compute minimum lengths for work vectors +C***Routines Called NONE +C***End Prologue DODRXW + +C...Used modules + USE REAL_PRECISION + +C...Scalar arguments + INTEGER + & LDWE,LD2WE,LIWMIN,LWMIN,MAXN,MAXM,MAXNP,MAXNQ + LOGICAL + & ISODR + +C...Variable definitions (alphabetically) +C ISODR: The variable designating whether the solution is by odr +C (ISODR=TRUE) or by ols (ISODR=FALSE). +C LDWE: The leading dimension of array WE. +C LD2WE: The second dimension of array WE. +C LIWMIN: The minimum length of vector IWORK for a given problem. +C LWMIN: The minimum length of vector WORK for a given problem. +C MAXM: The number of columns in the explanatory variable. +C MAXN: The number of observations. +C MAXNP: The number of function parameters. +C MAXNQ: The number of responses per observation. + + +C***First executable statement DODRXW + + + LIWMIN = 20+MAXNP+MAXNQ*(MAXNP+MAXM) + IF (ISODR) THEN + LWMIN = 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 + ELSE + LWMIN = 18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + + & 4*MAXN*MAXNQ + 2*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + + & 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ + END IF + + RETURN + END diff --git a/dataassim/math/optimization/odrpack95/tester.f b/dataassim/math/optimization/odrpack95/tester.f new file mode 100644 index 0000000..b01e1b6 --- /dev/null +++ b/dataassim/math/optimization/odrpack95/tester.f @@ -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 diff --git a/dataassim/math/optimization/odrpack_old.f b/dataassim/math/optimization/odrpack_old.f new file mode 100644 index 0000000..0f38289 --- /dev/null +++ b/dataassim/math/optimization/odrpack_old.f @@ -0,0 +1,13610 @@ +! This file contains subroutines from ODRPACK and Numerical Recipes. +! Note that machine precision is now computed within the program so +! there is no need to set machine dependent constants. +! Lianhong Gu, Oak Ridge National Laboratory + +*DMPREC + DOUBLE PRECISION FUNCTION DMPREC() + implicit none + integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp, + *maxexp + double precision eps,epsneg,xmin,xmax + +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 +C DOUBLE PRECISION +C + B +C INTEGER +C + 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) + +c DMPREC = B ** (1-TD) + + call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp, + *minexp,maxexp,eps,epsneg,xmin,xmax) + DMPREC=eps + RETURN + + END + + SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep, + *iexp,minexp,maxexp,eps,epsneg,xmin,xmax) + implicit none + INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd + double precision eps,epsneg,xmax,xmin + INTEGER i,itemp,iz,j,k,mx,nxres + double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa, + &two,y,z,zero,CONV + CONV(i)=dble(i) + one=CONV(1) + two=one+one + zero=one-one + a=one +1 continue + a=a+a + temp=a+one + temp1=temp-a + if (temp1-one.eq.zero) goto 1 + b=one +2 continue + b=b+b + temp=a+b + itemp=int(temp-a) + if (itemp.eq.0) goto 2 + ibeta=itemp + beta=CONV(ibeta) + it=0 + b=one +3 continue + it=it+1 + b=b*beta + temp=b+one + temp1=temp-b + if (temp1-one.eq.zero) goto 3 + irnd=0 + betah=beta/two + temp=a+betah + if (temp-a.ne.zero) irnd=1 + tempa=a+beta + temp=tempa+betah + if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2 + negep=it+3 + betain=one/beta + a=one + do 11 i=1, negep + a=a*betain +11 continue + b=a +4 continue + temp=one-a + if (temp-one.ne.zero) goto 5 + a=a*beta + negep=negep-1 + goto 4 +5 negep=-negep + epsneg=a + machep=-it-3 + a=b +6 continue + temp=one+a + if (temp-one.ne.zero) goto 7 + a=a*beta + machep=machep+1 + goto 6 +7 eps=a + ngrd=0 + temp=one+eps + if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1 + i=0 + k=1 + z=betain + t=one+eps + nxres=0 +8 continue + y=z + z=y*y + a=z*one + temp=z*t + if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9 + temp1=temp*betain + if (temp1*beta.eq.z) goto 9 + i=i+1 + k=k+k + goto 8 +9 if (ibeta.ne.10) then + iexp=i+1 + mx=k+k + else + iexp=2 + iz=ibeta +10 if (k.ge.iz) then + iz=iz*ibeta + iexp=iexp+1 + goto 10 + endif + mx=iz+iz-1 + endif +20 xmin=y + y=y*betain + a=y*one + temp=y*t + if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then + k=k+1 + temp1=temp*betain + if ((temp1*beta.ne.y).or.(temp.eq.y)) then + goto 20 + else + nxres=3 + xmin=y + endif + endif + minexp=-k + if ((mx.le.k+k-3).and.(ibeta.ne.10)) then + mx=mx+mx + iexp=iexp+1 + endif + maxexp=mx+minexp + irnd=irnd+nxres + if (irnd.ge.2) maxexp=maxexp-2 + i=maxexp+minexp + if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1 + if (i.gt.20) maxexp=maxexp-1 + if (a.ne.y) maxexp=maxexp-2 + xmax=one-epsneg + if (xmax*one.ne.xmax) xmax=one-beta*epsneg + xmax=xmax/(beta*beta*beta*xmin) + i=maxexp+minexp+3 + do 12 j=1,i + if (ibeta.eq.2) xmax=xmax+xmax + if (ibeta.ne.2) xmax=xmax*beta +12 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + +*DODR + SUBROUTINE 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) +C***BEGIN PROLOGUE DODR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODR + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK, + + M,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,PARTOL,SSTOL,TAUFAC,ZERO + INTEGER + + IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1) + INTEGER + + IFIXB(1),IFIXX(1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NEGONE: THE VALUE -1.0D0. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODR + + +C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES + + IFIXB(1) = -1 + IFIXX(1,1) = -1 + LDIFX = 1 + NDIGIT = -1 + TAUFAC = NEGONE + SSTOL = NEGONE + PARTOL = NEGONE + MAXIT = -1 + STPB(1) = NEGONE + STPD(1,1) = NEGONE + LDSTPD = 1 + SCLB(1) = NEGONE + SCLD(1,1) = NEGONE + LDSCLD = 1 + + SHORT = .TRUE. + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, 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) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + RETURN + + END +*DODRC + SUBROUTINE 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) +C***BEGIN PROLOGUE DODRC +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (LONG CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODRC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,ZERO + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WD1(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODRC + + SHORT = .FALSE. + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, 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) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + RETURN + + END +*DACCES + SUBROUTINE DACCES + + (N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) +C***BEGIN PROLOGUE DACCES +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DIWINF,DWINF +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS +C***END PROLOGUE DACESS + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + + RNORMS,RVAR,SSTOL,TAU,TAUFAC + INTEGER + + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, + + LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, + + NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WORK(LWORK),WSS(3) + INTEGER + + IWORK(LIWORK) + +C...LOCAL SCALARS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I, + + DELTAI,DELTNI,DELTSI,DIFFI,EPSI, + + EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, + + MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, + + NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIWINF,DWINF + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IDFI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPR1: THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORTS. +C IPR2F: THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE +C FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVT: THE PIVOT VECTOR. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT. +C LDTTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGA: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERS: THE SAVED PREDICTED RELATIVE REDUCTION IN THE +C SUM-OF-SQUARES. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORMS: THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVAR: THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES USED FOR BETA. +C SCLD: THE SCALING VALUES USED FOR DELTA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG- +C CALL (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSS: THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. +C WSSI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1). +C WSSDEI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2). +C WSSEPI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3). +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DACCES + + +C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + + IF (ACCESS) THEN + +C SET STARTING LOCATIONS FOR WORK VECTORS + + JPVT = JPVTI + OMEGA = OMEGAI + QRAUX = QRAUXI + SD = SDI + VCV = VCVI + U = UI + WRK1 = WRK1I + WRK2 = WRK2I + WRK3 = WRK3I + WRK4 = WRK4I + WRK5 = WRK5I + WRK6 = WRK6I + +C ACCESS VALUES FROM THE WORK VECTORS + + ACTRS = WORK(ACTRSI) + ALPHA = WORK(ALPHAI) + ETA = WORK(ETAI) + OLMAVG = WORK(OLMAVI) + PARTOL = WORK(PARTLI) + PNORM = WORK(PNORMI) + PRERS = WORK(PRERSI) + RCOND = WORK(RCONDI) + WSS(1) = WORK(WSSI) + WSS(2) = WORK(WSSDEI) + WSS(3) = WORK(WSSEPI) + RVAR = WORK(RVARI) + RNORMS = WORK(RNORSI) + SSTOL = WORK(SSTOLI) + TAU = WORK(TAUI) + TAUFAC = WORK(TAUFCI) + + NETA = IWORK(NETAI) + IRANK = IWORK(IRANKI) + JOB = IWORK(JOBI) + LUNRPT = IWORK(LUNRPI) + MAXIT = IWORK(MAXITI) + NFEV = IWORK(NFEVI) + NITER = IWORK(NITERI) + NJEV = IWORK(NJEVI) + NNZW = IWORK(NNZWI) + NPP = IWORK(NPPI) + IDF = IWORK(IDFI) + INT2 = IWORK(INT2I) + +C SET UP PRINT CONTROL VARIABLES + + IPRINT = IWORK(IPRINI) + + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + + ELSE + +C STORE VALUES INTO THE WORK VECTORS + + WORK(ACTRSI) = ACTRS + WORK(ALPHAI) = ALPHA + WORK(OLMAVI) = OLMAVG + WORK(PARTLI) = PARTOL + WORK(PNORMI) = PNORM + WORK(PRERSI) = PRERS + WORK(RCONDI) = RCOND + WORK(WSSI) = WSS(1) + WORK(WSSDEI) = WSS(2) + WORK(WSSEPI) = WSS(3) + WORK(RVARI) = RVAR + WORK(RNORSI) = RNORMS + WORK(SSTOLI) = SSTOL + WORK(TAUI) = TAU + + IWORK(IRANKI) = IRANK + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NITERI) = NITER + IWORK(NJEVI) = NJEV + IWORK(IDFI) = IDF + IWORK(INT2I) = INT2 + END IF + + RETURN + END +*DESUBI + SUBROUTINE DESUBI + + (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) +C***BEGIN PROLOGUE DESUBI +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE E = WD + ALPHA*TT**2 +C***END PROLOGUE DESUBI + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA + INTEGER + + LDTT,LDWD,LD2WD,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J,J1,J2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C E: THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2 +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF RESPONSES PER OBSERVATION. +C TT: THE SCALING VALUES USED FOR DELTA. +C WD: THE SQUARED DELTA WEIGHTS, D**2. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DESUBI + + +C N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE +C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS +C OF THE MULTIPLY SUBSCRIPTED ARRAYS. + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WD(1,1,1).GE.ZERO) THEN + IF (LDWD.GE.N) THEN +C THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED + + IF (LD2WD.EQ.1) THEN +C THE ARRAYS STORED IN WD ARE DIAGONAL + CALL DZERO(M,M,E,M) + DO 10 J=1,M + E(J,J) = WD(I,1,J) + 10 CONTINUE + ELSE +C THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES + DO 30 J1=1,M + DO 20 J2=1,M + E(J1,J2) = WD(I,J1,J2) + 20 CONTINUE + 30 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 110 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 110 CONTINUE + ELSE + DO 120 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 120 CONTINUE + END IF + ELSE + DO 130 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 130 CONTINUE + END IF + ELSE +C WD IS AN M BY M MATRIX + + IF (LD2WD.EQ.1) THEN +C THE ARRAY STORED IN WD IS DIAGONAL + CALL DZERO(M,M,E,M) + DO 140 J=1,M + E(J,J) = WD(1,1,J) + 140 CONTINUE + ELSE +C THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES + DO 160 J1=1,M + DO 150 J2=1,M + E(J1,J2) = WD(1,J1,J2) + 150 CONTINUE + 160 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 210 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 210 CONTINUE + ELSE + DO 220 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 220 CONTINUE + END IF + ELSE + DO 230 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 230 CONTINUE + END IF + END IF + ELSE +C WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1)) + CALL DZERO(M,M,E,M) + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 310 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 + 310 CONTINUE + ELSE + DO 320 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 + 320 CONTINUE + END IF + ELSE + DO 330 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 + 330 CONTINUE + END IF + END IF + + RETURN + END +*DETAF + SUBROUTINE DETAF + + (FCN, + + N,M,NP,NQ, + + XPLUSD,BETA,EPSMAC,NROW, + + PARTMP,PV0, + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WRK1,WRK2,WRK6,WRK7) +C***BEGIN PROLOGUE DETAF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS +C (ADAPTED FROM STARPAC SUBROUTINE ETAFUN) +C***END PROLOGUE DETAF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),PARTMP(NP),PV0(N,NQ), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO + INTEGER + + J,K,L + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10,MAX,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P1,P2,P5,ONE,TWO,HUNDRD + + /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: PARAMETERS OF THE LOCAL FIT. +C B: PARAMETERS OF THE LOCAL FIT. +C BETA: THE FUNCTION PARAMETERS. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE NOISE IN THE MODEL RESULTS. +C FAC: A FACTOR USED IN THE COMPUTATIONS. +C HUNDRD: THE VALUE 1.0D2. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C P1: THE VALUE 0.1D0. +C P2: THE VALUE 0.2D0. +C P5: THE VALUE 0.5D0. +C PARTMP: THE MODEL PARAMETERS. +C PV0: THE ORIGINAL PREDICTED VALUES. +C STP: A SMALL VALUE USED TO PERTURB THE PARAMETERS. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C WRK7: A WORK ARRAY OF (5 BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DETAF + + + STP = HUNDRD*EPSMAC + ETA = EPSMAC + + DO 40 J=-2,2 + IF (J.EQ.0) THEN + DO 10 L=1,NQ + WRK7(J,L) = PV0(NROW,L) + 10 CONTINUE + ELSE + DO 20 K=1,NP + IF (IFIXB(1).LT.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE IF (IFIXB(K).NE.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE + PARTMP(K) = BETA(K) + END IF + 20 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + PARTMP,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1,ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + WRK7(J,L) = WRK2(NROW,L) + 30 CONTINUE + END IF + 40 CONTINUE + + DO 100 L=1,NQ + A = ZERO + B = ZERO + DO 50 J=-2,2 + A = A + WRK7(J,L) + B = B + J*WRK7(J,L) + 50 CONTINUE + A = P2*A + B = P1*B + IF ((WRK7(0,L).NE.ZERO) .AND. + + (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN + FAC = ONE/ABS(WRK7(0,L)) + ELSE + FAC = ONE + END IF + DO 60 J=-2,2 + WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) + ETA = MAX(WRK7(J,L),ETA) + 60 CONTINUE + 100 CONTINUE + NETA = MAX(TWO,P5-LOG10(ETA)) + + RETURN + END +*DEVJAC + SUBROUTINE DEVJAC + + (FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN, + + STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) +C***BEGIN PROLOGUE DEVJAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DDOT_odr,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA +C***END PROLOGUE DEVJAC + +C...SCALAR ARGUMENTS + INTEGER + + INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, + + M,N,NETA,NFEV,NJEV,NP,NQ + LOGICAL + + ANAJAC,CDJAC,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), + + WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + INTEGER + + IDEVAL,J,K,K1,L + DOUBLE PRECISION + + ZERO + LOGICAL + + ERROR + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...DATA STATEMENTS + DATA ZERO + + /0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C DELTA: THE ESTIMATED VALUES OF DELTA. +C ERROR: THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO +C VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER +C THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION +C BY COMPUTING FJACD IN THE OLS CASE. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER-SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISTOP: THE VARIABLE DESIGNATING THAT THE USER WISHES THE +C COMPUTATIONS STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWE: THE LEADING DIMENSION OF ARRAYS WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LD2WE: THE SECOND DIMENSION OF ARRAYS WE AND WE1. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C WE1: THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C X: THE INDEPENDENT VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + +C***FIRST EXECUTABLE STATEMENT DEVJAC +C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA + CALL DUNPAC(NP,BETAC,BETA,IFIXB) +C COMPUTE XPLUSD = X + DELTA + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND +C THE JACOBIAN WRT DELTA (FJACD) + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + IF (ANAJAC) THEN + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV+1 + END IF +C MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO + IF (ISODR) THEN + DO 10 L=1,NQ + CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) + 10 CONTINUE + END IF + ELSE IF (CDJAC) THEN + CALL DJACCD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + ELSE + CALL DJACFD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + END IF + IF (ISTOP.LT.0) THEN + RETURN + ELSE IF (.NOT.ISODR) THEN +C TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD +C WITHIN FCN IN THE OLS CASE + ERROR = DDOT_odr(N*M,DELTA,1,DELTA,1).NE.ZERO + IF (ERROR) THEN + INFO = 50300 + RETURN + END IF + END IF +C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS + + IF (IFIXB(1).LT.0) THEN + DO 20 K=1,NP + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP) + 20 CONTINUE + ELSE + K1 = 0 + DO 30 K=1,NP + IF (IFIXB(K).GE.1) THEN + K1 = K1 + 1 + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP) + END IF + 30 CONTINUE + END IF + +C WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE + + IF (ISODR) THEN + DO 40 J=1,M + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACD(1,J,1),N*M,FJACD(1,J,1),N*M) + 40 CONTINUE + END IF + RETURN + END +*DFCTR + SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) +C***BEGIN PROLOGUE DFCTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT_odr +C***DATE WRITTEN 910706 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A +C MODIFIED CHOLESKY FACTORIZATION +C (ADAPTED FROM LINPACK SUBROUTINE DPOFA) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DFCTR + +C...SCALAR ARGUMENTS + INTEGER INFO,LDA,N + LOGICAL OKSEMI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,N) + +C...LOCAL SCALARS + DOUBLE PRECISION XI,S,T,TEN,ZERO + INTEGER J,K + +C...EXTERNAL FUNCTIONS + EXTERNAL DMPREC,DDOT_odr + DOUBLE PRECISION DMPREC,DDOT_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC SQRT + +C...DATA STATEMENTS + DATA + + ZERO,TEN + + /0.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE FACTORED. UPON RETURN, A CONTAINS THE +C UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R +C WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO +C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. +C I: AN INDEXING VARIABLE. +C INFO: AN IDICATOR VARIABLE, WHERE IF +C INFO = 0 THEN FACTORIZATION WAS COMPLETED +C INFO = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR +C OF ORDER K IS NOT POSITIVE (SEMI)DEFINITE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A. +C OKSEMI: THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE +C SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO +C BE POSITIVE DEFINITE (OKSEMI=FALSE). +C TEN: THE VALUE 10.0D0. +C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTR + + +C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS. + XI = -TEN*DMPREC() + +C COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A + DO 20 J=1,N + INFO = J + S = ZERO + DO 10 K=1,J-1 + IF (A(K,K).EQ.ZERO) THEN + T = ZERO + ELSE + T = A(K,J) - DDOT_odr(K-1,A(1,K),1,A(1,J),1) + T = T/A(K,K) + END IF + A(K,J) = T + S = S + T*T + 10 CONTINUE + S = A(J,J) - S +C ......EXIT + IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN + RETURN + ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN + RETURN + ELSE IF (S.LE.ZERO) THEN + A(J,J) = ZERO + ELSE + A(J,J) = SQRT(S) + END IF + 20 CONTINUE + INFO = 0 + +C ZERO OUT LOWER PORTION OF A + DO 40 J=2,N + DO 30 K=1,J-1 + A(J,K) = ZERO + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DFCTRW + SUBROUTINE DFCTRW + + (N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WRK0,WRK4, + + WE1,NNZW,INFO) +C***BEGIN PROLOGUE DFCTRW +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFCTR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE +C ODRPACK REFERENCE GUIDE +C***END PROLOGUE DFCTRW + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDWD,LDWE,LD2WD,LD2WE, + + M,N,NNZW,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), + + WRK0(NQ,NQ),WRK4(M,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,INF,J,J1,J2,L,L1,L2 + LOGICAL + + NOTZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFCTR + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NOTZRO: THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE +C WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) +C OR NOT (NOTZRO=TRUE). +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C WE: THE (SQUARED) EPSILON WEIGHTS. +C WE1: THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK0: A WORK ARRAY OF (NQ BY NQ) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTRW + + +C CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1 + + IF (WE(1,1,1).LT.ZERO) THEN +C WE CONTAINS A SCALAR + WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) + NNZW = N + + ELSE + NNZW = 0 + + IF (LDWE.EQ.1) THEN + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS A DIAGONAL MATRIX + DO 110 L=1,NQ + IF (WE(1,1,L).GT.ZERO) THEN + NNZW = N + WE1(1,1,L) = SQRT(WE(1,1,L)) + ELSE IF (WE(1,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 110 CONTINUE + ELSE + +C WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX + DO 130 L1=1,NQ + DO 120 L2=L1,NQ + WRK0(L1,L2) = WE(1,L1,L2) + 120 CONTINUE + 130 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + DO 150 L1=1,NQ + DO 140 L2=1,NQ + WE1(1,L1,L2) = WRK0(L1,L2) + 140 CONTINUE + IF (WE1(1,L1,L1).NE.ZERO) THEN + NNZW = N + END IF + 150 CONTINUE + END IF + END IF + + ELSE + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS AN ARRAY OF DIAGONAL MATRIX + DO 220 I=1,N + NOTZRO = .FALSE. + DO 210 L=1,NQ + IF (WE(I,1,L).GT.ZERO) THEN + NOTZRO = .TRUE. + WE1(I,1,L) = SQRT(WE(I,1,L)) + ELSE IF (WE(I,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 210 CONTINUE + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 220 CONTINUE + ELSE + +C WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES + DO 270 I=1,N + DO 240 L1=1,NQ + DO 230 L2=L1,NQ + WRK0(L1,L2) = WE(I,L1,L2) + 230 CONTINUE + 240 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + NOTZRO = .FALSE. + DO 260 L1=1,NQ + DO 250 L2=1,NQ + WE1(I,L1,L2) = WRK0(L1,L2) + 250 CONTINUE + IF (WE1(I,L1,L1).NE.ZERO) THEN + NOTZRO = .TRUE. + END IF + 260 CONTINUE + END IF + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 270 CONTINUE + END IF + END IF + END IF + +C CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS + + IF (NNZW.LT.NPP) THEN + INFO = 30020 + END IF + + +C CHECK DELTA WEIGHTS + + 300 CONTINUE + IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN +C PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR + RETURN + + ELSE + + IF (LDWD.EQ.1) THEN + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS A DIAGONAL MATRIX + DO 310 J=1,M + IF (WD(1,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 310 CONTINUE + ELSE + +C WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX + DO 330 J1=1,M + DO 320 J2=J1,M + WRK4(J1,J2) = WD(1,J1,J2) + 320 CONTINUE + 330 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + END IF + + ELSE + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS AN ARRAY OF DIAGONAL MATRICES + DO 420 I=1,N + DO 410 J=1,M + IF (WD(I,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 410 CONTINUE + 420 CONTINUE + ELSE + +C WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES + DO 470 I=1,N + DO 440 J1=1,M + DO 430 J2=J1,M + WRK4(J1,J2) = WD(I,J1,J2) + 430 CONTINUE + 440 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 470 CONTINUE + END IF + END IF + END IF + + RETURN + END +*DFLAGS + SUBROUTINE DFLAGS + + (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) +C***BEGIN PROLOGUE DFLAGS +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB +C***END PROLOGUE DFLAGS + +C...SCALAR ARGUMENTS + INTEGER + + JOB + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...LOCAL SCALARS + INTEGER + + J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF +C ARRAY WORK (INITD=FALSE). +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: THE VALUE OF A SPECIFIC DIGIT OF JOB. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). + + +C***FIRST EXECUTABLE STATEMENT DFLAGS + + + IF (JOB.GE.0) THEN + + RESTRT= JOB.GE.10000 + + INITD = MOD(JOB,10000)/1000.EQ.0 + + J = MOD(JOB,1000)/100 + IF (J.EQ.0) THEN + DOVCV = .TRUE. + REDOJ = .TRUE. + ELSE IF (J.EQ.1) THEN + DOVCV = .TRUE. + REDOJ = .FALSE. + ELSE + DOVCV = .FALSE. + REDOJ = .FALSE. + END IF + + J = MOD(JOB,100)/10 + IF (J.EQ.0) THEN + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.1) THEN + ANAJAC = .FALSE. + CDJAC = .TRUE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.2) THEN + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .TRUE. + ELSE + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + END IF + + J = MOD(JOB,10) + IF (J.EQ.0) THEN + ISODR = .TRUE. + IMPLCT = .FALSE. + ELSE IF (J.EQ.1) THEN + ISODR = .TRUE. + IMPLCT = .TRUE. + ELSE + ISODR = .FALSE. + IMPLCT = .FALSE. + END IF + + ELSE + + RESTRT = .FALSE. + INITD = .TRUE. + DOVCV = .TRUE. + REDOJ = .TRUE. + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ISODR = .TRUE. + IMPLCT = .FALSE. + + END IF + + RETURN + END +*DHSTEP + DOUBLE PRECISION FUNCTION DHSTEP + + (ITYPE,NETA,I,J,STP,LDSTP) +C***BEGIN PROLOGUE DHSTEP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES +C***END PROLOGUE DHSTEP + +C...SCALAR ARGUMENTS + INTEGER + + I,ITYPE,J,LDSTP,NETA + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + STP(LDSTP,J) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEN,THREE,TWO,ZERO + +C...DATA STATEMENTS + DATA + + ZERO,TWO,THREE,TEN + + /0.0D0,2.0D0,3.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C ITYPE: THE FINITE DIFFERENCE METHOD BEING USED, WHERE +C ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND +C ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES. +C J: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C LDSTP: THE LEADING DIMENSION OF ARRAY STP. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + + +C***FIRST EXECUTABLE STATEMENT DHSTEP + + +C SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE + + IF (STP(1,1).LE.ZERO) THEN + + IF (ITYPE.EQ.0) THEN +C USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/TWO - TWO) + + ELSE +C USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/THREE) + END IF + + ELSE IF (LDSTP.EQ.1) THEN + DHSTEP = STP(1,J) + + ELSE + DHSTEP = STP(I,J) + END IF + + RETURN + END +*DIFIX + SUBROUTINE DIFIX + + (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) +C***BEGIN PROLOGUE DIFIX +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 910612 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX +C***END PROLOGUE DIFIX + +C...SCALAR ARGUMENTS + INTEGER + + LDIFIX,LDT,LDTFIX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),TFIX(LDTFIX,M) + INTEGER + + IFIX(LDIFIX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE +C SET TO ZERO. +C J: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDIFIX: THE LEADING DIMENSION OF ARRAY IFIX. +C LDTFIX: THE LEADING DIMENSION OF ARRAY TFIX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE ARRAY. +C N: THE NUMBER OF ROWS OF DATA IN THE ARRAY. +C T: THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS +C OF IFIX. +C TFIX: THE RESULTING ARRAY. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DIFIX + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (IFIX(1,1).GE.ZERO) THEN + IF (LDIFIX.GE.N) THEN + DO 20 J=1,M + DO 10 I=1,N + IF (IFIX(I,J).EQ.0) THEN + TFIX(I,J) = ZERO + ELSE + TFIX(I,J) = T(I,J) + END IF + 10 CONTINUE + 20 CONTINUE + ELSE + DO 100 J=1,M + IF (IFIX(1,J).EQ.0) THEN + DO 30 I=1,N + TFIX(I,J) = ZERO + 30 CONTINUE + ELSE + DO 90 I=1,N + TFIX(I,J) = T(I,J) + 90 CONTINUE + END IF + 100 CONTINUE + END IF + END IF + + RETURN + END +*DINIWK + SUBROUTINE DINIWK + + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) +C***BEGIN PROLOGUE DINIWK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY +C***END PROLOGUE DINIWK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, + + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) + INTEGER + + IFIXX(LDIFX,M),IWORK(LIWORK) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,THREE,TWO,ZERO + INTEGER + + I,J + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr,DFLAGS,DSCLB,DSCLD,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C I: AN INDEXING VARIABLE. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C IWORK: THE INTEGER WORK SPACE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDTTI: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C THREE: THE VALUE 3.0D0. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT. +C TWO: THE VALUE 2.0D0. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DINIWK + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR + + WORK(EPSMAI) = DMPREC() + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C PARAMETERS (SEE ALSO SUBPROGRAM DODCNT) + + IF (PARTOL.LT.ZERO) THEN + WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) + ELSE + WORK(PARTLI) = MIN(PARTOL, ONE) + END IF + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS + + IF (SSTOL.LT.ZERO) THEN + WORK(SSTOLI) = SQRT(WORK(EPSMAI)) + ELSE + WORK(SSTOLI) = MIN(SSTOL, ONE) + END IF + +C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION + + IF (TAUFAC.LE.ZERO) THEN + WORK(TAUFCI) = ONE + ELSE + WORK(TAUFCI) = MIN(TAUFAC, ONE) + END IF + +C SET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.LT.0) THEN + IWORK(MAXITI) = 50 + ELSE + IWORK(MAXITI) = MAXIT + END IF + +C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL +C VARIABLE + + IF (JOB.LE.0) THEN + IWORK(JOBI) = 0 + ELSE + IWORK(JOBI) = JOB + END IF + +C SET PRINT CONTROL + + IF (IPRINT.LT.0) THEN + IWORK(IPRINI) = 2001 + ELSE + IWORK(IPRINI) = IPRINT + END IF + +C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES + + IF (LUNERR.LT.0) THEN + IWORK(LUNERI) = 6 + ELSE + IWORK(LUNERI) = LUNERR + END IF + +C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS + + IF (LUNRPT.LT.0) THEN + IWORK(LUNRPI) = 6 + ELSE + IWORK(LUNRPI) = LUNRPT + END IF + +C COMPUTE SCALING FOR BETA'S AND DELTA'S + + IF (SCLB(1).LE.ZERO) THEN + CALL DSCLB(NP,BETA,WORK(SSFI)) + ELSE + CALL DCOPY_odr(NP,SCLB,1,WORK(SSFI),1) + END IF + IF (ISODR) THEN + IF (SCLD(1,1).LE.ZERO) THEN + IWORK(LDTTI) = N + CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) + ELSE + IF (LDSCLD.EQ.1) THEN + IWORK(LDTTI) = 1 + CALL DCOPY_odr(M,SCLD(1,1),1,WORK(TTI),1) + ELSE + IWORK(LDTTI) = N + DO 10 J=1,M + CALL DCOPY_odr(N,SCLD(1,J),1, + + WORK(TTI+(J-1)*IWORK(LDTTI)),1) + 10 CONTINUE + END IF + END IF + END IF + +C INITIALIZE DELTA'S AS NECESSARY + + IF (ISODR) THEN + IF (INITD) THEN + CALL DZERO(N,M,WORK(DELTAI),N) + ELSE + IF (IFIXX(1,1).GE.0) THEN + IF (LDIFX.EQ.1) THEN + DO 20 J=1,M + IF (IFIXX(1,J).EQ.0) THEN + CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) + END IF + 20 CONTINUE + ELSE + DO 40 J=1,M + DO 30 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + WORK(DELTAI-1+I+(J-1)*N) = ZERO + END IF + 30 CONTINUE + 40 CONTINUE + END IF + END IF + END IF + ELSE + CALL DZERO(N,M,WORK(DELTAI),N) + END IF + + RETURN + END +*DIWINF + SUBROUTINE DIWINF + + (M,NP,NQ, + + MSGBI,MSGDI,IFIX2I,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) +C***BEGIN PROLOGUE DIWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE +C***END PROLOGUE DIWINF + +C...SCALAR ARGUMENTS + INTEGER + + IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN, + + LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI, + + NNZWI,NP,NPPI,NQ,NROWI,NTOLI + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIX2I: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGBI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGDI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABEL NITER. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. + + +C***FIRST EXECUTABLE STATEMENT DIWINF + + + IF (NP.GE.1 .AND. M.GE.1) THEN + MSGBI = 1 + MSGDI = MSGBI + NQ*NP+1 + IFIX2I = MSGDI + NQ*M+1 + ISTOPI = IFIX2I + NP + NNZWI = ISTOPI + 1 + NPPI = NNZWI + 1 + IDFI = NPPI + 1 + JOBI = IDFI + 1 + IPRINI = JOBI + 1 + LUNERI = IPRINI + 1 + LUNRPI = LUNERI + 1 + NROWI = LUNRPI + 1 + NTOLI = NROWI + 1 + NETAI = NTOLI + 1 + MAXITI = NETAI + 1 + NITERI = MAXITI + 1 + NFEVI = NITERI + 1 + NJEVI = NFEVI + 1 + INT2I = NJEVI + 1 + IRANKI = INT2I + 1 + LDTTI = IRANKI + 1 + LIWKMN = LDTTI + ELSE + MSGBI = 1 + MSGDI = 1 + IFIX2I = 1 + ISTOPI = 1 + NNZWI = 1 + NPPI = 1 + IDFI = 1 + JOBI = 1 + IPRINI = 1 + LUNERI = 1 + LUNRPI = 1 + NROWI = 1 + NTOLI = 1 + NETAI = 1 + MAXITI = 1 + NITERI = 1 + NFEVI = 1 + NJEVI = 1 + INT2I = 1 + IRANKI = 1 + LDTTI = 1 + LIWKMN = 1 + END IF + + RETURN + END +*DJACCD + SUBROUTINE DJACCD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACCD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACCD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN +C BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT +C (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALING VALUES USED FOR BETA. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACCD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 60 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = WRK2(I,L) + 20 CONTINUE + 30 CONTINUE + END IF + + BETA(K) = BETAK - WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + DO 50 L=1,NQ + DO 40 I=1,N + FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) + 40 CONTINUE + 50 CONTINUE + BETA(K) = BETAK + END IF + 60 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + END IF + + DO 150 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) + 150 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJACFD + SUBROUTINE DJACFD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACFD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACFD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A +C GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) +C OR NOT (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACFD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 40 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) + 20 CONTINUE + 30 CONTINUE + BETA(K) = BETAK + END IF + 40 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJCK + SUBROUTINE DJCK + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + SSF,TT,LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + PV0,FJACB,FJACD, + + MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DJCKM +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS +C (ADAPTED FROM STARPAC SUBROUTINE DCKCNT) +C***END PROLOGUE DJCK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT, + + M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO + INTEGER + + IDEVAL,J,LQ,MSGB1,MSGD1 + LOGICAL + + ISFIXD,ISWRTB + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKM + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10 + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE + + /0.0D0,0.5D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISFIXD: THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED +C (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED. +C J: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER +C SET BY THE USER OR COMPUTED BY DETAF. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. +C ONE: THE VALUE 1.0D0. +C P5: THE VALUE 0.5D0. +C PV: THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR +C ROW NROW IS STORED. +C PV0: THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES. +C SSF: THE SCALING VALUES USED FOR BETA. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TOL: THE AGREEMENT TOLERANCE. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCK + + +C SET TOLERANCE FOR CHECKING DERIVATIVES + + TOL = ETA**(0.25D0) + NTOL = MAX(ONE,P5-LOG10(TOL)) + + +C COMPUTE USER SUPPLIED DERIVATIVE VALUES + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV + 1 + END IF + +C CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW + + MSGB1 = 0 + MSGD1 = 0 + + DO 30 LQ=1,NQ + +C SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES + PV = PV0(NROW,LQ) + + ISWRTB = .TRUE. + DO 10 J=1,NP + + IF (IFIXB(1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (IFIXB(J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGB(1+LQ+(J-1)*NQ) = -1 + ELSE + IF (BETA(J).EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(J) + END IF + ELSE + TYPJ = ABS(BETA(J)) + END IF + + H0 = DHSTEP(0,NETA,1,J,STPB,1) + HC0 = H0 + +C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACB(NROW,J,LQ), + + DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGB(1) = -1 + RETURN + ELSE + DIFF(LQ,J) = DIFFJ + END IF + END IF + + 10 CONTINUE + +C CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW + + IF (ISODR) THEN + ISWRTB = .FALSE. + DO 20 J=1,M + + IF (IFIXX(1,1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGD(1+LQ+(J-1)*NQ) = -1 + ELSE + + IF (XPLUSD(NROW,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(NROW,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(NROW,J)) + END IF + + H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) + HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) + +C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACD(NROW,J,LQ), + + DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGD(1) = -1 + RETURN + ELSE + DIFF(LQ,NP+J) = DIFFJ + END IF + END IF + + 20 CONTINUE + END IF + 30 CONTINUE + MSGB(1) = MSGB1 + MSGD(1) = MSGD1 + + RETURN + END +*DJCKC + SUBROUTINE DJCKC + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0, + + PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKF,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE +C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKCRV) +C***END PROLOGUE DJCKC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO + + double precision guterm + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKF,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P01,ONE,TWO,TEN + + /0.01D0,1.0D0,2.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE OF THE MODEL FOR ROW NROW . +C PVMCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. +C PVPCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STP: A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STPCRV: THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. +C TEN: THE VALUE 10.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKC + + + IF (ISWRTB) THEN + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA + + STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL + + CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) + CURVE = CURVE + + + ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) + + +C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. + CALL DJCKF(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + IF (MSG(LQ,J).EQ.0) THEN + RETURN + END IF + +C CHECK IF HIGH CURVATURE COULD BE THE PROBLEM. + + STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) + IF (STP.LT.ABS(TEN*STP0)) THEN + STP = MIN(STP,P01*ABS(STP0)) + END IF + + guterm=STP + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) + + if(STP.eq.0.0d0)then + STP=guterm*SIGN(ONE,BETA(J)) + endif + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + + if(STP.eq.0.0d0)then + STP=guterm*SIGN(ONE,XPLUSD(NROW,J)) + endif + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C COMPUTE THE NEW NUMERICAL DERIVATIVE + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN + MSG(LQ,J) = 0 + +C CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2) + ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) + + + CURVE*(EPSMAC*TYPJ)**2) THEN + MSG(LQ,J) = 5 + END IF + + RETURN + END +*DJCKF + SUBROUTINE DJCKF + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE +C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKFPA) +C***END PROLOGUE DJCKF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ + + double precision holder + + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + HUNDRD,ONE,P1,STP,TWO + LOGICAL + + LARGE + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P1,ONE,TWO,HUNDRD + + /0.1D0,1.0D0,2.0D0,100.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LARGE: THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN +C THE STEP SIZE WOULD BE GREATER THAN TYPJ. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P1: THE VALUE 0.1D0. +C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKF + + +C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. +C TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR + + STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) + + IF (STP.GT.ABS(P1*STP0)) THEN + STP = MAX(STP,HUNDRD*ABS(STP0)) + END IF + IF (STP.GT.TYPJ) THEN + STP = TYPJ + LARGE = .TRUE. + ELSE + LARGE = .FALSE. + END IF + + holder=STP + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + + if(STP.eq.0.0d0)then + STP=holder*SIGN(ONE,BETA(J)) + endif + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + + if(STP.eq.0.0d0)then + STP=holder*SIGN(ONE,XPLUSD(NROW,J)) + endif + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP + + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK FOR AGREEMENT + + IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN +C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE. + MSG(LQ,J) = 0 + + ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN +C CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2) + IF (LARGE) THEN + MSG(LQ,J) = 4 + ELSE + MSG(LQ,J) = 5 + END IF + END IF + + RETURN + END +*DJCKM + SUBROUTINE DJCKM + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,D, + + DIFFJ,MSG1,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL +C DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKMN) +C***END PROLOGUE DJCKM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, + + TEN,THREE,TOL2,TWO,ZERO + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKC,DJCKZ,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD + + /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/ + DATA + + BIG,TOL2 + + /1.0D19,5.0D-2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIG: A BIG VALUE, USED TO INITIALIZE DIFFJ. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C H: THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H1: THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC1: THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C MSG1: THE ERROR CHECKING RESULTS SUMMARY. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH +C PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C P1: THE VALUE 0.1D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TOL2: A MINIMUM AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKM + + +C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE +C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES + + H1 = SQRT(ETA) + HC1 = ETA**(ONE/THREE) + + MSG(LQ,J) = 7 + DIFFJ = BIG + + DO 10 I=1,3 + + IF (I.EQ.1) THEN +C TRY INITIAL RELATIVE STEP SIZE + H = H0 + HC = HC0 + + ELSE IF (I.EQ.2) THEN +C TRY LARGER RELATIVE STEP SIZE + H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) + HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) + + ELSE IF (I.EQ.3) THEN +C TRY SMALLER RELATIVE STEP SIZE + H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) + HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) + END IF + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + + - XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP0 + +C CHECK FOR AGREEMENT + + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN +C NUMERICAL AND ANALYTIC DERIVATIVES AGREE + +C SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + DIFFJ = ABS(FD-D) + ELSE + DIFFJ = ABS(FD-D)/ABS(D) + END IF + +C SET MSG FLAG. + IF (D.EQ.ZERO) THEN + +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO. + MSG(LQ,J) = 1 + + ELSE +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO. + MSG(LQ,J) = 0 + END IF + + ELSE + +C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE. CHECK WHY + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + CALL DJCKZ(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + ELSE + CALL DJCKC(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + END IF + IF (MSG(LQ,J).LE.2) THEN + GO TO 20 + END IF + END IF + 10 CONTINUE + +C SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS + 20 CONTINUE + IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 + IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN + MSG1 = MAX(MSG1,1) + ELSE IF (MSG(LQ,J).GE.7) THEN + MSG1 = 2 + END IF + + RETURN + END +*DJCKZ + SUBROUTINE DJCKZ + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKZ +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE +C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC +C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO +C (ADAPTED FROM STARPAC SUBROUTINE DCKZRO) +C***END PROLOGUE DJCKZ + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CD,ONE,PVMSTP,THREE,TWO,ZERO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CD: THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVMSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKZ + + +C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP +C SIZE OF 2*STP0 + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + CD = (PVPSTP-PVMSTP)/(TWO*STP0) + DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) + +C CHECK FOR AGREEMENT + + IF (DIFFJ.LE.TOL*ABS(D)) THEN + +C FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE. + IF (D.EQ.ZERO) THEN + MSG(LQ,J) = 1 + ELSE + MSG(LQ,J) = 0 + END IF + + ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN +C DERIVATIVES ARE BOTH CLOSE TO ZERO + MSG(LQ,J) = 2 + + ELSE +C DERIVATIVES ARE NOT BOTH CLOSE TO ZERO + MSG(LQ,J) = 3 + END IF + + RETURN + END +*DODCHK + SUBROUTINE DODCHK + + (N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) +C***BEGIN PROLOGUE DODCHK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO +C***END PROLOGUE DODCHK + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ + LOGICAL + + ANAJAC,IMPLCT,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M) + INTEGER + + IFIXB(NP) + +C...LOCAL SCALARS + INTEGER + + I,J,K,LAST,NPP + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY X. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUE FOR DELTA. +C STPB: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT BETA. +C STPD: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODCHK + + +C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED + + IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN + NPP = NP + ELSE + NPP = 0 + DO 10 K=1,NP + IF (IFIXB(K).NE.0) THEN + NPP = NPP + 1 + END IF + 10 CONTINUE + END IF + +C CHECK PROBLEM SPECIFICATION PARAMETERS + + IF (N.LE.0 .OR. + + M.LE.0 .OR. + + (NPP.LE.0 .OR. NPP.GT.N) .OR. + + (NQ.LE.0)) THEN + + INFO = 10000 + IF (N.LE.0) THEN + INFO = INFO + 1000 + END IF + IF (M.LE.0) THEN + INFO = INFO + 100 + END IF + IF (NPP.LE.0 .OR. NPP.GT.N) THEN + INFO = INFO + 10 + END IF + IF (NQ.LE.0) THEN + INFO = INFO + 1 + END IF + + RETURN + + END IF + +C CHECK DIMENSION SPECIFICATION PARAMETERS + + IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. + + (LDX.LT.N) .OR. + + (LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. + + (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. + + (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. + + (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. + + (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. + + (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. + + (LWORK.LT.LWKMN) .OR. + + (LIWORK.LT.LIWKMN)) THEN + + INFO = 20000 + IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN + INFO = INFO + 1000 + END IF + IF (LDX.LT.N) THEN + INFO = INFO + 2000 + END IF + + IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN + INFO = INFO + 100 + END IF + IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. + + (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN + INFO = INFO + 200 + END IF + + IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN + INFO = INFO + 10 + END IF + IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN + INFO = INFO + 20 + END IF + IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN + INFO = INFO + 40 + END IF + + IF (LWORK.LT.LWKMN) THEN + INFO = INFO + 1 + END IF + IF (LIWORK.LT.LIWKMN) THEN + INFO = INFO + 2 + END IF + RETURN + + END IF + +C CHECK DELTA SCALING + + IF (ISODR .AND. SCLD(1,1).GT.0) THEN + IF (LDSCLD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 120 J=1,M + DO 110 I=1,LAST + IF (SCLD(I,J).LE.0) THEN + INFO = 30200 + GO TO 130 + END IF + 110 CONTINUE + 120 CONTINUE + END IF + 130 CONTINUE + +C CHECK BETA SCALING + + IF (SCLB(1).GT.0) THEN + DO 210 K=1,NP + IF (SCLB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 30100 + ELSE + INFO = INFO + 100 + END IF + GO TO 220 + END IF + 210 CONTINUE + END IF + 220 CONTINUE + +C CHECK DELTA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN + IF (LDSTPD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 320 J=1,M + DO 310 I=1,LAST + IF (STPD(I,J).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 32000 + ELSE + INFO = INFO + 2000 + END IF + GO TO 330 + END IF + 310 CONTINUE + 320 CONTINUE + END IF + 330 CONTINUE + +C CHECK BETA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. STPB(1).GT.0) THEN + DO 410 K=1,NP + IF (STPB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 31000 + ELSE + INFO = INFO + 1000 + END IF + GO TO 420 + END IF + 410 CONTINUE + END IF + 420 CONTINUE + + RETURN + END +*DODCNT + SUBROUTINE DODCNT + + (SHORT, 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) +C***BEGIN PROLOGUE DODCNT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODDRV +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION +C***END PROLOGUE DODCNT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + LOGICAL + + SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO + INTEGER + + IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, + + MAXITI,MAXIT1 + LOGICAL + + DONE,FSTITR,HEAD,IMPLCT,PRTPEN + +C...LOCAL ARRAYS + DOUBLE PRECISION + + PNLTY(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODDRV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...DATA STATEMENTS + DATA + + PCHECK,PSTART,PFAC,ZERO,ONE,THREE + + /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CNVTOL: THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS. +C DONE: THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS +C BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE). +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLES. +C IPRNTI: THE PRINT CONTROL VARIABLES. +C IPR1: THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR2: THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR3: THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR4: THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB2: THE 2ND DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB3: THE 3RD DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB4: THE 4TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB5: THE 5TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE CURRENT PENALTY PARAMETER VALUE. +C MAXIT1: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE NEXT PENALTY PARAMETER VALUE. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C ONE: THE VALUE 1.0D0. +C PARTOL: THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PCHECK: THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED +C BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED. +C PFAC: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE +C PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C PSTART: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C THREE: THE VALUE 3.0D0. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODCNT + + + IMPLCT = MOD(JOB,10).EQ.1 + FSTITR = .TRUE. + HEAD = .TRUE. + PRTPEN = .FALSE. + + IF (IMPLCT) THEN + +C SET UP FOR IMPLICIT PROBLEM + + IF (IPRINT.GE.0) THEN + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + ELSE + IPR1 = 2 + IPR2 = 0 + IPR2F = 0 + IPR3 = 1 + END IF + IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 + + JOB5 = MOD(JOB,100000)/10000 + JOB4 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB2 = MOD(JOB,100)/10 + JOB1 = MOD(JOB,10) + JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 + + IF (WE(1,1,1).LE.ZERO) THEN + PNLTY(1,1,1) = -PSTART + ELSE + PNLTY(1,1,1) = -WE(1,1,1) + END IF + + IF (PARTOL.LT.ZERO) THEN + CNVTOL = DMPREC()**(ONE/THREE) + ELSE + CNVTOL = MIN(PARTOL,ONE) + END IF + + IF (MAXIT.GE.1) THEN + MAXITI = MAXIT + ELSE + MAXITI = 100 + END IF + + DONE = MAXITI.EQ.0 + PRTPEN = .TRUE. + + 10 CONTINUE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, + + IPRNTI,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) + IF (DONE) THEN + RETURN + ELSE + DONE = MAXIT1.LE.0 .OR. + + (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. + + TSTIMP.LE.CNVTOL) + END IF + + IF (DONE) THEN + IF (TSTIMP.LE.CNVTOL) THEN + INFO = (INFO/10)*10 + 2 + ELSE + INFO = (INFO/10)*10 + 4 + END IF + JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 + MAXITI = 0 + IPRNTI = IPR3 + ELSE + PRTPEN = .TRUE. + PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) + JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 + MAXITI = MAXIT1 + IPRNTI = 0000 + IPR2*100 + IPR2F*10 + END IF + GO TO 10 + ELSE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + 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, + + MAXIT1,TSTIMP, INFO) + END IF + + RETURN + + END +*DODDRV + SUBROUTINE DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + 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, + + MAXIT1,TSTIMP, INFO) +C***BEGIN PROLOGUE DODDRV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DCOPY_odr,DDOT_odr,DETAF,DFCTRW,DFLAGS, +C DINIWK,DIWINF,DJCK,DNRM2_odr,DODCHK,DODMN, +C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN +C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION +C (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) +C***END PROLOGUE DODDRV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC,TSTIMP + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, + + N,NDIGIT,NP,NQ + LOGICAL + + FSTITR,HEAD,PRTPEN,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + EPSMAC,ETA,P5,ONE,TEN,ZERO + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI, + + IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN, + + LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, + + NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, + + NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, + + DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE,TEN + + /0.0D0,0.5D0,1.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY F. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEX VARIABLE. +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2I: THE IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT. +C K: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXIT1: FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT +C PENALTY PARAMETER VALUE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, +C SET BY DJCK. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C P5: THE VALUE 0.5D0. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL +C (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TEN: THE VALUE 10.0D0. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C X: THE EXPLANATORY VARIABLE. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODDRV + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE +C (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF) + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE +C ARE HANDLED REASONABLY BY DWINF) + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,FI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + IF (ISODR) THEN + WRK = WRK1I + LWRK = N*M*NQ + N*NQ + ELSE + WRK = WRK2I + LWRK = N*NQ + END IF + +C UPDATE THE PENALTY PARAMETERS +C (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE) + IF (RESTRT .AND. IMPLCT) THEN + WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) + WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) + END IF + + IF (RESTRT) THEN + +C RESET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.GE.0) THEN + IWORK(MAXITI) = IWORK(NITERI) + MAXIT + ELSE + IWORK(MAXITI) = IWORK(NITERI) + 10 + END IF + + IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN + INFO = 0 + END IF + + IF (JOB.GE.0) IWORK(JOBI) = JOB + IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT + IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL + IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL + + WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) + + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + WORK(WSSEPI) = DDOT_odr(N*NQ,WORK(FI),1,WORK(FI),1) + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + + ELSE + +C PERFORM ERROR CHECKING + + INFO = 0 + + CALL DODCHK(N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) + IF (INFO.GT.0) THEN + GO TO 50 + END IF + +C INITIALIZE WORK VECTORS AS NECESSARY + + DO 10 I=N*M+N*NQ+1,LWORK + WORK(I) = ZERO + 10 CONTINUE + DO 20 I=1,LIWORK + IWORK(I) = 0 + 20 CONTINUE + + CALL DINIWK(N,M,NP, + + WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + WORK(TAUI) = -WORK(TAUFCI) + +C SET UP FOR PARAMETER ESTIMATION - +C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES +C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY + + CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) + CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) + NPP = IWORK(NPPI) + +C CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, +C SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS + + CALL DFCTRW(N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WORK(WRK2I),WORK(WRK4I), + + WORK(WE1I),NNZW,INFO) + IWORK(NNZWI) = NNZW + + IF (INFO.NE.0) THEN + GO TO 50 + END IF +C EVALUATE THE PREDICTED VALUES AND +C WEIGHTED EPSILONS AT THE STARTING POINT + CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) + CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX, + + 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), + + ISTOP) + IWORK(ISTOPI) = ISTOP + IF (ISTOP.EQ.0) THEN + IWORK(NFEVI) = IWORK(NFEVI) + 1 + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + ELSE + INFO = 52000 + GO TO 50 + END IF + +C COMPUTE NORM OF THE INITIAL ESTIMATES + + CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP, + + WORK(WRK),NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N, + + WORK(WRK+NPP),N) + WORK(PNORMI) = DNRM2_odr(NPP+N*M,WORK(WRK),1) + ELSE + WORK(PNORMI) = DNRM2_odr(NPP,WORK(WRK),1) + END IF + +C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS + + WORK(WSSEPI) = DDOT_odr(N*NQ,WORK(FI),1,WORK(FI),1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N) + WORK(WSSDEI) = DDOT_odr(N*M,WORK(DELTAI),1,WORK(WRK),1) + ELSE + WORK(WSSDEI) = ZERO + END IF + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + +C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS + + NROW = -1 + CALL DSETN(N,M,WORK(XPLUSI),N,NROW) + IWORK(NROWI) = NROW + +C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS + + EPSMAC = WORK(EPSMAI) + IF (NDIGIT.LT.2) THEN + IWORK(NETAI) = -1 + NFEV = IWORK(NFEVI) + CALL DETAF(FCN, + + N,M,NP,NQ, + + WORK(XPLUSI),BETA,EPSMAC,NROW, + + WORK(BETANI),WORK(FNI), + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IF (ISTOP.NE.0) THEN + INFO = 53000 + IWORK(NETAI) = 0 + WORK(ETAI) = ZERO + GO TO 50 + ELSE + IWORK(NETAI) = -NETA + WORK(ETAI) = ETA + END IF + ELSE + IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) + WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) + END IF + +C CHECK DERIVATIVES IF NECESSARY + + IF (CHKJAC .AND. ANAJAC) THEN + NTOL = -1 + NFEV = IWORK(NFEVI) + NJEV = IWORK(NJEVI) + NETA = IWORK(NETAI) + LDTT = IWORK(LDTTI) + ETA = WORK(ETAI) + EPSMAC = WORK(EPSMAI) + CALL DJCK(FCN, + + N,M,NP,NQ, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + WORK(SSFI),WORK(TTI),LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + WORK(FNI),WORK(FJACBI),WORK(FJACDI), + + IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), + + ISTOP,NFEV,NJEV, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NJEVI) = NJEV + IWORK(NTOLI) = NTOL + IF (ISTOP.NE.0) THEN + INFO = 54000 + ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN + INFO = 40000 + END IF + ELSE + +C INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + END IF + +C PRINT APPROPRIATE ERROR MESSAGES + + 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN + IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN + CALL DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + WORK(FJACBI),WORK(FJACDI), + + WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), + + WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) + END IF + +C SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS + + IF (INFO.EQ.40000) THEN + IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN + IF (IWORK(MSGB).EQ.2) THEN + INFO = INFO + 1000 + END IF + IF (IWORK(MSGD).EQ.2) THEN + INFO = INFO + 100 + END IF + ELSE + INFO = 0 + END IF + END IF + IF (INFO.NE.0) THEN + RETURN + END IF + END IF + END IF + +C SAVE THE INITIAL VALUES OF BETA + CALL DCOPY_odr(NP,BETA,1,WORK(BETA0I),1) + +C FIND LEAST SQUARES SOLUTION + + CALL DCOPY_odr(N*NQ,WORK(FNI),1,WORK(FSI),1) + LDTT = IWORK(LDTTI) + CALL DODMN(HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), + + WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + + WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), + + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + + STPB,STPD,LDSTPD, + + WORK(XPLUSI),WORK(WRK),LWRK, + + WORK,LWORK,IWORK,LIWORK,INFO) + MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) + TSTIMP = ZERO + DO 100 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) + ELSE + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) + END IF + 100 CONTINUE + + RETURN + + END +*DODLM + SUBROUTINE DODLM + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,TAU,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,NLMS,RCOND,IRANK, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODLM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT_odr,DNRM2_odr,DODSTP,DSCALE,DWGHT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T +C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT +C ALGORITHM +C***END PROLOGUE DODLM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA2,EPSFCN,RCOND,TAU + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) + INTEGER + + JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO + INTEGER + + I,IWRK,J,K,L + LOGICAL + + FORVCV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODSTP,DSCALE,DWGHT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P001,P1 + + /0.0D0,0.001D0,0.1D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHAN: THE NEW LEVENBERG-MARQUARDT PARAMETER. +C ALPHA1: THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. +C ALPHA2: THE CURRENT LEVENBERG-MARQUARDT PARAMETER. +C BOT: THE LOWER LIMIT FOR SETTING ALPHA. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN +C SUBROUTINE DODSTP. +C IWRK: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2) WHERE +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C P001: THE VALUE 0.001D0 +C P1: THE VALUE 0.1D0 +C PHI1: THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C PHI2: THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C S: THE STEP FOR BETA. +C SA: THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TOP: THE UPPER LIMIT FOR SETTING ALPHA. +C TT: THE SCALE USED FOR THE DELTA'S. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODLM + + FORVCV = .FALSE. + ISTOPC = 0 + +C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) + + ALPHA1 = ZERO + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA1,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI1,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + +C INITIALIZE TAU IF NECESSARY + + IF (TAU.LT.ZERO) THEN + TAU = ABS(TAU)*PHI1 + END IF + +C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL + + IF ((PHI1-TAU).LE.P1*TAU) THEN + NLMS = 1 + ALPHA2 = ZERO + RETURN + END IF + +C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - +C FIND LOCALLY CONSTRAINED OPTIMAL STEP + + PHI1 = PHI1 - TAU + +C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA + + BOT = ZERO + + DO 30 K=1,NPP + DO 20 L=1,NQ + DO 10 I=1,N + TFJACB(I,L,K) = FJACB(I,K,L) + 10 CONTINUE + 20 CONTINUE + WRK(K) = DDOT_odr(N*NQ,TFJACB(1,1,K),1,F(1,1),1) + 30 CONTINUE + CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) + + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N) + IWRK = NPP + DO 50 J=1,M + DO 40 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = WRK(IWRK) + + + DDOT_odr(NQ,FJACD(I,J,1),N*M,F(I,1),N) + 40 CONTINUE + 50 CONTINUE + CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) + TOP = DNRM2_odr(NPP+N*M,WRK,1)/TAU + ELSE + TOP = DNRM2_odr(NPP,WRK,1)/TAU + END IF + + IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN + ALPHA2 = P001*TOP + END IF + +C MAIN LOOP + + DO 60 I=1,10 + +C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR +C CURRENT VALUE OF ALPHA + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI2,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + PHI2 = PHI2-TAU + +C CHECK WHETHER CURRENT STEP IS OPTIMAL + + IF (ABS(PHI2).LE.P1*TAU .OR. + + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN + NLMS = I+1 + RETURN + END IF + +C CURRENT STEP IS NOT OPTIMAL + +C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA + + IF (PHI1-PHI2.EQ.ZERO) THEN + NLMS = 12 + RETURN + END IF + SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) + IF (PHI2.LT.ZERO) THEN + TOP = MIN(TOP,ALPHA2) + ELSE + BOT = MAX(BOT,ALPHA2) + END IF + IF (PHI1*PHI2.GT.ZERO) THEN + BOT = MAX(BOT,ALPHA2-SA) + ELSE + TOP = MIN(TOP,ALPHA2-SA) + END IF + + ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU + IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN + ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) + END IF + +C GET READY FOR NEXT ITERATION + + ALPHA1 = ALPHA2 + ALPHA2 = ALPHAN + PHI1 = PHI2 + 60 CONTINUE + +C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS + + NLMS = 12 + + RETURN + END +*DODMN + SUBROUTINE DODMN + + (HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, + + T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, + + SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, + + XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO) +C***BEGIN PROLOGUE DODMN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DACCES,DCOPY_odr,DDOT_odr,DEVJAC,DFLAGS,DNRM2_odr,DODLM, +C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION +C***END PROLOGUE DODMN + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,LWRK,M,N,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + + DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + + F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), + + S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + T(N,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), + + WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + LOGICAL + + FSTITR,HEAD,PRTPEN + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, + + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + + RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, + + TEMP,TEMP1,TEMP2,TSNORM,ZERO + INTEGER + + I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, + + ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, + + MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX, + + SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, + + IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WSS(3) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DACCES,DCOPY_odr,DEVJAC,DFLAGS, + + DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN,MOD,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P0001,P1,P25,P5,P75,ONE + + /0.0D0,0.00010D0,0.10D0,0.250D0, + + 0.50D0,0.750D0,1.0D0/ + DATA + + LUDFLT + + /6/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAN: THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAS: THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C CNVPAR: THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS +C ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE). +C CNVSS: THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE +C WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAN: THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAS: THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DIRDER: THE DIRECTIONAL DERIVATIVE. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX +C SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C FS: THE SAVED PREDICTED VALUES FROM THE FUNCTION. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. +C INTDBL: THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE +C USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE). +C IPR: THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT. +C IPR1: THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORT. +C IPR2F: THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. +C IWORK: THE INTEGER WORK SPACE. +C IWRK: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JPVT: THE STARTING LOCATION IN IWORK OF ARRAY JPVT. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE AND WE1. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LOOPED: A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP +C HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE +C ENOUGH THE COMPUTATIONS WILL BE STOPPED. +C LSTEP: THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS +C BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE). +C LUDFLT: THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION +C REPORTS TO THE SCREEN. +C LUNR: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPR: THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OMEGA: THE STARTING LOCATION IN WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C P0001: THE VALUE 0.0001D0. +C P1: THE VALUE 0.1D0. +C P25: THE VALUE 0.25D0. +C P5: THE VALUE 0.5D0. +C P75: THE VALUE 0.75D0. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRERS: THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO +C BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RATIO: THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED +C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORM: THE NORM OF THE WEIGHTED ERRORS. +C RNORMN: THE NEW NORM OF THE WEIGHTED ERRORS. +C RNORMS: THE SAVED NORM OF THE WEIGHTED ERRORS. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TEMP1: A TEMPORARY STORAGE LOCATION. +C TEMP2: A TEMPORARY STORAGE LOCATION. +C TSNORM: THE NORM OF THE SCALED STEP. +C TT: THE SCALING VALUES USED FOR DELTA. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE: THE EPSILON WEIGHTS. +C WE1: THE SQUARE ROOT OF THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C WRK: A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2 +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODMN + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + ACCESS = .TRUE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + RNORM = SQRT(WSS(1)) + + DIDVCV = .FALSE. + INTDBL = .FALSE. + LSTEP = .TRUE. + +C PRINT INITIAL SUMMARY IF DESIRED + + IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 1 + IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR1.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR1,2) + END IF + LUNR = LUNRPT + DO 10 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR1.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 10 CONTINUE + + END IF + +C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION + + IF (RNORM.EQ.ZERO) THEN + INFO = 1 + OLMAVG = ZERO + ISTOP = 0 + GO TO 150 + END IF + +C STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED + + IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN + ISTOP = 0 + GO TO 150 + ELSE IF (NITER.GE.MAXIT) THEN + INFO = 4 + ISTOP = 0 + GO TO 150 + END IF + +C MAIN LOOP + + 100 CONTINUE + + NITER = NITER + 1 + RNORMS = RNORM + LOOPED = 0 + +C EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS) + + IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN + ISTOP = 0 + ELSE + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + END IF + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + +C SUB LOOP FOR +C INTERNAL DOUBLING OR +C COMPUTING NEW STEP WHEN OLD FAILED + + 110 CONTINUE + +C COMPUTE STEPS S AND T + + IF (LOOPED.GT.100) THEN + INFO = 60000 + GO TO 200 + ELSE + LOOPED = LOOPED + 1 + CALL DODLM(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,TAU,ETA,ISODR, + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,NLMS,RCOND,IRANK, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + END IF + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + OLMAVG = OLMAVG+NLMS + +C COMPUTE BETAN = BETAC + S +C DELTAN = DELTA + T + + CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) + IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) + +C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + TSNORM = DNRM2_odr(NPP+N*M,WRK,1) + ELSE + TSNORM = DNRM2_odr(NPP,WRK,1) + END IF + +C COMPUTE SCALED PREDICTED REDUCTION + + IWRK = 0 + DO 130 L=1,NQ + DO 120 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = DDOT_odr(NPP,FJACB(I,1,L),N,S,1) + IF (ISODR) WRK(IWRK) = WRK(IWRK) + + + DDOT_odr(M,FJACD(I,1,L),N,T(I,1),N) + 120 CONTINUE + 130 CONTINUE + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N) + TEMP1 = DDOT_odr(N*NQ,WRK,1,WRK,1) + + + DDOT_odr(N*M,T,1,WRK(N*NQ+1),1) + TEMP1 = SQRT(TEMP1)/RNORM + ELSE + TEMP1 = DNRM2_odr(N*NQ,WRK,1)/RNORM + END IF + TEMP2 = SQRT(ALPHA)*TSNORM/RNORM + PRERED = TEMP1**2+TEMP2**2/P5 + + DIRDER = -(TEMP1**2+TEMP2**2) + +C EVALUATE PREDICTED VALUES AT NEW POINT + + CALL DUNPAC(NP,BETAN,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 002,FN,WORK(WRK6),WORK(WRK1), + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + END IF + + IF (ISTOP.LT.0) THEN + +C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN + + INFO = 51000 + GO TO 200 + ELSE IF (ISTOP.GT.0) THEN + +C SET NORM TO INDICATE STEP SHOULD BE REJECTED + + RNORMN = RNORM/(P1*P75) + ELSE + +C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) + + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,FN,1,WRK,1) + ELSE + CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N) + RNORMN = SQRT(DDOT_odr(N*NQ,WRK,1,WRK,1) + + + DDOT_odr(N*M,DELTAN,1,WRK(N*NQ+1),1)) + ELSE + RNORMN = DNRM2_odr(N*NQ,WRK,1) + END IF + END IF + +C COMPUTE SCALED ACTUAL REDUCTION + + IF (P1*RNORMN.LT.RNORM) THEN + ACTRED = ONE - (RNORMN/RNORM)**2 + ELSE + ACTRED = -ONE + END IF + +C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION + + IF(PRERED .EQ. ZERO) THEN + RATIO = ZERO + ELSE + RATIO = ACTRED/PRERED + END IF + +C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE + + IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN + ISTOP = 0 + TAU = TAU*P5 + ALPHA = ALPHA/P5 + CALL DCOPY_odr(NPP,BETAS,1,BETAN,1) + CALL DCOPY_odr(N*M,DELTAS,1,DELTAN,1) + CALL DCOPY_odr(N*NQ,FS,1,FN,1) + ACTRED = ACTRS + PRERED = PRERS + RNORMN = RNORMS + RATIO = P5 + END IF + +C UPDATE STEP BOUND + + INTDBL = .FALSE. + IF (RATIO.LT.P25) THEN + IF (ACTRED.GE.ZERO) THEN + TEMP = P5 + ELSE + TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) + END IF + IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN + TEMP = P1 + END IF + TAU = TEMP*MIN(TAU,TSNORM/P1) + ALPHA = ALPHA/TEMP + + ELSE IF (ALPHA.EQ.ZERO) THEN + TAU = TSNORM/P5 + + ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN + +C STEP QUALIFIES FOR INTERNAL DOUBLING +C - UPDATE TAU AND ALPHA +C - SAVE INFORMATION FOR CURRENT POINT + + INTDBL = .TRUE. + + TAU = TSNORM/P5 + ALPHA = ALPHA*P5 + + CALL DCOPY_odr(NPP,BETAN,1,BETAS,1) + CALL DCOPY_odr(N*M,DELTAN,1,DELTAS,1) + CALL DCOPY_odr(N*NQ,FN,1,FS,1) + ACTRS = ACTRED + PRERS = PRERED + RNORMS = RNORMN + END IF + +C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS + + IF (INTDBL .AND. TAU.GT.ZERO) THEN + INT2 = INT2+1 + GO TO 110 + END IF + +C CHECK ACCEPTANCE + + IF (RATIO.GE.P0001) THEN + CALL DCOPY_odr(N*NQ,FN,1,FS,1) + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N) + CALL DCOPY_odr(NPP,BETAN,1,BETAC,1) + CALL DCOPY_odr(N*M,DELTAN,1,DELTA,1) + RNORM = RNORMN + CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N) + PNORM = DNRM2_odr(NPP+N*M,WRK,1) + ELSE + PNORM = DNRM2_odr(NPP,WRK,1) + END IF + LSTEP = .TRUE. + ELSE + LSTEP = .FALSE. + END IF + +C TEST CONVERGENCE + + INFO = 0 + CNVSS = RNORM.EQ.ZERO + + .OR. + + (ABS(ACTRED).LE.SSTOL .AND. + + PRERED.LE.SSTOL .AND. + + P5*RATIO.LE.ONE) + CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) + IF (CNVSS) INFO = 1 + IF (CNVPAR) INFO = 2 + IF (CNVSS .AND. CNVPAR) INFO = 3 + +C PRINT ITERATION REPORT + + IF (INFO.NE.0 .OR. LSTEP) THEN + IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN + IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN + IFLAG = 2 + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + WSS(1) = RNORM*RNORM + IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR2.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR2,2) + END IF + LUNR = LUNRPT + DO 140 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR2.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 140 CONTINUE + FSTITR = .FALSE. + PRTPEN = .FALSE. + END IF + END IF + END IF + +C CHECK IF FINISHED + + IF (INFO.EQ.0) THEN + IF (LSTEP) THEN + +C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET + + IF (NITER.GE.MAXIT) THEN + INFO = 4 + ELSE + GO TO 100 + END IF + ELSE + +C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET + + GO TO 110 + END IF + END IF + + 150 CONTINUE + + IF (ISTOP.GT.0) INFO = INFO + 100 + +C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER + + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED + + IF (DOVCV .AND. ISTOP.EQ.0) THEN + +C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED +C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED +C TO COMPUTE COVARIANCE MATRIX + + IF (REDOJ) THEN + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + + + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + END IF + + IF (IMPLCT) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + RSS = RNORM*RNORM + END IF + IF (REDOJ .OR. NITER.GE.1) THEN + CALL DODVCV(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + ETA,ISODR, + + WORK(VCV),WORK(SD), + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + DIDVCV = .TRUE. + END IF + + END IF + +C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS + + 200 DO 210 I=0,NP-1 + WORK(WRK3+I) = IWORK(JPVT+I) + IWORK(JPVT+I) = -2 + 210 CONTINUE + IF (REDOJ .OR. NITER.GE.1) THEN + DO 220 I=0,NPP-1 + J = WORK(WRK3+I) - 1 + IF (I.LE.NPP-IRANK-1) THEN + IWORK(JPVT+J) = 1 + ELSE + IWORK(JPVT+J) = -1 + END IF + 220 CONTINUE + IF (NPP.LT.NP) THEN + J = NPP-1 + DO 230 I=NP-1,0,-1 + IF (IFIXB(I+1).EQ.0) THEN + IWORK(JPVT+I) = 0 + ELSE + IWORK(JPVT+I) = IWORK(JPVT+J) + J = J - 1 + END IF + 230 CONTINUE + END IF + END IF + +C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER + + IF (NITER.GE.1) THEN + OLMAVG = OLMAVG/NITER + ELSE + OLMAVG = ZERO + END IF + +C COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER + + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N) + WSS(3) = DDOT_odr(N*NQ,WRK,1,WRK,1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + WSS(2) = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + WSS(2) = ZERO + END IF + WSS(1) = WSS(2) + WSS(3) + + ACCESS = .FALSE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + +C ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO + + IF (INFO.LE.9 .OR. INFO.GE.60000) THEN + IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN + INFO = INFO + 1000 + END IF + IF (ISTOP.NE.0) THEN + INFO = INFO + 100 + END IF + IF (IRANK.GE.1) THEN + IF (NPP.GT.IRANK) THEN + INFO = INFO + 10 + ELSE + INFO = INFO + 20 + END IF + END IF + END IF + +C PRINT FINAL SUMMARY + + IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 3 + + IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR3.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR3,2) + END IF + LUNR = LUNRPT + DO 240 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IWORK(JPVT),IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR3.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 240 CONTINUE + END IF + + RETURN + + END +*DODPC1 + SUBROUTINE DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB1,MSGB,MSGD1,MSGD, + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,WSSDEL,WSSEPS) +C***BEGIN PROLOGUE DODPC1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DHSTEP +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE INITIAL SUMMARY REPORT +C***END PROLOGUE DODPC1 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS + INTEGER + + IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M), + + Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP1,TEMP2,TEMP3,ZERO + INTEGER + + I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L + +C...LOCAL ARRAYS + CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES +C (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ITEMP: A TEMPORARY INTEGER VALUE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB2: THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB3: THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB4: THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB5: THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY +C ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED +C BY THE USER. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMPC0: A TEMPORARY CHARACTER*2 VALUE. +C TEMPC1: A TEMPORARY CHARACTER*5 VALUE. +C TEMPC2: A TEMPORARY CHARACTER*13 VALUE. +C TEMP1: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP2: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP3: A TEMPORARY DOUBLE PRECISION VALUE. +C TT: THE SCALING VALUES FOR DELTA. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE RESPONSE VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC1 + + +C PRINT PROBLEM SIZE SPECIFICATION + + WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP + + +C PRINT CONTROL VALUES + + JOB1 = JOB/10000 + JOB2 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB4 = MOD(JOB,100)/10 + JOB5 = MOD(JOB,10) + WRITE (LUNRPT,1100) JOB + IF (RESTRT) THEN + WRITE (LUNRPT,1110) JOB1 + ELSE + WRITE (LUNRPT,1111) JOB1 + END IF + IF (ISODR) THEN + IF (INITD) THEN + WRITE (LUNRPT,1120) JOB2 + ELSE + WRITE (LUNRPT,1121) JOB2 + END IF + ELSE + WRITE (LUNRPT,1122) JOB2,JOB5 + END IF + IF (DOVCV) THEN + WRITE (LUNRPT,1130) JOB3 + IF (REDOJ) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + ELSE + WRITE (LUNRPT,1133) JOB3 + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,1140) JOB4 + IF (CHKJAC) THEN + IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN + WRITE (LUNRPT,1141) + ELSE + WRITE (LUNRPT,1142) + END IF + ELSE + WRITE (LUNRPT,1143) + END IF + ELSE IF (CDJAC) THEN + WRITE (LUNRPT,1144) JOB4 + ELSE + WRITE (LUNRPT,1145) JOB4 + END IF + IF (ISODR) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1150) JOB5 + ELSE + WRITE (LUNRPT,1151) JOB5 + END IF + ELSE + WRITE (LUNRPT,1152) JOB5 + END IF + IF (NETA.LT.0) THEN + WRITE (LUNRPT,1200) -NETA + ELSE + WRITE (LUNRPT,1210) NETA + END IF + WRITE (LUNRPT,1300) TAUFAC + + +C PRINT STOPPING CRITERIA + + WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT + + +C PRINT INITIAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,1500) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,1600) WSS + IF (ISODR) THEN + WRITE (LUNRPT,1610) WSSDEL,WSSEPS + END IF + END IF + + + IF (IPR.GE.2) THEN + + +C PRINT FUNCTION PARAMETER DATA + + WRITE (LUNRPT,4000) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,4110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,4120) + ELSE + WRITE (LUNRPT,4200) + END IF + DO 130 J=1,NP + IF (IFIXB(1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (IFIXB(J).NE.0) THEN + TEMPC1 = ' NO' + ELSE + TEMPC1 = ' YES' + END IF + END IF + IF (ANAJAC) THEN + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + ITEMP = -1 + DO 110 L=1,NQ + ITEMP = MAX(ITEMP,MSGB(L,J)) + 110 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (SSF(1).LT.ZERO) THEN + TEMP1 = ABS(SSF(1)) + ELSE + TEMP1 = SSF(J) + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2 + ELSE + IF (CDJAC) THEN + TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) + ELSE + TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) + END IF + WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2 + END IF + 130 CONTINUE + +C PRINT EXPLANATORY VARIABLE DATA + + IF (ISODR) THEN + WRITE (LUNRPT,2010) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,2110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,2120) + ELSE + WRITE (LUNRPT,2130) + END IF + ELSE + WRITE (LUNRPT,2020) + WRITE (LUNRPT,2140) + END IF + IF (ISODR) THEN + DO 240 J = 1,M + TEMPC0 = '1,' + DO 230 I=1,N,N-1 + + IF (IFIXX(1,1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + ELSE + IF (IFIXX(I,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + END IF + END IF + + IF (TT(1,1).LT.ZERO) THEN + TEMP1 = ABS(TT(1,1)) + ELSE + IF (LDTT.EQ.1) THEN + TEMP1 = TT(1,J) + ELSE + TEMP1 = TT(I,J) + END IF + END IF + + IF (WD(1,1,1).LT.ZERO) THEN + TEMP2 = ABS(WD(1,1,1)) + ELSE + IF (LDWD.EQ.1) THEN + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(1,1,J) + ELSE + TEMP2 = WD(1,J,J) + END IF + ELSE + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(I,1,J) + ELSE + TEMP2 = WD(I,J,J) + END IF + END IF + END IF + + IF (ANAJAC) THEN + IF (CHKJAC .AND. + + (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. + + (I.EQ.1))) THEN + ITEMP = -1 + DO 210 L=1,NQ + ITEMP = MAX(ITEMP,MSGD(L,J)) + 210 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + END IF + ELSE + TEMPC2 = ' ' + IF (CDJAC) THEN + TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) + ELSE + TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5210) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + ELSE + WRITE (LUNRPT,5220) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + END IF + END IF + + TEMPC0 = 'N,' + + 230 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 240 CONTINUE + ELSE + + DO 260 J = 1,M + TEMPC0 = '1,' + DO 250 I=1,N,N-1 + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J) + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J) + END IF + TEMPC0 = 'N,' + 250 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 260 CONTINUE + END IF + +C PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS + + IF (.NOT.IMPLCT) THEN + WRITE (LUNRPT,3000) + WRITE (LUNRPT,3100) + DO 310 L=1,NQ + TEMPC0 = '1,' + DO 300 I=1,N,N-1 + IF (WE(1,1,1).LT.ZERO) THEN + TEMP1 = ABS(WE(1,1,1)) + ELSE IF (LDWE.EQ.1) THEN + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(1,1,L) + ELSE + TEMP1 = WE(1,L,L) + END IF + ELSE + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(I,1,L) + ELSE + TEMP1 = WE(I,L,L) + END IF + END IF + IF (NQ.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,L,Y(I,L),TEMP1 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,L,Y(I,L),TEMP1 + END IF + TEMPC0 = 'N,' + 300 CONTINUE + IF (L.LT.NQ) WRITE (LUNRPT,6000) + 310 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- PROBLEM SIZE:'/ + + ' N = ',I5, + + ' (NUMBER WITH NONZERO WEIGHT = ',I5,')'/ + + ' NQ = ',I5/ + + ' M = ',I5/ + + ' NP = ',I5, + + ' (NUMBER UNFIXED = ',I5,')') + 1100 FORMAT + + (/' --- CONTROL VALUES:'/ + + ' JOB = ',I5.5/ + + ' = ABCDE, WHERE') + 1110 FORMAT + + (' A=',I1,' ==> FIT IS A RESTART.') + 1111 FORMAT + + (' A=',I1,' ==> FIT IS NOT A RESTART.') + 1120 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' TO ZERO.') + 1121 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' BY USER.') + 1122 FORMAT + + (' B=',I1,' ==> DELTAS ARE FIXED AT', + + ' ZERO SINCE E=',I1,'.') + 1130 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' BE COMPUTED USING') + 1131 FORMAT + + (' DERIVATIVES RE-', + + 'EVALUATED AT THE SOLUTION.') + 1132 FORMAT + + (' DERIVATIVES FROM THE', + + ' LAST ITERATION.') + 1133 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' NOT BE COMPUTED.') + 1140 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' SUPPLIED BY USER.') + 1141 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR QUESTIONABLE.') + 1142 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR CORRECT.') + 1143 FORMAT + + (' DERIVATIVES WERE NOT', + + ' CHECKED.') + 1144 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY CENTRAL', + + ' DIFFERENCES.') + 1145 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY FORWARD', + + ' DIFFERENCES.') + 1150 FORMAT + + (' E=',I1,' ==> METHOD IS IMPLICIT ODR.') + 1151 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT ODR.') + 1152 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT OLS.') + 1200 FORMAT + + (' NDIGIT = ',I5,' (ESTIMATED BY ODRPACK)') + 1210 FORMAT + + (' NDIGIT = ',I5,' (SUPPLIED BY USER)') + 1300 FORMAT + + (' TAUFAC = ',1P,D12.2) + 1400 FORMAT + + (/' --- STOPPING CRITERIA:'/ + + ' SSTOL = ',1P,D12.2, + + ' (SUM OF SQUARES STOPPING TOLERANCE)'/ + + ' PARTOL = ',1P,D12.2, + + ' (PARAMETER STOPPING TOLERANCE)'/ + + ' MAXIT = ',I5, + + ' (MAXIMUM NUMBER OF ITERATIONS)') + 1500 FORMAT + + (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =', + + 17X,1P,D17.8) + 1510 FORMAT + + ( ' INITIAL PENALTY FUNCTION VALUE =',1P,D17.8/ + + ' PENALTY TERM =',1P,D17.8/ + + ' PENALTY PARAMETER =',1P,D10.1) + 1600 FORMAT + + (/' --- INITIAL WEIGHTED SUM OF SQUARES =', + + 17X,1P,D17.8) + 1610 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,D17.8) + 2010 FORMAT + + (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:') + 2020 FORMAT + + (/' --- EXPLANATORY VARIABLE SUMMARY:') + 2110 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2120 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT '/ + + ' ', + + ' '/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2130 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) (STPD)'/) + 2140 FORMAT + + (/' INDEX X(I,J)'/ + + ' (I,J) '/) + 3000 FORMAT + + (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT', + + ' SUMMARY:') + 3100 FORMAT + + (/' INDEX Y(I,L) WEIGHT'/ + + ' (I,L) (WE)'/) + 4000 FORMAT + + (/' --- FUNCTION PARAMETER SUMMARY:') + 4110 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4120 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' '/ + + ' ', + + ' '/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4200 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (K) (IFIXB) (SCLB)', + + ' (STPB)'/) + 4310 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13) + 4320 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5) + 5110 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5120 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5210 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 5220 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 6000 FORMAT + + (' ') + END +*DODPC2 + SUBROUTINE DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) +C***BEGIN PROLOGUE DODPC2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE GENERATE ITERATION REPORTS +C***END PROLOGUE DODPC2 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS + INTEGER + + IPR,LUNRPT,NFEV,NITER,NP + LOGICAL + + FSTITR,IMPLCT,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + RATIO,ZERO + INTEGER + + J,K,L + CHARACTER GN*3 + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C BETA: THE FUNCTION PARAMETERS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). +C GN: THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON +C STEP WAS TAKEN. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RATIO: THE RATIO OF TAU TO PNORM. +C TAU: THE TRUST REGION DIAMETER. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC2 + + + IF (FSTITR) THEN + IF (IPR.EQ.1) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1121) + ELSE + WRITE (LUNRPT,1122) + END IF + ELSE + IF (IMPLCT) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + END IF + END IF + IF (PRTPEN) THEN + WRITE (LUNRPT,1133) PNLTY + END IF + + IF (ALPHA.EQ.ZERO) THEN + GN = 'YES' + ELSE + GN = ' NO' + END IF + IF (PNORM.NE.ZERO) THEN + RATIO = TAU/PNORM + ELSE + RATIO = ZERO + END IF + IF (IPR.EQ.1) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN + ELSE + J = 1 + K = MIN(3,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,BETA(J) + ELSE + WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,K,(BETA(L),L=J,K) + END IF + IF (NP.GT.3) THEN + DO 10 J=4,NP,3 + K = MIN(J+2,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1151) J,BETA(J) + ELSE + WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) + END IF + 10 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1121 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----') + 1122 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----'/) + 1131 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----') + 1132 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----'/) + 1133 FORMAT + + (/' PENALTY PARAMETER VALUE = ', 1P,E10.1) + 1141 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) + 1142 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) + 1151 FORMAT + + (76X,I3,1P,D16.8) + 1152 FORMAT + + (70X,I3,' TO',I3,1P,3D16.8) + END +*DODPC3 + SUBROUTINE DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB2,F,DELTA) +C***BEGIN PROLOGUE DODPC3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE FINAL SUMMARY REPORT +C***END PROLOGUE DODPC3 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS + INTEGER + + IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, + + N,NFEV,NITER,NJEV,NP,NPP,NQ + LOGICAL + + ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP) + INTEGER + + IFIXB2(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TVAL + INTEGER + + D1,D2,D3,D4,D5,I,J,K,L,NPLM1 + CHARACTER FMT1*90 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPT + EXTERNAL + + DPPT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C D1: THE FIRST DIGIT OF INFO. +C D2: THE SECOND DIGIT OF INFO. +C D3: THE THIRD DIGIT OF INFO. +C D4: THE FOURTH DIGIT OF INFO. +C D5: THE FIFTH DIGIT OF INFO. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE ESTIMATED VALUES OF EPSILON. +C FMT1: A CHARACTER*90 VARIABLE USED FOR FORMATS. +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB2: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE +C ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK +C DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1, +C 0, AND -1, RESPECTIVELY. IF IFIXB2 IS -2, THEN NO ATTEMPT +C WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPR: THE VARIABLE INDICATING WHAT IS TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPLM1: THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS +C TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE +C MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. +C TVAL: THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE +C T DISTRIBUTION. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. + + +C***FIRST EXECUTABLE STATEMENT DODPC3 + + + D1 = INFO/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT STOPPING CONDITIONS + + WRITE (LUNRPT,1000) + IF (INFO.LE.9) THEN + IF (INFO.EQ.1) THEN + WRITE (LUNRPT,1011) INFO + ELSE IF (INFO.EQ.2) THEN + WRITE (LUNRPT,1012) INFO + ELSE IF (INFO.EQ.3) THEN + WRITE (LUNRPT,1013) INFO + ELSE IF (INFO.EQ.4) THEN + WRITE (LUNRPT,1014) INFO + ELSE IF (INFO.LE.9) THEN + WRITE (LUNRPT,1015) INFO + END IF + ELSE IF (INFO.LE.9999) THEN + +C PRINT WARNING DIAGNOSTICS + + WRITE (LUNRPT,1020) INFO + IF (D2.EQ.1) WRITE (LUNRPT,1021) + IF (D3.EQ.1) WRITE (LUNRPT,1022) + IF (D4.EQ.1) WRITE (LUNRPT,1023) + IF (D4.EQ.2) WRITE (LUNRPT,1024) + IF (D5.EQ.1) THEN + WRITE (LUNRPT,1031) + ELSE IF (D5.EQ.2) THEN + WRITE (LUNRPT,1032) + ELSE IF (D5.EQ.3) THEN + WRITE (LUNRPT,1033) + ELSE IF (D5.EQ.4) THEN + WRITE (LUNRPT,1034) + ELSE IF (D5.LE.9) THEN + WRITE (LUNRPT,1035) D5 + END IF + ELSE + +C PRINT ERROR MESSAGES + + WRITE (LUNRPT,1040) INFO + IF (D1.EQ.5) THEN + WRITE (LUNRPT,1042) + IF (D2.NE.0) WRITE (LUNRPT,1043) D2 + IF (D3.EQ.3) THEN + WRITE (LUNRPT,1044) D3 + ELSE IF (D3.NE.0) THEN + WRITE (LUNRPT,1045) D3 + END IF + ELSE IF (D1.EQ.6) THEN + WRITE (LUNRPT,1050) + ELSE + WRITE (LUNRPT,1060) D1 + END IF + END IF + +C PRINT MISC. STOPPING INFO + + WRITE (LUNRPT,1300) NITER + WRITE (LUNRPT,1310) NFEV + IF (ANAJAC) WRITE (LUNRPT,1320) NJEV + WRITE (LUNRPT,1330) IRANK + WRITE (LUNRPT,1340) RCOND + WRITE (LUNRPT,1350) ISTOP + +C PRINT FINAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,2000) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,2100) WSS + IF (ISODR) THEN + WRITE (LUNRPT,2110) WSSDEL,WSSEPS + END IF + END IF + IF (DIDVCV) THEN + WRITE (LUNRPT,2200) SQRT(RVAR),IDF + END IF + + NPLM1 = 3 + +C PRINT ESTIMATED BETA'S, AND, +C IF, FULL RANK, THEIR STANDARD ERRORS + + WRITE (LUNRPT,3000) + IF (DIDVCV) THEN + WRITE (LUNRPT,7300) + TVAL = DPPT(0.975D0,IDF) + DO 10 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J), + + BETA(J)-TVAL*SDBETA(J), + + BETA(J)+TVAL*SDBETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 10 CONTINUE + IF (.NOT.REDOJ) WRITE (LUNRPT,7310) + ELSE + IF (DOVCV) THEN + IF (D1.LE.5) THEN + WRITE (LUNRPT,7410) + ELSE + WRITE (LUNRPT,7420) + END IF + END IF + + IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN + IF (NP.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 20 J=1,NP,NPLM1+1 + K = MIN(J+NPLM1,NP) + IF (K.EQ.J) THEN + WRITE (LUNRPT,8100) J,BETA(J) + ELSE + WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) + END IF + 20 CONTINUE + IF (NITER.GE.1) THEN + WRITE (LUNRPT,8800) + ELSE + WRITE (LUNRPT,8900) + END IF + ELSE + WRITE (LUNRPT,7500) + DO 30 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8500) J,BETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 30 CONTINUE + END IF + END IF + + IF (IPR.EQ.1) RETURN + + +C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF +C COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE. + + IF (IMPLCT .AND. (M.LE.4)) THEN + WRITE (LUNRPT,4100) + WRITE (FMT1,9110) M + WRITE (LUNRPT,FMT1) (J,J=1,M) + DO 40 I=1,N + WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) + 40 CONTINUE + + ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN + WRITE (LUNRPT,4110) + WRITE (FMT1,9120) NQ,M + WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) + DO 50 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) + 50 CONTINUE + + ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN + WRITE (LUNRPT,4120) + WRITE (FMT1,9130) NQ + WRITE (LUNRPT,FMT1) (L,L=1,NQ) + DO 60 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) + 60 CONTINUE + ELSE + +C PRINT EPSILON'S AND DELTA'S SEPARATELY + + IF (.NOT.IMPLCT) THEN + +C PRINT EPSILON'S + + DO 80 J=1,NQ + WRITE (LUNRPT,4200) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 70 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,F(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) + END IF + 70 CONTINUE + 80 CONTINUE + END IF + +C PRINT DELTA'S + + IF (ISODR) THEN + DO 100 J=1,M + WRITE (LUNRPT,4300) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 90 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,DELTA(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) + END IF + 90 CONTINUE + 100 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- STOPPING CONDITIONS:') + 1011 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.') + 1012 FORMAT + + (' INFO = ',I5,' ==> PARAMETER CONVERGENCE.') + 1013 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND', + + ' PARAMETER CONVERGENCE.') + 1014 FORMAT + + (' INFO = ',I5,' ==> ITERATION LIMIT REACHED.') + 1015 FORMAT + + (' INFO = ',I5,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1020 FORMAT + + (' INFO = ',I5.4/ + + ' = ABCD, WHERE A NONZERO VALUE FOR DIGIT A,', + + ' B, OR C INDICATES WHY'/ + + ' THE RESULTS MIGHT BE QUESTIONABLE,', + + ' AND DIGIT D INDICATES'/ + + ' THE ACTUAL STOPPING CONDITION.') + 1021 FORMAT + + (' A=1 ==> DERIVATIVES ARE', + + ' QUESTIONABLE.') + 1022 FORMAT + + (' B=1 ==> USER SET ISTOP TO', + + ' NONZERO VALUE DURING LAST'/ + + ' CALL TO SUBROUTINE FCN.') + 1023 FORMAT + + (' C=1 ==> DERIVATIVES ARE NOT', + + ' FULL RANK AT THE SOLUTION.') + 1024 FORMAT + + (' C=2 ==> DERIVATIVES ARE ZERO', + + ' RANK AT THE SOLUTION.') + 1031 FORMAT + + (' D=1 ==> SUM OF SQUARES CONVERGENCE.') + 1032 FORMAT + + (' D=2 ==> PARAMETER CONVERGENCE.') + 1033 FORMAT + + (' D=3 ==> SUM OF SQUARES CONVERGENCE', + + ' AND PARAMETER CONVERGENCE.') + 1034 FORMAT + + (' D=4 ==> ITERATION LIMIT REACHED.') + 1035 FORMAT + + (' D=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1040 FORMAT + + (' INFO = ',I5.5/ + + ' = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN', + + ' DIGIT INDICATES AN'/ + + ' ABNORMAL STOPPING CONDITION.') + 1042 FORMAT + + (' A=5 ==> USER STOPPED COMPUTATIONS', + + ' IN SUBROUTINE FCN.') + 1043 FORMAT + + (' B=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' FUNCTION EVALUATION.') + 1044 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED BECAUSE'/ + + ' DERIVATIVES WITH', + + ' RESPECT TO DELTA WERE'/ + + ' COMPUTED BY', + + ' SUBROUTINE FCN WHEN'/ + + ' FIT IS OLS.') + 1045 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' JACOBIAN EVALUATION.') + 1050 FORMAT + + (' A=6 ==> NUMERICAL INSTABILITIES', + + ' HAVE BEEN DETECTED,'/ + + ' POSSIBLY INDICATING', + + ' A DISCONTINUITY IN THE'/ + + ' DERIVATIVES OR A POOR', + + ' POOR CHOICE OF PROBLEM'/ + + ' SCALE OR WEIGHTS.') + 1060 FORMAT + + (' A=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1300 FORMAT + + (' NITER = ',I5, + + ' (NUMBER OF ITERATIONS)') + 1310 FORMAT + + (' NFEV = ',I5, + + ' (NUMBER OF FUNCTION EVALUATIONS)') + 1320 FORMAT + + (' NJEV = ',I5, + + ' (NUMBER OF JACOBIAN EVALUATIONS)') + 1330 FORMAT + + (' IRANK = ',I5, + + ' (RANK DEFICIENCY)') + 1340 FORMAT + + (' RCOND = ',1P,D12.2, + + ' (INVERSE CONDITION NUMBER)') +*1341 FORMAT +* + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', +* + ' DIGITS IN RESULTS;'/ +* + ' SEE ODRPACK REFERENCE', +* + ' GUIDE, SECTION 4.C.') + 1350 FORMAT + + (' ISTOP = ',I5, + + ' (RETURNED BY USER FROM', + + ' SUBROUTINE FCN)') + 2000 FORMAT + + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ', + + 17X,1P,D17.8) + 2010 FORMAT + + ( ' FINAL PENALTY FUNCTION VALUE = ',1P,D17.8/ + + ' PENALTY TERM = ',1P,D17.8/ + + ' PENALTY PARAMETER = ',1P,D10.1) + 2100 FORMAT + + (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,D17.8) + 2110 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8) + 2200 FORMAT + + (/' --- RESIDUAL STANDARD DEVIATION = ', + + 17X,1P,D17.8/ + + ' DEGREES OF FREEDOM =',I5) + 3000 FORMAT + + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:') + 4100 FORMAT + + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:') + 4110 FORMAT + + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:') + 4120 FORMAT + + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:') + 4130 FORMAT(5X,I5,1P,5D16.8) + 4200 FORMAT + + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:') + 4300 FORMAT + + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:') + 7100 FORMAT + + (/' INDEX VALUE'/) + 7200 FORMAT + + (/' INDEX VALUE -------------->'/) + 7300 FORMAT + + (/' BETA S.D. BETA', + + ' ---- 95% CONFIDENCE INTERVAL ----'/) + 7310 FORMAT + + (/' N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE', + + ' COMPUTED USING'/ + + ' DERIVATIVES CALCULATED AT THE BEGINNING', + + ' OF THE LAST ITERATION,'/ + + ' AND NOT USING DERIVATIVES RE-EVALUATED AT THE', + + ' FINAL SOLUTION.') + 7410 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED BECAUSE'/ + + ' THE DERIVATIVES WERE NOT AVAILABLE. EITHER MAXIT', + + ' IS 0 AND THE THIRD'/ + + ' DIGIT OF JOB IS GREATER THAN 1, OR THE MOST', + + ' RECENTLY TRIED VALUES OF'/ + + ' BETA AND/OR X+DELTA WERE IDENTIFIED AS', + + ' UNACCEPTABLE BY USER SUPPLIED'/ + + ' SUBROUTINE FCN.') + 7420 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED.'/ + + ' (SEE INFO ABOVE.)') + 7500 FORMAT + + (/' BETA STATUS') + 8100 FORMAT + + (11X,I5,1P,D16.8) + 8200 FORMAT + + (3X,I5,' TO',I5,1P,7D16.8) + 8400 FORMAT + + (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8) + 8500 FORMAT + + (3X,I5,1X,1P,D16.8,6X,'ESTIMATED') + 8600 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' FIXED') + 8700 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' DROPPED') + 8800 FORMAT + + (/' N.B. NO PARAMETERS WERE FIXED BY THE USER OR', + + ' DROPPED AT THE LAST'/ + + ' ITERATION BECAUSE THEY CAUSED THE MODEL TO BE', + + ' RANK DEFICIENT.') + 8900 FORMAT + + (/' N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER', + + ' VALUES BECAUSE'/ + + ' MAXIT=0.') + 9110 FORMAT + + ('(/'' I'',', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9120 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')''),', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9130 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')'')/)') + + END +*DODPCR + SUBROUTINE DODPCR + + (IPR,LUNRPT, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,SDBETA, + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) +C***BEGIN PROLOGUE DODPCR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE COMPUTATION REPORTS +C***END PROLOGUE DODPCR + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + + SSTOL,TAU,TAUFAC + INTEGER + + IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, + + LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, + + NITER,NJEV,NNZW,NP,NPP,NQ + LOGICAL + + DIDVCV,FSTITR,HEAD,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP), + + STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + DOUBLE PRECISION + + PNLTY + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + CHARACTER TYP*3 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TT: THE SCALING VALUES FOR DELTA. +C TYP: THE CHARACTER*3 STRING "ODR" OR "OLS". +C WE: THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODPCR + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + PNLTY = ABS(WE(1,1,1)) + + IF (HEAD) THEN + CALL DODPHD(HEAD,LUNRPT) + END IF + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + +C PRINT INITIAL SUMMARY + + IF (IFLAG.EQ.1) THEN + WRITE (LUNRPT,1200) TYP + CALL DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB(1),MSGB(2),MSGD(1),MSGD(2), + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS(1),WSS(2),WSS(3)) + +C PRINT ITERATION REPORTS + + ELSE IF (IFLAG.EQ.2) THEN + + IF (FSTITR) THEN + WRITE (LUNRPT,1300) TYP + END IF + CALL DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) + +C PRINT FINAL SUMMARY + + ELSE IF (IFLAG.EQ.3) THEN + + WRITE (LUNRPT,1400) TYP + CALL DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB,F,DELTA) + END IF + + RETURN + +C FORMAT STATEMENTS + + 1200 FORMAT + + (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + 1300 FORMAT + + (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***') + 1400 FORMAT + + (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + + END +*DODPE1 + SUBROUTINE DODPE1 + + (UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) +C***BEGIN PROLOGUE DODPE1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS +C***END PROLOGUE DODPE1 + +C...SCALAR ARGUMENTS + INTEGER + + D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, + + LIWKMN,LWKMN,M,N,NQ,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE1 + + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION +C PARAMETERS + + IF (D1.EQ.1) THEN + IF (D2.NE.0) THEN + WRITE(UNIT,1100) + END IF + IF (D3.NE.0) THEN + WRITE(UNIT,1200) + END IF + IF (D4.NE.0) THEN + WRITE(UNIT,1300) + END IF + IF (D5.NE.0) THEN + WRITE(UNIT,1400) + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION +C PARAMETERS + + ELSE IF (D1.EQ.2) THEN + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + WRITE(UNIT,2110) + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,2120) + END IF + END IF + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN + WRITE(UNIT,2210) + END IF + IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2220) + END IF + IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2230) + END IF + END IF + + IF (D4.NE.0) THEN + IF (D4.EQ.1 .OR. D4.EQ.3) THEN + WRITE(UNIT,2310) + END IF + IF (D4.EQ.2 .OR. D4.EQ.3) THEN + WRITE(UNIT,2320) + END IF + END IF + + IF (D5.NE.0) THEN + IF (D5.EQ.1 .OR. D5.EQ.3) THEN + WRITE(UNIT,2410) LWKMN + END IF + IF (D5.EQ.2 .OR. D5.EQ.3) THEN + WRITE(UNIT,2420) LIWKMN + END IF + END IF + + ELSE IF (D1.EQ.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + IF (LDSCLD.GE.N) THEN + WRITE(UNIT,3110) + ELSE + WRITE(UNIT,3120) + END IF + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,3130) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3) THEN + IF (LDSTPD.GE.N) THEN + WRITE(UNIT,3210) + ELSE + WRITE(UNIT,3220) + END IF + END IF + IF (D3.EQ.2 .OR. D3.EQ.3) THEN + WRITE(UNIT,3230) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS + + IF (D4.NE.0) THEN + IF (D4.EQ.1) THEN + IF (LDWE.GE.N) THEN + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3310) + ELSE + WRITE(UNIT,3320) + END IF + ELSE + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3410) + ELSE + WRITE(UNIT,3420) + END IF + END IF + END IF + IF (D4.EQ.2) THEN + WRITE(UNIT,3500) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS + + IF (D5.NE.0) THEN + IF (LDWD.GE.N) THEN + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4310) + ELSE + WRITE(UNIT,4320) + END IF + ELSE + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4410) + ELSE + WRITE(UNIT,4420) + END IF + END IF + END IF + + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (/' ERROR : N IS LESS THAN ONE.') + 1200 FORMAT + + (/' ERROR : M IS LESS THAN ONE.') + 1300 FORMAT + + (/' ERROR : NP IS LESS THAN ONE'/ + + ' OR NP IS GREATER THAN N.') + 1400 FORMAT + + (/' ERROR : NQ IS LESS THAN ONE.') + 2110 FORMAT + + (/' ERROR : LDX IS LESS THAN N.') + 2120 FORMAT + + (/' ERROR : LDY IS LESS THAN N.') + 2210 FORMAT + + (/' ERROR : LDIFX IS LESS THAN N'/ + + ' AND LDIFX IS NOT EQUAL TO ONE.') + 2220 FORMAT + + (/' ERROR : LDSCLD IS LESS THAN N'/ + + ' AND LDSCLD IS NOT EQUAL TO ONE.') + 2230 FORMAT + + (/' ERROR : LDSTPD IS LESS THAN N'/ + + ' AND LDSTPD IS NOT EQUAL TO ONE.') + 2310 FORMAT + + (/' ERROR : LDWE IS LESS THAN N'/ + + ' AND LDWE IS NOT EQUAL TO ONE OR'/ + + ' OR'/ + + ' LD2WE IS LESS THAN NQ'/ + + ' AND LD2WE IS NOT EQUAL TO ONE.') + 2320 FORMAT + + (/' ERROR : LDWD IS LESS THAN N'/ + + ' AND LDWD IS NOT EQUAL TO ONE.') + 2410 FORMAT + + (/' ERROR : LWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') + 2420 FORMAT + + (/' ERROR : LIWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', + + ' IWORK.') + 3110 FORMAT + + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3120 FORMAT + + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3130 FORMAT + + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' SCLB MUST BE GREATER THAN ZERO.') + 3210 FORMAT + + (/' ERROR : STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3220 FORMAT + + (/' ERROR : STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3230 FORMAT + + (/' ERROR : STPB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' STPB MUST BE GREATER THAN ZERO.') + 3310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' SEMIDEFINITE. WHEN WE(1,1,1) IS GREATER THAN'/ + + ' OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/ + + ' EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/ + + ' TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/ + + ' MUST BE POSITIVE SEMIDEFINITE.') + 3320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/ + + ' ELEMENT. WHEN WE(1,1,1) IS GREATER THAN OR'/ + + ' EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/ + + ' TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/ + + ' (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/ + + ' NEGATIVE ELEMENTS.') + 3410 FORMAT + + (/' ERROR : THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/ + + ' NOT POSITIVE SEMIDEFINITE. WHEN WE(1,1,1) IS'/ + + ' GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/ + + ' TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/ + + ' THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/ + + ' SEMIDEFINITE.') + 3420 FORMAT + + (/' ERROR : THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/ + + ' A NEGATIVE ELEMENT. WHEN WE(1,1,1) IS GREATER'/ + + ' THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/ + + ' AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/ + + ' ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.') + 3500 FORMAT + + (/' ERROR : THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/ + + ' LESS THAN NP.') + 4310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' DEFINITE. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/ + + ' OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/ + + ' DEFINITE.') + 4320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/ + + ' ELEMENT. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/ + + ' ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.') + 4410 FORMAT + + (/' ERROR : THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/ + + ' NOT POSITIVE DEFINITE. WHEN WD(1,1,1) IS'/ + + ' GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/ + + ' (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.') + 4420 FORMAT + + (/' ERROR : THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/ + + ' NONPOSITIVE ELEMENT. WHEN WD(1,1,1) IS GREATER'/ + + ' THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/ + + ' EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/ + + ' HAVE ONLY POSITIVE ELEMENTS.') + END +*DODPE2 + SUBROUTINE DODPE2 + + (UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPE2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT +C***END PROLOGUE DODPE2 + +C...SCALAR ARGUMENTS + INTEGER + + M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + INTEGER + + I,J,K,L + CHARACTER FLAG*1,TYP*3 + +C...LOCAL ARRAYS + LOGICAL + + FTNOTE(0:7) + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FLAG: THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS. +C FTNOTE: THE ARRAY CONTROLING FOOTNOTES. +C I: AN INDEX VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C TYP: THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPE2 + + +C SET UP FOR FOOTNOTES + + DO 10 I=0,7 + FTNOTE(I) = .FALSE. + 10 CONTINUE + + DO 40 L=1,NQ + IF (MSGB1.GE.1) THEN + DO 20 I=1,NP + IF (MSGB(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGB(L,I)) = .TRUE. + END IF + 20 CONTINUE + END IF + + IF (MSGD1.GE.1) THEN + DO 30 I=1,M + IF (MSGD(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGD(L,I)) = .TRUE. + END IF + 30 CONTINUE + END IF + 40 CONTINUE + +C PRINT REPORT + + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + WRITE (UNIT,1000) TYP + + DO 70 L=1,NQ + + WRITE (UNIT,2100) L,NROW + WRITE (UNIT,2200) + + DO 50 I=1,NP + K = MSGB(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,3100) I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K + END IF + 50 CONTINUE + IF (ISODR) THEN + DO 60 I=1,M + K = MSGD(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,4100) NROW,I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,4200) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,4300) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K + END IF + 60 CONTINUE + END IF + 70 CONTINUE + +C PRINT FOOTNOTES + + IF (FTNOTE(0)) THEN + + WRITE (UNIT,5000) + IF (FTNOTE(1)) WRITE (UNIT,5100) + IF (FTNOTE(2)) WRITE (UNIT,5200) + IF (FTNOTE(3)) WRITE (UNIT,5300) + IF (FTNOTE(4)) WRITE (UNIT,5400) + IF (FTNOTE(5)) WRITE (UNIT,5500) + IF (FTNOTE(6)) WRITE (UNIT,5600) + IF (FTNOTE(7)) WRITE (UNIT,5700) + END IF + + IF (NETA.LT.0) THEN + WRITE (UNIT,6000) -NETA + ELSE + WRITE (UNIT,6100) NETA + END IF + WRITE (UNIT,7000) NTOL + +C PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED. + + WRITE (UNIT,8100) NROW + + DO 80 J=1,M + WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) + 80 CONTINUE + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3, + + ' ***'/) + 2100 FORMAT (/' FOR RESPONSE ',I2,' OF OBSERVATION ', I5/) + 2200 FORMAT (' ',' USER', + + ' ',' '/ + + ' ',' SUPPLIED', + + ' RELATIVE',' DERIVATIVE '/ + + ' DERIVATIVE WRT',' VALUE', + + ' DIFFERENCE',' ASSESSMENT '/) + 3100 FORMAT (' BETA(',I3,')', ' --- ', + + ' --- ',' UNCHECKED') + 3200 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 3300 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', + + ' --- ',' UNCHECKED') + 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 5000 FORMAT + + (/' NOTES:') + 5100 FORMAT + + (/' (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.') + 5200 FORMAT + + (/' (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS ONLY APPROXIMATELY ZERO.') + 5300 FORMAT + + (/' (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS NOT.') + 5400 FORMAT + + (/' (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE EITHER'/ + + ' THE RATIO OF RELATIVE CURVATURE TO RELATIVE', + + ' SLOPE IS TOO HIGH'/ + + ' OR THE SCALE IS WRONG.') + 5500 FORMAT + + (/' (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE THE'/ + + ' RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS', + + ' TOO HIGH.') + 5600 FORMAT + + (/' (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' HAVE AT LEAST 2 DIGITS IN COMMON.') + 5700 FORMAT + + (/' (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, AND'/ + + ' HAVE FEWER THAN 2 DIGITS IN COMMON. DERIVATIVE', + + ' CHECKING MUST'/ + + ' BE TURNED OFF IN ORDER TO PROCEED.') + 6000 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (ESTIMATED BY ODRPACK)') + 6100 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (SUPPLIED BY USER)') + 7000 FORMAT + + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ + + ' USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ + + ' USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED ', + + I5) + 8100 FORMAT + + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ', + + I5// + + ' -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/) + 8110 FORMAT + + (10X,'X(',I2,',',I2,')',1X,1P,3D16.8) + END +*DODPE3 + SUBROUTINE DODPE3 + + (UNIT,D2,D3) +C***BEGIN PROLOGUE DODPE3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE +C STOPPED IN USER SUPPLIED SUBROUTINES FCN +C***END PROLOGUE DODPE3 + +C...SCALAR ARGUMENTS + INTEGER + + D2,D3,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE3 + + +C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE +C STOPPED + + IF (D2.EQ.2) THEN + WRITE(UNIT,1100) + ELSE IF (D2.EQ.3) THEN + WRITE(UNIT,1200) + ELSE IF (D2.EQ.4) THEN + WRITE(UNIT,1300) + END IF + IF (D3.EQ.2) THEN + WRITE(UNIT,1400) + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/ + + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + + ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE '/ + + ' REGRESSION PROCEDURE CAN CONTINUE.') + 1200 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/ + + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ + + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ + + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ + + ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. THE '/ + + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1300 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ + + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ + + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ + + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ + + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ + + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, '/ + + ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. '/ + + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1400 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/ + + ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/ + + ' BETA AND DELTA SUPPLIED BY THE USER. THE INITIAL '/ + + ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/ + + ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/ + + ' CONTINUE.') + END +*DODPER + SUBROUTINE DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + FJACB,FJACD, + + DIFF,MSGB,ISODR,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPER +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS +C***END PROLOGUE DODPER + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, + + M,N,NETA,NP,NQ,NROW,NTOL + LOGICAL + + ISODR,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + INTEGER + + D1,D2,D3,D4,D5,UNIT + LOGICAL + + HEAD + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODPE1,DODPE2,DODPE3,DODPHD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C XPLUSD: THE VALUES X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPER + + +C SET LOGICAL UNIT NUMBER FOR ERROR REPORT + + IF (LUNERR.EQ.0) THEN + RETURN + ELSE IF (LUNERR.LT.0) THEN + UNIT = 6 + ELSE + UNIT = LUNERR + END IF + +C PRINT HEADING + + HEAD = .TRUE. + CALL DODPHD(HEAD,UNIT) + +C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO + + D1 = MOD(INFO,100000)/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP + + IF (D1.GE.1 .AND. D1.LE.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN +C PROBLEM SPECIFICATION PARAMETERS +C DIMENSION SPECIFICATION PARAMETERS +C NUMBER OF GOOD DIGITS IN X +C WEIGHTS + + CALL DODPE1(UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) + + ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN + +C PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING + + CALL DODPE2(UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), + + XPLUSD,NROW,NETA,NTOL) + + ELSE IF (D1.EQ.5) THEN + +C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN + + CALL DODPE3(UNIT,D2,D3) + + END IF + +C PRINT CORRECT FORM OF CALL STATEMENT + + IF ((D1.GE.1 .AND. D1.LE.3) .OR. + + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + + (D1.EQ.5)) THEN + IF (SHORT) THEN + WRITE (UNIT,1100) + ELSE + WRITE (UNIT,1200) + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' 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)') + 1200 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' 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 +*DODPHD + SUBROUTINE DODPHD + + (HEAD,UNIT) +C***BEGIN PROLOGUE DODPHD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ODRPACK HEADING +C***END PROLOGUE DODPHD + +C...SCALAR ARGUMENTS + INTEGER + + UNIT + LOGICAL + + HEAD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. + + +C***FIRST EXECUTABLE STATEMENT DODPHD + + + IF (HEAD) THEN + WRITE(UNIT,1000) + HEAD = .FALSE. + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT ( + + ' ******************************************************* '/ + + ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/ + + ' ******************************************************* '/) + END +*DODSTP + SUBROUTINE DODSTP + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,KPVT, + + S,T,PHI,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODSTP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2_odr,DQRDC,DQRSL,DROT, +C DROTG,DSOLVE,DTRCO,DTRSL_odr,DVEVTR,DWGHT,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) +C***END PROLOGUE DODSTP + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA,EPSFCN,PHI,RCOND + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) + INTEGER + + KPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CO,ONE,SI,TEMP,ZERO + INTEGER + + I,IMAX,INF,IPVT,J,K,K1,K2,KP,L + LOGICAL + + ELIM,FORVCV + +C...LOCAL ARRAYS + DOUBLE PRECISION + + DUM(2) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DNRM2_odr + INTEGER + + IDAMAX + EXTERNAL + + DNRM2_odr,IDAMAX + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, + + DSOLVE,DTRCO,DTRSL_odr,DVEVTR,DWGHT,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C CO: THE COSINE FROM THE PLANE ROTATION. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DUM: A DUMMY ARRAY. +C ELIM: THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN +C WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT +C (ELIM=FALSE). +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C INF: THE RETURN CODE FROM LINPACK ROUTINES. +C IPVT: THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C K2: AN INDEXING VARIABLE. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C KPVT: THE PIVOT VECTOR. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C ONE: THE VALUE 1.0D0. +C PHI: THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C S: THE STEP FOR BETA. +C SI: THE SINE FROM THE PLANE ROTATION. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODSTP + + +C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE + +C SET UP KPVT IF ALPHA = 0 + + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + DO 10 K=1,NP + KPVT(K) = K + 10 CONTINUE + ELSE + IF (NPP.GE.1) THEN + KP = NPP-IRANK + ELSE + KP = NPP + END IF + END IF + + IF (ISODR) THEN + +C T = WD * DELTA = D*G2 + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N) + + DO 300 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE OMEGA, SUCH THAT +C TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD) +C INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD) + CALL DVEVTR(M,NQ,I, + + FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) + DO 110 L=1,NQ + OMEGA(L,L) = ONE + OMEGA(L,L) + 110 CONTINUE + CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) +C = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA) + DO 130 J=1,M + DO 120 L=1,NQ + WRK1(I,L,J) = FJACD(I,J,L) + 120 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4) + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2) + 130 CONTINUE + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 140 J=1,M + WRK5(J) = T(I,J) + 140 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + +C COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB + DO 170 K=1,KP + DO 150 L=1,NQ + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + 150 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4) + DO 160 L=1,NQ + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 160 CONTINUE + 170 CONTINUE + +C COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1) + DO 190 L=1,NQ + WRK2(I,L) = ZERO + DO 180 J=1,M + WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) + 180 CONTINUE + WRK2(I,L) = WRK2(I,L) - F(I,L) + 190 CONTINUE + +C COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1) + CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4) + 300 CONTINUE + + ELSE + DO 360 I=1,N + DO 350 L=1,NQ + DO 340 K=1,KP + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 340 CONTINUE + WRK2(I,L) = -F(I,L) + 350 CONTINUE + 360 CONTINUE + END IF + +C COMPUTE S + +C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) + + IF (ALPHA.EQ.ZERO) THEN + IPVT = 1 + DO 410 K=1,NP + KPVT(K) = 0 + 410 CONTINUE + ELSE + IPVT = 0 + END IF + + CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) + CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, + + QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C ELIMINATE ALPHA PART USING GIVENS ROTATIONS + + IF (ALPHA.NE.ZERO) THEN + CALL DZERO(NPP,1,S,NPP) + DO 430 K1=1,KP + CALL DZERO(KP,1,WRK3,KP) + WRK3(K1) = SQRT(ALPHA) + DO 420 K2=K1,KP + CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) + IF (KP-K2.GE.1) THEN + CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, + + WRK3(K2+1),1,CO,SI) + END IF + TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) + S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) + WRK2(K2,1) = TEMP + 420 CONTINUE + 430 CONTINUE + END IF + +C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY + + IF (NPP.GE.1) THEN + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + +C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR + + 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) + IF (RCOND.LE.EPSFCN) THEN + ELIM = .TRUE. + IMAX = IDAMAX(KP,U,1) + +C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT + + IF (IMAX.NE.KP) THEN + CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, + + QRAUX,WRK3,2) + K = KPVT(IMAX) + DO 450 I=IMAX,KP-1 + KPVT(I) = KPVT(I+1) + 450 CONTINUE + KPVT(KP) = K + END IF + KP = KP-1 + ELSE + ELIM = .FALSE. + END IF + IF (ELIM .AND. KP.GE.1) THEN + GO TO 440 + ELSE + IRANK = NPP-KP + END IF + END IF + END IF + + IF (FORVCV) RETURN + +C BACKSOLVE AND UNSCRAMBLE + + IF (NPP.GE.1) THEN + DO 510 I=KP+1,NPP + WRK2(I,1) = ZERO + 510 CONTINUE + IF (KP.GE.1) THEN + CALL DTRSL_odr(TFJACB,N*NQ,KP,WRK2,01,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + END IF + DO 520 I=1,NPP + IF (SS(1).GT.ZERO) THEN + S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) + ELSE + S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) + END IF + 520 CONTINUE + END IF + + IF (ISODR) THEN + +C NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE, +C WHERE T = WD * DELTA = D*G2 +C WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) + + DO 670 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 610 J=1,M + WRK5(J) = T(I,J) + 610 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + + DO 640 L=1,NQ + WRK2(I,L) = F(I,L) + DO 620 K=1,NPP + WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) + 620 CONTINUE + DO 630 J=1,M + WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) + 630 CONTINUE + 640 CONTINUE + + DO 660 J=1,M + WRK5(J) = ZERO + DO 650 L=1,NQ + WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) + 650 CONTINUE + T(I,J) = -(WRK5(J) + T(I,J)) + 660 CONTINUE + CALL DSOLVE(M,WRK4,M,T(I,1),N,4) + CALL DSOLVE(M,WRK4,M,T(I,1),N,2) + 670 CONTINUE + + END IF + +C COMPUTE PHI(ALPHA) FROM SCALED S AND T + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + PHI = DNRM2_odr(NPP+N*M,WRK,1) + ELSE + PHI = DNRM2_odr(NPP,WRK,1) + END IF + + RETURN + END +*DODVCV + SUBROUTINE DODVCV + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + EPSFCN,ISODR, + + VCV,SD, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODVCV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPODI,DODSTP +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C***END PROLOGUE DODVCV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSFCN,RCOND,RSS,RVAR + INTEGER + + IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ), + + FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), + + T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), + + WRK6(N*NQ,NP),WRK(LWRK) + INTEGER + + IFIXB(NP),JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,IUNFIX,J,JUNFIX,KP,L + LOGICAL + + FORVCV + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPODI,DODSTP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C IUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C J: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C JUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR FJACB. +C VCV: THE COVARIANCE MATRIX OF THE ESTIMATED BETAS. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C WRK6: A WORK ARRAY OF (N*NQ BY P) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODVCV + + + FORVCV = .TRUE. + ISTOPC = 0 + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ZERO,EPSFCN,ISODR, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,TEMP,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + KP = NPP - IRANK + CALL DPODI (WRK6,N*NQ,KP,WRK3,1) + + IDF = 0 + DO 150 I=1,N + DO 120 J=1,NPP + DO 110 L=1,NQ + IF (FJACB(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 110 CONTINUE + 120 CONTINUE + IF (ISODR) THEN + DO 140 J=1,M + DO 130 L=1,NQ + IF (FJACD(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 130 CONTINUE + 140 CONTINUE + END IF + 150 CONTINUE + + IF (IDF.GT.KP) THEN + IDF = IDF - KP + RVAR = RSS/IDF + ELSE + IDF = 0 + RVAR = RSS + END IF + +C STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER + + DO 200 I=1,NP + SD(I) = ZERO + 200 CONTINUE + DO 210 I=1,KP + SD(JPVT(I)) = WRK6(I,I) + 210 CONTINUE + IF (NP.GT.NPP) THEN + JUNFIX = NPP + DO 220 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + SD(J) = ZERO + ELSE + SD(J) = SD(JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 220 CONTINUE + END IF + +C STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER + + DO 310 I=1,NP + DO 300 J=1,I + VCV(I,J) = ZERO + 300 CONTINUE + 310 CONTINUE + DO 330 I=1,KP + DO 320 J=I+1,KP + IF (JPVT(I).GT.JPVT(J)) THEN + VCV(JPVT(I),JPVT(J))=WRK6(I,J) + ELSE + VCV(JPVT(J),JPVT(I))=WRK6(I,J) + END IF + 320 CONTINUE + 330 CONTINUE + IF (NP.GT.NPP) THEN + IUNFIX = NPP + DO 360 I=NP,1,-1 + IF (IFIXB(I).EQ.0) THEN + DO 340 J=I,1,-1 + VCV(I,J) = ZERO + 340 CONTINUE + ELSE + JUNFIX = NPP + DO 350 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + VCV(I,J) = ZERO + ELSE + VCV(I,J) = VCV(IUNFIX,JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 350 CONTINUE + IUNFIX = IUNFIX - 1 + END IF + 360 CONTINUE + END IF + + DO 380 I=1,NP + VCV(I,I) = SD(I) + SD(I) = SQRT(RVAR*SD(I)) + DO 370 J=1,I + VCV(J,I) = VCV(I,J) + 370 CONTINUE + 380 CONTINUE + +C UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX + DO 410 I=1,NP + IF (SSF(1).GT.ZERO) THEN + SD(I) = SD(I)/SSF(I) + ELSE + SD(I) = SD(I)/ABS(SSF(1)) + END IF + DO 400 J=1,NP + IF (SSF(1).GT.ZERO) THEN + VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) + ELSE + VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) + END IF + 400 CONTINUE + 410 CONTINUE + + RETURN + END +*DPACK + SUBROUTINE DPACK + + (N2,N1,V1,V2,IFIX) +C***BEGIN PROLOGUE DPACK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY_odr +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 +C***END PROLOGUE DPACK + +C...SCALAR ARGUMENTS + INTEGER + + N1,N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS FROM V2. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE +C UNFIXED ELEMENTS ARE TO BE EXTRACTED. + + +C***FIRST EXECUTABLE STATEMENT DPACK + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I=1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1+1 + V1(N1) = V2(I) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY_odr(N2,V2,1,V1,1) + END IF + + RETURN + END +*DPPNML + DOUBLE PRECISION FUNCTION DPPNML + + (P) +C***BEGIN PROLOGUE DPPNML +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--JUNE 1972. +C (UPDATED --SEPTEMBER 1975, +C NOVEMBER 1975, AND +C OCTOBER 1976. +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD +C DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION +C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --THE CODING AS PRESENTED BELOW IS ESSENTIALLY +C IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS +C AS ALGORTIHM 70 OF APPLIED STATISTICS. +C --AS POINTED OUT BY ODEH AND EVANS IN APPLIED +C STATISTICS, THEIR ALGORITHM REPRESENTES A +C SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED +C HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT +C FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4) +C TO 1.5*(10**-8). +C***REFERENCES ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL +C DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, +C PAGES 96-97. +C EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND +C RATIONAL APPROXIMATION, M. SC. THESIS, 1972, +C UNIVERSITY OF VICTORIA, B. C., CANADA. +C HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, +C PAGES 113, 191, 192. +C NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS +C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. +C FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE +C LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION +C (UNPUBLISHED PH.D. DISSERTATION, PRINCETON +C UNIVERSITY), 1969, PAGES 21-44, 229-231. +C FILLIBEN, "THE PERCENT POINT FUNCTION", +C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 1, 1970, PAGES 40-111. +C KELLEY STATISTICAL TABLES, 1948. +C OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16. +C PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR +C STATISTICIANS, VOLUME 1, 1954, PAGES 104-113. +C***END PROLOGUE DPPNML + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + +C...LOCAL SCALARS + DOUBLE PRECISION + + ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + LOG,SQRT + +C...DATA STATEMENTS + DATA + + P0,P1,P2,P3,P4 + + /-0.322232431088D0,-1.0D0,-0.342242088547D0, + + -0.204231210245D-1,-0.453642210148D-4/ + DATA + + Q0,Q1,Q2,Q3,Q4 + + /0.993484626060D-1,0.588581570495D0, + + 0.531103462366D0,0.103537752850D0,0.38560700634D-2/ + DATA + + ZERO,HALF,ONE,TWO + + /0.0D0,0.5D0,1.0D0,2.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ADEN: A VALUE USED IN THE APPROXIMATION. +C ANUM: A VALUE USED IN THE APPROXIMATION. +C HALF: THE VALUE 0.5D0. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. +C P0: A PARAMETER USED IN THE APPROXIMATION. +C P1: A PARAMETER USED IN THE APPROXIMATION. +C P2: A PARAMETER USED IN THE APPROXIMATION. +C P3: A PARAMETER USED IN THE APPROXIMATION. +C P4: A PARAMETER USED IN THE APPROXIMATION. +C Q0: A PARAMETER USED IN THE APPROXIMATION. +C Q1: A PARAMETER USED IN THE APPROXIMATION. +C Q2: A PARAMETER USED IN THE APPROXIMATION. +C Q3: A PARAMETER USED IN THE APPROXIMATION. +C Q4: A PARAMETER USED IN THE APPROXIMATION. +C R: THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED. +C T: A VALUE USED IN THE APPROXIMATION. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + IF (P.EQ.HALF) THEN + DPPNML = ZERO + + ELSE + R = P + IF (P.GT.HALF) R = ONE - R + T = SQRT(-TWO*LOG(R)) + ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) + ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) + DPPNML = T + (ANUM/ADEN) + + IF (P.LT.HALF) DPPNML = -DPPNML + END IF + + RETURN + + END +*DPPT + DOUBLE PRECISION FUNCTION DPPT + + (P, IDF) +C***BEGIN PROLOGUE DPPT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPNML +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--OCTOBER 1975.) +C (UPDATED --NOVEMBER 1975.) +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM. +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION +C FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM +C AND SO THE COMPUTED PERCENT POINTS ARE EXACT. +C --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION +C IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO +C IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1. +C***REFERENCES NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS +C SERIES 55, 1964, PAGE 949, FORMULA 26.7.5. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 2, 1970, PAGE 102, FORMULA 11. +C FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS +C OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN +C STATISTICAL ASSOCIATION, 1969, PAGES 683-688. +C HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A +C HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975, +C PAGES 120-123. +C***END PROLOGUE DPPT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + INTEGER + + IDF + +C...LOCAL SCALARS + DOUBLE PRECISION + + ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, + + B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, + + HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, + + Z,ZERO + INTEGER + + IPASS,MAXIT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPNML + EXTERNAL + + DPPNML + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ATAN,COS,SIN,SQRT + +C...DATA STATEMENTS + DATA + + B21 + + /4.0D0/ + DATA + + B31, B32, B33, B34 + + /96.0D0,5.0D0,16.0D0,3.0D0/ + DATA + + B41, B42, B43, B44, B45 + + /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ + DATA + + B51,B52,B53,B54,B55,B56 + + /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ + DATA + + ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN + + /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ARG: A VALUE USED IN THE APPROXIMATION. +C B21: A PARAMETER USED IN THE APPROXIMATION. +C B31: A PARAMETER USED IN THE APPROXIMATION. +C B32: A PARAMETER USED IN THE APPROXIMATION. +C B33: A PARAMETER USED IN THE APPROXIMATION. +C B34: A PARAMETER USED IN THE APPROXIMATION. +C B41: A PARAMETER USED IN THE APPROXIMATION. +C B42: A PARAMETER USED IN THE APPROXIMATION. +C B43: A PARAMETER USED IN THE APPROXIMATION. +C B44: A PARAMETER USED IN THE APPROXIMATION. +C B45: A PARAMETER USED IN THE APPROXIMATION. +C B51: A PARAMETER USED IN THE APPROXIMATION. +C B52: A PARAMETER USED IN THE APPROXIMATION. +C B53: A PARAMETER USED IN THE APPROXIMATION. +C B54: A PARAMETER USED IN THE APPROXIMATION. +C B55: A PARAMETER USED IN THE APPROXIMATION. +C B56: A PARAMETER USED IN THE APPROXIMATION. +C C: A VALUE USED IN THE APPROXIMATION. +C CON: A VALUE USED IN THE APPROXIMATION. +C DF: THE DEGREES OF FREEDOM. +C D1: A VALUE USED IN THE APPROXIMATION. +C D3: A VALUE USED IN THE APPROXIMATION. +C D5: A VALUE USED IN THE APPROXIMATION. +C D7: A VALUE USED IN THE APPROXIMATION. +C D9: A VALUE USED IN THE APPROXIMATION. +C EIGHT: THE VALUE 8.0D0. +C FIFTN: THE VALUE 15.0D0. +C HALF: THE VALUE 0.5D0. +C IDF: THE (POSITIVE INTEGER) DEGREES OF FREEDOM. +C IPASS: A VALUE USED IN THE APPROXIMATION. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE. +C PI: THE VALUE OF PI. +C PPFN: THE NORMAL PERCENT POINT VALUE. +C S: A VALUE USED IN THE APPROXIMATION. +C TERM1: A VALUE USED IN THE APPROXIMATION. +C TERM2: A VALUE USED IN THE APPROXIMATION. +C TERM3: A VALUE USED IN THE APPROXIMATION. +C TERM4: A VALUE USED IN THE APPROXIMATION. +C TERM5: A VALUE USED IN THE APPROXIMATION. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C Z: A VALUE USED IN THE APPROXIMATION. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + PI = 3.141592653589793238462643383279D0 + DF = IDF + MAXIT = 5 + + IF (IDF.LE.0) THEN + +C TREAT THE IDF < 1 CASE + DPPT = ZERO + + ELSE IF (IDF.EQ.1) THEN + +C TREAT THE IDF = 1 (CAUCHY) CASE + ARG = PI*P + DPPT = -COS(ARG)/SIN(ARG) + + ELSE IF (IDF.EQ.2) THEN + +C TREAT THE IDF = 2 CASE + TERM1 = SQRT(TWO)/TWO + TERM2 = TWO*P - ONE + TERM3 = SQRT(P*(ONE-P)) + DPPT = TERM1*TERM2/TERM3 + + ELSE IF (IDF.GE.3) THEN + +C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE + PPFN = DPPNML(P) + D1 = PPFN + D3 = PPFN**3 + D5 = PPFN**5 + D7 = PPFN**7 + D9 = PPFN**9 + TERM1 = D1 + TERM2 = (ONE/B21)*(D3+D1)/DF + TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) + TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) + TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) + DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 + + IF (IDF.EQ.3) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 3 CASE + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 70 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+S*C-CON)/(TWO*C**2) + 70 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.4) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 4 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 90 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) + 90 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.5) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 5 CASE + + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 110 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ + + ((EIGHT/THREE)*C**4) + 110 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.6) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 6 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 130 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ + + ((FIFTN/EIGHT)*C**5) + 130 CONTINUE + DPPT = SQRT(DF)*S/C + END IF + END IF + + RETURN + + END +*DPVB + SUBROUTINE DPVB + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVB, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP +C***END PROLOGUE DPVB + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVB,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAJ: THE CURRENT ESTIMATE OF THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVB: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVB + + +C COMPUTE PREDICTED VALUES + + BETAJ = BETA(J) + BETA(J) = BETA(J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + BETA(J) = BETAJ + + PVB = WRK2(NROW,LQ) + + RETURN + END +*DPVD + SUBROUTINE DPVD + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVD, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING +C X(NROW,J) + DELTA(NROW,J) + STP +C***END PROLOGUE DPVD + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVD,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + XPDJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVD: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPDJ: THE (NROW,J)TH ELEMENT OF XPLUSD. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVD + + +C COMPUTE PREDICTED VALUES + + XPDJ = XPLUSD(NROW,J) + XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + XPLUSD(NROW,J) = XPDJ + + PVD = WRK2(NROW,LQ) + + RETURN + END +*DSCALE + SUBROUTINE DSCALE + + (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) +C***BEGIN PROLOGUE DSCALE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL +C***END PROLOGUE DSCALE + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDSCL,LDSCLT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEMP,ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ONE,ZERO + + /1.0D0,0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDSCL: THE LEADING DIMENSION OF ARRAY SCL. +C LDSCLT: THE LEADING DIMENSION OF ARRAY SCLT. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C ONE: THE VALUE 1.0D0. +C SCL: THE SCALE VALUES. +C SCLT: THE INVERSELY SCALED MATRIX. +C T: THE ARRAY TO BE INVERSELY SCALED BY SCL. +C TEMP: A TEMPORARY SCALAR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCALE + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (SCL(1,1).GE.ZERO) THEN + IF (LDSCL.GE.N) THEN + DO 80 J=1,M + DO 70 I=1,N + SCLT(I,J) = T(I,J)/SCL(I,J) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J=1,M + TEMP = ONE/SCL(1,J) + DO 90 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 90 CONTINUE + 100 CONTINUE + END IF + ELSE + TEMP = ONE/ABS(SCL(1,1)) + DO 120 J=1,M + DO 110 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + END IF + + RETURN + END +*DSCLB + SUBROUTINE DSCLB + + (NP,BETA,SSF) +C***BEGIN PROLOGUE DSCLB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR BETA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLB + +C...SCALAR ARGUMENTS + INTEGER + + NP + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SSF(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + BMAX,BMIN,ONE,TEN,ZERO + INTEGER + + K + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C BMAX: THE LARGEST NONZERO MAGNITUDE. +C BMIN: THE SMALLEST NONZERO MAGNITUDE. +C K: AN INDEXING VARIABLE. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SSF: THE SCALING VALUES FOR BETA. +C TEN: THE VALUE 10.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLB + + + BMAX = ABS(BETA(1)) + DO 10 K=2,NP + BMAX = MAX(BMAX,ABS(BETA(K))) + 10 CONTINUE + + IF (BMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF BETA ARE ZERO + + DO 20 K=1,NP + SSF(K) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + BMIN = BMAX + DO 30 K=1,NP + IF (BETA(K).NE.ZERO) THEN + BMIN = MIN(BMIN,ABS(BETA(K))) + END IF + 30 CONTINUE + BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE + DO 40 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + SSF(K) = TEN/BMIN + ELSE + IF (BIGDIF) THEN + SSF(K) = ONE/ABS(BETA(K)) + ELSE + SSF(K) = ONE/BMAX + END IF + END IF + 40 CONTINUE + + END IF + + RETURN + END +*DSCLD + SUBROUTINE DSCLD + + (N,M,X,LDX,TT,LDTT) +C***BEGIN PROLOGUE DSCLD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR DELTA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLD + +C...SCALAR ARGUMENTS + INTEGER + + LDTT,LDX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + TT(LDTT,M),X(LDX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEN,XMAX,XMIN,ZERO + INTEGER + + I,J + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C ONE: THE VALUE 1.0D0. +C TT: THE SCALING VALUES FOR DELTA. +C X: THE INDEPENDENT VARIABLE. +C XMAX: THE LARGEST NONZERO MAGNITUDE. +C XMIN: THE SMALLEST NONZERO MAGNITUDE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLD + + + DO 50 J=1,M + XMAX = ABS(X(1,J)) + DO 10 I=2,N + XMAX = MAX(XMAX,ABS(X(I,J))) + 10 CONTINUE + + IF (XMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO + + DO 20 I=1,N + TT(I,J) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + XMIN = XMAX + DO 30 I=1,N + IF (X(I,J).NE.ZERO) THEN + XMIN = MIN(XMIN,ABS(X(I,J))) + END IF + 30 CONTINUE + BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE + DO 40 I=1,N + IF (X(I,J).NE.ZERO) THEN + IF (BIGDIF) THEN + TT(I,J) = ONE/ABS(X(I,J)) + ELSE + TT(I,J) = ONE/XMAX + END IF + ELSE + TT(I,J) = TEN/XMIN + END IF + 40 CONTINUE + END IF + 50 CONTINUE + + RETURN + END +*DSETN + SUBROUTINE DSETN + + (N,M,X,LDX,NROW) +C***BEGIN PROLOGUE DSETN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED +C***END PROLOGUE DSETN + +C...SCALAR ARGUMENTS + INTEGER + + LDX,M,N,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NROW: THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE. +C X: THE INDEPENDENT VARIABLE. + + +C***FIRST EXECUTABLE STATEMENT DSETN + + + IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN + +C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS +C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. + + DO 20 I = 1, N + DO 10 J = 1, M + IF (X(I,J).EQ.0.0) GO TO 20 + 10 CONTINUE + NROW = I + RETURN + 20 CONTINUE + + NROW = 1 + + RETURN + END +*DSOLVE + SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB) +C***BEGIN PROLOGUE DSOLVE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DAXPY_odr,DDOT_odr +C***DATE WRITTEN 920220 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SOLVE SYSTEMS OF THE FORM +C T * X = B OR TRANS(T) * X = B +C WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N, +C AND THE SOLUTION X OVERWRITES THE RHS B. +C (ADAPTED FROM LINPACK SUBROUTINE DTRSL_odr) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DSOLVE + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(LDB,N),T(LDT,N) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + J1,J,JN + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C B: ON INPUT: THE RIGHT HAND SIDE; ON EXIT: THE SOLUTION +C J1: THE FIRST NONZERO ENTRY IN T. +C J: AN INDEXING VARIABLE. +C JN: THE LAST NONZERO ENTRY IN T. +C JOB: WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS +C 1 SOLVE T*X=B, T LOWER TRIANGULAR, +C 2 SOLVE T*X=B, T UPPER TRIANGULAR, +C 3 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 4 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C LDB: THE LEADING DIMENSION OF ARRAY B. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T. +C T: THE UPPER OR LOWER TRIDIAGONAL SYSTEM. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSOLVE + + +C FIND FIRST NONZERO DIAGONAL ENTRY IN T + J1 = 0 + DO 10 J=1,N + IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN + J1 = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 10 CONTINUE + IF (J1.EQ.0) RETURN + +C FIND LAST NONZERO DIAGONAL ENTRY IN T + JN = 0 + DO 20 J=N,J1,-1 + IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN + JN = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 20 CONTINUE + + IF (JOB.EQ.1) THEN + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + B(1,J1) = B(1,J1)/T(J1,J1) + DO 30 J = J1+1, JN + TEMP = -B(1,J-1) + CALL DAXPY_odr(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 30 CONTINUE + + ELSE IF (JOB.EQ.2) THEN + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 40 J = JN-1,J1,-1 + TEMP = -B(1,J+1) + CALL DAXPY_odr(J,TEMP,T(1,J+1),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 40 CONTINUE + + ELSE IF (JOB.EQ.3) THEN + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 50 J = JN-1,J1,-1 + B(1,J) = B(1,J) - + + DDOT_odr(JN-J+1,T(J+1,J),1,B(1,J+1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 50 CONTINUE + + ELSE IF (JOB.EQ.4) THEN + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + B(1,J1) = B(1,J1)/T(J1,J1) + DO 60 J = J1+1,JN + B(1,J) = B(1,J) - DDOT_odr(J-1,T(1,J),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 60 CONTINUE + END IF + + RETURN + END +*DUNPAC + SUBROUTINE DUNPAC + + (N2,V1,V2,IFIX) +C***BEGIN PROLOGUE DUNPAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY_odr +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE +C UNFIXED +C***END PROLOGUE DUNPAC + +C...SCALAR ARGUMENTS + INTEGER + + N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I,N1 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ODRPACK REFERENCE GUIDE.) +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE +C ELEMENTS OF V1 ARE TO BE INSERTED. + + +C***FIRST EXECUTABLE STATEMENT DUNPAC + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I = 1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1 + 1 + V2(I) = V1(N1) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY_odr(N2,V1,1,V2,1) + END IF + RETURN + END +*DVEVTR + SUBROUTINE DVEVTR + + (M,NQ,INDX, + + V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, + + WRK5) +C***BEGIN PROLOGUE DVEVTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DSOLVE +C***DATE WRITTEN 910613 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V +C***END PROLOGUE DVEVTR + +C...SCALAR ARGUMENTS + INTEGER + + INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + J,L1,L2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DSOLVE + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C INDX: THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED. +C J: AN INDEXING VARIABLE. +C LDE: THE LEADING DIMENSION OF ARRAY E. +C LDV: THE LEADING DIMENSION OF ARRAY V. +C LDVE: THE LEADING DIMENSION OF ARRAY VE. +C LDVEV: THE LEADING DIMENSION OF ARRAY VEV. +C LD2V: THE SECOND DIMENSION OF ARRAY V. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C E: THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2). +C V: AN ARRAY OF NQ BY M MATRICES. +C VE: THE NQ BY M ARRAY VE = V * INV(E) +C VEV: THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V). +C WRK5: AN M WORK VECTOR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DVEVTR + + + IF (NQ.EQ.0 .OR. M.EQ.0) RETURN + + DO 140 L1 = 1,NQ + DO 110 J = 1,M + WRK5(J) = V(INDX,J,L1) + 110 CONTINUE + CALL DSOLVE(M,E,LDE,WRK5,1,4) + DO 120 J = 1,M + VE(INDX,L1,J) = WRK5(J) + 120 CONTINUE + 140 CONTINUE + + DO 230 L1 = 1,NQ + DO 220 L2 = 1,L1 + VEV(L1,L2) = ZERO + DO 210 J = 1,M + VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) + 210 CONTINUE + VEV(L2,L1) = VEV(L1,L2) + 220 CONTINUE + 230 CONTINUE + + RETURN + END +*DWGHT + SUBROUTINE DWGHT + + (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT) +C***BEGIN PROLOGUE DWGHT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T +C***END PROLOGUE DWGHT + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDWT,LDWTT,LD2WT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,J,K + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDWT: THE LEADING DIMENSION OF ARRAY WT. +C LDWTT: THE LEADING DIMENSION OF ARRAY WTT. +C LD2WT: THE SECOND DIMENSION OF ARRAY WT. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C T: THE ARRAY BEING SCALED BY WT. +C TEMP: A TEMPORARY SCALAR. +C WT: THE WEIGHTS. +C WTT: THE RESULTS OF WEIGHTING ARRAY T BY WT. +C ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT +C ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DWGHT + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WT(1,1,1).GE.ZERO) THEN + IF (LDWT.GE.N) THEN + IF (LD2WT.GE.M) THEN +C WT IS AN N-ARRAY OF M BY M MATRICES + DO 130 I=1,N + DO 120 J=1,M + TEMP = ZERO + DO 110 K=1,M + TEMP = TEMP + WT(I,J,K)*T(I,K) + 110 CONTINUE + WTT(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE +C WT IS AN N-ARRAY OF DIAGONAL MATRICES + DO 230 I=1,N + DO 220 J=1,M + WTT(I,J) = WT(I,1,J)*T(I,J) + 220 CONTINUE + 230 CONTINUE + END IF + ELSE + IF (LD2WT.GE.M) THEN +C WT IS AN M BY M MATRIX + DO 330 I=1,N + DO 320 J=1,M + TEMP = ZERO + DO 310 K=1,M + TEMP = TEMP + WT(1,J,K)*T(I,K) + 310 CONTINUE + WTT(I,J) = TEMP + 320 CONTINUE + 330 CONTINUE + ELSE +C WT IS A DIAGONAL MATRICE + DO 430 I=1,N + DO 420 J=1,M + WTT(I,J) = WT(1,1,J)*T(I,J) + 420 CONTINUE + 430 CONTINUE + END IF + END IF + ELSE +C WT IS A SCALAR + DO 520 J=1,M + DO 510 I=1,N + WTT(I,J) = ABS(WT(1,1,1))*T(I,J) + 510 CONTINUE + 520 CONTINUE + END IF + + RETURN + END +*DWINF + SUBROUTINE DWINF + + (N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) +C***BEGIN PROLOGUE DWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C***END PROLOGUE DWINF + +C...SCALAR ARGUMENTS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN, + + M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI, + + WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ISODR + +C...LOCAL SCALARS + INTEGER + + NEXT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NEXT: THE NEXT AVAILABLE LOCATION WITH WORK. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DWINF + + + IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. + + LDWE.GE.1 .AND. LD2WE.GE.1) THEN + + DELTAI = 1 + EPSI = DELTAI + N*M + XPLUSI = EPSI + N*NQ + FNI = XPLUSI + N*M + SDI = FNI + N*NQ + VCVI = SDI + NP + RVARI = VCVI + NP*NP + + WSSI = RVARI + 1 + WSSDEI = WSSI + 1 + WSSEPI = WSSDEI + 1 + RCONDI = WSSEPI + 1 + ETAI = RCONDI + 1 + OLMAVI = ETAI + 1 + + TAUI = OLMAVI + 1 + ALPHAI = TAUI + 1 + ACTRSI = ALPHAI + 1 + PNORMI = ACTRSI + 1 + RNORSI = PNORMI + 1 + PRERSI = RNORSI + 1 + PARTLI = PRERSI + 1 + SSTOLI = PARTLI + 1 + TAUFCI = SSTOLI + 1 + EPSMAI = TAUFCI + 1 + BETA0I = EPSMAI + 1 + + BETACI = BETA0I + NP + BETASI = BETACI + NP + BETANI = BETASI + NP + SI = BETANI + NP + SSI = SI + NP + SSFI = SSI + NP + QRAUXI = SSFI + NP + UI = QRAUXI + NP + FSI = UI + NP + + FJACBI = FSI + N*NQ + + WE1I = FJACBI + N*NP*NQ + + DIFFI = WE1I + LDWE*LD2WE*NQ + + NEXT = DIFFI + NQ*(NP+M) + + IF (ISODR) THEN + DELTSI = NEXT + DELTNI = DELTSI + N*M + TI = DELTNI + N*M + TTI = TI + N*M + OMEGAI = TTI + N*M + FJACDI = OMEGAI + NQ*NQ + WRK1I = FJACDI + N*M*NQ + NEXT = WRK1I + N*M*NQ + ELSE + DELTSI = DELTAI + DELTNI = DELTAI + TI = DELTAI + TTI = DELTAI + OMEGAI = DELTAI + FJACDI = DELTAI + WRK1I = DELTAI + END IF + + WRK2I = NEXT + WRK3I = WRK2I + N*NQ + WRK4I = WRK3I + NP + WRK5I = WRK4I + M*M + WRK6I = WRK5I + M + WRK7I = WRK6I + N*NQ*NP + NEXT = WRK7I + 5*NQ + + LWKMN = NEXT + ELSE + DELTAI = 1 + EPSI = 1 + XPLUSI = 1 + FNI = 1 + SDI = 1 + VCVI = 1 + RVARI = 1 + WSSI = 1 + WSSDEI = 1 + WSSEPI = 1 + RCONDI = 1 + ETAI = 1 + OLMAVI = 1 + TAUI = 1 + ALPHAI = 1 + ACTRSI = 1 + PNORMI = 1 + RNORSI = 1 + PRERSI = 1 + PARTLI = 1 + SSTOLI = 1 + TAUFCI = 1 + EPSMAI = 1 + BETA0I = 1 + BETACI = 1 + BETASI = 1 + BETANI = 1 + SI = 1 + SSI = 1 + SSFI = 1 + QRAUXI = 1 + FSI = 1 + UI = 1 + FJACBI = 1 + WE1I = 1 + DIFFI = 1 + DELTSI = 1 + DELTNI = 1 + TI = 1 + TTI = 1 + FJACDI = 1 + OMEGAI = 1 + WRK1I = 1 + WRK2I = 1 + WRK3I = 1 + WRK4I = 1 + WRK5I = 1 + WRK6I = 1 + WRK7I = 1 + LWKMN = 1 + END IF + + RETURN + END +*DXMY + SUBROUTINE DXMY + + (N,M,X,LDX,Y,LDY,XMY,LDXMY) +C***BEGIN PROLOGUE DXMY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XMY = X - Y +C***END PROLOGUE DXMY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXMY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XMY(LDXMY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXMY: THE LEADING DIMENSION OF ARRAY XMY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS. +C XMY: THE VALUES OF X-Y. +C Y: THE SECOND OF THE TWO ARRAYS. + + +C***FIRST EXECUTABLE STATEMENT DXMY + + + DO 20 J=1,M + DO 10 I=1,N + XMY(I,J) = X(I,J) - Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DXPY + SUBROUTINE DXPY + + (N,M,X,LDX,Y,LDY,XPY,LDXPY) +C***BEGIN PROLOGUE DXPY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XPY = X + Y +C***END PROLOGUE DXPY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXPY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXPY: THE LEADING DIMENSION OF ARRAY XPY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. +C XPY: THE VALUES OF X+Y. +C Y: THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. + + +C***FIRST EXECUTABLE STATEMENT DXPY + + + DO 20 J=1,M + DO 10 I=1,N + XPY(I,J) = X(I,J) + Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DZERO + SUBROUTINE DZERO + + (N,M,A,LDA) +C***BEGIN PROLOGUE DZERO +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET A = ZERO +C***END PROLOGUE DZERO + +C...SCALAR ARGUMENTS + INTEGER + + LDA,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + A(LDA,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE SET TO ZERO. +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C M: THE NUMBER OF COLUMNS TO BE SET TO ZERO. +C N: THE NUMBER OF ROWS TO BE SET TO ZERO. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DZERO + + + DO 20 J=1,M + DO 10 I=1,N + A(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + + RETURN + END + +*DASUM + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +C***BEGIN PROLOGUE DASUM +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3A +C***KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE SUM OF MAGNITUDES OF D.P. VECTOR COMPONENTS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DASUM DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C RETURNS SUM OF MAGNITUDES OF DOUBLE PRECISION DX. +C DASUM = SUM FROM 0 TO N-1 OF DABS(DX(1+I*INCX)) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DASUM + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,MOD + + +C***FIRST EXECUTABLE STATEMENT DASUM + + + DASUM = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I=1,NS,INCX + DASUM = DASUM + DABS(DX(I)) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. + + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DASUM = DASUM + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) + 1 + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) + 50 CONTINUE + RETURN + END +*DAXPY_odr + SUBROUTINE DAXPY_odr(N,DA,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DAXPY_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A7 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P COMPUTATION Y = A*X + Y +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALAR MULTIPLIER +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY DOUBLE PRECISION RESULT (UNCHANGED IF N .LE. 0) +C OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. +C FOR I = 0 TO N-1, REPLACE DY(LY+I*INCY) WITH DA*DX(LX+I*INCX) + +C DY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N +C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DAXPY_odr + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DAXPY_odr + + + IF(N.LE.0.OR.DA.EQ.0.D0) RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. + + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END +*DCHEX + SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) +C***BEGIN PROLOGUE DCHEX +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D7B +C***KEYWORDS CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE UPDATES THE CHOLESKY FACTORIZATION A=TRANS(R)*R OF A +C POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM TRANS(E)*A*E WHERE E IS A +C PERMUTATION MATRIX. +C***DESCRIPTION +C DCHEX UPDATES THE CHOLESKY FACTORIZATION +C A = TRANS(R)*R +C OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM +C TRANS(E)*A*E +C WHERE E IS A PERMUTATION MATRIX. SPECIFICALLY, GIVEN +C AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX +C E (WHICH IS SPECIFIED BY K, L, AND JOB), DCHEX DETERMINES +C AN ORTHOGONAL MATRIX U SUCH THAT +C U*R*E = RR, +C WHERE RR IS UPPER TRIANGULAR. AT THE USERS OPTION, THE +C TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z. +C IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X*E, I.E. X WITH ITS COLUMNS PERMUTED. +C FOR A LESS TERSE DESCRIPTION OF WHAT DCHEX DOES AND HOW +C IT MAY BE APPLIED, SEE THE LINPACK GUIDE. +C THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1) +C OF PLANE ROTATIONS OF THE FORM +C ( C(I) S(I) ) +C ( ) , +C ( -S(I) C(I) ) +C WHERE C(I) IS DOUBLE PRECISION. THE ROWS THESE ROTATIONS OPERATE +C ON ARE DESCRIBED BELOW. +C THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED +C BY THE VALUE OF JOB. +C 1. RIGHT CIRCULAR SHIFT (JOB = 1). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER. +C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (L-I,L-I+1)-PLANE. +C 2. LEFT CIRCULAR SHIFT (JOB = 2). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER +C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (K+I-1,K+I)-PLANE. +C ON ENTRY +C R DOUBLE PRECISION(LDR,P), WHERE LDR .GE. P. +C R CONTAINS THE UPPER TRIANGULAR FACTOR +C THAT IS TO BE UPDATED. ELEMENTS OF R +C BELOW THE DIAGONAL ARE NOT REFERENCED. +C LDR INTEGER. +C LDR IS THE LEADING DIMENSION OF THE ARRAY R. +C P INTEGER. +C P IS THE ORDER OF THE MATRIX R. +C K INTEGER. +C K IS THE FIRST COLUMN TO BE PERMUTED. +C L INTEGER. +C L IS THE LAST COLUMN TO BE PERMUTED. +C L MUST BE STRICTLY GREATER THAN K. +C Z DOUBLE PRECISION(LDZ,N)Z), WHERE LDZ .GE. P. +C Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE +C TRANSFORMATION U IS MULTIPLIED. Z IS +C NOT REFERENCED IF NZ = 0. +C LDZ INTEGER. +C LDZ IS THE LEADING DIMENSION OF THE ARRAY Z. +C NZ INTEGER. +C NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z. +C JOB INTEGER. +C JOB DETERMINES THE TYPE OF PERMUTATION. +C JOB = 1 RIGHT CIRCULAR SHIFT. +C JOB = 2 LEFT CIRCULAR SHIFT. +C ON RETURN +C R CONTAINS THE UPDATED FACTOR. +C Z CONTAINS THE UPDATED MATRIX Z. +C C DOUBLE PRECISION(P). +C C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS. +C S DOUBLE PRECISION(P). +C S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DROTG +C***END PROLOGUE DCHEX + +C...SCALAR ARGUMENTS + INTEGER + + JOB,K,L,LDR,LDZ,NZ,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + C(*),R(LDR,*),S(*),Z(LDZ,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,T1 + INTEGER + + I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DROTG + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MAX0,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DCHEX + + + KM1 = K - 1 + KP1 = K + 1 + LMK = L - K + LM1 = L - 1 + +C PERFORM THE APPROPRIATE TASK. + + GO TO (10,130), JOB + +C RIGHT CIRCULAR SHIFT. + + 10 CONTINUE + +C REORDER THE COLUMNS. + + DO 20 I = 1, L + II = L - I + 1 + S(I) = R(II,L) + 20 CONTINUE + DO 40 JJ = K, LM1 + J = LM1 - JJ + K + DO 30 I = 1, J + R(I,J+1) = R(I,J) + 30 CONTINUE + R(J+1,J+1) = 0.0D0 + 40 CONTINUE + IF (K .EQ. 1) GO TO 60 + DO 50 I = 1, KM1 + II = L - I + 1 + R(I,K) = S(II) + 50 CONTINUE + 60 CONTINUE + +C CALCULATE THE ROTATIONS. + + T = S(1) + DO 70 I = 1, LMK + T1 = S(I) + CALL DROTG(S(I+1),T,C(I),T1) + S(I) = T1 + T = S(I+1) + 70 CONTINUE + R(K,K) = T + DO 90 J = KP1, P + IL = MAX0(1,L-J+1) + DO 80 II = IL, LMK + I = L - II + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 80 CONTINUE + 90 CONTINUE + +C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. + + IF (NZ .LT. 1) GO TO 120 + DO 110 J = 1, NZ + DO 100 II = 1, LMK + I = L - II + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 260 + +C LEFT CIRCULAR SHIFT + + 130 CONTINUE + +C REORDER THE COLUMNS + + DO 140 I = 1, K + II = LMK + I + S(II) = R(I,K) + 140 CONTINUE + DO 160 J = K, LM1 + DO 150 I = 1, J + R(I,J) = R(I,J+1) + 150 CONTINUE + JJ = J - KM1 + S(JJ) = R(J+1,J+1) + 160 CONTINUE + DO 170 I = 1, K + II = LMK + I + R(I,L) = S(II) + 170 CONTINUE + DO 180 I = KP1, L + R(I,L) = 0.0D0 + 180 CONTINUE + +C REDUCTION LOOP. + + DO 220 J = K, P + IF (J .EQ. K) GO TO 200 + +C APPLY THE ROTATIONS. + + IU = MIN0(J-1,L-1) + DO 190 I = K, IU + II = I - K + 1 + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 190 CONTINUE + 200 CONTINUE + IF (J .GE. L) GO TO 210 + JJ = J - K + 1 + T = S(JJ) + CALL DROTG(R(J,J),T,C(JJ),S(JJ)) + 210 CONTINUE + 220 CONTINUE + +C APPLY THE ROTATIONS TO Z. + + IF (NZ .LT. 1) GO TO 250 + DO 240 J = 1, NZ + DO 230 I = K, LM1 + II = I - KM1 + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN + END +*DCOPY_odr + SUBROUTINE DCOPY_odr(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DCOPY_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,COPY,DOUBLE PRECISION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR COPY Y = X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY COPY OF VECTOR DX (UNCHANGED IF N .LE. 0) +C COPY DOUBLE PRECISION DX TO DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, COPY DX(LX+I*INCX) TO DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DCOPY_odr + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DCOPY_odr + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. + + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS=N*INCX + DO 70 I=1,NS,INCX + DY(I) = DX(I) + 70 CONTINUE + RETURN + END +*DDOT_odr + DOUBLE PRECISION FUNCTION DDOT_odr(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DDOT_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A4 +C***KEYWORDS BLAS,DOUBLE PRECISION,INNER PRODUCT,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. INNER PRODUCT OF D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DDOT_odr DOUBLE PRECISION DOT PRODUCT (ZERO IF N .LE. 0) +C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. +C DDOT_odr = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DDOT_odr + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DDOT_odr + + + DDOT_odr = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOT_odr = DDOT_odr + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DDOT_odr = DDOT_odr + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOT_odr = DDOT_odr + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + 1 DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + RETURN + +C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DDOT_odr = DDOT_odr + DX(I)*DY(I) + 70 CONTINUE + RETURN + END +*DNRM2_odr + DOUBLE PRECISION FUNCTION DNRM2_odr(N,DX,INCX) +C***BEGIN PROLOGUE DNRM2_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3B +C***KEYWORDS BLAS,DOUBLE PRECISION,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA, +C NORM,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE EUCLIDEAN LENGTH (L2 NORM) OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DNRM2_odr DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C IF N .LE. 0 RETURN WITH RESULT = 0. +C IF N .GE. 1 THEN INCX MUST BE .GE. 1 +C C.L. LAWSON, 1978 JAN 08 +C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE +C HOPEFULLY APPLICABLE TO ALL MACHINES. +C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. +C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. +C WHERE +C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. +C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) +C V = LARGEST NO. (OVERFLOW LIMIT) +C BRIEF OUTLINE OF ALGORITHM.. +C PHASE 1 SCANS ZERO COMPONENTS. +C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO +C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO +C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M +C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. + +C VALUES FOR CUTLO AND CUTHI.. +C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER +C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. +C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE +C UNIVAC AND DEC AT 2**(-103) +C THUS CUTLO = 2**(-51) = 4.44089E-16 +C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. +C THUS CUTHI = 2**(63.5) = 1.30438E19 +C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. +C THUS CUTLO = 2**(-33.5) = 8.23181D-11 +C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 +C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / +C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DNRM2_odr + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CUTHI,CUTLO,HITEST,ONE,SUM,XMAX,ZERO + INTEGER + + I,J,NEXT,NN + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT,FLOAT + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.0D0,1.0D0/ + DATA + + CUTLO,CUTHI/8.232D-11,1.304D19/ + + +C***FIRST EXECUTABLE STATEMENT DNRM2_odr + + + XMAX = ZERO + IF(N .GT. 0) GO TO 10 + DNRM2_odr = ZERO + GO TO 300 + +! 10 ASSIGN 30 TO NEXT + 10 NEXT=30 + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 +C 20 GO TO NEXT,(30, 50, 70, 110) +! 20 GO TO NEXT +!------------------------------ +20 IF(NEXT.EQ.30) goto 30 + IF(NEXT.EQ.50) goto 50 + IF(NEXT.EQ.70) goto 70 + IF(NEXT.EQ.110) goto 110 + + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 +! ASSIGN 50 TO NEXT + NEXT=50 + XMAX = ZERO + +C PHASE 1. SUM IS ZERO + + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + +C PREPARE FOR PHASE 2. +! ASSIGN 70 TO NEXT + NEXT=70 + GO TO 105 + +C PREPARE FOR PHASE 4. + + 100 I = J +! ASSIGN 110 TO NEXT + NEXT=110 + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 + +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. + + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 + +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. + + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 + + +C PREPARE FOR PHASE 3. + + 75 SUM = (SUM * XMAX) * XMAX + + +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) + + 85 HITEST = CUTHI/FLOAT( N ) + +C PHASE 3. SUM IS MID-RANGE. NO SCALING. + + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2_odr = DSQRT( SUM ) + GO TO 300 + + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 + +C END OF MAIN LOOP. + +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. + + DNRM2_odr = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END +*DPODI + SUBROUTINE DPODI(A,LDA,N,DET,JOB) +C***BEGIN PROLOGUE DPODI +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1B,D3B1B +C***KEYWORDS DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE +C PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C***DESCRIPTION +C DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN +C DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C ON ENTRY +C A DOUBLE PRECISION(LDA, N) +C THE OUTPUT A FROM DPOCO OR DPOFA +C OR THE OUTPUT X FROM DQRDC. +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C N INTEGER +C THE ORDER OF THE MATRIX A . +C JOB INTEGER +C = 11 BOTH DETERMINANT AND INVERSE. +C = 01 INVERSE ONLY. +C = 10 DETERMINANT ONLY. +C ON RETURN +C A IF DPOCO OR DPOFA WAS USED TO FACTOR A , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(A) . +C IF DQRDC WAS USED TO DECOMPOSE X , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X) +C WHERE TRANS(X) IS THE TRANSPOSE. +C ELEMENTS OF A BELOW THE DIAGONAL ARE UNCHANGED. +C IF THE UNITS DIGIT OF JOB IS ZERO, A IS UNCHANGED. +C DET DOUBLE PRECISION(2) +C DETERMINANT OF A OR OF TRANS(X)*X IF REQUESTED. +C OTHERWISE NOT REFERENCED. +C DETERMINANT = DET(1) * 10.0**DET(2) +C WITH 1.0 .LE. DET(1) .LT. 10.0 +C OR DET(1) .EQ. 0.0 . +C ERROR CONDITION +C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS +C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. +C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY +C AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 . +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DSCAL_odr +C***END PROLOGUE DPODI + +C...SCALAR ARGUMENTS + INTEGER JOB,LDA,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,*),DET(*) + +C...LOCAL SCALARS + DOUBLE PRECISION S,T + INTEGER I,J,JM1,K,KP1 + +C...EXTERNAL SUBROUTINES + EXTERNAL DAXPY_odr,DSCAL_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC MOD + + +C***FIRST EXECUTABLE STATEMENT DPODI + + + IF (JOB/10 .EQ. 0) GO TO 70 + DET(1) = 1.0D0 + DET(2) = 0.0D0 + S = 10.0D0 + DO 50 I = 1, N + DET(1) = A(I,I)**2*DET(1) +C ...EXIT + IF (DET(1) .EQ. 0.0D0) GO TO 60 + 10 IF (DET(1) .GE. 1.0D0) GO TO 20 + DET(1) = S*DET(1) + DET(2) = DET(2) - 1.0D0 + GO TO 10 + 20 CONTINUE + 30 IF (DET(1) .LT. S) GO TO 40 + DET(1) = DET(1)/S + DET(2) = DET(2) + 1.0D0 + GO TO 30 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + +C COMPUTE INVERSE(R) + + IF (MOD(JOB,10) .EQ. 0) GO TO 140 + DO 100 K = 1, N + A(K,K) = 1.0D0/A(K,K) + T = -A(K,K) + CALL DSCAL_odr(K-1,T,A(1,K),1) + KP1 = K + 1 + IF (N .LT. KP1) GO TO 90 + DO 80 J = KP1, N + T = A(K,J) + A(K,J) = 0.0D0 + CALL DAXPY_odr(K,T,A(1,K),1,A(1,J),1) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C FORM INVERSE(R) * TRANS(INVERSE(R)) + + DO 130 J = 1, N + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 120 + DO 110 K = 1, JM1 + T = A(K,J) + CALL DAXPY_odr(K,T,A(1,J),1,A(1,K),1) + 110 CONTINUE + 120 CONTINUE + T = A(J,J) + CALL DSCAL_odr(J,T,A(1,J),1) + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DQRDC + SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) +C***BEGIN PROLOGUE DQRDC +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D5 +C***KEYWORDS DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK, +C MATRIX,ORTHOGONAL TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR FACTORI- +C ZATION OF N BY P MATRIX X. COLUMN PIVOTING IS OPTIONAL. +C***DESCRIPTION +C DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR +C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING +C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE +C PERFORMED AT THE USER'S OPTION. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N. +C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE +C COMPUTED. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX X. +C P INTEGER. +C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. +C JPVT INTEGER(P). +C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION +C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X +C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE +C VALUE OF JPVT(K). +C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL +C COLUMN. +C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN. +C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN. +C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS +C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL +C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS +C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY +C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE +C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN +C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST +C REDUCED NORM. JPVT IS NOT REFERENCED IF +C JOB .EQ. 0. +C WORK DOUBLE PRECISION(P). +C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF +C JOB .EQ. 0. +C JOB INTEGER. +C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING. +C IF JOB .EQ. 0, NO PIVOTING IS DONE. +C IF JOB .NE. 0, PIVOTING IS DONE. +C ON RETURN +C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER +C TRIANGULAR MATRIX R OF THE QR FACTORIZATION. +C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM +C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION +C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS +C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT +C OF THE ORIGINAL MATRIX X BUT THAT OF X +C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER +C THE ORTHOGONAL PART OF THE DECOMPOSITION. +C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE +C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO +C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DDOT_odr,DNRM2_odr,DSCAL_odr,DSWAP +C***END PROLOGUE DQRDC + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDX,N,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + QRAUX(*),WORK(*),X(LDX,*) + INTEGER + + JPVT(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + MAXNRM,NRMXL,T,TT + INTEGER + + J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU + LOGICAL + + NEGJ,SWAPJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr,DSCAL_odr,DSWAP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN,DSQRT,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DQRDC + + + PL = 1 + PU = 0 + IF (JOB .EQ. 0) GO TO 60 + +C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS +C ACCORDING TO JPVT. + + DO 20 J = 1, P + SWAPJ = JPVT(J) .GT. 0 + NEGJ = JPVT(J) .LT. 0 + JPVT(J) = J + IF (NEGJ) JPVT(J) = -J + IF (.NOT.SWAPJ) GO TO 10 + IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) + JPVT(J) = JPVT(PL) + JPVT(PL) = J + PL = PL + 1 + 10 CONTINUE + 20 CONTINUE + PU = P + DO 50 JJ = 1, P + J = P - JJ + 1 + IF (JPVT(J) .GE. 0) GO TO 40 + JPVT(J) = -JPVT(J) + IF (J .EQ. PU) GO TO 30 + CALL DSWAP(N,X(1,PU),1,X(1,J),1) + JP = JPVT(PU) + JPVT(PU) = JPVT(J) + JPVT(J) = JP + 30 CONTINUE + PU = PU - 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + +C COMPUTE THE NORMS OF THE FREE COLUMNS. + + IF (PU .LT. PL) GO TO 80 + DO 70 J = PL, PU + QRAUX(J) = DNRM2_odr(N,X(1,J),1) + WORK(J) = QRAUX(J) + 70 CONTINUE + 80 CONTINUE + +C PERFORM THE HOUSEHOLDER REDUCTION OF X. + + LUP = MIN0(N,P) + DO 200 L = 1, LUP + IF (L .LT. PL .OR. L .GE. PU) GO TO 120 + +C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT +C INTO THE PIVOT POSITION. + + MAXNRM = 0.0D0 + MAXJ = L + DO 100 J = L, PU + IF (QRAUX(J) .LE. MAXNRM) GO TO 90 + MAXNRM = QRAUX(J) + MAXJ = J + 90 CONTINUE + 100 CONTINUE + IF (MAXJ .EQ. L) GO TO 110 + CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) + QRAUX(MAXJ) = QRAUX(L) + WORK(MAXJ) = WORK(L) + JP = JPVT(MAXJ) + JPVT(MAXJ) = JPVT(L) + JPVT(L) = JP + 110 CONTINUE + 120 CONTINUE + QRAUX(L) = 0.0D0 + IF (L .EQ. N) GO TO 190 + +C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. + + NRMXL = DNRM2_odr(N-L+1,X(L,L),1) + IF (NRMXL .EQ. 0.0D0) GO TO 180 + IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L)) + CALL DSCAL_odr(N-L+1,1.0D0/NRMXL,X(L,L),1) + X(L,L) = 1.0D0 + X(L,L) + +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, +C UPDATING THE NORMS. + + LP1 = L + 1 + IF (P .LT. LP1) GO TO 170 + DO 160 J = LP1, P + T = -DDOT_odr(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) + CALL DAXPY_odr(N-L+1,T,X(L,L),1,X(L,J),1) + IF (J .LT. PL .OR. J .GT. PU) GO TO 150 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 150 + TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2 + TT = DMAX1(TT,0.0D0) + T = TT + TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 + IF (TT .EQ. 1.0D0) GO TO 130 + QRAUX(J) = QRAUX(J)*DSQRT(T) + GO TO 140 + 130 CONTINUE + QRAUX(J) = DNRM2_odr(N-L,X(L+1,J),1) + WORK(J) = QRAUX(J) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + +C SAVE THE TRANSFORMATION. + + QRAUX(L) = X(L,L) + X(L,L) = -NRMXL + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DQRSL + SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) +C***BEGIN PROLOGUE DQRSL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D9,D2A1 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX, +C ORTHOGONAL TRIANGULAR,SOLVE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C***DESCRIPTION +C DQRSL APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX +C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) +C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL +C N X P MATRIX X THAT WAS INPUT TO DQRDC (IF NO PIVOTING WAS +C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR +C ORIGINAL ORDER). DQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q +C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT +C XK = Q * (R) +C (0) +C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS +C X AND QRAUX. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P). +C X CONTAINS THE OUTPUT OF DQRDC. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST +C HAVE THE SAME VALUE AS N IN DQRDC. +C K INTEGER. +C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K +C MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE +C SAME AS IN THE CALLING SEQUENCE TO DQRDC. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM DQRDC. +C Y DOUBLE PRECISION(N) +C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED +C BY DQRSL. +C JOB INTEGER. +C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS +C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING +C MEANING. +C IF A .NE. 0, COMPUTE QY. +C IF B,C,D, OR E .NE. 0, COMPUTE QTY. +C IF C .NE. 0, COMPUTE B. +C IF D .NE. 0, COMPUTE RSD. +C IF E .NE. 0, COMPUTE XB. +C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB +C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR +C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING +C SEQUENCE. +C ON RETURN +C QY DOUBLE PRECISION(N). +C QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN +C REQUESTED. +C QTY DOUBLE PRECISION(N). +C QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS +C BEEN REQUESTED. HERE TRANS(Q) IS THE +C TRANSPOSE OF THE MATRIX Q. +C B DOUBLE PRECISION(K) +C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM +C MINIMIZE NORM2(Y - XK*B), +C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT +C IF PIVOTING WAS REQUESTED IN DQRDC, THE J-TH +C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J) +C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO DQRDC.) +C RSD DOUBLE PRECISION(N). +C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS +C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE +C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK. +C XB DOUBLE PRECISION(N). +C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO +C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE +C OF X. +C INFO INTEGER. +C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS +C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN +C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO +C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED. +C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED +C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE +C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM. +C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME +C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A +C FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE +C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS +C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE +C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE +C COMPUTED. THUS THE CALLING SEQUENCE +C CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) +C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD +C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING +C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR +C A SINGLE CALLING SEQUENCE. +C 1. (Y,QTY,B) (RSD) (XB) (QY) +C 2. (Y,QTY,RSD) (B) (XB) (QY) +C 3. (Y,QTY,XB) (B) (RSD) (QY) +C 4. (Y,QY) (QTY,B) (RSD) (XB) +C 5. (Y,QY) (QTY,RSD) (B) (XB) +C 6. (Y,QY) (QTY,XB) (B) (RSD) +C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO +C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DCOPY_odr,DDOT_odr +C***END PROLOGUE DQRSL + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,K,LDX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*), + + Y(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,TEMP + INTEGER + + I,J,JJ,JU,KP1 + LOGICAL + + CB,CQTY,CQY,CR,CXB + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr,DCOPY_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN0,MOD + + +C***FIRST EXECUTABLE STATEMENT DQRSL + + + INFO = 0 + +C DETERMINE WHAT IS TO BE COMPUTED. + + CQY = JOB/10000 .NE. 0 + CQTY = MOD(JOB,10000) .NE. 0 + CB = MOD(JOB,1000)/100 .NE. 0 + CR = MOD(JOB,100)/10 .NE. 0 + CXB = MOD(JOB,10) .NE. 0 + JU = MIN0(K,N-1) + +C SPECIAL ACTION WHEN N=1. + + IF (JU .NE. 0) GO TO 40 + IF (CQY) QY(1) = Y(1) + IF (CQTY) QTY(1) = Y(1) + IF (CXB) XB(1) = Y(1) + IF (.NOT.CB) GO TO 30 + IF (X(1,1) .NE. 0.0D0) GO TO 10 + INFO = 1 + GO TO 20 + 10 CONTINUE + B(1) = Y(1)/X(1,1) + 20 CONTINUE + 30 CONTINUE + IF (CR) RSD(1) = 0.0D0 + GO TO 250 + 40 CONTINUE + +C SET UP TO COMPUTE QY OR QTY. + + IF (CQY) CALL DCOPY_odr(N,Y,1,QY,1) + IF (CQTY) CALL DCOPY_odr(N,Y,1,QTY,1) + IF (.NOT.CQY) GO TO 70 + +C COMPUTE QY. + + DO 60 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 50 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT_odr(N-J+1,X(J,J),1,QY(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,QY(J),1) + X(J,J) = TEMP + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IF (.NOT.CQTY) GO TO 100 + +C COMPUTE TRANS(Q)*Y. + + DO 90 J = 1, JU + IF (QRAUX(J) .EQ. 0.0D0) GO TO 80 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT_odr(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,QTY(J),1) + X(J,J) = TEMP + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C SET UP TO COMPUTE B, RSD, OR XB. + + IF (CB) CALL DCOPY_odr(K,QTY,1,B,1) + KP1 = K + 1 + IF (CXB) CALL DCOPY_odr(K,QTY,1,XB,1) + IF (CR .AND. K .LT. N) + + CALL DCOPY_odr(N-K,QTY(KP1),1,RSD(KP1),1) + IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 + DO 110 I = KP1, N + XB(I) = 0.0D0 + 110 CONTINUE + 120 CONTINUE + IF (.NOT.CR) GO TO 140 + DO 130 I = 1, K + RSD(I) = 0.0D0 + 130 CONTINUE + 140 CONTINUE + IF (.NOT.CB) GO TO 190 + +C COMPUTE B. + + DO 170 JJ = 1, K + J = K - JJ + 1 + IF (X(J,J) .NE. 0.0D0) GO TO 150 + INFO = J +C ......EXIT + GO TO 180 + 150 CONTINUE + B(J) = B(J)/X(J,J) + IF (J .EQ. 1) GO TO 160 + T = -B(J) + CALL DAXPY_odr(J-1,T,X(1,J),1,B,1) + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 + +C COMPUTE RSD OR XB AS REQUIRED. + + DO 230 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 220 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + IF (.NOT.CR) GO TO 200 + T = -DDOT_odr(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,RSD(J),1) + 200 CONTINUE + IF (.NOT.CXB) GO TO 210 + T = -DDOT_odr(N-J+1,X(J,J),1,XB(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,XB(J),1) + 210 CONTINUE + X(J,J) = TEMP + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN + END +*DROT + SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS) +C***BEGIN PROLOGUE DROT +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A8 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE APPLY D.P. GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C DC D.P. ELEMENT OF ROTATION MATRIX +C DS D.P. ELEMENT OF ROTATION MATRIX +C --OUTPUT-- +C DX ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C DY ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C MULTIPLY THE 2 X 2 MATRIX ( DC DS) TIMES THE 2 X N MATRIX (DX**T) +C (-DS DC) (DY**T) +C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN +C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +C LX = (-INCX)*N, AND SIMILARLY FOR DY USING LY AND INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DC,DS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,W,Z,ZERO + INTEGER + + I,KX,KY,NSTEPS + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.D0,1.D0/ + + +C***FIRST EXECUTABLE STATEMENT DROT + + + IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 + IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 + + NSTEPS=INCX*N + DO 10 I=1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=DC*W+DS*Z + DY(I)=-DS*W+DC*Z + 10 CONTINUE + GO TO 40 + + 20 CONTINUE + KX=1 + KY=1 + + IF(INCX .LT. 0) KX=1-(N-1)*INCX + IF(INCY .LT. 0) KY=1-(N-1)*INCY + + DO 30 I=1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=DC*W+DS*Z + DY(KY)=-DS*W+DC*Z + KX=KX+INCX + KY=KY+INCY + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DROTG + SUBROUTINE DROTG(DA,DB,DC,DS) +C***BEGIN PROLOGUE DROTG +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1B10 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE CONSTRUCT D.P. PLANE GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C DA DOUBLE PRECISION SCALAR +C DB DOUBLE PRECISION SCALAR +C --OUTPUT-- +C DA DOUBLE PRECISION RESULT R +C DB DOUBLE PRECISION RESULT Z +C DC DOUBLE PRECISION RESULT +C DS DOUBLE PRECISION RESULT +C DESIGNED BY C. L. LAWSON, JPL, 1977 SEPT 08 +C CONSTRUCT THE GIVENS TRANSFORMATION +C ( DC DS ) +C G = ( ) , DC**2 + DS**2 = 1 , +C (-DS DC ) +C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . +C THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN +C STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH +C ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM. +C IF Z=1 SET DC=0.D0 AND DS=1.D0 +C IF DABS(Z) .LT. 1 SET DC=DSQRT(1-Z**2) AND DS=Z +C IF DABS(Z) .GT. 1 SET DC=1/Z AND DS=DSQRT(1-DC**2) +C NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL +C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROTG + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA,DB,DC,DS + +C...LOCAL SCALARS + DOUBLE PRECISION + + R,U,V + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT + + +C***FIRST EXECUTABLE STATEMENT DROTG + + + IF (DABS(DA) .LE. DABS(DB)) GO TO 10 + +C *** HERE DABS(DA) .GT. DABS(DB) *** + + U = DA + DA + V = DB / U + +C NOTE THAT U AND R HAVE THE SIGN OF DA + + R = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DC IS POSITIVE + + DC = DA / R + DS = V * (DC + DC) + DB = DS + DA = R + RETURN + +C *** HERE DABS(DA) .LE. DABS(DB) *** + + 10 IF (DB .EQ. 0.D0) GO TO 20 + U = DB + DB + V = DA / U + +C NOTE THAT U AND R HAVE THE SIGN OF DB +C (R IS IMMEDIATELY STORED IN DA) + + DA = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DS IS POSITIVE + + DS = DB / DA + DC = V * (DS + DS) + IF (DC .EQ. 0.D0) GO TO 15 + DB = 1.D0 / DC + RETURN + 15 DB = 1.D0 + RETURN + +C *** HERE DA = DB = 0.D0 *** + + 20 DC = 1.D0 + DS = 0.D0 + RETURN + + END +*DSCAL_odr + SUBROUTINE DSCAL_odr(N,DA,DX,INCX) +C***BEGIN PROLOGUE DSCAL_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A6 +C***KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR SCALE X = A*X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALE FACTOR +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DX DOUBLE PRECISION RESULT (UNCHANGED IF N.LE.0) +C REPLACE DOUBLE PRECISION DX BY DOUBLE PRECISION DA*DX. +C FOR I = 0 TO N-1, REPLACE DX(1+I*INCX) WITH DA * DX(1+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSCAL_odr + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSCAL_odr + + + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I = 1,NS,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 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) + 50 CONTINUE + RETURN + END +*DSWAP + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DSWAP +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE INTERCHANGE D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DX INPUT VECTOR DY (UNCHANGED IF N .LE. 0) +C DY INPUT VECTOR DX (UNCHANGED IF N .LE. 0) +C INTERCHANGE DOUBLE PRECISION DX AND DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, INTERCHANGE DX(LX+I*INCX) AND DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSWAP + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DTEMP1,DTEMP2,DTEMP3 + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSWAP + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. + + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN + 60 CONTINUE + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + NS = N*INCX + DO 70 I=1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END +*DTRCO + SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB) +C***BEGIN PROLOGUE DTRCO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX,TRIANGULAR +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C***DESCRIPTION +C DTRCO ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C JOB INTEGER +C = 0 T IS LOWER TRIANGULAR. +C = NONZERO T IS UPPER TRIANGULAR. +C ON RETURN +C RCOND DOUBLE PRECISION +C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . +C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS +C IN T AND B OF SIZE EPSILON MAY CAUSE +C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . +C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION +C 1.0 + RCOND .EQ. 1.0 +C IS TRUE, THEN T MAY BE SINGULAR TO WORKING +C PRECISION. IN PARTICULAR, RCOND IS ZERO IF +C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE +C UNDERFLOWS. +C Z DOUBLE PRECISION(N) +C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. +C IF T IS CLOSE TO A SINGULAR MATRIX, THEN Z IS +C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY_odr,DSCAL_odr +C***END PROLOGUE DTRCO + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + RCOND + INTEGER + + JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,*),Z(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + EK,S,SM,TNORM,W,WK,WKM,YNORM + INTEGER + + I1,J,J1,J2,K,KK,L + LOGICAL + + LOWER + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DASUM + EXTERNAL + + DASUM + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr,DSCAL_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN + + +C***FIRST EXECUTABLE STATEMENT DTRCO + + + LOWER = JOB .EQ. 0 + +C COMPUTE 1-NORM OF T + + TNORM = 0.0D0 + DO 10 J = 1, N + L = J + IF (LOWER) L = N + 1 - J + I1 = 1 + IF (LOWER) I1 = J + TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1)) + 10 CONTINUE + +C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . +C TRANS(T) IS THE TRANSPOSE OF T . +C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL +C GROWTH IN THE ELEMENTS OF Y . +C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. + +C SOLVE TRANS(T)*Y = E + + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 KK = 1, N + K = KK + IF (LOWER) K = N + 1 - KK + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30 + S = DABS(T(K,K))/DABS(EK-Z(K)) + CALL DSCAL_odr(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (T(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/T(K,K) + WKM = WKM/T(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + IF (KK .EQ. N) GO TO 90 + J1 = K + 1 + IF (LOWER) J1 = 1 + J2 = N + IF (LOWER) J2 = K - 1 + DO 60 J = J1, J2 + SM = SM + DABS(Z(J)+WKM*T(K,J)) + Z(J) = Z(J) + WK*T(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + W = WKM - WK + WK = WKM + DO 70 J = J1, J2 + Z(J) = Z(J) + W*T(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL_odr(N,S,Z,1) + + YNORM = 1.0D0 + +C SOLVE T*Z = Y + + DO 130 KK = 1, N + K = N + 1 - KK + IF (LOWER) K = KK + IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110 + S = DABS(T(K,K))/DABS(Z(K)) + CALL DSCAL_odr(N,S,Z,1) + YNORM = S*YNORM + 110 CONTINUE + IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K) + IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + I1 = 1 + IF (LOWER) I1 = K + 1 + IF (KK .GE. N) GO TO 120 + W = -Z(K) + CALL DAXPY_odr(N-KK,W,T(I1,K),1,Z(I1),1) + 120 CONTINUE + 130 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL_odr(N,S,Z,1) + YNORM = S*YNORM + + IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM + IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END +*DTRSL_odr + SUBROUTINE DTRSL_odr(T,LDT,N,B,JOB,INFO) +C***BEGIN PROLOGUE DTRSL_odr +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, +C TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE SOLVES SYSTEMS OF THE FORM T*X=B OR TRANS(T)*X=B WHERE T +C IS A TRIANGULAR MATRIX OF ORDER N. +C***DESCRIPTION +C DTRSL_odr SOLVES SYSTEMS OF THE FORM +C T * X = B +C OR +C TRANS(T) * X = B +C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. HERE TRANS(T) +C DENOTES THE TRANSPOSE OF THE MATRIX T. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE MATRIX OF THE SYSTEM. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C B DOUBLE PRECISION(N). +C B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM. +C JOB INTEGER +C JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED. +C IF JOB IS +C 00 SOLVE T*X=B, T LOWER TRIANGULAR, +C 01 SOLVE T*X=B, T UPPER TRIANGULAR, +C 10 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 11 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C ON RETURN +C B B CONTAINS THE SOLUTION, IF INFO .EQ. 0. +C OTHERWISE B IS UNALTERED. +C INFO INTEGER +C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR. +C OTHERWISE INFO CONTAINS THE INDEX OF +C THE FIRST ZERO DIAGONAL ELEMENT OF T. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DDOT_odr +C***END PROLOGUE DTRSL_odr + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),T(LDT,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP + INTEGER + + CASE,J,JJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DTRSL_odr + + +C BEGIN BLOCK PERMITTING ...EXITS TO 150 + +C CHECK FOR ZERO DIAGONAL ELEMENTS. + + DO 10 INFO = 1, N +C ......EXIT + IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150 + 10 CONTINUE + INFO = 0 + +C DETERMINE THE TASK AND GO TO IT. + + CASE = 1 + IF (MOD(JOB,10) .NE. 0) CASE = 2 + IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 + GO TO (20,50,80,110), CASE + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + + 20 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 40 + DO 30 J = 2, N + TEMP = -B(J-1) + CALL DAXPY_odr(N-J+1,TEMP,T(J,J-1),1,B(J),1) + B(J) = B(J)/T(J,J) + 30 CONTINUE + 40 CONTINUE + GO TO 140 + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + + 50 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 70 + DO 60 JJ = 2, N + J = N - JJ + 1 + TEMP = -B(J+1) + CALL DAXPY_odr(J,TEMP,T(1,J+1),1,B(1),1) + B(J) = B(J)/T(J,J) + 60 CONTINUE + 70 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + + 80 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 100 + DO 90 JJ = 2, N + J = N - JJ + 1 + B(J) = B(J) - DDOT_odr(JJ-1,T(J+1,J),1,B(J+1),1) + B(J) = B(J)/T(J,J) + 90 CONTINUE + 100 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + + 110 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 130 + DO 120 J = 2, N + B(J) = B(J) - DDOT_odr(J-1,T(1,J),1,B(1),1) + B(J) = B(J)/T(J,J) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + RETURN + END +*IDAMAX + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C***BEGIN PROLOGUE IDAMAX +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A2 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE FIND LARGEST COMPONENT OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C IDAMAX SMALLEST INDEX (ZERO IF N .LE. 0) +C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX. +C IDAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(DX(1-INCX+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE IDAMAX + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DMAX,XMAG + INTEGER + + I,II,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS + + +C***FIRST EXECUTABLE STATEMENT IDAMAX + + + IDAMAX = 0 + IF(N.LE.0) RETURN + IDAMAX = 1 + IF(N.LE.1)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + DMAX = DABS(DX(1)) + NS = N*INCX + II = 1 + DO 10 I = 1,NS,INCX + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 5 + IDAMAX = II + DMAX = XMAG + 5 II = II + 1 + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = XMAG + 30 CONTINUE + RETURN + END + diff --git a/dataassim/math/optimization/powell.f b/dataassim/math/optimization/powell.f index bfab820..54d38f8 100644 --- a/dataassim/math/optimization/powell.f +++ b/dataassim/math/optimization/powell.f @@ -4,7 +4,7 @@ implicit none INTEGER iter,n,np,NMAX,ITMAX double precision fret,ftol,p(np),xi(np,np),TINY, - & pmin(np),pmax(np) + & pmin(np),pmax(np),f1dim PARAMETER (NMAX=1000,TINY=1.0d-25) CU USES funkmin,linmin INTEGER i,ibig,j @@ -58,7 +58,7 @@ C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. SUBROUTINE linmin(p,pmin,pmax,xi,n,f1dim,fret) implicit none INTEGER n - double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n) + double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim PARAMETER (TOL=1.0d-8) CU USES brent,f1dim,mnbrak INTEGER j,k,ierr diff --git a/dataassim/math/optimization/qpso.f90 b/dataassim/math/optimization/qpso.f90 new file mode 100644 index 0000000..b0fec75 --- /dev/null +++ b/dataassim/math/optimization/qpso.f90 @@ -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 diff --git a/dataassim/math/othersupmath/charfloatlineparser.f b/dataassim/math/othersupmath/charfloatlineparser.f new file mode 100644 index 0000000..ca82710 --- /dev/null +++ b/dataassim/math/othersupmath/charfloatlineparser.f @@ -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 diff --git a/dataassim/math/othersupmath/charlineparser.f b/dataassim/math/othersupmath/charlineparser.f index d8c3ef6..145a41a 100644 --- a/dataassim/math/othersupmath/charlineparser.f +++ b/dataassim/math/othersupmath/charlineparser.f @@ -15,7 +15,8 @@ ! separating characters in a single line. When both commas and blank spaces appear in the line, comma is ! the saparating character and blank spaces are repalced with '_' integer nmax,n - character longchar*(*),charvars(nmax+100)*50 + character(*)::longchar + character charvars(nmax+100)*50 integer i,k,pos1,pos2,leng,posindex(0:nmax+100),itiscomma ! leng=LEN_TRIM(longchar) @@ -35,6 +36,10 @@ do i=1,leng if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1 enddo + if(itiscomma.ge.nmax)then + n=0 + return + endif if(itiscomma.gt.0)then !If the line contains at least one comma, it is assumed a comma separated line n=0 diff --git a/dataassim/math/othersupmath/doytotime.f b/dataassim/math/othersupmath/doytotime.f new file mode 100644 index 0000000..3534fc9 --- /dev/null +++ b/dataassim/math/othersupmath/doytotime.f @@ -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 diff --git a/dataassim/math/othersupmath/extCharToFloatNum.f b/dataassim/math/othersupmath/extCharToFloatNum.f index 1c40dbf..fc32d2c 100644 --- a/dataassim/math/othersupmath/extCharToFloatNum.f +++ b/dataassim/math/othersupmath/extCharToFloatNum.f @@ -5,7 +5,8 @@ !number. !ierr=0, successful conversion ! =1, conversion failed - character astring*50,cpastring*(*),c*1,d*1 + character(*)::cpastring + character astring*50,c*1,d*1 double precision f,fsign,factor integer ipos1,ipos2,ideci,k,j,i,m,numchar0, & numchar,ierr,ispartnum,nlength diff --git a/dataassim/math/othersupmath/fort.2 b/dataassim/math/othersupmath/fort.2 new file mode 100644 index 0000000..6924a21 --- /dev/null +++ b/dataassim/math/othersupmath/fort.2 @@ -0,0 +1,1996 @@ + 5 0.7584741326 -0.3437358393 0.9123953688 0.1233299063 + 6 0.9802417969 -0.0850690167 0.7479482022 0.6602518984 + 7 1.3601292236 -0.2803733684 1.0161933920 -0.1028005553 + 8 1.0554796571 -0.7580182086 0.8723907362 -0.2120288478 + 9 0.8006682511 -0.1781213752 0.8245652686 0.0670366760 + 10 0.8709157464 0.1790145034 0.8569700491 -0.1308427105 + 11 1.4017033380 0.3233870153 1.1785621111 -0.3139659239 + 12 1.0193005286 -0.5636369065 0.9578221774 1.1388132457 + 13 1.0596760058 0.2631358085 1.2366061191 -0.1313140065 + 14 0.9854108379 0.2843458781 1.0451670996 0.1052074942 + 15 1.0052968014 0.1304220935 0.8791524793 -0.7574819394 + 16 1.1151461063 -0.1329093328 1.2498226287 0.2258610885 + 17 1.1443710832 -0.0185565263 0.9497754552 0.5763011628 + 18 1.1937929795 0.2565784007 0.6952519286 0.2682279451 + 19 1.0118634272 0.0226859660 0.9365539071 0.2133915830 + 20 0.9526397265 0.4283245310 1.1095703301 -0.1452120660 + 21 1.1117748750 0.2247777398 0.8716042771 -0.2159660851 + 22 1.1595265108 0.2678961458 1.0386122305 -0.2407905197 + 23 1.1152318573 0.0100923530 1.2746122454 0.3494823149 + 24 0.8615725232 -0.0831596882 0.8419366947 0.3676418050 + 25 1.0030324321 0.0800566602 0.9742145968 -0.1676260561 + 26 1.0079651337 -0.0170836133 0.8745620745 -0.0296015070 + 27 1.1584930960 0.2657476300 1.2536031613 0.0022703801 + 28 0.8705633021 -0.2238300329 1.0859222260 -0.2167220184 + 29 0.8453507026 -0.1265270697 0.9947323718 -0.0825193641 + 30 1.0546988006 -0.1168440018 1.0954922908 -0.3155858317 + 31 0.9476374740 -0.0969872370 1.1309604783 0.1392148507 + 32 0.9686945493 0.0268526446 1.0783636008 0.1744939889 + 33 1.0009476870 -0.0527588878 0.9903134661 0.4285068026 + 34 1.1142043445 0.3394861748 1.2524206691 -0.0236339399 + 35 0.9312894648 0.2511032501 1.0011225384 0.3022817167 + 36 0.9924345880 -0.1296871680 1.1087435960 0.0411773255 + 37 0.9216515016 0.1730465713 1.0584671230 -0.3714770737 + 38 1.1291267706 -0.2705180364 0.9821204361 0.0228259049 + 39 1.0065929743 0.1678014970 0.9843215001 0.2171757248 + 40 1.0452406807 0.0063185604 0.9482782231 0.0795532599 + 41 0.7450371948 -0.1674869527 0.9999764041 -0.0014066002 + 42 0.8752626025 -0.1647885285 0.9387598714 -0.1544740629 + 43 0.7816286777 -0.0231909461 0.8341693194 -0.1092049920 + 44 1.0737330008 0.0482345169 0.9668647605 -0.1742375271 + 45 0.9519263798 -0.0073992706 1.1245487318 0.0380143435 + 46 0.9488801509 -0.3208376067 1.1159251844 -0.1705473272 + 47 0.9297458029 -0.1025337870 0.9546859000 0.0435212068 + 48 0.9013092237 0.0458166038 1.1562275996 -0.1692192677 + 49 1.0270749938 0.0415699993 0.8364407143 -0.2076705737 + 50 1.1780918190 0.0428094707 0.9571255804 0.2149438360 + 51 0.9951344512 0.0546664259 0.8587971631 -0.2717117201 + 52 0.8708593577 -0.1207207551 1.2511977806 -0.0714710137 + 53 1.0667132580 -0.0068625989 0.8636714640 0.0819141315 + 54 0.8653113372 -0.1427676002 0.9031547654 0.2501013086 + 55 0.9327141350 -0.0469420607 1.0237036543 0.0811048361 + 56 1.0852696671 -0.0483604771 0.9529128822 -0.2894128370 + 57 0.8633051509 -0.0385201617 1.2315187623 0.0664223282 + 58 0.9931736886 -0.0038969969 0.9294354761 0.2655350600 + 59 0.9116435326 -0.0199860369 0.8880418631 -0.1739396840 + 60 0.9535744285 0.0743949654 0.9764079703 -0.0675485967 + 61 0.9245484207 0.1315665197 1.0864674695 0.1591512008 + 62 0.9652654347 0.0959848785 1.0034967640 0.0371540443 + 63 1.0781402841 -0.1106319188 1.0950726390 -0.0147616147 + 64 0.9719407305 -0.0184168426 0.9337735323 0.0057975649 + 65 1.0488426450 -0.2675818087 1.0134352480 0.0045886504 + 66 1.0092728275 -0.0271632912 0.9115867094 0.0616550618 + 67 0.9567006023 -0.0855729924 0.8269836283 -0.1229289072 + 68 1.0291171301 0.1633516585 1.1204907324 -0.0058154728 + 69 0.9876200818 -0.0502180806 1.0131800748 0.0215647377 + 70 1.0682734398 0.0539671627 1.2765475457 0.0084936272 + 71 1.0967164551 -0.0297901518 1.0320972589 -0.0187951612 + 72 1.0895999077 0.0449134717 0.9492868518 0.0453583203 + 73 1.0037794188 -0.0070806925 1.0809918192 -0.0246191779 + 74 1.0650014001 0.0539894513 0.9661075679 -0.1003597431 + 75 0.9929049652 -0.0787193001 0.9675646907 -0.0272305650 + 76 1.0144217430 0.0707995218 1.0274292667 0.1293977593 + 77 0.8783986422 -0.0413346034 1.2215213287 -0.0379786652 + 78 0.9973263368 0.0779369504 0.9672273008 -0.0203419956 + 79 1.0060564564 -0.0090794509 1.0890079845 -0.1432904830 + 80 1.0722561118 0.0602200021 1.1264926306 -0.0017501716 + 81 1.1180854998 -0.0303223488 0.8737811694 -0.0594177922 + 82 0.9384028142 0.2482165032 0.8980774544 -0.0763886964 + 83 1.1110479265 0.0388436694 1.0057188555 -0.1126777992 + 84 0.9336248124 -0.0429345018 0.9440916753 0.1157254278 + 85 1.0274952298 -0.0838986470 0.8910404861 -0.0206885857 + 86 1.0519942865 0.0035101273 1.0568082705 0.1543616720 + 87 0.9936897701 0.1281947118 1.1328024721 0.0048494599 + 88 0.9208947381 -0.0920368930 0.9877563648 -0.0884149385 + 89 0.9451553473 0.1584041425 0.9835242302 0.1729027287 + 90 1.0984807873 -0.0496872464 0.9753921662 0.0273840241 + 91 1.0185560654 -0.0285456701 1.0014277003 0.0446434387 + 92 0.9480261983 -0.0591261198 0.9215892040 -0.2243135092 + 93 1.0748074839 -0.0426456350 1.0844111299 0.1725997159 + 94 0.9450551909 0.0825138378 1.0201566562 0.1463442820 + 95 0.9153391509 0.0396825854 1.0184753870 -0.0787797833 + 96 1.0188265169 0.0587335652 1.0836279863 0.0151389475 + 97 0.8777377179 -0.0865603523 1.0005040101 0.0933130855 + 98 1.0966714650 0.1636803399 1.0079589358 0.0964235013 + 99 1.0113621559 -0.0697513125 1.0487242804 -0.0026058459 + 100 1.0317855316 0.0881991951 0.9311027594 -0.0669877451 + 101 1.0321342392 -0.0278536997 1.0752551688 0.1073718181 + 102 0.9721350800 -0.2068854480 1.0559143950 0.0455956519 + 103 1.0413132125 0.0793666109 0.9927249009 0.0575322729 + 104 1.0154983727 0.0667040489 0.8810941572 0.0254690712 + 105 1.0543521852 -0.0140076271 0.9849404697 -0.2284763744 + 106 1.0714553101 -0.0517578906 0.9061338587 0.1079471842 + 107 0.8951980847 -0.0362644086 0.8614612280 -0.0614257117 + 108 1.1263678056 0.1338959703 0.9061409550 0.0460610809 + 109 0.9099982293 -0.1398050524 0.9788097301 0.0699909081 + 110 0.9470547860 0.0095841651 1.0095601783 0.0069201916 + 111 1.0187319035 -0.0285407730 0.9979002209 0.0640445960 + 112 1.0379684230 -0.0221573176 0.9537791807 0.1001786482 + 113 0.9828460551 0.1977940466 1.0442539992 0.0048712713 + 114 1.0588155107 -0.0176262783 0.8818951242 0.0040702646 + 115 1.0565009848 -0.1830368528 0.9346243638 0.0931378662 + 116 0.8751931581 -0.0528378381 0.9361141037 0.0246149295 + 117 0.9870516144 -0.0213428740 0.9104664638 -0.0236519545 + 118 0.9484216562 0.1491468255 0.8666669287 0.1347589822 + 119 0.9433469507 0.0735185059 1.0049049220 0.1944160302 + 120 0.9971938380 0.0260052939 0.9219831985 0.0662699284 + 121 0.9940357728 -0.0188235101 1.0068126859 0.0595250832 + 122 1.0361074706 -0.1854167715 1.0479005340 -0.0656787562 + 123 0.9604243303 0.0640849240 1.0142250370 0.1492572686 + 124 1.1405047056 -0.1984454879 0.9592868637 -0.1802215422 + 125 1.0101432693 0.1456973256 0.9315648075 -0.0404637187 + 126 0.8934636096 0.0725311501 1.0653333172 0.0677430207 + 127 0.9983379240 0.0545008842 0.9160150869 0.2013387307 + 128 0.9605280611 -0.1243687172 0.9494372099 -0.0244831781 + 129 0.9009816542 -0.2116296318 1.0288706640 0.1282942656 + 130 1.0280230820 0.1040484840 1.0109412511 -0.1443861745 + 131 0.9056262412 -0.1143642495 1.0110425749 -0.0354566924 + 132 1.1071490058 0.0988187861 0.9276945623 -0.0173892822 + 133 0.9568699693 0.0051289884 0.9913528466 -0.0110656974 + 134 0.9788384535 0.0094004982 1.0152982285 0.0754588858 + 135 1.0999808619 -0.0091086827 0.9407499354 0.0529761038 + 136 1.0680149834 -0.0269872037 1.0268021438 0.0967378784 + 137 0.9604394081 0.0774810190 1.0221704329 -0.0374618361 + 138 1.1065969816 0.0015986298 0.9665633201 -0.0833448883 + 139 0.9645257133 0.1483941891 0.9412823493 0.0361003920 + 140 1.0107125927 -0.0474989269 0.9835409209 0.0701585747 + 141 1.0149809730 -0.0295354859 1.0048834788 -0.0866937056 + 142 0.9835596324 0.1117782708 0.8421250735 -0.0483283144 + 143 0.9832939350 0.0575306122 1.0376721818 -0.0311064166 + 144 0.9778127405 -0.1207436764 0.9322340631 -0.0965406860 + 145 1.0045091529 0.1118116410 0.9663599981 0.1788484797 + 146 1.0468710181 -0.0381126576 0.9862869871 0.0378274043 + 147 0.9824246628 -0.0182906754 1.1080475088 -0.1498422211 + 148 0.9415145650 -0.0723322564 0.9112154495 -0.0368701187 + 149 1.0150654896 -0.0527884290 0.9726940131 -0.0393464790 + 150 0.9969370171 -0.0385871254 0.9914618282 0.0026246908 + 151 1.0624430149 0.0108868789 0.9762574077 0.0048107302 + 152 1.0426570869 0.1186125453 1.0571880976 0.0825509719 + 153 0.9176134497 0.0221903388 1.1005926166 0.0141368753 + 154 0.9077663464 0.0779982896 1.0305132120 -0.1373808942 + 155 0.9387290631 0.0099283912 0.9857430803 0.0958069954 + 156 1.0246486625 0.0899421033 1.0040026931 0.0047857069 + 157 1.0578359817 -0.1466524441 0.9749497433 -0.0581135098 + 158 0.9706542483 0.0273666009 1.0663476920 0.1326101621 + 159 0.9622678679 0.0528341684 1.0483837940 -0.0626605158 + 160 0.9659079985 0.1146900087 1.0056125394 -0.1265437100 + 161 0.9800540882 0.1119178351 0.9768898600 -0.2394795677 + 162 1.0641511329 0.0433810912 1.0421768750 -0.1110251749 + 163 1.0338105715 -0.0147049680 0.9306822813 -0.0919653849 + 164 0.9963403246 -0.0065535810 0.9734796636 -0.0289720141 + 165 0.9767871227 -0.0704148960 1.0714571970 0.0198633461 + 166 1.0246041826 0.0813362392 0.8844043952 -0.0002180809 + 167 0.9647306542 -0.0406302694 0.9298938675 0.0793038777 + 168 1.0102910304 -0.0868108809 1.0424985453 0.0278291004 + 169 1.0234049194 -0.0426201083 1.0445198949 -0.1822682721 + 170 1.0001413468 0.0489231005 0.9639678271 0.0634891487 + 171 0.9328036169 0.1050602658 1.0454728216 -0.0339505038 + 172 1.0054180543 -0.0274738422 1.0079576195 0.0875994225 + 173 1.0650303659 -0.0230740185 1.0356012720 0.1005057370 + 174 1.0078751573 0.0774855904 1.0994778516 -0.0404270353 + 175 0.9776310052 0.0134160267 1.0062345355 0.1190587377 + 176 1.0513878007 0.0529083671 0.9576348958 -0.0311760733 + 177 0.9850025711 -0.0415658824 1.0280070393 -0.0613315349 + 178 0.9328541353 0.1860382755 0.9834610652 -0.0380333984 + 179 0.9724596340 -0.0049618317 0.9476013775 -0.0932590533 + 180 1.0236788746 0.1117056520 0.9404707944 0.0021960210 + 181 0.9482313376 0.0766331590 0.9712074125 0.1350308342 + 182 1.0015829763 0.0963223016 0.9349989083 0.0841296694 + 183 1.0537217384 -0.0433982828 1.1070939597 0.0611726187 + 184 0.9681140472 0.1141435813 0.9905407537 0.0644533518 + 185 0.9948662261 -0.0169474346 0.9998939595 -0.1391165750 + 186 1.0365520316 0.1811290419 0.9929285231 -0.0421298362 + 187 0.9364563109 -0.0822260064 1.0090961878 -0.0410948480 + 188 0.9340921369 0.0792576115 0.9633984178 0.0618671725 + 189 1.0451082338 -0.0125306953 1.0183685735 -0.0461839464 + 190 1.0112925849 0.0451190562 0.9729720714 0.0501327322 + 191 1.0556311850 -0.0172087914 1.0157923949 0.0773386255 + 192 0.9906367023 -0.0342272976 1.0063852575 -0.0714464725 + 193 0.9940864339 0.0623612004 1.0629475702 -0.0074607989 + 194 0.9626840321 0.0028611375 1.0171462677 -0.0930017135 + 195 1.0444384282 -0.0254962753 1.0435760705 0.0219345719 + 196 1.0435188999 -0.0530288363 1.0274292091 -0.0038522318 + 197 0.9807309796 -0.0570846573 0.9871393015 0.0082701922 + 198 0.9255994919 -0.0394884024 1.1046030649 0.0228027345 + 199 0.8504819299 -0.0109204621 0.9580243106 0.0348253007 + 200 0.9943053883 0.0401248874 1.0284751070 0.0415187295 + 201 0.9902662383 -0.0442759727 0.9563023363 -0.0434045633 + 202 1.0130409871 0.0422875996 1.0123162884 -0.0124024071 + 203 1.0322335432 -0.0377941634 1.0994854290 0.0590188264 + 204 1.1202777841 -0.1588389836 1.0500253388 0.0070054562 + 205 0.9770747085 -0.0543226582 1.0060183237 0.0631722885 + 206 1.0664926394 0.2347883328 1.0561793859 -0.0375659068 + 207 0.9632099475 0.0096789132 1.0213968113 -0.0414589212 + 208 0.9114960644 0.0449590295 1.0416633046 0.0073427320 + 209 0.9644034274 0.0440571212 1.0048887562 0.1523338961 + 210 1.0422358688 -0.0799783777 1.0014108494 0.0436840779 + 211 1.0318072316 0.0464758223 1.1021955186 0.0805300783 + 212 0.9861569005 -0.0931670923 1.0146233396 0.0086396886 + 213 0.9784571885 0.0618244657 0.9743767347 -0.1307794456 + 214 1.0198804438 0.0245606751 1.0350691714 0.0196265570 + 215 0.9659045965 -0.1147570793 1.0320151988 -0.0028144994 + 216 1.0564923447 -0.0470725453 1.0005633644 -0.0061709089 + 217 1.0162624828 0.0619741692 1.0277740878 -0.0495414751 + 218 0.8983890897 -0.0086388227 0.9759825029 0.0244324594 + 219 1.0639350670 -0.0591727984 1.0062787678 0.0458597713 + 220 1.0604056153 0.0327777233 1.0004356901 -0.0072487994 + 221 1.1292647069 0.1278984382 1.0333159737 0.0348266090 + 222 1.0399003829 -0.1054283896 1.0036184142 -0.0550080835 + 223 1.0176789898 0.0107538081 0.9630151380 0.0848449978 + 224 0.9576463992 0.0629802112 0.9656337726 0.0553629240 + 225 0.9619183124 -0.0628333537 1.0036417866 -0.1214331864 + 226 0.9920532969 -0.0292924871 1.0143885737 0.0070171776 + 227 1.0735963320 0.0286280990 0.9688478787 0.0565192562 + 228 0.9559535428 0.0348765711 1.1206753385 0.0453531905 + 229 1.0527560192 -0.0950707649 1.0197581891 0.0442128043 + 230 0.9556376401 -0.0808487656 1.0587433772 0.0690772303 + 231 1.0225055705 -0.0045136406 1.0213829026 -0.0223966169 + 232 1.0745856883 -0.2338739348 1.0411552147 -0.0348164596 + 233 1.0307094632 -0.0273164590 1.0175152388 0.0036302972 + 234 0.9922219143 -0.0806378253 1.0606576678 -0.0184470514 + 235 0.9041475250 -0.0453497561 1.0166491048 0.1200325723 + 236 1.0037095802 0.0557410837 1.0111054425 0.0948701932 + 237 1.0187649455 0.0097593132 1.0728959831 0.0272834890 + 238 0.9085402561 -0.0000569837 1.0548363637 0.0501327767 + 239 0.9773265237 0.1050224552 1.0208505182 -0.0293413533 + 240 0.9321861742 0.0424340514 0.9505385083 0.0195232922 + 241 1.0235587587 -0.0335160669 0.9320908001 -0.0349310811 + 242 1.0205943363 -0.0400181327 0.9318055184 0.0861336379 + 243 1.0309715871 -0.0255463225 1.0313346895 -0.2033183996 + 244 0.9922251142 0.0664473706 1.0385521131 -0.0325270258 + 245 1.1024849668 0.0383454500 1.0524590568 -0.0100407622 + 246 1.0157856509 0.0665999884 0.9854851652 0.0930929619 + 247 1.0171582738 0.0190916060 0.9938193187 -0.0604383382 + 248 1.0347917220 0.1131573184 0.9690234121 -0.0343371391 + 249 1.0463736159 -0.0422774885 0.8956830057 0.0852507275 + 250 1.0502871157 -0.0315910104 1.0398626619 0.0590936684 + 251 0.9585531577 0.0353078420 1.0016716449 0.0710562246 + 252 0.9955261788 0.0223306493 0.9347898329 -0.0397318458 + 253 1.0233484030 0.0054274352 1.0102299209 0.0211172919 + 254 0.9337619075 -0.0223313611 1.0809263751 0.0435445482 + 255 0.9861916291 -0.0961098752 1.0115399693 0.0422676053 + 256 1.0746106180 0.0619510898 1.0306383347 0.0222543338 + 257 0.9726925654 0.0163313561 0.9638786923 0.0140739536 + 258 1.0053731124 0.0979431578 0.9780915263 0.0018841849 + 259 0.9087172532 -0.0481250148 0.9436658612 0.1044797075 + 260 0.9921230385 -0.0225585215 1.0496267599 0.0375562302 + 261 0.9687346602 -0.0155757786 0.9891296321 0.0169901388 + 262 1.0170839808 0.0346311409 0.9816575316 -0.0551285378 + 263 0.9819176041 0.0714674251 1.0214576676 -0.0352187323 + 264 1.0177489274 -0.0189209760 0.9402691195 0.0681863834 + 265 1.0274137880 -0.0455687627 1.0758107705 -0.0918228380 + 266 1.0299903106 0.1384676734 0.9730557875 -0.0975327275 + 267 1.1124311505 -0.0068494892 1.0179340979 -0.0248018809 + 268 1.0121831675 -0.0864510950 1.1245194832 0.0531515258 + 269 1.0355903744 -0.1046870949 1.0318831230 0.0688980769 + 270 0.9609855320 0.0642552175 0.9923314194 0.0476763125 + 271 0.8971990481 -0.1092829042 0.9875324587 0.0947712756 + 272 1.0663719179 0.1574012271 1.0200833294 0.0404750013 + 273 0.9416880501 -0.0180036172 0.9545861400 0.0092609653 + 274 0.9956280463 0.0573032765 0.9504609192 0.1126604335 + 275 0.9920389487 0.1092972178 0.9844221610 -0.0027790787 + 276 0.9977675235 -0.0710384928 1.0758486187 -0.0276176611 + 277 1.0391107984 0.0597930443 1.0696024087 0.0724631372 + 278 0.9682294977 -0.0414037096 1.0769628719 -0.0385745931 + 279 1.0250345449 0.0934421428 0.9624955679 0.0260696488 + 280 1.0608350638 0.0072815867 1.0455310398 -0.0404896203 + 281 0.9837642057 -0.0044405300 1.0018664645 0.0718972006 + 282 1.0231595585 0.0416697601 0.9972915111 0.0036664398 + 283 1.0401489580 -0.0241408821 0.9291373227 -0.0205156578 + 284 0.9462881308 -0.0211595011 0.9317097277 0.0365485850 + 285 1.0677375646 0.0416788476 1.0083232602 -0.1069854906 + 286 0.9602666221 -0.0159901383 1.0161309324 -0.0949317303 + 287 1.0096735031 -0.1428228759 1.0128000065 0.0577424753 + 288 0.9449290078 -0.0490188936 0.9797391223 0.0204960114 + 289 1.0098633609 -0.1493935200 1.0070458917 -0.0862311686 + 290 0.9591022546 -0.0172397138 0.9571898566 0.0076401239 + 291 1.0165045593 -0.0865730756 1.0362504914 -0.0895665356 + 292 1.0196338436 -0.0607692047 1.0687581808 0.0453057838 + 293 0.9788415844 -0.0785542887 0.9742376345 0.0321824155 + 294 0.9799681313 0.0842160441 1.1162097265 0.0495754359 + 295 1.0481133604 0.0098809654 1.0443749772 -0.0771568063 + 296 1.0092421260 0.0151808868 0.9501935121 0.0018418454 + 297 0.9729431699 0.1075084425 0.9859447808 0.0596087664 + 298 1.0294556274 -0.0267791028 1.0325355873 -0.0053373158 + 299 0.9665681961 0.0138913971 1.0269509460 -0.0562122278 + 300 1.0253884901 0.0231657528 1.0039329331 -0.0064160651 + 301 1.0185450485 0.0775491513 0.9673982430 -0.1116770716 + 302 1.0076224549 -0.0249691756 0.9706185349 0.0641596269 + 303 1.0386982973 0.0612904485 0.9121772239 0.1174579479 + 304 0.9771512828 0.0000062825 0.9639389073 0.0254538722 + 305 0.9957340729 -0.0677704975 1.0211278546 -0.0232958262 + 306 1.0862113966 0.0375106979 0.9934303824 0.1206411320 + 307 0.9976050279 -0.0096626652 0.9782786931 -0.0738829016 + 308 0.9871569961 -0.0512688484 0.9860207460 -0.0781138030 + 309 1.0048202209 0.0325427260 1.0056129067 -0.0046886819 + 310 0.9417941033 -0.0978355404 1.0202208384 0.0260870538 + 311 1.0115078968 0.1185256798 0.9809938563 0.0307809140 + 312 0.9653093579 -0.1199821792 0.9672402308 0.0644044185 + 313 1.0302997626 -0.0813079435 1.0314892662 -0.0139450224 + 314 0.9518311989 0.0255446522 0.9828284056 0.0859567895 + 315 0.9807132657 0.0138395737 0.9494125993 0.0305249056 + 316 1.1211310998 0.0643107072 1.0146142201 0.0555500125 + 317 0.9647616910 -0.0638274287 1.0302732057 0.0469139562 + 318 0.9301754558 0.1049517511 1.0437078369 0.0139256752 + 319 0.9225048205 0.0194104116 1.0154220529 0.0236763560 + 320 1.0446176673 0.0906303792 1.0700420969 0.0302621927 + 321 1.0438705164 -0.0301891799 0.9803907486 -0.0208830641 + 322 0.9663163454 -0.0830005684 1.0591221331 -0.0536786242 + 323 1.0143784363 -0.0251025348 0.9256452321 0.0015684474 + 324 1.0320370036 -0.0161384821 1.0294737291 0.1054216643 + 325 1.0294620555 0.0289166551 1.0206870512 0.0521494584 + 326 0.9736231258 0.0225586923 1.0535517018 0.0231005050 + 327 1.0236132707 0.0618041251 1.0654366212 0.0056129630 + 328 0.9557657357 -0.0738452090 1.0170340951 0.0978629775 + 329 1.0054185335 -0.1039218081 1.0316970329 -0.0508348798 + 330 1.0522537350 -0.0099214612 0.9718020856 -0.0247188791 + 331 1.0549884659 0.0738668477 1.0093504229 -0.0676723277 + 332 0.9975089475 0.0030453475 0.9875675325 0.0312119274 + 333 1.0507630835 0.0778098198 0.9907457603 0.0289785573 + 334 1.0485182554 -0.0322966462 1.0015131470 0.0659641626 + 335 0.9750489243 0.0187200499 0.9751004497 -0.0234309370 + 336 1.0180036544 -0.0177549145 1.0259603257 0.0140335058 + 337 0.9961247855 -0.0257414901 1.0242282862 0.0442639586 + 338 0.9361539384 -0.0373357624 1.0320556428 -0.0467309547 + 339 0.9725690625 0.0213310157 1.0681926647 0.0491379532 + 340 1.0328634193 -0.0277811620 0.9779788625 0.0751749400 + 341 0.9903251805 -0.0008748240 0.9964430193 -0.0300465193 + 342 1.0055755977 -0.0191657951 0.9938292926 0.0762053549 + 343 1.0662426855 0.1213731858 1.0332030059 0.0015550903 + 344 1.0304790286 -0.0031648695 0.9997995968 0.0605877456 + 345 0.9657650244 -0.0967111593 0.9806860293 0.0509189199 + 346 1.0164609679 -0.0383077688 0.9987928440 -0.0186130933 + 347 0.9691203906 0.1008457806 0.9943129073 0.0329122604 + 348 1.0275936225 0.0116983524 0.9731333340 0.0070085613 + 349 0.9647985259 -0.0310592248 0.9676396451 -0.1221222258 + 350 1.0026209592 0.0002593703 0.9654213505 0.0400554883 + 351 0.9624638834 0.0010728076 1.0048357856 0.0324089335 + 352 0.9826735626 -0.0168748456 0.9876698664 0.0032724498 + 353 1.0142132070 -0.0421978681 0.9820709926 0.0345506820 + 354 1.0675931656 -0.0245601701 0.9974003579 0.0193347130 + 355 0.9198302895 0.0014057086 1.0120620206 -0.1057881839 + 356 0.9649220391 0.0215978013 0.9495297001 0.0037474863 + 357 1.0606847621 -0.0615541940 0.9160278818 0.0230417344 + 358 1.0094232819 -0.0750243443 0.9384941983 -0.0339124425 + 359 1.0953885632 0.0259721563 0.9351427002 -0.0870422026 + 360 1.0037723322 0.0019255595 0.9889072254 0.0285054679 + 361 1.0666916571 -0.0343550358 1.0196928782 0.0766150756 + 362 0.9998681969 0.0327659051 1.0061561030 -0.1021720555 + 363 1.0057439665 0.0132140687 1.0275856061 0.0512127141 + 364 1.0429409095 0.0194255183 1.0093832601 -0.0573729247 + 365 1.0651226457 0.0450108197 1.0013552747 -0.0713800810 + 366 0.9172108063 0.0181852754 0.9441222645 0.0653714551 + 367 0.9098166656 -0.0302134241 1.0009099557 0.0895010310 + 368 0.9762136464 -0.0148117955 0.9755468517 0.0738802886 + 369 0.9327397602 0.0183966524 0.9291044910 -0.0362565355 + 370 1.0298871073 0.0331882003 1.0293570247 -0.0143560685 + 371 0.9361625393 0.1020945615 0.9630990527 0.0562559020 + 372 1.0117310053 0.0218208282 1.0087514583 0.0310005463 + 373 1.0652629759 -0.0157522257 0.9909793934 -0.0333058064 + 374 0.9817407713 0.0473015196 1.0073508034 0.0450995510 + 375 0.9769724598 0.0198740828 1.0266747609 0.0964176340 + 376 0.9325907787 0.0137226471 0.9937410948 0.0127118345 + 377 1.0107053734 -0.0307494536 1.0898399457 -0.0504859118 + 378 1.0470725852 0.0847893882 0.9771128922 -0.0966310268 + 379 1.0519346789 0.0847764288 1.0065258206 -0.0869839336 + 380 0.9995841403 -0.0669055137 1.0388192394 0.0338755846 + 381 0.9458410994 0.0013042893 0.9361874329 -0.0025401381 + 382 1.0385184812 -0.0335070529 1.0249620335 0.0410192756 + 383 0.9776057701 -0.0362878525 1.0189937137 -0.0709785108 + 384 0.9438397974 0.0187164015 1.0443504266 -0.0012051454 + 385 0.9872634159 -0.0303307517 0.9297131439 0.0648512481 + 386 0.9956948941 0.0013449377 0.9775991207 -0.0014713962 + 387 0.9890522103 0.0030389235 1.0206489454 -0.0456131859 + 388 1.0135011840 0.0409721198 1.0133883329 -0.0191897124 + 389 1.0750598944 -0.0282196459 1.0257033950 0.0661094748 + 390 0.9984934338 0.0980289891 0.9812179431 0.0230998202 + 391 0.9954085875 0.0504320864 1.0010297425 -0.0338678346 + 392 1.0043316115 -0.0489981358 1.0426910275 -0.1182807296 + 393 0.9845778728 -0.0265191574 0.9805244880 0.0503389531 + 394 1.0620438820 -0.0151609381 1.0186136276 -0.0708673092 + 395 0.9949620929 -0.0371877452 1.0536349444 0.0075181311 + 396 0.9567218596 -0.0024745809 1.0125294308 0.0019538818 + 397 0.9761101528 -0.0063978706 1.0036577108 -0.0194371916 + 398 1.0121092864 0.0435467880 1.0270166834 0.0044163567 + 399 0.9862587829 0.0170930178 0.9819546434 0.0378642696 + 400 1.0479406877 -0.0413744060 0.9493346154 0.0098630226 + 401 1.0060730167 0.0652348635 0.9726975966 -0.0474348187 + 402 1.0638118322 0.1678413289 1.0248406485 -0.0822197344 + 403 0.9781747532 -0.0275658442 0.9861144885 0.0055224391 + 404 0.9841570856 0.0623412822 0.9696432187 -0.0044496561 + 405 0.9659749542 0.0481733986 0.9742593923 -0.0066849481 + 406 1.0252400949 -0.0433855299 0.9859642538 -0.0271765526 + 407 1.0136742583 -0.0402647176 0.9875830089 0.0555573140 + 408 0.9930593398 -0.0694670569 1.0246351521 0.0243862381 + 409 0.9447434933 -0.0168434240 1.0964367601 0.0211885992 + 410 0.9837545057 0.0461796624 0.9685377194 0.0096855097 + 411 0.9770281924 -0.0055585390 0.9754165145 0.0015081514 + 412 1.0189963301 0.0285116765 0.9927640092 -0.0131887567 + 413 1.0349693265 0.0400785844 0.9881184418 0.0163179018 + 414 0.9705425526 -0.0104047612 1.0757660733 0.0001518293 + 415 0.9581366442 0.0451725901 1.0123348976 0.1221957075 + 416 0.9685155435 -0.0299418415 0.9851718578 -0.0671515312 + 417 1.0263085515 0.0119448531 1.0299177568 -0.0461507341 + 418 0.9790874186 -0.0339784159 0.9573938035 -0.0113590014 + 419 1.1102887036 -0.0453856119 0.9713279993 -0.0058778210 + 420 0.9936479030 0.1138694098 1.0290676926 0.0586714738 + 421 0.9869375401 0.0738805649 1.0440333860 0.0464900721 + 422 1.0410041791 -0.0488414314 1.0368469287 0.0617506552 + 423 1.0235699262 0.0459123944 1.0442535967 -0.0176530205 + 424 1.0052647586 -0.0581362024 1.0481243359 0.0308817250 + 425 0.9991188789 -0.0058551979 1.0402661910 0.1081584142 + 426 1.0246171980 0.0604518913 1.0260849747 -0.0177844602 + 427 1.0230848879 -0.0262789101 0.9853660902 0.0002913164 + 428 0.9950002105 -0.0864101902 0.9813656008 0.0555957124 + 429 0.9981569339 0.0607726966 1.0299232911 -0.0375508158 + 430 1.0545644500 -0.0666663935 0.9684349139 0.0977452317 + 431 1.0244836095 -0.0453160542 0.9792367878 0.0799518946 + 432 0.9504173538 0.0444194175 0.9725797525 0.0436078515 + 433 1.0081467616 -0.0080208350 1.0134699482 -0.0145719020 + 434 1.0501718057 0.0083638508 1.0652812144 -0.0206405059 + 435 0.9702181945 0.0439576230 0.9457408680 -0.0297470692 + 436 0.9844333671 0.0688045502 0.9875456127 -0.0358979299 + 437 1.0278197550 0.0307950112 1.0159563345 0.0044427805 + 438 0.9490765328 0.0276806217 0.9776657879 0.0937008816 + 439 1.0545892490 0.0875198144 1.0246234929 -0.0087951152 + 440 0.9737038584 -0.0028231742 1.0002363136 -0.0477480947 + 441 1.0034403245 -0.0222515027 0.9660990742 0.0261729873 + 442 1.0234497156 0.0634492670 0.9987766367 -0.0095074356 + 443 0.9601480789 -0.0011099899 1.0025027939 -0.0050999147 + 444 1.0169621887 -0.0680474230 0.9438729035 -0.0003491744 + 445 0.9839967520 -0.0982407546 0.9908365436 -0.0590371809 + 446 1.0162754909 -0.0508056304 0.9971992935 0.0072910105 + 447 1.0131858356 -0.0752134237 1.0620192278 0.0357718852 + 448 0.9881318787 0.0180833720 0.9496760542 0.0297890954 + 449 0.9993396115 -0.0213587886 1.0299535759 -0.0218366041 + 450 0.9555383982 -0.0519563052 1.0044903108 0.0272985730 + 451 1.0200426366 -0.0077259714 0.9511521250 0.0083759621 + 452 0.9659108521 0.0549304738 1.0338981775 -0.0034864579 + 453 1.0198566635 0.0539766916 1.0508788602 0.0128040409 + 454 1.0575558061 -0.0109676468 1.0361344591 0.0327396601 + 455 1.0126924415 -0.1017909212 1.0249738304 0.0558869782 + 456 0.9673139494 0.0148636194 1.0087665016 -0.0281657603 + 457 1.0222187265 -0.0472081774 1.0180462686 0.0085935231 + 458 1.0214079757 -0.0555502490 1.0470442811 -0.0748369392 + 459 1.0277720345 -0.0848961990 0.9694128399 -0.0051227848 + 460 1.0163973693 -0.0029798305 0.9438286839 0.0303086907 + 461 1.0352249443 0.0423278680 0.9718400866 0.0285709249 + 462 0.9641081724 0.0347852479 0.9896876153 0.0879052054 + 463 0.9935241991 -0.0179056036 0.9929174457 0.1035007269 + 464 1.0483888165 -0.0418119305 1.0285868588 -0.0246157936 + 465 0.9431113182 -0.0461776838 0.9842792465 -0.0881782828 + 466 0.9614215944 -0.0308363649 0.9640704059 -0.0348064251 + 467 1.0153436265 0.0034709363 0.9822924872 -0.0072843170 + 468 0.9818174301 -0.0537340699 0.9839601918 0.0301370244 + 469 1.0134306953 -0.0112304058 0.9683490622 0.0081103919 + 470 1.0121553989 -0.0340665875 0.9956154959 0.0094363633 + 471 0.9994367544 0.0065074979 1.0037154493 0.0067956510 + 472 0.9675610588 0.0028058542 1.0283668923 -0.0576637827 + 473 1.0003216312 0.0209366495 1.0025839180 -0.0592071510 + 474 1.0099792922 -0.0767112966 0.9176692247 -0.0355315485 + 475 0.9954320470 -0.0145555795 1.0469157619 -0.0470937942 + 476 0.9668166163 -0.0334676776 1.0038436085 -0.0339326971 + 477 0.9698237843 -0.0120473394 1.0401856151 0.0136478639 + 478 1.0072974848 0.0780895974 0.9755106265 0.0496595647 + 479 0.9480068013 -0.0425643908 0.9647063221 0.0507694390 + 480 0.9703990067 0.0615847994 0.9837652236 0.0511467632 + 481 0.9651439542 -0.0145519295 1.0045936926 0.0362099232 + 482 0.9745422801 0.0579014654 1.0747648468 0.0182854694 + 483 0.9923756617 -0.0690124369 1.0532977011 -0.0561771314 + 484 0.9872022033 0.0172853868 1.0015249814 0.0433984620 + 485 1.0919427819 0.0133680872 1.0412657894 -0.0092626635 + 486 0.9684791457 -0.0276449059 1.0025754869 -0.0155811545 + 487 0.9836529863 -0.0093971036 1.0043254318 -0.0212692690 + 488 1.0140931668 -0.0186470829 0.9798009379 0.0468592112 + 489 1.0415639447 0.0377836644 0.9978933899 0.0014777063 + 490 0.9960701729 0.0578486513 1.0002445745 -0.0428678542 + 491 0.9857861843 0.0687963610 1.0129356262 0.0267703314 + 492 1.0263996203 -0.0300817444 0.9873273230 -0.0118486604 + 493 1.0170841800 0.0189157006 0.9971603081 -0.0735264216 + 494 0.9871173409 0.0200146374 1.0192284765 -0.0353303107 + 495 1.0264248608 0.1058794416 0.9328811923 0.0022191795 + 496 1.0197898939 -0.0619977856 0.9900183400 0.0602304870 + 497 1.0183838875 -0.0568310889 1.0142459993 -0.0746292024 + 498 1.0287983479 -0.0293235502 1.0011422816 0.0333885759 + 499 1.0296630487 -0.0155382885 1.0111000166 -0.0447350930 + 500 0.9683506950 0.0612954787 1.0058906054 0.0365189762 + 501 1.0503830090 -0.0283788254 0.9647537033 -0.0470782103 + 502 0.9809574882 0.1018687908 1.0469574790 -0.0740170297 + 503 0.9888248684 -0.0070096245 1.0030916610 -0.0656782250 + 504 0.9722871739 0.0324738508 1.0037329859 0.0338019872 + 505 1.0249479829 -0.0100877191 1.0474862590 -0.0121303650 + 506 0.9939291677 -0.0033358283 0.9853946892 -0.0378556424 + 507 1.0271605782 0.0034919096 0.9972858971 0.0081455366 + 508 0.9768230374 0.0120733889 0.9655205640 -0.0028288633 + 509 0.9909990036 -0.0478850870 1.0051837058 -0.0707785911 + 510 0.9790220837 0.0110837708 1.0120365477 -0.0264836217 + 511 1.0454620096 -0.0768811215 0.9359046061 -0.0031918290 + 512 0.9745167725 -0.0295310834 1.0117424224 -0.0128170489 + 513 1.0365760997 -0.0384776507 0.9782378314 -0.0096045516 + 514 1.0182564906 0.0123585564 1.0038224787 -0.0445021184 + 515 0.9883948047 0.0262358361 1.0284312907 0.0396990068 + 516 1.0394539278 0.0193848279 1.0112675988 0.0102972461 + 517 1.0082260911 0.0201317493 0.9800465983 -0.0310424157 + 518 0.9662363299 -0.0056512484 1.0197225803 -0.0291114522 + 519 1.0611766987 0.0131083689 0.9861586978 0.0045072015 + 520 1.0003072994 0.0315523491 1.0261046547 0.0068378532 + 521 0.9836600995 0.0175459333 0.9565040066 0.0148356270 + 522 0.9797447364 0.0123311606 1.0286461127 0.0058220724 + 523 0.9776456052 0.0240117809 0.9661669112 0.0559366088 + 524 1.0065008475 0.0487356477 0.9751154321 -0.0184694393 + 525 0.9931144102 0.0113010498 0.9706392804 0.0194904153 + 526 0.9881361254 0.0062994978 1.0070178407 -0.0472420445 + 527 1.0540616348 0.0662696142 0.9568601387 0.0411756524 + 528 0.9482319696 0.0409624844 1.0036409448 0.0447819699 + 529 0.9632026130 0.0486543411 0.9768937856 -0.0339241237 + 530 1.0259660774 -0.0252868370 0.9737855206 0.0411438026 + 531 0.9969067651 -0.0064243387 0.9937427324 0.0850539322 + 532 1.0089843167 -0.0022386842 1.0024536202 -0.0091818421 + 533 1.0553486681 0.0359448801 0.9849410510 0.0430343244 + 534 0.9811373747 0.0131849532 0.9686433077 0.0234349195 + 535 0.9918202527 -0.0764914680 0.9902644947 0.0159470024 + 536 0.9777418789 0.0347838530 0.9169183943 0.0256137099 + 537 0.9992669075 -0.0394073353 0.9915439643 0.0218045224 + 538 0.9830053003 0.0874677706 1.0062558408 -0.0411934446 + 539 0.9984864147 -0.0043306780 1.0025500405 0.0025025485 + 540 0.9723356181 -0.0309537502 1.0360777870 0.0084862505 + 541 0.9198402542 -0.0891518775 1.0339192962 -0.0113839618 + 542 1.0166013529 -0.0318492335 0.9484427995 0.0446884037 + 543 0.9980818660 -0.0652095443 0.9495990264 -0.0031101791 + 544 0.9998656418 -0.0616150081 1.0044060639 -0.0267196568 + 545 1.0216729719 0.0222504643 0.9954949374 0.0743203182 + 546 0.9758858802 -0.0230278611 0.9561932285 0.0088557203 + 547 1.0123236683 -0.0053209752 1.0126267449 0.0414341149 + 548 1.0512934330 0.0184077498 1.0068131535 -0.0007487327 + 549 1.0512437759 0.0623230607 0.9664062013 -0.0059226729 + 550 0.9934242969 0.0175398969 0.9675428681 -0.0007106921 + 551 1.0102500466 0.0271139287 1.0226755026 -0.0661595370 + 552 0.9855970038 -0.0004277277 1.0515381567 0.0005605228 + 553 0.9564696474 0.0094375415 0.9746278813 0.0604933672 + 554 0.9861902579 -0.0081037271 0.9931752088 0.0378083496 + 555 1.0853632777 0.0172940396 0.9761074023 0.0031105242 + 556 1.0476061533 0.0288179322 1.0345621359 -0.0280019875 + 557 1.0710826240 0.0102667194 0.9736842206 0.0190905789 + 558 0.9886160427 0.0535677022 0.9812943264 0.0184045925 + 559 0.9803621167 -0.0529642408 0.9755071612 0.0152824488 + 560 0.9805630327 0.0396643120 0.9724975862 0.0048558176 + 561 0.9705365728 -0.0174217534 0.9749249856 -0.0323960920 + 562 1.0439578734 0.0325585514 1.0381268564 -0.0687521910 + 563 0.9497674063 0.0335281708 1.0425254529 0.0385317189 + 564 0.9859012000 0.0332996959 1.0017006048 -0.0156637045 + 565 0.9786420755 -0.0335323903 1.0179542127 -0.0429691276 + 566 1.0324132384 -0.0328736542 1.0160740679 -0.0328941916 + 567 1.0079614144 0.0602772244 1.0800357231 -0.0153621682 + 568 1.0123711242 0.0074235049 0.9996525755 -0.0058963453 + 569 1.0195348977 -0.0323234910 0.9810186243 -0.0045450680 + 570 1.0067198843 -0.0086824495 1.0667822546 -0.0143348681 + 571 1.0424787696 0.0351693801 1.0513909210 0.0346455974 + 572 0.9985202885 0.0349741154 1.0983573179 0.0505965264 + 573 0.9607180787 0.0267290981 1.0452403062 -0.0370745794 + 574 1.0146128549 -0.0186951528 0.9920395483 -0.0420618761 + 575 0.9662221335 0.0275460339 0.9964023422 0.0193596433 + 576 0.9694917971 0.0179820851 1.0118843986 -0.0339664508 + 577 1.0089974749 -0.0984898385 0.9261969211 -0.0204531380 + 578 1.0137150876 0.0818061445 0.9887325434 0.0233477066 + 579 0.9869085279 -0.0332485750 1.0165572928 0.0313869490 + 580 1.0122267418 0.0595119818 1.0300246298 -0.0395291627 + 581 1.0577754979 -0.0338386966 1.0093590377 0.0215387195 + 582 0.9756861497 0.0034410611 0.9633798664 -0.0603256089 + 583 1.0184692548 -0.0158574002 0.9812432656 -0.0228024763 + 584 1.0149705722 -0.0365104900 1.0070230501 -0.0121256613 + 585 0.9696849173 0.0218337209 0.9743854976 0.0736595923 + 586 0.9966475982 0.0494138860 0.9826600444 -0.0124903472 + 587 1.0332386025 0.0918702170 0.9671032895 -0.0110882590 + 588 1.0387348624 -0.0752792448 1.0229234864 -0.0237926522 + 589 0.9855397753 0.0046943630 1.0217623065 -0.0214827453 + 590 1.0103998468 0.0253393049 1.0327187000 0.0509659275 + 591 1.0366156806 0.0010226370 1.0246146392 0.0097031334 + 592 0.9707325205 -0.0093285580 1.0150191148 -0.0707151991 + 593 0.9513737364 0.0446990494 0.9586385750 0.0490958296 + 594 1.0002383284 -0.0567224553 1.0546025733 -0.0116066592 + 595 1.0104732575 0.0796892633 1.0212073388 -0.1023582430 + 596 0.9649512022 -0.0467063177 1.0250471960 -0.0016834115 + 597 1.0242170212 -0.0199019445 0.9744163632 0.0469591969 + 598 1.0621571387 0.0155439596 1.0386101914 0.0233632426 + 599 1.0195081114 -0.0000321293 0.9690174018 -0.0379942196 + 600 0.9881274349 0.0118161542 0.9492385839 -0.0078829023 + 601 0.9828106926 0.0666176082 0.9661399821 0.0136520602 + 602 1.0225074388 0.0681948460 0.9444137150 -0.0285651070 + 603 1.0244014797 -0.0367169700 0.9938646898 -0.0771045900 + 604 1.0110486884 0.0446895308 0.9713612682 0.0504459933 + 605 1.0248878485 0.0244693516 0.9904037051 -0.0144034648 + 606 1.0059101840 -0.0173559984 1.0771400276 0.0261333524 + 607 0.9938827465 -0.0093541307 1.0252282138 -0.0322310381 + 608 1.0146106135 -0.0078121605 1.0551183738 0.0497046972 + 609 0.9915930778 -0.0235992996 0.9750524494 0.0015239172 + 610 1.0188408355 -0.0592764987 1.0119910213 -0.0498693047 + 611 1.0190778082 0.0517200923 1.0060459607 -0.0197840438 + 612 0.9225646257 0.0064440632 0.9466709001 0.0391293967 + 613 0.9813943835 -0.0243145630 0.9995436142 -0.0119690975 + 614 1.0276758549 -0.0134454330 0.9715333885 0.0235810039 + 615 1.0317796756 -0.0016627504 1.0476813830 0.0153289757 + 616 0.9692768749 -0.0943762292 0.9979849732 -0.0393409556 + 617 0.9886081990 -0.0446261962 0.9946817308 0.0001464044 + 618 1.0102822216 -0.0169179773 0.9970357282 -0.0002215442 + 619 1.0039988004 -0.0146332787 0.9437031626 0.0363920615 + 620 1.0274264838 -0.0449454555 1.0004058485 0.0094859775 + 621 1.0223493924 0.0157724147 1.0305554523 0.0018001763 + 622 0.9932702965 0.0250305420 0.9962888784 0.0068878149 + 623 1.0301135781 0.0220801171 0.9859987044 0.0375215459 + 624 0.9560094706 0.0342472123 0.9720108042 -0.0214332676 + 625 1.0156057436 0.0014012605 0.9257516784 -0.0370768292 + 626 1.0315592404 0.0127163656 1.0256195360 0.0227017068 + 627 0.9616289844 -0.0193105139 1.0282301329 -0.0379985833 + 628 1.0099912279 0.0807588649 1.0197142112 0.0094372210 + 629 0.9706181953 -0.0328942949 0.9666632846 0.0178952692 + 630 1.0086974063 -0.0109039529 1.0342925881 0.0452909418 + 631 0.9918831423 -0.0437116784 0.9584480272 0.0064931136 + 632 0.9702697876 -0.0353555672 1.0072028691 0.0290538393 + 633 0.9626087913 0.0761482990 1.0406414074 -0.0240424943 + 634 1.0388253190 -0.0085334277 1.0202556899 0.0249993281 + 635 1.0430144894 0.0325256630 1.0314454867 0.0508473728 + 636 1.0436638079 -0.0479159960 0.9825402238 -0.0158028600 + 637 0.9778018215 -0.0044766743 1.0195456151 0.0010078732 + 638 1.0145871018 -0.0284487720 0.9625776067 0.0223224994 + 639 1.0300347997 0.0811826039 0.9914032439 -0.0049839889 + 640 0.9958342340 0.0144505138 1.0185176528 0.0062667970 + 641 0.9615956443 -0.0044769478 1.0346663550 -0.0516393144 + 642 1.0171114572 -0.0191364194 0.9568641638 -0.0294695915 + 643 0.9850977927 0.0031709860 1.0518309408 -0.0129050634 + 644 0.9942300680 0.0627439192 1.0296011947 -0.0760412624 + 645 0.9865016292 0.0187835307 0.9866671003 0.0258550126 + 646 1.0173704366 -0.0143320459 0.9901289344 0.0030566583 + 647 0.9903873533 0.0257981760 0.9572801530 -0.0345361320 + 648 0.9899545249 -0.0345907216 1.0036020106 -0.0477938281 + 649 1.0108610271 0.0077876856 1.0017018252 -0.0351227086 + 650 0.9737550561 0.0556107745 1.0563561237 0.0533411175 + 651 0.9901201016 -0.0673685914 0.9785451098 -0.0016682402 + 652 0.9648133375 0.0451403708 0.9942547079 0.0422912757 + 653 1.0211767344 0.0191632086 1.0274147755 -0.0626069310 + 654 1.0347582442 0.0665421666 0.9922926676 -0.0204776144 + 655 0.9954008121 -0.0302194695 1.0023467992 0.0480738636 + 656 1.0505519790 -0.0460676346 0.9951527381 -0.0329410775 + 657 0.9649873253 0.0742486907 0.9955142532 0.0455356680 + 658 1.0189895718 -0.0486418244 1.0509379135 0.0073998870 + 659 1.0116295635 -0.0406950396 1.0403960812 -0.0287117866 + 660 1.0385097396 -0.0284488690 0.9865072145 -0.0487240303 + 661 0.9529632126 -0.0618513054 0.9738407975 0.0487164214 + 662 1.0052988122 -0.0123217673 1.0026859341 -0.0046059580 + 663 1.0242067610 0.0132016049 1.0059060970 -0.0366953884 + 664 1.0250142321 0.0416660645 0.9668313215 0.0398711406 + 665 0.9976064720 0.0701689533 0.9738766982 -0.0277616292 + 666 1.0133078686 0.0164165982 1.0136116788 0.0862018316 + 667 0.9961258140 -0.0396963845 1.0141917431 0.0184675632 + 668 0.9688797856 0.0014274163 0.9882702671 -0.0238718221 + 669 1.0198286305 -0.0633380192 1.0022337311 -0.0309370610 + 670 1.0042218116 0.0024824809 0.9696719641 -0.0459194510 + 671 0.9892698172 -0.0191037669 1.0143717901 0.0220703568 + 672 1.0298268862 -0.0379232007 1.0037654943 -0.0545111166 + 673 1.0124779973 -0.0238298540 0.9771930350 0.0285776117 + 674 0.9700331230 0.0217417792 0.9543236030 0.0537092867 + 675 0.9941778475 -0.0190737912 0.9903561066 0.0400812844 + 676 0.9795131095 0.0400384077 0.9796724032 -0.0126171715 + 677 0.9959646282 -0.0728499287 0.9993170426 -0.0299335069 + 678 0.9781197626 -0.0249489090 0.9901491388 -0.0306596959 + 679 0.9718180566 0.0152392814 1.0634205006 -0.0197167187 + 680 0.9948183038 -0.0179538341 1.0006041808 0.0384563252 + 681 1.0214372151 -0.0342480854 1.0017311428 0.0451531522 + 682 1.0058647554 0.0080452099 0.9487265491 0.0212297468 + 683 1.0139070781 -0.0093288815 1.0318599370 -0.0565023652 + 684 0.9563993531 0.0168964270 0.9947554612 -0.0031740863 + 685 1.0068222151 -0.0132536494 0.9507747861 -0.0139709407 + 686 0.9883251168 0.0662149546 0.9610211898 0.0203590273 + 687 1.0312753645 0.0447778443 1.0083123909 0.0302532402 + 688 0.9936423048 0.0175205009 1.0250130509 0.0180011184 + 689 1.0048472098 -0.0101955693 0.9901681641 -0.0188164147 + 690 0.9893149110 0.0138784238 0.9789497311 -0.0141461593 + 691 0.9841091871 -0.0863923150 0.9620360621 0.0077369500 + 692 0.9716051306 -0.0294578121 0.9841512165 0.0197818894 + 693 0.9512105912 0.0175506543 0.9669052169 -0.0347110373 + 694 0.9334037299 -0.0068216505 0.9901817418 -0.0339425551 + 695 1.0251229664 0.0014163338 0.9577651012 0.0362249080 + 696 1.0261501302 0.0065846609 1.0360541184 -0.0553718669 + 697 1.0184249478 -0.0418873895 0.9669763342 0.0045769180 + 698 1.0025689609 0.0257951089 0.9988513115 -0.0255949885 + 699 0.9710207288 0.0212491675 1.0169332515 -0.0066675412 + 700 1.0041877144 -0.0406145298 1.0112712665 -0.0467395980 + 701 1.0428109458 -0.0220010924 0.9802987065 -0.0171780132 + 702 1.0559479630 0.0233423517 0.9731554464 0.0495651413 + 703 0.9772014172 0.0266782289 1.0124130652 0.0396891991 + 704 1.0428384836 -0.0019982483 0.9911120896 -0.0329662444 + 705 0.9828545638 0.0661686453 0.9994514304 0.0708138974 + 706 1.0064248348 -0.0229844591 0.9666696624 0.0148241443 + 707 0.9986171967 0.0409319694 1.0140860890 -0.0351035008 + 708 0.9971304389 0.0892930693 1.0514666752 -0.0256524574 + 709 0.9650447288 -0.0018112779 0.9922953148 -0.0164148440 + 710 1.0270215543 0.0341778148 0.9812652018 0.0093090601 + 711 1.0382010733 0.0027532265 0.9881410571 0.0261670211 + 712 1.0097014336 0.0221494545 1.0091528220 -0.0498472865 + 713 1.0099703675 -0.0209281129 1.0249802350 -0.0535170246 + 714 1.0183232400 0.0434411628 1.0304428271 0.0459157069 + 715 0.9517921797 -0.0607383386 0.9976166284 -0.0115825642 + 716 1.0129393524 0.0003253260 1.0203962806 -0.0295113599 + 717 0.9811009007 -0.0270895452 1.0524262131 0.0064192272 + 718 1.0368619853 0.0141397015 0.9411333731 -0.0122164532 + 719 1.0479620793 0.0332278870 0.9500611012 -0.0172618568 + 720 1.0059678011 0.0440307206 0.9567510067 -0.0024986654 + 721 0.9589599658 0.0506881902 0.9790691665 0.0167888154 + 722 0.9645150849 -0.0170369660 1.0462910248 -0.0536945634 + 723 0.9826867454 -0.0009861314 0.9660362236 -0.0355033814 + 724 0.9983562836 -0.0464972093 0.9905670043 -0.0640446232 + 725 0.9935005173 0.0297370335 1.0081430406 0.0180995483 + 726 1.0134266983 -0.0120352836 1.0095548219 0.0134648332 + 727 0.9868707996 -0.0321876294 0.9809781247 -0.0667819276 + 728 1.0070687671 -0.0480564745 0.9700812468 0.0148401805 + 729 1.0298974773 0.1010212449 1.0691934643 -0.0009480254 + 730 1.0094515473 -0.0194095654 0.9970195560 -0.0295574759 + 731 1.0387892283 0.0006451547 1.0432981784 -0.0094999822 + 732 1.0100329834 -0.0645473082 0.9549045379 -0.0675747405 + 733 0.9987553444 0.0827235631 1.0196166390 0.0362547635 + 734 0.9960860895 -0.0135121096 0.9924516537 -0.0070308228 + 735 1.0268201414 0.0263296034 1.0131163197 -0.0265268408 + 736 1.0199423267 -0.0161321485 0.9857909084 -0.0156168557 + 737 0.9898246420 -0.0185202625 1.0202204816 0.0138266641 + 738 1.0162822389 -0.0175187242 0.9450121788 -0.0518535067 + 739 0.9711311271 -0.0448855850 0.9454419260 -0.0442260503 + 740 1.0409785006 -0.0106432614 0.9062022307 0.0504144853 + 741 1.0039399394 0.0233120831 1.0036348017 0.0057811218 + 742 1.0156858093 0.0018168782 1.0373872628 0.0104623717 + 743 1.0154478879 -0.0106195307 0.9608670851 0.0481145751 + 744 1.0465440719 0.0039543589 0.9852786204 -0.0022184824 + 745 0.9731204424 -0.0493801548 0.9834208014 0.0235675100 + 746 0.9819493390 -0.0143191400 0.9852504746 0.0534342483 + 747 0.9931214076 -0.0147751072 1.0529696800 0.0392531535 + 748 1.0110833579 0.0298510271 0.9624471767 0.0036042599 + 749 0.9626208160 -0.0020032354 0.9661054959 0.0509165818 + 750 0.9807390708 0.0427582162 0.9866614390 0.0185631545 + 751 0.9864940376 0.0170068919 0.9850932758 0.0158791450 + 752 1.0133534526 -0.0234894064 1.0014656872 0.0338954820 + 753 0.9874570070 0.0028940395 0.9872961615 0.0382947311 + 754 0.9961939959 0.0656570636 0.9657713843 -0.0239368085 + 755 0.9822648731 0.0394706508 1.0120826608 -0.0005844137 + 756 1.0031843606 0.0490789922 0.9949269650 0.0036318141 + 757 1.0258208171 -0.0189936971 0.9969057173 0.0416243247 + 758 0.9976690309 0.0335868743 0.9712741833 -0.0145096384 + 759 1.0039579877 0.0062610444 1.0579865516 -0.0183062678 + 760 1.0001874367 -0.0263646876 0.9948703958 -0.0348906800 + 761 0.9892473755 -0.0160972498 0.9873946527 0.0169770010 + 762 0.9819140962 0.0157250960 1.0379703528 -0.0450258010 + 763 0.9958035851 -0.0203235636 0.9600629328 -0.0205845031 + 764 1.0065870840 -0.0143294862 0.9763713760 -0.0549561753 + 765 0.9832953279 0.0442141901 0.9639557510 0.0298025415 + 766 1.0034809620 0.0301897709 0.9631633719 0.0249519158 + 767 0.9520524580 0.0129652372 0.9560710837 -0.0736849387 + 768 1.0195029534 0.0267147423 0.9878110799 0.0174187390 + 769 1.0044552974 -0.0601580404 1.0034733841 -0.0464108533 + 770 0.9983251740 0.0164589048 1.0001358888 0.0404772646 + 771 0.9829658245 -0.0802490517 1.0280039698 0.0488917344 + 772 0.9988473202 -0.0973064167 0.9818426809 -0.0178329329 + 773 1.0038182121 0.0500347686 0.9637643279 0.0443988514 + 774 0.9665434883 -0.0097168229 1.0110082489 0.0222985975 + 775 0.9525450905 0.0331882011 0.9969681786 -0.0399379370 + 776 1.0284657895 -0.0213596323 1.0162783599 -0.0223145220 + 777 0.9822982456 0.0423505509 1.0356450167 0.0285248146 + 778 1.0267027293 0.0454583942 0.9882805154 -0.0124182656 + 779 1.0002875384 0.0121063937 1.0180954040 0.0010296686 + 780 0.9382404384 0.0389758629 0.9925036573 -0.0515870890 + 781 1.0124524627 0.0015521012 0.9631975781 0.0803519333 + 782 0.9637093428 -0.0120948536 0.9752951360 0.0125090768 + 783 1.0145414128 -0.0212199856 1.0423131426 0.0669714759 + 784 1.0027790386 0.0371333826 1.0056329246 0.0605644292 + 785 0.9882460823 0.0380550411 0.9997334624 0.0036341385 + 786 0.9538921243 -0.0643284070 0.9848631866 0.0578841141 + 787 0.9877629493 -0.0130155204 0.9825768143 -0.0042457206 + 788 0.9650337114 0.0112816478 1.0075380916 -0.0695259142 + 789 1.0254288924 0.0193779802 1.0133257294 0.0226711661 + 790 1.0056569736 -0.0120294354 0.9904925008 0.0262961756 + 791 1.0089460512 0.0227752206 1.0179518901 0.0007987800 + 792 1.0191100195 -0.0091441483 0.9948907930 -0.0459768424 + 793 0.9983124910 0.0433073533 1.0215181557 0.0114528739 + 794 1.0289320741 0.0650704136 1.0139679702 -0.0183081357 + 795 0.9896370510 -0.0491239791 1.0144304433 -0.0605080966 + 796 0.9827352087 0.0239098968 0.9559740850 -0.0409058085 + 797 0.9721625517 0.0057238536 0.9913690277 -0.0128067193 + 798 1.0077766816 -0.0218480305 1.0146995854 -0.0010484345 + 799 0.9693846287 0.0315664009 1.0314215087 -0.0018183157 + 800 1.0331427213 -0.0407379925 0.9850759311 -0.0020411776 + 801 0.9872243795 -0.0385958106 1.0443807672 -0.0139089693 + 802 1.0343445020 0.0395104473 0.9583849856 0.0024649226 + 803 1.0005538534 0.0480954160 0.9952543925 0.0337059038 + 804 0.9672042626 0.0171132877 1.0097339539 0.0178865959 + 805 0.9932008795 0.0048336150 1.0579585335 0.0174239316 + 806 1.0424945436 0.0281593426 1.0048488427 0.0515129508 + 807 0.9301719628 0.0449097470 1.0071420095 0.0349682278 + 808 1.0066689133 -0.0535887739 1.0152241717 0.0315363578 + 809 1.0135147851 0.0482167520 1.0295305385 0.0000755731 + 810 1.0148800513 -0.0237232561 0.9831329508 0.0255859051 + 811 1.0155698420 0.0576107921 1.0061848818 0.0123404399 + 812 1.0272968125 0.0471233337 1.0009616024 -0.0087416894 + 813 1.0227113799 0.0376325589 0.9870147439 0.0377530405 + 814 1.0164736919 -0.0164938778 0.9648262268 0.0204576201 + 815 0.9860939150 0.0072886473 0.9726619572 -0.0044660850 + 816 1.0100070979 0.0167437229 1.0114587621 0.0529458807 + 817 1.0031842445 -0.0142934588 0.9654830101 -0.0315801681 + 818 0.9843645110 0.0012365579 1.0246812383 0.0165512534 + 819 1.0128976201 0.0373069190 1.0150781258 0.0327725760 + 820 0.9786149507 0.0626983149 1.0017160456 0.0544669786 + 821 0.9856628262 -0.0013454652 0.9966381261 -0.0330322756 + 822 0.9688589818 -0.0300059879 1.0252008854 -0.0318491477 + 823 0.9831556181 0.0860131956 0.9745323770 -0.0125571380 + 824 1.0207281042 0.1114589883 0.9811282764 0.0227469646 + 825 0.9900206712 -0.0021922585 1.0405915687 -0.0330601036 + 826 0.9769159001 0.0338496245 1.0217517651 0.0264941161 + 827 1.0033906939 -0.0223878340 1.0436346715 0.0297857081 + 828 0.9687842759 -0.0448645492 1.0104903266 0.0127369316 + 829 1.0177220206 -0.0077881663 0.9743580973 0.0104411608 + 830 1.0166431817 0.0427297507 1.0162638037 0.0176156701 + 831 0.9792750636 0.0130000910 1.0263118819 -0.0313515026 + 832 1.0002027392 -0.0583809586 1.0191801109 0.0230342419 + 833 0.9972690636 0.0224740447 1.0228874475 0.0015369902 + 834 0.9904311491 0.0167890823 1.0167983221 -0.0161483135 + 835 0.9947170245 0.0162975314 0.9988001557 -0.0256323694 + 836 1.0134376140 -0.0277768411 0.9702463477 -0.0411086492 + 837 1.0419760885 -0.0882627442 1.0201126442 -0.0382590297 + 838 0.9972474757 -0.0332187709 0.9882633475 -0.0237828472 + 839 0.9746123166 0.0476165255 0.9921609083 -0.0434213133 + 840 1.0231310710 -0.0021508795 0.9781140925 0.0135529007 + 841 1.0030762014 0.0425641062 0.9649124653 -0.0421613075 + 842 1.0181889368 0.0223070174 0.9654425378 0.0211102615 + 843 0.9795984842 -0.0579701682 1.0303370689 -0.0082699258 + 844 0.9666112491 -0.0000404163 0.9834587983 0.0083830737 + 845 1.0558444278 0.0454385637 0.9693084668 0.0598639513 + 846 0.9928283156 -0.0377088604 0.9547194141 0.0350210548 + 847 0.9873689797 0.0410902385 0.9702512175 0.0296505593 + 848 0.9798395668 -0.0203778113 1.0203693503 -0.0104521528 + 849 1.0044461756 -0.0425592412 0.9677273718 0.0189365083 + 850 0.9534172506 -0.0223429592 1.0006423448 0.0015947834 + 851 1.0601874170 0.0292139357 0.9861240636 -0.0261667575 + 852 1.0236541324 -0.0183176538 0.9654370986 0.0083428952 + 853 0.9597580528 0.0070743457 0.9831606380 -0.0212142283 + 854 0.9889847184 -0.0374994921 1.0097888508 -0.0575426615 + 855 0.9670114735 -0.0442149717 1.0260076717 -0.0217506356 + 856 0.9987288030 -0.0010369583 1.0852246758 -0.0681587345 + 857 1.0226731060 -0.0124675220 0.9769236130 -0.0692105490 + 858 0.9579160966 -0.0480938376 0.9712371820 -0.0633442127 + 859 1.0370926810 0.0582670230 0.9989744424 -0.0250671088 + 860 0.9663266803 -0.0288184163 1.0055202481 -0.0519252810 + 861 0.9689076354 -0.0897303117 1.0080507431 -0.0140033841 + 862 0.9841300259 0.0112933660 0.9811874516 0.0280352001 + 863 0.9876162907 -0.0238585135 1.0215555463 -0.0059665515 + 864 0.9606419133 -0.0591469857 0.9825212192 -0.0288391958 + 865 0.9971826055 -0.0219725830 0.9947624627 0.0668877184 + 866 0.9995137465 0.0244179893 1.0107396086 -0.0315114616 + 867 1.0343236596 0.0003305469 1.0471062461 -0.0679287831 + 868 1.0244696010 -0.0917480542 1.0302418230 0.0025800498 + 869 0.9904278521 0.0230182645 1.0130746506 -0.0019831213 + 870 0.9930086248 -0.0490105124 0.9738844915 0.0319219699 + 871 0.9694600020 -0.0051772638 0.9617703365 -0.0084615638 + 872 0.9246591765 0.0023911340 0.9860236997 -0.0248968864 + 873 1.0370602484 -0.0245617578 1.0071453065 0.0060406508 + 874 1.0565168880 0.0119142622 1.0043923772 -0.0404573581 + 875 0.9832704489 0.0048787789 1.0061715096 -0.0371269656 + 876 1.0019785004 -0.0057944658 1.0094178049 0.0346548956 + 877 0.9514608383 0.0188745657 1.0129034408 0.0301995980 + 878 1.0700421781 0.0380369366 1.0036938623 -0.0081055844 + 879 0.9989749711 0.0242557340 1.0053369371 0.0430977485 + 880 0.9928304061 0.0091391719 0.9918189746 -0.0373189275 + 881 1.0342686686 -0.0271395031 1.0043343236 -0.0134392408 + 882 1.0007601839 -0.0224600287 0.9683080891 -0.0101949644 + 883 0.9835505758 -0.0438456274 1.0013054929 0.0232696400 + 884 0.9790540200 0.0459512975 1.0322329398 0.0824852436 + 885 0.9995178196 0.0107875570 1.0119311058 -0.0432473680 + 886 0.9936592491 0.0370219217 1.0308221709 0.0309826876 + 887 1.0114890739 0.0167562891 0.9948941761 0.0001987116 + 888 0.9372160476 0.0055741409 1.0174604171 0.0457392516 + 889 1.0070166589 -0.0009506125 1.0024656586 0.0435782450 + 890 1.0026980535 -0.0069205212 0.9730727985 0.0166234855 + 891 0.9970648816 -0.0339052368 0.9940795887 0.0339546102 + 892 1.0065360094 -0.0145109394 0.9965989300 0.0391073028 + 893 1.0255345367 -0.0650304291 0.9760694917 0.0406311610 + 894 0.9628636508 -0.0108227758 0.9907441296 -0.0574195660 + 895 1.0031772835 -0.0039045925 1.0015082720 -0.0703382868 + 896 1.0328274534 -0.0622502759 0.9815687391 -0.0164296542 + 897 0.9938237983 0.0192984965 1.0014201285 -0.0197173379 + 898 0.9972090159 0.0181319466 0.9800844899 0.0188331969 + 899 1.0196385470 -0.0008088017 1.0217964811 0.0248806562 + 900 0.9674886308 -0.0405265280 1.0319316511 0.0596406179 + 901 1.0213980347 -0.0010033866 0.9938530780 0.0170848822 + 902 0.9917322553 -0.0240683372 1.0119949187 -0.0426837403 + 903 1.0362053157 -0.0388274911 0.9911681615 -0.0819552296 + 904 1.0061098013 0.0030034057 0.9816047903 0.0421946002 + 905 1.0086571350 0.0046419874 1.0435501809 0.0218871021 + 906 1.0141796845 -0.0010710539 0.9862338500 -0.0152781153 + 907 0.9771724421 0.0086397882 0.9945651501 0.0227671483 + 908 0.9789254504 0.0413127679 0.9559675965 0.0221746521 + 909 0.9717773453 -0.0179406331 0.9740297342 0.0259593051 + 910 0.9920413345 -0.0459080681 1.0580469439 0.0027058285 + 911 0.9564428309 -0.0269978128 1.0059151885 0.0095452285 + 912 0.9847426297 0.0493797746 0.9955082363 -0.0428827830 + 913 0.9805782999 -0.0326094946 1.0270437507 -0.0554523476 + 914 0.9564383094 -0.0548673655 0.9796920037 0.0331832004 + 915 0.9835002350 0.0246040355 1.0047248412 0.0102358808 + 916 1.0395579649 0.0017976806 1.0032873533 -0.0058388903 + 917 0.9905421297 -0.0359199706 1.0140174059 0.0233733048 + 918 0.9853759918 0.0340937050 0.9920644571 -0.0150944576 + 919 0.9818191170 0.0052766620 1.0366113732 -0.0264609298 + 920 1.0038321962 -0.0164749524 1.0184506221 0.0583632723 + 921 0.9714315944 -0.0545474765 1.0384127179 -0.0054091314 + 922 0.9850831831 0.0259293135 1.0550085626 0.0308220494 + 923 1.0225014308 0.0255877043 0.9908809632 -0.0126231486 + 924 1.0098180909 -0.0319572939 0.9971069218 0.0006024364 + 925 1.0168545497 -0.0553373075 1.0174811918 -0.0588144906 + 926 0.9922018588 0.0223559193 1.0202906876 -0.0410292998 + 927 0.9863606933 -0.0264870535 0.9759187507 0.0707036862 + 928 0.9759681371 0.0345028913 0.9980917676 -0.0184661130 + 929 0.9965010929 0.0078858791 0.9895431216 0.0186338728 + 930 0.9589701074 0.0163847117 0.9800374762 0.0533283098 + 931 1.0148027273 0.0028225610 0.9648072850 -0.0322349121 + 932 1.0334470511 0.0285779124 0.9936550036 -0.0179330155 + 933 0.9865283114 -0.0052634195 1.0427191332 -0.0191900238 + 934 0.9929046731 -0.0176956075 0.9896880534 0.0172464566 + 935 1.0257929652 0.0039258218 1.0262251678 0.0190182940 + 936 0.9723456089 0.0018445293 0.9645144209 0.0188526761 + 937 0.9545381277 0.0633345605 1.0146084181 -0.0598203085 + 938 1.0083746435 -0.0397299670 1.0478986292 0.0376714154 + 939 0.9938285279 0.0077566448 1.0065920820 0.0143702873 + 940 0.9720410293 -0.0712421833 1.0298812609 -0.0190036913 + 941 0.9808761568 0.0861780958 0.9972861155 0.0105550645 + 942 1.0175148527 0.0672473181 1.0020511845 0.0402112177 + 943 1.0154464778 -0.0013778117 1.0355741850 0.0823840731 + 944 1.0069749715 -0.0011859899 1.0336825220 -0.0390792568 + 945 1.0208508874 0.0058940746 1.0070956477 -0.0031241385 + 946 1.0033814616 0.0479294061 0.9876629151 0.0170507469 + 947 0.9785783271 -0.0133440885 0.9679786813 -0.0242142132 + 948 0.9944195517 0.0174902363 0.9874222969 -0.0215238507 + 949 0.9987298430 -0.0624937839 1.0304804098 0.0097733728 + 950 1.0306040171 0.0003976635 0.9902114020 0.0447884835 + 951 1.0138282285 0.0571752703 1.0151189792 -0.0681874733 + 952 0.9923818504 -0.0375509794 1.0024972752 -0.0127243179 + 953 1.0039066825 0.0398613197 0.9891082233 -0.0153847200 + 954 0.9911821777 0.0011733136 0.9789419996 -0.0357455319 + 955 1.0392934746 0.0062237050 1.0003380423 0.0012405484 + 956 0.9486981755 0.0115065838 1.0169517426 -0.0007989386 + 957 0.9985829645 -0.0290625438 0.9841907880 0.0233015581 + 958 1.0039702807 0.0235369611 0.9812024674 -0.0321769887 + 959 1.0505241795 -0.0092211852 1.0112938247 0.0246027447 + 960 1.0069144326 0.0019768591 0.9809664716 0.0178642200 + 961 0.9817714953 0.0106890489 0.9932272685 0.0067049526 + 962 1.0320734411 -0.0000530931 0.9808932199 -0.0848024790 + 963 1.0153086766 0.0241060398 1.0352445671 0.0220746145 + 964 0.9884157084 -0.0817876354 0.9548253182 -0.0192962275 + 965 0.9984107927 -0.0535630377 0.9738224283 -0.0345506420 + 966 1.0360345422 0.0027523186 1.0206246184 0.0009769448 + 967 1.0343880246 0.0000216399 0.9979012087 0.0922683054 + 968 1.0088381379 -0.0052871480 0.9589723551 -0.0194457815 + 969 1.0436030468 -0.0285474437 1.0105700848 -0.0077799928 + 970 1.0091525607 -0.0487281231 0.9836711193 0.0489340585 + 971 1.0325023181 0.0472290348 0.9506156094 -0.0832855791 + 972 0.9885163138 0.0100624029 0.9909158763 0.0163013834 + 973 0.9560975831 0.0163147374 0.9653755464 0.0250278064 + 974 0.9830553477 -0.0108048416 1.0053545045 0.0656618426 + 975 1.0029580266 -0.0118135059 1.0113317077 -0.0185735815 + 976 1.0309761596 -0.0742857101 0.9666870750 -0.0300558338 + 977 0.9555889549 -0.0566341082 0.9656574802 0.0131391671 + 978 1.0285096690 0.0414780933 1.0188969004 -0.0202573940 + 979 1.0504185342 -0.0097999587 0.9855534065 -0.0050091958 + 980 1.0014066089 -0.0217901548 0.9930353551 0.0143048732 + 981 1.0133458139 -0.0189062190 1.0125189614 -0.0515415537 + 982 1.0125744318 0.0625406377 1.0093315591 -0.0176690428 + 983 0.9969626922 -0.0390998770 1.0205079354 0.0307236292 + 984 1.0170015725 0.0112819644 1.0209396748 0.0552329713 + 985 0.9812599614 -0.0181750346 1.0053065507 -0.0123312399 + 986 1.0129883579 0.0210724326 0.9892621700 0.0528889127 + 987 1.0134279444 0.0175964606 0.9638609654 0.0139270508 + 988 1.0134809574 -0.0233872077 1.0436031692 0.0035042862 + 989 1.0251872226 0.0045713682 0.9632691449 0.0087931281 + 990 1.0482228148 0.0305766260 0.9792102867 0.0259004562 + 991 0.9504877848 0.0150485537 0.9775219277 -0.0310600552 + 992 1.0566075809 0.0509779304 1.0144796170 0.0007929962 + 993 0.9890871506 0.0181158353 0.9792404079 0.0133652246 + 994 1.0019578263 0.0228180266 0.9893235757 0.0044069085 + 995 0.9406712459 0.0123310985 0.9730242137 -0.0001423970 + 996 0.9953177855 -0.0129913715 0.9923336531 -0.0019060061 + 997 0.9641137234 -0.0018171517 0.9907287681 -0.0178442161 + 998 1.0044265597 -0.0467383075 1.0323264024 0.0087864990 + 999 1.0029318027 -0.0202900376 0.9883115237 0.0102100971 + 1000 1.0012165294 -0.0072129095 0.9921461790 -0.0470144979 + 1001 0.9704195153 -0.0096478585 1.0028101394 -0.0179943866 + 1002 0.9873936049 0.0028894275 1.0635631958 -0.0340356418 + 1003 1.0138535972 0.0135616269 0.9946257837 -0.0391939152 + 1004 0.9924779523 0.0436928783 1.0454732219 0.0133283540 + 1005 1.0194050990 0.0419372667 1.0005805488 -0.0124980991 + 1006 1.0076652631 -0.0548921844 1.0279582475 -0.0329029452 + 1007 0.9910764717 0.0224843130 0.9933496621 -0.0467568280 + 1008 1.0092722482 -0.0209177706 0.9961955385 0.0356646437 + 1009 0.9919344403 0.0337506070 1.0233889795 -0.0152207108 + 1010 1.0186883667 -0.0082358174 0.9812639185 0.0620584733 + 1011 0.9501130691 0.0122371634 1.0103907916 -0.0369105512 + 1012 0.9848752286 -0.0166990481 0.9773307310 -0.0240365925 + 1013 1.0156739280 0.0049208399 1.0074062062 0.0181718930 + 1014 1.0075959707 -0.0013142903 0.9729015934 -0.0205121381 + 1015 0.9899493029 -0.0071022435 1.0627663220 0.0074434559 + 1016 1.0114314454 -0.0007225646 0.9833101889 0.0734954746 + 1017 0.9795941746 0.0281852459 0.9991220753 -0.0279023674 + 1018 1.0002352021 -0.0086186049 1.0117600764 -0.0437026491 + 1019 0.9732081553 -0.0309122296 1.0251412427 0.0040454323 + 1020 0.9907883546 0.0107261438 0.9802518689 0.0086719414 + 1021 0.9848854600 0.0368950560 0.9864392451 0.0354932854 + 1022 1.0004590612 -0.0018228364 1.0011456988 0.0092239976 + 1023 0.9735379394 -0.0206390643 0.9695717154 0.0285043106 + 1024 0.9813502192 0.0357834704 0.9853272765 0.0081438632 + 1025 0.9953863793 -0.0360879090 0.9973411604 0.0226708515 + 1026 1.0275162718 0.0564315610 1.0040907686 0.0551596181 + 1027 0.9794246733 0.0133241739 1.0060927272 -0.0651507221 + 1028 1.0328649354 0.0153268898 1.0115676822 -0.0154474802 + 1029 1.0142484545 0.0150675121 0.9891742213 0.0328809051 + 1030 0.9854862378 0.0157791616 1.0070913825 0.0121816029 + 1031 1.0028119356 -0.0079506998 0.9769084995 -0.0300311415 + 1032 0.9820255270 0.0653979844 0.9935119072 -0.0021545513 + 1033 1.0275209872 0.0174022726 1.0172443181 0.0698907960 + 1034 0.9995808539 0.0013468624 1.0035042234 0.0160833529 + 1035 1.0191993281 0.0187147771 0.9918179038 -0.0346471006 + 1036 1.0128946117 0.0268453697 0.9687512432 -0.0100714167 + 1037 0.9735089505 0.0574319257 0.9956050702 -0.0047904707 + 1038 1.0014928133 -0.0148548209 1.0157738134 0.0032013125 + 1039 0.9735214095 0.0730063597 0.9717631160 0.0519274577 + 1040 1.0424264176 0.0085083384 1.0406652315 -0.0101427379 + 1041 1.0181803128 0.0261448533 1.0113705086 0.0016408860 + 1042 0.9897954646 -0.0097150045 0.9955623147 -0.0263681164 + 1043 0.9901001201 -0.0018421807 0.9978733239 -0.0140895092 + 1044 1.0088520178 -0.0191261851 1.0130509524 0.0269676979 + 1045 0.9807367496 -0.0003141802 0.9775137116 0.0167702534 + 1046 0.9758489338 0.0266940395 0.9926578915 0.0214005666 + 1047 0.9743769603 0.0370277630 1.0040846103 0.0083581802 + 1048 1.0104288198 0.0593470698 1.0013436202 0.0369815759 + 1049 0.9783971157 -0.0134047724 0.9825409176 -0.0046962521 + 1050 0.9940823657 -0.0016798590 0.9906704688 0.0412037921 + 1051 0.9827971924 0.0076051475 0.9874715367 -0.0036861454 + 1052 0.9996552052 -0.0041321963 0.9804632668 0.0139082223 + 1053 0.9837663290 -0.0045772992 1.0061204824 -0.0202959517 + 1054 1.0516237475 -0.0100392546 1.0145750273 0.0310611963 + 1055 1.0470582235 0.0483259980 1.0185007483 -0.0791339282 + 1056 1.0018098179 0.0084546019 1.0169217002 -0.0090949908 + 1057 1.0164298605 0.0010309932 1.0033812786 0.0158703830 + 1058 1.0181507299 0.0029334350 1.0167052599 -0.0580523844 + 1059 1.0076333686 0.0252341659 1.0171549224 -0.0125332013 + 1060 0.9757147589 0.0002691276 0.9790426501 0.0365902965 + 1061 0.9846074606 -0.0104146251 1.0122386422 0.0021857920 + 1062 0.9896587402 -0.0117476839 1.0097693110 0.0252875213 + 1063 1.0277490232 -0.0128184068 0.9658943709 -0.0057365598 + 1064 1.0214982026 0.0000233256 0.9773953649 -0.0003568798 + 1065 0.9675273732 0.0008330701 1.0054907883 0.0226567776 + 1066 0.9994639876 -0.0278435397 0.9860898178 -0.0564763099 + 1067 1.0017347779 0.0050206221 0.9963153446 0.0610932651 + 1068 0.9948531849 0.0156738381 0.9883824334 0.0220901900 + 1069 1.0304651439 -0.0198192446 0.9950441681 0.0491875198 + 1070 0.9913349668 -0.0022770963 0.9819580535 -0.0219342614 + 1071 1.0072052160 0.0028049497 0.9922790758 0.0164211451 + 1072 1.0021293476 0.0220283797 0.9703910037 -0.0147502826 + 1073 1.0587825378 -0.0186898546 0.9882427718 -0.0341422112 + 1074 0.9888803177 -0.0244313452 1.0045768701 0.0034558518 + 1075 0.9924696728 -0.0368479131 0.9952632212 -0.0175897509 + 1076 0.9551620874 0.0094423429 1.0142398996 0.0031708084 + 1077 1.0308660461 -0.0447269176 0.9915942656 0.0049480346 + 1078 0.9780712650 -0.0339751788 0.9857060490 0.0455550546 + 1079 0.9994816231 -0.1018153291 0.9814081075 -0.0493824181 + 1080 1.0216050327 0.0044937405 0.9985644706 -0.0032958788 + 1081 0.9837813460 0.0216746941 0.9434733633 -0.0182128209 + 1082 1.0127483029 -0.0313360484 1.0168070464 0.0210897191 + 1083 1.0158765676 -0.0214662507 0.9910378111 -0.0015161617 + 1084 0.9681100055 0.0273128546 1.0096701438 -0.0291784443 + 1085 0.9871756619 -0.0284575833 1.0396652874 -0.0146124210 + 1086 0.9827211243 -0.0148933987 1.0036045471 0.0099636378 + 1087 0.9853285996 -0.0223038899 1.0220693021 -0.0361595059 + 1088 1.0226543536 0.0112803378 0.9820046252 0.0694280498 + 1089 0.9908726076 0.0346518720 0.9678812151 0.0186409102 + 1090 1.0426584415 -0.0151007195 1.0486938093 0.0436085572 + 1091 1.0218805010 0.0394097374 0.9809431789 0.0466855227 + 1092 0.9779516701 0.0040809689 0.9874126511 -0.0410387046 + 1093 1.0053345340 -0.0028727575 0.9938901066 -0.0018860204 + 1094 0.9882624884 0.0370760437 0.9749563338 -0.0198076821 + 1095 0.9854094956 0.0271539122 1.0167971530 -0.0160870187 + 1096 1.0268098464 -0.0170609897 1.0052770923 0.0353796524 + 1097 1.0201946024 0.0348291459 1.0058739566 0.0022543578 + 1098 0.9870983102 0.0441040233 1.0310869143 0.0030618596 + 1099 0.9830379493 0.0127712636 0.9600984739 0.0106027685 + 1100 1.0351850726 0.0068659493 1.0103450254 -0.0489625783 + 1101 1.0105322453 0.0447338672 1.0193500103 0.0242463181 + 1102 1.0095504116 0.0052904586 0.9897063867 -0.0175404441 + 1103 0.9858042977 -0.0109465973 1.0433175679 0.0060908810 + 1104 1.0041300983 -0.0297846699 1.0189604801 -0.0103070336 + 1105 0.9708138310 -0.0214721060 1.0316209149 0.0243877069 + 1106 1.0299609226 -0.0299163475 0.9955957779 0.0311069016 + 1107 0.9945311171 -0.0438336057 1.0078766733 0.0140042381 + 1108 0.9781070285 0.0175803458 1.0029320396 0.0267613525 + 1109 1.0025481579 -0.0209496599 0.9714149835 -0.0621894755 + 1110 0.9971163174 -0.0014275602 1.0083562106 0.0028918478 + 1111 1.0002380209 0.0752726302 0.9455860039 -0.0024400652 + 1112 1.0486505844 0.0333307444 1.0121726905 0.0128109696 + 1113 1.0323253982 -0.0284639960 1.0125546815 -0.0070368969 + 1114 1.0149480009 -0.0499251476 1.0052932870 -0.0017628835 + 1115 1.0177171528 0.0160628980 0.9938140088 0.0145763566 + 1116 1.0099322035 -0.0022799347 1.0187542908 0.0203244096 + 1117 0.9788016912 -0.0202046055 0.9656194757 0.0132752342 + 1118 1.0159388518 -0.0526770112 1.0115265474 -0.0048424561 + 1119 0.9989289297 -0.0634112849 1.0281267698 0.0229402800 + 1120 0.9942294985 0.0218808208 0.9927783322 0.0255570135 + 1121 0.9724479999 0.0020742225 0.9785420430 0.0284562515 + 1122 1.0245853639 -0.0369630231 0.9849862900 -0.0118416686 + 1123 0.9917515001 0.0380622257 1.0276193123 -0.0214181481 + 1124 0.9931018754 -0.0349607687 1.0110877783 -0.0263901202 + 1125 0.9969271161 0.0093464065 1.0037743191 -0.0274017104 + 1126 1.0189913785 0.0468269402 1.0178935473 -0.0041318493 + 1127 0.9952294765 -0.0421501025 0.9984846632 0.0049575288 + 1128 1.0015150071 -0.0502975340 0.9769614377 0.0173548723 + 1129 0.9818606910 0.0201703868 1.0018759938 0.0840154331 + 1130 0.9954741962 0.0516495479 1.0036427807 -0.0251992489 + 1131 1.0388446216 -0.0565902855 0.9992283868 -0.0367053432 + 1132 0.9764671701 -0.0192846138 1.0241155038 0.0426211696 + 1133 0.9904703395 0.0229516190 1.0183500814 0.0303918399 + 1134 0.9592682071 0.0337148989 1.0016179960 -0.0135925839 + 1135 1.0367234298 -0.0195055171 0.9834747897 -0.0165449390 + 1136 0.9890911659 0.0255707257 1.0182179955 -0.0042887608 + 1137 1.0328700558 -0.0086737472 0.9398698799 0.0108838889 + 1138 0.9664591394 0.0104579507 1.0080567047 -0.0139442421 + 1139 1.0169991128 -0.0357831488 0.9839030817 -0.0366116808 + 1140 1.0193854998 -0.0043628077 1.0363479310 -0.0503733148 + 1141 0.9901768964 0.0248653260 0.9579103512 -0.0096252171 + 1142 0.9870349157 0.0350847367 0.9931823142 0.0383627738 + 1143 1.0591798163 -0.0261223041 1.0083613107 -0.0485243905 + 1144 0.9877290874 -0.0543700927 0.9993983289 0.0102203477 + 1145 1.0020759578 -0.0414945281 0.9894978219 -0.0368153080 + 1146 1.0123794277 0.0406404196 1.0006478844 -0.0400259822 + 1147 0.9908254075 0.0184454824 1.0121549983 -0.0044573076 + 1148 1.0151720463 0.0280437437 1.0263921234 0.0495093409 + 1149 1.0297332774 -0.0082770210 0.9919734832 0.0432529090 + 1150 1.0046748281 -0.0235217366 0.9938805528 -0.0348570671 + 1151 1.0420725713 0.0146505860 0.9913246361 0.0251296511 + 1152 0.9928703591 0.0046270701 0.9951573849 -0.0101670275 + 1153 1.0077558261 0.0357807277 0.9999149045 0.0055112388 + 1154 0.9893890726 -0.0150000389 1.0643325322 0.0015816767 + 1155 1.0116784586 0.0020347490 0.9856485635 -0.0173767503 + 1156 0.9682823833 -0.0250010011 1.0180984664 0.0205889297 + 1157 1.0370694483 0.0284695350 0.9807133425 -0.0474027014 + 1158 1.0208351727 -0.0013392984 0.9985458958 -0.0519666356 + 1159 1.0115755768 -0.0080639259 1.0450299014 0.0244209110 + 1160 0.9941039213 -0.0015566791 1.0066810576 0.0411485627 + 1161 0.9862430760 0.0162776364 0.9865380850 0.0169305278 + 1162 0.9721463178 -0.0006829655 0.9637036370 -0.0075670210 + 1163 0.9824191334 0.0208390974 0.9917566107 -0.0161023172 + 1164 1.0228509974 -0.0200267255 1.0022868131 -0.0118114819 + 1165 1.0189091216 0.0345896060 0.9676285137 0.0096487683 + 1166 0.9883540729 -0.0487024525 0.9808655433 0.0365376319 + 1167 1.0183293998 0.0194622371 1.0009022732 0.0141124100 + 1168 0.9896930598 -0.0434999729 1.0097547192 0.0095833382 + 1169 1.0217713739 -0.0373229330 1.0342229846 0.0216209946 + 1170 1.0180856459 -0.0191729367 0.9839530826 0.0459958806 + 1171 0.9896173994 -0.0341431904 0.9738265247 0.0202157496 + 1172 1.0234507320 -0.0242498726 1.0271646762 -0.0015818661 + 1173 0.9714219672 0.0272987771 0.9949877199 0.0141280272 + 1174 1.0171884862 -0.0260286469 1.0050253279 0.0113128887 + 1175 0.9654547489 0.0118222181 0.9863361081 -0.0629655703 + 1176 1.0144523856 -0.0196937663 1.0066195038 0.0297657892 + 1177 0.9817991942 -0.0075725008 1.0150486583 -0.0029957704 + 1178 0.9636619562 -0.0052542574 0.9876082083 -0.0089696972 + 1179 0.9901696252 -0.0076862358 0.9702395926 0.0499319188 + 1180 0.9971995572 0.0084883488 0.9919110490 -0.0520547690 + 1181 1.0075003575 -0.0419406665 1.0185859314 -0.0428994953 + 1182 1.0231084754 -0.0089450929 1.0136784030 -0.0177098963 + 1183 0.9976219820 -0.0022527620 1.0004996785 -0.0114005270 + 1184 1.0361209126 -0.0439370700 0.9818308043 0.0374373188 + 1185 1.0043350732 -0.0256947566 1.0245399066 -0.0050398015 + 1186 0.9962604235 -0.0394058213 1.0147276652 -0.0612213574 + 1187 0.9976434607 -0.0236226487 0.9993224364 -0.0164044147 + 1188 1.0235546464 -0.0219392655 1.0020730666 -0.0145037760 + 1189 1.0283250521 -0.0097327124 0.9889325777 -0.0164259201 + 1190 1.0157583547 -0.0013119065 1.0543115257 -0.0148500314 + 1191 0.9952007443 -0.0406962271 0.9743216949 0.0350525750 + 1192 1.0167764788 -0.0017576873 1.0188483496 0.0037289959 + 1193 0.9875424926 -0.0101993989 0.9839128646 0.0361690796 + 1194 1.0098898202 0.0117948720 1.0174921072 -0.0086690071 + 1195 0.9796610406 -0.0277840647 1.0172222256 0.0252443691 + 1196 1.0052177143 0.0567738057 0.9525758213 0.0235224443 + 1197 0.9880648981 0.0012234810 0.9864342427 -0.0117432281 + 1198 1.0153741704 -0.0056202458 1.0171269499 -0.0080808903 + 1199 1.0193390301 0.0391520350 1.0422304668 0.0050301028 + 1200 0.9620503555 0.0188423457 0.9767956282 -0.0038088791 + 1201 0.9667377502 0.0016760039 0.9901687328 0.0381143126 + 1202 0.9857039530 -0.0788270317 1.0513005496 0.0155251778 + 1203 1.0034092968 -0.0064426850 1.0007331801 0.0433935317 + 1204 0.9703775952 0.0195004791 1.0119853647 -0.0365008227 + 1205 0.9655342184 0.0012661461 0.9837272688 0.0665024146 + 1206 0.9794234310 -0.0370527830 1.0117467742 -0.0052842569 + 1207 1.0224274226 -0.0081266204 0.9880733932 0.0637351981 + 1208 0.9866534441 -0.0356601137 1.0104181496 0.0078478758 + 1209 0.9965993934 0.0218200239 0.9996098243 0.0013785711 + 1210 1.0084746719 0.0349960436 1.0067324679 -0.0264051688 + 1211 0.9848861388 0.0159685251 1.0164542651 0.0107407030 + 1212 1.0301897757 -0.0586409083 0.9918887504 -0.0251525320 + 1213 1.0334248200 0.0440535260 1.0013063373 -0.0063777656 + 1214 1.0501299432 0.0334977946 1.0420942946 -0.0002072945 + 1215 0.9899212605 -0.0083086805 1.0021312196 0.0012283614 + 1216 1.0179254718 -0.0107697425 1.0427807548 -0.0592993981 + 1217 1.0186026562 0.0127493143 1.0029448074 0.0209554915 + 1218 1.0014553021 -0.0340543960 0.9772767221 -0.0294115803 + 1219 0.9820155170 -0.0302803879 0.9799702661 0.0106574366 + 1220 1.0128752567 -0.0213842674 0.9934993272 0.0492339168 + 1221 1.0096179459 -0.0106286490 1.0029389721 -0.0270667311 + 1222 1.0076018132 -0.0075004982 0.9857042705 0.0007793485 + 1223 0.9932176746 0.0458065939 1.0043880099 0.0247495837 + 1224 1.0171086027 -0.0084169166 1.0153130438 0.0087888885 + 1225 0.9922582832 -0.0206427660 0.9768572446 0.0062453995 + 1226 0.9943016197 0.0467030716 1.0213684882 0.0188977125 + 1227 0.9938485371 -0.0132892708 0.9807555150 0.0344620846 + 1228 0.9959490073 0.0563252370 0.9906690628 0.0056339247 + 1229 1.0032096306 0.0260404227 1.0074722051 -0.0190167218 + 1230 1.0174148542 0.0113788854 1.0236674493 -0.0263038599 + 1231 0.9857856256 -0.0154963017 0.9981089873 0.0228708485 + 1232 0.9734408023 0.0172094810 1.0141274278 0.0101743765 + 1233 1.0093469951 -0.0055225383 1.0263019858 -0.0278619403 + 1234 1.0232274154 -0.0332892090 1.0454581432 -0.0139083382 + 1235 1.0087847042 -0.0395801008 0.9858298427 0.0019742868 + 1236 0.9623754765 0.0248963882 0.9933471835 0.0683375065 + 1237 1.0249775289 -0.0371227409 1.0118646593 0.0125224443 + 1238 1.0169494903 -0.0196294622 0.9751755327 0.0030333308 + 1239 0.9800300086 -0.0027283020 1.0092013197 -0.0050047891 + 1240 0.9613164965 0.0175215696 1.0016122377 0.0122274975 + 1241 0.9772526484 0.0536981679 1.0370866590 -0.0098066322 + 1242 0.9843094155 -0.0073263917 0.9890327696 0.0038320626 + 1243 0.9815751759 0.0111927386 0.9989665477 -0.0088102934 + 1244 1.0000858816 -0.0227666556 1.0180548402 0.0337876189 + 1245 1.0060972660 -0.0553161857 1.0240524490 -0.0001695541 + 1246 0.9629042803 0.0157545020 0.9744535482 -0.0401721523 + 1247 0.9842215194 -0.0329441537 1.0011938691 0.0047157365 + 1248 0.9936892834 0.0154822715 0.9907056017 -0.0162090612 + 1249 1.0217678981 0.0167156827 0.9728318733 -0.0184756205 + 1250 0.9842819690 0.0463475991 0.9940025551 -0.0421063814 + 1251 1.0291457393 -0.0300073149 1.0259244013 -0.0195683600 + 1252 0.9863897263 0.0004502460 1.0159146322 0.0091849498 + 1253 1.0033741835 -0.0027637261 0.9968824097 0.0124084765 + 1254 0.9650217425 0.0419208300 0.9915739989 0.0211820972 + 1255 0.9752300823 -0.0003708872 1.0158349872 -0.0120360298 + 1256 1.0231243478 -0.0044061668 0.9748051101 -0.0052432602 + 1257 0.9697122876 -0.0679543333 1.0004046021 0.0621055906 + 1258 0.9894709532 0.0223206692 0.9925440836 -0.0310022952 + 1259 0.9820247610 -0.0237536845 0.9731593105 -0.0530455632 + 1260 0.9454589839 -0.0299769458 1.0264847229 -0.0118993185 + 1261 0.9905092939 0.0524771013 0.9814528688 0.0236003073 + 1262 0.9854204910 0.0202489827 0.9806288765 -0.0053944799 + 1263 1.0247973093 0.0264898313 1.0003334907 0.0323873664 + 1264 1.0200435450 0.0167882251 0.9940045789 0.0160529744 + 1265 1.0063531543 0.0062045806 0.9749439163 -0.0441984052 + 1266 0.9944512578 0.0239681458 0.9971898644 -0.0270795487 + 1267 1.0137225649 -0.0085483406 0.9989232054 0.0392098167 + 1268 1.0019126005 0.0399749407 1.0074706462 -0.0296253395 + 1269 1.0044154536 0.0175958103 1.0121601311 0.0048640628 + 1270 0.9954576497 0.0112721766 1.0120923780 0.0157163380 + 1271 1.0376119969 -0.0449567060 0.9945992067 -0.0293454205 + 1272 0.9584057545 -0.0004461581 1.0093174234 -0.0126281788 + 1273 1.0151371565 -0.0023514660 1.0320927614 -0.0166994842 + 1274 1.0028469933 -0.0045223056 1.0033753890 -0.0170365791 + 1275 1.0189476576 -0.0347826533 0.9984817415 -0.0123948444 + 1276 0.9775997350 0.0191620615 0.9671260682 -0.0068494203 + 1277 1.0037067950 0.0238411887 1.0248428867 -0.0158709454 + 1278 0.9682388340 0.0382148635 0.9904128423 -0.0096310913 + 1279 0.9981611275 -0.0446438432 1.0226343026 0.0211890566 + 1280 0.9572004111 0.0231997475 0.9863379856 0.0561328860 + 1281 1.0178408526 -0.0355105850 0.9651124490 -0.0239130197 + 1282 1.0187895150 -0.0328805091 0.9993820706 0.0102730657 + 1283 0.9630262133 -0.0015652321 1.0230982438 -0.0145543254 + 1284 1.0038153375 0.0324342033 0.9947532808 -0.0109523206 + 1285 1.0136486980 0.0171007312 1.0153845388 -0.0269585315 + 1286 0.9864500521 0.0382116635 0.9580422390 -0.0059127663 + 1287 1.0385691844 -0.0226899920 0.9682794293 -0.0331946557 + 1288 0.9934140331 0.0001880302 0.9995351064 -0.0040786100 + 1289 0.9700820059 -0.0025124374 1.0417551466 0.0116505741 + 1290 0.9783656932 0.0039928050 0.9998003584 0.0304641335 + 1291 1.0206120369 0.0159850388 1.0147253076 -0.0491388048 + 1292 0.9901228143 0.0400730510 1.0070667654 0.0600471965 + 1293 0.9843737354 -0.0566716889 0.9997170163 -0.0186289484 + 1294 1.0152487627 0.0047608561 0.9821588556 0.0222672165 + 1295 0.9772977289 0.0171472601 0.9941540339 -0.0029895215 + 1296 1.0040056710 0.0477076953 0.9954838993 0.0254442704 + 1297 0.9931590193 -0.0151991993 1.0161038663 0.0218714463 + 1298 1.0435930304 0.0183516888 0.9873496370 0.0411520139 + 1299 0.9714786420 0.0416389573 1.0151270775 0.0410321011 + 1300 1.0313726370 0.0599090675 0.9909911756 0.0262836879 + 1301 1.0271925722 0.0241699646 1.0157440859 0.0214285679 + 1302 1.0008217370 -0.0758573302 0.9965872547 -0.0275190776 + 1303 1.0138596181 -0.0358145910 0.9692270149 0.0019383119 + 1304 0.9956193217 0.0617100780 0.9894167708 -0.0003919603 + 1305 1.0250151412 -0.0256676316 1.0152137936 -0.0260073794 + 1306 0.9853671082 -0.0472028782 0.9875167050 0.0349110857 + 1307 1.0151062285 0.0463350639 1.0090201575 0.0174326269 + 1308 1.0083869458 0.0155888954 0.9806944621 0.0050507835 + 1309 0.9972027231 -0.0190410839 0.9837901942 0.0088498205 + 1310 1.0194366259 -0.0051958815 0.9952522303 -0.0265823473 + 1311 0.9910831890 -0.0416993581 1.0110099623 0.0205803112 + 1312 1.0255067684 -0.0114630421 1.0005861044 -0.0416218094 + 1313 1.0122063428 -0.0029202159 0.9737871148 0.0270690920 + 1314 1.0105274300 -0.0141475746 0.9654456179 0.0488880099 + 1315 0.9882230493 -0.0088748956 1.0251558709 -0.0443879508 + 1316 1.0117400463 -0.0171654500 1.0072591539 0.0008369455 + 1317 0.9826173212 -0.0313276176 0.9806887430 0.0063625118 + 1318 0.9946197402 -0.0001327871 1.0087274040 -0.0339560162 + 1319 0.9831342552 0.0015521684 1.0166180921 0.0278071023 + 1320 1.0262074804 0.0207039216 1.0168304117 -0.0751383418 + 1321 0.9622448340 0.0035464341 0.9795853719 0.0180167273 + 1322 0.9948158643 -0.0456816781 0.9877291909 0.0247731666 + 1323 1.0057594181 0.0119967249 0.9734623096 -0.0082566743 + 1324 0.9793236732 0.0046091618 1.0397141791 -0.0094630062 + 1325 1.0118703010 -0.0108166855 0.9571736994 -0.0161236756 + 1326 1.0024259876 -0.0246074538 0.9618928067 -0.0101610389 + 1327 1.0074198068 0.0017822208 1.0146168888 0.0100322575 + 1328 0.9817904571 -0.0203645372 1.0498269409 -0.0339660118 + 1329 1.0084961860 0.0104810090 1.0058128614 -0.0172848179 + 1330 0.9886732977 -0.0432614431 0.9959797422 0.0084576301 + 1331 0.9756247070 0.0225971031 0.9949482898 -0.0020695532 + 1332 0.9824498785 -0.0090006179 0.9977762683 -0.0377580701 + 1333 1.0068432600 0.0356340998 1.0095364553 0.0053649329 + 1334 0.9963864269 0.0122622962 0.9695508189 -0.0160801917 + 1335 1.0124373562 0.0048331528 1.0124370905 -0.0022576117 + 1336 0.9837755466 -0.0331773325 0.9929520738 -0.0058658396 + 1337 1.0200713121 0.0397458916 1.0370942339 0.0214821804 + 1338 0.9924364837 0.0195500610 0.9635950479 -0.0138700233 + 1339 1.0049772007 0.0378355866 0.9892420134 0.0043517431 + 1340 0.9669052489 -0.0382953102 0.9764499526 -0.0039604374 + 1341 1.0265873662 0.0674238205 0.9895915095 -0.0130723246 + 1342 0.9924321406 -0.0255754474 0.9704444400 -0.0488926244 + 1343 1.0106934600 -0.0090143769 0.9904418622 -0.0177726177 + 1344 1.0220274369 0.0129475896 0.9888431429 0.0311881535 + 1345 0.9989135799 -0.0679342352 1.0131925928 0.0215655578 + 1346 1.0056547003 -0.0010894314 1.0299410085 -0.0052357120 + 1347 0.9785112339 -0.0295951218 1.0219056578 -0.0019176806 + 1348 1.0226219805 -0.0094229277 1.0055190382 -0.0073929967 + 1349 1.0238943819 -0.0210956765 0.9931944848 0.0404661387 + 1350 1.0012041287 0.0196623211 0.9670409060 0.0427294959 + 1351 1.0275169516 0.0553093619 1.0137274187 0.0249573591 + 1352 1.0113670128 0.0177018143 1.0091589049 0.0163553657 + 1353 0.9802987599 -0.0286675322 0.9850753771 -0.0370394569 + 1354 0.9774658492 -0.0154598064 0.9879197329 -0.0147444463 + 1355 1.0267932803 0.0022032123 1.0063831981 0.0039870776 + 1356 0.9991469381 -0.0388686989 0.9680831816 -0.0299349660 + 1357 0.9808501578 0.0397274330 0.9753414529 -0.0194614911 + 1358 1.0081745468 0.0400863404 1.0321282713 0.0082582520 + 1359 0.9699295016 -0.0131615259 1.0077247828 -0.0073784091 + 1360 0.9736695971 0.0091022845 0.9902058856 -0.0214663904 + 1361 0.9880059541 -0.0132692694 0.9912751768 0.0015548538 + 1362 0.9670789118 0.0080473866 0.9918526705 -0.0015291746 + 1363 1.0280836286 0.0273078893 1.0307787771 0.0052299718 + 1364 0.9777721458 -0.0250687382 1.0314732792 0.0203045199 + 1365 1.0360409078 -0.0155160736 0.9975599098 0.0185085645 + 1366 0.9941991119 0.0086696434 0.9726722991 -0.0296458326 + 1367 1.0307946435 0.0161149195 1.0005145614 -0.0392708542 + 1368 0.9886617747 -0.0033094632 1.0001113606 0.0771841375 + 1369 0.9995322014 -0.0041533805 1.0118468333 -0.0078401240 + 1370 1.0066038545 0.0359541196 1.0103386479 0.0040127354 + 1371 0.9415588384 0.0085455122 1.0136158720 0.0156475350 + 1372 1.0092718471 -0.0335667630 0.9936022902 0.0137046342 + 1373 1.0140119305 0.0105153119 1.0425717794 -0.0081731374 + 1374 1.0298295541 -0.0216905699 1.0016711617 -0.0251904665 + 1375 1.0061517698 0.0402928873 0.9764643910 -0.0279302392 + 1376 1.0166281693 -0.0106145988 0.9723746197 -0.0091265209 + 1377 0.9933809112 -0.0397811344 0.9946302817 0.0256035688 + 1378 0.9856215423 -0.0028409903 0.9850312373 -0.0225163504 + 1379 1.0055933197 -0.0030594936 0.9761679655 0.0102013631 + 1380 0.9904078952 0.0230018263 0.9624116738 -0.0209580538 + 1381 1.0450520505 0.0074620323 0.9726840506 0.0032515306 + 1382 1.0002635802 -0.0003341236 1.0012352186 0.0410140415 + 1383 1.0095979700 0.0088087448 0.9713501111 0.0357393176 + 1384 1.0168295262 0.0045423599 0.9764296211 -0.0323175988 + 1385 1.0049447755 -0.0255534235 0.9636513523 0.0407208004 + 1386 1.0027084973 0.0119940999 0.9923303662 -0.0348470087 + 1387 1.0286184030 -0.0021828195 1.0087865853 0.0280126190 + 1388 0.9987638715 -0.0337150462 0.9831363866 -0.0024584419 + 1389 0.9864464380 -0.0335465681 0.9908404356 -0.0118113562 + 1390 0.9749671038 0.0081064175 1.0403304083 0.0196653487 + 1391 1.0196437326 -0.0172229621 0.9770449937 -0.0026320202 + 1392 0.9871922425 -0.0239427595 0.9996901309 0.0496765142 + 1393 1.0096518432 -0.0213991280 0.9846458919 0.0401505669 + 1394 0.9968092417 -0.0058380279 1.0040425674 -0.0019534433 + 1395 0.9984277693 -0.0113539264 1.0283011653 -0.0010968671 + 1396 1.0241912506 0.0054959737 1.0293108476 0.0244474057 + 1397 0.9817002954 0.0132221094 0.9801363179 -0.0202435597 + 1398 1.0412701009 0.0473030912 1.0049049043 -0.0362627094 + 1399 1.0181455876 -0.0173943674 0.9820708394 -0.0668144709 + 1400 0.9935221182 -0.0212570084 1.0087015478 0.0522111632 + 1401 1.0060144239 0.0355084169 0.9858197504 -0.0013628979 + 1402 1.0058909659 -0.0157778868 1.0194893120 -0.0053701740 + 1403 1.0038215855 0.0292451029 1.0025925306 0.0087204645 + 1404 0.9699298374 -0.0069209026 0.9969508577 0.0531265600 + 1405 1.0121559032 0.0032498275 1.0186642779 0.0284569394 + 1406 0.9982050463 0.0017672219 1.0092782441 0.0266942937 + 1407 0.9967894231 -0.0385329651 1.0019613786 0.0143858617 + 1408 0.9768361103 0.0144954596 1.0212492540 0.0017423003 + 1409 0.9993862764 -0.0437542624 1.0118770339 -0.0138328660 + 1410 0.9698298356 -0.0342190257 0.9958059919 0.0209840423 + 1411 1.0240650399 -0.0626300499 0.9999067657 0.0219419910 + 1412 1.0257844327 0.0211844072 1.0256980578 0.0308190350 + 1413 1.0268963039 -0.0174096895 0.9902483614 0.0053030039 + 1414 1.0122429059 0.0383163954 0.9860191231 -0.0159803473 + 1415 0.9879161517 0.0094703439 0.9962743919 0.0996483168 + 1416 1.0241825641 -0.0087530550 1.0119145924 0.0200492023 + 1417 0.9816046447 0.0472835091 0.9990334080 -0.0566781071 + 1418 1.0112117165 0.0094464733 0.9675477305 -0.0348676617 + 1419 0.9728076902 -0.0505416677 1.0023102850 -0.0314015759 + 1420 1.0294003358 -0.0373074861 0.9803534474 -0.0274824257 + 1421 1.0302458991 0.0161204388 0.9974169426 -0.0098778836 + 1422 1.0142596959 -0.0201788625 0.9990174693 -0.0391084180 + 1423 0.9982869850 0.0125678913 0.9898097800 -0.0196484375 + 1424 1.0034666687 0.0080233749 0.9682610534 0.0469749592 + 1425 1.0078195948 -0.0123946541 0.9982024641 -0.0153834372 + 1426 1.0105784945 -0.0160782671 1.0085159508 0.0086820012 + 1427 0.9772711059 -0.0209939628 0.9911939126 -0.0234551784 + 1428 1.0203337668 -0.0329763696 1.0074347657 0.0082794132 + 1429 0.9737908883 0.0099524617 1.0391595071 -0.0048566491 + 1430 1.0274077119 -0.0358782914 0.9939722409 -0.0025346697 + 1431 0.9763136146 0.0489750798 1.0072119933 0.0021010271 + 1432 1.0054795153 0.0055143396 0.9987017089 -0.0280311723 + 1433 0.9737226909 -0.0023955329 0.9910379524 0.0105760722 + 1434 0.9988776970 -0.0284377314 0.9955465884 0.0131365777 + 1435 0.9977335889 0.0278293547 0.9645358746 0.0089077735 + 1436 0.9893911974 0.0068800852 1.0034093952 0.0145442009 + 1437 0.9804628597 0.0215689261 1.0004256416 0.0061346643 + 1438 1.0171048239 -0.0085706687 0.9885032058 0.0219337085 + 1439 0.9856890518 0.0178824976 0.9711413739 -0.0161683660 + 1440 0.9892840233 -0.0333751689 0.9730221569 0.0113535124 + 1441 0.9957059243 -0.0351340157 1.0116185480 0.0156680344 + 1442 1.0060612122 0.0520615510 1.0259080496 0.0077892883 + 1443 0.9824788150 0.0091653596 0.9692966411 0.0120306027 + 1444 1.0053938799 0.0032368059 0.9717137529 -0.0341402715 + 1445 1.0100478742 0.0372043688 1.0134131509 0.0151697410 + 1446 1.0186296853 0.0337739278 0.9883990591 -0.0075470144 + 1447 0.9819743861 0.0200873768 1.0009899574 -0.0475839816 + 1448 0.9938092150 -0.0152810274 0.9825991700 -0.0419601350 + 1449 0.9730594169 0.0021918873 1.0125471984 0.0386179924 + 1450 0.9554668023 0.0085119255 1.0028718124 0.0133948090 + 1451 0.9841703649 -0.0065364581 1.0290060889 -0.0271901404 + 1452 0.9829459178 0.0344700307 1.0099892087 0.0263352840 + 1453 0.9741077116 -0.0333703374 0.9878632502 0.0099820716 + 1454 0.9692687386 0.0208739445 1.0154861565 -0.0117062607 + 1455 1.0328808368 0.0229692890 0.9939876042 0.0020072028 + 1456 0.9716538588 -0.0278776575 1.0197743495 -0.0115565111 + 1457 0.9947752412 -0.0755566842 0.9783633493 0.0524852449 + 1458 0.9880987930 -0.0294673230 1.0234182378 -0.0046824770 + 1459 0.9926065165 0.0022354581 1.0096225060 0.0193594695 + 1460 0.9861278412 -0.0018285302 0.9907380353 -0.0395576685 + 1461 0.9958701147 -0.0018779056 1.0107989557 0.0183715580 + 1462 0.9853862415 -0.0155194689 1.0208280284 0.0384389192 + 1463 0.9879392961 -0.0117179632 0.9896806920 0.0069514023 + 1464 0.9781571060 0.0045430655 1.0096533308 0.0164100390 + 1465 1.0043223133 0.0619680796 1.0255452591 0.0041455186 + 1466 1.0251252806 -0.0075279994 1.0126988987 -0.0374758844 + 1467 1.0365993005 0.0144079151 0.9807652323 -0.0236613109 + 1468 0.9863509758 0.0123177633 0.9744710450 -0.0160896282 + 1469 0.9785717365 -0.0238916778 0.9922863125 -0.0399282859 + 1470 1.0027131048 -0.0105318962 1.0247451760 0.0057954828 + 1471 1.0106207134 -0.0007404730 1.0255369778 -0.0220893904 + 1472 0.9760498892 -0.0480489628 1.0084828237 -0.0081008775 + 1473 0.9857736186 -0.0177487388 0.9853641102 -0.0781901004 + 1474 0.9827430227 0.0136724141 1.0395046771 0.0060466482 + 1475 1.0025101539 0.0481793811 0.9900173253 0.0081291357 + 1476 1.0099304192 0.0088507039 0.9782229651 -0.0177923830 + 1477 0.9855588537 0.0156604786 1.0053506972 0.0032290711 + 1478 1.0145986957 0.0316949814 0.9753624709 0.0375470816 + 1479 0.9881251459 -0.0236102273 0.9939562078 0.0245555623 + 1480 1.0079016451 -0.0492830248 1.0128954170 -0.0054649427 + 1481 0.9675330191 0.0239841739 1.0019762749 0.0203211522 + 1482 0.9976489863 -0.0011549756 1.0325406271 -0.0453745183 + 1483 0.9948447258 -0.0028622950 0.9990595177 0.0169873146 + 1484 1.0180961676 -0.0347925786 0.9874209768 -0.0025628974 + 1485 1.0097565767 0.0356403859 0.9512356740 0.0104523812 + 1486 1.0014213370 -0.0224050604 0.9851831517 -0.0109867749 + 1487 1.0213887344 0.0038794477 0.9902154208 0.0417872602 + 1488 0.9937596846 -0.0179451355 0.9955422392 0.0197917532 + 1489 0.9898057756 0.0158219724 0.9967446231 0.0116130442 + 1490 0.9891701020 0.0027802375 1.0137993656 0.0081072166 + 1491 1.0015324442 0.0521494420 0.9901026766 0.0142619202 + 1492 0.9829991271 0.0125572891 1.0488476717 0.0061688836 + 1493 0.9878710612 -0.0263347768 1.0051003567 0.0283256141 + 1494 0.9514084989 -0.0040085895 0.9898694017 0.0181326666 + 1495 1.0354232379 0.0053845474 1.0020905539 0.0182400145 + 1496 1.0015762813 -0.0120493709 0.9921547320 0.0014763625 + 1497 1.0209346838 -0.0380869993 0.9897211678 0.0092626066 + 1498 0.9810377381 -0.0446171233 0.9859124825 0.0549732425 + 1499 1.0350444257 0.0259758756 0.9836554125 -0.0233445282 + 1500 1.0158934170 0.0155597867 0.9773481598 0.0141663952 + 1501 1.0078208709 -0.0158066181 1.0327748310 -0.0249219503 + 1502 1.0104150629 0.0215144777 1.0009350161 0.0003905436 + 1503 0.9899824493 -0.0356226938 1.0481984139 0.0297400106 + 1504 1.0051133002 -0.0388868320 1.0015582997 0.0106514558 + 1505 1.0106215347 0.0315918445 1.0104712155 0.0142096161 + 1506 0.9718482808 0.0200512186 1.0343220300 0.0271592075 + 1507 0.9981308953 -0.0075260650 0.9974560056 -0.0137172707 + 1508 1.0073468706 -0.0027202155 0.9935474200 -0.0234043301 + 1509 1.0128628000 0.0101151244 1.0237074452 0.0087924323 + 1510 0.9981143304 -0.0055534271 0.9893038672 -0.0073180462 + 1511 1.0033991466 0.0143012598 0.9699439605 -0.0474666323 + 1512 0.9981355483 0.0043894167 1.0090826781 0.0040524820 + 1513 0.9983033246 0.0049130445 0.9814074509 -0.0350924431 + 1514 0.9991663609 -0.0034504332 0.9946379524 0.0307951743 + 1515 0.9539226920 0.0077990503 1.0005432566 -0.0088623935 + 1516 0.9627168866 -0.0133356276 0.9891499707 0.0613725904 + 1517 1.0055764113 -0.0483937010 1.0090831906 -0.0135582765 + 1518 0.9769411788 0.0101748741 1.0103668678 -0.0137744192 + 1519 1.0047421013 0.0149938142 1.0570897245 -0.0012410712 + 1520 0.9617914267 -0.0206501229 0.9685107548 -0.0095817165 + 1521 0.9896745168 0.0028555915 0.9683511129 -0.0283390229 + 1522 0.9784020262 0.0187343003 1.0007149785 0.0074560144 + 1523 1.0132889565 -0.0177099647 0.9931148147 0.0069991545 + 1524 0.9909097521 0.0156787968 1.0042081415 -0.0159510964 + 1525 1.0106987334 -0.0152353764 1.0064184713 0.0335579213 + 1526 0.9959079439 0.0364533741 1.0002388962 -0.0031685846 + 1527 1.0020842855 0.0056788169 1.0152145633 -0.0061024104 + 1528 1.0307175172 0.0009404885 0.9979948726 -0.0068090713 + 1529 0.9920250594 0.0229060345 0.9912933194 -0.0045693914 + 1530 0.9902807417 0.0128361974 0.9933978680 0.0312709669 + 1531 0.9871569715 -0.0027956579 1.0231440160 0.0164980652 + 1532 1.0317283949 -0.0170697277 1.0227814337 0.0075915969 + 1533 1.0150661620 -0.0248556303 1.0053732926 0.0197428390 + 1534 0.9557997612 0.0007626297 1.0196901164 0.0003631314 + 1535 1.0048307800 -0.0241064539 1.0184833228 0.0000587769 + 1536 0.9720370104 -0.0071714049 0.9791724611 0.0741611748 + 1537 0.9429097224 -0.0238358828 1.0152271139 -0.0279040569 + 1538 0.9854885546 -0.0497938752 1.0067642832 0.0319611369 + 1539 0.9868495469 0.0209370919 1.0229940629 0.0409034490 + 1540 1.0125796871 0.0195436669 0.9955376846 -0.0258939490 + 1541 0.9782713567 -0.0054284924 1.0071734335 -0.0164433847 + 1542 0.9965829881 -0.0093911387 1.0069284620 -0.0114543802 + 1543 0.9723270086 -0.0217359450 1.0154274416 -0.0243279039 + 1544 1.0049342912 0.0267543896 0.9831605916 -0.0004805359 + 1545 0.9879062132 -0.0044161136 0.9783210532 0.0696451895 + 1546 0.9934290808 0.0298281138 1.0165303076 -0.0035732423 + 1547 0.9913189090 -0.0115162838 1.0069732745 -0.0245097714 + 1548 0.9760618958 0.0038191999 1.0003268529 -0.0936553955 + 1549 0.9714453809 0.0217821990 0.9707794807 -0.0356563417 + 1550 1.0321271383 -0.0263805397 0.9945440453 0.0148247532 + 1551 0.9800436768 -0.0111772400 0.9916800573 0.0134875361 + 1552 1.0284803709 0.0360053367 1.0126166404 -0.0101850245 + 1553 0.9957614430 -0.0031138262 0.9821203976 -0.0108616036 + 1554 0.9791919152 0.0199323367 1.0012355457 -0.0293002507 + 1555 0.9914412436 -0.0161294645 1.0008131956 -0.0091668010 + 1556 1.0137201685 0.0091080244 1.0209590894 -0.0315030722 + 1557 1.0041624880 -0.0183337751 1.0085938244 0.0045907799 + 1558 0.9927722112 0.0030500803 0.9985855155 0.0339656765 + 1559 1.0047583966 -0.0463572834 0.9883836664 -0.0446022929 + 1560 1.0095620322 -0.0498261018 0.9747527122 0.0280540794 + 1561 1.0021696739 -0.0407576670 0.9793802259 -0.0038714062 + 1562 0.9847898924 -0.0005512408 0.9971241485 -0.0013590436 + 1563 0.9980516031 -0.0120192110 1.0105812274 0.0132874463 + 1564 0.9974060561 0.0637981025 0.9794564473 -0.0205008232 + 1565 1.0007337895 -0.0016684639 0.9938318656 -0.0293046677 + 1566 1.0145346763 -0.0344033476 0.9729963106 0.0498193872 + 1567 1.0070460356 0.0199859198 0.9939039006 -0.0052351577 + 1568 1.0214628223 0.0104890360 1.0122354406 -0.0059499613 + 1569 0.9821934218 0.0021568840 0.9967468626 0.0086245567 + 1570 0.9837978170 -0.0385847493 0.9742253063 -0.0039252078 + 1571 0.9882606567 -0.0158015797 1.0571154617 0.0154817416 + 1572 0.9934060538 -0.0133936889 1.0104675328 -0.0347277068 + 1573 1.0146390721 0.0108399418 1.0166051427 0.0431927253 + 1574 0.9985018377 0.0048465074 1.0233165197 -0.0052891426 + 1575 0.9930810810 0.0250453733 1.0199031359 0.0314490711 + 1576 1.0169928523 -0.0131157781 0.9950515887 0.0093918464 + 1577 1.0020065114 0.0247370055 1.0229238877 0.0053006311 + 1578 0.9818106550 -0.0393639021 1.0015835742 -0.0297776267 + 1579 0.9729163838 0.0329279655 0.9908599233 -0.0039783818 + 1580 0.9689859275 -0.0251350292 0.9882057038 0.0280407836 + 1581 0.9768927246 -0.0181756486 1.0045309697 0.0143364033 + 1582 1.0145543556 0.0175337313 1.0517886008 0.0121246261 + 1583 0.9784823262 -0.0025978922 0.9967947712 0.0183780194 + 1584 1.0324705220 0.0004350791 0.9890623960 -0.0142918301 + 1585 1.0040497442 -0.0038437539 1.0103179277 -0.0078819921 + 1586 0.9877494031 0.0161277632 0.9797763485 0.0280342132 + 1587 0.9872736360 0.0090160889 1.0161043154 -0.0102263234 + 1588 0.9975186968 0.0083080264 1.0095397014 0.0098980302 + 1589 1.0119152845 -0.0319780084 1.0266532958 0.0144708626 + 1590 0.9934146492 -0.0048856343 1.0011605751 0.0089585104 + 1591 1.0066248254 0.0312093864 0.9984338045 0.0412469593 + 1592 1.0049194879 0.0057114069 1.0075694723 -0.0138265398 + 1593 1.0123861806 -0.0264624907 1.0255529244 -0.0076665567 + 1594 0.9875631054 -0.0315846531 1.0229173919 0.0297788841 + 1595 0.9862143247 -0.0284014255 1.0263586277 0.0328511040 + 1596 0.9826357223 0.0025495031 1.0032031097 -0.0058899325 + 1597 0.9895997043 -0.0105220495 1.0066256008 0.0268075848 + 1598 1.0168979788 0.0166665928 1.0040887044 -0.0113669227 + 1599 0.9931419826 0.0111748360 1.0169296623 0.0630428269 + 1600 0.9870988117 -0.0012854508 0.9992122830 0.0040846641 + 1601 1.0183624953 -0.0366405758 0.9722536565 0.0119043381 + 1602 1.0131623377 -0.0075110034 0.9925604641 0.0243045209 + 1603 0.9917551488 -0.0343680063 1.0024077628 0.0075064710 + 1604 1.0092373113 -0.0047231546 1.0116075565 0.0010755589 + 1605 1.0137566479 -0.0213027127 0.9862050630 0.0084659236 + 1606 0.9776631127 -0.0099168722 1.0297944178 0.0455096844 + 1607 1.0020439442 -0.0224792211 1.0219454013 -0.0093019931 + 1608 0.9907701834 -0.0363555661 0.9909818339 0.0435091983 + 1609 1.0016981697 0.0051989612 0.9994448020 -0.0144212458 + 1610 0.9958442821 0.0337491554 1.0074693789 -0.0428281020 + 1611 0.9967296138 -0.0455052283 1.0159201553 -0.0247767245 + 1612 0.9826443425 -0.0213674964 0.9941175074 -0.0428451294 + 1613 0.9960206642 -0.0192876190 1.0016964087 0.0156848275 + 1614 0.9984895093 -0.0099789320 0.9943930779 0.0185994496 + 1615 0.9717699585 -0.0001936814 0.9768630045 0.0776203638 + 1616 0.9933417853 -0.0146662211 0.9685735685 -0.0181566982 + 1617 1.0084933763 -0.0206911915 0.9797133442 0.0223414498 + 1618 0.9799858794 -0.0155308134 1.0161178327 -0.0061471275 + 1619 1.0007871038 0.0105181770 0.9977739089 0.0166127007 + 1620 0.9950303090 0.0211500326 0.9807044774 0.0073763925 + 1621 1.0274919664 -0.0122358796 1.0062811419 0.0073714834 + 1622 0.9827959125 0.0258745687 1.0240861507 -0.0095484440 + 1623 1.0425253903 -0.0131367324 1.0030849559 -0.0117963916 + 1624 0.9864354752 -0.0197870435 1.0129411500 -0.0131225564 + 1625 1.0114759732 -0.0323911996 1.0347465105 0.0266764508 + 1626 0.9911770435 -0.0047823269 1.0033131291 0.0264148712 + 1627 0.9901843762 0.0094946064 1.0137064048 -0.0306516267 + 1628 1.0013441884 0.0378453348 0.9687843718 0.0256539056 + 1629 1.0039524317 0.0048247242 1.0299172719 0.0059217714 + 1630 0.9854564608 0.0213596642 0.9988588449 0.0019422212 + 1631 1.0005565304 -0.0019451713 0.9700747979 -0.0239527614 + 1632 0.9973238366 0.0166506026 1.0028495272 0.0360622642 + 1633 1.0160771219 -0.0225439592 0.9988808257 -0.0047073552 + 1634 1.0110876573 0.0149610045 0.9901666878 0.0369239074 + 1635 0.9800634704 -0.0174580139 0.9871451085 -0.0052841387 + 1636 0.9931351995 -0.0188266856 0.9731755895 0.0112072758 + 1637 0.9436719689 0.0043210906 0.9899007606 0.0306870933 + 1638 1.0199333140 -0.0211687986 1.0063905768 -0.0073393936 + 1639 1.0116091928 -0.0160905800 0.9740632863 -0.0147783310 + 1640 1.0120367421 0.0027816034 1.0124441652 0.0088667514 + 1641 1.0423968910 0.0087918017 1.0132979286 0.0182071635 + 1642 0.9945306314 -0.0312477602 1.0131954629 -0.0185558678 + 1643 0.9871723792 0.0052130151 0.9845216204 -0.0146913005 + 1644 0.9672348768 -0.0056974572 0.9946742021 0.0009224608 + 1645 1.0023261302 -0.0028019390 0.9811355005 0.0050829926 + 1646 0.9963632017 0.0188199691 0.9968232998 0.0157594568 + 1647 0.9904497719 -0.0310278843 1.0162358805 -0.0222726076 + 1648 1.0107068580 0.0010294656 0.9843779019 -0.0193209193 + 1649 0.9867334639 -0.0536941292 0.9681087728 0.0006857723 + 1650 0.9761378435 -0.0071483953 1.0298279362 0.0106370905 + 1651 1.0266199102 -0.0014218961 1.0081643019 -0.0057512826 + 1652 1.0126682406 -0.0037761546 1.0016260142 0.0400451233 + 1653 0.9789957502 -0.0149116348 1.0214620040 0.0122761549 + 1654 0.9975009866 -0.0565282677 0.9950376547 -0.0395159597 + 1655 0.9818856021 -0.0280139947 1.0158323831 -0.0032115129 + 1656 0.9864605644 -0.0041666908 1.0222888010 0.0101930978 + 1657 0.9937609412 -0.0156461314 0.9608932902 0.0100123726 + 1658 0.9757157311 0.0078217428 1.0129271548 0.0159443751 + 1659 1.0026103532 0.0081802981 0.9853337956 0.0029181902 + 1660 0.9947547811 0.0022534003 0.9704971297 0.0181223843 + 1661 1.0063342810 -0.0399716346 1.0187978132 -0.0483947157 + 1662 0.9958739551 -0.0615749715 1.0280202626 -0.0294128207 + 1663 1.0142513306 0.0342987411 1.0146288262 -0.0001490815 + 1664 1.0042330807 -0.0278983280 0.9737440142 -0.0171243821 + 1665 1.0198173642 -0.0422166187 1.0029532764 -0.0140357842 + 1666 0.9999847265 0.0123467205 0.9926358157 0.0330750042 + 1667 0.9745395780 -0.0114814800 1.0107795853 -0.0327842698 + 1668 0.9960089417 -0.0114891904 1.0282222353 0.0188358820 + 1669 0.9839372290 -0.0146147904 1.0035709998 0.0382405458 + 1670 0.9914925325 -0.0046137382 0.9995367809 -0.0038722714 + 1671 1.0192201558 -0.0216801958 0.9938832009 0.0217499020 + 1672 0.9727910696 0.0215586354 1.0070561014 0.0442725506 + 1673 0.9908908387 0.0599213018 1.0217979927 -0.0092961093 + 1674 1.0367595836 -0.0355258452 0.9976613042 0.0034161605 + 1675 1.0148251981 -0.0336308523 0.9778629406 0.0309676257 + 1676 0.9874176695 0.0036959424 1.0123408501 -0.0220039553 + 1677 0.9847961456 0.0290773796 1.0045590965 -0.0184917130 + 1678 1.0222798695 -0.0329392074 1.0035693445 -0.0229640544 + 1679 1.0216991871 -0.0008461374 0.9997502951 -0.0163913576 + 1680 1.0108792596 0.0109777135 0.9900727117 -0.0303125622 + 1681 1.0076545540 -0.0194480911 0.9960239273 0.0342544128 + 1682 0.9994966408 -0.0441084015 0.9826337365 0.0141275860 + 1683 0.9951866766 0.0305656623 1.0001249984 -0.0224011008 + 1684 1.0155755783 -0.0250633129 1.0129600215 -0.0244854839 + 1685 0.9736010207 -0.0319095387 0.9927308359 0.0110783583 + 1686 0.9843761550 -0.0030502403 0.9854221408 -0.0301316097 + 1687 0.9964618109 -0.0205613553 0.9953387081 -0.0131785396 + 1688 0.9908342320 0.0136014205 0.9655744643 0.0059962248 + 1689 1.0001945876 0.0033437859 0.9867507344 0.0425897101 + 1690 1.0300748664 -0.0211811119 0.9917943749 0.0054056769 + 1691 1.0027541716 -0.0366953257 0.9874645084 -0.0068276332 + 1692 0.9672997865 -0.0210873183 1.0043964591 0.0377743961 + 1693 0.9984935081 0.0348529911 0.9931187348 0.0043890194 + 1694 1.0002129945 0.0312967802 1.0095762046 0.0283869298 + 1695 0.9741715251 -0.0150155972 0.9888396687 0.0107982885 + 1696 1.0142235429 0.0344752543 1.0003825726 0.0059218222 + 1697 1.0174422723 -0.0027461113 0.9933838218 0.0325048036 + 1698 1.0168196340 0.0399477646 1.0038758505 0.0134802270 + 1699 0.9908778958 0.0134289991 1.0025694960 -0.0424649901 + 1700 1.0156772787 0.0497691515 0.9545197833 0.0024664477 + 1701 0.9979964628 0.0185168356 1.0361787416 0.0208517110 + 1702 0.9852616593 -0.0592287728 0.9802833128 -0.0396497756 + 1703 0.9985712148 -0.0027306160 0.9893150746 0.0531831810 + 1704 0.9977595867 0.0042401466 0.9788169574 0.0026052161 + 1705 1.0223690746 -0.0173091498 1.0264972514 -0.0159723584 + 1706 0.9820822527 -0.0026991449 1.0352281399 0.0164292057 + 1707 0.9900840600 -0.0086252305 1.0276181227 -0.0061892640 + 1708 1.0096645205 -0.0192701261 0.9800223802 -0.0459067659 + 1709 1.0220651891 0.0254666008 0.9776004276 0.0175449197 + 1710 1.0291290568 0.0506595539 1.0041183383 0.0246591076 + 1711 1.0054324513 -0.0163123665 0.9893600004 0.0071289787 + 1712 1.0126433439 -0.0196244752 0.9717447575 0.0436310249 + 1713 0.9820297976 0.0391240898 1.0001484278 -0.0409543336 + 1714 1.0195825691 -0.0162072942 1.0291209393 -0.0018138418 + 1715 0.9918191973 0.0137056283 0.9896206645 0.0092292023 + 1716 0.9780828145 -0.0295506336 0.9964616108 -0.0027768281 + 1717 1.0127079098 -0.0133098137 1.0271809119 0.0051561500 + 1718 1.0128815794 0.0101893534 1.0371078086 0.0009484567 + 1719 0.9938951009 0.0006016208 0.9776650666 0.0468282605 + 1720 0.9702750944 0.0224703747 1.0029661905 0.0011331443 + 1721 0.9835713433 -0.0226909161 1.0010999746 -0.0125381567 + 1722 1.0026325620 -0.0325646402 0.9903236143 -0.0234863285 + 1723 1.0111236321 -0.0139478591 0.9832132220 -0.0205225741 + 1724 1.0119388161 0.0037754285 1.0011341772 0.0313401372 + 1725 1.0124010450 0.0247853718 0.9977648789 -0.0043169687 + 1726 0.9659008580 0.0281553514 0.9939816415 0.0196627411 + 1727 1.0315803880 0.0397321711 0.9989310855 0.0189124219 + 1728 1.0155032062 0.0070743991 1.0285076088 0.0186741659 + 1729 1.0165982190 -0.0101774165 0.9594066373 0.0077220325 + 1730 0.9992223022 -0.0057661001 0.9758383948 0.0072783672 + 1731 0.9863231162 0.0030737386 1.0060153559 -0.0172380441 + 1732 1.0023674484 -0.0010577727 1.0102235166 0.0062880491 + 1733 0.9859898004 0.0026625682 0.9827579650 -0.0255628876 + 1734 1.0235604536 0.0099487210 0.9856182250 -0.0318259843 + 1735 0.9797706041 0.0367866352 1.0161497347 -0.0064656256 + 1736 0.9859182473 0.0222190773 1.0208806646 -0.0138268846 + 1737 1.0052457787 -0.0363923011 1.0006977299 0.0199886207 + 1738 1.0180210068 -0.0212213832 1.0430566406 0.0075605794 + 1739 1.0063056980 0.0076130011 0.9770307716 -0.0338286014 + 1740 0.9784719210 0.0167113205 1.0185627577 -0.0021080721 + 1741 1.0115981778 0.0044947193 1.0051967545 -0.0172392055 + 1742 1.0308844311 0.0010441450 0.9863959758 -0.0011821847 + 1743 1.0349702490 -0.0155225259 0.9800480714 -0.0074720689 + 1744 0.9947541278 0.0346910840 1.0061133800 0.0315982122 + 1745 1.0153899064 -0.0048504688 1.0008567847 0.0095785748 + 1746 0.9871505044 0.0199651028 0.9848973782 0.0318442529 + 1747 1.0214051386 0.0062997215 0.9846151287 -0.0127937411 + 1748 0.9840122757 0.0117984670 0.9570659247 -0.0276010447 + 1749 0.9812029633 -0.0199432046 0.9669802105 -0.0262718006 + 1750 1.0142998579 0.0182409835 1.0149507031 -0.0067687176 + 1751 0.9769227963 -0.0170101171 0.9769158059 -0.0085868348 + 1752 0.9980238434 0.0128992752 0.9691858510 -0.0469866204 + 1753 1.0046845280 0.0206988727 0.9875698769 0.0154040477 + 1754 1.0002862915 0.0177852411 1.0004338332 -0.0342273302 + 1755 0.9800904228 -0.0040269756 1.0072608076 -0.0279838360 + 1756 1.0095184538 0.0358814440 0.9742513588 0.0096996233 + 1757 1.0029596951 0.0265248918 1.0103469366 -0.0002011596 + 1758 0.9987157552 -0.0002725584 0.9875109724 0.0375961868 + 1759 1.0025556197 -0.0201829869 1.0057811629 0.0458127504 + 1760 1.0131190139 -0.0036315258 0.9973137894 -0.0118973551 + 1761 1.0155029919 0.0581654564 0.9883422220 -0.0405271464 + 1762 1.0010850398 0.0140584055 0.9787359455 -0.0474607049 + 1763 0.9983677208 -0.0258548230 1.0077305253 0.0343812076 + 1764 1.0166035429 -0.0311410600 1.0206661198 -0.0043905022 + 1765 0.9783841888 -0.0049563393 0.9819957572 0.0335768122 + 1766 0.9999982132 0.0012520793 1.0422513419 0.0334916897 + 1767 0.9966414126 0.0268413870 1.0046488603 0.0114540619 + 1768 1.0088184206 -0.0216376593 0.9899796070 0.0504790153 + 1769 1.0326977070 -0.0030553575 1.0067564312 -0.0294915336 + 1770 1.0042711933 -0.0458091278 1.0047482494 0.0058137336 + 1771 0.9867782419 -0.0015650968 1.0098492034 -0.0091700800 + 1772 1.0219702468 0.0133296956 0.9963650372 -0.0198644030 + 1773 0.9912012495 0.0555955901 1.0275910481 -0.0067588924 + 1774 1.0192282276 0.0218738742 1.0027404110 -0.0195125788 + 1775 1.0048500299 -0.0581507810 0.9957741546 -0.0091151261 + 1776 1.0016457102 -0.0238455009 0.9963102084 0.0458872239 + 1777 1.0207242216 0.0258582404 0.9991028157 0.0172670632 + 1778 0.9892780670 -0.0041699969 0.9904200004 -0.0114140690 + 1779 0.9978030417 -0.0086799120 1.0175788983 -0.0453573765 + 1780 1.0015721330 0.0099706010 1.0242392339 0.0037076227 + 1781 0.9838705391 0.0140584164 0.9867681886 -0.0032085961 + 1782 1.0131838361 -0.0009242198 0.9762489545 -0.0166878663 + 1783 1.0046218537 -0.0062975717 0.9995407924 -0.0082791447 + 1784 0.9954695114 0.0004481573 1.0236045730 -0.0008415129 + 1785 0.9972700867 0.0094668451 0.9851306229 0.0335048646 + 1786 1.0067456095 0.0026068168 1.0046489124 0.0263219662 + 1787 0.9859975117 0.0632194525 1.0002721675 -0.0369663065 + 1788 1.0076997623 -0.0365590931 1.0167706500 -0.0448809318 + 1789 1.0205046091 -0.0029395818 0.9992456635 -0.0088049622 + 1790 1.0046492786 0.0194455999 0.9811626796 -0.0234905063 + 1791 0.9838167444 -0.0191307917 0.9709525123 0.0317425918 + 1792 1.0067866101 0.0021207262 0.9826949945 0.0067801672 + 1793 1.0131290654 -0.0217445043 0.9722398787 0.0137818303 + 1794 0.9983469184 -0.0158534565 0.9767943372 0.0152073022 + 1795 0.9924292140 0.0246786002 0.9788018623 -0.0150044093 + 1796 0.9964116861 0.0272709076 1.0334699440 -0.0203439910 + 1797 1.0070563121 0.0152094759 1.0242728710 0.0366413242 + 1798 1.0037978179 -0.0184963371 1.0002051115 0.0288369182 + 1799 1.0206199363 0.0048374805 0.9905901728 0.0291327550 + 1800 1.0100395338 0.0162105572 1.0161198627 0.0166756401 + 1801 0.9928709403 0.0238252450 0.9984913242 0.0079048757 + 1802 0.9654922167 0.0017005884 0.9729244352 -0.0059040190 + 1803 0.9789224518 -0.0036756648 1.0116453864 -0.0179239069 + 1804 1.0235184972 -0.0242761896 1.0110164977 0.0098696204 + 1805 0.9962011808 0.0025592925 1.0025976488 -0.0281550031 + 1806 0.9920259476 -0.0549591603 1.0103335925 0.0314557083 + 1807 0.9818894088 -0.0042175623 0.9998106815 -0.0450586496 + 1808 0.9959617110 -0.0114166488 1.0280456129 -0.0220736948 + 1809 0.9906515708 -0.0255655830 0.9986720850 -0.0318415038 + 1810 0.9910713483 -0.0180655449 1.0253577758 0.0271022247 + 1811 1.0197513517 0.0013224949 1.0020957267 -0.0078208112 + 1812 0.9841033500 -0.0323172510 0.9631318792 0.0115153478 + 1813 1.0219401777 -0.0256133922 1.0083090832 -0.0255929698 + 1814 0.9977492495 0.0078665213 1.0007768364 0.0427818536 + 1815 0.9800084212 -0.0239676444 0.9959255217 0.0041158034 + 1816 1.0099767476 0.0224743689 0.9779127411 -0.0106392136 + 1817 0.9802978447 0.0125460638 1.0076060258 -0.0051347399 + 1818 1.0192521183 0.0236347708 1.0093527518 -0.0174472815 + 1819 1.0031123855 0.0178753181 0.9912964605 -0.0014057507 + 1820 1.0043295890 0.0071274886 1.0016995936 0.0229448821 + 1821 1.0011085598 -0.0201748868 1.0207379649 -0.0027020382 + 1822 0.9850726919 0.0107461346 0.9990360198 0.0199766986 + 1823 0.9950350971 -0.0360491619 1.0316503041 -0.0049107043 + 1824 1.0166091168 0.0171846793 0.9782006592 -0.0064299050 + 1825 1.0257353107 0.0119840669 0.9890452431 -0.0005362699 + 1826 0.9831535571 -0.0031936081 1.0040125550 0.0192906402 + 1827 0.9869184568 -0.0079643819 1.0158870226 0.0186781996 + 1828 0.9941801973 0.0276877858 1.0159398571 0.0137681083 + 1829 1.0137444936 -0.0099740368 0.9996170078 0.0059440470 + 1830 0.9745172467 -0.0029218450 1.0205438238 -0.0138124759 + 1831 1.0241255255 0.0455345853 1.0083854055 0.0128824764 + 1832 0.9805011901 0.0076391778 0.9911608859 0.0369078945 + 1833 1.0068244098 -0.0226406393 1.0028542581 0.0089228721 + 1834 0.9916918023 -0.0033102600 1.0143318769 0.0203167510 + 1835 0.9731092080 -0.0103379013 0.9894262311 0.0505752545 + 1836 1.0060092980 0.0062834353 1.0107337603 0.0013765640 + 1837 0.9918611384 0.0203612132 1.0173922191 -0.0079562284 + 1838 0.9940615691 0.0165875932 0.9975589318 -0.0020768289 + 1839 1.0225956199 0.0246464332 1.0007940287 0.0108151352 + 1840 0.9971250174 0.0305120168 0.9907149011 -0.0317569549 + 1841 0.9902956800 -0.0036579277 1.0076681674 -0.0087820470 + 1842 1.0258418724 -0.0249640762 0.9974293867 0.0019084949 + 1843 1.0226233263 0.0137382721 1.0057678869 -0.0176635983 + 1844 0.9837675823 -0.0357910376 1.0043413438 0.0493164710 + 1845 0.9961847076 0.0255469118 1.0061182560 -0.0078775266 + 1846 0.9999416205 0.0278391102 0.9968789563 -0.0141829916 + 1847 0.9956023533 -0.0185654338 0.9941118793 -0.0445098144 + 1848 0.9894694904 -0.0250148861 1.0039574748 0.0017324217 + 1849 0.9805143685 0.0428870335 0.9967544088 -0.0011776149 + 1850 0.9986506089 0.0336786842 0.9990665998 -0.0344634760 + 1851 0.9842326458 -0.0127709349 1.0217812610 -0.0273110408 + 1852 1.0014853235 -0.0186662084 0.9902541448 0.0506037785 + 1853 1.0144100857 -0.0282002053 0.9861351123 -0.0159178437 + 1854 1.0043644647 0.0515306595 0.9892222998 0.0081563387 + 1855 1.0171865240 0.0255675399 0.9974911858 0.0119852541 + 1856 1.0046371683 0.0167036766 1.0033404866 -0.0069403871 + 1857 0.9820321497 0.0243553579 0.9953049345 -0.0239103331 + 1858 0.9926615875 0.0086368258 0.9849409402 0.0077313537 + 1859 0.9938775603 -0.0006712162 0.9736543127 -0.0020443890 + 1860 1.0125726444 -0.0394911236 0.9897211028 0.0202576823 + 1861 0.9989455890 0.0077433001 0.9981344504 0.0112425318 + 1862 0.9964368597 -0.0345682512 1.0132380843 0.0603784410 + 1863 1.0304279394 -0.0225823990 0.9938008355 0.0012670150 + 1864 1.0172460968 -0.0263111287 0.9941409741 -0.0108011949 + 1865 1.0109062573 0.0295946491 1.0080143954 0.0146724143 + 1866 0.9852881299 0.0039614563 1.0154412977 0.0157223123 + 1867 0.9956846084 0.0425791172 0.9680468355 -0.0032543999 + 1868 0.9802729147 -0.0067459761 0.9934919272 -0.0352359659 + 1869 1.0250967431 0.0198767924 0.9972305911 -0.0201589201 + 1870 1.0066044217 0.0030946527 0.9819580580 0.0118755881 + 1871 0.9954109484 -0.0132999307 0.9993416801 -0.0402750450 + 1872 0.9961571150 0.0120590748 1.0015087550 -0.0233067787 + 1873 1.0252652765 0.0130608626 0.9924591123 0.0280797505 + 1874 0.9848653300 0.0138842132 1.0146890020 0.0260265650 + 1875 0.9879895840 0.0076681393 1.0132799605 0.0105121261 + 1876 1.0131512042 0.0355563951 0.9926603309 -0.0082605873 + 1877 0.9869785968 0.0147131266 0.9920691174 0.0077495956 + 1878 1.0090320188 -0.0173920124 0.9810110859 0.0393009307 + 1879 1.0083102190 0.0164115404 0.9984758329 0.0139724246 + 1880 0.9963076458 -0.0138968113 1.0218332055 -0.0261524509 + 1881 1.0216025004 0.0076288753 0.9766485316 -0.0325559475 + 1882 0.9907170508 0.0148000855 1.0112808520 -0.0257140543 + 1883 1.0335539614 0.0095489930 1.0225470135 -0.0031434702 + 1884 0.9812076920 0.0221378077 0.9808433362 0.0251874496 + 1885 0.9968302430 0.0456291000 1.0264325604 0.0321383054 + 1886 1.0122675822 -0.0179680181 0.9870227962 0.0501932671 + 1887 1.0035004367 0.0195414153 0.9843858920 -0.0158222349 + 1888 1.0231006219 -0.0083733177 1.0148340782 -0.0176564140 + 1889 1.0005285234 0.0000895039 1.0013160208 0.0188745990 + 1890 0.9732596107 -0.0063501638 0.9916276533 0.0245536078 + 1891 1.0094554940 -0.0201946814 1.0277873609 -0.0210553934 + 1892 1.0338245842 -0.0225605691 0.9765236755 -0.0065239739 + 1893 1.0123072130 0.0108062195 1.0168048733 0.0043463082 + 1894 0.9717942012 -0.0143715236 0.9974556796 0.0338110527 + 1895 0.9698629052 0.0041885737 0.9842471977 0.0158514240 + 1896 0.9927942821 -0.0110294232 1.0059816193 -0.0180110555 + 1897 0.9985315317 0.0121325709 1.0129592738 0.0076969765 + 1898 1.0116666750 -0.0339074875 0.9825506940 0.0427540012 + 1899 0.9982632333 -0.0151049029 0.9790717880 0.0074620381 + 1900 0.9834750707 -0.0256013738 0.9800911065 -0.0022257558 + 1901 1.0111403869 0.0231928856 1.0014048932 0.0091128978 + 1902 1.0068296825 0.0099253609 0.9689832975 0.0188354330 + 1903 0.9810056234 -0.0131371717 0.9946390024 0.0085882756 + 1904 0.9801948794 0.0224456593 0.9907026371 -0.0122303392 + 1905 0.9879911483 -0.0176368254 0.9715798500 0.0200966283 + 1906 1.0044586369 0.0138997191 1.0015773809 -0.0110968560 + 1907 0.9878494081 -0.0007303984 1.0102084257 -0.0118220252 + 1908 1.0205065255 0.0048039398 0.9869978761 0.0256796255 + 1909 1.0035080387 -0.0090518048 1.0102188097 0.0317911120 + 1910 1.0016154559 -0.0001927330 1.0154296995 -0.0022041851 + 1911 1.0153966854 -0.0310801715 1.0005947461 0.0236196050 + 1912 0.9961086209 0.0161980992 0.9889080386 -0.0058112734 + 1913 1.0003178049 -0.0065638893 1.0123362134 0.0493124912 + 1914 1.0168699641 -0.0307768031 0.9819517609 0.0210001023 + 1915 1.0080111449 -0.0071660536 1.0412907752 0.0174688767 + 1916 1.0122252676 -0.0329398915 0.9894558381 0.0337735010 + 1917 0.9858233723 0.0191677932 1.0121232947 0.0256779836 + 1918 1.0070855488 0.0203337499 0.9907618155 0.0082558252 + 1919 0.9971627647 -0.0160351160 1.0118767843 0.0010164507 + 1920 0.9943468113 -0.0144708318 1.0077122318 0.0062587207 + 1921 0.9940561485 0.0094690694 1.0094941917 -0.0453326949 + 1922 0.9760436495 -0.0109458672 0.9918981281 -0.0239648204 + 1923 0.9862966166 0.0200508242 0.9929845457 -0.0002620119 + 1924 0.9979971223 0.0176746626 1.0131183232 -0.0365276452 + 1925 0.9993359609 0.0021132218 1.0098728334 0.0067889653 + 1926 1.0158952921 -0.0134219708 1.0060284487 -0.0000787672 + 1927 0.9995476366 0.0512670334 0.9555579957 -0.0045597518 + 1928 0.9794472757 -0.0174463328 1.0107605046 0.0265105423 + 1929 0.9886471206 0.0338768653 1.0264141946 -0.0061046431 + 1930 0.9804110271 -0.0116599243 1.0182145921 0.0016270878 + 1931 1.0017387603 -0.0025048112 0.9601793204 0.0147327672 + 1932 0.9841751565 -0.0054161720 0.9994764050 -0.0183053932 + 1933 1.0049790437 -0.0156925977 0.9791947967 -0.0240203959 + 1934 0.9697142907 0.0355870862 0.9852125700 -0.0046479657 + 1935 0.9682029147 0.0188061938 1.0209066983 -0.0349022615 + 1936 0.9981312006 -0.0270110423 0.9995959028 -0.0210105333 + 1937 0.9986127214 -0.0049605068 1.0240247786 -0.0421462398 + 1938 0.9948877386 -0.0083598223 0.9956647932 -0.0038672918 + 1939 1.0148736871 0.0149309273 0.9851649462 -0.0047050123 + 1940 0.9967078422 0.0114998503 0.9968784975 0.0110954720 + 1941 0.9865800650 0.0175727409 0.9972656006 0.0395780195 + 1942 0.9947407148 0.0072469045 1.0031091524 0.0164794784 + 1943 1.0130280410 -0.0149561356 1.0087242492 0.0284926610 + 1944 1.0085918005 -0.0131826492 0.9904781277 0.0044210040 + 1945 0.9585130960 -0.0398481112 1.0014437571 -0.0017226248 + 1946 1.0194381342 -0.0346925043 1.0039485168 0.0162946979 + 1947 0.9841726822 -0.0133021421 0.9905626688 -0.0550319211 + 1948 1.0146575903 -0.0214492736 1.0066311986 -0.0274068183 + 1949 0.9838331460 0.0244550585 0.9892056984 0.0255355285 + 1950 0.9868598201 0.0171072195 1.0089239267 -0.0646475469 + 1951 0.9691407507 -0.0338928132 1.0056962008 0.0069897168 + 1952 1.0193523711 0.0252017084 0.9949647034 0.0265404433 + 1953 1.0064626183 0.0091586324 0.9984661663 0.0148310368 + 1954 0.9953982519 -0.0331824499 1.0208096957 -0.0216779286 + 1955 1.0259894711 0.0154500614 1.0164308582 0.0330662926 + 1956 1.0029813466 -0.0063964940 1.0047920739 0.0120783627 + 1957 1.0123260583 0.0239305968 0.9835470820 -0.0130686349 + 1958 1.0001889038 0.0102298032 1.0072568327 -0.0295914702 + 1959 1.0217661551 -0.0067211135 1.0012685049 0.0159544649 + 1960 1.0065628329 -0.0160012100 1.0006326917 0.0068153415 + 1961 0.9946509073 -0.0083898037 1.0094040047 0.0005280799 + 1962 1.0036535369 0.0001015808 0.9854938971 0.0055067330 + 1963 0.9635960816 -0.0250440246 1.0070599785 0.0126214849 + 1964 0.9721112819 0.0236924865 1.0030699630 -0.0448778358 + 1965 1.0162451286 -0.0070952125 1.0088868541 0.0259769745 + 1966 1.0236057302 -0.0050367935 1.0322518123 0.0205004944 + 1967 0.9713840059 0.0045032236 1.0363442178 0.0468406796 + 1968 1.0073021676 -0.0194936819 1.0009087196 -0.0036578346 + 1969 1.0006248186 0.0070692659 0.9806304469 0.0133061590 + 1970 1.0015318199 -0.0087557181 0.9928472741 0.0415979097 + 1971 1.0156256766 -0.0356949471 0.9996938357 -0.0128136760 + 1972 1.0087426252 0.0037556875 0.9865801836 -0.0093578365 + 1973 1.0323258280 0.0099423370 1.0080645996 0.0093161910 + 1974 0.9892106411 0.0089129029 1.0210934059 -0.0484575858 + 1975 0.9993139157 -0.0106150394 1.0078939356 -0.0376634361 + 1976 1.0170586329 0.0182408444 1.0123239443 0.0201856170 + 1977 1.0047778934 -0.0102996773 1.0077910953 -0.0207482315 + 1978 1.0020739235 -0.0359578104 0.9976833296 -0.0304659937 + 1979 0.9839477079 0.0046090460 1.0161559625 0.0249182622 + 1980 0.9869269226 -0.0294778644 0.9993577874 0.0183269519 + 1981 0.9884008617 -0.0094662948 0.9809684930 -0.0422382999 + 1982 1.0138097064 0.0169505096 0.9890557697 0.0058096237 + 1983 0.9865289248 -0.0182130118 1.0125621247 -0.0121396182 + 1984 1.0265175284 0.0082243441 0.9769232378 -0.0005255607 + 1985 1.0202808089 0.0000474010 0.9894026591 0.0073351898 + 1986 1.0179874418 -0.0294150723 0.9853697840 -0.0147034634 + 1987 0.9841045663 -0.0155884338 0.9836149890 -0.0234388968 + 1988 1.0043533271 -0.0053602043 0.9989008671 0.0089110778 + 1989 1.0117369054 -0.0059009710 1.0008630511 -0.0041536351 + 1990 1.0141782239 0.0246880863 0.9768221497 0.0395292963 + 1991 1.0079608834 -0.0492755254 0.9983025867 -0.0194775134 + 1992 0.9908400620 -0.0098324399 1.0010645015 0.0043656346 + 1993 0.9840242697 0.0296611691 1.0169741368 -0.0055762316 + 1994 1.0267132591 0.0198829647 0.9772320867 -0.0152374215 + 1995 0.9892956856 -0.0321338659 0.9887898800 -0.0049084362 + 1996 1.0368056516 -0.0232024821 0.9789517839 0.0099416661 + 1997 1.0023362880 0.0084215681 0.9927891316 -0.0032909617 + 1998 0.9741618047 -0.0012869341 1.0027559185 -0.0165650101 + 1999 0.9955515360 0.0092065121 0.9959389384 -0.0291439139 + 2000 1.0082303148 0.0017458978 1.0140729809 0.0260650696 diff --git a/dataassim/math/othersupmath/gasdev.f b/dataassim/math/othersupmath/gasdev.f index bb24f3c..c1b763a 100644 --- a/dataassim/math/othersupmath/gasdev.f +++ b/dataassim/math/othersupmath/gasdev.f @@ -71,13 +71,13 @@ return end - double precision function ran1(idum) - implicit none - integer idum,IA,IM,IQ,IR,NTAB,NDIV - double precision AM,EPS,RNMX - PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773, - & IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15, - & RNMX=1.0d0-EPS) +! double precision function ran1(idum) +! implicit none +! integer idum,IA,IM,IQ,IR,NTAB,NDIV +! double precision AM,EPS,RNMX +! PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773, +! & IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15, +! & RNMX=1.0d0-EPS) ! ! Minimal random number generator of Park and Miller with Bays-Durham shuffle and ! added safegaurds. Return a uniform random deviate between 0.0 and 1.0, exclusive @@ -85,25 +85,25 @@ ! thereafter, do not alter idum between successive deviates in a sequence. RNMX ! should approximate the largest floating value that is less than 1. ! - integer j,k,iv(NTAB),iy - save iv,iy - data iv /NTAB*0/,iy /0/ - if(idum.le.0.or.iy.eq.0)then - idum=max(-idum,1) - do j=NTAB+8,1,-1 - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if(idum.lt.0)idum=idum+IM - if(j.le.NTAB)iv(j)=idum - enddo - iy=iv(1) - endif - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if(idum.lt.0)idum=idum+IM - j=1+iy/NDIV - iy=iv(j) - iv(j)=idum - ran1=dmin1(AM*iy,RNMX) - return - end \ No newline at end of file +! integer j,k,iv(NTAB),iy +! save iv,iy +! data iv /NTAB*0/,iy /0/ +! if(idum.le.0.or.iy.eq.0)then +! idum=max(-idum,1) +! do j=NTAB+8,1,-1 +! k=idum/IQ +! idum=IA*(idum-k*IQ)-IR*k +! if(idum.lt.0)idum=idum+IM +! if(j.le.NTAB)iv(j)=idum +! enddo +! iy=iv(1) +! endif +! k=idum/IQ +! idum=IA*(idum-k*IQ)-IR*k +! if(idum.lt.0)idum=idum+IM +! j=1+iy/NDIV +! iy=iv(j) +! iv(j)=idum +! ran1=dmin1(AM*iy,RNMX) +! return +! end diff --git a/dataassim/math/othersupmath/sigmoid.f b/dataassim/math/othersupmath/sigmoid.f index 673abe0..09359ec 100644 --- a/dataassim/math/othersupmath/sigmoid.f +++ b/dataassim/math/othersupmath/sigmoid.f @@ -73,7 +73,7 @@ do i=1,6 grad(i)=grad6(i) enddo - call gradsigmoidfunc(0.0,a2,b2,c2,x02,x,grad6) + call gradsigmoidfunc(0.0d0,a2,b2,c2,x02,x,grad6) grad(6)=grad(6)-grad6(6) do i=1,4 grad(6+i)=-grad6(i) diff --git a/dataassim/math/othersupmath/supmath.f b/dataassim/math/othersupmath/supmath.f index b8efa12..9388e2c 100644 --- a/dataassim/math/othersupmath/supmath.f +++ b/dataassim/math/othersupmath/supmath.f @@ -1,3 +1,54 @@ + subroutine fgetmaxmin(n,x,xmin,imin,xmax,imax) + implicit none + integer n,imin,imax,i + double precision x(n),xmin,xmax + imin=1 + xmin=x(1) + imax=1 + xmax=x(1) + do i=2,n + if(x(i).lt.xmin)then + imin=i + xmin=x(i) + endif + if(x(i).gt.xmax)then + imax=i + xmax=x(i) + endif + enddo + return + end + + double precision function fdotsec(idotsec) + implicit none + integer idotsec,i,k,j(100),n + k=idotsec + i=1 +10 j(i)=mod(k,10) + k=k/10 + if(k.gt.0)then + i=i+1 + goto 10 + endif + fdotsec=0.0d0 + do k=1,i + n=10**(i-k+1) + fdotsec=fdotsec+dble(j(k))/dble(n) + enddo + return + end + + integer function isitnaninf(x) +!If x is NaN or INF, isitnaninf=1. Otherwise, isitnaninf=0 + implicit none + double precision x + isitnaninf=1 + if((x+1.0d0).gt.x)isitnaninf=0 + if((x+1.0d0).lt.x)isitnaninf=1 + if((x+1.0d0).eq.x)isitnaninf=1 + return + end + subroutine sort_shell(n,a,iorder) !sort array a with the Shell method (from smallest to largest). !iorder records the original position of each member. @@ -66,6 +117,41 @@ c: x^3+p*x^2+q*x+r=0 cubicroot=root2 return end + + subroutine getcubicroot(p,q,r,root1,root2,root3) +c + implicit double precision(a-h,l,o-z) + +c: x^3+p*x^2+q*x+r=0 + root1=-9999.0d0 + root2=-9999.0d0 + root3=-9999.0d0 + + capq=(p*p-3.0d0*q)/9.0d0 + capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0 + if (capr*capr .lt. capq*capq*capq) then + rtta=dacos(capr/(dsqrt(capq*capq*capq))) + root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0 + + root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)* + & dsqrt(3.0d0))-p/3.0d0 + root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)* + & dsqrt(3.0d0))-p/3.0d0 + else + capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr- + & capq*capq*capq))**(1.0d0/3.0d0) + if (dabs(capa) .lt. 1.0d-6) then + capb=0.0 + else + capb=capq/capa + end if + root2 =(capa+capb)-p/3.0d0 + end if + cubicroot=root2 + return + end + + c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& subroutine quadraticroots(a,b,c,root1,root2) implicit none @@ -531,7 +617,31 @@ c#################################################################### std=std+(xvar(j)-fmean)*(xvar(j)-fmean) enddo std=dsqrt(std/dble(nsamp-1)) - end + end + + subroutine stdmeancv(nsamp0,xvar0,std,fmean,cv) + implicit none + integer nsamp0,nsamp,j + double precision xvar0(nsamp0),xvar(nsamp0),std,fmean,cv + nsamp=0 + do j=1,nsamp0 + if(dabs(xvar0(j)+9999.0d0).gt.1.0d-7)then + nsamp=nsamp+1 + xvar(nsamp)=xvar0(j) + endif + enddo + fmean=0.0d0 + do j=1,nsamp + fmean=fmean+xvar(j) + enddo + fmean=fmean/dble(nsamp) + std=0.0d0 + do j=1,nsamp + std=std+(xvar(j)-fmean)*(xvar(j)-fmean) + enddo + std=dsqrt(std/dble(nsamp-1)) + cv=std/fmean + end c####################################################################### subroutine reinitialization(x0min,x0likely, & x0max,x0new,minterval) diff --git a/dataassim/math/othersupmath/univparser.f b/dataassim/math/othersupmath/univparser.f index d1ba308..77ea273 100644 --- a/dataassim/math/othersupmath/univparser.f +++ b/dataassim/math/othersupmath/univparser.f @@ -4,7 +4,8 @@ implicit none integer nmax,n double precision vars(nmax+100) - character longchar*(*),astring*50,c*1 + character(*)::longchar + character astring*50,c*1 integer i,pos1,pos2,ispartnum,leng,numchar,ierr ! n=0 diff --git a/dataassim/math/othersupmath/y_aPLUSbx.f b/dataassim/math/othersupmath/y_aPLUSbx.f new file mode 100644 index 0000000..659bb85 --- /dev/null +++ b/dataassim/math/othersupmath/y_aPLUSbx.f @@ -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 diff --git a/dataassim/mathrun/Makefile b/dataassim/mathrun/Makefile new file mode 100644 index 0000000..f694802 --- /dev/null +++ b/dataassim/mathrun/Makefile @@ -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) diff --git a/dataassim/mathrun/fort.112 b/dataassim/mathrun/fort.112 new file mode 100644 index 0000000..69ffe3d --- /dev/null +++ b/dataassim/mathrun/fort.112 @@ -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 diff --git a/dataassim/mathrun/fort.9 b/dataassim/mathrun/fort.9 new file mode 100644 index 0000000..3086497 --- /dev/null +++ b/dataassim/mathrun/fort.9 @@ -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 diff --git a/dataassim/mathrun/mathtest b/dataassim/mathrun/mathtest new file mode 100644 index 0000000..5f86960 Binary files /dev/null and b/dataassim/mathrun/mathtest differ diff --git a/dataassim/mathrun/sensfit b/dataassim/mathrun/sensfit new file mode 100644 index 0000000..8e0fc73 Binary files /dev/null and b/dataassim/mathrun/sensfit differ diff --git a/dataassim/mathrun/testdata.txt b/dataassim/mathrun/testdata.txt new file mode 100644 index 0000000..e023e77 --- /dev/null +++ b/dataassim/mathrun/testdata.txt @@ -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 diff --git a/leafres/testarea/C4PhotoFit.f b/leafres/testarea/C4PhotoFit.f new file mode 100644 index 0000000..5014d74 --- /dev/null +++ b/leafres/testarea/C4PhotoFit.f @@ -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 diff --git a/leafres/testarea/C4SetUpLeafGasFit.f b/leafres/testarea/C4SetUpLeafGasFit.f new file mode 100644 index 0000000..767969a --- /dev/null +++ b/leafres/testarea/C4SetUpLeafGasFit.f @@ -0,0 +1,1578 @@ + subroutine C4SetUpLeafGasFit(icurveno_usr,curvename,ntotsamples0, + &CurveTypeID,anet_obs0,pco2i0,templeaf0,PARi0,pres_air0,po2i0, + &chlflphips20,pco2ambient0,trmmol0,gswmeas0,vpdl0,tempair0, + &eambient0,fo_pam0,fm_pam0,fs_pam0,pam_measlight0,stargamma25_usr, + &fkc25_usr,fko25_usr,rdlight25_usr,alpha25_usr,resistwp25_usr, + &resistch25_usr,isitmassbased,indexunit, + &siteID,Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,species,avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,woodporosity,sapwooddensity,leafratio) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' +!--------------------Inputs-------------------------------------------------------------- +!None of the inputs is changed by this subroutine +!icurveno_usr(int): the curve number +!curvename(char): the curve name +!ntotsamples0: the total number of data points +!CurveTypeID =1-3: Any measurements where limitation states are known: +! =1 limited by Rubisco +! =2 limited by RuBp regeneration +! =3 limited by TPU +! =11-25: ACi Curves. Each different CurveTypeID number represents a different A/Ci curve (i.e., different PAR levels). +! For example, five different PAR levels are used to measure five A/Ci curves with PAR = 200, 400, 600, 800, +! 1000.Use 11, 12, 13, 14, 15 to indentify points of each curve. Maxumum 15 A/Ci curves. +! The curves must be numbered consecutively. +! =31-45: ALight Curves. Each different CurveTypeID number represents a different A/Light curve (i.e., different ambient CO2 levels). +! For example, five different ambient levels are used to measure five A/Light curves with CO2a= 100, 200, 300, 400, 500. +! Use 31, 32, 33, 34, 35 to indentify points of each ALight curve. The curves must be ordered consecutively. +! =-9999: all other types of measurements. +!anet_obs0: Net photosynthetic rate (umol m-2 s-1) +!pco2i0: Intercellular CO2 concentration (Pa) +!templeaf0: leaf temperature (K) +!PARi0: The PAR level inside the chamber to which photosynthesis responds (umolm-2s-1) +!pres_air0: Atmospheric pressure (Pa) +!po2i0: Oxygen partial presssure (Pa) +!chlflphips20: Chlorophyll fluorescence (NA), that is, DeltaF/Fm, the fraction of +! absorbed PSII photons that are used in photochemistry +!pco2ambient0: Ambient CO2 partial pressure (Pa) +!trmmol0: Transpiration rate (mmolm-2s-1) +!gswmeas0: Stomatal conductance for water vapor (molm-2s-1) +!vpdl0: Water vapor pressure difference between the leaf and chamber air (Pa) +!tempair0: Air temperature inside the chamber (K) +!eambient0: Water vapor pressure inside the chamber (Pa). +!fo_pam0: fo (dark adapated) or fo' (actinic light turned off, far red light on to drain electrons from PSII) from pulse amplitude modulation (arbitrary unit). +!fm_pam0: fm (dark adapated with saturation pulse) or fm' (actinic light with saturation pulse) from pulse amplitude modulation (arbitrary unit). +!fs_pam0: steady state fluorescence from pulse amplitude modulation (arbitrary unit). +!pam_measlight0: the measuring light level (umolm-2s-1) +!stargamma25_usr: Chloroplastic CO2 compenstation point at 25oC provided by the user (Pa), set to -9999 if not available +!fkc25_usr: the Michaelis constant for CO2 at 25oC provided by the user (Pa), set to -9999 if not available +!fko25_usr: the Michaelis constant for O2 at 25oC provided by the user (Pa), set to -9999 if not available +!rdlight25_usr: Leaf dark respiration at 25oC provided by user (Pa), set to -9999 if not available +!alpha25_usr: The fraction of glycolate carbon not returned to the chloroplast at 25oC provided by user (NA), set to -9999 if not available +!resistwp25_usr: resistance to CO2 via cell walls and plasmalemma provided by user [umol-1msPa], set to -9999 if not available +!resistch25_usr: resistance to CO2 via chloroplastic envelope provided by user[umol-1msPa], set to -9999 if not available +!isitmassbased: = 0, area-based (typical) +! = 1. mass-based (atypical) +!paramunit: file unit number to write ouputs +!compareunit: file unit number to write ouputs +!stomwuecicaoutunit: file unit number to write ouputs +!wuecicacompunit: file unit number to write ouputs +!stomcompunit: file unit number to write ouputs +!fluorescenceunit: file unit number to write outputs for comparison from fluorescence fit +!fluoresparamunit: file unit number to write parameters from fluorescence fit +!General information,not used but recorded in the output files +! & siteID,Latitude,Longitude,Elevation,yearsampled, +! & sampledoy,GrowingSeasonStart,GrowingSeasonEnd, +! & standage,CanopyHeight,LeafAreaIndex,species, +! & avetimeresolution,avetimesampled,SampleHeight, +! & Needleage,specificLAI,nitrogencontent,carboncontent, +! & phoscontent,woodporosity,sapwooddensity,leafratio) + integer icurveno_usr,ntotsamples0,isitmassbased,indexunit(20) + character*100 curvename + character siteID*(*),species*(*),woodporosity*(*) + double precision CurveTypeID(ntotsamples0), + &anet_obs0(ntotsamples0),pco2i0(ntotsamples0), + &templeaf0(ntotsamples0),PARi0(ntotsamples0), + &pres_air0(ntotsamples0),po2i0(ntotsamples0), + &chlflphips20(ntotsamples0),pco2ambient0(ntotsamples0), + &trmmol0(ntotsamples0),gswmeas0(ntotsamples0),vpdl0(ntotsamples0), + &tempair0(ntotsamples0),eambient0(ntotsamples0), + &fo_pam0(ntotsamples0),fm_pam0(ntotsamples0), + &fs_pam0(ntotsamples0),pam_measlight0(ntotsamples0), + &stargamma25_usr,fkc25_usr,fko25_usr, + &rdlight25_usr,alpha25_usr,resistwp25_usr,resistch25_usr, +!General information,not used but recorded in the output files + &Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,avetimeresolution,avetimesampled,SampleHeight, + &Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,sapwooddensity,leafratio +!------------------------------------------------------------------------------------------ + character*30 modeltype,fourchars(20) + dimension modeltype(0:10) + + integer i,j,k,m,n,idorwp0,idorch0,irchoption1,irchoption2,i2ndary, + &numrubis,numrubp,numtpu,INFO,iderivative,idoalpha0, + &ioriorder(3*ntotsamples0),ibelong(3*ntotsamples0),ACiID(15), + &ALightID(15),paramunit,compareunit,stomwuecicaoutunit, + &stomcompunit,wuecicacompunit,fluorescenceunit, + &fluoresparamunit,aciempfitunit,alightempfitunit,idotempcoeff, + &idomeso,idohavjt + + double precision vcmax25_ini,fjmax25_ini,tpu25_ini,rdlight25_ini, + &stargamma25_ini,fkc25_ini,fko25_ini,alpha25_ini,resistwp25_ini, + &resistch25_ini,resiststomco20(ntotsamples0),term,term1,term2, + &aPPFDlf0(ntotsamples0),weitx(ntotsamples0),xmin(ntotsamples0), + &xmax(ntotsamples0),weity(ntotsamples0),beta(20),starco2i(15), + &der_starco2i(15),Amax_ACi(15),ACiinter(15),der_ACiinter(15), + &der_ACiend(15),starPAR(15),der_starPAR(15),Asat_ALight(15), + &ALightinter(15),der_ALightinter(15),der_ALightend(15), + &PhiPSIIzero_ACi(15),der_PhiPSIIzero_ACi(15),PhiPSIImax_ACi(15), + &PhiPSIIinter_ACi(15),der_PhiPSIIinter_ACi(15), + &der_PhiPSIIend_ACi(15),ExcessLightFactor(15), + &der_PhiPSII1000_ALight(15),PhiPSIIinter_ALight(15), + &der_PhiPSIIinter_ALight(15),amaxave,recycleratio(6,ntotsamples0), + &stargamma25fit(6),ACiavetempleaf(15),ACiaveaPPFDlf(15), + &ACiavepo2i(15),ALightavetempleaf(15),ALightaveCO2ambient(15), + &ALightavepo2i(15),co2c_Pa(4,ntotsamples0),co2imany(500), + &critdelPAR,critdelCi_Pa,rdlight,atp,resistwp,resistch,stargamma, + &ccc,ccj,cct,ac,aj,at,phifactor_ini,thetafactor_ini,betaPSII_ini, + &realizedfjelect,xvector(ntotsamples0),yvector(ntotsamples0), + &fvector(ntotsamples0),gvector(ntotsamples0),hvector(ntotsamples0), + &zvector(ntotsamples0),wvector(ntotsamples0),uvector(ntotsamples0), + &fo_dark,fm_dark,resp_dark,tempK_dark,ACimaxcurvature(15), + &ACimaxcurvpco2i(15),PhiPSIImaxcurvature_ACi(15), + &PhiPSIImaxcurv_ACi(15),ALightmaxcurvature(15), + &ALightmaxcurvPAR(15),PhiPSIImaxcurvature_ALight(15), + &PhiPSIImaxcurv_ALight(15),co2iRubismax25,co2iRuBpmax25, + &anetRubismax25,anetRuBpmax25,starco2a(15),der_starco2a(15), + &Amax_ACa(15),ACainter(15),der_ACainter(15),der_ACa400ppm(15), + &anet_ACa400ppm(15),PhiPSIImax_ACa(15),PhiPSIIinter_ACa(15), + &der_PhiPSIIinter_ACa(15),der_PhiPSIIend_ACa(15), + &ACamaxcurvature(15),ACamaxcurvpco2a(15),Aciavepres_air(15), + &PhiPSIImaxcurvature_ACa(15),PhiPSIImaxcurv_ACa(15), + &PhiPSIIzero_ACa(15),der_PhiPSIIzero_ACa(15),ha_darkresp_ini, + &ha_stargamma_ini,ha_vcmax_ini,ha_jmax_ini,ha_tpu_ini,ha_gmeso_ini + parameter(critdelPAR=-2.0d0,critdelCi_Pa=-2.0d0) +!use positive critdelCi_Pa and critdelPAR to indicate absolute distance +!use negative critdelCi_Pa and critdelPAR to indicate relative distance (percentage value) +!End of declaration======================================================================= + paramunit=indexunit(1) + compareunit=indexunit(2) + stomwuecicaoutunit=indexunit(3) + stomcompunit=indexunit(4) + wuecicacompunit=indexunit(5) + fluorescenceunit=indexunit(6) + fluoresparamunit=indexunit(7) + aciempfitunit=indexunit(8) + alightempfitunit=indexunit(9) +!----------------------------------------------------------------------------------------- + call commonparameters(stargamma25_ini,fkc25_ini,fko25_ini, + &alpha25_ini,ha_vcmax_ini,hd_vcmax,sv_vcmax,ha_jmax_ini,hd_jmax, + &sv_jmax,ha_tpu_ini,hd_tpu,sv_tpu,ha_gmeso_ini,hd_gmeso,sv_gmeso, + &ha_darkresp_ini,ha_stargamma_ini,ha_kc,ha_ko,abspt_lf_par, + &gascon,phifactor_ini,thetafactor_ini,betaPSII_ini) + ha_darkresp=ha_darkresp_ini + ha_stargamma=ha_stargamma_ini + ha_vcmax=ha_vcmax_ini + ha_jmax=ha_jmax_ini + ha_tpu=ha_tpu_ini + ha_gmeso=ha_gmeso_ini + call pam_parameters(ntotsamples0,fo_pam0,fm_pam0,fs_pam0, + &pam_measlight0,anet_obs0,PARi0,templeaf0,yield_ps2,yield_npq, + &qlake,qpuddle,kps2_norm,knpq_norm,fo_dark,fm_dark,resp_dark, + &tempK_dark) + j=0 + do i=1,ntotsamples0 +!this is needed because the calling routine passes any data that have valid PAM measurements. + k=0 + if(dabs(anet_obs0(i)+9999.0d0).lt.0.01d0)k=1 + if(dabs(pco2i0(i)+9999.0d0).lt.0.01d0)k=1 + if(dabs(templeaf0(i)+9999.0d0).lt.0.01d0)k=1 + if(k.eq.0)then + j=j+1 + anet_obs0(j)=anet_obs0(i) + pco2i0(j)=pco2i0(i) + templeaf0(j)=templeaf0(i) + PARi0(j)=PARi0(i) + pres_air0(j)=pres_air0(i) + po2i0(j)=po2i0(i) + chlflphips20(j)=chlflphips20(i) + pco2ambient0(j)=pco2ambient0(i) + trmmol0(j)=trmmol0(i) + gswmeas0(j)=gswmeas0(i) + vpdl0(j)=vpdl0(i) + tempair0(j)=tempair0(i) + eambient0(j)=eambient0(i) +! + fo_pam0(j)=fo_pam0(i) + fm_pam0(j)=fm_pam0(i) + fs_pam0(j)=fs_pam0(i) + pam_measlight0(j)=pam_measlight0(i) + yield_ps2(j)=yield_ps2(i) + yield_npq(j)=yield_npq(i) + qlake(j)=qlake(i) + qpuddle(j)=qpuddle(i) + kps2_norm(j)=kps2_norm(i) + knpq_norm(j)=knpq_norm(i) + endif + enddo + ntotsamples0=j +! + vcmax25_ini=50.0d0 + fjmax25_ini=1.1d0*vcmax25_ini + tpu25_ini=0.07d0*fjmax25_ini + rdlight25_ini=0.015d0*vcmax25_ini + if(resp_dark.gt.0.0d0)then +!data contain dark-adapted rd + call resp_mitocho(tempK_dark,1.0d0,ha_darkresp,gascon,term) + rdlight25_ini=resp_dark/term + if(rdlight25_usr.le.0.0d0)rdlight25_usr=rdlight25_ini + endif + resistwp25_ini=0.1d0 + resistch25_ini=0.1d0 + resistwp25max=100.0d0 + resistwp25min=0.0d0 + resistch25max=100.0d0 + resistch25min=0.0d0 + rdlight25max=10.d0 + rdlight25min=1.0d-7 + stargamma25max=10.0d0 + stargamma25min=1.0d-7 + vcmax25max=700.0d0 + vcmax25min=0.0d0 + fkc25max=100.0d0 + fkc25min=5.0d0 + fko25max=20000.0d0 + fko25min=10000.0d0 + fjmax25max=800.0d0 + fjmax25min=0.0d0 + tpu25max=20.0d0 + tpu25min=0.0d0 + alpha25max=10.0d0 + alpha25min=0.0d0 + alpha25_ini=0.001d0 + phifactormin=1.0d-5 + phifactormax=2.0d0 + thetafactormin=1.0d-5 + thetafactormax=1.2d0 + betaPSIImin=0.0d0 + betaPSIImax=1.0d0 + if(ha_darkresp.gt.0.0d0)then + ha_darkrespmin=5.0d0 + ha_darkrespmax=200.0d0 + else +!-Q10 + ha_darkrespmin=-200.0d0 + ha_darkrespmax=0.0d0 + endif + ha_stargammamin=5.0d0 + ha_stargammamax=200.0d0 + ha_vcmaxmin=40.0d0 + ha_vcmaxmax=100.0d0 + ha_jmaxmin=20.0d0 + ha_jmaxmax=100.0d0 + ha_tpumin=20.0d0 + ha_tpumax=100.0d0 + ha_gmesomin=20.0d0 + ha_gmesomax=100.0d0 + if(isitmassbased.eq.1)then + vcmax25max=2000.0d0 + fjmax25max=2000.0d0 + tpu25max=100.0d0 + rdlight25max=30.d0 + endif + nFixedPoints=0 + numACicurves=0 + numALightcurves=0 + nFreePoints=0 + do i=1,ntotsamples0 + aPPFDlf0(i)=PARi0(i)*abspt_lf_par + if(gswmeas0(i).gt.0.0d0)then + resiststomco20(i)=1.6d0/gswmeas0(i) +!unit is 1/(mol/m2/s). Now we need to change it to 1.0d0/(umol/m2/s/Pa) + resiststomco20(i)=resiststomco20(i)*pres_air0(i)*1.0d-6 + else + resiststomco20(i)=-9999.0d0 + endif + j=idnint(CurveTypeID(i)+0.1d0) + if(j.eq.1.or.j.eq.2.or.j.eq.3)then +!points whose limitation states are known. + nFixedPoints=nFixedPoints+1 + Fixedanet_obs(nFixedPoints)=anet_obs0(i) + Fixedpco2i(nFixedPoints)=pco2i0(i) + Fixedtempleaf(nFixedPoints)=templeaf0(i) + FixedaPPFDlf(nFixedPoints)=aPPFDlf0(i) + Fixedpres_air(nFixedPoints)=pres_air0(i) + Fixedpo2i(nFixedPoints)=po2i0(i) + Fixedchlflphips2(nFixedPoints)=chlflphips20(i) + Fixedpco2ambient(nFixedPoints)=pco2ambient0(i) + Fixedtrmmol(nFixedPoints)=trmmol0(i) + Fixedgswmeas(nFixedPoints)=gswmeas0(i) + Fixedvpdl(nFixedPoints)=vpdl0(i) + Fixedtempair(nFixedPoints)=tempair0(i) + Fixedeambient(nFixedPoints)=eambient0(i) +! + Fixedfo_pam(nFixedPoints)=fo_pam0(i) + Fixedfm_pam(nFixedPoints)=fm_pam0(i) + Fixedfs_pam(nFixedPoints)=fs_pam0(i) + Fixedpam_measlight(nFixedPoints)=pam_measlight0(i) + Fixedyield_ps2(nFixedPoints)=yield_ps2(i) + Fixedyield_npq(nFixedPoints)=yield_npq(i) + Fixedqlake(nFixedPoints)=qlake(i) + Fixedqpuddle(nFixedPoints)=qpuddle(i) + Fixedkps2_norm(nFixedPoints)=kps2_norm(i) + Fixedknpq_norm(nFixedPoints)=knpq_norm(i) +! + Fixedresiststomco2(nFixedPoints)=resiststomco20(i) + Prioriphotolimit(nFixedPoints)=j + else + if(j.ge.11.and.j.le.25)then +!A/Ci curves without knowing limitation states of points. + m=0 + do k=1,numACicurves + if(j.eq.ACiID(k))then + nACiPoints(k)=nACiPoints(k)+1 + ACianet_obs0(nACiPoints(k),k)=anet_obs0(i) + ACipco2i0(nACiPoints(k),k)=pco2i0(i) + ACitempleaf0(nACiPoints(k),k)=templeaf0(i) + ACiaPPFDlf0(nACiPoints(k),k)=aPPFDlf0(i) + ACipres_air0(nACiPoints(k),k)=pres_air0(i) + ACipo2i0(nACiPoints(k),k)=po2i0(i) + ACichlflphips20(nACiPoints(k),k)=chlflphips20(i) + ACipco2ambient0(nACiPoints(k),k)=pco2ambient0(i) + ACitrmmol0(nACiPoints(k),k)=trmmol0(i) + ACigswmeas0(nACiPoints(k),k)=gswmeas0(i) + ACivpdl0(nACiPoints(k),k)=vpdl0(i) + ACitempair0(nACiPoints(k),k)=tempair0(i) + ACieambient0(nACiPoints(k),k)=eambient0(i) +! + ACifo_pam0(nACiPoints(k),k)=fo_pam0(i) + ACifm_pam0(nACiPoints(k),k)=fm_pam0(i) + ACifs_pam0(nACiPoints(k),k)=fs_pam0(i) + ACipam_measlight0(nACiPoints(k),k)=pam_measlight0(i) + ACiyield_ps20(nACiPoints(k),k)=yield_ps2(i) + ACiyield_npq0(nACiPoints(k),k)=yield_npq(i) + ACiqlake0(nACiPoints(k),k)=qlake(i) + ACiqpuddle0(nACiPoints(k),k)=qpuddle(i) + ACikps2_norm0(nACiPoints(k),k)=kps2_norm(i) + ACiknpq_norm0(nACiPoints(k),k)=knpq_norm(i) +! + ACiresiststomco20(nACiPoints(k),k)=resiststomco20(i) + m=1 + endif + enddo + if(m.eq.0)then +!A new ACi curve + numACicurves=numACicurves+1 + nACiPoints(numACicurves)=1 + ACiID(numACicurves)=j + ACianet_obs0(1,numACicurves)=anet_obs0(i) + ACipco2i0(1,numACicurves)=pco2i0(i) + ACitempleaf0(1,numACicurves)=templeaf0(i) + ACiaPPFDlf0(1,numACicurves)=aPPFDlf0(i) + ACipres_air0(1,numACicurves)=pres_air0(i) + ACipo2i0(1,numACicurves)=po2i0(i) + ACichlflphips20(1,numACicurves)=chlflphips20(i) + ACipco2ambient0(1,numACicurves)=pco2ambient0(i) + ACitrmmol0(1,numACicurves)=trmmol0(i) + ACigswmeas0(1,numACicurves)=gswmeas0(i) + ACivpdl0(1,numACicurves)=vpdl0(i) + ACitempair0(1,numACicurves)=tempair0(i) + ACieambient0(1,numACicurves)=eambient0(i) +! + ACifo_pam0(1,numACicurves)=fo_pam0(i) + ACifm_pam0(1,numACicurves)=fm_pam0(i) + ACifs_pam0(1,numACicurves)=fs_pam0(i) + ACipam_measlight0(1,numACicurves)=pam_measlight0(i) + ACiyield_ps20(1,numACicurves)=yield_ps2(i) + ACiyield_npq0(1,numACicurves)=yield_npq(i) + ACiqlake0(1,numACicurves)=qlake(i) + ACiqpuddle0(1,numACicurves)=qpuddle(i) + ACikps2_norm0(1,numACicurves)=kps2_norm(i) + ACiknpq_norm0(1,numACicurves)=knpq_norm(i) +! + ACiresiststomco20(1,numACicurves)=resiststomco20(i) + endif + else + if(j.ge.31.and.j.le.45)then +!A/Light curves without knowing limitation states of points. + m=0 + do k=1,numALightcurves + if(j.eq.ALightID(k))then + nALightPoints(k)=nALightPoints(k)+1 + ALightanet_obs0(nALightPoints(k),k)=anet_obs0(i) + ALightpco2i0(nALightPoints(k),k)=pco2i0(i) + ALighttempleaf0(nALightPoints(k),k)=templeaf0(i) + ALightaPPFDlf0(nALightPoints(k),k)=aPPFDlf0(i) + ALightpres_air0(nALightPoints(k),k)=pres_air0(i) + ALightpo2i0(nALightPoints(k),k)=po2i0(i) + ALightchlflphips20(nALightPoints(k),k)=chlflphips20(i) + ALightpco2ambient0(nALightPoints(k),k)=pco2ambient0(i) + ALighttrmmol0(nALightPoints(k),k)=trmmol0(i) + ALightgswmeas0(nALightPoints(k),k)=gswmeas0(i) + ALightvpdl0(nALightPoints(k),k)=vpdl0(i) + ALighttempair0(nALightPoints(k),k)=tempair0(i) + ALighteambient0(nALightPoints(k),k)=eambient0(i) +! + ALightfo_pam0(nALightPoints(k),k)=fo_pam0(i) + ALightfm_pam0(nALightPoints(k),k)=fm_pam0(i) + ALightfs_pam0(nALightPoints(k),k)=fs_pam0(i) + ALightpam_measlight0(nALightPoints(k),k)= + &pam_measlight0(i) + ALightyield_ps20(nALightPoints(k),k)=yield_ps2(i) + ALightyield_npq0(nALightPoints(k),k)=yield_npq(i) + ALightqlake0(nALightPoints(k),k)=qlake(i) + ALightqpuddle0(nALightPoints(k),k)=qpuddle(i) + ALightkps2_norm0(nALightPoints(k),k)=kps2_norm(i) + ALightknpq_norm0(nALightPoints(k),k)=knpq_norm(i) +! + ALightresiststomco20(nALightPoints(k),k)= + &resiststomco20(i) + m=1 + endif + enddo + if(m.eq.0)then +!A new A/Light curve + numALightcurves=numALightcurves+1 + nALightPoints(numALightcurves)=1 + ALightID(numALightcurves)=j + ALightanet_obs0(1,numALightcurves)=anet_obs0(i) + ALightpco2i0(1,numALightcurves)=pco2i0(i) + ALighttempleaf0(1,numALightcurves)=templeaf0(i) + ALightaPPFDlf0(1,numALightcurves)=aPPFDlf0(i) + ALightpres_air0(1,numALightcurves)=pres_air0(i) + ALightpo2i0(1,numALightcurves)=po2i0(i) + ALightchlflphips20(1,numALightcurves)=chlflphips20(i) + ALightpco2ambient0(1,numALightcurves)=pco2ambient0(i) + ALighttrmmol0(1,numALightcurves)=trmmol0(i) + ALightgswmeas0(1,numALightcurves)=gswmeas0(i) + ALightvpdl0(1,numALightcurves)=vpdl0(i) + ALighttempair0(1,numALightcurves)=tempair0(i) + ALighteambient0(1,numALightcurves)=eambient0(i) +! + ALightfo_pam0(1,numALightcurves)=fo_pam0(i) + ALightfm_pam0(1,numALightcurves)=fm_pam0(i) + ALightfs_pam0(1,numALightcurves)=fs_pam0(i) + ALightpam_measlight0(1,numALightcurves)= + &pam_measlight0(i) + ALightyield_ps20(1,numALightcurves)=yield_ps2(i) + ALightyield_npq0(1,numALightcurves)=yield_npq(i) + ALightqlake0(1,numALightcurves)=qlake(i) + ALightqpuddle0(1,numALightcurves)=qpuddle(i) + ALightkps2_norm0(1,numALightcurves)=kps2_norm(i) + ALightknpq_norm0(1,numALightcurves)=knpq_norm(i) +! + ALightresiststomco20(1,numALightcurves)= + &resiststomco20(i) + endif + else + nFreePoints=nFreePoints+1 + Freeanet_obs(nFreePoints)=anet_obs0(i) + Freepco2i(nFreePoints)=pco2i0(i) + Freetempleaf(nFreePoints)=templeaf0(i) + FreeaPPFDlf(nFreePoints)=aPPFDlf0(i) + Freepres_air(nFreePoints)=pres_air0(i) + Freepo2i(nFreePoints)=po2i0(i) + Freechlflphips2(nFreePoints)=chlflphips20(i) + Freepco2ambient(nFreePoints)=pco2ambient0(i) + Freetrmmol(nFreePoints)=trmmol0(i) + Freegswmeas(nFreePoints)=gswmeas0(i) + Freevpdl(nFreePoints)=vpdl0(i) + Freetempair(nFreePoints)=tempair0(i) + Freeeambient(nFreePoints)=eambient0(i) +! + Freefo_pam(nFreePoints)=fo_pam0(i) + Freefm_pam(nFreePoints)=fm_pam0(i) + Freefs_pam(nFreePoints)=fs_pam0(i) + Freepam_measlight(nFreePoints)=pam_measlight0(i) + Freeyield_ps2(nFreePoints)=yield_ps2(i) + Freeyield_npq(nFreePoints)=yield_npq(i) + Freeqlake(nFreePoints)=qlake(i) + Freeqpuddle(nFreePoints)=qpuddle(i) + Freekps2_norm(nFreePoints)=kps2_norm(i) + Freeknpq_norm(nFreePoints)=knpq_norm(i) +! + Freeresiststomco2(nFreePoints)=resiststomco20(i) + endif + endif + endif + enddo +!----------------------------------------------------------------------- +!Average clusters and then sort of ACi and ALight points. No need to cluster or sort fixed and free points + do i=1,numACicurves + call clustering(nACiPoints(i),1,ACipco2i0(1:nACiPoints(i),i:i), + &critdelCi_Pa,k,ibelong) + if(k.lt.nACipoints(i))then + call aftercluster(nACiPoints(i),1, + &ACipco2i0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipco2ambient0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiaPPFDlf0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACitempleaf0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipres_air0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACianet_obs0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipo2i0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACitrmmol0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACigswmeas0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACivpdl0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACitempair0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACieambient0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACichlflphips20(1:nACiPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nACiPoints(i),1, + &ACifo_pam0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACifm_pam0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACifs_pam0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipam_measlight0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiyield_ps20(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiyield_npq0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiqlake0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiqpuddle0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACikps2_norm0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiknpq_norm0(1:nACiPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nACiPoints(i),1, + &ACiresiststomco20(1:nACiPoints(i),i:i),k,ibelong,fvector) + nACiPoints(i)=k + endif +!sort CO2i from low to high + do j=1,nACiPoints(i) + ACipco2i(j,i)=ACipco2i0(j,i) + enddo + call sort_shell(nACiPoints(i),ACipco2i(1:nACiPoints(i),i:i), + &ioriorder) + do j=1,nACiPoints(i) + ACianet_obs(j,i)=ACianet_obs0(ioriorder(j),i) + ACitempleaf(j,i)=ACitempleaf0(ioriorder(j),i) + ACiaPPFDlf(j,i)=ACiaPPFDlf0(ioriorder(j),i) + ACipo2i(j,i)=ACipo2i0(ioriorder(j),i) + ACipres_air(j,i)=ACipres_air0(ioriorder(j),i) + ACipco2ambient(j,i)=ACipco2ambient0(ioriorder(j),i) + ACitrmmol(j,i)=ACitrmmol0(ioriorder(j),i) + ACigswmeas(j,i)=ACigswmeas0(ioriorder(j),i) + ACivpdl(j,i)=ACivpdl0(ioriorder(j),i) + ACitempair(j,i)=ACitempair0(ioriorder(j),i) + ACieambient(j,i)=ACieambient0(ioriorder(j),i) + ACichlflphips2(j,i)=ACichlflphips20(ioriorder(j),i) +! + ACifo_pam(j,i)=ACifo_pam0(ioriorder(j),i) + ACifm_pam(j,i)=ACifm_pam0(ioriorder(j),i) + ACifs_pam(j,i)=ACifs_pam0(ioriorder(j),i) + ACipam_measlight(j,i)=ACipam_measlight0(ioriorder(j),i) + ACiyield_ps2(j,i)=ACiyield_ps20(ioriorder(j),i) + ACiyield_npq(j,i)=ACiyield_npq0(ioriorder(j),i) + ACiqlake(j,i)=ACiqlake0(ioriorder(j),i) + ACiqpuddle(j,i)=ACiqpuddle0(ioriorder(j),i) + ACikps2_norm(j,i)=ACikps2_norm0(ioriorder(j),i) + ACiknpq_norm(j,i)=ACiknpq_norm0(ioriorder(j),i) +! + ACiresiststomco2(j,i)=ACiresiststomco20(ioriorder(j),i) + enddo + enddo + do i=1,numALightcurves + call clustering(nALightPoints(i),1, + &ALightaPPFDlf0(1:nALightPoints(i),i:i),critdelPAR,k,ibelong) + if(k.lt.nALightpoints(i))then + call aftercluster(nALightPoints(i),1, + &ALightpco2i0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpco2ambient0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightaPPFDlf0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighttempleaf0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpres_air0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightanet_obs0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpo2i0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighttrmmol0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightgswmeas0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightvpdl0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighttempair0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighteambient0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightchlflphips20(1:nALightPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nALightPoints(i),1, + &ALightfo_pam0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightfm_pam0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightfs_pam0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpam_measlight0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightyield_ps20(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightyield_npq0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightqlake0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightqpuddle0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightkps2_norm0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightknpq_norm0(1:nALightPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nALightPoints(i),1, + &ALightresiststomco20(1:nALightPoints(i),i:i),k,ibelong,fvector) + nALightPoints(i)=k + endif +!sort PAR from low to high + do j=1,nALightPoints(i) + ALightaPPFDlf(j,i)=ALightaPPFDlf0(j,i) + enddo + call sort_shell(nALightPoints(i), + &ALightaPPFDlf(1:nALightPoints(i),i:i),ioriorder) + do j=1,nALightPoints(i) + ALightanet_obs(j,i)=ALightanet_obs0(ioriorder(j),i) + ALighttempleaf(j,i)=ALighttempleaf0(ioriorder(j),i) + ALightpco2i(j,i)=ALightpco2i0(ioriorder(j),i) + ALightpo2i(j,i)=ALightpo2i0(ioriorder(j),i) + ALightpres_air(j,i)=ALightpres_air0(ioriorder(j),i) + ALightpco2ambient(j,i)=ALightpco2ambient0(ioriorder(j),i) + ALighttrmmol(j,i)=ALighttrmmol0(ioriorder(j),i) + ALightgswmeas(j,i)=ALightgswmeas0(ioriorder(j),i) + ALightvpdl(j,i)=ALightvpdl0(ioriorder(j),i) + ALighttempair(j,i)=ALighttempair0(ioriorder(j),i) + ALighteambient(j,i)=ALighteambient0(ioriorder(j),i) + ALightchlflphips2(j,i)=ALightchlflphips20(ioriorder(j),i) +! + ALightfo_pam(j,i)=ALightfo_pam0(ioriorder(j),i) + ALightfm_pam(j,i)=ALightfm_pam0(ioriorder(j),i) + ALightfs_pam(j,i)=ALightfs_pam0(ioriorder(j),i) + ALightpam_measlight(j,i)=ALightpam_measlight0(ioriorder(j),i) + ALightyield_ps2(j,i)=ALightyield_ps20(ioriorder(j),i) + ALightyield_npq(j,i)=ALightyield_npq0(ioriorder(j),i) + ALightqlake(j,i)=ALightqlake0(ioriorder(j),i) + ALightqpuddle(j,i)=ALightqpuddle0(ioriorder(j),i) + ALightkps2_norm(j,i)=ALightkps2_norm0(ioriorder(j),i) + ALightknpq_norm(j,i)=ALightknpq_norm0(ioriorder(j),i) +! + ALightresiststomco2(j,i)=ALightresiststomco20(ioriorder(j),i) + enddo + enddo +!----------------------------------------------------------------------- + do i=1,numACicurves + amaxave=0.0d0 + n=3 + do j=nACiPoints(i)-n+1,nACiPoints(i) + amaxave=amaxave+ACianet_obs(j,i) + enddo + amaxave=amaxave/dble(n) +!the sigmoidal function has better asymptotic behaviour so +!it is used for estimating anetmaxs. + iderivative=1 + INFO=0 +!INFO =0, ordinary distance regression +!INFO =1, explicit orthogonal distance regression with shortest distance within iteration +!INFO =2, explicit orthogonal distance regression with x positions as parameters + beta(1)=dabs(amaxave) + if(amaxave.lt.0.0d0)then + betamin(1)=amaxave + else + betamin(1)=0.5d0*amaxave + endif + betamax(1)=1000.0d0 + beta(2)=1.5d0 + betamin(2)=1.0d-5 + betamax(2)=1000.0d0 + beta(3)=0.1d0 + betamin(3)=0.0d0 + betamax(3)=100.0d0 + beta(4)=30.0d0 + betamin(4)=0.0d0 + betamax(4)=5000.0d0 + beta(5)=-10.0d0 + betamin(5)=-1000.0d0 + betamax(5)=1000.0d0 + k=0 + n=0 + do j=1,nACiPoints(i) + weitx(j)=1.0d0 + xmin(j)=dmax1(0.0d0,ACipco2i(j,i)-20.0d0) + xmax(j)=ACipco2i(j,i)+20.0d0 + weity(j)=1.0d0 + if(ACichlflphips2(j,i).gt.0.0d0)then + k=k+1 + yvector(k)=ACichlflphips2(j,i) + xvector(k)=ACipco2i(j,i) + uvector(k)=ACipco2ambient(j,i) + endif + if(ACipco2ambient(j,i).gt.0.0d0)then + n=n+1 + zvector(n)=ACianet_obs(j,i) + wvector(n)=ACipco2ambient(j,i) + endif + enddo +! + call GenericRegres(nACiPoints(i),1, + &ACianet_obs(1:nACiPoints(i),i:i),1,ACipco2i(1:nACiPoints(i),i:i), + &weity,weitx,5,beta,betamin,betamax,xmin,xmax,iderivative,INFO, + &fvector,gvector,sumsquare) + call properties_surffunc(5,beta,starco2i(i),der_starco2i(i), + &Amax_ACi(i),ACiinter(i),der_ACiinter(i), + &ACipco2i(nACiPoints(i):nACiPoints(i),i:i),der_ACiend(i),term, + &ACipco2i(1:1,i:i),ACipco2i(nACiPoints(i):nACiPoints(i),i:i), + &ACimaxcurvature(i),ACimaxcurvpco2i(i)) + if(n.ge.5)then + call GenericRegres(n,1,zvector,1,wvector,weity,weitx,5,beta, + &betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,starco2a(i),der_starco2a(i), + &Amax_ACa(i),ACainter(i),der_ACainter(i),40.0d0,der_ACa400ppm(i), + &anet_ACa400ppm(i),wvector(1),wvector(n),ACamaxcurvature(i), + &ACamaxcurvpco2a(i)) + else + der_starco2a(i)=-9999.0d0 + Amax_ACa(i)=-9999.0d0 + ACainter(i)=-9999.0d0 + der_ACainter(i)=-9999.0d0 + der_ACa400ppm(i)=-9999.0d0 + anet_ACa400ppm(i)=-9999.0d0 + ACamaxcurvature(i)=-9999.0d0 + ACamaxcurvpco2a(i)=-9999.0d0 + endif + if(Amax_ACi(i).lt.50.0d0)amaxave=Amax_ACi(i) + j=min0(5,nACiPoints(i)) + call y_aPLUSbx(j,ACipco2i(1:j,i:i),ACianet_obs(1:j,i:i),ac,at) +!fit for y=ac+at*x + if(ac.lt.0.0d0.and.dabs(ac).lt.rdlight25max)then + rdlight25_ini=dabs(ac) + if((-ac/at).lt.stargamma25max.and. + &(-ac/at).gt.stargamma25_ini)stargamma25max=-ac/at + endif + if(amaxave.gt.0.0d0)then + vcmax25_ini=amaxave+rdlight25_ini + else + fjmax25_ini=10.0d0 + vcmax25_ini=fjmax25_ini/1.1d0 + tpu25_ini=1.0d0 + endif + if(k.ge.5)then +! beta(1)=0.50d0 +! betamin(1)=0.0d0 +! betamax(1)=1000.0d0 +! beta(2)=5.50d0 +! betamin(2)=0.0d0 +! betamax(2)=1000.0d0 +! beta(3)=1.50d0 +! betamin(3)=-10.0d0 +! betamax(3)=10.0d0 + + beta(1)=0.4d0 + betamin(1)=0.0d0 + betamax(1)=2.0d0 + beta(2)=1.5d0 + betamin(2)=1.0d-5 + betamax(2)=1000.0d0 + beta(3)=0.1d0 + betamin(3)=0.0d0 + betamax(3)=100.0d0 + beta(4)=30.0d0 + betamin(4)=0.0d0 + betamax(4)=5000.0d0 + beta(5)=0.1d0 + betamin(5)=-5.0d0 + betamax(5)=5.0d0 + do j=1,k + xmin(j)=dmax1(0.0d0,xvector(j)-20.0d0) + xmax(j)=xvector(j)+20.0d0 + enddo + call GenericRegres(k,1,yvector,1,xvector,weity,weitx,5, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,PhiPSIIzero_ACi(i), + &der_PhiPSIIzero_ACi(i),PhiPSIImax_ACi(i), + &PhiPSIIinter_ACi(i),der_PhiPSIIinter_ACi(i),xvector(k), + &der_PhiPSIIend_ACi(i),term,xvector(1),xvector(k), + &PhiPSIImaxcurvature_ACi(i),PhiPSIImaxcurv_ACi(i)) + call GenericRegres(k,1,yvector,1,uvector,weity,weitx,5, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,PhiPSIIzero_ACa(i), + &der_PhiPSIIzero_ACa(i),PhiPSIImax_ACa(i), + &PhiPSIIinter_ACa(i),der_PhiPSIIinter_ACa(i),uvector(k), + &der_PhiPSIIend_ACa(i),term,uvector(1),uvector(k), + &PhiPSIImaxcurvature_ACa(i),PhiPSIImaxcurv_ACa(i)) + else + PhiPSIIinter_ACi(i)=-9999.0d0 + der_PhiPSIIinter_ACi(i)=-9999.0d0 + PhiPSIIzero_ACi(i)=-9999.0d0 + der_PhiPSIIzero_ACi(i)=-9999.0d0 + PhiPSIImax_ACi(i)=-9999.0d0 + der_PhiPSIIend_ACi(i)=-9999.0d0 + PhiPSIImaxcurvature_ACi(i)=-9999.0d0 + PhiPSIImaxcurv_ACi(i)=-9999.0d0 + PhiPSIIinter_ACa(i)=-9999.0d0 + der_PhiPSIIinter_ACa(i)=-9999.0d0 + PhiPSIIzero_ACa(i)=-9999.0d0 + der_PhiPSIIzero_ACa(i)=-9999.0d0 + PhiPSIImax_ACa(i)=-9999.0d0 + der_PhiPSIIend_ACa(i)=-9999.0d0 + PhiPSIImaxcurvature_ACa(i)=-9999.0d0 + PhiPSIImaxcurv_ACa(i)=-9999.0d0 + endif +! + n=nACiPoints(i) + call y_aPLUSbxrsq(n,ACipco2i(1:n,i:i),ACianet_obs(1:n,i:i), + &ac,at,term) + resistwp25_ini=3.0d0*term**6 + resistch25_ini=term**6 + + if(term.lt.0.9d0)then + if(Amax_ACi(i).gt.0.0d0.and.Amax_ACi(i).lt.100.0d0)then + resistwp25_ini= + &resistwp25_ini*dmin1(20.0d0/Amax_ACi(i),3.0d0) + resistch25_ini= + &resistch25_ini*dmin1(20.0d0/Amax_ACi(i),2.0d0) + else + if(Amax_ACi(i).le.0.0d0)then + resistwp25_ini=6.0d0 + resistch25_ini=4.0d0 + endif + endif + endif +!almost a straightline +!determine the absolute last point of rubisco or rubp for an A/Ci curve + k=4 +10 if(n.le.k)goto 20 + if(ACianet_obs(n,i).gt.ACianet_obs(n-1,i).and. + &ACianet_obs(n-1,i).gt.ACianet_obs(n-2,i))goto 20 + do j=1,k + gvector(j)=ACipco2i(n-j+1,i) + fvector(j)=ACianet_obs(n-j+1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=a+bx + if(at.gt.0.0d0)goto 20 + n=n-1 + goto 10 +20 nendaci(i)=n + if(ACianet_obs(n,i).le.ACianet_obs(n-1,i).and. + &ACianet_obs(n-1,i).le.ACianet_obs(n-2,i))nendaci(i)=nendaci(i)-1 + n=nACiPoints(i)-nendaci(i) + if(n.ge.3)then + do j=1,n + gvector(j)=ACipco2i(nendaci(i)+j,i) + fvector(j)=ACianet_obs(nendaci(i)+j,i) + enddo + call y_aPLUSbx(n,gvector,fvector,ac,at) +!fit for y=a+bx + if(dabs(at).le.1.0d-5)idoalpha0=0 + endif +!Beyond nendaci, the points can only be limited by TPU +! +!Determine the point before which all points are limited by Rubisco and/or RuBP regeneration and after which some points might be +!limited by Rubisco and/or RuBP regeneration and/or TPU until nendaci after which all points are limited by TPU. + n=1 + aj=-1.0d+20 +22 if(n.ge.(nendaci(i)-3))goto 24 + do j=1,k + gvector(j)=ACipco2i(n+j-1,i) + fvector(j)=ACianet_obs(n+j-1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=a+bx + if(at.le.0.0d0)goto 24 + if(at.gt.aj)then + aj=at + else + if(at.lt.aj/5.0d0)goto 24 + endif + n=n+1 + goto 22 +24 nstartaci(i)=n-1 +! + n=nACiPoints(i) + if(n.ge.4)then + if(ACianet_obs(n,i).gt.ACianet_obs(n-1,i).and. + &ACianet_obs(n-1,i).gt.ACianet_obs(n-2,i).and. + &ACianet_obs(n-2,i).gt.ACianet_obs(n-3,i))then + nstartaci(i)=n-1 + nendaci(i)=n +!only the last point can be possibly tpu + endif + endif + if((nendaci(i)-nstartaci(i)).le.2)goto 29 +25 n=nstartaci(i) + if(ACianet_obs(n+1,i).gt.ACianet_obs(n,i))then +!if anet continues to increase, the point is not tpu limited + if((nendaci(i)-nstartaci(i)).gt.2)then + nstartaci(i)=n+1 + goto 25 + endif + else + nstartaci(i)=nstartaci(i)-1 + nstartaci(i)=max0(nstartaci(i),0) + endif +29 continue +!before nstartaci, no TPU points can occur + enddo +! + do i=1,numALightcurves + amaxave=0.0d0 + n=3 + do j=nALightPoints(i)-n+1,nALightPoints(i) + amaxave=amaxave+ALightanet_obs(j,i) + enddo + amaxave=amaxave/dble(n) +!the sigmoidal function has better asymptotic behaviour so +!it is used for estimating anetmaxs. + iderivative=1 + INFO=0 + beta(1)=dabs(amaxave) + if(amaxave.lt.0.0d0)then + betamin(1)=amaxave + else + betamin(1)=0.5d0*amaxave + endif + betamax(1)=200.0d0 + beta(2)=1.5d0 + betamin(2)=1.0d-5 + betamax(2)=1.0d+5 + beta(3)=0.1d0 + betamin(3)=0.0d0 + betamax(3)=5000.0d0 + beta(4)=30.0d0 + betamin(4)=-1000.0d0 + betamax(4)=1000.0d0 + beta(5)=-10.0d0 + betamin(5)=-100.0d0 + betamax(5)=100.0d0 + k=0 + do j=1,nALightPoints(i) + hvector(j)=ALightaPPFDlf(j,i)/abspt_lf_par + weitx(j)=1.0d0 + xmin(j)=dmax1(0.0d0,hvector(j)-20.0d0) + xmax(j)=hvector(j)+20.0d0 + weity(j)=1.0d0 + if(ALightchlflphips2(j,i).gt.0.0d0)then + k=k+1 + yvector(k)=ALightchlflphips2(j,i) + xvector(k)=hvector(j) + endif + enddo + call GenericRegres(nALightPoints(i),1, + &ALightanet_obs(1:nALightPoints(i),i:i),1,hvector(i),weity,weitx,5, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,starPAR(i),der_starPAR(i), + &Asat_ALight(i),ALightinter(i),der_ALightinter(i), + &hvector(nALightPoints(i)),der_ALightend(i),term, + &hvector(1),hvector(nALightPoints(i)),ALightmaxcurvature(i), + &ALightmaxcurvPAR(i)) + if(Asat_ALight(i).lt.50.0d0)amaxave=Asat_ALight(i) + j=min0(5,nALightPoints(i)) + call y_aPLUSbx(j,hvector(1:j),ALightanet_obs(1:j,i:i),ac,at) +!fit for y=ac+at*x + if(ac.lt.0.0d0.and.dabs(ac).lt.rdlight25max) + &rdlight25_ini=dabs(ac) + if(amaxave.gt.0.0d0)then + fjmax25_ini=(amaxave+rdlight25_ini)*4.0d0+10.0d0 + vcmax25_ini=fjmax25_ini/1.1d0 + tpu25_ini=(amaxave+rdlight25_ini)/3.0d0 + else + fjmax25_ini=10.0d0 + vcmax25_ini=fjmax25_ini/1.1d0 + tpu25_ini=1.0d0 + endif + if(k.ge.5)then + beta(1)=0.50d0 + betamin(1)=-1000.0d0 + betamax(1)=0.0d0 + beta(2)=5.50d0 + betamin(2)=0.0d0 + betamax(2)=1000.0d0 + beta(3)=1.50d0 + betamin(3)=-10.0d0 + betamax(3)=10.0d0 + do j=1,k + xmin(j)=dmax1(0.0d0,xvector(j)-20.0d0) + xmax(j)=xvector(j)+20.0d0 + enddo + call GenericRegres(k,1,yvector,1,xvector,weity,weitx,3, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(3,beta,term,term1,term2, + &PhiPSIIinter_ALight(i),der_PhiPSIIinter_ALight(i), + &1000.0d0,der_PhiPSII1000_ALight(i),ExcessLightFactor(i), + &xvector(1),xvector(k),PhiPSIImaxcurvature_ALight(i), + &PhiPSIImaxcurv_ALight(i)) + der_PhiPSIIinter_ALight(i)=der_PhiPSIIinter_ALight(i)*1000.0d0 + der_PhiPSII1000_ALight(i)=der_PhiPSII1000_ALight(i)*1000.0d0 + ExcessLightFactor(i)=1.0d0-ExcessLightFactor(i)/0.83d0 + else + PhiPSIIinter_ALight(i)=-9999.0d0 + der_PhiPSIIinter_ALight(i)=-9999.0d0 + der_PhiPSII1000_ALight(i)=-9999.0d0 + ExcessLightFactor(i)=-9999.0d0 + PhiPSIImaxcurvature_ALight(i)=-9999.0d0 + PhiPSIImaxcurv_ALight(i)=-9999.0d0 + endif +!determine the absolute last point of rubp for an A/Light curve + k=4 + n=nALightPoints(i) +30 if(n.le.k)goto 40 + if(ALightanet_obs(n,i).gt.ALightanet_obs(n-1,i).and. + &ALightanet_obs(n-1,i).gt.ALightanet_obs(n-2,i))goto 40 + do j=1,k + gvector(j)=ALightaPPFDlf(n-j+1,i) + fvector(j)=ALightanet_obs(n-j+1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=ac+at*x + if(at.gt.0.0d0)goto 40 + n=n-1 + goto 30 +40 nendalight(i)=n + if(ALightanet_obs(n,i).le.ALightanet_obs(n-1,i).and. + &ALightanet_obs(n-1,i).le.ALightanet_obs(n-2,i)) + &nendalight(i)=nendalight(i)-1 +!Beyond nendalight, the points can only be limited by Rubisco or TPU because they have constant or decreasing anet with inceased light +! +!Determine the point before which all points are limited by RuBP regeneration and after which some points might be limited by RuBP until +!nendalight. + n=1 + aj=-1.0d+20 +50 if(n.ge.(nendalight(i)-3))goto 55 + do j=1,k + gvector(j)=ALightaPPFDlf(n+j-1,i) + fvector(j)=ALightanet_obs(n+j-1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=ac+at*x + if(at.lt.1.0d-4)goto 55 + if(at.gt.aj)then + aj=at + else + if(at.lt.aj/5.0d0)goto 55 + endif + n=n+1 + goto 50 +55 if(n.ge.(nendalight(i)-1))then + n=nendalight(i)-1 + goto 56 + endif + if(ALightanet_obs(n,i).lt.ALightanet_obs(n+1,i))then + n=n+1 + goto 55 + endif +56 nstartalight(i)=n-1 +!before nstartalight, no rubisco or tpu points can occur because anet increases with increased light, indicating RuBP regeneration +!limitation +! + n=nALightPoints(i) + if(n.ge.4)then + if(ALightanet_obs(n,i).gt.ALightanet_obs(n-1,i).and. + &ALightanet_obs(n-1,i).gt.ALightanet_obs(n-2,i).and. + &ALightanet_obs(n-2,i).gt.ALightanet_obs(n-3,i))then + if(ALightpco2i(n,i).le.ALightpco2i(n-1,i).and. + &ALightpco2i(n-1,i).le.ALightpco2i(n-2,i).and. + &ALightpco2i(n-2,i).le.ALightpco2i(n-3,i))then + nstartalight(i)=n-1 + nendalight(i)=n +!only the last point can be possibly Rubico or TPU because anet continues to rise while Ci is constant or decreasing + endif + endif + endif + if((nendalight(i)-nstartalight(i)).le.2)goto 64 +62 n=nstartalight(i) + if(ALightanet_obs(n+1,i).gt.ALightanet_obs(n,i).and. + &ALightpco2i(n+1,i).le.ALightpco2i(n,i))then +!continue until we reach the point when anet does not increase while pco2i does not decrease, i,e, if anet continues +!to increase while pco2i continues to decrease, we assumue this point is still limited by rubp regeneration. + if((nendalight(i)-nstartalight(i)).gt.2)then + nstartalight(i)=n+1 + goto 62 + endif + else + nstartalight(i)=nstartalight(i)-1 + nstartalight(i)=max0(nstartalight(i),0) + endif +64 continue +!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), which is indicated by +!ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we assume a sequence of (RuBP, Rubisco and TPU), +!which is indicated by ialightorder=2. + ialightorder(i)=2 + do j=nstartalight(i)+1,nALightPoints(i) + if(ALightpco2i(j,i).lt.ALightpco2i(j-1,i))ialightorder(i)=0 + enddo + enddo +!------------------------------------------------------------------------------------ +!Merge Fixed points, ACi points, ALight points, and Free points into single arrays. Do not change this order. + ntotsamples=0 + do i=1,nFixedPoints + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=Fixedanet_obs(i) + pco2i(ntotsamples)=Fixedpco2i(i) + templeaf(ntotsamples)=Fixedtempleaf(i) + aPPFDlf(ntotsamples)=FixedaPPFDlf(i) + pres_air(ntotsamples)=Fixedpres_air(i) + po2i(ntotsamples)=Fixedpo2i(i) + chlflphips2(ntotsamples)=Fixedchlflphips2(i) + pco2ambient(ntotsamples)=Fixedpco2ambient(i) + trmmol(ntotsamples)=Fixedtrmmol(i) + gswmeas(ntotsamples)=Fixedgswmeas(i) + vpdl(ntotsamples)=Fixedvpdl(i) + tempair(ntotsamples)=Fixedtempair(i) + eambient(ntotsamples)=Fixedeambient(i) +! + fo_pam(ntotsamples)=Fixedfo_pam(i) + fm_pam(ntotsamples)=Fixedfm_pam(i) + fs_pam(ntotsamples)=Fixedfs_pam(i) + pam_measlight(ntotsamples)=Fixedpam_measlight(i) + yield_ps2(ntotsamples)=Fixedyield_ps2(i) + yield_npq(ntotsamples)=Fixedyield_npq(i) + qlake(ntotsamples)=Fixedqlake(i) + qpuddle(ntotsamples)=Fixedqpuddle(i) + kps2_norm(ntotsamples)=Fixedkps2_norm(i) + knpq_norm(ntotsamples)=Fixedknpq_norm(i) +! + resiststomco2(ntotsamples)=Fixedresiststomco2(i) + enddo + do i=1,numACicurves + ACiavetempleaf(i)=0.0d0 + ACiaveaPPFDlf(i)=0.0d0 + ACiavepo2i(i)=0.0d0 + ACiavepres_air(i)=0.0d0 + do j=1,nACiPoints(i) + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=ACianet_obs(j,i) + pco2i(ntotsamples)=ACipco2i(j,i) + templeaf(ntotsamples)=ACitempleaf(j,i) + aPPFDlf(ntotsamples)=ACiaPPFDlf(j,i) + pres_air(ntotsamples)=ACipres_air(j,i) + po2i(ntotsamples)=ACipo2i(j,i) + chlflphips2(ntotsamples)=ACichlflphips2(j,i) + pco2ambient(ntotsamples)=ACipco2ambient(j,i) + trmmol(ntotsamples)=ACitrmmol(j,i) + gswmeas(ntotsamples)=ACigswmeas(j,i) + vpdl(ntotsamples)=ACivpdl(j,i) + tempair(ntotsamples)=ACitempair(j,i) + eambient(ntotsamples)=ACieambient(j,i) +! + fo_pam(ntotsamples)=ACifo_pam(j,i) + fm_pam(ntotsamples)=ACifm_pam(j,i) + fs_pam(ntotsamples)=ACifs_pam(j,i) + pam_measlight(ntotsamples)=ACipam_measlight(j,i) + yield_ps2(ntotsamples)=ACiyield_ps2(j,i) + yield_npq(ntotsamples)=ACiyield_npq(j,i) + qlake(ntotsamples)=ACiqlake(j,i) + qpuddle(ntotsamples)=ACiqpuddle(j,i) + kps2_norm(ntotsamples)=ACikps2_norm(j,i) + knpq_norm(ntotsamples)=ACiknpq_norm(j,i) +! + resiststomco2(ntotsamples)=ACiresiststomco2(j,i) + ACiavetempleaf(i)=ACiavetempleaf(i)+ACitempleaf(j,i) + ACiaveaPPFDlf(i)=ACiaveaPPFDlf(i)+ACiaPPFDlf(j,i) + ACiavepo2i(i)=ACiavepo2i(i)+ACipo2i(j,i) + ACiavepres_air(i)=ACiavepres_air(i)+ACipres_air(j,i) + enddo + ACiavetempleaf(i)=ACiavetempleaf(i)/dble(nACiPoints(i)) + ACiaveaPPFDlf(i)=ACiaveaPPFDlf(i)/dble(nACiPoints(i)) + ACiavepo2i(i)=ACiavepo2i(i)/dble(nACiPoints(i)) + ACiavepres_air(i)=ACiavepres_air(i)/dble(nACiPoints(i)) + enddo + do i=1,numALightcurves + ALightavetempleaf(i)=0.0d0 + ALightaveCO2ambient(i)=0.0d0 + ALightavepo2i(i)=0.0d0 + do j=1,nALightPoints(i) + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=ALightanet_obs(j,i) + pco2i(ntotsamples)=ALightpco2i(j,i) + templeaf(ntotsamples)=ALighttempleaf(j,i) + aPPFDlf(ntotsamples)=ALightaPPFDlf(j,i) + pres_air(ntotsamples)=ALightpres_air(j,i) + po2i(ntotsamples)=ALightpo2i(j,i) + chlflphips2(ntotsamples)=ALightchlflphips2(j,i) + pco2ambient(ntotsamples)=ALightpco2ambient(j,i) + trmmol(ntotsamples)=ALighttrmmol(j,i) + gswmeas(ntotsamples)=ALightgswmeas(j,i) + vpdl(ntotsamples)=ALightvpdl(j,i) + tempair(ntotsamples)=ALighttempair(j,i) + eambient(ntotsamples)=ALighteambient(j,i) +! + fo_pam(ntotsamples)=ALightfo_pam(j,i) + fm_pam(ntotsamples)=ALightfm_pam(j,i) + fs_pam(ntotsamples)=ALightfs_pam(j,i) + pam_measlight(ntotsamples)=ALightpam_measlight(j,i) + yield_ps2(ntotsamples)=ALightyield_ps2(j,i) + yield_npq(ntotsamples)=ALightyield_npq(j,i) + qlake(ntotsamples)=ALightqlake(j,i) + qpuddle(ntotsamples)=ALightqpuddle(j,i) + kps2_norm(ntotsamples)=ALightkps2_norm(j,i) + knpq_norm(ntotsamples)=ALightknpq_norm(j,i) +! + resiststomco2(ntotsamples)=ALightresiststomco2(j,i) + ALightavetempleaf(i)=ALightavetempleaf(i)+ALighttempleaf(j,i) + ALightaveCO2ambient(i)=ALightaveCO2ambient(i)+ + &ALightpco2ambient(j,i) + ALightavepo2i(i)=ALightavepo2i(i)+ALightpo2i(j,i) + enddo + ALightavetempleaf(i)=ALightavetempleaf(i)/dble(nALightPoints(i)) + ALightaveCO2ambient(i)=ALightaveCO2ambient(i)/ + &dble(nALightPoints(i)) + ALightavepo2i(i)=ALightavepo2i(i)/dble(nALightPoints(i)) + enddo + do i=1,nFreePoints + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=Freeanet_obs(i) + pco2i(ntotsamples)=Freepco2i(i) + templeaf(ntotsamples)=Freetempleaf(i) + aPPFDlf(ntotsamples)=FreeaPPFDlf(i) + pres_air(ntotsamples)=Freepres_air(i) + po2i(ntotsamples)=Freepo2i(i) + chlflphips2(ntotsamples)=Freechlflphips2(i) + pco2ambient(ntotsamples)=Freepco2ambient(i) + trmmol(ntotsamples)=Freetrmmol(i) + gswmeas(ntotsamples)=Freegswmeas(i) + vpdl(ntotsamples)=Freevpdl(i) + tempair(ntotsamples)=Freetempair(i) + eambient(ntotsamples)=Freeeambient(i) +! + fo_pam(ntotsamples)=Freefo_pam(i) + fm_pam(ntotsamples)=Freefm_pam(i) + fs_pam(ntotsamples)=Freefs_pam(i) + pam_measlight(ntotsamples)=Freepam_measlight(i) + yield_ps2(ntotsamples)=Freeyield_ps2(i) + yield_npq(ntotsamples)=Freeyield_npq(i) + qlake(ntotsamples)=Freeqlake(i) + qpuddle(ntotsamples)=Freeqpuddle(i) + kps2_norm(ntotsamples)=Freekps2_norm(i) + knpq_norm(ntotsamples)=Freeknpq_norm(i) +! + resiststomco2(ntotsamples)=Freeresiststomco2(i) + enddo + ntotphips2=0 + term1=1.0d+99 + term2=-1.0d+99 + do i=1,ntotsamples + pco2i_ori(i)=pco2i(i) + templeaf_ori(i)=templeaf(i) + if(templeaf(i).lt.term1)term1=templeaf(i) + if(templeaf(i).gt.term2)term2=templeaf(i) + aPPFDlf_ori(i)=aPPFDlf(i) + pres_air_ori(i)=pres_air(i) + po2i_ori(i)=po2i(i) + chlflphips2_ori(i)=chlflphips2(i) + pco2ambient_ori(i)=pco2ambient(i) + trmmol_ori(i)=trmmol(i) + gswmeas_ori(i)=gswmeas(i) + vpdl_ori(i)=vpdl(i) + tempair_ori(i)=tempair(i) + eambient_ori(i)=eambient(i) + resiststomco2_ori(i)=resiststomco2(i) + if(chlflphips2_ori(i).gt.0.0d0)then + ntotphips2=ntotphips2+1 + endif + enddo + idotempcoeff=0 + if((term2-term1).gt.2.0d0)idotempcoeff=1 +!If temperature variation in the dataset is larger enough, try to estimate parameters in temperature response functions +!All variables are now in the right order. All ACi curves are ordered and All ALight curves are ordered. +!------------------------------------------------------------------------------------------------------- +! + do i=1,ntotsamples + anet_pred(i)=-9999.0d0 + pco2i_pred(i)=-9999.0d0 + pco2c(i)=-9999.0d0 + anet_pred_flu(i)=-9999.0d0 + pco2i_pred_flu(i)=-9999.0d0 + pco2c_anet_flu(i)=-9999.0d0 + pco2c_pco2i_flu(i)=-9999.0d0 + enddo + + if(ntotphips2.gt.5)then + do idorch=1,1 +!we do a fluorescence only fit + Prioriknowlimit=-1 + ifitmode=1 +!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet +!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i +!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i +!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet + idorwp=1 + resistwp25_ori=resistwp25_ini + if(idorch.eq.1)then + resistch25_ori=resistch25_ini + else + resistch25_ori=0.0d0 + endif + if(rdlight25_usr.le.0.0d0)then + idord=1 + rdlight25_ori=rdlight25_ini + else + idord=0 + rdlight25_ori=rdlight25_usr + endif + idostargamma=1 + idobetaPSII=1 + idoha_darkresp=idotempcoeff + idoha_stargamma=idotempcoeff + idoha_gmeso=idotempcoeff + stargamma25_ori=stargamma25_ini + betaPSII_ori=betaPSII_ini + fjmax25_ori=fjmax25_ini + phifactor_ori=phifactor_ini + thetafactor_ori=thetafactor_ini + ha_darkresp_ori=ha_darkresp_ini + ha_stargamma_ori=ha_stargamma_ini + ha_gmeso_ori=ha_gmeso_ini + ha_jmax_ori=ha_jmax_ini + call HybridCombinatorial() + do j=1,ntotsamples + call gmesoontemp(templeaf(j),1.0d0,gascon,ha_gmeso, + &hd_gmeso,sv_gmeso,term) + resistwp=resistwp25/term + resistch=resistch25/term + call resp_mitocho(templeaf(j),rdlight25,ha_darkresp, + &gascon,rdlight) + call co2compens(templeaf(j),stargamma25, + &ha_stargamma,gascon,stargamma) + write(fluorescenceunit,370)trim(curvename),pco2i_ori(j), + &pco2i_pred(j),pco2c(j),anet_obs(j),anet_pred(j), + &pco2ambient_ori(j),po2i_ori(j)/1000.0d0,eambient_ori(j)/1000.0d0, + &pres_air_ori(j)/1000.0d0,vpdl_ori(j)/1000.0d0, + &aPPFDlf(j)/abspt_lf_par,templeaf_ori(j)-273.15d0, + &tempair_ori(j)-273.15d0,trmmol_ori(j),gswmeas_ori(j), + &chlflphips2_ori(j),rdlight25,resistwp25,resistch25, + &stargamma25,betaPSII,sumsquare,ha_darkresp,resistwp,resistch, + &ha_stargamma,fo_pam(j),fm_pam(j),fs_pam(j),pam_measlight(j), + &yield_ps2(j),yield_npq(j),qlake(j),qpuddle(j),kps2_norm(j), + &knpq_norm(j) + enddo + if(idorch.eq.0)then + fvector(1)=rdlight25 + fvector(2)=resistwp25 + fvector(3)=stargamma25 + fvector(4)=betaPSII + endif + enddo + if(ntotlights.gt.0)then +!Jmax estimation with fluorescence data. +!Only points before nstartalight are used because these points are apparently limited by RuBP regeneration and therefore +!the electron transport equation applies. ntotlights is the number of points that are clearly limited by RuBP regeneration. + modeltype(0)='PARi' + modeltype(1)='TempLeaf' + modeltype(2)='PhiPSII_obs' + modeltype(3)='PhiPSII_pred' + modeltype(4)='Jmax25' + modeltype(5)='phifactor' + modeltype(6)='thetafactor' + modeltype(7)='ha_jmax' + modeltype(8)='SumSquare' + write(fluorescenceunit,305)(trim(modeltype(j)),j=0,8) + do j=1,ntotlights + write(fluorescenceunit,306)aparlights(j)/abspt_lf_par, + &templflights(j)-273.15d0,flphips2lights(j),PhiPSIIlights_pred(j), + &fjmax25,phifactor,thetafactor,ha_jmax,flujmaxfval + enddo + else + fjmax25=-9999.0d0 + phifactor=-9999.0d0 + thetafactor=-9999.0d0 + flujmaxfval=-9999.0d0 + endif + term=tempK_dark-273.15d0 + if(term.lt.-10000.0d0)term=-9999.0d0 + write(fluoresparamunit,380)trim(curvename),fjmax25,rdlight25, + &fvector(1),resistwp25,fvector(2),resistch25,stargamma25, + &fvector(3),phifactor,thetafactor,betaPSII,fvector(4),fo_dark, + &fm_dark,resp_dark,term,sumsquare,flujmaxfval + endif +!---------------------------------------------------------------- + idophifactor=0 + idothetafactor=0 + idobetaPSII=0 + ifitmode=-1 +!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet +!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i +!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i +!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet + if(numALightcurves.ge.1)then + idophifactor=1 + idothetafactor=1 + endif + if(ntotphips2.ge.2)idobetaPSII=1 + modeltype(0)='NoSuitModel' + modeltype(1)='RubiscoRuBpTpu' + modeltype(2)='RubiscoRuBp' + modeltype(3)='RubiscoTpu' + modeltype(4)='RuBpTpu' + modeltype(5)='Rubisco' + modeltype(6)='RuBp' + modeltype(7)='Tpu' + fourchars(1)='CO2i' + fourchars(2)='CO2cc' + fourchars(3)='Ac' + fourchars(4)='CO2cj' + fourchars(5)='Aj' + fourchars(6)='CO2ct' + fourchars(7)='At' + do k=1,4 + do j=1,ntotsamples + co2c_Pa(k,j)=-9999.0d0 + recycleratio(k,j)=-9999.0d0 + recycleratio(5,j)=-9999.0d0 + recycleratio(6,j)=-9999.0d0 + enddo + enddo + if(rdlight25_usr.gt.0.0d0)then + idord=0 + rdlight25_ori=rdlight25_usr + else + idord=1 + rdlight25_ori=rdlight25_ini + endif + vcmax25_ori=vcmax25_ini + c4kp25_ori=20000.0d0*vcmax25_ini + c4aparslope_ori=0.05d0 +!------------------------------------------------------------------- + call C4PhotoFit() +!------------------------------------------------------------------- + idomeso=-9999 + idohavjt=-9999 + idostargamma=-9999 + idokc=-9999 + idoko=-9999 + idoalpha=-9999 + idobetaPSII=-9999 + do j=1,ntotsamples + pco2i_pred(j)=pco2i_ori(j) + pco2c(j)=pco2i_ori(j) + bestiphotolimit(j)=Postiphotolimit(j) + recycleratio(1,j)=-9999.0d0 + PhiPSII_pred(j)=-9999.0d0 + pco2i_pred_flu(j)=-9999.0d0 + anet_pred_flu(j)=-9999.0d0 + pco2c_pco2i_flu(j)=-9999.0d0 + pco2c_anet_flu(j)=-9999.0d0 + write(compareunit,300)trim(curvename),idomeso,idohavjt, + &idostargamma,idokc,idoko,idord,idoalpha,idobetaPSII, + &pco2i_ori(j),pco2i_pred(j),pco2c(j),anet_obs(j),anet_pred(j), + &bestiphotolimit(j),recycleratio(1,j),pco2ambient_ori(j), + &po2i_ori(j)/1000.0d0,eambient_ori(j)/1000.0d0, + &pres_air_ori(j)/1000.0d0,vpdl_ori(j)/1000.0d0, + &aPPFDlf(j)/abspt_lf_par,templeaf_ori(j)-273.15d0, + &tempair_ori(j)-273.15d0,trmmol_ori(j),gswmeas_ori(j), + &chlflphips2_ori(j),PhiPSII_pred(j),pco2i_pred_flu(j), + &anet_pred_flu(j),pco2c_pco2i_flu(j),pco2c_anet_flu(j) + enddo +!Generate mono-limiting curves + k=nFixedPoints + do i=1,numACicurves + n=k+nACiPoints(i) + j=n-k + call ilimittypestats(j,bestiphotolimit(k+1:n), + &Currentilimittype,numrubis,numrubp,numtpu) + write(compareunit,310)(trim(fourchars(j)),j=1,7) + co2imany(1)=1.0d0 + co2imany(2)=2.0d0 + co2imany(3)=3.0d0 + co2imany(4)=4.0d0 + co2imany(5)=5.0d0 + co2imany(6)=6.0d0 + m=6 + term=ACipco2i(nACiPoints(i),i)+10.0d0 + do while (co2imany(m).le.term) + m=m+1 + co2imany(m)=co2imany(m-1)+2.5d0 + enddo + do j=1,m + ccc=co2imany(j) + ccj=co2imany(j) + cct=co2imany(j) + Currentilimittype=5 + call c4leafanetmodel(Currentilimittype,ACiaveaPPFDlf(i), + &ACiavetempleaf(i),co2imany(j),ACiavepres_air(i),vcmax25, + &c4aparslope,c4kp25,rdlight25,ac,bestilimittype) + Currentilimittype=6 + call c4leafanetmodel(Currentilimittype,ACiaveaPPFDlf(i), + &ACiavetempleaf(i),co2imany(j),ACiavepres_air(i),vcmax25, + &c4aparslope,c4kp25,rdlight25,aj,bestilimittype) + Currentilimittype=7 + call c4leafanetmodel(Currentilimittype,ACiaveaPPFDlf(i), + &ACiavetempleaf(i),co2imany(j),ACiavepres_air(i),vcmax25, + &c4aparslope,c4kp25,rdlight25,at,bestilimittype) + write(compareunit,320)co2imany(j),ccc,ac,ccj,aj,cct,at + k=n + enddo + enddo + write(compareunit,*) +!------------------------------------------------------------------------------ + bestilimittype=1 + write(paramunit,330)trim(curvename), + &trim(modeltype(bestilimittype)),vcmax25,c4aparslope,c4kp25, + &rdlight25,bestnumrubis,bestnumrubp,bestnumtpu,ntotsamples, + &bestsumsquare, + &trim(siteID),Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,trim(species),avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,trim(woodporosity),sapwooddensity,leafratio + if(numACicurves.gt.0)then + do i=1,numACicurves + write(aciempfitunit,390)trim(curvename),i,starco2i(i), + &der_starco2i(i),Amax_ACi(i),ACiinter(i),der_ACiinter(i), + &der_ACiend(i),PhiPSIImax_ACi(i),PhiPSIIinter_ACi(i), + &der_PhiPSIIinter_ACi(i),der_PhiPSIIend_ACi(i), + &ACimaxcurvature(i),ACimaxcurvpco2i(i), + &PhiPSIImaxcurvature_ACi(i),PhiPSIImaxcurv_ACi(i), + &starco2a(i),der_starco2a(i),Amax_ACa(i),ACainter(i), + &der_ACainter(i),der_ACa400ppm(i),anet_ACa400ppm(i), + &PhiPSIImax_ACa(i),PhiPSIIinter_ACa(i),der_PhiPSIIinter_ACa(i), + &der_PhiPSIIend_ACa(i),ACamaxcurvature(i),ACamaxcurvpco2a(i), + &PhiPSIImaxcurvature_ACa(i),PhiPSIImaxcurv_ACa(i),ACiavetempleaf(i) + &-273.15d0,ACiaveaPPFDlf(i)/abspt_lf_par,ACiavepo2i(i), + &trim(siteID),Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,trim(species),avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,trim(woodporosity),sapwooddensity,leafratio + enddo + endif + if(numALightcurves.gt.0)then + do i=1,numALightcurves + write(alightempfitunit,360)trim(curvename),i,starPAR(i), + &der_starPAR(i),Asat_ALight(i),ALightinter(i),der_ALightinter(i), + &der_ALightend(i),PhiPSIIinter_ALight(i), + &der_PhiPSIIinter_ALight(i),ExcessLightFactor(i), + &der_PhiPSII1000_ALight(i),ALightmaxcurvature(i), + &ALightmaxcurvPAR(i),PhiPSIImaxcurvature_ALight(i), + &PhiPSIImaxcurv_ALight(i),ALightavetempleaf(i)-273.15d0, + &ALightaveCO2ambient(i),ALightavepo2i(i), + &trim(siteID),Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,trim(species),avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,trim(woodporosity),sapwooddensity,leafratio + enddo + endif + return +300 format(a,',',8(i0,','),5(f0.6,','),i0,',',16(f0.6,','),f0.6) +305 format(8(a,','),a) +306 format(8(f0.6,','),f0.6) +310 format(6(a,','),a) +320 format(6(f0.6,','),f0.6) +330 format(2(a,','),4(f0.6,','),4(i0,','),f0.6,',',a,',',10(f0.6,','), + &a,',',8(f0.6,','),a,',',f0.6,',',f0.6) +360 format(a,',',i0,',',17(f0.6,','),a,',',10(f0.6,','),a,',', + &8(f0.6,','),a,',',f0.6,',',f0.6) +370 format(a,',',35(f0.6,','),f0.6) +380 format(a,',',17(f0.6,','),f0.6) +390 format(a,',',i0,',',32(f0.6,','),a,',', + &10(f0.6,','),a,',',8(f0.6,','),a,',',f0.6,',',f0.6) + end subroutine C4SetUpLeafGasFit diff --git a/leafres/testarea/HybridCombinatorial.f b/leafres/testarea/HybridCombinatorial.f index bace95a..8cf8e76 100644 --- a/leafres/testarea/HybridCombinatorial.f +++ b/leafres/testarea/HybridCombinatorial.f @@ -233,7 +233,7 @@ 2001 continue enddo -! goto 1000 + goto 1000 gacontrol(1)=200.0d0 gacontrol(2)=2000.0d0 diff --git a/leafres/testarea/LeafGasFit_Stom.f b/leafres/testarea/LeafGasFit_Stom.f index fe3d03e..027c37d 100644 --- a/leafres/testarea/LeafGasFit_Stom.f +++ b/leafres/testarea/LeafGasFit_Stom.f @@ -596,8 +596,8 @@ do j=1,npoints write(unitwuecicacomp,380)curveno,trim(curvename),co2a_ppm(j), &vpdl(j),wue(j),wuemod(j),cicameas(j),cicamod(j),wue_intrin(j), - &wue_intrinmod(j),((cccimeas(k,j),cccimod(k,j)),k=1,4), - &((co2recycleratio(k,j),recycmod(k,j)),k=1,6) + &wue_intrinmod(j),(cccimeas(k,j),cccimod(k,j),k=1,4), + &(co2recycleratio(k,j),recycmod(k,j),k=1,6) enddo write(unitparamsout,390)curveno,trim(curvename),npoints_stom, &co2threshold,co2current,vpdl_ref,ballintersurf,ballslopesurf, @@ -608,10 +608,10 @@ &dewarrsqgsw,wueref,der_wueref,rsqwue,(alfit(i),i=1,5), &wueref_intrin,der_wueref_intrin,rsqwue_intrin,(blfit(i),i=1,5), &cicaref,der_cicaref,rsqcica,(cicafit(i),i=1,5), - &avetleaf,avetair,avevpdl,avepari,((ccciref(i),der_ccciref(i), - &rsqccci(i),(cccifit(i,j),j=1,6)),i=1,4), - &((recycref(i),der_recycref(i), - &rsqrecyc(i),(recycfit(i,j),j=1,5)),i=1,6), + &avetleaf,avetair,avevpdl,avepari,(ccciref(i),der_ccciref(i), + &rsqccci(i),(cccifit(i,j),j=1,6),i=1,4), + &(recycref(i),der_recycref(i), + &rsqrecyc(i),(recycfit(i,j),j=1,5),i=1,6), ! &trim(siteID),Latitude,Longitude,Elevation,yearsampled, &sampledoy,GrowingSeasonStart,GrowingSeasonEnd, diff --git a/leafres/testarea/LeafGasPISCAL_mpi.f b/leafres/testarea/LeafGasPISCAL_mpi.f index fdcb914..e727e21 100644 --- a/leafres/testarea/LeafGasPISCAL_mpi.f +++ b/leafres/testarea/LeafGasPISCAL_mpi.f @@ -17,7 +17,7 @@ integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2, &ntotfiles,noutputfiles,i,j,k,rank_mpi,numproc_mpi,numproc, &ierror_mpi,nshare,nmod,npartfiles,istartno,iendno,indexunit(20), - &numchar,needheader(20),rootprocess + &numchar,needheader(20),rootprocess,ic3c4cam character rundate*8,runtime*10,runzone*5,longchar*5000,achar*5, &longchar1*5000 character*100 datapath,outpath,storein,storeout,ACidata(8000) @@ -26,12 +26,13 @@ ! Set input / output directory parameter( & datapath= + &'../input/', ! &'/home/l2g/ngeetropics/gamboa/curves/', ! &'/home/l2g/ngeetropics/metropolitano/curves/', ! &'/home/l2g/ngeetropics/fortsherman/curves/', ! & '/home/l2g/ngeetropics/kelsey/curves/', ! & '/home/l2g/leafres/hybriddata/Berner/', - & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', ! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/', ! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/', @@ -61,12 +62,13 @@ ! & '/home/l2g/dataassim/leaf/data/dweston/inputs/', ! & '/home/l2g/GEMSiS/curves/', & outpath= + &'../output/fitresult/touser/', ! &'/home/l2g/ngeetropics/gamboa/results/', ! &'/home/l2g/ngeetropics/metropolitano/results/', ! &'/home/l2g/ngeetropics/fortsherman/', ! &'/home/l2g/ngeetropics/kelsey/results/', ! & '/home/l2g/leafres/hybriddata/Berner/', - & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', ! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/', ! &'/home/l2g/leafres/hybriddata/cernusak/2014data/', ! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/', @@ -100,23 +102,50 @@ ! &storein='/home/l2g/leafweb/users/curves/', ! &storeout='/home/l2g/leafweb/users/results/', - &storein='/home/l2g/clm/results/', - &storeout='/home/l2g/clm/results/', + &storein='../output/clninput/', + &storeout='../output/fitresult/nottouser/', + ! &storein='/home/l2g/junk/', ! &storeout='/home/l2g/junk/', ! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', ! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', - & AllACiFiles='AllLeafGasFiles') + & AllACiFiles='../piscal.cfg') !---------------End of variable declaration---------------- rootprocess=0 dataunit=1 spareunit=3 ! if(rank_mpi.ne.rootprocess)goto 25 !read A/Ci curve names stored in AllACiFiles - open(unit=2,file=trim(datapath)//trim(AllACiFiles)) + open(unit=2,file=trim(AllACiFiles)) ntotfiles=1 + ic3c4cam=-9999 10 read(2,fmt=300,end=20)longchar + if(longchar.eq.''.or.longchar.eq.' ')goto 10 + if(ntotfiles.eq.1.and.ic3c4cam.lt.0)then + i=0 + if(index(longchar,'_photosynthesis_leafweb').gt.0)then + i=index(longchar,'c3')+index(longchar,'C3') + if(i.gt.0)then + ic3c4cam=1 + else + i=index(longchar,'c4')+index(longchar,'C4') + if(i.gt.0)then + ic3c4cam=2 + else + i=index(longchar,'cam')+index(longchar,'caM')+ + &index(longchar,'cAm')+index(longchar,'cAM')+ + &index(longchar,'Cam')+index(longchar,'CaM')+ + &index(longchar,'CAm')+index(longchar,'CAM') + if(i.gt.0)ic3c4cam=3 + endif + endif + endif + if(i.gt.0)goto 10 +!if no indication is provided, c3 photosynthesis is assumed and the first line +!contains the name of the first data file + ic3c4cam=1 + endif i=len(longchar) j=0 15 j=j+1 @@ -153,6 +182,9 @@ noutputfiles=11 !10 to 20 are used for file units for output files do i=1,noutputfiles + if(ic3c4cam.eq.1)outputfile(i)='C3_'//outputfile(i) + if(ic3c4cam.eq.2)outputfile(i)='C4_'//outputfile(i) + if(ic3c4cam.eq.3)outputfile(i)='CAM_'//outputfile(i) indexunit(i)=i+9 enddo call MPI_INIT(ierror_mpi) @@ -190,82 +222,16 @@ numchar=numchar+1 goto 30 40 call NumberToChar(rank_mpi,numchar,achar) - do i=1,noutputfiles-1 + do i=1,noutputfiles open(unit=indexunit(i), &file=trim(outpath)//trim(outputfile(i))//trim(achar)) enddo - call ToLeafGasOptimization(npartfiles,ACidata(istartno:iendno), - &dataunit,spareunit,datapath,indexunit,ierr) - do i=1,noutputfiles-1 + call ToLeafGasOptimization(ic3c4cam,npartfiles, + &ACidata(istartno:iendno),dataunit,spareunit,datapath,indexunit, + &ierr) + do i=1,noutputfiles close(indexunit(i)) enddo - if(ierr(1).ne.0)then - i=indexunit(noutputfiles) - open(unit=i, - &file=trim(outpath)//trim(outputfile(noutputfiles))//trim(achar)) - write(i,*)'Input data error in ',ACidata(ierr(2)+istartno-1) - write(i,*) - &'Please resubmit the data after correcting the following error:' - if(ierr(1).eq.1)then - write(i,*)'Photosynthesis (umol/m2/s) out of range' - endif - if(ierr(1).eq.2)then - write(i,*)'Intercellular CO2(ppm) out of range' - endif - if(ierr(1).eq.3)then - write(i,*)'Leaf temperature (oC) out of range' - endif - if(ierr(1).eq.4)then - write(i,*)'Chamber PAR (umol/m2/s) out of range' - endif - if(ierr(1).eq.5)then - write(i,*)'Atmospheric pressure (Pa) out of range' - endif - if(ierr(1).eq.13)then - write(i,*)'Check line 13 for data entry error' - endif - if(ierr(1).eq.14)then - write(i,*)'Specified chloroplastic CO2 compensation point', - &'(Pa) out of range' - endif - if(ierr(1).eq.15)then - write(i,*)'Specified Michaelis-Menten constant for the', - &'carboxylase (Kc) out of range' - endif - if(ierr(1).eq.16)then - write(i,*)'Specified Michaelis-Menten constant for the', - &'oxygenase (Ko) out of range' - endif - if(ierr(1).eq.17)then - write(i,*)'Specified fraction of nonreturned glycolate', - &'carbon(alpha) out of range 0~1' - endif - if(ierr(1).eq.18)then - write(i,*)'Specified dark respiration rate Rd out of range >0' - endif - if(ierr(1).eq.19)then - write(i,*)'Specified mesophyll) resistance rch or rwp out of', - &'of range >0' - endif - if(ierr(1).eq.34)then - write(i,*)'Check Column 33 or 34. Mixing area- and mass-based - &measurements is not allowed' - endif - if(ierr(1).eq.36)then - write(i,*)'Check line 16 for data entry error' - endif - if(ierr(1).eq.39)then - write(i,*) - &'Check the main body of data for data entry error, starting from - &line 19' - endif - if(ierr(1).eq.40)then - write(i,*) - &'Data file format cannot be recognized' - endif - - close(i) - endif !make sure everyone is done before wrapping up. 45 call MPI_BARRIER(MPI_COMM_WORLD,ierror_mpi) if(rank_mpi.eq.rootprocess)then @@ -326,29 +292,41 @@ enddo !---------------------------------------------------------- !intercept the data - goto 450 -399 call date_and_time(rundate,runtime,runzone,runvalues) + if(needheader(noutputfiles).eq.2)then +!if there is error in any input files, donot store the data + do i=1,ntotfiles + open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i))) + close(1,status='delete') + enddo + goto 450 + endif + call date_and_time(rundate,runtime,runzone,runvalues) do i=1,ntotfiles - open(unit=1,file=trim(datapath)//trim(ACidata(i))) + open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i))) open(unit=2,file= - &trim(storein)//rundate//runtime(1:6)//trim(ACidata(i))) + &trim(storein)//rundate//runtime(1:6)//'clean'//trim(ACidata(i))) 400 read(1,fmt=300,end=410)longchar write(2,310)trim(longchar) goto 400 -410 close(1) +410 close(1,status='delete') close(2) enddo - do i=1,6 + do i=1,noutputfiles k=0 open(unit=1,file=trim(outpath)//trim(outputfile(i))) - open(unit=2,file= + if(i.ge.3.and.i.le.5)then + open(unit=2,file= &trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i))) + else + open(unit=2,file= + &trim(outpath)//rundate//runtime(1:6)//trim(outputfile(i))) + endif 420 read(1,fmt=300,end=430)longchar write(2,310)trim(longchar) k=1 goto 420 430 if(k.eq.1)then - close(1) + close(1,status='delete') close(2) else close(1,status='delete') diff --git a/leafres/testarea/LeafGasPISCAL_single.f b/leafres/testarea/LeafGasPISCAL_single.f index 2e7e069..a182052 100644 --- a/leafres/testarea/LeafGasPISCAL_single.f +++ b/leafres/testarea/LeafGasPISCAL_single.f @@ -15,7 +15,7 @@ program main implicit none integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2, - &ntotfiles,noutputfiles,i,j,k,indexunit(20) + &ntotfiles,noutputfiles,i,j,k,indexunit(20),ic3c4cam character rundate*8,runtime*10,runzone*5,longchar*5000 character*100 datapath,outpath,storein,storeout, &ACidata(8000) @@ -23,11 +23,14 @@ ! Set input / output directory parameter(datapath= +! &'../input/', + &'/home/l2g/jimei/', ! &'/home/l2g/ngeetropics/gamboa/curves/', ! &'/home/l2g/ngeetropics/metropolitano/curves/', ! &'/home/l2g/ngeetropics/fortsherman/curves/', ! &'/home/l2g/ngeetropics/kelsey/curves/', - & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! &'/home/l2g/leafres/hybriddata/nicksmith/data/', ! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/', ! &'/home/l2g/leafres/hybriddata/cernusak/2014data/', ! &'/home/l2g/leafres/hybriddata/hanjimei/', @@ -59,6 +62,8 @@ ! & '/home/l2g/dataassim/leaf/data/dweston/inputs/', ! & '/home/l2g/GEMSiS/curves/', & outpath= +! &'../output/fitresult/touser/', + &'/home/l2g/jimei/', ! &'/home/l2g/ngeetropics/gamboa/results/', ! &'/home/l2g/ngeetropics/metropolitano/results/', ! &'/home/l2g/ngeetropics/fortsherman/results/', @@ -69,7 +74,9 @@ ! &'/home/l2g/leafres/hybriddata/hanjimei/', ! ! & '/home/l2g/leafres/hybriddata/Berner/', - & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! & '/home/l2g/leafres/hybriddata/nicksmith/results/', + ! & '/home/l2g/leafres/hybriddata/huidafeng/', ! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/ ! &', @@ -99,43 +106,28 @@ ! &storein='/home/l2g/leafweb/users/curves/', ! &storeout='/home/l2g/leafweb/users/results/', - &storein='/home/l2g/leafres/testdata/', - &storeout='/home/l2g/leafres/testdata/', -! &storein='/home/l2g/junk/', -! &storeout='/home/l2g/junk/', +! &storein='../output/clninput/', +! &storeout='../output/fitresult/nottouser/', + + &storein='/home/l2g/jimei/', + &storeout='/home/l2g/jimei/', ! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', ! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', - & AllACiFiles='AllLeafGasFiles') +! & AllACiFiles='../piscal.cfg') + &AllACiFiles='/home/l2g/jimei/piscal.cfg') !---------------End of variable declaration---------------- ierr(1)=-1 ierr(2)=-1 - outputfile(1)='leafgasparameters.csv' - outputfile(2)='leafgascomparison.csv' - outputfile(3)='stomwuecicaparameters.csv' - outputfile(4)='stomcomparison.csv' - outputfile(5)='wuecicacomparison.csv' - outputfile(6)='fluorescencefit.csv' - outputfile(7)='fluoresparameters.csv' - outputfile(8)='aciempfitparameters.csv' - outputfile(9)='alightempfitparameters.csv' - outputfile(10)='warningmessage' - outputfile(11)='errormessage' - noutputfiles=11 - do i=1,noutputfiles - indexunit(i)=i+9 - enddo - do i=1,noutputfiles-1 - open(unit=indexunit(i),file=trim(outpath)//trim(outputfile(i))) - enddo !read A/Ci curve names stored in AllACiFiles dataunit=1 spareunit=3 open(unit=dataunit,status='scratch') - open(unit=spareunit,file=trim(datapath)//trim(AllACiFiles)) - read(spareunit,fmt=300,err=40,end=40)longchar + open(unit=spareunit,file=trim(AllACiFiles)) + read(spareunit,fmt=300,err=90,end=90)longchar rewind(spareunit) -2 read(spareunit,fmt=300,err=40,end=5)longchar +2 read(spareunit,fmt=300,err=90,end=5)longchar + if(longchar.eq.''.or.longchar.eq.' ')goto 2 3 k=index(longchar,char(13)) if(k.gt.0)then !DOS text format, convert it to unix format @@ -147,7 +139,34 @@ 5 close(spareunit) rewind(dataunit) ntotfiles=1 + ic3c4cam=-9999 10 read(dataunit,fmt=300,end=20)longchar + if(ntotfiles.eq.1.and.ic3c4cam.lt.0)then + i=0 + if((index(longchar,'_photosynthesis_leafweb')+ + &index(longchar,'_Photosynthesis_leafweb')+ + &index(longchar,'_Photosynthesis_LeafWeb')).gt.0)then + i=index(longchar,'c3')+index(longchar,'C3') + if(i.gt.0)then + ic3c4cam=1 + else + i=index(longchar,'c4')+index(longchar,'C4') + if(i.gt.0)then + ic3c4cam=2 + else + i=index(longchar,'cam')+index(longchar,'caM')+ + &index(longchar,'cAm')+index(longchar,'cAM')+ + &index(longchar,'Cam')+index(longchar,'CaM')+ + &index(longchar,'CAm')+index(longchar,'CAM') + if(i.gt.0)ic3c4cam=3 + endif + endif + endif + if(i.gt.0)goto 10 +!if no indication is provided, c3 photosynthesis is assumed and the first line +!contains the name of the first data file + ic3c4cam=1 + endif i=len(longchar) j=0 15 j=j+1 @@ -170,83 +189,32 @@ goto 10 20 ntotfiles=ntotfiles-1 close(dataunit) - call ToLeafGasOptimization(ntotfiles,ACidata,dataunit,spareunit, - &datapath,indexunit,ierr) -40 do i=1,noutputfiles-1 + outputfile(1)='leafgasparameters.csv' + outputfile(2)='leafgascomparison.csv' + outputfile(3)='stomwuecicaparameters.csv' + outputfile(4)='stomcomparison.csv' + outputfile(5)='wuecicacomparison.csv' + outputfile(6)='fluorescencefit.csv' + outputfile(7)='fluoresparameters.csv' + outputfile(8)='aciempfitparameters.csv' + outputfile(9)='alightempfitparameters.csv' + outputfile(10)='warningmessage' + outputfile(11)='errormessage' + noutputfiles=11 + do i=1,noutputfiles + if(ic3c4cam.eq.1)outputfile(i)='C3_'//outputfile(i) + if(ic3c4cam.eq.2)outputfile(i)='C4_'//outputfile(i) + if(ic3c4cam.eq.3)outputfile(i)='CAM_'//outputfile(i) + indexunit(i)=i+9 + enddo + do i=1,noutputfiles + open(unit=indexunit(i),file=trim(outpath)//trim(outputfile(i))) + enddo + call ToLeafGasOptimization(ic3c4cam,ntotfiles,ACidata,dataunit, + &spareunit,datapath,indexunit,ierr) + do i=1,noutputfiles close(indexunit(i)) enddo - if(ierr(1).ne.0)then - i=indexunit(noutputfiles) - open(unit=i,file=trim(outpath)//trim(outputfile(noutputfiles))) - if(ierr(1).eq.-1)then - close(spareunit) - write(i,*) - &'No data files to analyze or incorrect file name format' - else - write(i,*)'Input data error in ',trim(ACidata(ierr(2))) - write(i,*) - &'Please resubmit the data after correcting the following error:' - endif - if(ierr(1).eq.1)then - write(i,*)'Photosynthesis (umol/m2/s) out of range' - endif - if(ierr(1).eq.2)then - write(i,*)'Intercellular CO2(ppm) out of range' - endif - if(ierr(1).eq.3)then - write(i,*)'Leaf temperature (oC) out of range' - endif - if(ierr(1).eq.4)then - write(i,*)'Chamber PAR (umol/m2/s) out of range' - endif - if(ierr(1).eq.5)then - write(i,*)'Atmospheric pressure (Pa) out of range' - endif - if(ierr(1).eq.13)then - write(i,*)'Check line 13 for data entry error' - endif - if(ierr(1).eq.14)then - write(i,*)'Specified chloroplastic CO2 compensation point', - &'(Pa) out of range' - endif - if(ierr(1).eq.15)then - write(i,*)'Specified Michaelis-Menten constant for the', - &'carboxylase (Kc) out of range' - endif - if(ierr(1).eq.16)then - write(i,*)'Specified Michaelis-Menten constant for the', - &'oxygenase (Ko) out of range' - endif - if(ierr(1).eq.17)then - write(i,*)'Specified fraction of nonreturned glycolate', - &'carbon(alpha) out of range 0~1' - endif - if(ierr(1).eq.18)then - write(i,*)'Specified dark respiration rate Rd out of range >0' - endif - if(ierr(1).eq.19)then - write(i,*)'Specified internal (mesophyll) conductance gi out', - &'of range >0' - endif - if(ierr(1).eq.34)then - write(i,*)'Check Column 33 or 34. Mixing area- and mass-based - &measurements is not allowed' - endif - if(ierr(1).eq.36)then - write(i,*)'Check line 16 for data entry error' - endif - if(ierr(1).eq.39)then - write(i,*) - &'Check the main body of data for data entry error, starting from - &line 19' - endif - if(ierr(1).eq.40)then - write(i,*) - &'Data file format cannot be recognized' - endif - - close(i) - endif do j=1,noutputfiles open(unit=2,file=trim(outpath)//trim(outputfile(j))) read(2,*,end=70) @@ -260,29 +228,47 @@ 80 enddo !---------------------------------------------------------- !intercept the data - goto 450 -399 call date_and_time(rundate,runtime,runzone,runvalues) +90 if(ierr(1).ne.0)then + if(ierr(1).eq.-1)then + close(spareunit) + open(unit=spareunit,file=trim(outpath)//'errormessage') + write(spareunit,*)'No data files to analyze' + close(spareunit) + goto 450 + endif + do i=1,ntotfiles + open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i))) + close(1,status='delete') + enddo + goto 450 + endif + call date_and_time(rundate,runtime,runzone,runvalues) do i=1,ntotfiles - open(unit=1,file=trim(datapath)//trim(ACidata(i))) + open(unit=1,file=trim(datapath)//'clean'//trim(ACidata(i))) open(unit=2,file= - &trim(storein)//rundate//runtime(1:6)//trim(ACidata(i))) + &trim(storein)//rundate//runtime(1:6)//'clean'//trim(ACidata(i))) 400 read(1,fmt=300,end=410)longchar write(2,310)trim(longchar) goto 400 -410 close(1) +410 close(1,status='delete') close(2) enddo - do i=1,6 + do i=1,noutputfiles k=0 open(unit=1,file=trim(outpath)//trim(outputfile(i))) - open(unit=2,file= + if(i.ge.3.and.i.le.5)then + open(unit=2,file= &trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i))) + else + open(unit=2,file= + &trim(outpath)//rundate//runtime(1:6)//trim(outputfile(i))) + endif 420 read(1,fmt=300,end=430)longchar write(2,310)trim(longchar) k=1 goto 420 430 if(k.eq.1)then - close(1) + close(1,status='delete') close(2) else close(1,status='delete') diff --git a/leafres/testarea/LeafGasParams.h b/leafres/testarea/LeafGasParams.h index 7e530fb..3fb1aa9 100644 --- a/leafres/testarea/LeafGasParams.h +++ b/leafres/testarea/LeafGasParams.h @@ -58,7 +58,7 @@ &ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin, &ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori, &ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax, - &ha_gmeso_ori + &ha_gmeso_ori,c4aparslope,c4aparslope_ori,c4kp25,c4kp25_ori integer minimumrubis,minimumfj,minimumvt,idorwp,idorch,idord, &idostargamma,idoalpha,idokc,idoko,ifixunivparams(maxpsnparam), @@ -84,7 +84,7 @@ &ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin, &ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori, &ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax, - &ha_gmeso_ori + &ha_gmeso_ori,c4aparslope,c4aparslope_ori,c4kp25,c4kp25_ori common /intleafparams/minimumrubis,minimumfj,minimumvt,idorwp, &idorch,idord,idostargamma,idoalpha,idokc,idoko,ifixunivparams, diff --git a/leafres/testarea/LeafGasPrintToFiles.f b/leafres/testarea/LeafGasPrintToFiles.f index fa7ad41..35a9344 100644 --- a/leafres/testarea/LeafGasPrintToFiles.f +++ b/leafres/testarea/LeafGasPrintToFiles.f @@ -1,8 +1,9 @@ - subroutine LeafGasPrintToFiles(isitmassbased,indexunit) + subroutine LeafGasPrintToFiles(isitmassbased,indexunit, + &ic3c4cam) implicit none integer isitmassbased,indexunit(20),paramunit,compareunit, &stomwuecicaoutunit,stomcompunit,wuecicacompunit,fluorescenceunit, - &fluoresparamunit,aciempfitunit,alightempfitunit + &fluoresparamunit,aciempfitunit,alightempfitunit,ic3c4cam character *25, & sitevars(50),unitsitevars(50), & paramsvar(0:50),unitparamsvar(0:50), @@ -363,7 +364,7 @@ unitparamsvar(41)='umolkg-1s-1' unitparamsvar(42)='umolkg-1s-1' endif - + sitevars(1)='siteID' sitevars(2)='Latitude' sitevars(3)='Longitude' @@ -411,15 +412,25 @@ unitsitevars(21)='ring/diffuse' unitsitevars(22)='g/cm3' unitsitevars(23)='Unitless' - - write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9), + if(ic3c4cam.eq.1)then + write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9), &(trim(paramsvar(i)),',',i=0,34),(trim(paramsvar(i)),',',i=39,42), &(trim(sitevars(i)),',',i=1,22),trim(sitevars(23)) - write(paramunit,'(2000A)')(trim(unitunivcomvars(i)),',',i=1,9), + write(paramunit,'(2000A)')(trim(unitunivcomvars(i)),',',i=1,9), &(trim(unitparamsvar(i)),',',i=0,34), &(trim(unitparamsvar(i)),',',i=39,42), &(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23)) - + endif + if(ic3c4cam.eq.2)then + write(paramunit,'(2000A)')trim(univcomvars(1)),',', + &'Model,Vcmax25,c4aparslope,c4kp25,rdlight25,', + &(trim(paramsvar(i)),',',i=30,34), + &(trim(sitevars(i)),',',i=1,22),trim(sitevars(23)) + write(paramunit,'(2000A)')trim(unitunivcomvars(1)),',', + &'NA,umolm-2s-1,CO2/photon,umolm-2s-1,umolm-2s-1,', + &(trim(unitparamsvar(i)),',',i=30,34), + &(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23)) + endif write(fluorescenceunit,'(1000A)')trim(univcomvars(1)),',', &(trim(univcomvars(i)),',',i=10,14), &(trim(univcomvars(i)),',',i=17,27), @@ -514,9 +525,9 @@ unitstomwuecica(16)='umolkg-1s-1' endif - write(stomcompunit,'(100A)')((trim(stomwuecica(i)),','), + write(stomcompunit,'(100A)')(trim(stomwuecica(i)),',', &i=1,15),trim(stomwuecica(16)) - write(stomcompunit,'(100A)')((trim(unitstomwuecica(i)),','), + write(stomcompunit,'(100A)')(trim(unitstomwuecica(i)),',', &i=1,15),trim(unitstomwuecica(16)) !------------------------------------------------------------ stomwuecica(1)='curveno' @@ -581,9 +592,9 @@ unitstomwuecica(29)='NA' unitstomwuecica(30)='NA' - write(wuecicacompunit,'(200A)')((trim(stomwuecica(i)),','), + write(wuecicacompunit,'(200A)')(trim(stomwuecica(i)),',', &i=1,29),trim(stomwuecica(30)) - write(wuecicacompunit,'(200A)')((trim(unitstomwuecica(i)),','), + write(wuecicacompunit,'(200A)')(trim(unitstomwuecica(i)),',', &i=1,29),trim(stomwuecica(30)) stomwuecica(1)='curveno' @@ -875,10 +886,10 @@ unitstomwuecica(55)='umolkg-1s-1' endif - write(stomwuecicaoutunit,'(2000A)')((trim(stomwuecica(i)),','), - &i=1,139),((trim(sitevars(i)),','),i=1,22),trim(sitevars(23)) - write(stomwuecicaoutunit,'(2000A)')((trim(unitstomwuecica(i)), - &','),i=1,139),((trim(unitsitevars(i)),','),i=1,22), + write(stomwuecicaoutunit,'(2000A)')(trim(stomwuecica(i)),',', + &i=1,139),(trim(sitevars(i)),',',i=1,22),trim(sitevars(23)) + write(stomwuecicaoutunit,'(2000A)')(trim(unitstomwuecica(i)), + &',',i=1,139),(trim(unitsitevars(i)),',',i=1,22), &trim(unitsitevars(23)) return end diff --git a/leafres/testarea/SetUpLeafGasFit.f b/leafres/testarea/SetUpLeafGasFit.f index 9496446..0ff23a7 100644 --- a/leafres/testarea/SetUpLeafGasFit.f +++ b/leafres/testarea/SetUpLeafGasFit.f @@ -685,7 +685,7 @@ else betamin(1)=0.5d0*amaxave endif - betamax(1)=200.0d0 + betamax(1)=1000.0d0 beta(2)=1.5d0 betamin(2)=1.0d-5 betamax(2)=1000.0d0 @@ -696,8 +696,8 @@ betamin(4)=0.0d0 betamax(4)=5000.0d0 beta(5)=-10.0d0 - betamin(5)=-100.0d0 - betamax(5)=100.0d0 + betamin(5)=-1000.0d0 + betamax(5)=1000.0d0 k=0 n=0 do j=1,nACiPoints(i) @@ -717,6 +717,7 @@ wvector(n)=ACipco2ambient(j,i) endif enddo +! call GenericRegres(nACiPoints(i),1, &ACianet_obs(1:nACiPoints(i),i:i),1,ACipco2i(1:nACiPoints(i),i:i), &weity,weitx,5,beta,betamin,betamax,xmin,xmax,iderivative,INFO, @@ -726,13 +727,24 @@ &ACipco2i(nACiPoints(i):nACiPoints(i),i:i),der_ACiend(i),term, &ACipco2i(1:1,i:i),ACipco2i(nACiPoints(i):nACiPoints(i),i:i), &ACimaxcurvature(i),ACimaxcurvpco2i(i)) - call GenericRegres(n,1,zvector,1,wvector,weity,weitx,5,beta, + if(n.ge.5)then + call GenericRegres(n,1,zvector,1,wvector,weity,weitx,5,beta, &betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, &sumsquare) - call properties_surffunc(5,beta,starco2a(i),der_starco2a(i), + call properties_surffunc(5,beta,starco2a(i),der_starco2a(i), &Amax_ACa(i),ACainter(i),der_ACainter(i),40.0d0,der_ACa400ppm(i), &anet_ACa400ppm(i),wvector(1),wvector(n),ACamaxcurvature(i), &ACamaxcurvpco2a(i)) + else + der_starco2a(i)=-9999.0d0 + Amax_ACa(i)=-9999.0d0 + ACainter(i)=-9999.0d0 + der_ACainter(i)=-9999.0d0 + der_ACa400ppm(i)=-9999.0d0 + anet_ACa400ppm(i)=-9999.0d0 + ACamaxcurvature(i)=-9999.0d0 + ACamaxcurvpco2a(i)=-9999.0d0 + endif if(Amax_ACi(i).lt.50.0d0)amaxave=Amax_ACi(i) j=min0(5,nACiPoints(i)) call y_aPLUSbx(j,ACipco2i(1:j,i:i),ACianet_obs(1:j,i:i),ac,at) @@ -1268,7 +1280,7 @@ endif enddo idotempcoeff=0 - if((term2-term1).gt.2.0d0)idotempcoeff=1 + if((term2-term1).gt.5.0d0)idotempcoeff=1 !If temperature variation in the dataset is larger enough, try to estimate parameters in temperature response functions !All variables are now in the right order. All ACi curves are ordered and All ALight curves are ordered. !------------------------------------------------------------------------------------------------------- @@ -1283,7 +1295,7 @@ pco2c_pco2i_flu(i)=-9999.0d0 enddo if(ntotphips2.gt.5)then - do idorch=1,1 + do idorch=0,0 !we do a fluorescence only fit Prioriknowlimit=-1 ifitmode=1 @@ -1291,7 +1303,7 @@ !ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i !ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i !ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet - idorwp=1 + idorwp=0 resistwp25_ori=resistwp25_ini if(idorch.eq.1)then resistch25_ori=resistch25_ini @@ -1638,11 +1650,12 @@ co2imany(3)=3.0d0 co2imany(4)=4.0d0 co2imany(5)=5.0d0 - m=5 + co2imany(6)=6.0d0 + m=6 term=ACipco2i(nACiPoints(i),i)+10.0d0 - do ccc=6.0d0,term,2.5d0 + do while (co2imany(m).le.term) m=m+1 - co2imany(m)=ccc + co2imany(m)=co2imany(m-1)+2.5d0 enddo do j=1,m ccc=co2imany(j) diff --git a/leafres/testarea/ToLeafGasOptimization.f b/leafres/testarea/ToLeafGasOptimization.f index 7d2d147..44b4e74 100644 --- a/leafres/testarea/ToLeafGasOptimization.f +++ b/leafres/testarea/ToLeafGasOptimization.f @@ -1,15 +1,16 @@ - subroutine ToLeafGasOptimization(ntotfiles,ACidata,dataunit, - &spareunit,datapath,indexunit,ierr) + subroutine ToLeafGasOptimization(ic3c4cam,ntotfiles,ACidata, + &dataunit,spareunit,datapath,indexunit,ierr) implicit none !--------------All inputs except for ierr. Outputs are written to files---------------- - integer ntotfiles,dataunit,spareunit,ierr(2),indexunit(20) -!ierr(1)=0, ok, >1 input data out of range + integer ic3c4cam,ntotfiles,dataunit,spareunit,ierr(2), + &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 character*100 datapath,ACidata(ntotfiles) !------------------------------------------------------------------------------- integer ntotpoints,npoints(ntotfiles),i,j,k,n,curveno(ntotfiles), &iobs,maxobs,nmax,iwarning,warningunit,isitmassbased(ntotfiles), - &iprintheader(ntotfiles),ivector(1000),startline + &iprintheader(ntotfiles),ivector(1000),startline,errorunit parameter(maxobs=2000,nmax=100) character*100 sample(ntotfiles) character*50 chartime,siteID(ntotfiles),species(ntotfiles),ftime, @@ -49,8 +50,14 @@ &stdco2,fmeanco2,xminco2,xmaxco2 ! warningunit=indexunit(10) + errorunit=indexunit(11) 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') ! write(121,'(200A)')'name,','hhmmss,','no,','time,','datumlimit,', ! &'stom_COND_mol,','CO2chamber_ppm,','CO2i_ppm,','PARi_umol,', @@ -61,7 +68,7 @@ do 10 i=1,ntotfiles isitmassbased(i)=0 iwarning=0 - ierr(2)=i + ierr(2)=i npoints(i)=0 sample(i)=trim(ACidata(i)) !fill any blank spaces in sample(i) with '_' @@ -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. !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 + open(unit=spareunit,file=trim(datapath)//trim(ACidata(i))) + read(spareunit,fmt=300,err=35,end=35)longchar1 + rewind(spareunit) open(unit=dataunit,file= &trim(datapath)//trim(ACidata(i))//'middle') - open(unit=spareunit,file=trim(datapath)//trim(ACidata(i))) - read(spareunit,fmt=300,err=40,end=40)longchar1 - rewind(spareunit) -2 read(spareunit,fmt=300,err=40,end=5)longchar1 +2 read(spareunit,fmt=300,err=35,end=5)longchar1 3 k=index(longchar1,char(13)) if(k.gt.0)then !DOS text format, convert it to unix format @@ -94,8 +101,8 @@ rewind(dataunit) open(unit=spareunit,file= - &trim(datapath)//trim(ACidata(i))//'clean') -7 read(dataunit,fmt=310,err=40,end=9)longchar + &trim(datapath)//'clean'//trim(ACidata(i))) +7 read(dataunit,fmt=310,err=36,end=9)longchar if(longchar.eq.''.or.longchar.eq.' ')goto 7 call charlineparser(longchar,nmax,charvars,n) if(n.eq.0)goto 7 @@ -110,15 +117,21 @@ j=j+1 ivector(j)=n goto 500 -600 if(j.lt.12)then - close(spareunit,status='delete') - goto 630 - else - rewind(spareunit) - endif +600 rewind(spareunit) startline=0 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 if(ivector(startline).ne.ivector(startline+1))n=1 if(ivector(startline).ne.ivector(startline+2))n=1 @@ -149,7 +162,7 @@ read(spareunit,*) enddo !========================================================================================================================= - read(spareunit,fmt=310,err=13)longchar + read(spareunit,fmt=310,err=40)longchar call charlineparser(longchar,nmax,charvars,n) do j=n+1,nmax charvars(j)='-9999' @@ -199,7 +212,7 @@ do j=1,2 read(spareunit,*) enddo - read(spareunit,fmt=310,err=36)longchar + read(spareunit,fmt=310,err=40)longchar call charlineparser(longchar,nmax,charvars,n) do j=n+1,nmax charvars(j)='-9999' @@ -235,7 +248,7 @@ do j=1,2 read(spareunit,*) 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) if(n.le.25)goto 20 do j=n+1,nmax @@ -323,7 +336,18 @@ !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 !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 !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) @@ -346,7 +370,18 @@ CO2i_ppm=((gtc-1.0d-3*transp_mmol/2.0d0)*CO2chamber_ppm- &PNcor_umol)/(gtc-1.0d-3*transp_mmol/2.0d0) 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 if(isitmassbased(i).eq.0)then term=-100.0d0 @@ -356,8 +391,21 @@ term1=1.0d+10 endif if(PNcor_umol.lt.term.or.PNcor_umol.gt.term1)then - ierr(1)=1 - if(fm_fluoresce.le.0.0d0)return + if(fm_fluoresce.le.0.0d0)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), '... + &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 if(transp_mmol.gt.0.0d0.and.stom_COND_mol.gt.0.0d0 &.and.BLCond.gt.0.0d0)then @@ -381,13 +429,29 @@ endif endif if(CO2i_ppm.le.0.0d0.or.CO2i_ppm.gt.10000.0d0)then -! ierr(1)=2 -! 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,*)'Intercellular CO2 (ppm) out of range' +! ierr(1)=1 if(fm_fluoresce.le.0.0d0)goto 20 endif if(Tleaf_oC.lt.-50.0d0.or.Tleaf_oC.gt.100.0d0)then - ierr(1)=3 - if(fm_fluoresce.le.0.0d0)return + if(fm_fluoresce.le.0.0d0)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), '... + &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 if(isitmassbased(i).eq.0)then term1=1.0d+5 @@ -395,15 +459,29 @@ term1=1.0d+10 endif if(PARi_umol.lt.-10.01d0.or.PARi_umol.gt.term1)then - ierr(1)=4 - 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 PAR data' + write(errorunit,*)'Sample chamber PAR out of range' + ierr(1)=1 else PARi_umol=dmax1(0.0d0,PARi_umol) endif if(Press_KPa.lt.50.0d0.or.Press_KPa.gt.150.0d0)then Press_KPa=98.9d0 -! ierr(1)=5 -! 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,*)'Air pressure out of range' +! ierr(1)=1 endif if(Tair_oC.lt.-50.0d0.or.Tair_oC.gt.100.0d0)then Tair_oC=Tleaf_oC @@ -483,14 +561,47 @@ call CharToNumeric(chartime,term) sampletime(i,npoints(i))=term goto 20 -100 close(spareunit,status='delete') - do j=1,npoints(i) +100 do j=1,npoints(i) vectorhorse(j)=sampletime(i,j) call time_resolution(npoints(i),vectorhorse, & avetimeresolution(i),avetimesampled(i)) 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 + if(ierr(1).eq.1)return iprintheader(1)=1 do i=2,ntotfiles if(isitmassbased(i).eq.isitmassbased(i-1))then @@ -502,7 +613,8 @@ k=1 do i=1,ntotfiles 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 endif if(npoints(i).lt.3)goto 1112 @@ -536,7 +648,30 @@ 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)), &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)), @@ -560,16 +695,6 @@ 1112 continue enddo 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) 310 format(a5000) 340 format(a) diff --git a/leafres/testarea/UnivParamsAlloc.f b/leafres/testarea/UnivParamsAlloc.f index f5ea8ad..63675c3 100644 --- a/leafres/testarea/UnivParamsAlloc.f +++ b/leafres/testarea/UnivParamsAlloc.f @@ -61,7 +61,7 @@ ifixunivparams(5)=1 if(idokc.eq.1)ifixunivparams(6)=1 if(idoko.eq.1)ifixunivparams(7)=1 - if(idoha_vcmax)ifixunivparams(16)=1 + if(idoha_vcmax.eq.1)ifixunivparams(16)=1 endif if(Currentilimittype.le.2.or.Currentilimittype.eq.4.or. &Currentilimittype.eq.6)then diff --git a/leafres/testarea/UnivPhotoFit.f b/leafres/testarea/UnivPhotoFit.f index 390fbbb..e9581b0 100644 --- a/leafres/testarea/UnivPhotoFit.f +++ b/leafres/testarea/UnivPhotoFit.f @@ -172,10 +172,12 @@ implicit none include '../testarea/LeafGasParams.h' include '../testarea/LeafGasHybridFit.h' - integer i,ndim,k,j,iderivative,iwrong,jnon + 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,4),shorty(maxobs,2),ran2, - &ftol_relax + &betacp(20),ftol,xtol,shortx(maxobs,10),shorty(maxobs,5), + &ftol_relax,term1,term2,ran2,history(2000,25),discount,upper,lower, + &f1dim_UnivPhotoFit,ff_pikaia parameter(ftol=1.0d-7,xtol=1.0d-7) external funkmin_UnivPhotoFit,f1dim_UnivPhotoFit, &FCN_UnivPhotoFit,ff_pikaia @@ -193,113 +195,312 @@ enddo isitbounded=1 call funkmin_UnivPhotoFit(ndim,beta,sumsquare) - do i=1,ndim - beta0(i)=beta(i) - enddo - sumsquare0=sumsquare - ftol_relax=ftol - k=0 if(subbestsumsquare(Currentilimittype).gt.1.0d+9)then - jnon=0 - ftol_relax=ftol*100.0d0 - endif -30 call nongradopt(ndim,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit, - &beta,betamin,betamax,ftol_relax,sumsquare) - call funkmin_UnivPhotoFit(ndim,beta,sumsquare) - if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)then - do i=1,ndim - beta(i)=beta0(i) - enddo - sumsquare=sumsquare0 - else - if((sumsquare0-sumsquare).gt.ftol_relax)then -!reset the counter for arriving at a better minimum - k=0 - else -!if the same minimum is found, increment the counter - k=k+1 - endif +!global search do i=1,ndim beta0(i)=beta(i) + history(1,i)=beta(i) enddo sumsquare0=sumsquare - endif - if(subbestsumsquare(Currentilimittype).gt.1.0d+9)then - jnon=jnon+1 -!for the first run, try different initial guesses - if(jnon.lt.100.and.k.lt.5)then - if(ran2().gt.0.7d0)then - do i=1,ndim - beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) - enddo - else - do i=1,ndim - if(ran2().gt.0.5d0)then - beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))* - &(betamax(i)-beta(i)) - else - beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))* - &(beta(i)-betamin(i)) - endif - enddo - endif - call funkmin_UnivPhotoFit(ndim,beta,sumsquare) - goto 30 - else - if((ftol_relax-ftol).gt.ftol)then - ftol_relax=ftol - goto 30 - endif - endif - call RepeatCompassSearch(ndim,beta,sumsquare,betamin, - &betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,xtol) - call funkmin_UnivPhotoFit(ndim,beta,sumsquare) - if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0) - &then - do i=1,ndim - beta(i)=beta0(i) - enddo - sumsquare=sumsquare0 - endif - do i=1,ndim - betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + history(1,ndim+1)=sumsquare +!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. + jnon=0 + isame=0 + n=1 + nave=n + ftol_relax=ftol*1000.0d0 + discount=2.0d0 +!relax the convergence criterion for scouting +30 do i=1,ndim + betacp(i)=beta(i) enddo sumsquarecp=sumsquare - isitbounded=0 - call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquarecp,i) - isitbounded=1 - if(i.eq.0)then + iderivative=0 + if(ifitmode.lt.0)then + iwrong=0 + else + iwrong=1 + endif + k=ifitmode + ifitmode=-1 +!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet +!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i +!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i +!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet +!for odr_leastsquare, only the predicted value of the response variable is needed, i.e., the cost function value is not needed. +!also, only anet as a function of CO2i is considered (not the other way around) because odr_leastsquare cannot handle the situation +!co2i as a function of anet for tpu limitation when alpha=0 + i=1 + if(ntotphips2.ge.1)i=2 + j=4 + if(Currentiknowlimit.eq.-1)then +!fluorescence only fit. chlflphisi2 becomes a forcing variable + i=1 + j=5 + endif + call odr_leastsquare(ndim,FCN_UnivPhotoFit,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) + ifitmode=k +!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) + po2i(i)=po2i_ori(i) + chlflphips2(i)=chlflphips2_ori(i) + enddo + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + if(isitnaninf(sumsquare).eq.1.or.sumsquare.gt.sumsquarecp)then do i=1,ndim - betacp(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + beta(i)=betacp(i) enddo - call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp) + sumsquare=sumsquarecp else do i=1,ndim betacp(i)=beta(i) enddo sumsquarecp=sumsquare endif - if((sumsquarecp+1.0d0).ne.sumsquarecp.and. - &sumsquare.gt.sumsquarecp)then + call nongradopt(ndim,funkmin_UnivPhotoFit, + &f1dim_UnivPhotoFit,beta,betamin,betamax,ftol_relax,sumsquare) + if(isitnaninf(sumsquare).eq.1.or.sumsquare.gt.sumsquarecp)then do i=1,ndim beta(i)=betacp(i) enddo sumsquare=sumsquarecp endif + if(sumsquare.gt.1.0d0)then + term1=sumsquare*ftol_relax + else + term1=ftol_relax*10.0d0 + endif + if(sumsquare.gt.sumsquare0)then +!failure + if((sumsquare-sumsquare0).gt.term1)then + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0 +!even though sumsquare is much worse than sumsquare0, 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)-sumsquare).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)=sumsquare + 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 sumsquare is larger than sumsquare0. +!Increment the counter for arriving at the same minimum. + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0 + isame=isame+1 + endif +60 do i=1,ndim + beta(i)=beta0(i) + enddo + sumsquare=sumsquare0 + else +!success + if((sumsquare0-sumsquare).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 + isame=isame+1 + nave=n + 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,(sumsquare0-sumsquare)/1000.0d0) + endif + isame=0 + n=n+1 + do i=1,ndim + history(n,i)=beta(i) + enddo + history(n,ndim+1)=sumsquare + history(n,ndim+2)=0.0d0 + history(n,ndim+3)=0.0d0 + endif + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=sumsquare + endif + jnon=jnon+1 + if(jnon.lt.200.and.isame.lt.3)then +!we first explore around the very first initial guess + if(jnon.lt.10)then + icompete=1 + term1=0.05d0+dmin1(history(1,ndim+3)*0.1d0,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 + goto 70 + endif +!try average if n is incremented + if(n.gt.nave)then + term1=1.0d0/(history(1,ndim+1)+1.0d-5) + do i=2,n + term1=term1+1.0d0/(history(i,ndim+1)+1.0d-5) + enddo + do i=1,ndim + beta(i)=history(1,i)/(term1*(history(1,ndim+1)+1.0d-5)) + do icompete=2,n + beta(i)=beta(i)+history(icompete,i)/ + &(term1*(history(icompete,ndim+1)+1.0d-5)) + enddo + enddo + nave=n + icompete=0 + goto 70 + endif +!try different initial guesses + if(ran2().gt.0.2d0)then +!guess around the best + icompete=1 + term1=history(1,ndim+1)+ + &discount*history(1,ndim+2)*history(1,ndim+3) + do i=2,n + term2=history(i,ndim+1)+ + &discount*history(i,ndim+2)*history(i,ndim+3) + if(term2.le.term1)then + term1=term2 + do i2=1,ndim+3 + history(n+1,i2)=history(i,i2) + history(i,i2)=history(1,i2) + history(1,i2)=history(n+1,i2) + enddo + endif + enddo + term1=0.05d0+dmin1(history(1,ndim+2)*history(1,ndim+3)* + &0.015d0,0.9d0) + history(1,ndim+2)=history(1,ndim+2)+1.0d0 + do i=1,ndim + lower=history(1,i)-term1*(history(1,i)-betamin(i)) + upper=history(1,i)+term1*(betamax(i)-history(1,i)) + beta(i)=lower+ran2()*(upper-lower) + enddo + else +!completely random guess + do i=1,ndim + beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) + enddo + icompete=0 + endif +70 call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + goto 30 + else + if((ftol_relax-ftol).gt.ftol)then + if(isame.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)=sumsquare + 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 + sumsquarecp=history(i,ndim+1) + call RepeatCompassSearch(ndim,betacp,sumsquarecp, + &betamin,betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit, + &ftol_relax) + call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp) + if(isitnaninf(sumsquarecp).eq.0.and.sumsquarecp.lt. + &sumsquare)then + do icompete=1,ndim + beta(icompete)=betacp(icompete) + enddo + sumsquare=sumsquarecp + endif + enddo + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=sumsquare + jnon=0 + icompete=1 + else + icompete=0 + endif + ftol_relax=ftol + goto 30 + endif + endif + + goto 110 + do i=1,ndim - beta0(i)=beta(i) + betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) enddo - sumsquare0=sumsquare + sumsquarecp=sumsquare + call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquarecp,i) + if(i.eq.0)then + do i=1,ndim + betacp(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + enddo + call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp) + if(isitnaninf(sumsquarecp).eq.0.and.sumsquare.gt.sumsquarecp) + &then + do i=1,ndim + beta(i)=betacp(i) + enddo + sumsquare=sumsquarecp + endif + endif else - return +!local search + call nongradopt(ndim,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit, + &beta,betamin,betamax,ftol,sumsquare) + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) endif + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=sumsquare iderivative=0 if(ifitmode.lt.0)then iwrong=0 else iwrong=1 endif - isitbounded=1 k=ifitmode ifitmode=-1 !ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet @@ -322,7 +523,6 @@ &weitforcings(1:ntotsamples,1:j),weitresponses(1:ntotsamples,1:i), &iderivative,shortx(1:ntotsamples,1:j),shorty(1:ntotsamples,1:i), &sumsquare,iwrong) - isitbounded=1 ifitmode=k !after odr_leastsquare, forcing variables are destroyed. restore to the origninals do i=1,ntotsamples @@ -333,29 +533,12 @@ chlflphips2(i)=chlflphips2_ori(i) enddo call funkmin_UnivPhotoFit(ndim,beta,sumsquare) - if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)then + if(isitnaninf(sumsquare).eq.1.or.sumsquare.gt.sumsquare0)then do i=1,ndim beta(i)=beta0(i) enddo sumsquare=sumsquare0 endif - k=0 - do i=1,ndim - if(beta(i).lt.betamin(i))k=1 - if(beta(i).gt.betamax(i))k=1 - enddo - if(k.eq.1)then - do i=1,ndim - betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) - enddo - isitbounded=0 - call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquare,i) - do i=1,ndim - beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) - enddo - isitbounded=1 - call funkmin_UnivPhotoFit(ndim,beta,sumsquare) - endif j=0 100 jnon=0 105 sumsquare0=sumsquare @@ -370,21 +553,11 @@ goto 105 endif if(sumsquare.eq.sumsquare0)goto 110 - if(dabs(sumsquare).le.dabs(sumsquare0))then - else - if(dabs(sumsquare).gt.1.0d+20)then -!in case of infinity (division by zero) - do i=1,ndim - beta(i)=beta0(i) - enddo - sumsquare=sumsquare0 - else -!designed this way to avoid sumsquare='NAN' - do i=1,ndim - beta(i)=beta0(i) - enddo - sumsquare=sumsquare0 - endif + if(isitnaninf(sumsquare).eq.1.or.sumsquare.gt.sumsquare0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + sumsquare=sumsquare0 endif sumsquarecp=sumsquare do i=1,ndim @@ -394,14 +567,14 @@ &betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,xtol) call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp) if(sumsquare.eq.sumsquarecp)goto 110 - if(dabs(sumsquarecp).lt.dabs(sumsquare))then + if(isitnaninf(sumsquarecp).eq.0.and.sumsquarecp.lt.sumsquare)then do i=1,ndim beta(i)=betacp(i) enddo sumsquare=sumsquarecp endif j=j+1 - if(j.le.2.and.dabs(sumsquare-sumsquare0).gt.ftol)goto 100 + if(j.le.2.and.(sumsquare0-sumsquare).gt.ftol)goto 100 ! !------------------------------------------------------ 110 call funkmin_UnivPhotoFit(ndim,beta,sumsquare) diff --git a/leafres/testarea/c4leafanetmodel.f b/leafres/testarea/c4leafanetmodel.f new file mode 100644 index 0000000..74cda8d --- /dev/null +++ b/leafres/testarea/c4leafanetmodel.f @@ -0,0 +1,89 @@ + subroutine c4leafanetmodel(ilimittype,aPPFDlf,templeaf,pco2i, + &pres_air,vcmax25,c4aparslope,c4kp25,rdlight25,anet_pred, + &Postiphotolimit) + implicit none +!------------ Inputs ------------------- +!ilimittype=1: Rubisco,RuBp and TPU limitations +!ilimittype=2: Rubisco and RuBp limitations only +!ilimittype=3: Rubisco and TPU limitations only +!ilimittype=4: RuBp and TPU limitations only +!ilimittype=5: Rubisco limitation only +!ilimittype=6: RuBp limitation only +!ilimittype=7: TPU limitation only +!aPPFDlf: Absorbed photosynthetic photon flux density by leaf (umol m-2 s-1) +!templeaf: Leaf temperature [K] +!pco2i: Intercellular air pressure [Pa] +!pres_air: Ambient air pressure [Pa] +!vcmax25: Maximum RuBP saturated rate of carboxylation at 25oC +! of leaf temperature [umol m-2 s-1] +!c4aparslope: Slope of the response of light-limited rate with respect +! to absorbed light +!c4kp25: Slope of the response of the PEP carboxylase-limited +! rate of carboxylation for C4 plants +!rdlight25: Mitochondrial respiration rate in the light at 25oC + double precision aPPFDlf,templeaf,pco2i,pres_air, + &vcmax25,c4aparslope,c4kp25,rdlight25 +!------------Output--------------------- +!anet_pred: Predicted net photosynthetic rate [umol m-2 s-1] +!Postiphotolimit: limit state indicator +! = 1 Rubisco-limited rate +! = 2 RuBP-regeneration limited rate +! = 3 Product-limited rate + double precision anet_pred + integer ilimittype,Postiphotolimit +!-------------------------------------- + double precision q10,fh,fl,frd,wc,wj,wp,rd,thetacj,thetaip,Ai + q10=2.0d0 + fh=1.0d0+dexp(0.3d0*(templeaf-313.15d0)) + fl=1.0d0+dexp(0.2d0*(288.15d0-templeaf)) + frd=1.0d0+dexp(1.3d0*(templeaf-328.15d0)) + wc=vcmax25*(q10**((templeaf-298.15d0)/10.0d0))/(fh*fl) + wj=c4aparslope*aPPFDlf + wp=c4kp25*(q10**((templeaf-298.15)/10.0d0))*pco2i/pres_air + rd=rdlight25*(q10**((templeaf-298.15d0)/10.0d0))/frd + if((ilimittype.eq.1.and.wc.le.wj.and.wc.le.wp).or. + &ilimittype.eq.5)then + Postiphotolimit=1 + anet_pred=wc-rd + endif + if((ilimittype.eq.1.and.wj.le.wc.and.wj.le.wp).or. + &ilimittype.eq.6)then + Postiphotolimit=2 + anet_pred=wj-rd + endif + if((ilimittype.eq.1.and.wp.le.wc.and.wp.le.wj).or. + &ilimittype.eq.7)then + Postiphotolimit=3 + anet_pred=wp-rd + endif + if(ilimittype.eq.2.and.wc.le.wj)then + Postiphotolimit=1 + anet_pred=wc-rd + else + Postiphotolimit=2 + anet_pred=wj-rd + endif + if(ilimittype.eq.3.and.wc.le.wp)then + Postiphotolimit=1 + anet_pred=wc-rd + else + Postiphotolimit=3 + anet_pred=wp-rd + endif + if(ilimittype.eq.4.and.wj.le.wp)then + Postiphotolimit=2 + anet_pred=wj-rd + else + Postiphotolimit=3 + anet_pred=wp-rd + endif + if(ilimittype.eq.1)then + thetacj=0.8d0 + thetaip=0.95d0 + Ai=((wc+wj)-dsqrt((wc+wj)**2-4.0d0*thetacj*wc*wj))/ + &(2.0d0*thetacj) + anet_pred=((Ai+wp)-dsqrt((Ai+wp)**2-4.0d0*thetaip*Ai*wp))/ + &(2.0d0*thetaip)-rd + endif + return + end diff --git a/leafres/testarea/cica5.f b/leafres/testarea/cica5.f index 8c5a2b6..e64d51a 100644 --- a/leafres/testarea/cica5.f +++ b/leafres/testarea/cica5.f @@ -11,7 +11,7 @@ c integer i,ndim,imodel0 double precision beta(ndim),fatbeta,ftol,bmin0(ndim), - & bmax0(ndim) + & bmax0(ndim),f1dim_cica parameter(ftol=1.0d-7) external funkmin_cica,f1dim_cica diff --git a/leafres/testarea/cica_Regression5.f b/leafres/testarea/cica_Regression5.f index 9a5db62..ce44707 100644 --- a/leafres/testarea/cica_Regression5.f +++ b/leafres/testarea/cica_Regression5.f @@ -156,7 +156,7 @@ C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + ISTOP) implicit none - include '../src/cica.h' + include '../testarea/cica.h' C SUBROUTINE ARGUMENTS C ==> N NUMBER OF OBSERVATIONS diff --git a/leafres/testarea/fluorescencejmax.f b/leafres/testarea/fluorescencejmax.f index 67e0fe4..32b50e5 100644 --- a/leafres/testarea/fluorescencejmax.f +++ b/leafres/testarea/fluorescencejmax.f @@ -3,11 +3,14 @@ implicit none include '../testarea/LeafGasParams.h' include '../testarea/LeafGasHybridFit.h' - integer i,ndim,k,j,iderivative,iwrong + integer i,ndim,k,j,iderivative,iwrong,n,icompete,i2,isitnaninf, + &nave double precision beta(4),sumsquare0,beta0(4),sumsquarecp, &betacp(4),ftol,xtol,shortx(maxobs,2),shorty(maxobs), - &xvar(maxobs,2),weitx(maxobs,2),weity(maxobs),ran2, - &templflights0(maxobs),aparlights0(maxobs),termmin,termmax + &xvar(maxobs,2),weitx(maxobs,2),weity(maxobs), + &templflights0(maxobs),aparlights0(maxobs),termmin,termmax, + &ftol_relax,term1,term2,ran2,discount,history(2000,10),upper,lower, + &f1dim_flujmax,flujmax_pikaia parameter(ftol=1.0d-7,xtol=1.0d-7) external funkmin_flujmax,f1dim_flujmax,FCN_flujmax,flujmax_pikaia !beta(1)=fjmax25 @@ -65,104 +68,298 @@ call funkmin_flujmax(ndim,beta,flujmaxfval) do i=1,ndim beta0(i)=beta(i) + history(1,i)=beta(i) enddo sumsquare0=flujmaxfval + history(1,ndim+1)=flujmaxfval +!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 -30 call nongradopt(ndim,funkmin_flujmax, - &f1dim_flujmax,beta,betamin,betamax,ftol,flujmaxfval) - call funkmin_flujmax(ndim,beta,flujmaxfval) - if((flujmaxfval+1.0d0).eq.flujmaxfval)then - do i=1,ndim - beta(i)=beta0(i) - enddo - flujmaxfval=sumsquare0 - else - if(dabs(flujmaxfval-sumsquare0).lt.ftol)k=k+1 - if(flujmaxfval.gt.sumsquare0)then - do i=1,ndim - beta(i)=beta0(i) - enddo - flujmaxfval=sumsquare0 - else - if((sumsquare0-flujmaxfval).gt.ftol)k=0 -!reset the counter of revisiting a minimum if a new minimum is found - endif - endif - j=j+1 -!try different initial guesses - if(j.lt.200.and.k.lt.50)then - do i=1,ndim - beta0(i)=beta(i) - beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) - enddo - sumsquare0=flujmaxfval - call funkmin_flujmax(ndim,beta,flujmaxfval) - goto 30 - endif - call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin, - &betamax,funkmin_flujmax,f1dim_flujmax,xtol) - do i=1,ndim - betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + n=1 + nave=1 + ftol_relax=ftol*1000.0d0 + discount=2.0d0 +30 do i=1,ndim + betacp(i)=beta(i) enddo - isitbounded=0 - call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i) - do i=1,ndim - beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) - enddo - isitbounded=1 - call funkmin_flujmax(ndim,beta,flujmaxfval) - call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin, - &betamax,funkmin_flujmax,f1dim_flujmax,xtol) - isitbounded=1 - call funkmin_flujmax(ndim,beta,flujmaxfval) - do i=1,ndim - beta0(i)=beta(i) - enddo - sumsquare0=flujmaxfval + sumsquarecp=flujmaxfval iderivative=0 iwrong=0 call odr_leastsquare(ndim,FCN_flujmax,beta,ntotlights, &xvar(1:ntotlights,1:2),2,flphips2lights,1,weitx(1:ntotlights,1:2), &weity,iderivative,shortx(1:ntotlights,1:2),shorty(1:ntotlights), &flujmaxfval,iwrong) - isitbounded=1 !after odr_leastsquare, forcing variables are destroyed. restore to the origninals do i=1,ntotlights templflights(i)=templflights0(i) aparlights(i)=aparlights0(i) enddo call funkmin_flujmax(ndim,beta,flujmaxfval) - if(dabs(flujmaxfval).le.dabs(sumsquare0))then + if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquarecp)then + do i=1,ndim + beta(i)=betacp(i) + enddo + flujmaxfval=sumsquarecp else - if(dabs(flujmaxfval).gt.1.0d+20)then -!in case of infinity (division by zero) + do i=1,ndim + betacp(i)=beta(i) + enddo + sumsquarecp=flujmaxfval + endif + call nongradopt(ndim,funkmin_flujmax,f1dim_flujmax, + &beta,betamin,betamax,ftol_relax,flujmaxfval) + if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquarecp)then + do i=1,ndim + beta(i)=betacp(i) + enddo + flujmaxfval=sumsquarecp + endif + if(flujmaxfval.gt.1.0d0)then + term1=flujmaxfval*ftol_relax + else + term1=ftol_relax*10.0d0 + endif + if(flujmaxfval.gt.sumsquare0)then +!failure + if((flujmaxfval-sumsquare0).gt.term1)then + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0 +!even though flujmaxfval is much worse than sumsquare0, 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)-flujmaxfval).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 - beta(i)=beta0(i) + history(n,i)=beta(i) enddo - flujmaxfval=sumsquare0 + history(n,ndim+1)=flujmaxfval + history(n,ndim+2)=0.0d0 + history(n,ndim+3)=0.0d0 +!use average only when there is improvement + nave=n else -!designed this way to avoid flujmaxfval='NAN' +!the difference is minimal even though flujmaxfval is larger than sumsquare0. +!Increment the counter for arriving at the same minimum. + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0 + k=k+1 + endif +60 do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + else +!success + if((sumsquare0-flujmaxfval).lt.term1)then +!negligible improvement. Increment the counter for arriving at the same minimum. +!no increment for the set of central initial guesses + if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.5d0 + k=k+1 + else +!reset the counter for arriving at a better minimum. +!Increment the set of central initial guesses + if(dabs(discount-2.0d0).lt.ftol)then + discount=dmax1(0.001d0,(sumsquare0-flujmaxfval)/1000.0d0) + endif + k=0 + n=n+1 do i=1,ndim - beta(i)=beta0(i) + history(n,i)=beta(i) enddo - flujmaxfval=sumsquare0 + history(n,ndim+1)=flujmaxfval + history(n,ndim+2)=0.0d0 + history(n,ndim+3)=0.0d0 + endif + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=flujmaxfval + endif + j=j+1 + if(j.lt.200.and.k.lt.3)then +!first explore around the very first initial guess + if(j.lt.10)then + term1=0.05d0+dmin1(history(1,ndim+3)*0.1d0,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 + icompete=1 + goto 70 + endif +!try average + if(n.gt.nave)then + term1=1.0d0/(history(1,ndim+1)+1.0d-5) + do i=2,n + term1=term1+1.0d0/(history(i,ndim+1)+1.0d-5) + enddo + do i=1,ndim + beta(i)=history(1,i)/(term1*(history(1,ndim+1)+1.0d-5)) + do icompete=2,n + beta(i)=beta(i)+history(icompete,i)/ + &(term1*(history(icompete,ndim+1)+1.0d-5)) + enddo + enddo + nave=n + icompete=0 + goto 70 + endif +!try different initial guesses + if(ran2().gt.0.2d0)then +!guess around the best + icompete=1 + term1=history(1,ndim+1)+ + &discount*history(1,ndim+2)*history(1,ndim+3) + do i=2,n + term2=history(i,ndim+1)+ + &discount*history(i,ndim+2)*history(i,ndim+3) + if(term2.le.term1)then + term1=term2 + do i2=1,ndim+3 + history(n+1,i2)=history(i,i2) + history(i,i2)=history(1,i2) + history(1,i2)=history(n+1,i2) + enddo + endif + enddo + term1=0.05d0+dmin1(history(1,ndim+2)*history(1,ndim+3)* + &0.015d0,0.9d0) + history(1,ndim+2)=history(1,ndim+2)+1.0d0 + do i=1,ndim + lower=history(1,i)-term1*(history(1,i)-betamin(i)) + upper=history(1,i)+term1*(betamax(i)-history(1,i)) + beta(i)=lower+ran2()*(upper-lower) + enddo + else +!completely random guess + do i=1,ndim + beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) + enddo + icompete=0 + endif +70 call funkmin_flujmax(ndim,beta,flujmaxfval) + goto 30 + else + if((ftol_relax-ftol).gt.ftol)then + if(k.le.1)then + n=n+1 + do i=1,ndim+3 + history(n,i)=history(1,i) + enddo + do i=1,ndim + history(1,i)=beta(i) + enddo + history(1,ndim+1)=flujmaxfval + 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 + sumsquarecp=history(i,ndim+1) + call RepeatCompassSearch(ndim,betacp,sumsquarecp, + &betamin,betamax,funkmin_flujmax,f1dim_flujmax,ftol_relax) + call funkmin_flujmax(ndim,betacp,sumsquarecp) + if(isitnaninf(sumsquarecp).eq.0.and.sumsquarecp.lt. + &flujmaxfval)then + do icompete=1,ndim + beta(icompete)=betacp(icompete) + enddo + flujmaxfval=sumsquarecp + endif + enddo + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=flujmaxfval + j=0 + icompete=1 + else + icompete=0 + endif + ftol_relax=ftol + goto 30 endif endif - j=0 -100 if(j.ge.10)then + + goto 110 + + call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin, + &betamax,funkmin_flujmax,f1dim_flujmax,xtol) + call funkmin_flujmax(ndim,beta,flujmaxfval) + if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquare0)then do i=1,ndim - betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + beta(i)=beta0(i) enddo - isitbounded=0 - call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i) + flujmaxfval=sumsquare0 + else do i=1,ndim - beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + beta0(i)=beta(i) enddo - isitbounded=1 - call funkmin_flujmax(ndim,beta,flujmaxfval) + sumsquare0=flujmaxfval endif - sumsquare0=flujmaxfval + do i=1,ndim + betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + enddo + call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i) + if(i.eq.0)then + do i=1,ndim + betacp(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + enddo + call funkmin_flujmax(ndim,betacp,flujmaxfval) + if(isitnaninf(flujmaxfval).eq.0.and.flujmaxfval.lt.sumsquare0) + &then + do i=1,ndim + beta(i)=betacp(i) + beta0(i)=betacp(i) + enddo + sumsquare0=flujmaxfval + endif + endif + flujmaxfval=sumsquare0 + iderivative=0 + iwrong=0 + call odr_leastsquare(ndim,FCN_flujmax,beta,ntotlights, + &xvar(1:ntotlights,1:2),2,flphips2lights,1,weitx(1:ntotlights,1:2), + &weity,iderivative,shortx(1:ntotlights,1:2),shorty(1:ntotlights), + &flujmaxfval,iwrong) +!after odr_leastsquare, forcing variables are destroyed. restore to the origninals + do i=1,ntotlights + templflights(i)=templflights0(i) + aparlights(i)=aparlights0(i) + enddo + call funkmin_flujmax(ndim,beta,flujmaxfval) + if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquare0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + endif + j=0 +100 sumsquare0=flujmaxfval do i=1,ndim beta0(i)=beta(i) enddo @@ -170,21 +367,11 @@ &beta,betamin,betamax,ftol,flujmaxfval) call funkmin_flujmax(ndim,beta,flujmaxfval) if(flujmaxfval.eq.sumsquare0)return - if(dabs(flujmaxfval).le.dabs(sumsquare0))then - else - if(dabs(flujmaxfval).gt.1.0d+20)then -!in case of infinity (division by zero) - do i=1,ndim - beta(i)=beta0(i) - enddo - flujmaxfval=sumsquare0 - else -!designed this way to avoid flujmaxfval='NAN' - do i=1,ndim - beta(i)=beta0(i) - enddo - flujmaxfval=sumsquare0 - endif + if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquare0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 endif sumsquarecp=flujmaxfval do i=1,ndim @@ -194,14 +381,15 @@ &betamax,funkmin_flujmax,f1dim_flujmax,xtol) call funkmin_flujmax(ndim,betacp,sumsquarecp) if(flujmaxfval.eq.sumsquarecp)return - if(dabs(sumsquarecp).lt.dabs(flujmaxfval))then + if(isitnaninf(sumsquarecp).eq.0.and.flujmaxfval.gt.sumsquarecp) + &then do i=1,ndim beta(i)=betacp(i) enddo flujmaxfval=sumsquarecp endif j=j+1 - if(j.le.2.and.dabs(flujmaxfval-sumsquare0).gt.ftol)goto 100 + if(j.le.2.and.(sumsquare0-flujmaxfval).gt.ftol)goto 100 ! !------------------------------------------------------ 110 call funkmin_flujmax(ndim,beta,flujmaxfval) diff --git a/leafres/testarea/funkmin_C4Fit.f b/leafres/testarea/funkmin_C4Fit.f new file mode 100644 index 0000000..e63277b --- /dev/null +++ b/leafres/testarea/funkmin_C4Fit.f @@ -0,0 +1,128 @@ + subroutine funkmin_C4Fit(ndim,beta,fvalue) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer ndim + double precision beta(1:ndim),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +! +!---------Local variables-------------------------------------------------- + integer i +!----------- End of variables declaration --------------------------------- +!check to see if parameters are out of bounds. + if(isitbounded.eq.1)then + do i=1,ndim + if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + endif + vcmax25=beta(1) + c4aparslope=beta(2) + c4kp25=beta(3) + if(idord.eq.1)rdlight25=beta(ndim) + fvalue=0.0d0 + do i=1,ntotsamples + call c4leafanetmodel(1,aPPFDlf(i),templeaf(i),pco2i(i), + &pres_air(i),vcmax25,c4aparslope,c4kp25,rdlight25,anet_pred(i), + &Postiphotolimit(i)) + fvalue=fvalue+(anet_obs(i)-anet_pred(i))**2.0d0 + enddo + return + end subroutine funkmin_C4Fit +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_C4Fit(x) + implicit none + double precision x +CU USES funkmin_C4Fit + INTEGER j +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX) + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_C4Fit(ncom,xt,f1dim_C4Fit) + return + END +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE FCN_C4Fit(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' +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) + integer k + double precision fvalue +c + ISTOP=0 + do I=1,NP + if(BETA(I).lt.betamin(I).or. + &BETA(I).gt.betamax(I))then + ISTOP=1 + return + endif + enddo + do I=1,N + pco2i(I)=XPLUSD(I,1) + aPPFDlf(I)=XPLUSD(I,2) + templeaf(I)=XPLUSD(I,3) + pres_air(I)=XPLUSD(I,4) + enddo + IF (MOD(IDEVAL,10).GE.1) THEN + call funkmin_C4Fit(NP,BETA,fvalue) + if(fvalue.gt.1.0d+20)then + ISTOP=1 + return + endif + DO 100 I = 1,N + F(I,1)=anet_pred(I) + 100 CONTINUE + END IF + RETURN + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/leafres/testarea/stomoptimization.f b/leafres/testarea/stomoptimization.f index b839d3f..d5511b1 100644 --- a/leafres/testarea/stomoptimization.f +++ b/leafres/testarea/stomoptimization.f @@ -10,7 +10,7 @@ c &gammas0(npoints),yAnet0(npoints),gswmeas0(npoints), &pvapordef_s0(npoints),stomintercept,stomslope,rayDzero integer i,ndim - double precision beta(10),fatbeta,ftol + double precision beta(10),fatbeta,ftol,f1dim_stom parameter(ftol=1.0d-7) external funkmin_stom,f1dim_stom diff --git a/leafres/testrun/Makefile b/leafres/testrun/Makefile index 189af25..5e05a07 100644 --- a/leafres/testrun/Makefile +++ b/leafres/testrun/Makefile @@ -1,12 +1,11 @@ # This is the makefile for piscal # name of executable ALL = piscal -#mpipiscal # compiler options FF = mpif90 #FOPTS = -g -C -FOPTS = -g -fallow-argument-mismatch +FOPTS = -g #Base directory BASEDIR = ../.. @@ -27,7 +26,8 @@ OBJS = LeafGasPISCAL_single.o adsor.o clustering.o cppowell.o GenericRegres.o lf LeafGasFit_Stom.o nonsyssolver.o time_resolution.o CharToNumeric.o cpfixedpoint.o funkmin_cica5.o NumberToChar.o\ stdmaxmeanmin.o ToLeafGasOptimization.o cica5.o cpnongradopt.o funkmin_stom.o LeafGasPrintToFiles.o odr_leastsquare.o StomatalConductance.o\ UnivParamsAlloc.o cica_Regression5.o cpnonsyssolver.o funkmin_UnivPhotoFit.o leafunivphotosyn.o odrpack.o stomlfitbasis.o UnivPhotoFit.o\ - fluorescencejmax.o funkmin_flujmax.o pam_parameters.o + fluorescencejmax.o funkmin_flujmax.o pam_parameters.o C4SetUpLeafGasFit.o C4PhotoFit.o funkmin_C4Fit.o c4leafanetmodel.o d1mach.o dnqsol.o\ + ierm1.o derv1.o dnrm2.o ierv1.o ermsg.o erfin.o $(ALL): $(OBJS) $(FF) $(FOPTS) $(OBJS) -o $@