* E04HYF Example Program Text * Mark 19 Revised. NAG Copyright 1999. * .. Parameters .. INTEGER M, N, NT, LW PARAMETER (M=15,N=3,NT=3,LW=8*N+2*N*N+2*M*N+3*M) INTEGER NIN, NOUT PARAMETER (NIN=5,NOUT=6) * .. Local Scalars .. DOUBLE PRECISION FSUMSQ INTEGER I, IFAIL, J, K * .. Local Arrays .. DOUBLE PRECISION T(M,NT), USER(M+M*NT), W(LW), X(N), Y(M) INTEGER IUSER(1) * .. External Subroutines .. EXTERNAL E04HYF, LSFUN3, LSHES3 * .. Executable Statements .. WRITE (NOUT,*) 'E04HYF Example Program Results' * Skip heading in data file READ (NIN,*) * * Observations of TJ (J = 1, 2, 3) are held in T(I, J) * (I = 1, 2, . . . , 15) * IUSER(1) = NT K = M DO 40 I = 1, M READ (NIN,*) Y(I), (T(I,J),J=1,NT) USER(I) = Y(I) DO 20 J = 1, NT USER(K+J) = T(I,J) 20 CONTINUE K = K + NT 40 CONTINUE * X(1) = 0.5D0 X(2) = 1.0D0 X(3) = 1.5D0 * IFAIL = 1 * CALL E04HYF(M,N,LSFUN3,LSHES3,X,FSUMSQ,W,LW,IUSER,USER,IFAIL) * IF (IFAIL.NE.0) THEN WRITE (NOUT,*) WRITE (NOUT,99999) 'Error exit type', IFAIL, + ' - see routine document' END IF IF (IFAIL.NE.1 .AND. IFAIL.NE.9) THEN WRITE (NOUT,*) WRITE (NOUT,99998) 'On exit, the sum of squares is', FSUMSQ WRITE (NOUT,99998) 'at the point', (X(J),J=1,N) END IF STOP * 99999 FORMAT (1X,A,I3,A) 99998 FORMAT (1X,A,3F12.4) END SUBROUTINE LSFUN3(M,N,XC,FVECC,FJACC,LJC,IUSER,USER) * Routine to evaluate the residuals and their 1st derivatives. * .. Scalar Arguments .. INTEGER LJC, M, N * .. Array Arguments .. DOUBLE PRECISION FJACC(LJC,N), FVECC(M), USER(*), XC(N) INTEGER IUSER(*) * .. Local Scalars .. DOUBLE PRECISION DENOM, DUMMY INTEGER I, K * .. Executable Statements .. K = M DO 20 I = 1, M DENOM = XC(2)*USER(K+2) + XC(3)*USER(K+3) FVECC(I) = XC(1) + USER(K+1)/DENOM - USER(I) FJACC(I,1) = 1.0D0 DUMMY = -1.0D0/(DENOM*DENOM) FJACC(I,2) = USER(K+1)*USER(K+2)*DUMMY FJACC(I,3) = USER(K+1)*USER(K+3)*DUMMY K = K + IUSER(1) 20 CONTINUE RETURN END * SUBROUTINE LSHES3(M,N,FVECC,XC,B,LB,IUSER,USER) * Routine to compute the lower triangle of the matrix B * (stored by rows in the array B). * .. Scalar Arguments .. INTEGER LB, M, N * .. Array Arguments .. DOUBLE PRECISION B(LB), FVECC(M), USER(*), XC(N) INTEGER IUSER(*) * .. Local Scalars .. DOUBLE PRECISION DUMMY, SUM22, SUM32, SUM33 INTEGER I, K * .. Executable Statements .. B(1) = 0.0D0 B(2) = 0.0D0 SUM22 = 0.0D0 SUM32 = 0.0D0 SUM33 = 0.0D0 K = M DO 20 I = 1, M DUMMY = 2.0D0*USER(K+1)/(XC(2)*USER(K+2)+XC(3)*USER(K+3))**3 SUM22 = SUM22 + FVECC(I)*DUMMY*USER(K+2)**2 SUM32 = SUM32 + FVECC(I)*DUMMY*USER(K+2)*USER(K+3) SUM33 = SUM33 + FVECC(I)*DUMMY*USER(K+3)**2 K = K + IUSER(1) 20 CONTINUE B(3) = SUM22 B(4) = 0.0D0 B(5) = SUM32 B(6) = SUM33 RETURN END