* F07BFF Example Program Text * Mark 21 Release. NAG Copyright 2004. * .. Parameters .. INTEGER NIN, NOUT PARAMETER (NIN=5,NOUT=6) INTEGER NMAX, KLMAX, KUMAX PARAMETER (NMAX=8,KLMAX=4,KUMAX=4) INTEGER LDAB PARAMETER (LDAB=KLMAX+KUMAX+1) * .. Local Scalars .. DOUBLE PRECISION AMAX, BIG, CJ, COLCND, ROWCND, SMALL INTEGER I, IFAIL, INFO, J, K, KL, KU, N * .. Local Arrays .. DOUBLE PRECISION AB(LDAB,NMAX), C(NMAX), R(NMAX) * .. External Functions .. DOUBLE PRECISION X02AJF, X02AMF INTEGER X02BHF EXTERNAL X02AJF, X02AMF, X02BHF * .. External Subroutines .. EXTERNAL DGBEQU, X04CEF * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Executable Statements .. WRITE (NOUT,*) 'F07BFF Example Program Results' WRITE (NOUT,*) * Skip heading in data file READ (NIN,*) READ (NIN,*) N, KL, KU IF (N.LE.NMAX .AND. KL.LE.KLMAX .AND. KU.LE.KUMAX) THEN * * Read the band matrix A from data file * K = KU + 1 READ (NIN,*) ((AB(K+I-J,J),J=MAX(I-KL,1),MIN(I+KU,N)),I=1,N) * * Print the matrix A * IFAIL = 0 CALL X04CEF(N,N,KL,KU,AB,LDAB,'Matrix A',IFAIL) WRITE (NOUT,*) * * Compute row and column scaling factors * CALL DGBEQU(N,N,KL,KU,AB,LDAB,R,C,ROWCND,COLCND,AMAX,INFO) * IF (INFO.GT.0) THEN IF (INFO.LE.N) THEN WRITE (NOUT,99999) 'Row ', INFO, ' of A is exactly zero' ELSE WRITE (NOUT,99999) 'Column ', INFO - N, + ' of A is exactly zero' END IF ELSE * * Print ROWCND, COLCND, AMAX and the scale factors * WRITE (NOUT,99998) 'ROWCND = ', ROWCND, ', COLCND = ', + COLCND, ', AMAX = ', AMAX WRITE (NOUT,*) WRITE (NOUT,*) 'Row scale factors' WRITE (NOUT,99997) (R(I),I=1,N) WRITE (NOUT,*) WRITE (NOUT,*) 'Column scale factors' WRITE (NOUT,99997) (C(I),I=1,N) WRITE (NOUT,*) * * Compute values close to underflow and overflow * SMALL = X02AMF()/(X02AJF()*X02BHF()) BIG = 1.0D0/SMALL IF ((ROWCND.GE.0.1D0) .AND. (AMAX.GE.SMALL) + .AND. (AMAX.LE.BIG)) THEN IF (COLCND.LT.0.1D0) THEN * * Just column scale A * DO 40 J = 1, N CJ = C(J) K = KU + 1 - J DO 20 I = MAX(1,J-KU), MIN(N,J+KL) AB(K+I,J) = AB(K+I,J)*CJ 20 CONTINUE 40 CONTINUE * * Print the column scaled matrix * IFAIL = 0 CALL X04CEF(N,N,KL,KU,AB,LDAB,'Scaled matrix',IFAIL) * END IF ELSE IF (COLCND.GE.0.1D0) THEN * * Just row scale A * DO 80 J = 1, N K = KU + 1 - J DO 60 I = MAX(1,J-KU), MIN(N,J+KL) AB(K+I,J) = R(I)*AB(K+I,J) 60 CONTINUE 80 CONTINUE * * Print the row scaled matrix * IFAIL = 0 CALL X04CEF(N,N,KL,KU,AB,LDAB,'Scaled matrix',IFAIL) * ELSE * * Row and column scale A * DO 120 J = 1, N CJ = C(J) K = KU + 1 - J DO 100 I = MAX(1,J-KU), MIN(N,J+KL) AB(K+I,J) = R(I)*AB(K+I,J)*CJ 100 CONTINUE 120 CONTINUE * * Print the row and column scaled matrix * IFAIL = 0 CALL X04CEF(N,N,KL,KU,AB,LDAB,'Scaled matrix',IFAIL) * END IF END IF ELSE WRITE (NOUT,*) + 'One or more of NMAX, KLMAX or KUMAX is too small' END IF * 99999 FORMAT (1X,A,I4,A) 99998 FORMAT (1X,3(A,1P,E7.1)) 99997 FORMAT ((1X,1P,7E11.1)) END