relibc_openlibm/slatec/cscale.f

*DECK CSCALE
      SUBROUTINE CSCALE (A, NRDA, NROW, NCOL, COLS, COLSAV, ROWS,
     +   ROWSAV, ANORM, SCALES, ISCALE, IC)
C***BEGIN PROLOGUE  CSCALE
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (CSCALE-S, DCSCAL-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     This routine scales the matrix A by columns when needed
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  SDOT
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  CSCALE
      DIMENSION A(NRDA,*),COLS(*),COLSAV(*),SCALES(*),
     1          ROWS(*),ROWSAV(*)
C
      SAVE TEN4, TEN20
      DATA TEN4,TEN20/1.E+4,1.E+20/
C
C***FIRST EXECUTABLE STATEMENT  CSCALE
      IF (ISCALE .NE. (-1)) GO TO 25
C
      IF (IC .EQ. 0) GO TO 10
      DO 5 K=1,NCOL
    5    COLS(K)=SDOT(NROW,A(1,K),1,A(1,K),1)
C
   10 ASCALE=ANORM/NCOL
      DO 20 K=1,NCOL
         CS=COLS(K)
         IF ((CS .GT. TEN4*ASCALE) .OR. (TEN4*CS .LT. ASCALE)) GO TO 50
         IF ((CS .LT. 1./TEN20) .OR. (CS .GT. TEN20)) GO TO 50
   20 CONTINUE
C
   25 DO 30 K=1,NCOL
   30    SCALES(K)=1.
      RETURN
C
   50 ALOG2=LOG(2.)
      ANORM=0.
      DO 100 K=1,NCOL
         CS=COLS(K)
         IF (CS .NE. 0.) GO TO 60
         SCALES(K)=1.
         GO TO 100
   60    P=LOG(CS)/ALOG2
         IP=-0.5*P
         S=2.**IP
         SCALES(K)=S
         IF (IC .EQ. 1) GO TO 70
         COLS(K)=S*S*COLS(K)
         ANORM=ANORM+COLS(K)
         COLSAV(K)=COLS(K)
   70    DO 80 J=1,NROW
   80       A(J,K)=S*A(J,K)
  100 CONTINUE
C
      IF (IC .EQ. 0) RETURN
C
      DO 200 K=1,NROW
         ROWS(K)=SDOT(NCOL,A(K,1),NRDA,A(K,1),NRDA)
         ROWSAV(K)=ROWS(K)
  200    ANORM=ANORM+ROWS(K)
      RETURN
      END