mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
74 lines
1.9 KiB
Fortran
74 lines
1.9 KiB
Fortran
*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
|