*
* $Id: f406rd.F,v 1.1.1.1 1996/02/15 17:48:42 mclareni Exp $
*
* $Log: f406rd.F,v $
* Revision 1.1.1.1  1996/02/15 17:48:42  mclareni
* Kernlib
*
*
#include "kernnumt/pilot.h"
      SUBROUTINE F406RD(N,M,K,KMAX,IDIM,A,ABAND,B,BREF,RESID)
      REAL RESID,RB
      DOUBLE PRECISION A,ABAND,B,BREF,ONE
      DIMENSION A(IDIM,N),ABAND(IDIM,2),B(IDIM,KMAX),BREF(IDIM,KMAX)
      DATA ONE/1.D0/
C
C  SETS RESID EQUAL TO THE LARGEST RESIDUAL FOUND WHEN SOLVING A BANDED
C  LINEAR SYSTEM BY MEANS OF SUBROUTINE DBEQN (F406).
C
C     N       ORDER OF COEFFICIENT MATRIX.
C     M       BAND-WIDTH PARAMETER.
C     K       CURRENT NUMBER OF RIGHT-HAND SIDES.
C     KMAX    MAXIMUM NUMBER OF RIGHT-HAND SIDES.
C     A       (DOUBLE PRECISION) TWO-DIMENSIONAL ARRAY WITH AT LEAST
C             N COLUMNS.
C     ABAND   (DOUBLE PRECISION) TWO-DIMENSIONAL ARRAY WITH AT LEAST
C             MIN(2*M+1,N)+1 COLUMNS.
C     B,BREF  (DOUBLE PRECISION) TWO-DIMENSIONAL ARRAYS WITH AT LEAST
C             KMAX COLUMNS.
C     RESID   (REAL) OUTPUT VARIABLE.
C
C  CALLS ... SUBROUTINE DBEQN (F406).
C        ... CERN PACKAGES F002 AND F003.
C        ... TEST-ROUTINE F406SD.
C
C  START.
C
      IF(K.LT.1) RETURN
      MBAND=2*M+1
C
C  SET ARRAY A TO A BAND MATRIX WHICH IS WELL-CONDITIONED ONLY IF PIV-
C  OTING OCCURS, AND SET A PACKED COPY IN ARRAY ABAND.
C
      CALL F406SD(N,M,IDIM,A)
      DO 2 I=1,N
         JMIN=MAX0(I-M,1)
         JMAX=MIN0(I+M,N)
         DO 1 J=JMIN,JMAX
            L=J-I+M+1
            IF(I.LE.M) ABAND(I,J)=A(I,J)
            IF(I.GT.M) ABAND(I,L)=A(I,J)
    1    CONTINUE
    2 CONTINUE
C
C  SET MINUS ONES AS A MARKER IN THE FIRST NON-SET COLUMN OF B.
C  THESE SHOULD NOT BE OVERWRITTEN BY CALLING DBEQN.
C
      LSTCOL=MIN0(MBAND,N)
      CALL DVSET(N,-ONE,ABAND(1,LSTCOL+1),ABAND(2,LSTCOL+1))
C
C  SET A RIGHT-HAND SIDE MATRIX IN B, WITH A COPY IN BREF.
C
      CALL DMRAN(N,KMAX,-ONE,ONE,B,B(1,2),B(2,1))
      CALL DMCPY(N,KMAX,B,B(1,2),B(2,1),BREF,BREF(1,2),BREF(2,1))
C
C  CALL DBEQN TO REPLACE B BY THE SOLUTION MATRIX AINV*B.
C
      CALL DBEQN(N,M,ABAND,IDIM,IFAIL,K,B)
C
C  REPLACE B BY THE MATRIX OF RESIDUALS (USING FIRST COLUMN OF ABAND AS
C  A WORKING VECTOR FOR SUBROUTINE DMMLT).
C
      CALL DMMLT(N,N,K,A,A(1,2),A(2,1),B,B(1,2),B(2,1),
     *                                          B,B(1,2),B(2,1),ABAND)
      CALL DMSUB(N,KMAX,B,B(1,2),B(2,1),BREF,BREF(1,2),BREF(2,1),
     *                                             B,B(1,2),B(2,1))
C
C  SET RESID TO THE LARGEST RESIDUAL.
C
      RESID=0.
      DO 4 I=1,N
         DO 3 J=1,KMAX
            RB=B(I,J)
            RESID=AMAX1(RESID,ABS(RB))
    3    CONTINUE
    4 CONTINUE
C
C  IF MARKED COLUMN OF ABAND HAS CHANGED, SET RESID NEGATIVE.
C
      DO 5 I=1,N
         IF(ABAND(I,LSTCOL+1).NE.-ONE) RESID=-ABS(RESID)
    5 CONTINUE
      RETURN
      END