* G02HBF Example Program Text * Mark 14 Revised. NAG Copyright 1989. * .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN=5,NOUT=6) INTEGER NMAX, MMAX PARAMETER (NMAX=5,MMAX=3) * .. Local Scalars .. DOUBLE PRECISION BD, BL, TOL INTEGER I, IFAIL, IX, J, K, L1, L2, M, MAXIT, MM, N, NIT, + NITMON * .. Local Arrays .. DOUBLE PRECISION A(MMAX*(MMAX+1)/2), WK(MMAX*(MMAX+1)/2), + X(NMAX,MMAX), Z(NMAX) * .. External Functions .. DOUBLE PRECISION UCV EXTERNAL UCV * .. External Subroutines .. EXTERNAL G02HBF, X04ABF * .. Executable Statements .. WRITE (NOUT,*) 'G02HBF Example Program Results' * Skip heading in data file READ (NIN,*) CALL X04ABF(1,NOUT) * Read in the dimensions of X READ (NIN,*) N, M IF (N.GT.0 .AND. N.LE.NMAX .AND. M.GT.0 .AND. M.LE.MMAX) THEN * Read in the X matrix DO 20 I = 1, N READ (NIN,*) (X(I,J),J=1,M) 20 CONTINUE IX = NMAX * Read in the initial value of A MM = (M+1)*M/2 READ (NIN,*) (A(J),J=1,MM) * Set the values remaining parameters BL = 0.9D0 BD = 0.9D0 MAXIT = 50 TOL = 0.5D-4 IFAIL = 0 * * Change NITMON to a positive value if monitoring information * is required * NITMON = 0 * CALL G02HBF(UCV,N,M,X,IX,A,Z,BL,BD,TOL,MAXIT,NITMON,NIT,WK, + IFAIL) * WRITE (NOUT,99999) 'G02HBF required ', NIT, + ' iterations to converge' WRITE (NOUT,*) WRITE (NOUT,*) 'Matrix A' L2 = 0 DO 40 J = 1, M L1 = L2 + 1 L2 = L2 + J WRITE (NOUT,99998) (A(K),K=L1,L2) 40 CONTINUE WRITE (NOUT,*) WRITE (NOUT,*) 'Vector Z' DO 60 I = 1, N WRITE (NOUT,99998) Z(I) 60 CONTINUE * Calculate Krasker-Welsch weights WRITE (NOUT,*) WRITE (NOUT,*) 'Vector of weights' DO 80 I = 1, N Z(I) = 1.0D0/Z(I) WRITE (NOUT,99998) Z(I) 80 CONTINUE END IF STOP * 99999 FORMAT (1X,A,I4,A) 99998 FORMAT (1X,6F9.4) END * DOUBLE PRECISION FUNCTION UCV(T) * UCV function for Krasker-Welsch weights * .. Parameters .. DOUBLE PRECISION UCVC PARAMETER (UCVC=2.5D0) * .. Scalar Arguments .. DOUBLE PRECISION T * .. Local Scalars .. DOUBLE PRECISION PC, PD, Q, Q2 INTEGER IFAIL * .. External Functions .. DOUBLE PRECISION S15ABF, X01AAF, X02AKF EXTERNAL S15ABF, X01AAF, X02AKF * .. Intrinsic Functions .. INTRINSIC EXP, LOG, SQRT * .. Executable Statements .. UCV = 1.0D0 IF (T.NE.0.0D0) THEN Q = UCVC/T Q2 = Q*Q IFAIL = 0 PC = S15ABF(Q,IFAIL) IF (Q2.LT.-LOG(X02AKF())) THEN PD = EXP(-Q2/2.0D0)/SQRT(X01AAF(0.0D0)*2.0D0) ELSE PD = 0.0D0 END IF UCV = (2.0D0*PC-1.0D0)*(1.0D0-Q2) + Q2 - 2.0D0*Q*PD END IF RETURN END