#! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # 539 # This archive created: Tue Apr 6 14:42:24 2004 export PATH; PATH=/bin:$PATH if test -f '539' then echo shar: will not over-write existing file "'539'" else cat << "SHAR_EOF" > '539' REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) C C RETURNS THE DOT PRODUCT OF SINGLE PRECISION SX AND SY. C SDOT = SUM FOR I = 0 TO N-1 OF SX(LX+I*INCX) * SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C REAL SX(1),SY(1) SDOT = 0.0E0 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1)5,20,60 5 CONTINUE C C CODE FOR UNEQUAL INCREMENTS OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SDOT = SDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SDOT = SDOT + SX(I)*SY(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SDOT = SDOT + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) + $ SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4) 50 CONTINUE RETURN C C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. C 60 CONTINUE NS=N*INCX DO 70 I=1,NS,INCX SDOT = SDOT + SX(I)*SY(I) 70 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY) C C RETURNS D.P. DOT PRODUCT ACCUMULATED IN D.P., FOR S.P. SX AND SY C DSDOT = SUM FOR I = 0 TO N-1 OF SX(LX+I*INCX) * SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C REAL SX(1),SY(1) C DSDOT = 0.D0 IF(N .LE. 0)RETURN IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20 KX = 1 KY = 1 IF(INCX.LT.0) KX = 1+(1-N)*INCX IF(INCY.LT.0) KY = 1+(1-N)*INCY DO 10 I = 1,N DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) KX = KX + INCX KY = KY + INCY 10 CONTINUE RETURN 20 CONTINUE NS = N*INCX DO 30 I=1,NS,INCX DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) 30 CONTINUE RETURN END REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) C C RETURNS S.P. RESULT WITH DOT PRODUCT ACCUMULATED IN D.P. C SDSDOT = SB + SUM FOR I = 0 TO N-1 OF SX(LX+I*INCX)*SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C REAL SX(1),SY(1),SB DOUBLE PRECISION DSDOT C DSDOT = DBLE(SB) IF(N .LE. 0) GO TO 30 IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 40 KX = 1 KY = 1 IF(INCX.LT.0) KX = 1+(1-N)*INCX IF(INCY.LT.0) KY = 1+(1-N)*INCY DO 10 I = 1,N DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) KX = KX + INCX KY = KY + INCY 10 CONTINUE 30 SDSDOT = SNGL(DSDOT) RETURN 40 CONTINUE NS = N*INCX DO 50 I=1,NS,INCX DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) 50 CONTINUE SDSDOT = SNGL(DSDOT) RETURN END DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) C C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. C DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C DOUBLE PRECISION DX(1),DY(1) DDOT = 0.D0 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DDOT = DDOT + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DDOT = DDOT + DX(I)*DY(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + $ DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 50 CONTINUE RETURN C C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX DDOT = DDOT + DX(I)*DY(I) 70 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DQDOTA(N,DB,QC,DX,INCX,DY,INCY) C D.P. DOT PRODUCT WITH EXTENDED PRECISION ACCUMULATION (AND RESULT) C QC AND DQDOTA ARE SET = DB + QC + SUM FOR I = 0 TO N-1 OF C DX(LX+I*INCX) * DY(LY+I*INCY), WHERE QC IS AN EXTENDED C PRECISION RESULT PREVIOUSLY COMPUTED BY DQDOTI OR DQDOTA C AND LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. THE MP PACKAGE BY C RICHARD P. BRENT IS USED FOR THE EXTENDED PRECISION ARITHMETIC. C C FRED T. KROGH, JPL, 1977, JUNE 1 C2 DOUBLE PRECISION DX(1), DY(1), DB INTEGER QC(10), QX(10), QY(10) C THE COMMON BLOCK FOR THE MP PACKAGE (MODIFIED TO GIVE IT A NAME) COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(12) DATA I1 / 0 / C IF I1 IS 0 THE MP PACKAGE MUST BE INITIALIZED (MPBLAS SETS I1 = 1) IF (I1 .EQ. 0) CALL MPBLAS(I1) IF (DB .EQ. 0.D0) GO TO 20 CALL MPCDM(DB, QX) CALL MPADD(QC, QX, QC) 20 IF (N .EQ. 0) GO TO 40 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N + 1) * INCX + 1 IF (INCY .LT. 0) IY = (-N + 1) * INCY + 1 DO 30 I = 1,N CALL MPCDM(DX(IX), QX) CALL MPCDM(DY(IY), QY) CALL MPMUL(QX, QY, QX) CALL MPADD(QC, QX, QC) IX = IX + INCX IY = IY + INCY 30 CONTINUE 40 CALL MPCMD(QC, DQDOTA) RETURN END COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) C C RETURNS THE DOT PRODUCT FOR COMPLEX CX AND CY, USES CONJUGATE(CX) C CDOTC = SUM FOR I = 0 TO N-1 OF CONJ(CX(LX+I*INCX))*CY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C COMPLEX CX(1),CY(1) C CDOTC = (0.,0.) IF(N .LE. 0)RETURN IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20 KX = 1 KY = 1 IF(INCX.LT.0) KX = 1+(1-N)*INCX IF(INCY.LT.0) KY = 1+(1-N)*INCY DO 10 I = 1,N CDOTC = CDOTC + CONJG(CX(KX))*CY(KY) KX = KX + INCX KY = KY + INCY 10 CONTINUE RETURN 20 CONTINUE NS = N*INCX DO 30 I=1,NS,INCX CDOTC = CONJG(CX(I))*CY(I) + CDOTC 30 CONTINUE RETURN END COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) C C RETURNS THE DOT PRODUCT FOR COMPLEX CX AND CY, NO CONJUGATION C CDOTU = SUM FOR I = 0 TO N-1 OF CX(LX+I*INCX) * CY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C COMPLEX CX(1),CY(1) C CDOTU = (0.,0.) IF(N .LE. 0)RETURN IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20 KX = 1 KY = 1 IF(INCX.LT.0) KX = 1+(1-N)*INCX IF(INCY.LT.0) KY = 1+(1-N)*INCY DO 10 I = 1,N CDOTU = CDOTU + CX(KX)*CY(KY) KX = KX + INCX KY = KY + INCY 10 CONTINUE RETURN 20 CONTINUE NS = N*INCX DO 30 I=1,NS,INCX CDOTU = CDOTU + CX(I)*CY(I) 30 CONTINUE RETURN END SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) C C OVERWRITE SINGLE PRECISION SY WITH SINGLE PRECISION SA*SX +SY. C FOR I = 0 TO N-1, REPLACE SY(LY+I*INCY) WITH SA*SX(LX+I*INCX) + C SY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. C REAL SX(1),SY(1),SA IF(N.LE.0.OR.SA.EQ.0.E0) RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SY(I) = SY(I) + SA*SX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 SY(I) = SY(I) + SA*SX(I) SY(I + 1) = SY(I + 1) + SA*SX(I + 1) SY(I + 2) = SY(I + 2) + SA*SX(I + 2) SY(I + 3) = SY(I + 3) + SA*SX(I + 3) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SY(I) = SA*SX(I) + SY(I) 70 CONTINUE RETURN END SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) C C OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. C FOR I = 0 TO N-1, REPLACE DY(LY+I*INCY) WITH DA*DX(LX+I*INCX) + C DY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. C DOUBLE PRECISION DX(1),DY(1),DA IF(N.LE.0.OR.DA.EQ.0.D0) RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I + 1) = DY(I + 1) + DA*DX(I + 1) DY(I + 2) = DY(I + 2) + DA*DX(I + 2) DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX DY(I) = DA*DX(I) + DY(I) 70 CONTINUE RETURN END SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) C C OVERWRITE COMPLEX CY WITH COMPLEX CA*CX + CY. C FOR I = 0 TO N-1, REPLACE CY(LY+I*INCY) WITH CA*CX(LX+I*INCX) + C CY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. C COMPLEX CX(1),CY(1),CA C CANORM = ABS(REAL(CA)) + ABS(AIMAG(CA)) IF(N.LE.0.OR.CANORM.EQ.0.E0) RETURN IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20 KX = 1 KY = 1 IF(INCX.LT.0) KX = 1+(1-N)*INCX IF(INCY.LT.0) KY = 1+(1-N)*INCY DO 10 I = 1,N CY(KY) = CY(KY) + CA*CX(KX) KX = KX + INCX KY = KY + INCY 10 CONTINUE RETURN 20 CONTINUE NS = N*INCX DO 30 I=1,NS,INCX CY(I) = CA*CX(I) + CY(I) 30 CONTINUE RETURN END SUBROUTINE SROTG(SA,SB,SC,SS) C C DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08 C C C CONSTRUCT THE GIVENS TRANSFORMATION C C ( SC SS ) C G = ( ) , SC**2 + SS**2 = 1 , C (-SS SC ) C C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (SA,SB)**T . C C THE QUANTITY R = (+/-)SQRT(SA**2 + SB**2) OVERWRITES SA IN C STORAGE. THE VALUE OF SB IS OVERWRITTEN BY A VALUE Z WHICH C ALLOWS SC AND SS TO BE RECOVERED BY THE FOLLOWING ALGORITHM: C IF Z=1 SET SC=0. AND SS=1. C IF ABS(Z) .LT. 1 SET SC=SQRT(1-Z**2) AND SS=Z C IF ABS(Z) .GT. 1 SET SC=1/Z AND SS=SQRT(1-SC**2) C C NORMALLY, THE SUBPROGRAM SROT(N,SX,INCX,SY,INCY,SC,SS) WILL C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. C C ------------------------------------------------------------------ C IF (ABS(SA) .LE. ABS(SB)) GO TO 10 C C *** HERE ABS(SA) .GT. ABS(SB) *** C U = SA + SA V = SB / U C C NOTE THAT U AND R HAVE THE SIGN OF SA C R = SQRT(.25 + V**2) * U C C NOTE THAT SC IS POSITIVE C SC = SA / R SS = V * (SC + SC) SB = SS SA = R RETURN C C *** HERE ABS(SA) .LE. ABS(SB) *** C 10 IF (SB .EQ. 0.) GO TO 20 U = SB + SB V = SA / U C C NOTE THAT U AND R HAVE THE SIGN OF SB C (R IS IMMEDIATELY STORED IN SA) C SA = SQRT(.25 + V**2) * U C C NOTE THAT SS IS POSITIVE C SS = SB / SA SC = V * (SS + SS) IF (SC .EQ. 0.) GO TO 15 SB = 1. / SC RETURN 15 SB = 1. RETURN C C *** HERE SA = SB = 0. *** C 20 SC = 1. SS = 0. RETURN C END SUBROUTINE DROTG(DA,DB,DC,DS) C C DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08 C C C CONSTRUCT THE GIVENS TRANSFORMATION C C ( DC DS ) C G = ( ) , DC**2 + DS**2 = 1 , C (-DS DC ) C C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . C C THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN C STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH C ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM: C IF Z=1 SET DC=0.D0 AND DS=1.D0 C IF DABS(Z) .LT. 1 SET DC=DSQRT(1-Z**2) AND DS=Z C IF DABS(Z) .GT. 1 SET DC=1/Z AND DS=DSQRT(1-DC**2) C C NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. C C ------------------------------------------------------------------ C DOUBLE PRECISION DA, DB, DC, DS, U, V, R IF (DABS(DA) .LE. DABS(DB)) GO TO 10 C C *** HERE DABS(DA) .GT. DABS(DB) *** C U = DA + DA V = DB / U C C NOTE THAT U AND R HAVE THE SIGN OF DA C R = DSQRT(.25D0 + V**2) * U C C NOTE THAT DC IS POSITIVE C DC = DA / R DS = V * (DC + DC) DB = DS DA = R RETURN C C *** HERE DABS(DA) .LE. DABS(DB) *** C 10 IF (DB .EQ. 0.D0) GO TO 20 U = DB + DB V = DA / U C C NOTE THAT U AND R HAVE THE SIGN OF DB C (R IS IMMEDIATELY STORED IN DA) C DA = DSQRT(.25D0 + V**2) * U C C NOTE THAT DS IS POSITIVE C DS = DB / DA DC = V * (DS + DS) IF (DC .EQ. 0.D0) GO TO 15 DB = 1.D0 / DC RETURN 15 DB = 1.D0 RETURN C C *** HERE DA = DB = 0.D0 *** C 20 DC = 1.D0 DS = 0.D0 RETURN C END SUBROUTINE SROT(N,SX,INCX,SY,INCY,SC,SS) C C MULTIPLY THE 2 X 2 MATRIX ( SC SS) TIMES THE 2 X N MATRIX (SX**T) C (-SS SC) (SY**T) C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN C SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. REAL SX,SY,SC,SS,ZERO,ONE,W,Z DIMENSION SX(1),SY(1) C DATA ZERO,ONE/0.E0,1.E0/ IF(N .LE. 0 .OR. (SS .EQ. ZERO .AND. SC .EQ. ONE)) GO TO 40 IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 C NSTEPS=INCX*N DO 10 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=SC*W+SS*Z SY(I)=-SS*W+SC*Z 10 CONTINUE GO TO 40 C 20 CONTINUE KX=1 KY=1 C IF(INCX .LT. 0) KX=1-(N-1)*INCX IF(INCY .LT. 0) KY=1-(N-1)*INCY C DO 30 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=SC*W+SS*Z SY(KY)=-SS*W+SC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE C RETURN END SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS) C C MULTIPLY THE 2 X 2 MATRIX ( DC DS) TIMES THE 2 X N MATRIX (DX**T) C (-DS DC) (DY**T) C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR DY USING LY AND INCY. DOUBLE PRECISION DX,DY,DC,DS,ZERO,ONE,W,Z DIMENSION DX(1),DY(1) C DATA ZERO,ONE/0.D0,1.D0/ IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 C NSTEPS=INCX*N DO 10 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=DC*W+DS*Z DY(I)=-DS*W+DC*Z 10 CONTINUE GO TO 40 C 20 CONTINUE KX=1 KY=1 C IF(INCX .LT. 0) KX=1-(N-1)*INCX IF(INCY .LT. 0) KY=1-(N-1)*INCY C DO 30 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=DC*W+DS*Z DY(KY)=-DS*W+DC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE C RETURN END SUBROUTINE SROTMG (SD1,SD2,SX1,SY1,SPARAM) C C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS C THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* C SY2)**T. C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 C C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) C H=( ) ( ) ( ) ( ) C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). C LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 C RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE C VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) C C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE C OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. C DIMENSION SPARAM(5) C DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/ DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ C Change from Remark TOMS 30(1) March 2004 pp86-94 C IF(.NOT. SD1 .LT. ZERO) GO TO 10 IF((SD1 .GT. ZERO) .AND. (SD2 .NE. ZERO)) GO TO 10 C GO ZERO-H-D-AND-SX1.. GO TO 60 10 CONTINUE C CASE-SD1-NONNEGATIVE SP2=SD2*SY1 IF(.NOT. SP2 .EQ. ZERO) GO TO 20 SFLAG=-TWO GO TO 260 C REGULAR-CASE.. 20 CONTINUE SP1=SD1*SX1 SQ2=SP2*SY1 SQ1=SP1*SX1 C IF(.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40 SH21=-SY1/SX1 SH12=SP2/SP1 C SU=ONE-SH12*SH21 C IF(.NOT. SU .LE. ZERO) GO TO 30 C GO ZERO-H-D-AND-SX1.. GO TO 60 30 CONTINUE SFLAG=ZERO SD1=SD1/SU SD2=SD2/SU SX1=SX1*SU C GO SCALE-CHECK.. GO TO 100 40 CONTINUE IF(.NOT. SQ2 .LT. ZERO) GO TO 50 C GO ZERO-H-D-AND-SX1.. GO TO 60 50 CONTINUE SFLAG=ONE SH11=SP1/SP2 SH22=SX1/SY1 SU=ONE+SH11*SH22 STEMP=SD2/SU SD2=SD1/SU SD1=STEMP SX1=SY1*SU C GO SCALE-CHECK GO TO 100 C PROCEDURE..ZERO-H-D-AND-SX1.. 60 CONTINUE C Change from Remark TOMS 30(1) March 2004 pp86-94 C SFLAG=-ONE SFLAG=2 SH11=ZERO SH12=ZERO SH21=ZERO SH22=ZERO C SD1=ZERO SD2=ZERO SX1=ZERO C RETURN.. GO TO 220 C PROCEDURE..FIX-H.. 70 CONTINUE IF(.NOT. SFLAG .GE. ZERO) GO TO 90 C IF(.NOT. SFLAG .EQ. ZERO) GO TO 80 SH11=ONE SH22=ONE SFLAG=-ONE GO TO 90 80 CONTINUE SH21=-ONE SH12=ONE SFLAG=-ONE 90 CONTINUE GO TO IGO,(120,150,180,210) C PROCEDURE..SCALE-CHECK 100 CONTINUE 110 CONTINUE IF(.NOT. SD1 .LE. RGAMSQ) GO TO 130 IF(SD1 .EQ. ZERO) GO TO 160 ASSIGN 120 TO IGO C FIX-H.. GO TO 70 120 CONTINUE SD1=SD1*GAM**2 SX1=SX1/GAM SH11=SH11/GAM SH12=SH12/GAM GO TO 110 130 CONTINUE 140 CONTINUE IF(.NOT. SD1 .GE. GAMSQ) GO TO 160 ASSIGN 150 TO IGO C FIX-H.. GO TO 70 150 CONTINUE SD1=SD1/GAM**2 SX1=SX1*GAM SH11=SH11*GAM SH12=SH12*GAM GO TO 140 160 CONTINUE 170 CONTINUE IF(.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190 IF(SD2 .EQ. ZERO) GO TO 220 ASSIGN 180 TO IGO C FIX-H.. GO TO 70 180 CONTINUE SD2=SD2*GAM**2 SH21=SH21/GAM SH22=SH22/GAM GO TO 170 190 CONTINUE 200 CONTINUE IF(.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220 ASSIGN 210 TO IGO C FIX-H.. GO TO 70 210 CONTINUE SD2=SD2/GAM**2 SH21=SH21*GAM SH22=SH22*GAM GO TO 200 220 CONTINUE IF(SFLAG)250,230,240 230 CONTINUE SPARAM(3)=SH21 SPARAM(4)=SH12 GO TO 260 240 CONTINUE SPARAM(2)=SH11 SPARAM(5)=SH22 GO TO 260 250 CONTINUE SPARAM(2)=SH11 SPARAM(3)=SH21 SPARAM(4)=SH12 SPARAM(5)=SH22 260 CONTINUE SPARAM(1)=SFLAG RETURN END SUBROUTINE DROTM (N,DX,INCX,DY,INCY,DPARAM) C C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX C C (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN C (DY**T) C C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 C C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) C H=( ) ( ) ( ) ( ) C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). C SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. C DOUBLE PRECISION DFLAG,DH12,DH22,DX,TWO,Z,DH11,DH21, 1 DPARAM,DY,W,ZERO DIMENSION DX(1),DY(1),DPARAM(5) DATA ZERO,TWO/0.D0,2.D0/ C DFLAG=DPARAM(1) IF(N .LE. 0 .OR.(DFLAG+TWO.EQ.ZERO)) GO TO 140 IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 C NSTEPS=N*INCX IF(DFLAG) 50,10,30 10 CONTINUE DH12=DPARAM(4) DH21=DPARAM(3) DO 20 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=W+Z*DH12 DY(I)=W*DH21+Z 20 CONTINUE GO TO 140 30 CONTINUE DH11=DPARAM(2) DH22=DPARAM(5) DO 40 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=W*DH11+Z DY(I)=-W+DH22*Z 40 CONTINUE GO TO 140 50 CONTINUE DH11=DPARAM(2) DH12=DPARAM(4) DH21=DPARAM(3) DH22=DPARAM(5) DO 60 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=W*DH11+Z*DH12 DY(I)=W*DH21+Z*DH22 60 CONTINUE GO TO 140 70 CONTINUE KX=1 KY=1 IF(INCX .LT. 0) KX=1+(1-N)*INCX IF(INCY .LT. 0) KY=1+(1-N)*INCY C IF(DFLAG)120,80,100 80 CONTINUE DH12=DPARAM(4) DH21=DPARAM(3) DO 90 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=W+Z*DH12 DY(KY)=W*DH21+Z KX=KX+INCX KY=KY+INCY 90 CONTINUE GO TO 140 100 CONTINUE DH11=DPARAM(2) DH22=DPARAM(5) DO 110 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=W*DH11+Z DY(KY)=-W+DH22*Z KX=KX+INCX KY=KY+INCY 110 CONTINUE GO TO 140 120 CONTINUE DH11=DPARAM(2) DH12=DPARAM(4) DH21=DPARAM(3) DH22=DPARAM(5) DO 130 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=W*DH11+Z*DH12 DY(KY)=W*DH21+Z*DH22 KX=KX+INCX KY=KY+INCY 130 CONTINUE 140 CONTINUE RETURN END SUBROUTINE DROTMG (DD1,DD2,DX1,DY1,DPARAM) C C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS C THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* C DY2)**T. C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 C C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) C H=( ) ( ) ( ) ( ) C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). C LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 C RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE C VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) C C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE C OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. C DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2, 1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1, 2 DTEMP,DX1,TWO DIMENSION DPARAM(5) C DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/ DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ C Change from Remark TOMS 30(1) March 2004 pp86-94 C IF(.NOT. DD1 .LT. ZERO) GO TO 10 IF((DD1 .GT. ZERO) .AND. (DD2 .NE. ZERO)) GO TO 10 C GO ZERO-H-D-AND-DX1.. GO TO 60 10 CONTINUE C CASE-DD1-NONNEGATIVE DP2=DD2*DY1 IF(.NOT. DP2 .EQ. ZERO) GO TO 20 DFLAG=-TWO GO TO 260 C REGULAR-CASE.. 20 CONTINUE DP1=DD1*DX1 DQ2=DP2*DY1 DQ1=DP1*DX1 C IF(.NOT. DABS(DQ1) .GT. DABS(DQ2)) GO TO 40 DH21=-DY1/DX1 DH12=DP2/DP1 C DU=ONE-DH12*DH21 C IF(.NOT. DU .LE. ZERO) GO TO 30 C GO ZERO-H-D-AND-DX1.. GO TO 60 30 CONTINUE DFLAG=ZERO DD1=DD1/DU DD2=DD2/DU DX1=DX1*DU C GO SCALE-CHECK.. GO TO 100 40 CONTINUE IF(.NOT. DQ2 .LT. ZERO) GO TO 50 C GO ZERO-H-D-AND-DX1.. GO TO 60 50 CONTINUE DFLAG=ONE DH11=DP1/DP2 DH22=DX1/DY1 DU=ONE+DH11*DH22 DTEMP=DD2/DU DD2=DD1/DU DD1=DTEMP DX1=DY1*DU C GO SCALE-CHECK GO TO 100 C PROCEDURE..ZERO-H-D-AND-DX1.. 60 CONTINUE C Change from Remark TOMS 30(1) March 2004 pp86-94 C DFLAG=-ONE DFLAG=2 DH11=ZERO DH12=ZERO DH21=ZERO DH22=ZERO C DD1=ZERO DD2=ZERO DX1=ZERO C RETURN.. GO TO 220 C PROCEDURE..FIX-H.. 70 CONTINUE IF(.NOT. DFLAG .GE. ZERO) GO TO 90 C IF(.NOT. DFLAG .EQ. ZERO) GO TO 80 DH11=ONE DH22=ONE DFLAG=-ONE GO TO 90 80 CONTINUE DH21=-ONE DH12=ONE DFLAG=-ONE 90 CONTINUE GO TO IGO,(120,150,180,210) C PROCEDURE..SCALE-CHECK 100 CONTINUE 110 CONTINUE IF(.NOT. DD1 .LE. RGAMSQ) GO TO 130 IF(DD1 .EQ. ZERO) GO TO 160 ASSIGN 120 TO IGO C FIX-H.. GO TO 70 120 CONTINUE DD1=DD1*GAM**2 DX1=DX1/GAM DH11=DH11/GAM DH12=DH12/GAM GO TO 110 130 CONTINUE 140 CONTINUE IF(.NOT. DD1 .GE. GAMSQ) GO TO 160 ASSIGN 150 TO IGO C FIX-H.. GO TO 70 150 CONTINUE DD1=DD1/GAM**2 DX1=DX1*GAM DH11=DH11*GAM DH12=DH12*GAM GO TO 140 160 CONTINUE 170 CONTINUE IF(.NOT. DABS(DD2) .LE. RGAMSQ) GO TO 190 IF(DD2 .EQ. ZERO) GO TO 220 ASSIGN 180 TO IGO C FIX-H.. GO TO 70 180 CONTINUE DD2=DD2*GAM**2 DH21=DH21/GAM DH22=DH22/GAM GO TO 170 190 CONTINUE 200 CONTINUE IF(.NOT. DABS(DD2) .GE. GAMSQ) GO TO 220 ASSIGN 210 TO IGO C FIX-H.. GO TO 70 210 CONTINUE DD2=DD2/GAM**2 DH21=DH21*GAM DH22=DH22*GAM GO TO 200 220 CONTINUE IF(DFLAG)250,230,240 230 CONTINUE DPARAM(3)=DH21 DPARAM(4)=DH12 GO TO 260 240 CONTINUE DPARAM(2)=DH11 DPARAM(5)=DH22 GO TO 260 250 CONTINUE DPARAM(2)=DH11 DPARAM(3)=DH21 DPARAM(4)=DH12 DPARAM(5)=DH22 260 CONTINUE DPARAM(1)=DFLAG RETURN END SUBROUTINE SROTM (N,SX,INCX,SY,INCY,SPARAM) C C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX C C (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN C (DX**T) C C SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 C C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) C H=( ) ( ) ( ) ( ) C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). C SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. C DIMENSION SX(1),SY(1),SPARAM(5) DATA ZERO,TWO/0.E0,2.E0/ C SFLAG=SPARAM(1) IF(N .LE. 0 .OR.(SFLAG+TWO.EQ.ZERO)) GO TO 140 IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 C NSTEPS=N*INCX IF(SFLAG) 50,10,30 10 CONTINUE SH12=SPARAM(4) SH21=SPARAM(3) DO 20 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=W+Z*SH12 SY(I)=W*SH21+Z 20 CONTINUE GO TO 140 30 CONTINUE SH11=SPARAM(2) SH22=SPARAM(5) DO 40 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=W*SH11+Z SY(I)=-W+SH22*Z 40 CONTINUE GO TO 140 50 CONTINUE SH11=SPARAM(2) SH12=SPARAM(4) SH21=SPARAM(3) SH22=SPARAM(5) DO 60 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=W*SH11+Z*SH12 SY(I)=W*SH21+Z*SH22 60 CONTINUE GO TO 140 70 CONTINUE KX=1 KY=1 IF(INCX .LT. 0) KX=1+(1-N)*INCX IF(INCY .LT. 0) KY=1+(1-N)*INCY C IF(SFLAG)120,80,100 80 CONTINUE SH12=SPARAM(4) SH21=SPARAM(3) DO 90 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=W+Z*SH12 SY(KY)=W*SH21+Z KX=KX+INCX KY=KY+INCY 90 CONTINUE GO TO 140 100 CONTINUE SH11=SPARAM(2) SH22=SPARAM(5) DO 110 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=W*SH11+Z SY(KY)=-W+SH22*Z KX=KX+INCX KY=KY+INCY 110 CONTINUE GO TO 140 120 CONTINUE SH11=SPARAM(2) SH12=SPARAM(4) SH21=SPARAM(3) SH22=SPARAM(5) DO 130 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=W*SH11+Z*SH12 SY(KY)=W*SH21+Z*SH22 KX=KX+INCX KY=KY+INCY 130 CONTINUE 140 CONTINUE RETURN END SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) C C COPY SINGLE PRECISION SX TO SINGLE PRECISION SY. C FOR I = 0 TO N-1, COPY SX(LX+I*INCX) TO SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C REAL SX(1),SY(1) IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SY(I) = SX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 SY(I) = SX(I) SY(I + 1) = SX(I + 1) SY(I + 2) = SX(I + 2) SY(I + 3) = SX(I + 3) SY(I + 4) = SX(I + 4) SY(I + 5) = SX(I + 5) SY(I + 6) = SX(I + 6) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SY(I) = SX(I) 70 CONTINUE RETURN END SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) C C COPY DOUBLE PRECISION DX TO DOUBLE PRECISION DY. C FOR I = 0 TO N-1, COPY DX(LX+I*INCX) TO DY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C DOUBLE PRECISION DX(1),DY(1) IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 DY(I) = DX(I) DY(I + 1) = DX(I + 1) DY(I + 2) = DX(I + 2) DY(I + 3) = DX(I + 3) DY(I + 4) = DX(I + 4) DY(I + 5) = DX(I + 5) DY(I + 6) = DX(I + 6) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS=N*INCX DO 70 I=1,NS,INCX DY(I) = DX(I) 70 CONTINUE RETURN END SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) C C COPY COMPLEX CX TO COMPLEX CY. C FOR I = 0 TO N-1, COPY CX(LX+I*INCX) TO CY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C COMPLEX CX(1),CY(1) C IF(N .LE. 0)RETURN IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20 KX = 1 KY = 1 IF(INCX.LT.0) KX = 1+(1-N)*INCX IF(INCY.LT.0) KY = 1+(1-N)*INCY DO 10 I = 1,N CY(KY) = CX(KX) KX = KX + INCX KY = KY + INCY 10 CONTINUE RETURN 20 CONTINUE NS = N*INCX DO 30 I=1,NS,INCX CY(I) = CX(I) 30 CONTINUE RETURN END SUBROUTINE SSWAP (N,SX,INCX,SY,INCY) C C INTERCHANGE SINGLE PRECISION SX AND SINGLE PRECISION SY. C FOR I = 0 TO N-1, INTERCHANGE SX(LX+I*INCX) AND SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C REAL SX(1),SY(1),STEMP1,STEMP2,STEMP3 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N STEMP1 = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. C 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 STEMP1 = SX(I) STEMP2 = SX(I+1) STEMP3 = SX(I+2) SX(I) = SY(I) SX(I+1) = SY(I+1) SX(I+2) = SY(I+2) SY(I) = STEMP1 SY(I+1) = STEMP2 SY(I+2) = STEMP3 50 CONTINUE RETURN 60 CONTINUE C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C NS = N*INCX DO 70 I=1,NS,INCX STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 70 CONTINUE RETURN END SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) C C INTERCHANGE DOUBLE PRECISION DX AND DOUBLE PRECISION DY. C FOR I = 0 TO N-1, INTERCHANGE DX(LX+I*INCX) AND DY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C DOUBLE PRECISION DX(1),DY(1),DTEMP1,DTEMP2,DTEMP3 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP1 = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. C 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 DTEMP1 = DX(I) DTEMP2 = DX(I+1) DTEMP3 = DX(I+2) DX(I) = DY(I) DX(I+1) = DY(I+1) DX(I+2) = DY(I+2) DY(I) = DTEMP1 DY(I+1) = DTEMP2 DY(I+2) = DTEMP3 50 CONTINUE RETURN 60 CONTINUE C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C NS = N*INCX DO 70 I=1,NS,INCX DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 70 CONTINUE RETURN END SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) C C INTERCHANGE COMPLEX CX AND COMPLEX CY C FOR I = 0 TO N-1, INTERCHANGE CX(LX+I*INCX) AND CY(LY+I*INCY), C WHERE LX = 1 IF INCX .GT. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C COMPLEX CX(1),CY(1),CTEMP C IF(N .LE. 0)RETURN IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20 KX = 1 KY = 1 IF(INCX.LT.0) KX = 1+(1-N)*INCX IF(INCY.LT.0) KY = 1+(1-N)*INCY DO 10 I = 1,N CTEMP = CX(KX) CX(KX) = CY(KY) CY(KY) = CTEMP KX = KX + INCX KY = KY + INCY 10 CONTINUE RETURN 20 CONTINUE NS = N*INCX DO 30 I=1,NS,INCX CTEMP = CX(I) CX(I) = CY(I) CY(I) = CTEMP 30 CONTINUE RETURN END REAL FUNCTION SNRM2 ( N, SX, INCX) INTEGER NEXT REAL SX(1), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE DATA ZERO, ONE /0.0E0, 1.0E0/ C C EUCLIDEAN NORM OF THE N-VECTOR STORED IN SX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON, 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / C IF(N .GT. 0) GO TO 10 SNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( SX(I) .EQ. ZERO) GO TO 200 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / SX(I)) / SX(I) 105 XMAX = ABS(SX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( ABS(SX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( ABS(SX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / SX(I))**2 XMAX = ABS(SX(I)) GO TO 200 C 115 SUM = SUM + (SX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J =I,NN,INCX IF(ABS(SX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + SX(J)**2 SNRM2 = SQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C SNRM2 = XMAX * SQRT(SUM) 300 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) INTEGER NEXT DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE DATA ZERO, ONE /0.0D0, 1.0D0/ C C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON, 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C IF(N .GT. 0) GO TO 10 DNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( DX(I) .EQ. ZERO) GO TO 200 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / DX(I)) / DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / DX(I))**2 XMAX = DABS(DX(I)) GO TO 200 C 115 SUM = SUM + (DX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J =I,NN,INCX IF(DABS(DX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + DX(J)**2 DNRM2 = DSQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C DNRM2 = XMAX * DSQRT(SUM) 300 CONTINUE RETURN END REAL FUNCTION SCNRM2( N, CX, INCX) LOGICAL IMAG, SCALE INTEGER NEXT REAL CUTLO, CUTHI, HITEST, SUM, XMAX, ABSX, ZERO, ONE COMPLEX CX(1) DATA ZERO, ONE /0.0E0, 1.0E0/ C C UNITARY NORM OF THE COMPLEX N-VECTOR STORED IN CX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON , 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / C IF(N .GT. 0) GO TO 10 SCNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP DO 210 I=1,NN,INCX ABSX = ABS(REAL(CX(I))) IMAG = .FALSE. GO TO NEXT,(30, 50, 70, 90, 110) 30 IF( ABSX .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT SCALE = .FALSE. C C PHASE 1. SUM IS ZERO C 50 IF( ABSX .EQ. ZERO) GO TO 200 IF( ABSX .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 ASSIGN 110 TO NEXT SUM = (SUM / ABSX) / ABSX 105 SCALE = .TRUE. XMAX = ABSX GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( ABSX .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( ABSX .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / ABSX)**2 XMAX = ABSX GO TO 200 C 115 SUM = SUM + (ABSX/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C 85 ASSIGN 90 TO NEXT SCALE = .FALSE. C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C 90 IF(ABSX .GE. HITEST) GO TO 100 SUM = SUM + ABSX**2 200 CONTINUE C CONTROL SELECTION OF REAL AND IMAGINARY PARTS. C IF(IMAG) GO TO 210 ABSX = ABS(AIMAG(CX(I))) IMAG = .TRUE. GO TO NEXT,( 50, 70, 90, 110 ) C 210 CONTINUE C C END OF MAIN LOOP. C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C SCNRM2 = SQRT(SUM) IF(SCALE) SCNRM2 = SCNRM2 * XMAX 300 CONTINUE RETURN END REAL FUNCTION SASUM(N,SX,INCX) C C RETURNS SUM OF MAGNITUDES OF SINGLE PRECISION SX. C SASUM = SUM FROM 0 TO N-1 OF ABS(SX(1+I*INCX)) C REAL SX(1) SASUM = 0.0E0 IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C NS = N*INCX DO 10 I=1,NS,INCX SASUM = SASUM + ABS(SX(I)) 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. C 20 M = MOD(N,6) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SASUM = SASUM + ABS(SX(I)) 30 CONTINUE IF( N .LT. 6 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 SASUM = SASUM + ABS(SX(I)) + ABS(SX(I + 1)) + ABS(SX(I + 2)) $ + ABS(SX(I + 3)) + ABS(SX(I + 4)) + ABS(SX(I + 5)) 50 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) C C RETURNS SUM OF MAGNITUDES OF DOUBLE PRECISION DX. C DASUM = SUM FROM 0 TO N-1 OF DABS(DX(1+I*INCX)) C DOUBLE PRECISION DX(1) DASUM = 0.D0 IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C NS = N*INCX DO 10 I=1,NS,INCX DASUM = DASUM + DABS(DX(I)) 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. C 20 M = MOD(N,6) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DASUM = DASUM + DABS(DX(I)) 30 CONTINUE IF( N .LT. 6 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) $ + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) 50 CONTINUE RETURN END FUNCTION SCASUM(N,CX,INCX) C RETURNS SUMS OF MAGNITUDES OF REAL AND IMAGINARY PARTS OF C COMPONENTS OF CX. NOTE THAT THIS IS NOT THE L1 NORM OF CX. C CASUM = SUM FROM 0 TO N-1 OF ABS(REAL(CX(1+I*INCX))) + C ABS(IMAG(CX(1+I*INCX))) C COMPLEX CX(1) C SCASUM=0. IF(N .LE. 0) RETURN NS = N*INCX DO 10 I=1,NS,INCX SCASUM = SCASUM + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) 10 CONTINUE RETURN END SUBROUTINE SSCAL(N,SA,SX,INCX) C C REPLACE SINGLE PRECISION SX BY SINGLE PRECISION SA*SX. C FOR I = 0 TO N-1, REPLACE SX(1+I*INCX) WITH SA * SX(1+I*INCX) C REAL SA,SX(1) IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C NS = N*INCX DO 10 I = 1,NS,INCX SX(I) = SA*SX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SX(I) = SA*SX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SX(I) = SA*SX(I) SX(I + 1) = SA*SX(I + 1) SX(I + 2) = SA*SX(I + 2) SX(I + 3) = SA*SX(I + 3) SX(I + 4) = SA*SX(I + 4) 50 CONTINUE RETURN END SUBROUTINE DSCAL(N,DA,DX,INCX) C C REPLACE DOUBLE PRECISION DX BY DOUBLE PRECISION DA*DX. C FOR I = 0 TO N-1, REPLACE DX(1+I*INCX) WITH DA * DX(1+I*INCX) C DOUBLE PRECISION DA,DX(1) IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C NS = N*INCX DO 10 I = 1,NS,INCX DX(I) = DA*DX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I + 1) = DA*DX(I + 1) DX(I + 2) = DA*DX(I + 2) DX(I + 3) = DA*DX(I + 3) DX(I + 4) = DA*DX(I + 4) 50 CONTINUE RETURN END SUBROUTINE CSCAL(N,CA,CX,INCX) C C REPLACE COMPLEX CX BY COMPLEX CA*CX. C FOR I = 0 TO N-1, REPLACE CX(1+I*INCX) WITH CA * CX(1+I*INCX) C COMPLEX CA,CX(1) C IF(N .LE. 0) RETURN NS = N*INCX DO 10 I = 1,NS,INCX CX(I) = CA*CX(I) 10 CONTINUE RETURN END SUBROUTINE CSSCAL(N,SA,CX,INCX) C C REPLACE COMPLEX CX BY (SINGLE PRECISION SA) * (COMPLEX CX) C FOR I = 0 TO N-1, REPLACE CX(1+I*INCX) WITH SA * CX(1+I*INCX) C COMPLEX CX(1) REAL SA C IF(N .LE. 0) RETURN NS = N*INCX DO 10 I = 1,NS,INCX CX(I) = SA*CX(I) 10 CONTINUE RETURN END INTEGER FUNCTION ISAMAX(N,SX,INCX) C C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF SINGLE PRECISION SX. C ISAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(SX(1-INCX+I*INCX)) C REAL SX(1),SMAX,XMAG ISAMAX = 0 IF(N.LE.0) RETURN ISAMAX = 1 IF(N.LE.1)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C SMAX = ABS(SX(1)) NS = N*INCX II = 1 DO 10 I=1,NS,INCX XMAG = ABS(SX(I)) IF(XMAG.LE.SMAX) GO TO 5 ISAMAX = II SMAX = XMAG 5 II = II + 1 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C 20 SMAX = ABS(SX(1)) DO 30 I = 2,N XMAG = ABS(SX(I)) IF(XMAG.LE.SMAX) GO TO 30 ISAMAX = I SMAX = XMAG 30 CONTINUE RETURN END INTEGER FUNCTION IDAMAX(N,DX,INCX) C C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX. C IDAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(DX(1-INCX+I*INCX)) C DOUBLE PRECISION DX(1),DMAX,XMAG IDAMAX = 0 IF(N.LE.0) RETURN IDAMAX = 1 IF(N.LE.1)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C DMAX = DABS(DX(1)) NS = N*INCX II = 1 DO 10 I = 1,NS,INCX XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 5 IDAMAX = II DMAX = XMAG 5 II = II + 1 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C 20 DMAX = DABS(DX(1)) DO 30 I = 2,N XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 30 IDAMAX = I DMAX = XMAG 30 CONTINUE RETURN END INTEGER FUNCTION ICAMAX(N,CX,INCX) C C RETURNS THE INDEX OF THE COMPONENT OF CX HAVING THE C LARGEST SUM OF MAGNITUDES OF REAL AND IMAGINARY PARTS. C ICAMAX = FIRST I, I = 1 TO N, TO MINIMIZE C ABS(REAL(CX(1-INCX+I*INCX))) + ABS(IMAG(CX(1-INCX+I*INCX))) C COMPLEX CX(1) C ICAMAX = 0 IF(N.LE.0) RETURN ICAMAX = 1 IF(N .LE. 1) RETURN NS = N*INCX II = 1 SUMMAX = ABS(REAL(CX(1))) + ABS(AIMAG(CX(1))) DO 20 I=1,NS,INCX SUMRI = ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) IF(SUMMAX.GE.SUMRI) GO TO 10 SUMMAX = SUMRI ICAMAX = II 10 II = II + 1 20 CONTINUE RETURN END SUBROUTINE DTEST(LEN,DCOMP,DTRUE,DSIZE,DFAC) C1 ********************************* DTEST ************************** C C THIS SUBR COMPARES ARRAYS DCOMP() AND DTRUE() OF LENGTH LEN TO C SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY DFAC, ARE C NEGLIGIBLE. C C C. L. LAWSON, JPL, 1974 DEC 10 C2 COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS LOGICAL PASS DOUBLE PRECISION DCOMP(LEN),DTRUE(LEN),DSIZE(LEN),DFAC,DDIFF,DD C DO 10 I=1,LEN DD = DCOMP(I)-DTRUE(I) IF(DDIFF(DABS(DSIZE(I))+DABS(DFAC*DD),DABS(DSIZE(I))) .EQ. 0.D0) * GO TO 10 C C HERE DCOMP(I) IS NOT CLOSE TO DTRUE(I). C IF(.NOT. PASS) GO TO 5 C PRINT FAIL MESSAGE AND HEADER. PASS = .FALSE. WRITE(NPRINT,1000) WRITE(NPRINT,1001) 5 WRITE(NPRINT,1002) ICASE,N,INCX,INCY,MODE,I, * DCOMP(I),DTRUE(I),DD,DSIZE(I) 10 CONTINUE RETURN 1000 FORMAT(1H+,39X,4HFAIL) 1001 FORMAT(26H0CASE N INCX INCY MODE I, 1 29X,7HCOMP(I),29X,7HTRUE(I),2X,10HDIFFERENCE, 2 5X,7HSIZE(I)/1X) 1002 FORMAT(1X,I4,I3,3I5,I3,2D36.18,2D12.4) END FUNCTION SDIFF(SA,SB) C1 ********************************* SDIFF ************************** C COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 C2 SDIFF=SA-SB RETURN END DOUBLE PRECISION FUNCTION DDIFF(DA,DB) C1 ********************************* DDIFF ************************** C COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 C2 DOUBLE PRECISION DA,DB DDIFF=DA-DB RETURN END SUBROUTINE STEST1(SCOMP1, STRUE1, SSIZE, SFAC) C1 ************************* STEST1 ***************************** C C THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN C REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE C ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. C C C.L. LAWSON, JPL, 1978 DEC 6 C2 REAL SCOMP(1),STRUE(1),SSIZE(1) C SCOMP(1) = SCOMP1 STRUE(1) = STRUE1 CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) C RETURN END SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) C1 **************************** CTEST ***************************** C C C.L. LAWSON, JPL, 1978 DEC 6 C2 COMPLEX CCOMP(LEN),CTRUE(LEN),CSIZE(LEN) REAL SFAC REAL SCOMP(20),STRUE(20),SSIZE(20) C DO 10 I=1,LEN SCOMP(2*I-1) = REAL(CCOMP(I)) SCOMP(2*I) = AIMAG(CCOMP(I)) STRUE(2*I-1) = REAL(CTRUE(I)) STRUE(2*I) = AIMAG(CTRUE(I)) SSIZE(2*I-1) = REAL(CSIZE(I)) SSIZE(2*I) = AIMAG(CSIZE(I)) 10 CONTINUE C CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) RETURN END SUBROUTINE DTEST1(DCOMP1, DTRUE1, DSIZE, DFAC) C1 ************************* DTEST1 ***************************** C C THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN C REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE C ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. C C C.L. LAWSON, JPL, 1978 DEC 6 C2 DOUBLE PRECISION DCOMP1, DTRUE1, DFAC DOUBLE PRECISION DCOMP(1),DTRUE(1),DSIZE(1) C DCOMP(1) = DCOMP1 DTRUE(1) = DTRUE1 CALL DTEST(1,DCOMP,DTRUE,DSIZE,DFAC) C RETURN END SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) C1 ********************************* STEST ************************** C C THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO C SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE C NEGLIGIBLE. C C C. L. LAWSON, JPL, 1974 DEC 10 C2 REAL SCOMP(LEN),STRUE(LEN),SSIZE(LEN),SFAC,SDIFF,SD LOGICAL PASS COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS C DO 10 I=1,LEN SD = SCOMP(I)-STRUE(I) IF( SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD), ABS(SSIZE(I))) .EQ. 0.) * GO TO 10 C C HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). C IF(.NOT. PASS) GO TO 5 C PRINT FAIL MESSAGE AND HEADER. PASS = .FALSE. WRITE(NPRINT,1000) WRITE(NPRINT,1001) 5 WRITE(NPRINT,1002) ICASE,N,INCX,INCY,MODE,I, * SCOMP(I),STRUE(I),SD,SSIZE(I) 10 CONTINUE RETURN 1000 FORMAT(1H+,39X,4HFAIL) 1001 FORMAT(26H0CASE N INCX INCY MODE I, 1 29X,7HCOMP(I),29X,7HTRUE(I),2X,10HDIFFERENCE, 2 5X,7HSIZE(I)/1X) 1002 FORMAT(1X,I4,I3,3I5,I3,2E36.8,2E12.4) END SUBROUTINE ITEST1(ICOMP,ITRUE) C1 ********************************* ITEST1 ************************* C C THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR C EQUALITY. C C. L. LAWSON, JPL, 1974 DEC 10 C2 COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS LOGICAL PASS INTEGER ICOMP, ITRUE C IF(ICOMP .EQ. ITRUE) GO TO 10 C C HERE ICOMP IS NOT EQUAL TO ITRUE. C IF(.NOT. PASS) GO TO 5 C PRINT FAIL MESSAGE AND HEADER. PASS = .FALSE. WRITE(NPRINT,1000) WRITE(NPRINT,1001) 5 ID=ICOMP-ITRUE WRITE(NPRINT,1002) ICASE,N,INCX,INCY,MODE,ICOMP,ITRUE,ID 10 CONTINUE RETURN 1000 FORMAT(1H+,39X,4HFAIL) 1001 FORMAT(26H0CASE N INCX INCY MODE , 1 29X,7HCOMP ,29X,7HTRUE ,2X,10HDIFFERENCE/1X) 1002 FORMAT(1X,I4,I3,3I5,2I36,I12) END DOUBLE PRECISION FUNCTION DQDOTI(N,DB,QC,DX,INCX,DY,INCY) C D.P. DOT PRODUCT WITH EXTENDED PRECISION ACCUMULATION (AND RESULT) C QC AND DQDOTI ARE SET = DB + SUM FOR I = 0 TO N-1 OF C DX(LX+I*INCX) * DY(LY+I*INCY), WHERE QC IS AN EXTENDED C PRECISION RESULT WHICH CAN BE USED AS INPUT TO DQDOTA, C AND LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. THE MP PACKAGE BY C RICHARD P. BRENT IS USED FOR THE EXTENDED PRECISION ARITHMETIC. C C FRED T. KROGH, JPL, 1977, JUNE 1 C2 DOUBLE PRECISION DX(1), DY(1), DB INTEGER QC(10), QX(10), QY(10) C THE COMMON BLOCK FOR THE MP PACKAGE (MODIFIED TO GIVE IT A NAME) COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(12) DATA I1 / 0 / C IF I1 IS 0 THE MP PACKAGE MUST BE INITIALIZED (MPBLAS SETS I1 = 1) IF (I1 .EQ. 0) CALL MPBLAS(I1) QC(1) = 0 IF (DB .EQ. 0.D0) GO TO 60 CALL MPCDM(DB, QX) CALL MPADD(QC, QX, QC) 60 IF (N .EQ. 0) GO TO 80 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N + 1) * INCX + 1 IF (INCY .LT. 0) IY = (-N + 1) * INCY + 1 DO 70 I = 1,N CALL MPCDM(DX(IX), QX) CALL MPCDM(DY(IY), QY) CALL MPMUL(QX, QY, QX) CALL MPADD(QC, QX, QC) IX = IX + INCX IY = IY + INCY 70 CONTINUE 80 CALL MPCMD(QC, DQDOTI) RETURN END C PROGRAM TBLA C C THIS IS A TEST DRIVER FOR THE BLAS. C THE BLAS (BASIC LINEAR ALGEBRA SUBPROGRAMS) ARE A SET OF C THIRTY-EIGHT FORTRAN CALLABLE SUBPROGRAMS FOR BASIC OPERATIONS C OF NUMERICAL LINEAR ALGEBRA. THIS SOFTWARE PACKAGE IS THE C RESULT OF A VOLUNTARY AND COLLABORATIVE PROJECT OF THE C ACM-SIGNUM COMMITTEE ON BASIC LINEAR ALGEBRA SUBPROGRAMS. C THIS PROJECT WAS CARRIED OUT DURING THE PERIOD 1973-1977. C C THE BLAS ARE DESCRIBED IN THE PAPER, C BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE, C BY C.L.LAWSON, R.J.HANSON, D.R.KINCAID, AND F.T.KROGH, C IN THE ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE,1979. C ALSO APPEARED AS U.TEXAS REPORT CNA-124, JULY, 1977, C AND SANDIA REPORT SAND77-0898J, FEBRUARY, 1978. C C C******************************************************************* C SUMMARY OF FUNCTIONS AND NAMES FOR BLAS C ------------------------------------------------------------------- C FUNCTION PREFIX AND SUFFIX ROOT C ------------------------------------------------------------------- C DOT PRODUCT /SDS- DS- DQ-I DQ-A C-U C-C D- S- -DOT C CONSTANT TIMES A VECTOR PLUS A VECTOR / C- D- S- -AXPY C SET-UP GIVENS ROTATION / D- S- -ROTG C APPLY ROTATION / D- S- -ROT C SET-UP MODIFIED GIVENS ROTATION / D- S- -ROTMG C APPLY MODIFIED ROTATION / D- S- -ROTM C COPY X TO Y / C- D- S- -COPY C SWAP X AND Y / C- D- S- -SWAP C 2-NORM (EUCLIDEAN LENGTH) / SC- D- S- -NRM2 C SUM OF ABSOLUTE VALUES* / SC- D- S- -ASUM C CONSTANT TIMES A VECTOR / CS- C- D- S- -SCAL C INDEX OF ELEMENT HAVING MAX ABS VALUE*/ IC- ID- IS- -AMAX C ------------------------------------------------------------------ C *FOR COMPLEX VECTORS, THESE SUBPROGRAMS USE ABS(REAL)+ABS(IMAG). C C ARGUMENTS DESCRIBING VECTOR STORAGE C ----------------------------------- C C IN THE ARGUMENT LISTS, N DENOTES THE NUMBER OF COMPONENTS OF C A VECTOR, AND INCX DENOTES THE STORAGE SPACING BETWEEN COMPO- C NENTS OF THE X VECTOR. IF INCX .GE. 0 , THEN COMPONENT I OF C VECTOR X IS STORED IN SX(1+(I-1)*INCX) FOR I=1,...,N. C IF INCX .LT. 0 , COMPONENT I OF VECTOR X IS STORED IN C SX(1+(N-I)*IABS(INCX)). THE PARAMETER INCY GIVES THE STORAGE C SPACING FOR THE Y VECTOR. C ONLY POSITIVE VALUES OF INCX ARE ALLOWED FOR SUBPROGRAMS C THAT HAVE ONLY ONE VECTOR ARGUMENT. C C SPECIFICATION OF SUBPROGRAMS C ---------------------------- C DOT PRODUCT SUBPROGRAMS C ----------------------- C (SUM OF PRODUCTS OF COMPONENTS OF VECTORS X AND Y, C IF N .LE. 0 THE INNER PRODUCT WILL BE SET TO ZERO.) C SW = SDOT (N,SX,INCX,SY,INCY) C DW = DSDOT (N,SX,INCX,SY,INCY) C DOUBLE PRECISION ACCUMULATION USED IN DSDOT. C SW = SDSDOT (N,SB,SX,INCX,SY,INCY) C DOUBLE PRECISION ACCUMULATION AND DOUBLE PRECISION SUM OF C RESULTS PLUS SCALAR SB. SINGLE PRECISION RESULTS IN SW. C DW = DDOT (N,DX,INCX,DY,INCY) C DW = DQDOTI (N,DB,QC,DX,INCX,DY,INCY) C EXTENDED PRECISION ACCUMULATION AND EXTENDED PRECISION C SUM OF RESULTS PLUS DOUBLE PRECISION SCALAR DB. EXTENDED PRECISON C RESULTS IN QC AND DOUBLE PRECISION RESULTS IN DW. C DW = DQDOTA (N,DB,QC,DX,INCX,DY,INCY) C EXTENDED PRECISION ACCUMULATION AND EXTENDED PRECISION C SUM OF RESULTS PLUS EXTENDED PRECISION SCALAR QC AND DOUBLE PRECISION C SCALAR DB. EXTENDED PRECISION RESULTS IN QC AND DOUBLE C PRECISON RESULTS IN DW. C CW = CDOTC (N,CX,INCX,CY,INCY) C COMPLEX CONJUGATE OF X VECTOR USED. C CW = CDOTU (N,CX,INCX,CY,INCY) C UNCONJUGATED VECTORS USED. C C ELEMENTARY VECTOR OPERATION (Y = A*X + Y) C ----------------------------------------- C CALL SAXPY (N,SA,SX,INCX,SY,INCY) C CALL DAXPY (N,DA,DX,INCX,DY,INCY) C CALL CAXPY (N,CA,CX,INCX,CY,INCY) C IF A=0 OR IF N .LE. 0 THESE SUBROUTINES RETURN IMMEDIATELY. C C CONSTRUCT GIVENS PLANE ROTATION C ------------------------------- C CALL SROTG (SA,SB,SC,SS) C CALL DROTG (DA,DB,DC,DS) C SEE TOMS PAPER FOR DETAILS. C C APPLY A PLANE ROTATION C ---------------------- C CALL SROT (N,SX,INCX,SY,INCY,SC,SS) C CALL DROT (N,DX,INCX,DY,INCY,DC,DS) C SEE TOMS PAPER FOR DETAILS. C C CONSTRUCT A MODIFIED GIVENS TRANSFORMATION C ------------------------------------------ C CALL SROTMG (SD1,SD2,SB1,SB2,SPARAM) C CALL DROTMG (DD1,DD2,DB1,DB2,DPARAM) C SEE TOMS PAPER FOR DETAILS. C C APPLY A MODIFIED GIVENS TRANSFORMATION C -------------------------------------- C CALL SROTM (N,SX,INCX,SY,INCY,SPARAM) C CALL DROTM (N,DX,INCX,DY,INCY,DPARAM) C SEE TOMS PAPER FOR DETAILS. C C COPY A VECTOR X TO Y C -------------------- C CALL SCOPY (N,SX,INCX,SY,INCY) C CALL DCOPY (N,DX,INCX,DY,INCY) C CALL CCOPY (N,CX,INCX,CY,INCY) C IF N .LE. 0 THESE SUBROUTINES RETURN IMMEDIATELY C C INTERCHANGE VECTORS X AND Y C --------------------------- C CALL SSWAP (N,SX,INCX,SY,INCY) C CALL DSWAP (N,DX,INCX,DY,INCY) C CALL CSWAP (N,CX,INCX,CY,INCY) C IF N .LE. 0 THESE SUBROUTINES RETURN IMMEDIATELY C C EUCLIDEAN LENGTH OR L-2 NORM OF A VECTOR C ---------------------------------------- C (SQUARE ROOT OF SUM OF ABSOLUTE VALUES SQUARED.) C SW = SNRM2 (N,SX,INCX) C DW = DNRM2 (N,DX,INCX) C SW = SCNRM2 (N,CX,INCX) C IF N .LE. THESE SUBROUTINES RETURN IMMEDIATELY C C SUM OF MAGNITUDES OF VECTOR COMPONENTS C -------------------------------------- C (SUM OF ABSOLUTE VALUES OR ABS(REAL)+ABS(IMAG)) C SW = SASUM (N,SX,INCX) C DW = DASUM (N,DX,INCX) C SW = SCASUM (N,CX,INCX) C IF N .LE. 0 THESE FUNCTIONS ARE SET TO 0 AND RETURN IMMEDIATELY. C C VECTOR SCALING (X = A*X) C ------------------------- C CALL SSCAL (N,SA,SX,INCX) C CALL DSCAL (N,DA,DX,INCX) C CALL CSCAL (N,CA,CX,INCX) C CALL CSSCAL (N,SA,CX,INCX) C IF N .LE. 0 THESE SUBPROGRAMS RETURN IMMEDIATELY. C C FIND LARGEST COMPONENT OF A VECTOR C ---------------------------------- C (SMALLEST INDEX OF COMPONENT WITH LARGEST ABSOLUTE VALUE OR C ABS(REAL)+ABS(IMAG).) C IMAX = ISAMAX (N,SX,INCX) C IMAX = IDAMAX (N,DX,INCX) C IMAX = ICAMAX (N,CX,INCX) C IF N .LE. 0 THESE FUNCTIONS SET TO 0 AND RETURN IMMEDIATELY. C C TYPE DECLARATIONS FOR FUNCTION NAMES ARE AS FOLLOWS.. C C INTEGER ISAMAX,IDAMAX,ICAMAX C REAL SDOT,SDSDOT,SNRM2,SCNRM2,SASUM,SCASUM C DOUBLE PRECISION DSDOT,DDOT,DQDOTI,DQDOTA,DASUM C COMPLEX CDOTC,CDOTU C C TYPE AND DIMENSION INFORMATION FOR VARIABLES OCCURRING IN C SUBPROGRAM SPECIFICATIONS ARE AS FOLLOWS.. C C INTEGER N,INXC,INCY,IMAX C REAL SC(MX),SY(MY),SA,SB,SC,SS C REAL SD1,SD2,SB1,SB2,SPARAM(5),SW,QC(10) C DOUBLE PRECISION DX(MX),DY(MY),DA,DB,DC,DS C DOUBLE PRECISION DD1,DD2,DB1,DB2,DPARAM(5),DW C COMPLEX CX(MX),CY(MY),CA,CW C C WHERE MX = MAX(1,N*ABS(INCX)) C MY = MAX(1,N*ABS(INCY)) C C C************* DEMONSTRATION OF USAGE OF BLAS ********************** C C DIMENSION A(20,20),B(15,10),C(20,15),X(10) C INTEGER IP(20) C C MDA = 20 C MDB = 15 C MDC = 20 C C M = 10 C K = 15 C N = 10 C C------------------------------------------------------------------- C PRODUCT OF RECTANGULAR MATRICES C(MXN) = A(MXK)*B(KXN) C C DO 10 J=1,M C DO 10 I=1,N C 10 C(I,J) = SDOT(K,A(I,1),MDA,B(1,J),1) C C------------------------------------------------------------------- C SOLVE NXN UPPER TRANGULAR NONSINGULAR LINEAR SYSTEM AX = B C C DO 20 II=1,N C I = N+1-II C CALL SSCAL(M,1./A(I,I),B(I,1),MDB) C DO 20 J=1,M C 20 CALL SAXPY(I-1,-B(I,J),A(1,I),1,B(1,J),1) C C------------------------------------------------------------------- C SCALE COLUMNS OF RECTANGULAR MATRIX C(MXN) C C DO 30 J=1,N C T = 1.E0/SNRM2(M,C(1,J),1) C 30 CALL SSCAL(M,T,C(1,J),1) C C------------------------------------------------------------------- C ROW EQUILIBRATE SQUARE MATRIX A(NXN) C C DO 40 I=1,N C JMAX = ISAMAX(N,A(I,1),MDA) C T = A(I,JMAX) C IF(T .EQ. 0.E0) GO TO 40 C CALL SSCAL(N,1.E0/T,A(I,1),MDA) C 40 CONTINUE C C----------------------------------------------------------------- C TO CHOOSE ROW PIVOT IN GAUSSIAN ELIMINATION USE C C IMAX = ISAMAX(N-J+1,A(J,J),1) + J-1 C C------------------------------------------------------------------- C SET NXN MATRIX A TO IDENTITY MATRIX AND SET B = A C C DO 50 J=1,N C 50 CALL SCOPY(N,0.E0,0,A(1,J),1) C CALL SCOPY(N,1.E0,0,A,MDA+1) C DO 60 J=1,N C 60 CALL SCOPY(N,A(1,J),1,B(1,J),1) C C------------------------------------------------------------------- C INTERCHANGE OR SWAP COLUMNS OF MXN MATRIX C C C DO 70 J=1,N C L = IP(J) C IF(J .NE. L) CALL SSWAP(M,C(1,J),1,C(1,L),1) C 70 CONTINUE C C------------------------------------------------------------------- C TRANSPOSE AN NXN MATRIX A IN-PLACE C C DO 80 J=1,N C 80 CALL SSWAP(N-J,A(J,J+1),MDA,A(J+1,J),1) C C END C PROGRAM MAIN(INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT) C1 ********************************* TBLA *************************** C TEST DRIVER FOR BASIC LINEAR ALGEBRA SUBPROGRAMS. C C. L. LAWSON,JPL, 1974 DEC 10, 1975 MAY 28 C TBLA READS INPUT FROM UNIT 5 AND WRITES OUTPUT ON UNIT C NPRINT WHICH IS NOMINALLY SET TO 6. THE FORM OF ACCEPTABLE C INPUT IS DESCRIBED IN FORMAT STATEMENT 1002. C FOR EACH SUBPROGRAM SELECTED FOR TESTING, TBLA CALLS ONE OF C THE SUBROUTINES CHECK0, CHECK1, CHECK2. CHECK0 IS USED TO TEST C SUBPROGRAMS HAVING NO VECTOR ARGUMENTS, CHECK1 FOR THOSE HAVING C ONE VECTOR ARGUMENT, AND CHECK2 FOR THOSE HAVING TWO. C THE TUNING PARAMETERS SFAC, SDFAC, DFAC, AND DQFAC ARE SET IN C A DATA STATEMENT AND PASSED TO CHECK0, CHECK1, AND CHECK2 TO SET C TOLERANCES ON TESTING THE SUBPROGRAMS. THE PREFIXES, S,SD,D, C AND DQ REFER TO THE TYPE OF SUBPROGRAM FOR WHICH EACH TOLERANCE C IS USED, NAMELY SINGLE PRECISION, MIXED SINGLE AND DOUBLE C PRECISION, DOUBLE PRECISION, AND MIXED DOUBLE AND EXTENDED C PRECISION. C THE TUNING PARAMETERS ULTIMATELY ARE USED IN STEST AND DTEST. C SEE THESE SUBROUTINE LISTINGS FOR THE PRECISE ROLE OF THOSE C PARAMETERS. THESE PARAMETERS COMPENSATE FOR THE VAGARIES OF C ARITHMETIC TRUNCATION ON DIFFERENT MACHINES. SETTING A TUNING C PARAMETER SMALLER PROVIDES MORE TOLERANCE FOR BAD TRUNCATION, C I.E. MAKES IT EASIER TO PASS THE TESTS. C THE PARAMETERS IN COMMON/COMBLA/ ARE USED AS FOLLOWS.. C C NPRINT FORTRAN UNIT FOR PRINTED OUTPUT. SET IN TBLA. C USED IN TBLA, HEADER, STEST, DTEST, AND ITEST1. C ICASE NUMBER IDENTIFYING SUBPROGRAM BEING TESTED. SEE COMMENTS C ALONG RIGHT MARGIN IN CHECK0, CHECK1, AND CHECK2 C FOR ASSOCIATION OF NUMBERS FROM 1 TO 38 WITH NAMES OF C SUBPROGRAMS. ICASE IS SET IN TBLA AND USED IN VARIOUS C OF THE SUBROUTINES. C N SET IN CHECK0, CHECK1, OR CHECK2. GENERALLY DENOTES C THE DIMENSION OF A VECTOR BEING SENT TO A BLAS C SUBPROGRAM, BUT IN TESTS NOT INVOLVING VECTOR C ARGUMENTS N IS USED JUST TO DISTINGUISH DIFFERENT SETS C OF TEST DATA. WILL BE PRINTED WHEN ERRORS ARE NOTED. C INCX SET IN TBLA, CHECK1, AND CHECK2. SENT TO BLAS C SUBPROGRAMS AS TEST DATA. PRINTED WHEN ERRORS ARE C NOTED. C INCY SET IN TBLA, AND CHECK2. SENT TO BLAS SUBPROGRAMS AS C TEST DATA. PRINTED WHEN ERRORS ARE NOTED. C MODE SET IN TBLA AND CHECK2. DISTINGUISHES TEST CASES. C PRINTED WHEN ERRORS ARE NOTED. C PASS SET IN TBLA, STEST, DTEST, AND ITEST1. SET TO TRUE C OR FALSE TO DENOTE SUCCESS OR FAILURE OF TESTING FOR C A BLAS SUBPROGRAM. ALWAYS PRINTED FOR EACH SUBPROGRAM C TESTED. C2 COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS LOGICAL PASS,ALLZRO INTEGER ITEST(38) DOUBLE PRECISION DFAC,DQFAC DATA SFAC,SDFAC,DFAC,DQFAC / .3125E-1, .50, .625D-1, .125D0/ NPRINT = 6 5 WRITE(NPRINT,1002) READ(5,1000) ITEST WRITE(NPRINT,1005) ITEST ALLZRO=.TRUE. DO 60 IC=1,38 ICASE=IC IF(ITEST(ICASE) .EQ. 0) GO TO 60 ALLZRO=.FALSE. CALL HEADER C C INITIALIZE PASS, INCX, INCY, AND MODE FOR A NEW CASE. C THE VALUE 9999 FOR INCX, INCY OR MODE WILL APPEAR IN THE C DETAILED OUTPUT, IF ANY, FOR CASES THAT DO NOT INVOLVE C THESE PARAMETERS. C PASS=.TRUE. INCX=9999 INCY=9999 MODE=9999 GO TO (12,12,12,12,12,12,12,12,12,12, A 12,10,10,12,12,10,10,12,12,12, B 12,12,12,12,12,11,11,11,11,11, C 11,11,11,11,11,11,11,11), ICASE C ICASE = 12-13 OR 16-17 10 CALL CHECK0(SFAC,DFAC) GO TO 50 C ICASE = 26-38 11 CALL CHECK1(SFAC,DFAC) GO TO 50 C ICASE = 1-11, 14-15, OR 18-25 12 CALL CHECK2(SFAC,SDFAC,DFAC,DQFAC) 50 CONTINUE C PRINT IF(PASS) WRITE(NPRINT,1001) 60 CONTINUE IF(.NOT. ALLZRO) GO TO 5 STOP 1000 FORMAT(80I1) 1001 FORMAT(1H+,39X,4HPASS) 1002 FORMAT(1X///33H PROGRAM TBLA IS READY FOR INPUT./ 142H INPUT ONE CARD IMAGE HAVING ONES OR ZEROS/ 242H IN COLS 1 - 38. A ONE IN COL K MEANS TO/ 341H TEST SUBPROGRAM NO. K. ALL ZEROS MEANS/ 438H TO TERMINATE EXECUTION. INPUT NOW.) 1005 FORMAT(1H0,38I2) END SUBROUTINE HEADER C1 ********************************* HEADER ************************* C PRINT HEADER FOR CASE C C. L. LAWSON, JPL, 1974 DEC 12 C2 COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS LOGICAL PASS DIMENSION L(3,38) C DATA L(1, 1),L(2, 1),L(3, 1)/2H ,2HSD,2HOT/ DATA L(1, 2),L(2, 2),L(3, 2)/2H D,2HSD,2HOT/ DATA L(1, 3),L(2, 3),L(3, 3)/2HSD,2HSD,2HOT/ DATA L(1, 4),L(2, 4),L(3, 4)/2H ,2HDD,2HOT/ DATA L(1, 5),L(2, 5),L(3, 5)/2HDQ,2HDO,2HTI/ DATA L(1, 6),L(2, 6),L(3, 6)/2HDQ,2HDO,2HTA/ DATA L(1,7),L(2,7),L(3,7)/2H C,2HDO,2HTC/ DATA L(1, 8),L(2, 8),L(3, 8)/2H C,2HDO,2HTU/ DATA L(1, 9),L(2, 9),L(3, 9)/2H S,2HAX,2HPY/ DATA L(1,10),L(2,10),L(3,10)/2H D,2HAX,2HPY/ DATA L(1,11),L(2,11),L(3,11)/2H C,2HAX,2HPY/ DATA L(1,12),L(2,12),L(3,12)/2H S,2HRO,2HTG/ DATA L(1,13),L(2,13),L(3,13)/2H D,2HRO,2HTG/ DATA L(1,14),L(2,14),L(3,14)/2H ,2HSR,2HOT/ DATA L(1,15),L(2,15),L(3,15)/2H ,2HDR,2HOT/ DATA L(1,16),L(2,16),L(3,16)/2HSR,2HOT,2HMG/ DATA L(1,17),L(2,17),L(3,17)/2HDR,2HOT,2HMG/ DATA L(1,18),L(2,18),L(3,18)/2H S,2HRO,2HTM/ DATA L(1,19),L(2,19),L(3,19)/2H D,2HRO,2HTM/ DATA L(1,20),L(2,20),L(3,20)/2H S,2HCO,2HPY/ DATA L(1,21),L(2,21),L(3,21)/2H D,2HCO,2HPY/ DATA L(1,22),L(2,22),L(3,22)/2H C,2HCO,2HPY/ DATA L(1,23),L(2,23),L(3,23)/2H S,2HSW,2HAP/ DATA L(1,24),L(2,24),L(3,24)/2H D,2HSW,2HAP/ DATA L(1,25),L(2,25),L(3,25)/2H C,2HSW,2HAP/ DATA L(1,26),L(2,26),L(3,26)/2H S,2HNR,2HM2/ DATA L(1,27),L(2,27),L(3,27)/2H D,2HNR,2HM2/ DATA L(1,28),L(2,28),L(3,28)/2HSC,2HNR,2HM2/ DATA L(1,29),L(2,29),L(3,29)/2H S,2HAS,2HUM/ DATA L(1,30),L(2,30),L(3,30)/2H D,2HAS,2HUM/ DATA L(1,31),L(2,31),L(3,31)/2HSC,2HAS,2HUM/ DATA L(1,32),L(2,32),L(3,32)/2H S,2HSC,2HAL/ DATA L(1,33),L(2,33),L(3,33)/2H D,2HSC,2HAL/ DATA L(1,34),L(2,34),L(3,34)/2H C,2HSC,2HAL/ DATA L(1,35),L(2,35),L(3,35)/2HCS,2HSC,2HAL/ DATA L(1,36),L(2,36),L(3,36)/2HIS,2HAM,2HAX/ DATA L(1,37),L(2,37),L(3,37)/2HID,2HAM,2HAX/ DATA L(1,38),L(2,38),L(3,38)/2HIC,2HAM,2HAX/ C WRITE(NPRINT,1000) ICASE,(L(I,ICASE),I=1,3) RETURN C 1000 FORMAT(23H0TEST OF SUBPROGRAM NO.,I3,2X,3A2) END SUBROUTINE CHECK0(SFAC,DFAC) C1 ********************************* CHECK0 ************************* C THIS SUBROUTINE TESTS SUBPROGRAMS 12-13 AND 16-17. C THESE SUBPROGRAMS HAVE NO ARRAY ARGUMENTS. C C C. L. LAWSON, JPL, 1975 MAR 07, MAY 28 C R. J. HANSON, J. A. WISNIEWSKI, SANDIA LABS, APRIL 25,1977. C2 COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS LOGICAL PASS REAL STRUE(9),STEMP(9) DOUBLE PRECISION DC,DS,DA1(8),DB1(8),DC1(8),DS1(8) DOUBLE PRECISION DA,DATRUE(8),DBTRUE(8),DZERO,DFAC,DB DOUBLE PRECISION DAB(4,9),DTEMP(9),DTRUE(9,9),D12 DATA ZERO, DZERO / 0., 0.D0 / DATA DA1/ .3D0, .4D0, -.3D0, -.4D0, -.3D0, 0.D0, 0.D0, 1.D0/ DATA DB1/ .4D0, .3D0, .4D0, .3D0, -.4D0, 0.D0, 1.D0, 0.D0/ DATA DC1/ .6D0, .8D0, -.6D0, .8D0, .6D0, 1.D0, 0.D0, 1.D0/ DATA DS1/ .8D0, .6D0, .8D0, -.6D0, .8D0, 0.D0, 1.D0, 0.D0/ DATA DATRUE/ .5D0, .5D0, .5D0, -.5D0, -.5D0, 0.D0, 1.D0, 1.D0/ DATA DBTRUE/ 0.D0, .6D0, 0.D0, -.6D0, 0.D0, 0.D0, 1.D0, 0.D0/ C INPUT FOR MODIFIED GIVENS DATA DAB/ .1D0,.3D0,1.2D0,.2D0, A .7D0, .2D0, .6D0, 4.2D0, B 0.D0,0.D0,0.D0,0.D0, C 4.D0, -1.D0, 2.D0, 4.D0, D 6.D-10, 2.D-2, 1.D5, 10.D0, E 4.D10, 2.D-2, 1.D-5, 10.D0, F 2.D-10, 4.D-2, 1.D5, 10.D0, G 2.D10, 4.D-2, 1.D-5, 10.D0, H 4.D0, -2.D0, 8.D0, 4.D0 / C TRUE RESULTS FOR MODIFIED GIVENS DATA DTRUE/0.D0,0.D0, 1.3D0, .2D0, 0.D0,0.D0,0.D0, .5D0, 0.D0, A 0.D0,0.D0, 4.5D0, 4.2D0, 1.D0, .5D0, 0.D0,0.D0,0.D0, B 0.D0,0.D0,0.D0,0.D0, -2.D0, 0.D0,0.D0,0.D0,0.D0, C 0.D0,0.D0,0.D0, 4.D0, -1.D0, 0.D0,0.D0,0.D0,0.D0, D 0.D0, 15.D-3, 0.D0, 10.D0, -1.D0, 0.D0, -1.D-4, E 0.D0, 1.D0, F 0.D0,0.D0, 6144.D-5, 10.D0, -1.D0, 4096.D0, -1.D6, G 0.D0, 1.D0, H 0.D0,0.D0,15.D0,10.D0,-1.D0, 5.D-5, 0.D0,1.D0,0.D0, I 0.D0,0.D0, 15.D0, 10.D0, -1. D0, 5.D5, -4096.D0, J 1.D0, 4096.D-6, K 0.D0,0.D0, 7.D0, 4.D0, 0.D0,0.D0, -.5D0, -.25D0, 0.D0/ C 4096 = 2 ** 12 DATA D12 /4096.D0/ C C COMPUTE TRUE VALUES WHICH CANNOT BE PRESTORED C IN DECIMAL NOTATION. DTRUE(1,1) = 12.D0 / 130.D0 DTRUE(2,1) = 36.D0 / 130.D0 DTRUE(7,1) = -1.D0 / 6.D0 DTRUE(1,2) = 14.D0 / 75.D0 DTRUE(2,2) = 49.D0 / 75.D0 DTRUE(9,2) = 1.D0 / 7.D0 DTRUE(1,5) = 45.D-11 * (D12 * D12) DTRUE(3,5) = 4.D5 / (3.D0 * D12) DTRUE(6,5) = 1.D0 / D12 DTRUE(8,5) = 1.D4 / (3.D0 * D12) DTRUE(1,6) = 4.D10 / (1.5D0 * D12 * D12) DTRUE(2,6) = 2.D-2 / 1.5D0 DTRUE(8,6) = 5.D-7 * D12 DTRUE(1,7) = 4.D0 / 150.D0 DTRUE(2,7) = (2.D-10 / 1.5D0) * (D12 * D12) DTRUE(7,7) = -DTRUE(6,5) DTRUE(9,7) = 1.D4 / D12 DTRUE(1,8) = DTRUE(1,7) DTRUE(2,8) = 2.D10 / (1.5D0 * D12 * D12) DTRUE(1,9) = 32.D0 / 7.D0 DTRUE(2,9) = -16.D0 / 7.D0 DBTRUE(1) = 1.D0/.6D0 DBTRUE(3) = -1.D0/.6D0 DBTRUE(5) = 1.D0/.6D0 C JUMP= ICASE-11 DO 500 K=1,9 C SET N=K FOR IDENTIFICATION IN OUTPUT IF ANY. N=K C BRANCH TO SELECT SUBPROGRAM TO BE TESTED. C GO TO (120,130,999,999,160,170), JUMP C 12. SROTG 120 IF(K.GT.8) GO TO 600 SA=SNGL(DA1(K)) SB = SNGL(DB1(K)) CALL SROTG(SA,SB,SC,SS) CALL STEST1 (SA,SNGL(DATRUE(K)),SNGL(DATRUE(K)),SFAC) CALL STEST1 (SB,SNGL(DBTRUE(K)),SNGL(DBTRUE(K)),SFAC) CALL STEST1 (SC,SNGL(DC1(K)),SNGL(DC1(K)),SFAC) CALL STEST1 (SS,SNGL(DS1(K)),SNGL(DS1(K)),SFAC) GO TO 500 C 13. DROTG 130 IF(K.GT.8) GO TO 600 DA=DA1(K) DB = DB1(K) CALL DROTG(DA,DB,DC,DS) CALL DTEST1 (DA,DATRUE(K),DATRUE(K),DFAC) CALL DTEST1 (DB,DBTRUE(K),DBTRUE(K),DFAC) CALL DTEST1 (DC,DC1(K),DC1(K),DFAC) CALL DTEST1 (DS,DS1(K),DS1(K),DFAC) GO TO 500 C 16. SROTMG 160 CONTINUE DO 162 I=1,4 STEMP(I) = SNGL(DAB(I,K)) STEMP(I+4) = ZERO 162 CONTINUE STEMP(9) = ZERO CALL SROTMG(STEMP(1),STEMP(2),STEMP(3),STEMP(4),STEMP(5)) C DO 166 I=1,9 166 STRUE(I)=SNGL(DTRUE(I,K)) CALL STEST(9,STEMP,STRUE,STRUE,SFAC) GO TO 500 C 17. DROTMG 170 CONTINUE DO 172 I=1,4 DTEMP(I)= DAB(I,K) DTEMP(I+4) = DZERO 172 CONTINUE DTEMP(9) = DZERO CALL DROTMG(DTEMP(1),DTEMP(2),DTEMP(3),DTEMP(4),DTEMP(5)) CALL DTEST(9,DTEMP,DTRUE(1,K),DTRUE(1,K),DFAC) 500 CONTINUE 600 RETURN C THE FOLLOWING STOP SHOULD NEVER BE REACHED. 999 STOP END SUBROUTINE CHECK1(SFAC,DFAC) C1 ********************************* CHECK1 ************************* C THIS SUBPROGRAM TESTS THE INCREMENTING AND ACCURACY OF THE LINEAR C ALGEBRA SUBPROGRAMS 26 - 38 (SNRM2 TO ICAMAX). STORED RESULTS ARE C COMPARED WITH THE RESULT RETURNED BY THE SUBPROGRAM. C C THESE SUBPROGRAMS REQUIRE A SINGLE VECTOR ARGUMENT. C C ICASE DESIGNATES WHICH SUBPROGRAM TO TEST. C 26 .LE. ICASE .LE. 38 C C. L. LAWSON, JPL, 1974 DEC 10, MAY 28 C2 COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS LOGICAL PASS INTEGER ITRUE2(5),ITRUE3(5) DOUBLE PRECISION DA,DX(8) DOUBLE PRECISION DV(8,5,2) DOUBLE PRECISION DFAC DOUBLE PRECISION DNRM2,DASUM DOUBLE PRECISION DTRUE1(5),DTRUE3(5),DTRUE5(8,5,2) REAL STRUE2(5),STRUE4(5),STRUE(8),SX(8) COMPLEX CA,CV(8,5,2),CTRUE5(8,5,2),CTRUE6(8,5,2),CX(8) C DATA SA, DA, CA / .3, .3D0, (.4,-.7) / DATA DV/.1D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0, 1 .3D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0, 2 .3D0,-.4D0,4.D0,4.D0,4.D0,4.D0,4.D0,4.D0, 3 .2D0,-.6D0,.3D0,5.D0,5.D0,5.D0,5.D0,5.D0, 4 .1D0,-.3D0,.5D0,-.1D0,6.D0,6.D0,6.D0,6.D0, 5 .1D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0, 6 .3D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0, 7 .3D0,2.D0,-.4D0,2.D0,2.D0,2.D0,2.D0,2.D0, 8 .2D0,3.D0,-.6D0,5.D0,.3D0,2.D0,2.D0,2.D0, 9 .1D0,4.D0,-.3D0,6.D0,-.5D0,7.D0,-.1D0, 3.D0/ C COMPLEX TEST VECTORS DATA CV/ 1(.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), 2(.3,-.4),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), 3(.1,-.3),(.5,-.1),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), 4(.1,.1),(-.6,.1),(.1,-.3),(7.,8.),(7.,8.),(7.,8.),(7.,8.),(7.,8.), 5(.3,.1),(.1,.4),(.4,.1),(.1,.2),(2.,3.),(2.,3.),(2.,3.),(2.,3.), 6(.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), 7(.3,-.4),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), 8(.1,-.3),(8.,9.),(.5,-.1),(2.,5.),(2.,5.),(2.,5.),(2.,5.),(2.,5.), 9(.1,.1),(3.,6.),(-.6,.1),(4.,7.),(.1,-.3),(7.,2.),(7.,2.),(7.,2.), T(.3,.1),(5.,8.),(.1,.4),(6.,9.),(.4,.1),(8.,3.),(.1,.2),(9.,4.) / C DATA STRUE2/.0,.5,.6,.7,.7/ DATA STRUE4/.0,.7,1.,1.3,1.7/ DATA DTRUE1/.0D0,.3D0,.5D0,.7D0,.6D0/ DATA DTRUE3/.0D0,.3D0,.7D0,1.1D0,1.D0/ DATA DTRUE5/.10D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0, 1 .09D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0, 2 .09D0,-.12D0,4.D0,4.D0,4.D0,4.D0,4.D0,4.D0, 3 .06D0,-.18D0,.09D0,5.D0,5.D0,5.D0,5.D0,5.D0, 4 .03D0,-.09D0,.15D0,-.03D0,6.D0,6.D0,6.D0,6.D0, 5 .10D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0, 6 .09D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0, 7 .09D0,2.D0,-.12D0,2.D0,2.D0,2.D0,2.D0,2.D0, 8 .06D0,3.D0,-.18D0,5.D0,.09D0,2.D0,2.D0,2.D0, 9 .03D0,4.D0, -.09D0,6.D0, -.15D0,7.D0, -.03D0, 3.D0/ C DATA CTRUE5/ A(.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), B(-.16,-.37),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), C (3.,4.), D(-.17,-.19),(.13,-.39),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), E (5.,6.), F(.11,-.03),(-.17,.46),(-.17,-.19),(7.,8.),(7.,8.),(7.,8.),(7.,8.), G (7.,8.), H(.19,-.17),(.32,.09),(.23,-.24),(.18,.01),(2.,3.),(2.,3.),(2.,3.), I (2.,3.), J(.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), K(-.16,-.37),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), L (6.,7.), M(-.17,-.19),(8.,9.),(.13,-.39),(2.,5.),(2.,5.),(2.,5.),(2.,5.), N (2.,5.), O(.11,-.03),(3.,6.),(-.17,.46),(4.,7.),(-.17,-.19),(7.,2.),(7.,2.), P (7.,2.), Q(.19,-.17),(5.,8.),(.32,.09),(6.,9.),(.23,-.24),(8.,3.),(.18,.01), R (9.,4.) / C DATA CTRUE6/ A(.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), B(.09,-.12),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), C (3.,4.), D(.03,-.09),(.15,-.03),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), E (5.,6.), F(.03,.03),(-.18,.03),(.03,-.09),(7.,8.),(7.,8.),(7.,8.),(7.,8.), G (7.,8.), H(.09,.03),(.03,.12),(.12,.03),(.03,.06),(2.,3.),(2.,3.),(2.,3.), I (2.,3.), J(.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), K(.09,-.12),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), L (6.,7.), M(.03,-.09),(8.,9.),(.15,-.03),(2.,5.),(2.,5.),(2.,5.),(2.,5.), N (2.,5.), O(.03,.03),(3.,6.),(-.18,.03),(4.,7.),(.03,-.09),(7.,2.),(7.,2.), P (7.,2.), Q(.09,.03),(5.,8.),(.03,.12),(6.,9.),(.12,.03),(8.,3.),(.03,.06), R (9.,4.) / C C DATA ITRUE2/ 0, 1, 2, 2, 3/ DATA ITRUE3/ 0, 1, 2, 2, 2/ C JUMP=ICASE-25 DO 520 INCX=1,2 DO 500 NP1=1,5 N=NP1-1 LEN= 2*MAX0(N,1) C SET VECTOR ARGUMENTS. DO 22 I=1,LEN SX(I) = SNGL(DV(I,NP1,INCX)) DX(I)=DV(I,NP1,INCX) 22 CX(I)=CV(I,NP1,INCX) C C BRANCH TO INVOKE SUBPROGRAM TO BE TESTED. C GO TO (260,270,280,290,300,310,320, * 330,340,350,360,370,380),JUMP C 26. SNRM2 260 STEMP=SNGL(DTRUE1(NP1)) CALL STEST1 (SNRM2(N,SX,INCX),STEMP,STEMP,SFAC) GO TO 500 C 27. DNRM2 270 CALL DTEST1 (DNRM2(N,DX,INCX),DTRUE1(NP1),DTRUE1(NP1),DFAC) GO TO 500 C 28. SCNRM2 280 CALL STEST1 (SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1),SFAC) GO TO 500 C 29. SASUM 290 STEMP=SNGL(DTRUE3(NP1)) CALL STEST1 (SASUM(N,SX,INCX),STEMP,STEMP,SFAC) GO TO 500 C 30. DASUM 300 CALL DTEST1 (DASUM(N,DX,INCX),DTRUE3(NP1),DTRUE3(NP1),DFAC) GO TO 500 C 31. SCASUM 310 CALL STEST1 (SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),SFAC) GO TO 500 C 32. SSCALE 320 CALL SSCAL(N,SA,SX,INCX) DO 322 I=1,LEN 322 STRUE(I)= SNGL(DTRUE5(I,NP1,INCX)) CALL STEST(LEN,SX,STRUE,STRUE,SFAC) GO TO 500 C 33. DSCALE 330 CALL DSCAL(N,DA,DX,INCX) CALL DTEST(LEN,DX,DTRUE5(1,NP1,INCX),DTRUE5(1,NP1,INCX),DFAC) GO TO 500 C 34. CSCALE 340 CALL CSCAL(N,CA,CX,INCX) CALL CTEST (LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX),SFAC) GO TO 500 C 35. CSSCAL 350 CALL CSSCAL(N,SA,CX,INCX) CALL CTEST (LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX),SFAC) GO TO 500 C 36. ISAMAX 360 CALL ITEST1 (ISAMAX(N,SX,INCX),ITRUE2(NP1)) GO TO 500 C 37. IDAMAX 370 CALL ITEST1 (IDAMAX(N,DX,INCX),ITRUE2(NP1)) GO TO 500 C 38. ICAMAX 380 CALL ITEST1 (ICAMAX(N,CX,INCX),ITRUE3(NP1)) C 500 CONTINUE 520 CONTINUE RETURN END SUBROUTINE CHECK2(SFAC,SDFAC,DFAC,DQFAC) C1 ********************************* CHECK2 ************************* C THIS SUBPROGRAM TESTS THE BASIC LINEAR ALGEBRA SUBPROGRAMS 1-11, C 14-15, AND 18-25. SUBPROGRAMS IN THIS SET EACH REQUIRE TWO ARRAYS C IN THE PARAMETER LIST. C C C. L. LAWSON, JPL, 1975 FEB 26, APR 29, MAY 8, MAY 28 C2 COMMON/COMBLA/NPRINT,ICASE,N,INCX,INCY,MODE,PASS C LOGICAL PASS INTEGER INCXS(4),INCYS(4),LENS(4,2),NS(4),QC(10) REAL SX(7),SY(7),STX(7),STY(7),SSIZE1(4),SSIZE2(14,2) REAL SSIZE(7),SPARAM(5),ST7B(4,4),SSIZE3(4) DOUBLE PRECISION DX(7),DA,DX1(7),DY1(7),DY(7),DT7(4,4),DT8(7,4,4) DOUBLE PRECISION DX2(7), DY2(7), DT2(4,4,2), DPARAM(5), DPAR(5,4) DOUBLE PRECISION DSDOT,DDOT,DQDOTI,DQDOTA,DFAC,DQFAC DOUBLE PRECISION DT10X(7,4,4),DT10Y(7,4,4),DB DOUBLE PRECISION DSIZE1(4),DSIZE2(7,2),DSIZE(7) DOUBLE PRECISION DC,DS,DT9X(7,4,4),DT9Y(7,4,4),DTX(7),DTY(7) DOUBLE PRECISION DT19X(7,4,16),DT19XA(7,4,4),DT19XB(7,4,4) DOUBLE PRECISION DT19XC(7,4,4),DT19XD(7,4,4),DT19Y(7,4,16) DOUBLE PRECISION DT19YA(7,4,4),DT19YB(7,4,4),DT19YC(7,4,4) DOUBLE PRECISION DT19YD(7,4,4) C COMPLEX CX(7),CA,CX1(7),CY1(7),CY(7),CT6(4,4),CT7(4,4) COMPLEX CT8(7,4,4),CSIZE1(4),CSIZE2(7,2) COMPLEX CT10X(7,4,4), CT10Y(7,4,4) COMPLEX CDOT(1) COMPLEX CDOTC,CDOTU EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)),(DT19X(1,1,5), A DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)), B (DT19X(1,1,13),DT19XD(1,1,1)) EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5), A DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)), B (DT19Y(1,1,13),DT19YD(1,1,1)) DATA SA,DA,CA,DB,SB/.3,.3D0,(.4,-.7),.25D0,.1/ DATA INCXS/ 1, 2, -2, -1 / DATA INCYS/ 1, -2, 1, -2 / DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ DATA NS / 0, 1, 2, 4 / DATA SC,SS,DC,DS/ .8,.6,.8D0,.6D0/ DATA DX1/ .6D0, .1D0,-.5D0, .8D0, .9D0,-.3D0,-.4D0/ DATA DY1/ .5D0,-.9D0, .3D0, .7D0,-.6D0, .2D0, .8D0/ DATA DX2/ 1.D0,.01D0, .02D0,1.25D0,.06D0, 2.D0, 1.D0/ DATA DY2/ 1.D0,.04D0,-.03D0,-1.D0,.05D0,3.D0,-1.D0/ DATA CX1/(.7,-.8),(-.4,-.7),(-.1,-.9),(.2,-.8),(-.9,-.4),(.1,.4), * (-.6,.6)/ DATA CY1/(.6,-.6),(-.9,.5),(.7,-.6),(.1,-.5),(-.1,-.2),(-.5,-.3), * (.8,-.7) / C C FOR DQDOTI AND DQDOTA C DATA DT2/0.25D0,1.25D0,1.2504D0,-0.0002D0, A 0.25D0,1.25D0,0.24D0,0.2492D0, B 0.25D0,1.25D0,0.31D0,0.2518D0, C 0.25D0,1.25D0,1.2497D0,0.0007D0, D 0.D0,2.D0,2.0008D0,-.5004D0, E 0.D0,2.D0,-.02D0,-.0016D0, F 0.D0,2.D0,.12D0,.0036D0, G 0.D0,2.D0,1.9994D0,-0.4986D0/ DATA DT7/ 0.D0,.30D0,.21D0,.62D0, 0.D0,.30D0,-.07D0,.85D0, * 0.D0,.30D0,-.79D0,-.74D0, 0.D0,.30D0,.33D0,1.27D0/ DATA ST7B/ .1, .4, .31, .72, .1, .4, .03, .95, * .1, .4, -.69, -.64, .1, .4, .43, 1.37/ C C FOR CDOTU C DATA CT7/(0.,0.),(-.06,-.90),(.65,-.47),(-.34,-1.22), 1 (0.,0.),(-.06,-.90),(-.59,-1.46),(-1.04,-.04), 2 (0.,0.),(-.06,-.90),(-.83,.59), ( .07,-.37), 3 (0.,0.),(-.06,-.90),(-.76,-1.15),(-1.33,-1.82)/ C C FOR CDOTC C DATA CT6/(0.,0.),(.90,0.06), (.91,-.77), (1.80,-.10), A (0.,0.),(.90,0.06), (1.45,.74), (.20,.90), B (0.,0.),(.90,0.06), (-.55,.23), (.83,-.39), C (0.,0.),(.90,0.06), (1.04,0.79), (1.95,1.22)/ C DATA DT8/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 1 .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 2 .68D0,-.87D0, 0.D0,0.D0,0.D0,0.D0,0.D0, 3 .68D0,-.87D0,.15D0,.94D0, 0.D0,0.D0,0.D0, 4 .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 5 .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 6 .35D0,-.9D0,.48D0, 0.D0,0.D0,0.D0,0.D0, 7 .38D0,-.9D0,.57D0,.7D0,-.75D0,.2D0,.98D0, 8 .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, 9 .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .35D0,-.72D0, 0.D0,0.D0,0.D0,0.D0,0.D0, B .38D0,-.63D0,.15D0,.88D0, 0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .68D0,-.9D0,.33D0, 0.D0,0.D0,0.D0,0.D0, F .68D0,-.9D0,.33D0,.7D0,-.75D0,.2D0,1.04D0/ C DATA CT8/ A(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), C(.32,-1.41),(-1.55,.5),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), D(.32,-1.41),(-1.55,.5),(.03,-.89),(-.38,-.96),(0.,0.),(0.,0.), E (0.,0.), F(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), G(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), H(-.07,-.89),(-.9,.5),(.42,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.), I(.78,.06),(-.9,.5),(.06,-.13),(.1,-.5),(-.77,-.49),(-.5,-.3), J (.52,-1.51), K(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), L(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), M(-.07,-.89),(-1.18,-.31),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), N(.78,.06),(-1.54,.97),(.03,-.89),(-.18,-1.31),(0.,0.),(0.,0.), O(0.,0.),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), P(.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), Q(.32,-1.41),(-.9,.5),(.05,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), R(.32,-1.41),(-.9,.5),(.05,-.6),(.1,-.5),(-.77,-.49),(-.5,-.3), S (.32,-1.16) / C C C TRUE X VALUES AFTER ROTATION USING SROT OR DROT. DATA DT9X/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .78D0,-.46D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .78D0,-.46D0,-.22D0,1.06D0, 0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F .66D0,.1D0,-.1D0, 0.D0,0.D0,0.D0,0.D0, G .96D0,.1D0,-.76D0,.8D0,.90D0,-.3D0,-.02D0, H .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J -.06D0,.1D0,-.1D0, 0.D0,0.D0,0.D0,0.D0, K .90D0,.1D0,-.22D0,.8D0,.18D0,-.3D0,-.02D0, L .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .78D0,.26D0, 0.D0,0.D0,0.D0,0.D0,0.D0, O .78D0,.26D0,-.76D0,1.12D0, 0.D0,0.D0,0.D0/ C C TRUE Y VALUES AFTER ROTATION USING SROT OR DROT. C DATA DT9Y/ .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .04D0,-.78D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .04D0,-.78D0, .54D0, .08D0, 0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F .7D0,-.9D0,-.12D0, 0.D0,0.D0,0.D0,0.D0, G .64D0,-.9D0,-.30D0, .7D0,-.18D0, .2D0, .28D0, H .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J .7D0,-1.08D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K .64D0,-1.26D0,.54D0, .20D0, 0.D0,0.D0,0.D0, L .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .04D0,-.9D0, .18D0, 0.D0,0.D0,0.D0,0.D0, O .04D0,-.9D0, .18D0, .7D0,-.18D0, .2D0, .16D0/ C DATA DT10X/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0,-.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0,-.9D0,.3D0,.7D0, 0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F .3D0,.1D0 ,.5D0, 0.D0,0.D0,0.D0,0.D0, G .8D0,.1D0 ,-.6D0,.8D0 ,.3D0,-.3D0,.5D0, H .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J -.9D0,.1D0,.5D0, 0.D0,0.D0,0.D0,0.D0, K .7D0, .1D0,.3D0, .8D0,-.9D0,-.3D0,.5D0, L .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .5D0,.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, O .5D0,.3D0,-.6D0,.8D0, 0.D0,0.D0,0.D0/ C DATA DT10Y/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0,.1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0,.1D0,-.5D0,.8D0, 0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.5D0,-.9D0,.6D0, 0.D0,0.D0,0.D0,0.D0, G -.4D0,-.9D0,.9D0, .7D0,-.5D0, .2D0,.6D0, H .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, I .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, J -.5D0,.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K -.4D0,.9D0,-.5D0,.6D0, 0.D0,0.D0,0.D0, L .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, M .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, N .6D0,-.9D0,.1D0, 0.D0,0.D0,0.D0,0.D0, O .6D0,-.9D0,.1D0, .7D0,-.5D0, .2D0, .8D0/ C DATA CT10X/ A(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), C(.6,-.6),(-.9,.5),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), D(.6,-.6),(-.9,.5),(.7,-.6),(.1,-.5),(0.,0.),(0.,0.),(0.,0.), E(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), F(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), G(.7,-.6),(-.4,-.7),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), H(.8,-.7),(-.4,-.7),(-.1,-.2),(.2,-.8),(.7,-.6),(.1,.4),(.6,-.6), I(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), J(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), K(-.9,.5),(-.4,-.7),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), L(.1,-.5),(-.4,-.7),(.7,-.6),(.2,-.8),(-.9,.5),(.1,.4),(.6,-.6), M(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), N(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), O(.6,-.6),(.7,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), P(.6,-.6),(.7,-.6),(-.1,-.2),(.8,-.7),(0.,0.),(0.,0.),(0.,0.) / C DATA CT10Y/ A(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), C(.7,-.8),(-.4,-.7),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), D(.7,-.8),(-.4,-.7),(-.1,-.9),(.2,-.8),(0.,0.),(0.,0.),(0.,0.), E(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), F(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), G(-.1,-.9),(-.9,.5),(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.), H(-.6,.6),(-.9,.5),(-.9,-.4),(.1,-.5),(-.1,-.9),(-.5,-.3),(.7,-.8), I(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), J(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), K(-.1,-.9),(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), L(-.6,.6),(-.9,-.4),(-.1,-.9),(.7,-.8),(0.,0.),(0.,0.),(0.,0.), M(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), N(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), O(.7,-.8),(-.9,.5),(-.4,-.7),(0.,0.),(0.,0.),(0.,0.),(0.,0.), P(.7,-.8),(-.9,.5),(-.4,-.7),(.1,-.5),(-.1,-.9),(-.5,-.3),(.2,-.8)/ C TRUE X RESULTS F0R ROTATIONS SROTM AND DROTM DATA DT19XA/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I -.8D0, 3.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J -.9D0, 2.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K 3.5D0, -.4D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, M -.8D0, 3.8D0, -2.2D0, -1.2D0, 0.D0,0.D0,0.D0, N -.9D0, 2.8D0, -1.4D0, -1.3D0, 0.D0,0.D0,0.D0, O 3.5D0, -.4D0, -2.2D0, 4.7D0, 0.D0,0.D0,0.D0/ C DATA DT19XB/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, I 0.D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, J -.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, K 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, M -2.0D0, .1D0, 1.4D0, .8D0, .6D0, -.3D0, -2.8D0, N -1.8D0, .1D0, 1.3D0, .8D0, 0.D0, -.3D0, -1.9D0, O 3.8D0, .1D0, -3.1D0, .8D0, 4.8D0, -.3D0, -1.5D0 / C DATA DT19XC/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, I 4.8D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, J 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, K 2.1D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, M -1.6D0, .1D0, -2.2D0, .8D0, 5.4D0, -.3D0, -2.8D0, N -1.5D0, .1D0, -1.4D0, .8D0, 3.6D0, -.3D0, -1.9D0, O 3.7D0, .1D0, -2.2D0, .8D0, 3.6D0, -.3D0, -1.5D0 / C DATA DT19XD/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I -.8D0, -1.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J -.9D0, -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K 3.5D0, .8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, M -.8D0, -1.0D0, 1.4D0, -1.6D0, 0.D0,0.D0,0.D0, N -.9D0, -.8D0, 1.3D0, -1.6D0, 0.D0,0.D0,0.D0, O 3.5D0, .8D0, -3.1D0, 4.8D0, 0.D0,0.D0,0.D0/ C TRUE Y RESULTS FOR ROTATIONS SROTM AND DROTM DATA DT19YA/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I .7D0, -4.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J 1.7D0, -.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K -2.6D0, 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, M .7D0, -4.8D0, 3.0D0, 1.1D0, 0.D0,0.D0,0.D0, N 1.7D0, -.7D0, -.7D0, 2.3D0, 0.D0,0.D0,0.D0, O -2.6D0, 3.5D0, -.7D0, -3.6D0, 0.D0,0.D0,0.D0/ C DATA DT19YB/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, I 4.0D0, -.9D0, -.3D0, 0.D0,0.D0,0.D0,0.D0, J -.5D0, -.9D0, 1.5D0, 0.D0,0.D0,0.D0,0.D0, K -1.5D0, -.9D0, -1.8D0, 0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, M 3.7D0, -.9D0, -1.2D0, .7D0, -1.5D0, .2D0, 2.2D0, N -.3D0, -.9D0, 2.1D0, .7D0, -1.6D0, .2D0, 2.0D0, O -1.6D0, -.9D0, -2.1D0, .7D0, 2.9D0, .2D0, -3.8D0 / C DATA DT19YC/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, I 4.0D0, -6.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, J -.5D0, .3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, K -1.5D0, 3.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, M 3.7D0, -7.2D0, 3.0D0, 1.7D0, 0.D0,0.D0,0.D0, N -.3D0, .9D0, -.7D0, 1.9D0, 0.D0,0.D0,0.D0, O -1.6D0, 2.7D0, -.7D0, -3.4D0, 0.D0,0.D0,0.D0/ C DATA DT19YD/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, B .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, C .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, D .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, E .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, F 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, G -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, H .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, I .7D0, -.9D0, 1.2D0, 0.D0,0.D0,0.D0,0.D0, J 1.7D0, -.9D0, .5D0, 0.D0,0.D0,0.D0,0.D0, K -2.6D0, -.9D0, -1.3D0, 0.D0,0.D0,0.D0,0.D0, L .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, M .7D0, -.9D0, 1.2D0, .7D0, -1.5D0, .2D0, 1.6D0, N 1.7D0, -.9D0, .5D0, .7D0, -1.6D0, .2D0, 2.4D0, O -2.6D0, -.9D0, -1.3D0, .7D0, 2.9D0, .2D0, -4.0D0 / C DATA SSIZE1/ 0. , .3 , 1.6 , 3.2 / DATA DSIZE1/ 0.D0, .3D0, 1.6D0, 3.2D0 / DATA SSIZE3/ .1, .4, 1.7, 3.3 / C C FOR CDOTC AND CDOTU C DATA CSIZE1/ (0.,0.), (.9,.9), (1.63,1.73), (2.90,2.78) / DATA SSIZE2/0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., A 1.17,1.17,1.17,1.17,1.17,1.17,1.17, B 1.17,1.17,1.17,1.17,1.17,1.17,1.17/ DATA DSIZE2/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, A 1.17D0,1.17D0,1.17D0,1.17D0,1.17D0,1.17D0,1.17D0/ C C FOR CAXPY C DATA CSIZE2/ A (0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), B (1.54,1.54),(1.54,1.54),(1.54,1.54),(1.54,1.54),(1.54,1.54), C (1.54,1.54),(1.54,1.54) / C C FOR SROTM AND DROTM C DATA DPAR/-2.D0, 0.D0,0.D0,0.D0,0.D0, A -1.D0, 2.D0, -3.D0, -4.D0, 5.D0, B 0.D0, 0.D0, 2.D0, -3.D0, 0.D0, C 1.D0, 5.D0, 2.D0, 0.D0, -4.D0/ C DO 520 KI=1,4 INCX = INCXS(KI) INCY = INCYS(KI) MX = IABS(INCX) MY = IABS(INCY) C DO 500 KN=1,4 N= NS(KN) KSIZE=MIN0(2,KN) LENX = LENS(KN,MX) LENY = LENS(KN,MY) C INITIALIZE ALL ARGUMENT ARRAYS. DO 5 I=1,7 SX(I)= SNGL(DX1(I)) SY(I)= SNGL(DY1(I)) DX(I)= DX1(I) DY(I)= DY1(I) CX(I)= CX1(I) 5 CY(I)= CY1(I) C C BRANCH TO SELECT SUBPROGRAM TO BE TESTED. C GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, A 110,999,999,140,150,999,999,180,190,200, B 210,220,230,240,250), ICASE C 1. SDOT 10 CALL STEST1 (SDOT(N,SX,INCX,SY,INCY),SNGL(DT7(KN,KI)), * SSIZE1(KN),SFAC) GO TO 500 C 2. DSDOT 20 CALL STEST1 (SNGL(DSDOT(N,SX,INCX,SY,INCY)), * SNGL(DT7(KN,KI)),SSIZE1(KN),SFAC) GO TO 500 C 3. SDSDOT 30 CALL STEST1 (SDSDOT(N,SB,SX,INCX,SY,INCY), * ST7B(KN,KI),SSIZE3(KN),SFAC) GO TO 500 C 4. DDOT 40 CALL DTEST1 (DDOT(N,DX,INCX,DY,INCY),DT7(KN,KI), * DSIZE1(KN),DFAC) GO TO 500 C 5. DQDOTI 50 CONTINUE C DQDOTI AND DQDOTA ARE SUPPOSED TO USE EXTENDED C PRECISION ARITHMETIC INTERNALLY. C SET MODE = 1 OR 2 TO DISTINGUISH TESTS OF DQDOTI OR DQDOTA C IN THE DIAGNOSTIC OUTPUT. C MODE = 1 CALL DTEST1 (DQDOTI(N,DB,QC,DX2,INCX,DY2,INCY), * DT2(KN,KI,1),DT2(KN,KI,1),DQFAC) GO TO 500 C 6. DQDOTA 60 CONTINUE C TO TEST DQDOTA WE ACTUALLY TEST BOTH DQDOTI AND DQDOTA. C THE OUTPUT VALUE OF QX FROM DQDOTI WILL BE USED AS INPUT C TO DQDOTA. QX IS SUPPOSED TO BE IN A MACHINE-DEPENDENT C EXTENDED PRECISION FORM. C MODE IS SET TO 1 OR 2 TO DISTINGUISH TESTS OF C DQDOTI OR DQDOTA IN THE DIAGNOSTIC OUTPUT. C MODE = 1 CALL DTEST1 (DQDOTI(N,DB,QC,DX2,INCX,DY2,INCY), * DT2(KN,KI,1),DT2(KN,KI,1),DQFAC) MODE = 2 CALL DTEST1 (DQDOTA(N,-DB,QC,DX2,INCX,DY2,INCY), * DT2(KN,KI,2),DT2(KN,KI,2),DQFAC) GO TO 500 C 7. CDOTC 70 CDOT(1) = CDOTC(N,CX,INCX,CY,INCY) CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) GO TO 500 C 8. CDOTU 80 CDOT(1) = CDOTU(N,CX,INCX,CY,INCY) CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) GO TO 500 C 9. SAXPY 90 CALL SAXPY(N,SA,SX,INCX,SY,INCY) DO 95 J=1,LENY 95 STY(J)= SNGL(DT8(J,KN,KI)) CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) GO TO 500 C 10. DAXPY 100 CALL DAXPY(N,DA,DX,INCX,DY,INCY) CALL DTEST(LENY,DY,DT8(1,KN,KI),DSIZE2(1,KSIZE),DFAC) GO TO 500 C 11. CAXPY 110 CALL CAXPY(N,CA,CX,INCX,CY,INCY) CALL CTEST (LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) GO TO 500 C 14. SROT 140 CONTINUE DO 144 I=1,7 SX(I)= SNGL(DX1(I)) SY(I)= SNGL(DY1(I)) STX(I)= SNGL(DT9X(I,KN,KI)) STY(I)= SNGL(DT9Y(I,KN,KI)) 144 CONTINUE CALL SROT (N,SX,INCX,SY,INCY,SC,SS) CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) GO TO 500 C 15. DROT 150 CONTINUE DO 154 I=1,7 DX(I)=DX1(I) DY(I)=DY1(I) 154 CONTINUE CALL DROT (N,DX,INCX,DY,INCY,DC,DS) CALL DTEST(LENX,DX,DT9X(1,KN,KI), DSIZE2(1,KSIZE),DFAC) CALL DTEST(LENY,DY,DT9Y(1,KN,KI),DSIZE2(1,KSIZE),DFAC) GO TO 500 C 18. SROTM 180 KNI=KN+4*(KI-1) DO 189 KPAR=1,4 DO 182 I=1,7 SX(I)= SNGL(DX1(I)) SY(I)= SNGL(DY1(I)) STX(I)= SNGL(DT19X(I,KPAR,KNI)) 182 STY(I)= SNGL(DT19Y(I,KPAR,KNI)) C DO 186 I=1,5 186 SPARAM(I) = SNGL(DPAR(I,KPAR)) C SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, C IF ANY MODE = INT(SPARAM(1)) C DO 187 I=1,LENX 187 SSIZE(I)=STX(I) C THE TRUE RESULTS DT19X(1,2,7) AND C DT19X(5,3,8) ARE ZERO DUE TO CANCELLATION. C DT19X(1,2,7) = 2.*.6 - 4.*.3 = 0 C DT19X(5,3,8) = .9 - 3.*.3 = 0 C FOR THESE CASES RESPECTIVELY SET SIZE( ) C EQUAL TO 2.4 AND 1.8 IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) 1 SSIZE(1) = 2.4E0 IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8)) 1 SSIZE(5) = 1.8E0 C CALL SROTM(N,SX,INCX,SY,INCY,SPARAM) CALL STEST(LENX,SX,STX,SSIZE,SFAC) CALL STEST(LENY,SY,STY,STY,SFAC) 189 CONTINUE GO TO 500 C 19. DROTM 190 KNI=KN+4*(KI-1) DO 199 KPAR=1,4 DO 192 I=1,7 DX(I)=DX1(I) DY(I)=DY1(I) DTX(I)= DT19X(I,KPAR,KNI) 192 DTY(I)= DT19Y(I,KPAR,KNI) C DO 196 I=1,5 196 DPARAM(I) = DPAR(I,KPAR) C SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, C IF ANY MODE = IDINT(DPARAM(1)) C DO 197 I=1,LENX 197 DSIZE(I)=DTX(I) C SEE REMARK ABOVE ABOUT DT11X(1,2,7) C AND DT11X(5,3,8). IF ((KPAR .EQ. 2) .AND. (KNI .EQ. 7)) 1 DSIZE(1) = 2.4D0 IF ((KPAR .EQ. 3) .AND. (KNI .EQ. 8)) 1 DSIZE(5) = 1.8D0 C CALL DROTM(N,DX,INCX,DY,INCY,DPARAM) CALL DTEST(LENX,DX,DTX,DSIZE,DFAC) CALL DTEST(LENY,DY,DTY,DTY,DFAC) 199 CONTINUE GO TO 500 C 20. SCOPY 200 DO 205 I=1,7 205 STY(I)= SNGL(DT10Y( I,KN,KI)) CALL SCOPY(N,SX,INCX,SY,INCY) CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.) GO TO 500 C 21. DCOPY 210 CALL DCOPY(N,DX,INCX,DY,INCY) CALL DTEST(LENY,DY,DT10Y(1,KN,KI), DSIZE2(1,1),1.D0 ) GO TO 500 C 22. CCOPY 220 CALL CCOPY(N,CX,INCX,CY,INCY) CALL CTEST (LENY,CY,CT10Y(1,KN,KI),SSIZE2(1,1),1.) GO TO 500 C 23. SSWAP 230 CALL SSWAP(N,SX,INCX,SY,INCY) DO 235 I=1,7 STX(I)= SNGL(DT10X(I,KN,KI)) 235 STY(I)= SNGL(DT10Y(I,KN,KI)) CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.) CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.) GO TO 500 C 24. DSWAP 240 CALL DSWAP(N,DX,INCX,DY,INCY) CALL DTEST(LENX,DX,DT10X(1,KN,KI), DSIZE2(1,1),1.D0) CALL DTEST(LENY,DY,DT10Y(1,KN,KI), DSIZE2(1,1),1.D0) GO TO 500 C 25. CSWAP 250 CALL CSWAP(N,CX,INCX,CY,INCY) CALL CTEST (LENX,CX,CT10X(1,KN,KI), SSIZE2(1,1),1.) CALL CTEST (LENY,CY, CT10Y(1,KN,KI), SSIZE2(1,1),1.) C C C 500 CONTINUE 520 CONTINUE RETURN C THE FOLLOWING STOP SHOULD NEVER BE REACHED. 999 STOP END SUBROUTINE MPBLAS(I1) C C THIS SUBROUTINE IS CALLED TO SET UP BRENT'S MP PACKAGE C FOR USE BY THE EXTENDED PRECISION INNER PRODUCTS FROM THE BLAS. C C THE COMMON BLOCK FOR THE MP PACKAGE (MODIFIED TO GIVE IT A NAME) COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(12) C C SET I1 = 1 TO FLAG THAT THIS ROUTINE WAS CALLED I1 = 1 C C FOR FULL EXTENDED PRECISION ACCURACY, MPB SHOULD BE AS LARGE AS C POSSIBLE, SUBJECT TO THE RESTRICTIONS IN BRENT'S PAPER (ACM TRANS. C ON MATH. SOFTWARE, MARCH 1978, VOL. 4, NO. 1.). C STATEMENTS BELOW ARE FOR AN INTEGER WORDLENGTH OF 48, 36, 32, C 24, 18, AND 16. PICK ONE, OR GENERATE A NEW ONE. C 48 MPB = 4194304 C 36 MPB = 65536 32 MPB = 16384 C 24 MPB = 1024 C 18 MPB = 128 C 16 MPB = 64 C C SET UP REMAINING PARAMETERS C UNIT FOR ERROR MESSAGES MPLUN = 6 C NUMBER OF MP DIGITS MPT = 8 C DIMENSION OF R MPMXR = 12 C EXPONENT RANGE MPM = 32767 RETURN END C $$ ****** MPADD ****** SUBROUTINE MPADD (X, Y, Z) C ADDS X AND Y, FORMING RESULT IN Z, WHERE X, Y AND Z ARE MP C NUMBERS. FOUR GUARD DIGITS ARE USED, AND THEN R*-ROUNDING. INTEGER X(1), Y(1), Z(1) CALL MPADD2 (X, Y, Z, Y, 0) RETURN END C $$ ****** MPMLP ****** SUBROUTINE MPMLP (U, V, W, J) C PERFORMS INNER MULTIPLICATION LOOP FOR MPMUL C NOTE THAT CARRIES ARE NOT PROPAGATED IN INNER LOOP, C WHICH SAVES TIME AT THE EXPENSE OF SPACE. INTEGER U(1), V(1), W DO 10 I = 1, J 10 U(I) = U(I) + W*V(I) RETURN END C $$ ****** MPUNFL ****** SUBROUTINE MPUNFL (X) C CALLED ON MULTIPLE-PRECISION UNDERFLOW, IE WHEN THE C EXPONENT OF MP NUMBER X WOULD BE LESS THAN -M. INTEGER X(1) C SINCE M MAY HAVE BEEN OVERWRITTEN, CHECK B, T, M ETC. CALL MPCHK (1, 4) C THE UNDERFLOWING NUMBER IS SET TO ZERO C AN ALTERNATIVE WOULD BE TO CALL MPMINR (X) AND RETURN, C POSSIBLY UPDATING A COUNTER AND TERMINATING EXECUTION C AFTER A PRESET NUMBER OF UNDERFLOWS. ACTION COULD EASILY C BE DETERMINED BY A FLAG IN LABELLED COMMON. X(1) = 0 RETURN END C $$ ****** MPMULI ****** SUBROUTINE MPMULI (X, IY, Z) C MULTIPLIES MP X BY SINGLE-PRECISION INTEGER IY GIVING MP Z. C THIS IS FASTER THAN USING MPMUL. RESULT IS ROUNDED. C MULTIPLICATION BY 1 MAY BE USED TO NORMALIZE A NUMBER C EVEN IF THE LAST DIGIT IS B. INTEGER X(1), Z(1) CALL MPMUL2 (X, IY, Z, 0) RETURN END C $$ ****** MPADD2 ****** SUBROUTINE MPADD2 (X, Y, Z, Y1, TRUNC) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C CALLED BY MPADD, MPSUB ETC. C X, Y AND Z ARE MP NUMBERS, Y1 AND TRUNC ARE INTEGERS. C TO FORCE CALL BY REFERENCE RATHER THAN VALUE/RESULT, Y1 IS C DECLARED AS AN ARRAY, BUT ONLY Y1(1) IS EVER USED. C SETS Z = X + Y1(1)*ABS(Y), WHERE Y1(1) = +- Y(1). C IF TRUNC.EQ.0 R*-ROUNDING IS USED, OTHERWISE TRUNCATION. C R*-ROUNDING IS DEFINED IN KUKI AND CODI, COMM. ACM C 16(1973), 223. (SEE ALSO BRENT, IEEE TC-22(1973), 601.) COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1), Y(1), Z(1), Y1(1), TRUNC INTEGER S, ED, RS, RE C CHECK FOR X OR Y ZERO IF (X(1).NE.0) GO TO 20 10 CALL MPSTR(Y, Z) Z(1) = Y1(1) RETURN 20 IF (Y1(1).NE.0) GO TO 40 30 CALL MPSTR (X, Z) RETURN C COMPARE SIGNS 40 S = X(1)*Y1(1) IF (IABS(S).LE.1) GO TO 60 CALL MPCHK (1, 4) WRITE (LUN, 50) 50 FORMAT (44H *** SIGN NOT 0, +1 OR -1 IN CALL TO MPADD2,, $ 33H POSSIBLE OVERWRITING PROBLEM ***) CALL MPERR Z(1) = 0 RETURN C COMPARE EXPONENTS 60 ED = X(2) - Y(2) MED = IABS(ED) IF (ED) 90, 70, 120 C EXPONENTS EQUAL SO COMPARE SIGNS, THEN FRACTIONS IF NEC. 70 IF (S.GT.0) GO TO 100 DO 80 J = 1, T IF (X(J+2) - Y(J+2)) 100, 80, 130 80 CONTINUE C RESULT IS ZERO Z(1) = 0 RETURN C HERE EXPONENT(Y) .GE. EXPONENT(X) 90 IF (MED.GT.T) GO TO 10 100 RS = Y1(1) RE = Y(2) CALL MPADD3 (X, Y, S, MED, RE) C NORMALIZE, ROUND OR TRUNCATE, AND RETURN 110 CALL MPNZR (RS, RE, Z, TRUNC) RETURN C ABS(X) .GT. ABS(Y) 120 IF (MED.GT.T) GO TO 30 130 RS = X(1) RE = X(2) CALL MPADD3 (Y, X, S, MED, RE) GO TO 110 END C $$ ****** MPADD3 ****** SUBROUTINE MPADD3 (X, Y, S, MED, RE) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C CALLED BY MPADD2, DOES INNER LOOPS OF ADDITION COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1), Y(1), S, RE, C, TED TED = T + MED I2 = T + 4 I = I2 C = 0 C CLEAR GUARD DIGITS TO RIGHT OF X DIGITS 10 IF (I.LE.TED) GO TO 20 R(I) = 0 I = I - 1 GO TO 10 20 IF (S.LT.0) GO TO 130 C HERE DO ADDITION, EXPONENT(Y) .GE. EXPONENT(X) IF (I.LT.T) GO TO 40 30 J = I - MED R(I) = X(J+2) I = I - 1 IF (I.GT.T) GO TO 30 40 IF (I.LE.MED) GO TO 60 J = I - MED C = Y(I+2) + X(J+2) + C IF (C.LT.B) GO TO 50 C CARRY GENERATED HERE R(I) = C - B C = 1 I = I - 1 GO TO 40 C NO CARRY GENERATED HERE 50 R(I) = C C = 0 I = I - 1 GO TO 40 60 IF (I.LE.0) GO TO 90 C = Y(I+2) + C IF (C.LT.B) GO TO 70 R(I) = 0 C = 1 I = I - 1 GO TO 60 70 R(I) = C I = I - 1 C NO CARRY POSSIBLE HERE 80 IF (I.LE.0) RETURN R(I) = Y(I+2) I = I - 1 GO TO 80 90 IF (C.EQ.0) RETURN C MUST SHIFT RIGHT HERE AS CARRY OFF END I2P = I2 + 1 DO 100 J = 2, I2 I = I2P - J 100 R(I+1) = R(I) R(1) = 1 RE = RE + 1 RETURN C HERE DO SUBTRACTION, ABS(Y) .GT. ABS(X) 110 J = I - MED R(I) = C - X(J+2) C = 0 IF (R(I).GE.0) GO TO 120 C BORROW GENERATED HERE C = -1 R(I) = R(I) + B 120 I = I - 1 130 IF (I.GT.T) GO TO 110 140 IF (I.LE.MED) GO TO 160 J = I - MED C = Y(I+2) + C - X(J+2) IF (C.GE.0) GO TO 150 C BORROW GENERATED HERE R(I) = C + B C = -1 I = I - 1 GO TO 140 C NO BORROW GENERATED HERE 150 R(I) = C C = 0 I = I - 1 GO TO 140 160 IF (I.LE.0) RETURN C = Y(I+2) + C IF (C.GE.0) GO TO 70 R(I) = C + B C = -1 I = I - 1 GO TO 160 END C $$ ****** MPCDM ****** SUBROUTINE MPCDM (DX, Z) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C CONVERTS DOUBLE-PRECISION NUMBER DX TO MULTIPLE-PRECISION Z. C SOME NUMBERS WILL NOT CONVERT EXACTLY ON MACHINES C WITH BASE OTHER THAN TWO, FOUR OR SIXTEEN. C THIS ROUTINE IS NOT CALLED BY ANY OTHER ROUTINE IN MP, C SO MAY BE OMITTED IF DOUBLE-PRECISION IS NOT AVAILABLE. DOUBLE PRECISION DB, DJ, DX, DBLE COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, Z(1), RS, RE, TP C CHECK LEGALITY OF B, T, M, MXR AND LUN CALL MPCHK (1, 4) I2 = T + 4 C CHECK SIGN IF (DX) 20, 10, 30 C IF DX = 0D0 RETURN 0 10 Z(1) = 0 RETURN C DX .LT. 0D0 20 RS = -1 DJ = -DX GO TO 40 C DX .GT. 0D0 30 RS = 1 DJ = DX 40 IE = 0 50 IF (DJ.LT.1D0) GO TO 60 C INCREASE IE AND DIVIDE DJ BY 16. IE = IE + 1 DJ = 0.0625D0*DJ GO TO 50 60 IF (DJ.GE.0.0625D0) GO TO 70 IE = IE - 1 DJ = 16D0*DJ GO TO 60 C NOW DJ IS DY DIVIDED BY SUITABLE POWER OF 16 C SET EXPONENT TO 0 70 RE = 0 C DB = DFLOAT(B) IS NOT ANSI STANDARD SO USE FLOAT AND DBLE DB = DBLE(FLOAT(B)) C CONVERSION LOOP (ASSUME DOUBLE-PRECISION OPS. EXACT) DO 80 I = 1, I2 DJ = DB*DJ R(I) = IDINT(DJ) 80 DJ = DJ - DBLE(FLOAT(R(I))) C NORMALIZE RESULT CALL MPNZR (RS, RE, Z, 0) IB = MAX0(7*B*B, 32767)/16 TP = 1 C NOW MULTIPLY BY 16**IE IF (IE) 90, 130, 110 90 K = -IE DO 100 I = 1, K TP = 16*TP IF ((TP.LE.IB).AND.(TP.NE.B).AND.(I.LT.K)) GO TO 100 CALL MPDIVI (Z, TP, Z) TP = 1 100 CONTINUE RETURN 110 DO 120 I = 1, IE TP = 16*TP IF ((TP.LE.IB).AND.(TP.NE.B).AND.(I.LT.IE)) GO TO 120 CALL MPMULI (Z, TP, Z) TP = 1 120 CONTINUE 130 RETURN END C $$ ****** MPCHK ****** SUBROUTINE MPCHK (I, J) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C CHECKS LEGALITY OF B, T, M, MXR AND LUN WHICH SHOULD BE SET C IN COMMON. C THE CONDITION ON MXR (THE DIMENSION OF R IN COMMON) IS THAT C MXR .GE. (I*T + J) COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R C FIRST CHECK THAT LUN IN RANGE 1 TO 99, IF NOT PRINT ERROR C MESSAGE ON LOGICAL UNIT 6. IF ((0.LT.LUN).AND.(LUN.LT.100)) GO TO 20 WRITE (6, 10) LUN 10 FORMAT (10H *** LUN =, I10, 26H ILLEGAL IN CALL TO MPCHK,, $ 49H PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***) LUN = 6 CALL MPERR C NOW CHECK LEGALITY OF B, T AND M 20 IF (B.GT.1) GO TO 40 WRITE (LUN, 30) B 30 FORMAT (8H *** B =, I10, 26H ILLEGAL IN CALL TO MPCHK,/ $ 49H PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***) CALL MPERR 40 IF (T.GT.1) GO TO 60 WRITE (LUN, 50) T 50 FORMAT (8H *** T =, I10, 26H ILLEGAL IN CALL TO MPCHK,/ $ 49H PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***) CALL MPERR 60 IF (M.GT.T) GO TO 80 WRITE (LUN, 70) 70 FORMAT (31H *** M .LE. T IN CALL TO MPCHK,/ $ 49H PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***) CALL MPERR C 8*B*B-1 SHOULD BE REPRESENTABLE, IF NOT WILL OVERFLOW C AND MAY BECOME NEGATIVE, SO CHECK FOR THIS 80 IB = 4*B*B - 1 IF ((IB.GT.0).AND.((2*IB+1).GT.0)) GO TO 100 WRITE (LUN, 90) 90 FORMAT (37H *** B TOO LARGE IN CALL TO MPCHK ***) CALL MPERR C CHECK THAT SPACE IN COMMON IS SUFFICIENT 100 MX = I*T + J IF (MXR.GE.MX) RETURN C HERE COMMON IS TOO SMALL, SO GIVE ERROR MESSAGE. WRITE (LUN, 110) I, J, MX, MXR, T 110 FORMAT (51H *** MXR TOO SMALL OR NOT SET TO DIM(R) BEFORE CALL, $ 21H TO AN MP ROUTINE *** / $ 27H *** MXR SHOULD BE AT LEAST, I3, 4H*T +, I4, 2H =, I6, 5H *** $ / 19H *** ACTUALLY MXR =, I10, 9H, AND T =, I10, 5H ***) CALL MPERR RETURN END C $$ ****** MPCMD ****** SUBROUTINE MPCMD (X, DZ) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C CONVERTS MULTIPLE-PRECISION X TO DOUBLE-PRECISION DZ. C ASSUMES X IS IN ALLOWABLE RANGE FOR DOUBLE-PRECISION C NUMBERS. THERE IS SOME LOSS OF ACCURACY IF THE C EXPONENT IS LARGE. DOUBLE PRECISION DB, DZ, DZ2, DBLE, DLOG, DABS COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1), TM C CHECK LEGALITY OF B, T, M, MXR AND LUN CALL MPCHK (1, 4) DZ = 0D0 IF (X(1).EQ.0) RETURN C DB = DFLOAT(B) IS NOT ANSI STANDARD, SO USE FLOAT AND DBLE DB = DBLE(FLOAT(B)) DO 10 I = 1, T DZ = DB*DZ + DBLE(FLOAT(X(I+2))) TM = I C CHECK IF FULL DOUBLE-PRECISION ACCURACY ATTAINED DZ2 = DZ + 1D0 C TEST BELOW NOT ALWAYS EQUIVALENT TO - IF (DZ2.LE.DZ) GO TO 20, C FOR EXAMPLE ON CYBER 76. IF ((DZ2-DZ).LE.0D0) GO TO 20 10 CONTINUE C NOW ALLOW FOR EXPONENT 20 DZ = DZ*(DB**(X(2)-TM)) C CHECK REASONABLENESS OF RESULT. IF (DZ.LE.0D0) GO TO 30 C LHS SHOULD BE .LE. 0.5 BUT ALLOW FOR SOME ERROR IN DLOG IF (DABS(DBLE(FLOAT(X(2)))-(DLOG(DZ)/ $ DLOG(DBLE(FLOAT(B)))+0.5D0)).GT.0.6D0) GO TO 30 IF (X(1).LT.0) DZ = -DZ RETURN C FOLLOWING MESSAGE INDICATES THAT X IS TOO LARGE OR SMALL - C TRY USING MPCMDE INSTEAD. 30 WRITE (LUN, 40) 40 FORMAT (48H *** FLOATING-POINT OVER/UNDER-FLOW IN MPCMD ***) CALL MPERR RETURN END C $$ ****** MPDIVI ****** SUBROUTINE MPDIVI (X, IY, Z) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C DIVIDES MP X BY THE SINGLE-PRECISION INTEGER IY GIVING MP Z. C THIS IS MUCH FASTER THAN DIVISION BY AN MP NUMBER. COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1), Z(1), RS, RE, R1, C, C2, B2 RS = X(1) J = IY IF (J) 30, 10, 40 10 WRITE (LUN, 20) 20 FORMAT (53H *** ATTEMPTED DIVISION BY ZERO IN CALL TO MPDIVI ***) GO TO 230 30 J = -J RS = -RS 40 RE = X(2) C CHECK FOR ZERO DIVIDEND IF (RS.EQ.0) GO TO 120 C CHECK FOR DIVISION BY B IF (J.NE.B) GO TO 50 CALL MPSTR (X, Z) IF (RE.LE.(-M)) GO TO 240 Z(1) = RS Z(2) = RE - 1 RETURN C CHECK FOR DIVISION BY 1 OR -1 50 IF (J.NE.1) GO TO 60 CALL MPSTR (X, Z) Z(1) = RS RETURN 60 C = 0 I2 = T + 4 I = 0 C IF J*B NOT REPRESENTABLE AS AN INTEGER HAVE TO SIMULATE C LONG DIVISION. ASSUME AT LEAST 16-BIT WORD. B2 = MAX0 (8*B, 32767/B) IF (J.GE.B2) GO TO 130 C LOOK FOR FIRST NONZERO DIGIT IN QUOTIENT 70 I = I + 1 C = B*C IF (I.LE.T) C = C + X(I+2) R1 = C/J IF (R1) 210, 70, 80 C ADJUST EXPONENT AND GET T+4 DIGITS IN QUOTIENT 80 RE = RE + 1 - I R(1) = R1 C = B*(C - J*R1) KH = 2 IF (I.GE.T) GO TO 100 KH = 1 + T - I DO 90 K = 2, KH I = I + 1 C = C + X(I+2) R(K) = C/J 90 C = B*(C - J*R(K)) IF (C.LT.0) GO TO 210 KH = KH + 1 100 DO 110 K = KH, I2 R(K) = C/J 110 C = B*(C - J*R(K)) IF (C.LT.0) GO TO 210 C NORMALIZE AND ROUND RESULT 120 CALL MPNZR (RS, RE, Z, 0) RETURN C HERE NEED SIMULATED DOUBLE-PRECISION DIVISION 130 C2 = 0 J1 = J/B J2 = J - J1*B J11 = J1 + 1 C LOOK FOR FIRST NONZERO DIGIT 140 I = I + 1 C = B*C + C2 C2 = 0 IF (I.LE.T) C2 = X(I+2) IF (C-J1) 140, 150, 160 150 IF (C2.LT.J2) GO TO 140 C COMPUTE T+4 QUOTIENT DIGITS 160 RE = RE + 1 - I K = 1 GO TO 180 C MAIN LOOP FOR LARGE ABS(IY) CASE 170 K = K + 1 IF (K.GT.I2) GO TO 120 I = I + 1 C GET APPROXIMATE QUOTIENT FIRST 180 IR = C/J11 C NOW REDUCE SO OVERFLOW DOES NOT OCCUR IQ = C - IR*J1 IF (IQ.LT.B2) GO TO 190 C HERE IQ*B WOULD POSSIBLY OVERFLOW SO INCREASE IR IR = IR + 1 IQ = IQ - J1 190 IQ = IQ*B - IR*J2 IF (IQ.GE.0) GO TO 200 C HERE IQ NEGATIVE SO IR WAS TOO LARGE IR = IR - 1 IQ = IQ + J 200 IF (I.LE.T) IQ = IQ + X(I+2) IQJ = IQ/J C R(K) = QUOTIENT, C = REMAINDER R(K) = IQJ + IR C = IQ - J*IQJ IF (C.GE.0) GO TO 170 C CARRY NEGATIVE SO OVERFLOW MUST HAVE OCCURRED 210 CALL MPCHK (1, 4) WRITE (LUN, 220) 220 FORMAT (48H *** INTEGER OVERFLOW IN MPDIVI, B TOO LARGE ***) 230 CALL MPERR Z(1) = 0 RETURN C UNDERFLOW HERE 240 CALL MPUNFL(Z) RETURN END C $$ ****** MPERR ****** SUBROUTINE MPERR C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C THIS ROUTINE IS CALLED WHEN A FATAL ERROR CONDITION IS C ENCOUNTERED, AND AFTER A MESSAGE HAS BEEN WRITTEN ON C LOGICAL UNIT LUN. COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R WRITE (LUN, 10) 10 FORMAT (42H *** EXECUTION TERMINATED BY CALL TO MPERR, $ 25H IN MP VERSION 770217 ***) C AT PRESENT JUST STOP, BUT COULD DUMP B, T, ETC. HERE. C ACTION COULD EASILY BE CONTROLLED BY A FLAG IN LABELLED COMMON. C ANSI VERSION USES STOP, UNIVAC 1108 VERSION USES C RETURN 0 IN ORDER TO GIVE A TRACE-BACK. C FOR DEBUGGING PURPOSES IT MAY BE USEFUL SIMPLY TO C RETURN HERE. MOST MP ROUTINES RETURN WITH RESULT C ZERO AFTER CALLING MPERR. STOP END C $$ ****** MPMAXR ****** SUBROUTINE MPMAXR (X) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C SETS X TO THE LARGEST POSSIBLE POSITIVE MP NUMBER COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1) C CHECK LEGALITY OF B, T, M, MXR AND LUN CALL MPCHK (1, 4) IT = B - 1 C SET FRACTION DIGITS TO B-1 DO 10 I = 1, T 10 X(I+2) = IT C SET SIGN AND EXPONENT X(1) = 1 X(2) = M RETURN END C $$ ****** MPMUL ****** SUBROUTINE MPMUL (X, Y, Z) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C MULTIPLIES X AND Y, RETURNING RESULT IN Z, FOR MP X, Y AND Z. C THE SIMPLE O(T**2) ALGORITHM IS USED, WITH C FOUR GUARD DIGITS AND R*-ROUNDING. C ADVANTAGE IS TAKEN OF ZERO DIGITS IN X, BUT NOT IN Y. C ASYMPTOTICALLY FASTER ALGORITHMS ARE KNOWN (SEE KNUTH, C VOL. 2), BUT ARE DIFFICULT TO IMPLEMENT IN FORTRAN IN AN C EFFICIENT AND MACHINE-INDEPENDENT MANNER. C IN COMMENTS TO OTHER MP ROUTINES, M(T) IS THE TIME C TO PERFORM T-DIGIT MP MULTIPLICATION. THUS C M(T) = O(T**2) WITH THE PRESENT VERSION OF MPMUL, C BUT M(T) = O(T.LOG(T).LOG(LOG(T))) IS THEORETICALLY POSSIBLE. COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1), Y(1), Z(1), RS, RE, XI, C, RI C CHECK LEGALITY OF B, T, M, MXR AND LUN CALL MPCHK (1, 4) I2 = T + 4 I2P = I2 + 1 C FORM SIGN OF PRODUCT RS = X(1)*Y(1) IF (RS.NE.0) GO TO 10 C SET RESULT TO ZERO Z(1) = 0 RETURN C FORM EXPONENT OF PRODUCT 10 RE = X(2) + Y(2) C CLEAR ACCUMULATOR DO 20 I = 1, I2 20 R(I) = 0 C PERFORM MULTIPLICATION C = 8 DO 40 I = 1, T XI = X(I+2) C FOR SPEED, PUT THE NUMBER WITH MANY ZEROS FIRST IF (XI.EQ.0) GO TO 40 CALL MPMLP (R(I+1), Y(3), XI, MIN0 (T, I2 - I)) C = C - 1 IF (C.GT.0) GO TO 40 C CHECK FOR LEGAL BASE B DIGIT IF ((XI.LT.0).OR.(XI.GE.B)) GO TO 90 C PROPAGATE CARRIES AT END AND EVERY EIGHTH TIME, C FASTER THAN DOING IT EVERY TIME. DO 30 J = 1, I2 J1 = I2P - J RI = R(J1) + C IF (RI.LT.0) GO TO 70 C = RI/B 30 R(J1) = RI - B*C IF (C.NE.0) GO TO 90 C = 8 40 CONTINUE IF (C.EQ.8) GO TO 60 IF ((XI.LT.0).OR.(XI.GE.B)) GO TO 90 C = 0 DO 50 J = 1, I2 J1 = I2P - J RI = R(J1) + C IF (RI.LT.0) GO TO 70 C = RI/B 50 R(J1) = RI - B*C IF (C.NE.0) GO TO 90 C NORMALIZE AND ROUND RESULT 60 CALL MPNZR (RS, RE, Z, 0) RETURN 70 WRITE (LUN, 80) 80 FORMAT (47H *** INTEGER OVERFLOW IN MPMUL, B TOO LARGE ***) GO TO 110 90 WRITE (LUN, 100) 100 FORMAT (43H *** ILLEGAL BASE B DIGIT IN CALL TO MPMUL,, $ 33H POSSIBLE OVERWRITING PROBLEM ***) 110 CALL MPERR Z(1) = 0 RETURN END C $$ ****** MPMUL2 ****** SUBROUTINE MPMUL2 (X, IY, Z, TRUNC) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C MULTIPLIES MP X BY SINGLE-PRECISION INTEGER IY GIVING MP Z. C MULTIPLICATION BY 1 MAY BE USED TO NORMALIZE A NUMBER C EVEN IF SOME DIGITS ARE GREATER THAN B-1. C RESULT IS ROUNDED IF TRUNC.EQ.0, OTHERWISE TRUNCATED. COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1), Z(1), TRUNC, RE, RS INTEGER C, C1, C2, RI, T1, T3, T4 RS = X(1) IF (RS.EQ.0) GO TO 10 J = IY IF (J) 20, 10, 50 C RESULT ZERO 10 Z(1) = 0 RETURN 20 J = -J RS = -RS C CHECK FOR MULTIPLICATION BY B IF (J.NE.B) GO TO 50 IF (X(2).LT.M) GO TO 40 CALL MPCHK (1, 4) WRITE (LUN, 30) 30 FORMAT (36H *** OVERFLOW OCCURRED IN MPMUL2 ***) CALL MPOVFL (Z) RETURN 40 CALL MPSTR (X, Z) Z(1) = RS Z(2) = X(2) + 1 RETURN C SET EXPONENT TO EXPONENT(X) + 4 50 RE = X(2) + 4 C FORM PRODUCT IN ACCUMULATOR C = 0 T1 = T + 1 T3 = T + 3 T4 = T + 4 C IF J*B NOT REPRESENTABLE AS AN INTEGER WE HAVE TO SIMULATE C DOUBLE-PRECISION MULTIPLICATION. IF (J.GE.MAX0(8*B, 32767/B)) GO TO 110 DO 60 IJ = 1, T I = T1 - IJ RI = J*X(I+2) + C C = RI/B 60 R(I+4) = RI - B*C C CHECK FOR INTEGER OVERFLOW IF (RI.LT.0) GO TO 130 C HAVE TO TREAT FIRST FOUR WORDS OF R SEPARATELY DO 70 IJ = 1, 4 I = 5 - IJ RI = C C = RI/B 70 R(I) = RI - B*C IF (C.EQ.0) GO TO 100 C HAVE TO SHIFT RIGHT HERE AS CARRY OFF END 80 DO 90 IJ = 1, T3 I = T4 - IJ 90 R(I+1) = R(I) RI = C C = RI/B R(1) = RI - B*C RE = RE + 1 IF (C) 130, 100, 80 C NORMALIZE AND ROUND OR TRUNCATE RESULT 100 CALL MPNZR (RS, RE, Z, TRUNC) RETURN C HERE J IS TOO LARGE FOR SINGLE-PRECISION MULTIPLICATION 110 J1 = J/B J2 = J - J1*B C FORM PRODUCT DO 120 IJ = 1, T4 C1 = C/B C2 = C - B*C1 I = T1 - IJ IX = 0 IF (I.GT.0) IX = X(I+2) RI = J2*IX + C2 IS = RI/B C = J1*IX + C1 + IS 120 R(I+4) = RI - B*IS IF (C) 130, 100, 80 C CAN ONLY GET HERE IF INTEGER OVERFLOW OCCURRED 130 CALL MPCHK (1, 4) WRITE (LUN, 140) 140 FORMAT (48H *** INTEGER OVERFLOW IN MPMUL2, B TOO LARGE ***) CALL MPERR GO TO 10 END C $$ ****** MPNZR ****** SUBROUTINE MPNZR (RS, RE, Z, TRUNC) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C ASSUMES LONG (I.E. (T+4)-DIGIT) FRACTION IN C R, SIGN = RS, EXPONENT = RE. NORMALIZES, C AND RETURNS MP RESULT IN Z. INTEGER ARGUMENTS RS AND RE C ARE NOT PRESERVED. R*-ROUNDING IS USED IF TRUNC.EQ.0 COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, Z(1), RE, RS, TRUNC, B2 I2 = T + 4 IF (RS.NE.0) GO TO 20 C STORE ZERO IN Z 10 Z(1) = 0 RETURN C CHECK THAT SIGN = +-1 20 IF (IABS(RS).LE.1) GO TO 40 WRITE (LUN, 30) 30 FORMAT (43H *** SIGN NOT 0, +1 OR -1 IN CALL TO MPNZR,, $ 33H POSSIBLE OVERWRITING PROBLEM ***) CALL MPERR GO TO 10 C LOOK FOR FIRST NONZERO DIGIT 40 DO 50 I = 1, I2 IS = I - 1 IF (R(I).GT.0) GO TO 60 50 CONTINUE C FRACTION ZERO GO TO 10 60 IF (IS.EQ.0) GO TO 90 C NORMALIZE RE = RE - IS I2M = I2 - IS DO 70 J = 1, I2M K = J + IS 70 R(J) = R(K) I2P = I2M + 1 DO 80 J = I2P, I2 80 R(J) = 0 C CHECK TO SEE IF TRUNCATION IS DESIRED 90 IF (TRUNC.NE.0) GO TO 150 C SEE IF ROUNDING NECESSARY C TREAT EVEN AND ODD BASES DIFFERENTLY B2 = B/2 IF ((2*B2).NE.B) GO TO 130 C B EVEN. ROUND IF R(T+1).GE.B2 UNLESS R(T) ODD AND ALL ZEROS C AFTER R(T+2). IF (R(T+1) - B2) 150, 100, 110 100 IF (MOD(R(T),2).EQ.0) GO TO 110 IF ((R(T+2)+R(T+3)+R(T+4)).EQ.0) GO TO 150 C ROUND 110 DO 120 J = 1, T I = T + 1 - J R(I) = R(I) + 1 IF (R(I).LT.B) GO TO 150 120 R(I) = 0 C EXCEPTIONAL CASE, ROUNDED UP TO .10000... RE = RE + 1 R(1) = 1 GO TO 150 C ODD BASE, ROUND IF R(T+1)... .GT. 1/2 130 DO 140 I = 1, 4 IT = T + I IF (R(IT) - B2) 150, 140, 110 140 CONTINUE C CHECK FOR OVERFLOW 150 IF (RE.LE.M) GO TO 170 WRITE (LUN, 160) 160 FORMAT (35H *** OVERFLOW OCCURRED IN MPNZR ***) CALL MPOVFL (Z) RETURN C CHECK FOR UNDERFLOW 170 IF (RE.LT.(-M)) GO TO 190 C STORE RESULT IN Z Z(1) = RS Z(2) = RE DO 180 I = 1, T 180 Z(I+2) = R(I) RETURN C UNDERFLOW HERE 190 CALL MPUNFL (Z) RETURN END C $$ ****** MPOVFL ****** SUBROUTINE MPOVFL (X) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C CALLED ON MULTIPLE-PRECISION OVERFLOW, IE WHEN THE C EXPONENT OF MP NUMBER X WOULD EXCEED M. C AT PRESENT EXECUTION IS TERMINATED WITH AN ERROR MESSAGE C AFTER CALLING MPMAXR(X), BUT IT WOULD BE POSSIBLE TO RETURN, C POSSIBLY UPDATING A COUNTER AND TERMINATING EXECUTION AFTER C A PRESET NUMBER OF OVERFLOWS. ACTION COULD EASILY BE DETERMINED C BY A FLAG IN LABELLED COMMON. COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1) C M MAY HAVE BEEN OVERWRITTEN, SO CHECK B, T, M ETC. CALL MPCHK (1, 4) C SET X TO LARGEST POSSIBLE POSITIVE NUMBER CALL MPMAXR (X) WRITE (LUN, 10) 10 FORMAT (45H *** CALL TO MPOVFL, MP OVERFLOW OCCURRED ***) C TERMINATE EXECUTION BY CALLING MPERR CALL MPERR RETURN END C $$ ****** MPSTR ****** SUBROUTINE MPSTR (X, Y) C MODIFIED FOR USE WITH BLAS. C COMMON CHANGED TO NAMED COMMON, R GIVEN DIMENSION 12. C SETS Y = X FOR MP X AND Y. COMMON /MPCOM/ B, T, M, LUN, MXR, R(12) INTEGER B, T, R, X(1), Y(1), T2 C SEE IF X AND Y HAVE THE SAME ADDRESS (THEY OFTEN DO) J = X(1) Y(1) = J + 1 IF (J.EQ.X(1)) GO TO 10 C HERE X(1) AND Y(1) MUST HAVE THE SAME ADDRESS X(1) = J RETURN C HERE X(1) AND Y(1) HAVE DIFFERENT ADDRESSES 10 Y(1) = J C NO NEED TO MOVE X(2), ... IF X(1) = 0 IF (J.EQ.0) RETURN T2 = T + 2 DO 20 I = 2, T2 20 Y(I) = X(I) RETURN END MACRO 10 &ADDR INCFX &R1,&R2,&R3,&R4,&SHIFT,&BRANCH 20 .* ADJUST BASE ADDRESS OF ARRAYS IF INCREMENTS ARE NEGATIVE 30 &ADDR L &R2,0(&R2) 40 SLA &R2,&SHIFT 50 BP &BRANCH 60 LR &R4,&R2 70 MR &R4-1,&R3 80 SR &R1,&R4 90 MEND 100 ./ ADD NAME=INCBR 110 MACRO 120 &ADDR INCBR &R1,&R2,&R3,&R4,&R5,&LABEL 130 .* STANDARD INCREMENTING AND TESTING FOR LOOP END 140 &ADDR AR &R1,&R2 150 AR &R3,&R4 160 BCT &R5,&LABEL 170 MEND 180 ./ ADD NAME=NCHK 190 MACRO 200 &ADDR NCHK &R1,&R2,&LABEL 210 .* TEST FOR N .GT. 0. QUIT WHEN N .LE. 0 220 &ADDR L &R1,0(&R2) 230 LTR &R2,&R1 240 BNP &LABEL 250 BCTR &R1,0 260 MEND 270 ./ ADD NAME=EQUATE 280 MACRO 290 EQUATE 300 .* DEFINE SYMBOLIC NAMES OF REGS., ETC. 310 R0 EQU 0 320 R1 EQU 1 330 R2 EQU 2 340 R3 EQU 3 350 R4 EQU 4 360 R5 EQU 5 370 R6 EQU 6 380 R7 EQU 7 390 R8 EQU 8 400 R9 EQU 9 410 R10 EQU 10 420 R11 EQU 11 430 R12 EQU 12 440 R13 EQU 13 450 R14 EQU 14 460 R15 EQU 15 470 F0 EQU 0 480 F2 EQU 2 490 F4 EQU 4 500 F6 EQU 6 510 RSTAR4 EQU 2 520 RSTAR8 EQU 3 530 CSTAR8 EQU 3 540 CSTAR16 EQU 4 550 MEND 560 ./ ADD NAME=PROLOG 570 MACRO 580 &NAME PROLOG &MAXREG,&EPID=YES,&TRACE=YES 590 .* VARIOUS INDIVIDUALS HAVE CONTRIBUTED TO THE 360 ASM. 600 .* EFFORT. THESE INCLUDE 610 .* R.J.HANSON, TIM HARRINGTON, JOHN WISNIEWSKI, AND KAREN HASKELL 620 .* SPECIAL THANKS TO PROF. DAVE BENSON FOR HELP WITH IBM/360 ASM. 630 .* PROPERTIES. 640 GBLB &CALLQ 650 GBLC ®NUM 660 LCLA &K 670 .* 680 .* THIS NEXT CARD STOPS MACRO EXPANSION ON THE PRINT. 690 PRINT NOGEN 700 &NAME CSECT 710 EQUATE 720 AIF ('&TRACE' NE 'YES').L1 730 HSA EQU 4 . HIGHER SAVEAREA 740 LSA EQU 8 . LOWER SAVEAREA 750 .L1 ANOP 760 &CALLQ SETB ('&TRACE' EQ 'YES') 770 ®NUM SETC '&MAXREG' 780 AIF ('&EPID' NE 'YES' AND '&TRACE' NE 'YES').L30 790 USING &NAME,15 . TEMPORARY BASE REGISTER 800 B PRO&SYSNDX 810 AIF ('&EPID' NE 'YES').L10 820 &K SETA K'&NAME 830 DC AL1(&K) . LENGTH OF EPID 840 DC CL&K'&NAME' . ENTRY POINT INDICATOR 850 .L10 AIF ('&TRACE' NE 'YES').L15 860 SAVE&SYSNDX DS 18F . SAVEAREA 870 .L15 ANOP 880 PRO&SYSNDX DS 0H 890 DROP 15 900 .L20 AIF ('&TRACE' NE 'YES').L30 910 STM 14,&MAXREG+1,12(13) 920 USING &NAME,15 930 LA 14,SAVE&SYSNDX . MY SAVEAREA 940 ST 14,LSA(13) . SAVEAREA 950 ST 13,HSA(14) . POINTERS 960 LR 13,14 970 LR &MAXREG+1,15 980 DROP 15 990 USING &NAME,&MAXREG+1 . PROGRAM BASE REGISTER 1000 MEXIT 1010 .L30 STM 14,&MAXREG,12(13) 1020 USING &NAME,15 . PROGRAM BASE REGISTER 1030 MEND 1040 ./ ADD NAME=EPILOG 1050 MACRO 1060 &LBL EPILOG &RESULT 1070 GBLB &CALLQ 1080 GBLC ®NUM 1090 AIF (&CALLQ).L10 1100 AIF (T'&RESULT EQ 'O').L5 1110 &LBL LM 14,15,12(13) . RESULT IN R0. 1120 LM 1,®NUM,24(13) 1130 AGO .L50 1140 .L5 ANOP 1150 &LBL LM 14,®NUM,12(13) . RESULTS IN F0. 1160 AGO .L50 1170 .L10 AIF (T'&RESULT EQ 'O').L15 1180 &LBL L 13,HSA(13) . RESTORE CALLER'S SAVEAREA. 1190 LM 14,15,12(13) . RESULT IN R0. 1200 LM 1,®NUM+1,24(13) 1210 AGO .L50 1220 .L15 ANOP 1230 &LBL L 13,HSA(13) . RESTORE CALLERS'S SAVEAREA. 1240 LM 14,®NUM+1,12(13) . 1250 AGO .L50 1260 .L50 BR 14 . RETURN TO CALLING PROGRAM. 1270 MEND 1280 ./ ADD NAME=FIXH 1290 MACRO 1300 &LABEL FIXH 1310 &LABEL LE F6,SFLAG . GET SFLAG 1320 LTER F6,F6 . TEST SFLAG 1330 BM FXHC&SYSNDX . IF SFLAG<0 RETURN 1340 BZ FXHB&SYSNDX . IF SFLAG=0 BRANCH TO B1 1350 LE F6,=E'1.0' . SFLAG>0 CASE; PUT 1.0 INTO F6 1360 STE F6,H12 . SET H12=1.0 1370 LCER F6,F6 . SET F6=-1.0 1380 STE F6,H21 . SET H21=-1.0 1390 B FXHA&SYSNDX 1400 FXHB&SYSNDX LE F6,=E'1.0' . PUT 1.0 INTO F6(B1 BRANCH) 1410 STE F6,H11 . SET H11=1.0 1420 STE F6,H22 . SET H22=1.0 1430 FXHA&SYSNDX LNER F6,F6 . SET F6=-1. 1440 STE F6,SFLAG . SET SFLAG=-1. 1450 FXHC&SYSNDX DS 0H 1460 MEND 1470 ./ ADD NAME=DFIXH 1480 MACRO 1490 &LABEL DFIXH 1500 &LABEL LD F6,DFLAG . GET DFLAG 1510 LTDR F6,F6 . TEST DFLAG 1520 BM FXHC&SYSNDX . IF DFLAG<0 RETURN 1530 BZ FXHB&SYSNDX . IF DFLAG=0 BRANCH TO B1 1540 LD F6,=D'1.0' . DFLAG>0 CASE; PUT 1.0 INTO F6 1550 STD F6,H12 . SET H12=1.0 1560 LCDR F6,F6 . SET F6=-1.0 1570 STD F6,H21 . 1580 B FXHA&SYSNDX 1590 FXHB&SYSNDX LD F6,=D'1.0' . PUT 1.0 INTO F6(B1 BRANCH) 1600 STD F6,H11 . SET H11=1.0 1610 STD F6,H22 . SET H22=1.0 1620 FXHA&SYSNDX LNDR F6,F6 . SET F6=-1.0 1630 STD F6,DFLAG . SET DFLAG=-1. 1640 FXHC&SYSNDX DS 0H 1650 MEND 1660 //ASM.SYSIN DD * 1670 *********SINGLE PRECISION INNER PRODUCT, SDOT, IBM/360 ASM.************ 1680 * USAGE STATEMENT 14 AUGUST 1975* 1690 * SW = SDOT (N,SX,INCX,SY,INCY) WASH. ST. U./ANL* 1700 * SW,SDOT,SX( ),SY( ),REAL*4 N,INCX,INCY,INTEGER*4 * 1710 *********************************************************************** 1720 SDOT PROLOG R11 1730 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 1740 SER F0,F0 SET SDOT = 0.0 1750 NCHK R7,R2,DONE GET N AND EXIT IF N .LE. 0 1760 L R11,0(R4) GET INCX 1770 C R11,0(R6) COMPARE INCY WITH INCX 1780 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 1790 SLA R11,RSTAR4 MULTIPLY INCS * 4 1800 BM INCNE BRANCH TO GEN. LOOP IF NEG. 1810 LR R8,R11 STORE INCX*4 IN UNOCCUPIED R8 1820 MR R10,R7 COMPUTE INCX * 4 * (N-1) 1830 SR R6,R6 SET R6 = 0 1840 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 1850 CNOP 0,8 ALIGN ON DOUBLE WORD. 1860 LOOPEQ LE F2,0(R6,R3) GET SX( ) AND MULTIPLY 1870 ME F2,0(R6,R5) BY SY( ) AND ACCUMULATE 1880 AER F0,F2 INNER PRODUCT IN F0 1890 BXLE R6,R10,LOOPEQ 1900 B DONE 1910 INCNE INCFX R3,R4,R7,R9,RSTAR4,ICY FIX SX( ) INCREMENT 1920 ICY INCFX R5,R6,R7,R9,RSTAR4,LOOPNE FIX SY( ) INCREMENT 1930 CNOP 0,8 ALIGN ON DOUBLE WORD. 1940 LOOPNE LE F2,0(R3) GET SX( ) AND MULTIPLY 1950 ME F2,0(R5) BY SY( ) AND ACCUMULATE 1960 AER F0,F2 INNER PRODUCT IN F0 1970 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE 1980 DONE EPILOG 1990 END 2000 *********DOUBLE PRECISION INNER PRODUCT, DSDOT, IBM/360 ASM.*********** 2010 * USAGE STATEMENT 19 MAY 1974* 2020 * DW = DSDOT(N,SX,INCX,SY,INCY) WASH. ST. U* 2030 * DW,DSDOT,REAL*8 SX( ),SY( ) REAL *4, N,INCX,INCY INTEGER * 4 * 2040 *********************************************************************** 2050 DSDOT PROLOG R9 2060 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 2070 SDR F0,F0 SET DSDOT = 0 2080 NCHK R7,R2,DONE GET N AND QUIT IF N .LE. 0 2090 INCFX R3,R4,R7,R9,RSTAR4,ICY FIX SX( ) INCREMENT 2100 ICY INCFX R5,R6,R7,R9,RSTAR4,LOOP FIX SY( ) INCREMENT 2110 CNOP 0,8 ALIGN ON DOUBLE WORD. 2120 LOOP LE F2,0(R3) GET SX( ) AND 2130 ME F2,0(R5) MULTIPLY BY SY( ) AND 2140 ADR F0,F2 ACCUMULATE INNER PRODUCT 2150 INCBR R3,R4,R5,R6,R2,LOOP ADD INCREMENTS AND CONTINUE LOOP 2160 DONE EPILOG 2170 END 2180 *********ACCUM. INNER. PROD. AND ADD SCALAR, SDSDOT, IBM/360 ASM.****** 2190 * USAGE STATEMENT 19 MAY 1974* 2200 * SW = SDSDOT(N,SB,SX,INCX,SY,INCY) WASH. ST. U* 2210 * SW,SDSDOT,SB,SX( ),SY( ), REAL * 4, N,INCX,INCY INTEGER * 4 * 2220 *********************************************************************** 2230 SDSDOT PROLOG R11 2240 LM R2,R7,0(R1) GET POINTERS TO ARGUMENTS 2250 SDR F0,F0 SET SDSDOT =0.D0 2260 LE F0,0(R3) LOAD DBLE(SB) 2270 NCHK R9,R2,DONE GET N AND QUIT IF N .LE. 0 2280 L R11,0(R5) LOAD R11 WITH INCX 2290 C R11,0(R7) COMPARE INCX WITH INCY 2300 BNE INCNEN IF INCX .NE. INCY, GEN. LOOP. 2310 SLA R11,RSTAR4 MULT. INCX*4 2320 BM INCNEN IF BOTH INCX AND INCY NEG., 2330 * USE GEN. LOOP. 2340 LR R8,R11 SAVE INCX*4 AS INCREMENT. 2350 * THE CONTENTS OF REG R11 (CONTAINING INCX*4) ARE MOVED TO 2360 * R8 (UNOCCUPIED) BECAUSE THE 'MR' INSTRUCTION WHICH FOLLOWS 2370 * PLACES THE RESULT IN R11 AND ZEROES R10. 2380 MR R10,R9 COMPUTE INCX*4*(N-1) 2390 SR R7,R7 SET R7=0 2400 LR R10,R8 LOAD R10 WITH INCREMENT USED IN 2410 * LOOP. THE 'BXLE' INSTRUCTION (BELOW) ADDS THE CONTENTS OF REG 2420 * R10 TO REG. R7 AND COMPARES WITH THE CONTENTS OF REG R11. 2430 * THE BRANCH (TO LOOPE) IS TAKEN WHEN THE CONTENTS OF R7 2440 * DO NOT EXCEED THE CONTENTS OF REG R11. 2450 CNOP 0,8 ALIGN ON DOUBLE WORD. 2460 LOOPE LE F2,0(R7,R4) SET SX( ) 2470 ME F2,0(R7,R6) COMPUTE SX( )*SY( ) 2480 ADR F0,F2 ACCUMULATE INNER PRODUCT 2490 BXLE R7,R10,LOOPE 2500 B DONE 2510 INCNEN INCFX R4,R5,R9,R11,RSTAR4,ICY FIX SX( ) INCREMENT 2520 ICY INCFX R6,R7,R9,R11,RSTAR4,LOOP FIX SY( ) INCREMENT 2530 CNOP 0,8 ALIGN ON DOUBLE WORD. 2540 LOOP LE F2,0(R4) GET SX( ) AND 2550 ME F2,0(R6) MULTIPLY BY SY( ) AND 2560 ADR F0,F2 ACCUMULATE INNER PRODUCT 2570 INCBR R4,R5,R6,R7,R2,LOOP ADD INCREMENTS AND CONTINUE LOOP 2580 DONE EPILOG EXIT WITH SNGL(DBLE(SB)+DOT 2590 * PRODUCT) IN F0 NOW. 2600 END 2610 *********DOUBLE PRECISION INNER PRODUCT, DDOT, IBM/360 ASM.************ 2620 * USAGE STATEMENT 21 JULY 1975* 2630 * DW = DDOT (N,DX,INCX,DY,INCY) WASH. ST. U/ANL* 2640 * DW,DDOT,DX( ),DY( ),REAL*8 N,INCX,INCY,INTEGER*4 * 2650 *********************************************************************** 2660 DDOT PROLOG R11 2670 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 2680 SDR F0,F0 SET DDOT = 0.0D0 2690 NCHK R7,R2,DONE GET N AND EXIT IF N .LE. 0 2700 L R11,0(R4) GET INCX 2710 C R11,0(R6) COMPARE INCY WITH INCX 2720 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 2730 SLA R11,RSTAR8 MULTIPLY INCX * 8 2740 BM INCNE BRANCH TO GEN. LOOP IF NEG. 2750 LR R8,R11 STORE INCX*8 IN UNOCCUPIED R8 2760 MR R10,R7 COMPUTE INCX * 8 * (N-1) 2770 SR R6,R6 SET R6 = 0 2780 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 2790 CNOP 0,8 ALIGN ON DOUBLE WORD. 2800 LOOPEQ LD F2,0(R6,R3) GET DX( ) AND MULTIPLY 2810 MD F2,0(R6,R5) BY DY( ) AND ACCUMULATE 2820 ADR F0,F2 INNER PRODUCTS IN F0 2830 BXLE R6,R10,LOOPEQ 2840 B DONE 2850 INCNE INCFX R3,R4,R7,R9,RSTAR8,ICY FIX DX( ) INCREMENT 2860 ICY INCFX R5,R6,R7,R9,RSTAR8,LOOPNE FIX DY( ) INCREMENT 2870 CNOP 0,8 ALIGN ON DOUBLE WORD. 2880 LOOPNE LD F2,0(R3) GET DX( ) AND MULTIPLY 2890 MD F2,0(R5) BY DY( ) AND ACCUMULATE 2900 ADR F0,F2 INNER PRODUCTS IN F0 2910 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE 2920 DONE EPILOG 2930 END 2940 *********EXTENDED PREC. DOT PRODUCT, DQDOTA, IBM/360 ASM.********** 2950 * USAGE STATEMENT * 2960 * DW = DQDOTA (N,DB,QC,DX,INCX,DY,INCY) * 2970 * QC(5) REAL*4,DW,DQDOTA,DB,DX(),DY() REAL*8, * 2980 * N,INCX,INCY INTEGER*4 * 2990 ******************************************************************* 3000 DQDOTA PROLOG R11 3010 LM R2,R8,0(R1) 3020 SDR F2,F2 CLEAR REG. F2 3030 LD F0,0(R3) LOAD EXTENDED (DB) 3040 LE F4,0(R4) GET QC( ) 3050 STE F4,TEMP 3060 LE F4,4(R4) 3070 STE F4,TEMP+4 3080 LD F4,TEMP 3090 LE F6,8(R4) 3100 STE F6,TEMP 3110 LE F6,12(R4) 3120 STE F6,TEMP+4 3130 LD F6,TEMP END GET QC( ) 3140 * AXR F0,F4 COMPUTE DB + QC( ) 3150 * WARNING: THE ABOVE INSTRUCTION MAY NOT BE PRESENT ON YOUR 3160 * MACHINE. OPTIONS: REPLACE IT BY ADR F0,F4 OR USE A SOFTWARE 3170 * REPLACEMENT FOR THE OPERATION. 3180 ADR F0,F4 COMPUTE DB + QC( ) 3190 NCHK R9,R2,FIXQC 3200 INCFX R5,R6,R9,R11,RSTAR8,INCY 3210 INCY INCFX R7,R8,R9,R11,RSTAR8,LOOP 3220 CNOP 0,8 ALIGN ON DOUBLE WORD. 3230 LOOP LD F4,0(R5) GET DX( ) 3240 * MXD F4,0(R7) COMPUTE EXTEND. (DX()) * DY() 3250 * WARNING: THE ABOVE INSTRUCTION MAY NOT BE PRESENT ON YOUR 3260 * MACHINE. OPTIONS: REPLACE IT BY MD F4,0(R7) OR USE A SOFTWARE 3270 * REPLACEMENT FOR THE OPERATION. 3280 MD F4,0(R7) COMPUTE EXTEND. (DX()) * DY() 3290 * 3300 * AXR F0,F4 ACCUM. EXTEND. SUM 3310 * WARNING: THE ABOVE INSTRUCTION MAY NOT BE PRESENT ON YOUR 3320 * MACHINE. OPTIONS: REPLACE IT BY ADR F0,F4 OR USE A SOFTWARE 3330 * REPLACEMENT FOR THE OPERATION. 3340 ADR F0,F4 ACCUM. EXTEND. SUM 3350 INCBR R5,R6,R7,R8,R2,LOOP 3360 FIXQC STD F0,TEMP STORE RESULT IN 3370 LE F4,TEMP EXTEND. QC( ) 3380 STE F4,0(R4) THE REAL*4 OPS. ARE 3390 LE F4,TEMP+4 NEEDED BECAUSE 3400 STE F4,4(R4) QC( ) MAY NOT HAVE 3410 STD F2,TEMP REAL*8 ALIGNMENT. 3420 LE F4,TEMP NOTE THAT ONLY 3430 STE F4,8(R4) QC(I),I=1,4 ARE USED. 3440 LE F4,TEMP+4 3450 STE F4,12(R4) 3460 EPILOG 3470 DS 0D 3480 TEMP DS D 3490 END 3500 *********EXTENDED PREC. DOT PRODUCT, DQDOTI, IBM/360 ASM.********** 3510 * USAGE STATEMENT * 3520 * DW = DQDOTI (N,DB,QC,DX,INCX,DY,INCY) * 3530 * QC(5) REAL*4,DW,DQDOTI,DB,DX(),DY() REAL*8, * 3540 * N,INCX,INCY INTEGER*4 * 3550 ******************************************************************* 3560 DQDOTI PROLOG R11 3570 LM R2,R8,0(R1) 3580 SDR F2,F2 CLEAR REG. F2 3590 LD F0,0(R3) LOAD EXTENDED (DB) 3600 NCHK R9,R2,FIXQC 3610 INCFX R5,R6,R9,R11,RSTAR8,INCY 3620 INCY INCFX R7,R8,R9,R11,RSTAR8,LOOP 3630 CNOP 0,8 ALIGN ON DOUBLE WORD. 3640 LOOP LD F4,0(R5) GET DX( ) 3650 * MXD F4,0(R7) COMPUTE EXTEND. (DX()) * DY() 3660 * WARNING: THE ABOVE INSTRUCTION MAY NOT BE PRESENT ON YOUR 3670 * MACHINE. OPTIONS: REPLACE IT BY MD F4,0(R7) OR USE A SOFTWARE 3680 * REPLACEMENT FOR THE OPERATION. 3690 MD F4,0(R7) COMPUTE EXTEND. (DX()) * DY() 3700 * 3710 * AXR F0,F4 ACCUM. EXTEND. SUM 3720 * WARNING: THE ABOVE INSTRUCTION MAY NOT BE PRESENT ON YOUR 3730 * MACHINE. OPTIONS: REPLACE IT BY ADR F0,F4 OR USE A SOFTWARE 3740 * REPLACEMENT FOR THE OPERATION. 3750 ADR F0,F4 ACCUM. EXTEND. SUM 3760 INCBR R5,R6,R7,R8,R2,LOOP 3770 FIXQC STD F0,TEMP STORE RESULT IN 3780 LE F4,TEMP EXTEND. QC( ) 3790 STE F4,0(R4) THE REAL*4 OPS. ARE 3800 LE F4,TEMP+4 NEEDED BECAUSE 3810 STE F4,4(R4) QC( ) MAY NOT HAVE 3820 STD F2,TEMP REAL*8 ALIGNMENT. 3830 LE F4,TEMP NOTE THAT ONLY 3840 STE F4,8(R4) QC(I),I=1,4 ARE USED. 3850 LE F4,TEMP+4 3860 STE F4,12(R4) 3870 EPILOG 3880 DS 0D 3890 TEMP DS D 3900 END 3910 *********COMPLEX (CONJUGATED) INNER PRODUCT, CDOTC,IBM/360 ASM.******** 3920 * USAGE STATEMENT 3 SEPTEMBER 1975* 3930 * CW = CDOTC(N,CX,INCX,CY,INCY) WASH. ST. U./ANL* 3940 * CW,CDOTC,CX( ), CY( ) COMPLEX*8, N,INCX,INCY INTEGER*4 * 3950 * (THE ARRAY CX( ) HAS ITS ELEMENTS CONJUGATED). * 3960 *********************************************************************** 3970 CDOTC PROLOG R11 3980 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 3990 SER F0,F0 SET CDOT=(0.,0.). 4000 SER F2,F2 4010 NCHK R7,R2,DONE GET N AND QUIT IF N .LE. 0. 4020 L R11,0(R4) GET INCX 4030 C R11,0(R6) COMPARE INCY WITH INCX 4040 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 4050 SLA R11,CSTAR8 MULTIPLY INCX * 8 4060 BM INCNE GEN. LOOP IF INCX,INCY NEG. 4070 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 4080 MR R10,R7 MULTIPLY INCX * 8 * (N-1) 4090 SR R6,R6 SET R6 = 0 4100 LR R10,R8 LOAD LOOPEQ INCREMENT INTO R10 4110 CNOP 0,8 ALIGN ON DOUBLE WORD. 4120 LOOPEQ LE F4,0(R6,R3) GET CX( ) = (S,T) 4130 LE F6,4(R6,R3) 4140 ME F4,0(R6,R5) USE CY( ) = (U,V) TO FORM 4150 ME F6,4(R6,R5) S*U AND T*V 4160 AER F0,F4 ACCUMULATE REAL PART OF 4170 AER F0,F6 PRODUCT CONJG(CX( ))*CY( )=S*U+T*V 4180 LE F4,0(R6,R3) GET CX( ) = (S,T) 4190 LE F6,4(R6,R3) 4200 ME F4,4(R6,R5) USE CY( ) = (U,V) TO FORM 4210 ME F6,0(R6,R5) S*V AND T*U 4220 AER F2,F4 ACCUMULATE IMAG. PART OF 4230 SER F2,F6 PRODUCT CONJG(CX( ))*CY( )=S*V-T*U 4240 BXLE R6,R10,LOOPEQ 4250 B DONE 4260 INCNE INCFX R3,R4,R7,R9,CSTAR8,ICY FIX CX( ) INCREMENT 4270 ICY INCFX R5,R6,R7,R9,CSTAR8,LOOPNE FIX CY( ) INCREMENT 4280 CNOP 0,8 ALIGN ON DOUBLE WORD. 4290 LOOPNE LE F4,0(R3) GET CX( ) =(S,T) 4300 LE F6,4(R3) 4310 ME F4,0(R5) USE CY( ) = (U,V) TO FORM 4320 ME F6,4(R5) S*U AND T*V. 4330 AER F0,F4 ACCUMULATE REAL PART OF 4340 AER F0,F6 PRODUCT CONJG(CX( ))*CY( ) =S*U+T*V 4350 LE F4,0(R3) GET CX( ) = (S,T). 4360 LE F6,4(R3) 4370 ME F4,4(R5) USE CY( ) = (U,V) TO FORM 4380 ME F6,0(R5) S*V AND T*U 4390 AER F2,F4 ACCUMULATE IMAG. PART OF 4400 SER F2,F6 PRODUCT CONJG(CX( ))*CY( )=S*V-T*U 4410 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE LOOP 4420 DONE EPILOG 4430 END 4440 *********COMPLEX INNER PRODUCT, CDOTU, IBM/360 ASM.******************** 4450 * USAGE STATEMENT 3 SEPTEMBER 1975* 4460 * CW = CDOTU (N,CX,INCX,CY,INCY) WASH. ST. U./ANL* 4470 * CW,CDOTU,CX( ), CY( ) COMPLEX*8, N,INCX,INCY INTEGER*4 * 4480 *********************************************************************** 4490 CDOTU PROLOG R11 4500 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS. 4510 SER F0,F0 SET CDOTU = (0.,0.). 4520 SER F2,F2 4530 NCHK R7,R2,DONE GET N AND QUIT IF N .LE. 0 4540 L R11,0(R4) GET INCX 4550 C R11,0(R6) COMPARE INCY WITH INCX 4560 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 4570 SLA R11,CSTAR8 MULTIPLY INCX*8 4580 BM INCNE INCX,INCY NEG., GEN. LOOP 4590 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 4600 MR R10,R7 COMPUTE INCX * 8 * (N-1) 4610 SR R6,R6 SET R6 = 0 4620 LR R10,R8 LOAD LOOPEQ INCREMENT INTO R10 4630 CNOP 0,8 ALIGN ON DOUBLE WORD. 4640 LOOPEQ LE F4,0(R6,R3) GET CX( ) = (S,T) 4650 LE F6,4(R6,R3) 4660 ME F4,0(R6,R5) USE CY( ) = (U,V) TO FORM 4670 ME F6,4(R6,R5) S*U AND T*V 4680 AER F0,F4 ACCUMULATE REAL PART OF 4690 SER F0,F6 PRODUCT CX( )*CY( ) = S*U-T*V 4700 LE F4,0(R6,R3) GET CX( ) = (S,T) 4710 LE F6,4(R6,R3) 4720 ME F4,4(R6,R5) USE CY( ) = (U,V) TO FORM 4730 ME F6,0(R6,R5) S*V AND T*U 4740 AER F2,F4 ACCUMULATE IMAG. PART OF 4750 AER F2,F6 PRODUCT CX( )*CY( ) = S*V+T*U 4760 BXLE R6,R10,LOOPEQ 4770 B DONE 4780 INCNE INCFX R3,R4,R7,R9,CSTAR8,ICY FIX CX( ) INCREMENT 4790 ICY INCFX R5,R6,R7,R9,CSTAR8,LOOPNE FIX CY( ) INCREMENT 4800 CNOP 0,8 ALIGN ON DOUBLE WORD. 4810 LOOPNE LE F4,0(R3) GET CX( ) = (S,T) 4820 LE F6,4(R3) 4830 ME F4,0(R5) USE CY( ) = (U,V) TO FORM 4840 ME F6,4(R5) S*U AND T*V 4850 AER F0,F4 ACCUMULATE REAL PART OF 4860 SER F0,F6 PRODUCT CX( )*CY( ) = S*U-T*V 4870 LE F4,0(R3) GET CX( ) = (S,T) 4880 LE F6,4(R3) 4890 ME F4,4(R5) USE CY( ) = (U,V) TO FORM 4900 ME F6,0(R5) S*V AND T*U 4910 AER F2,F4 ACCUMULATE IMAG. PART OF 4920 AER F2,F6 PRODUCT CX( )*CY( ) = S*V+T*U 4930 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE LOOP 4940 DONE EPILOG 4950 END 4960 ********SINGLE PREC. AFFINE TRANSFORMATION, SAXPY, IBM/360 ASM.******** 4970 * USAGE STATEMENT 14 AUGUST 1975* 4980 * CALL SAXPY (N,SA,SX,INCX,SY,INCY) WASH. ST. U/ANL* 4990 * SA,SX( ),SY( ),REAL*4 N,INCX,INCY,INTEGER*4 * 5000 *********************************************************************** 5010 SAXPY PROLOG R11 5020 LM R2,R7,0(R1) GET POINTERS TO ARGUMENTS 5030 NCHK R9,R2,DONE GET N AND EXIT IF N .LE. 0 5040 LE F2,0(R3) GET SCALAR SA FOR MULTIPLYING 5050 L R11,0(R5) GET INCX 5060 C R11,0(R7) COMPARE INCY WITH INCX 5070 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 5080 SLA R11,RSTAR4 MULTIPLY INCX * 4 5090 BM INCNE IF INCX, INCY NEG., GEN. LOOP 5100 LR R8,R11 SAVE INCX * 4 IN UNOCCUPIED R8 5110 MR R10,R9 COMPUTE INCX * 4 * (N-1) 5120 SR R7,R7 SET R7 = 0 5130 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 5140 CNOP 0,8 ALIGN ON DOUBLE WORD. 5150 LOOPEQ LE F0,0(R7,R4) GET SX( ) 5160 MER F0,F2 COMPUTE SA * SX( ) 5170 AE F0,0(R7,R6) COMPUTE SA * SX( ) + SY( ) 5180 STE F0,0(R7,R6) AND STORE AT SY( ) 5190 BXLE R7,R10,LOOPEQ 5200 B DONE 5210 INCNE INCFX R4,R5,R9,R11,RSTAR4,ICY FIX SX( ) INCREMENT 5220 ICY INCFX R6,R7,R9,R11,RSTAR4,LOOPNE FIX SY( ) INCREMENT 5230 CNOP 0,8 ALIGN ON DOUBLE WORD. 5240 LOOPNE LE F0,0(R4) GET SX( ) 5250 MER F0,F2 COMPUTE SA * SX( ) 5260 AE F0,0(R6) COMPUTE SA * SX( ) + SY( ) 5270 STE F0,0(R6) AND STORE AT SY( ) 5280 INCBR R4,R5,R6,R7,R2,LOOPNE ADD INCREMENTS AND CONTINUE 5290 DONE EPILOG 5300 END 5310 *********DBL. PREC. AFFINE TRANSFORMATION, DAXPY, IBM/360 ASM.********* 5320 * USAGE STATEMENT 14 AUGUST 1975* 5330 * CALL DAXPY (N,DA,DX,INCX,DY,INCY) WASH. ST. U/ANL* 5340 * DA,DX( ),DY( ) REAL*8, N,INCX,INCY INTEGER*4 * 5350 *********************************************************************** 5360 DAXPY PROLOG R11 5370 LM R2,R7,0(R1) GET POINTERS TO ARGUMENTS 5380 NCHK R9,R2,DONE GET N AND QUIT IF N .LE. 0 5390 LD F2,0(R3) GET SCALAR DA FOR MULTIPLYING 5400 L R11,0(R5) GET INCX 5410 C R11,0(R7) COMPARE INCY WITH INCX 5420 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 5430 SLA R11,RSTAR8 MULTIPLY INCX * 8 5440 BM INCNE IF INCX,INCY NEG., GEN. LOOP 5450 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 5460 MR R10,R9 COMPUTE INCX * 8 * (N-1) 5470 SR R7,R7 SET R7 = 0 5480 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 5490 CNOP 0,8 ALIGN ON DOUBLE WORD. 5500 LOOPEQ LD F0,0(R7,R4) GET DX( ) 5510 MDR F0,F2 COMPUTE DA * DX( ) 5520 AD F0,0(R7,R6) COMPUTE DA * DX( ) + DY( ) 5530 STD F0,0(R7,R6) AND STORE AT DY( ) 5540 BXLE R7,R10,LOOPEQ 5550 B DONE 5560 INCNE INCFX R4,R5,R9,R11,RSTAR8,ICY FIX DX( ) INCREMENT 5570 ICY INCFX R6,R7,R9,R11,RSTAR8,LOOPNE FIX DY( ) INCREMENT 5580 CNOP 0,8 ALIGN ON DOUBLE WORD. 5590 LOOPNE LD F0,0(R4) GET DX( ) 5600 MDR F0,F2 COMPUTE DA * DX( ) 5610 AD F0,0(R6) COMPUTE DA * DX( ) + DY( ) 5620 STD F0,0(R6) AND STORE AT DY( ) 5630 INCBR R4,R5,R6,R7,R2,LOOPNE ADD INCREMENTS AND CONTINUE 5640 DONE EPILOG 5650 END 5660 *********COMPLEX AFFINE TRANSFORMATION, CAXPY, IBM/360 ASM.************ 5670 * USAGE STATEMENT 3 SEPTEMBER 1975* 5680 * CALL CAXPY (N,CA,CX,INCX,CY,INCY) WASH. ST. U/ANL* 5690 * CA,CX( ),CY( ) COMPLEX*8, N,INCX,INCY INTEGER*4 * 5700 *********************************************************************** 5710 CAXPY PROLOG R11 5720 LM R2,R7,0(R1) GET POINTERS TO ARGUMENTS 5730 NCHK R9,R2,DONE GET N AND QUIT IF N .LE. 0 5740 LE F4,0(R3) GET REAL PART OF CA 5750 STE F4,AR STORE IT LOCALLY 5760 LE F6,4(R3) GET IMAG. PART OF CA 5770 L R11,0(R5) GET INCX 5780 C R11,0(R7) COMPARE INCY WITH INCX 5790 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 5800 SLA R11,CSTAR8 MULTIPLY INCX * 8 5810 BM INCNE GEN. LOOP IF INCX,INCY NEG. 5820 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 5830 MR R10,R9 MULTIPLY INCX * 8 * (N-1) 5840 SR R7,R7 SET R7 = 0 5850 LR R10,R8 LOAD LOOPEQ INCREMENT INTO R10 5860 CNOP 0,8 ALIGN ON DOUBLE WORD. 5870 LOOPEQ LE F0,AR GET REAL PART OF CA 5880 LER F2,F6 TRANSFER IMAG. PART OF CA TO F2 5890 ME F0,0(R7,R4) 5900 ME F2,4(R7,R4) 5910 SER F0,F2 REAL PART OF CA * CX( ) 5920 AE F0,0(R7,R6) PLUS REAL PART OF CY( ) 5930 LE F2,AR 5940 ME F2,4(R7,R4) 5950 LER F4,F6 5960 ME F4,0(R7,R4) 5970 AER F2,F4 IMAG. PART OF CA * CX( ) 5980 AE F2,4(R7,R6) PLUS IMAG. PART OF CY( ) 5990 STE F0,0(R7,R6) STORE CY( ) + CA * CX( ) 6000 STE F2,4(R7,R6) AT CY( ) 6010 BXLE R7,R10,LOOPEQ 6020 B DONE 6030 INCNE INCFX R4,R5,R9,R11,CSTAR8,ICY FIX CX( ) INCREMENT 6040 ICY INCFX R6,R7,R9,R11,CSTAR8,LOOPNE FIX CY( ) INCREMENT 6050 CNOP 0,8 ALIGN ON DOUBLE WORD. 6060 LOOPNE LE F0,AR GET REAL PART OF CA 6070 LER F2,F6 TRANSFER IMAG. PART OF CA TO F2 6080 ME F0,0(R4) 6090 ME F2,4(R4) 6100 SER F0,F2 REAL PART OF CA*CX( ) 6110 AE F0,0(R6) PLUS REAL PART OF CY( ) 6120 LE F2,AR 6130 ME F2,4(R4) 6140 LER F4,F6 6150 ME F4,0(R4) 6160 AER F2,F4 IMAG. PART OF CA*CX( ) 6170 AE F2,4(R6) PLUS IMAG. PART OF CY( ) 6180 STE F0,0(R6) 6190 STE F2,4(R6) STORE CY( )+CA*CX( ) AT CY( ) 6200 INCBR R4,R5,R6,R7,R2,LOOPNE 6210 DONE EPILOG 6220 AR DS F 6230 END 6240 *********CONSTRUCT GIVENS TRANS., SNGL PREC., SROTG, IBM/360 ASM.****** 6250 * USAGE STATEMENT 10 JUNE 1977* 6260 * CALL SROTG (SA,SB,SC,SS) WASH. ST. U* 6270 * SA,SB,SC,SS REAL*4 * 6280 *********************************************************************** 6290 SROTG PROLOG R5 6300 LM R2,R5,0(R1) GET POINTERS TO ARGUMENTS 6310 LE F2,0(R2) GET SA IN F2 6320 LE F0,0(R3) GET SB IN F0 6330 LPER F4,F0 NOW ABS(SB) IN F4 6340 LPER F6,F2 AND ABS(SA) IN F6 6350 CER F6,F4 TEST FOR 6360 BNH CASE2 ABS(SA) .LE. ABS(SB) 6370 AER F2,F2 COMPUTE 2*SA 6380 DER F0,F2 COMPUTE W = SB/(2*SA) 6390 STE F0,W SAVE W 6400 MER F0,F0 COMPUTE W**2 6410 AE F0,=E'0.25' COMPUTE 0.25E0+W**2 6420 STE F0,VALUE PUT AWAY FOR SQRT( ) CALL 6430 L R15,=V(SQRT) GET LOC. OF SQRT( ) 6440 CNOP 0,4 ALIGN PROPERLY 6450 BAL R1,SQRT1 6460 DC X'80',AL3(VALUE) 6470 SQRT1 BALR R14,R15 GO TO SQRT( ) SUBPROGRAM 6480 LE F2,=E'1.0' NOW Q=SQRT(0.25E0+W**2) IN F0 6490 AER F0,F0 COMPUTE 2*Q 6500 DER F2,F0 COMPUTE 1.E0/(2*Q) = SC 6510 ME F0,0(R2) COMPUTE R = SA*Q*2 6520 STE F0,0(R2) STORE R ON SA 6530 STE F2,0(R4) STORE SC 6540 ME F2,W COMPUTE SS = W*SC*2 6550 AER F2,F2 6560 STE F2,0(R5) STORE SS 6570 B DONE 6580 CASE2 LTER F0,F0 SET COND. FOR SB 6590 BNZ CASE3 6600 LE F2,=E'1.0' GET 1.0 AND 6610 STE F2,0(R4) STORE SC 6620 STE F0,0(R5) STORE 0. IN SS 6630 B DONE 6640 CASE3 AER F0,F0 COMPUTE 2*SB 6650 DER F2,F0 COMPUTE W = SA/(2*SB) 6660 STE F2,W SAVE W 6670 MER F2,F2 COMPUTE W**2 6680 AE F2,=E'0.25' COMPUTE 0.25E0+W**2 6690 STE F2,VALUE PUT AWAY FOR SQRT( ) 6700 L R15,=V(SQRT) GET LOC. OF SQRT( ) 6710 CNOP 0,4 ALIGN PROPERLY 6720 BAL R1,SQRT2 6730 DC X'80',AL3(VALUE) 6740 SQRT2 BALR R14,R15 GO TO SQRT( ) SUBPROGRAM 6750 LE F2,=E'1.0' NOW Q=SQRT(0.25E0+W**2) IN F0 6760 AER F0,F0 COMPUTE 2*Q 6770 DER F2,F0 COMPUTE 1.E0/(2*Q) = SS 6780 ME F0,0(R3) COMPUTE R = SB*Q*2 6790 STE F0,0(R2) STORE R ON SA 6800 STE F2,0(R5) STORE SS 6810 ME F2,W COMPUTE SC = W*SS*2 6820 AER F2,F2 6830 STE F2,0(R4) STORE SC 6840 DONE LE F0,0(R4) GET SC IN F0. 6850 LE F2,0(R5) GET SS IN F2. 6860 LPER F4,F0 SAVE ABS(SC) IN F4. 6870 LPER F6,F2 SAVE ABS(SS) IN F6. 6880 CER F6,F4 TEST FOR 6890 BNL TESTSC ABS(SS).LT.ABS(SC) 6900 STE F2,0(R3) STORE SS IN SB. 6910 B OUT 6920 TESTSC LTER F4,F4 SET INDICATOR FOR SC.EQ.0. 6930 BNZ SAVERC 6940 LE F0,=E'1.0' 6950 STE F0,0(R3) STORE 1.0 IN SB IF SC.EQ.0. 6960 B OUT 6970 SAVERC LE F2,=E'1.0' COMPUTE 1./SC AND 6980 DER F2,F0 STORE IN SB FOR LAST CASE. 6990 STE F2,0(R3) 7000 OUT EPILOG 7010 W DS F 7020 VALUE DS F'0' 7030 END 7040 *********CONSTRUCT GIVENS TRANS., DOUB. PREC., DROTG, IBM/360 ASM.***** 7050 * USAGE STATEMENT 10 JUNE 1977 * 7060 * CALL DROTG (DA,DB,DC,DS) WASH. ST. U* 7070 * DA,DB,DC,DS REAL*8 * 7080 *********************************************************************** 7090 DROTG PROLOG R5 7100 LM R2,R5,0(R1) GET POINTERS TO ARGUMENTS 7110 LD F2,0(R2) GET DA IN F2 7120 LD F0,0(R3) GET DB IN F0 7130 LPDR F4,F0 NOW DABS(DB) IN F4 7140 LPDR F6,F2 AND DABS(DA) IN F6 7150 CDR F6,F4 TEST FOR 7160 BNH CASE2 DABS(DA) .LE. DABS(DB) 7170 ADR F2,F2 COMPUTE 2*DA 7180 DDR F0,F2 COMPUTE W= DB/(2*DA) 7190 STD F0,W SAVE W 7200 MDR F0,F0 COMPUTE W**2 7210 AD F0,=D'0.25' COMPUTE 0.25D0+W**2 7220 STD F0,VALUE PUT AWAY FOR DSQRT( ) CALL 7230 L R15,=V(DSQRT) GET LOC OF DSQRT( ) 7240 CNOP 0,4 ALIGN PROPERLY 7250 BAL R1,SQRT1 7260 DC X'80',AL3(VALUE) 7270 SQRT1 BALR R14,R15 GO TO DSQRT( ) SUBPROGRAM 7280 LD F2,=D'1.0' NOW Q=DSQRT(0.25D0+W**2) IN F0 7290 ADR F0,F0 COMPUTE 2*Q 7300 DDR F2,F0 COMPUTE 1.D0/(2*Q) = DC 7310 MD F0,0(R2) COMPUTE R = DA*Q*2 7320 STORE1 STD F0,0(R2) STORE R ON DA 7330 STD F2,0(R4) STORE DC 7340 MD F2,W COMPUTE DS=W*DC*2 7350 ADR F2,F2 7360 STD F2,0(R5) STORE DS 7370 B DONE 7380 CASE2 LTDR F0,F0 SET COND. FOR DB 7390 BNZ CASE3 7400 LD F2,=D'1.0' GET 1.0 AND 7410 STD F2,0(R4) STORE DC 7420 STD F0,0(R5) STORE 0.0 IN DS 7430 B DONE 7440 CASE3 ADR F0,F0 COMPUTE 2*DB 7450 DDR F2,F0 COMPUTE W=DA/(2*DB) 7460 STD F2,W SAVE W 7470 MDR F2,F2 COMPUTE W**2 7480 AD F2,=D'0.25' COMPUTE 0.25D0+W**2 7490 STD F2,VALUE PUT AWAY FOR DSQRT( ) 7500 L R15,=V(DSQRT) GET LOC OF DSQRT( ) 7510 CNOP 0,4 ALIGN PROPERLY 7520 BAL 1,SQRT2 7530 DC X'80',AL3(VALUE) 7540 SQRT2 BALR R14,R15 GO TO DSQRT( ) SUBROUTINE 7550 LD F2,=D'1.0' NOW Q=DSQRT(0.25D0+W**2) IN F0 7560 ADR F0,F0 COMPUTE 2*Q 7570 DDR F2,F0 COMPUTE 1.D0/(2*Q) =DS 7580 MD F0,0(R3) COMPUTE R=DB*Q*2 7590 STD F0,0(R2) STORE R ON DA 7600 STD F2,0(R5) STORE DS 7610 MD F2,W COMPUTE DC=W*DS*2 7620 ADR F2,F2 7630 STD F2,0(R4) STORE DC 7640 DONE LD F0,0(R4) GET DC IN F0. 7650 LD F2,0(R5) GET DS IN F2. 7660 LPDR F4,F0 SAVE ABS(DC) IN F4. 7670 LPDR F6,F2 SAVE ABS(DS) IN F6. 7680 CDR F6,F4 TEST FOR 7690 BNL TESTSC ABS(DS).LT.ABS(DC) 7700 STD F2,0(R3) STORE DS IN DB. 7710 B OUT 7720 TESTSC LTDR F4,F4 SET INDICATOR FOR DC.EQ.0. 7730 BNZ SAVERC 7740 LD F0,=D'1.0' 7750 STD F0,0(R3) STORE 1.0 IN DB IF DC.EQ.0. 7760 B OUT 7770 SAVERC LD F2,=D'1.0' COMPUTE 1./DC AND 7780 DDR F2,F0 STORE IN DB FOR LAST CASE. 7790 STD F2,0(R3) 7800 OUT EPILOG 7810 VALUE DS D'0' 7820 W DS D 7830 END 7840 *********APPLY SINGLE PREC. PLANE ROTATION, SROT, IBM/360 ASM.********* 7850 * USAGE STATEMENT 3 SEPTEMBER 1975* 7860 * CALL SROT (N,SX,INCX,SY,INCY,SC,SS) WASH. ST. U./ANL* 7870 * SX( ),SY( ), SC,SS REAL*4, N,INCX,INCY INTEGER *4 * 7880 *********************************************************************** 7890 SROT PROLOG R11 7900 LM R2,R8,0(R1) GET POINTERS TO ARGUMENTS 7910 NCHK R9,R2,DONE GET N AND QUIT IF N .LE. 0 7920 LE F4,0(R7) GET SC AND 7930 LE F6,0(R8) SS FOR MULTIPLYING 7940 LER F0,F4 IF SC .EQ. 1.0 7950 SE F0,=E'1.0' AND SS .EQ. 0. 7960 BNZ UCASE NO TRANS. 7970 LTER F6,F6 IS 7980 BZ DONE NECESSARY. 7990 UCASE L R11,0(R4) GET INCX 8000 C R11,0(R6) COMPARE INCY WITH INCX 8010 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 8020 SLA R11,RSTAR4 MULTIPLY INCX * 4 8030 BM INCNE GEN. LOOP IF INCX,INCY NEG. 8040 LR R8,R11 SAVE INCX*4 IN UNOCCUPIED R8 8050 MR R10,R9 MULTIPLY INCX * 4 * (N-1) 8060 SR R6,R6 SET R6 = 0 8070 LR R10,R8 LOAD LOOPEQ INCREMENT INTO R10 8080 CNOP 0,8 ALIGN ON DOUBLE WORD. 8090 LOOPEQ LE F0,0(R6,R3) GET SX( ) 8100 LE F2,0(R6,R5) GET SY( ) 8110 MER F0,F4 COMPUTE SC * SX( ) 8120 MER F2,F6 COMPUTE SS * SY( ) 8130 AER F0,F2 COMPUTE SC*SX( ) + SS*SY( ) 8140 LE F2,0(R6,R3) GET SX( ) 8150 STE F0,0(R6,R3) OVERWRITE SX( ) WITH PRODUCT 8160 LE F0,0(R6,R5) GET SY( ) 8170 MER F0,F4 COMPUTE SC * SY( ) 8180 MER F2,F6 COMPUTE SS * SX( ) 8190 SER F0,F2 COMPUTE -SS*SX( ) + SC*SY( ) 8200 STE F0,0(R6,R5) OVERWRITE SY( ) WITH PRODUCT 8210 BXLE R6,R10,LOOPEQ 8220 B DONE 8230 INCNE INCFX R3,R4,R9,R11,RSTAR4,ICY FIX SX( ) INCREMENT 8240 ICY INCFX R5,R6,R9,R11,RSTAR4,LOOPNE FIX SY( ) INCREMENT 8250 CNOP 0,8 ALIGN ON DOUBLE WORD. 8260 LOOPNE LE F0,0(R3) GET SX( ) 8270 LE F2,0(R5) GET SY( ) 8280 MER F0,F4 COMPUTE SC*SX( ) 8290 MER F2,F6 COMPUTE SS*SY( ) 8300 AER F0,F2 COMPUTE SC*SX( )+SS*SY( ) 8310 LE F2,0(R3) GET SX( ) 8320 STE F0,0(R3) OVERWRITE SX( ) WITH PRODUCT 8330 LE F0,0(R5) GET SY( ) 8340 MER F0,F4 COMPUTE SC*SY( ) 8350 MER F2,F6 COMPUTE SS*SX( ) 8360 SER F0,F2 COMPUTE -SS*SX( )+SC*SY( ) 8370 STE F0,0(R5) OVERWRITE SY( ) WITH PRODUCT 8380 INCBR R3,R4,R5,R6,R2,LOOPNE 8390 DONE EPILOG 8400 END 8410 *********APPLY DBLE PREC. PLANE ROTATION, DROT, IBM/360 ASM.*********** 8420 * USAGE STATEMENT 3 SEPTEMBER 1975* 8430 * CALL DROT (N,DX,INCX,DY,INCY,DC,DS) WASH. ST. U./ANL* 8440 * DX( ),DY( ),DC,DS, REAL *8, N,INCX,INCY INTEGER *4 * 8450 *********************************************************************** 8460 DROT PROLOG R11 8470 LM R2,R8,0(R1) GET POINTER TO ARGUMENTS. 8480 NCHK R9,R2,DONE GET N AND QUIT IF N .LE. 0 8490 LD F4,0(R7) GET DC AND 8500 LD F6,0(R8) DS FOR MULTIPLYING 8510 LDR F0,F4 IF DC .EQ. 1.0 8520 SD F0,=D'1.0' AND DS .EQ. 0. 8530 BNZ UCASE NO TRANS. 8540 LTDR F6,F6 8550 BZ DONE NECESSARY. 8560 UCASE L R11,0(R4) GET INCX 8570 C R11,0(R6) COMPARE INCY WITH INCX 8580 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 8590 SLA R11,RSTAR8 MULTIPLY INCX * 8 8600 BM INCNE GEN. LOOP IF INCX, INCY NEG. 8610 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 8620 MR R10,R9 COMPUTE INCX * 8 * (N-1) 8630 SR R6,R6 SET R6 = 0 8640 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 8650 CNOP 0,8 ALIGN ON DOUBLE WORD. 8660 LOOPEQ LD F0,0(R6,R3) GET DX( ) 8670 LD F2,0(R6,R5) GET DY( ) 8680 MDR F0,F4 COMPUTE DC * DX( ) 8690 MDR F2,F6 COMPUTE DS * DY( ) 8700 ADR F0,F2 COMPUTE DC*DX( ) + DS*DY( ) 8710 LD F2,0(R6,R3) GET DX( ) 8720 STD F0,0(R6,R3) OVERWRITE DX( ) WITH PRODUCT 8730 LD F0,0(R6,R5) GET DY( ) 8740 MDR F0,F4 COMPUTE DC * DY( ) 8750 MDR F2,F6 COMPUTE DS * DX( ) 8760 SDR F0,F2 COMPUTE -DS*DX( ) + DC*DY( ) 8770 STD F0,0(R6,R5) OVERWRITE DY( ) WITH PRODUCT 8780 BXLE R6,R10,LOOPEQ 8790 B DONE 8800 INCNE INCFX R3,R4,R9,R11,RSTAR8,ICY FIX DX( ) INCREMENT 8810 ICY INCFX R5,R6,R9,R11,RSTAR8,LOOPNE FIX DY( ) INCREMENT 8820 CNOP 0,8 ALIGN ON DOUBLE WORD. 8830 LOOPNE LD F0,0(R3) GET DX( ) 8840 LD F2,0(R5) GET DY( ) 8850 MDR F0,F4 COMPUTE DC*DX( ) 8860 MDR F2,F6 COMPUTE DS*DY( ) 8870 ADR F0,F2 COMPUTE DC*DX( )+DS*DY( ) 8880 LD F2,0(R3) GET DX( ) 8890 STD F0,0(R3) OVERWRITE DX( ) WITH PRODUCT 8900 LD F0,0(R5) GET DY( ) 8910 MDR F0,F4 COMPUTE DC*DY( ) 8920 MDR F2,F6 COMPUTE DS*DX( ) 8930 SDR F0,F2 COMPUTE -DS*DX( )+DC*DY( ) 8940 STD F0,0(R5) OVERWRITE DY( ) WITH PRODUCT 8950 INCBR R3,R4,R5,R6,R2,LOOPNE 8960 DONE EPILOG 8970 END 8980 *********CONSTRUCT MOD. GIVENS TRANS., SNGL PREC., SROTMG, IBM/360 ASM. 8990 * USAGE STATEMENT 2 JUN 1975* 9000 * CALL SROTMG (D1,D2,B1,B2,SPARAM) WASH. ST. U* 9010 * REAL * 4 D1,D2,B1,B2,SPARAM(5) * 9020 *********************************************************************** 9030 SROTMG PROLOG R6 9040 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 9050 USING SPARAM,R6 USE ADDRESS OF SPARAM(1) AS BASE 9060 LE F4,0(R4) GET B1 9070 LE F6,0(R5) GET B2 9080 LER F0,F4 SAVE B1 IN F0 9090 LER F2,F6 SAVE B2 IN F2 9100 ME F4,0(R2) COMPUTE P1=D1*B1 9110 ME F6,0(R3) COMPUTE P2=D2*B2 9120 MER F0,F4 COMPUTE P1*B1 9130 MER F2,F6 COMPUTE P2*B2 9140 STE F2,P2B2 SAVE P2*B2 9150 LPER F0,F0 COMPUTE ABS(P1*B1) 9160 LPER F2,F2 COMPUTE ABS(P2*B2) 9170 CER F0,F2 SEE IF ABS(P1*B1) .GE. 9180 BH BR1 ABS(P2*B2) 9190 LE F2,P2B2 SEE IF P2*B2 .GE. 0 9200 LTER F2,F2 9210 BZ NOTRANS P2*B2=0 CASE, NO TRANSFORMATION 9220 BM BR2 P2*B2<0, BRANCH TO BR2 9230 LE F0,=E'1.0' P2*B2>0 CASE 9240 STE F0,SFLAG SET SFLAG=1.0 9250 DER F4,F6 COMPUTE P1/P2 9260 STE F4,H11 STORE H11=P1/P2 9270 LE F0,0(R4) GET B1 9280 LE F2,0(R5) GET B2 9290 DER F0,F2 COMPUTE B1/B2 9300 STE F0,H22 STORE H22=B1/B2 9310 MER F0,F4 COMPUTE H11*H22 9320 AE F0,=E'1.0' COMPUTE U=1.0+H11*H22 9330 MER F2,F0 COMPUTE B2*U 9340 STE F2,0(R4) STORE B1=B2*U 9350 LE F4,0(R3) GET D2 9360 DER F4,F0 COMPUTE D2/U 9370 LE F2,0(R2) GET D1 9380 DER F2,F0 COMPUTE D1/U 9390 STE F4,0(R2) STORE D1=D2/U 9400 STE F2,0(R3) STORE D2=D1/U 9410 B DWLP1 9420 NOTRANS LE F0,=E'-2.0' NO TRANSFORMATION CASE; 9430 STE F0,SFLAG SET SFLAG=-2.0 9440 B DONE RETURN 9450 BR2 LE F0,=E'-1.0' P2*B2<0 CASE 9460 STE F0,SFLAG SET SFLAG=-1.0 9470 SER F0,F0 9480 STE F0,H11 SET H11=0. 9490 STE F0,H12 SET H12=0. 9500 STE F0,H21 SET H21=0. 9510 STE F0,H22 SET H22=0. 9520 STE F0,0(R2) SET D1=0. 9530 STE F0,0(R3) SET D2=0. 9540 STE F0,0(R4) SET B1=0. 9550 B DONE RETURN 9560 BR1 DER F6,F4 COMPUTE P2/P1 9570 STE F6,H12 STORE H12=P2/P1 9580 LE F2,0(R5) GET B2 9590 LE F0,0(R4) GET B1 9600 DER F2,F0 COMPUTE B2/B1 9610 MER F6,F2 COMPUTE H12*B2/B1 9620 AE F6,=E'1.0' COMPUTE U=1.0+H12*B2/B1 9630 LCER F2,F2 COMPUTE H21=-B2/B1 9640 STE F2,H21 STORE H21 9650 CE F6,TOL SEE IF U .LE. TOL 9660 BNH BR2 9670 SER F2,F2 9680 STE F2,SFLAG SET SFLAG=0. 9690 LE F4,0(R2) GET D1 9700 LE F2,0(R3) GET D2 9710 DER F4,F6 COMPUTE D1/U 9720 DER F2,F6 COMPUTE D2/U 9730 MER F0,F6 COMPUTE B1*U 9740 STE F4,0(R2) STORE D1=D1/U 9750 STE F2,0(R3) STORE D2=D2/U 9760 STE F0,0(R4) STORE B1=B1*U 9770 DWLP1 LPER F0,F4 PUT ABS(D1) INTO F0 9780 CE F0,TWOM24 SEE IF ABS(D1) .GT. TWOM24 9790 BH DWLP2 9800 LTER F4,F4 SEE IF D1=0. 9810 BZ DWLP3 IF D1=0. BRANCH TO DWLP3 9820 FIXH 9830 ME F4,TWO12 MULTIPLY TWICE TO COMPUTE 9840 ME F4,TWO12 D1*(C**2) 9850 STE F4,0(R2) STORE D1=D1*(C**2) 9860 LE F6,0(R4) GET B1 9870 DE F6,TWO12 COMPUTE B1 C 9880 STE F6,0(R4) STORE B1=B1/C 9890 LE F6,H11 GET H11 9900 DE F6,TWO12 COMPUTE H11/C 9910 STE F6,H11 STORE H11=H11/C 9920 LE F6,H12 GET H12 9930 DE F6,TWO12 COMPUTE H12/C 9940 STE F6,H12 STORE H12=H12/C 9950 B DWLP1 9960 DWLP2 LPER F0,F4 PUT ABS(D1) INTO F0 9970 CE F0,TWO24 SEE IF ABS(D1) .LT. TWO24 9980 BL DWLP3 9990 FIXH 10000 DE F4,TWO12 DIVIDE TWICE TO COMPUTE 10010 DE F4,TWO12 D1/C**2 10020 STE F4,0(R2) STORE D1=D1/C**2 10030 LE F6,0(R4) GET B1 10040 ME F6,TWO12 COMPUTE B1*C 10050 STE F6,0(R4) STORE B1=B1*C 10060 LE F6,H11 GET H11 10070 ME F6,TWO12 COMPUTE H11*C 10080 STE F6,H11 STORE H11=H11*C 10090 LE F6,H12 GET H12 10100 ME F6,TWO12 COMPUTE H12*C 10110 STE F6,H12 STORE H12=H12*C 10120 B DWLP2 10130 DWLP3 LPER F0,F2 PUT ABS(D2) INTO F0 10140 CE F0,TWOM24 SEE IF ABS(D2) .GT. TWOM24 10150 BH DWLP4 10160 LTER F2,F2 SEE IF D2=0. 10170 BZ DONE IF D2=0. RETURN 10180 FIXH 10190 ME F2,TWO12 MULTIPLY TWICE TO COMPUTE 10200 ME F2,TWO12 D2*(C**2) 10210 STE F2,0(R3) STORE D2=D2*(C**2) 10220 LE F6,H21 GET H21 10230 DE F6,TWO12 COMPUTE H21/C 10240 STE F6,H21 STORE H21=H21/C 10250 LE F6,H22 GET H22 10260 DE F6,TWO12 COMPUTE H22/C 10270 STE F6,H22 STORE H22=H22/C 10280 B DWLP3 10290 DWLP4 LPER F0,F2 PUT ABS(D2) INTO F0 10300 CE F0,TWO24 SEE IF ABS(D2) .LT. TWO24 10310 BL DONE 10320 FIXH 10330 DE F2,TWO12 DIVIDE TWICE TO COMPUTE 10340 DE F2,TWO12 D2/C**2 10350 STE F2,0(R3) STORE D2=D2/C**2 10360 LE F6,H21 GET H21 10370 ME F6,TWO12 COMPUTE H21*C 10380 STE F6,H21 STORE H21=H21*C 10390 LE F6,H22 GET H22 10400 ME F6,TWO12 COMPUTE H22*C 10410 STE F6,H22 STORE H22=H22*C 10420 B DWLP4 10430 DONE EPILOG 10440 LTORG 10450 DS 0F 10460 P2B2 DS F 10470 TWO12 DC E'4096.' 10480 TWO24 DC E'16777216.' 10490 TWOM24 DC E'5.960E-08' 10500 TOL DC E'0.0' 10510 SPARAM DSECT 10520 SFLAG DS F 10530 H11 DS F 10540 H21 DS F 10550 H12 DS F 10560 H22 DS F 10570 END 10580 *********CONSTRUCT MOD. GIVENS TRANS., DBLE PREC., DROTMG, IBM/360 ASM. 10590 * USAGE STATEMENT 2 JUN 1975* 10600 * CALL DROTMG (D1,D2,B1,B2,DPARAM) WASH. ST. U* 10610 * REAL * 8 D1,D2,B1,B2,DPARAM(5) * 10620 *********************************************************************** 10630 DROTMG PROLOG R6 10640 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 10650 USING DPARAM,R6 LOAD ADDRESS OF DPARAM 10660 LD F4,0(R4) GET B1 10670 LD F6,0(R5) GET B2 10680 LDR F0,F4 SAVE B1 IN F0 10690 LDR F2,F6 SAVE B2 IN F2 10700 MD F4,0(R2) COMPUTE P1=D1*B1 10710 MD F6,0(R3) COMPUTE P2=D2*B2 10720 MDR F0,F4 COMPUTE P1*B1 10730 MDR F2,F6 COMPUTE P2*B2 10740 STD F2,P2B2 SAVE P2*B2 10750 LPDR F0,F0 COMPUTE DABS(P1*B1) 10760 LPDR F2,F2 COMPUTE DABS(P2*B2) 10770 CDR F0,F2 SEE IF DABS(P1*B1) .GT. 10780 BH BR1 DABS(P2*B2) 10790 LD F2,P2B2 SEE IF P2*B2 .GE. 0 10800 LTDR F2,F2 10810 BZ NOTRANS P2*B2=0 CASE, NO TRANSFORMATION 10820 BM BR2 P2*B2<0, BRANCH TO BR2 10830 LD F0,=D'1.0' P2*B2>0 CASE 10840 STD F0,DFLAG SET DFLAG=1.0 10850 DDR F4,F6 COMPUTE P1/P2 10860 STD F4,H11 STORE H11=P1/P2 10870 LD F0,0(R4) GET B1 10880 LD F2,0(R5) GET B2 10890 DDR F0,F2 COMPUTE B1/B2 10900 STD F0,H22 STORE H22=B1/B2 10910 MDR F0,F4 COMPUTE H11*H22 10920 AD F0,=D'1.0' COMPUTE U=1.0+H11*H22 10930 MDR F2,F0 COMPUTE B2*U 10940 STD F2,0(R4) STORE B1=B2*U 10950 LD F4,0(R3) GET D2 10960 DDR F4,F0 COMPUTE D2/U 10970 LD F2,0(R2) GET D1 10980 DDR F2,F0 COMPUTE D1/U 10990 STD F4,0(R2) STORE D1=D2/U 11000 STD F2,0(R3) STORE D2=D1/U 11010 B DWLP1 11020 NOTRANS LD F0,=D'-2.0' NO TRANSFORMATION CASE; 11030 STD F0,DFLAG SET DFLAG=-2.0 11040 B DONE RETURN 11050 BR2 LD F0,=D'-1.0' P2*B2<0 CASE 11060 STD F0,DFLAG SET DFLAG=-1.0 11070 SDR F0,F0 11080 STD F0,H11 SET H11=0. 11090 STD F0,H12 SET H12=0. 11100 STD F0,H21 SET H21=0. 11110 STD F0,H22 SET H22=0. 11120 STD F0,0(R2) SET D1=0. 11130 STD F0,0(R3) SET D2=0. 11140 STD F0,0(R4) SET B1=0. 11150 B DONE RETURN 11160 BR1 DDR F6,F4 COMPUTE P2/P1 11170 STD F6,H12 STORE H12=P2/P1 11180 LD F2,0(R5) GET B2 11190 LD F0,0(R4) GET B1 11200 DDR F2,F0 COMPUTE B2/B1 11210 MDR F6,F2 COMPUTE H12*B2/B1 11220 AD F6,=D'1.0' COMPUTE U=1+H12*B2/B1 11230 LCDR F2,F2 COMPUTE H21=-B2/B1 11240 STD F2,H21 STORE H21 11250 CD F6,TOL SEE IF U .LE. TOL 11260 BNH BR2 11270 SDR F2,F2 11280 STD F2,DFLAG SET DFLAG=0. 11290 LD F4,0(R2) GET D1 11300 LD F2,0(R3) GET D2 11310 DDR F4,F6 COMPUTE D1/U 11320 DDR F2,F6 COMPUTE D2/U 11330 MDR F0,F6 COMPUTE B1*U 11340 STD F4,0(R2) STORE D1=D1/U 11350 STD F2,0(R3) STORE D2=D2/U 11360 STD F0,0(R4) STORE B1=B1*U 11370 DWLP1 LPDR F0,F4 PUT DABS(D1) INTO F0 11380 CD F0,TWOM24 SEE IF DABS(D1) .GT. TWOM24 11390 BH DWLP2 11400 LTDR F4,F4 SEE IF D1=0. 11410 BZ DWLP3 IF D1=0. BRANCH TO DWLP3 11420 DFIXH 11430 MD F4,TWO12 MULTIPLY TWICE TO COMPUTE 11440 MD F4,TWO12 D1*(C**2) 11450 STD F4,0(R2) STORE D1=D1*(C**2) 11460 LD F6,0(R4) GET B1 11470 DD F6,TWO12 COMPUTE B1/C 11480 STD F6,0(R4) STORE B1=B1/C 11490 LD F6,H11 GET H11 11500 DD F6,TWO12 COMPUTE H11/C 11510 STD F6,H11 STORE H11=H11/C 11520 LD F6,H12 GET H12 11530 DD F6,TWO12 COMPUTE H12/C 11540 STD F6,H12 STORE H12=H12/C 11550 B DWLP1 11560 DWLP2 LPDR F0,F4 PUT DABS(D1) INTO F0 11570 CD F0,TWO24 SEE IF DABS(D1) .LT. TWO24 11580 BL DWLP3 11590 DFIXH 11600 DD F4,TWO12 DIVIDE TWICE TO COMPUTE 11610 DD F4,TWO12 D1/C**2 11620 STD F4,0(R2) STORE D1=D1/C**2 11630 LD F6,0(R4) GET B1 11640 MD F6,TWO12 COMPUTE B1*C 11650 STD F6,0(R4) STORE B1=B1*C 11660 LD F6,H11 GET H11 11670 MD F6,TWO12 COMPUTE H11*C 11680 STD F6,H11 STORE H11=H11*C 11690 LD F6,H12 GET H12 11700 MD F6,TWO12 COMPUTE H12*C 11710 STD F6,H12 STORE H12=H12*C 11720 B DWLP2 11730 DWLP3 LPDR F0,F2 PUT DABS(D2) INTO F0 11740 CD F0,TWOM24 SEE IF DABS(D2) .GT. TWOM24 11750 BH DWLP4 11760 LTDR F2,F2 SEE IF D2=0. 11770 BZ DONE IF D2=0. RETURN 11780 DFIXH 11790 MD F2,TWO12 MULTIPLY TWICE TO COMPUTE 11800 MD F2,TWO12 D2*(C**2) 11810 STD F2,0(R3) STORE D2=D2*(C**2) 11820 LD F6,H21 GET H21 11830 DD F6,TWO12 COMPUTE H21/C 11840 STD F6,H21 STORE H21=H21/C 11850 LD F6,H22 GET H22 11860 DD F6,TWO12 COMPUTE H22/C 11870 STD F6,H22 STORE H22=H22/C 11880 B DWLP3 11890 DWLP4 LPDR F0,F2 PUT DABS(D2) INTO F0 11900 CD F0,TWO24 SEE IF DABS(D2) .LT. TWO24 11910 BL DONE 11920 DFIXH 11930 DD F2,TWO12 DIVIDE TWICE TO COMPUTE 11940 DD F2,TWO12 D2/C**2 11950 STD F2,0(R3) STORE D2=D2/C**2 11960 LD F6,H21 GET H21 11970 MD F6,TWO12 COMPUTE H21*C 11980 STD F6,H21 STORE H21=H21*C 11990 LD F6,H22 GET H22 12000 MD F6,TWO12 COMPUTE H22*C 12010 STD F6,H22 STORE H22=H22*C 12020 B DWLP4 12030 DONE EPILOG 12040 LTORG 12050 DS 0D 12060 P2B2 DS D 12070 TWO12 DC D'4096.' 12080 TWO24 DC D'16777216.' 12090 TWOM24 DC D'5.960E-08' 12100 TOL DC D'0.0' 12110 DPARAM DSECT 12120 DFLAG DS D 12130 H11 DS D 12140 H21 DS D 12150 H12 DS D 12160 H22 DS D 12170 END 12180 *********APPLY MOD. GIVENS TRANS., SNGL PREC., SROTM, IBM/360 ASM.***** 12190 * USAGE STATEMENT 30 SEPT 1975* 12200 * CALL SROTM (N,SX,INCX,SY,INCY,SPARAM) WASH. ST. U* 12210 * REAL*4 SX( ),SY( ),SPARAM(5), INTEGER * 4 N,INCX,INCY * 12220 *********************************************************************** 12230 SROTM PROLOG R11 12240 LM R2,R7,0(R1) GET POINTERS TO ARGUMENTS 12250 USING SPARAM,R7 LOAD ADDRESS OF SPARAM( ) 12260 NCHK R9,R2,DONE GET N AND QUIT IF N .LE. 0 12270 LE F0,FLAG GET FLAG TO SEE WHICH MODE 12280 LTER F0,F0 THE TRANSFORMATION WILL HAVE 12290 BZ B1 FLAG=0. CASE 12300 BP B2 FLAG=1. CASE 12310 AE F0,=E'2.0' CHECK FOR FLAG=-2. CASE 12320 BZ DONE 12330 B C3 BRANCH TO LOOP 3 12340 B1 LE F4,H12 SAVE H12 AND H21 FOR MULTIPLYING 12350 LE F6,H21 IN LOOP 1 12360 L R11,0(R4) GET INCX 12370 C R11,0(R6) COMPARE INCY WITH INCX 12380 BNE C1 BRANCH TO GEN. LOOP IF NOT EQUAL 12390 SLA R11,RSTAR4 MULTIPLY INCX * 4 12400 BM C1 GEN. LOOP IF INCX,INCY NEG. 12410 LR R8,R11 SAVE INCX*4 IN UNOCCUPIED R8 12420 MR R10,R9 COMPUTE INCX * 4 * (N-1) 12430 SR R6,R6 SET R6 = 0 12440 LR R10,R8 LOAD R10 WITH LOOP1E INCREMENT 12450 CNOP 0,8 ALIGN ON DOUBLE WORD. 12460 LOOP1E LE F0,0(R6,R3) GET SX() 12470 LE F2,0(R6,R5) GET SY() 12480 MER F2,F4 COMPUTE H12*SY() 12490 MER F0,F6 COMPUTE H21*SX() 12500 AE F2,0(R6,R3) COMPUTE SX()+H12*SY() 12510 AE F0,0(R6,R5) COMPUTE H21*SX()+SY() 12520 STE F2,0(R6,R3) OVERWRITE SX() 12530 STE F0,0(R6,R5) OVERWRITE SY() 12540 BXLE R6,R10,LOOP1E 12550 B DONE 12560 C1 INCFX R3,R4,R9,R11,RSTAR4,ICY1 FIX SX() INCREMENT 12570 ICY1 INCFX R5,R6,R9,R11,RSTAR4,LOOP1N FIX SY() INCREMENT 12580 CNOP 0,8 ALIGN ON DOUBLE WORD. 12590 LOOP1N LE F0,0(R3) GET SX() 12600 LE F2,0(R5) GET SY() 12610 MER F2,F4 COMPUTE H12*SY() 12620 MER F0,F6 COMPUTE H21*SX() 12630 AE F2,0(R3) COMPUTE SX()+H12*SY() 12640 AE F0,0(R5) COMPUTE H21*SX()+SY() 12650 STE F2,0(R3) OVERWRITE SX() 12660 STE F0,0(R5) OVERWRITE SY() 12670 INCBR R3,R4,R5,R6,R2,LOOP1N 12680 B DONE 12690 B2 LE F4,H11 SAVE H11 AND H22 FOR MULTIPLYING 12700 LE F6,H22 IN LOOP2 12710 L R11,0(R4) GET INCX 12720 C R11,0(R6) COMPARE INCY WITH INCX 12730 BNE C2 BRANCH TO GEN. LOOP IF NOT EQUAL 12740 SLA R11,RSTAR4 MULTIPLY INCX * 4 12750 BM C2 GEN. LOOP IF INCX,INCY NEG. 12760 LR R8,R11 SAVE INCX*4 IN UNOCCUPIED R8 12770 MR R10,R9 COMPUTE INCX * 4 * (N-1) 12780 SR R6,R6 SET R6 = 0 12790 LR R10,R8 LOAD R10 WITH LOOP2E INCREMENT 12800 CNOP 0,8 ALIGN ON DOUBLE WORD. 12810 LOOP2E LE F0,0(R6,R3) GET SX() 12820 LE F2,0(R6,R5) GET SY() 12830 MER F0,F4 COMPUTE H11*SX() 12840 MER F2,F6 COMPUTE H22*SY() 12850 AE F0,0(R6,R5) COMPUTE H11*SX()+SY() 12860 SE F2,0(R6,R3) COMPUTE -SX()+H22*SY() 12870 STE F0,0(R6,R3) OVERWRITE SX() 12880 STE F2,0(R6,R5) OVERWRITE SY() 12890 BXLE R6,R10,LOOP2E 12900 B DONE 12910 C2 INCFX R3,R4,R9,R11,RSTAR4,ICY2 FIX SX() INCREMENT 12920 ICY2 INCFX R5,R6,R9,R11,RSTAR4,LOOP2N FIX SY() INCREMENT 12930 CNOP 0,8 ALIGN ON DOUBLE WORD. 12940 LOOP2N LE F0,0(R3) GET SX() 12950 LE F2,0(R5) GET SY() 12960 MER F0,F4 COMPUTE H11*SX() 12970 MER F2,F6 COMPUTE H22*SY() 12980 AE F0,0(R5) COMPUTE H11*SX()+SY() 12990 SE F2,0(R3) COMPUTE -SX()+H22*SY() 13000 STE F0,0(R3) OVERWRITE SX() 13010 STE F2,0(R5) OVERWRITE SY() 13020 INCBR R3,R4,R5,R6,R2,LOOP2N 13030 B DONE 13040 C3 INCFX R3,R4,R9,R11,RSTAR4,ICY3 FIX SX() INCREMENT 13050 ICY3 INCFX R5,R6,R9,R11,RSTAR4,LOOP3 FIX SY() INCREMENT 13060 CNOP 0,8 ALIGN ON DOUBLE WORD. 13070 LOOP3 LE F4,0(R3) GET SX() 13080 LE F6,0(R5) GET SY() 13090 LE F0,H11 GET H11 13100 LE F2,H12 GET H12 13110 MER F0,F4 COMPUTE H11*SX() 13120 MER F2,F6 COMPUTE H12*SY() 13130 AER F2,F0 COMPUTE H11*SX()+H12*SY() 13140 LE F0,H21 GET H21 13150 MER F0,F4 COMPUTE H21*SX() 13160 STE F2,0(R3) OVERWRITE SX() 13170 LE F2,H22 GET H22 13180 MER F2,F6 COMPUTE H22*SY() 13190 AER F0,F2 COMPUTE H21*SX()+H22*SY() 13200 STE F0,0(R5) OVERWRITE SY() 13210 INCBR R3,R4,R5,R6,R2,LOOP3 13220 DONE EPILOG 13230 LTORG 13240 SPARAM DSECT 13250 FLAG DS F 13260 H11 DS F 13270 H21 DS F 13280 H12 DS F 13290 H22 DS F 13300 END 13310 *********APPLY MOD. GIVENS TRANS., DBLE PREC., DROTM, IBM/360 ASM.***** 13320 * USAGE STATEMENT 30 SEPT 1975* 13330 * CALL DROTM (N,DX,INCX,DY,INCY,DPARAM) WASH. ST. U* 13340 * REAL*8 DX( ),DY( ),DPARAM(5), INTEGER * 4 N,INCX,INCY * 13350 *********************************************************************** 13360 DROTM PROLOG R11 13370 LM R2,R7,0(R1) GET POINTERS TO ARGUMENTS 13380 USING DPARAM,R7 LOAD ADDRESS OF DPARAM( ) 13390 NCHK R9,R2,DONE GET N AND QUIT IF N .LE. 0 13400 LD F0,FLAG GET FLAG TO SEE WHICH MODE 13410 LTDR F0,F0 THE TRANSFORMATION WILL HAVE 13420 BZ B1 FLAG=0. CASE 13430 BP B2 FLAG=1. CASE 13440 AD F0,=D'2.0' CHECK FOR FLAG=-2. CASE 13450 BZ DONE 13460 B C3 BRANCH TO LOOP 3 13470 B1 LD F4,H12 SAVE H12 AND H21 FOR MULTIPLYING 13480 LD F6,H21 IN LOOP 1 13490 L R11,0(R4) GET INCX 13500 C R11,0(R6) COMPARE INCY WITH INCX 13510 BNE C1 BRANCH TO GEN. LOOP IF NOT EQUAL 13520 SLA R11,RSTAR8 MULTIPLY INCX * 8 13530 BM C1 GEN. LOOP IF INCX,INCY NEG. 13540 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 13550 MR R10,R9 COMPUTE INCX * 8 * (N-1) 13560 SR R6,R6 SET R6 = 0 13570 LR R10,R8 LOAD R10 WITH LOOP1E INCREMENT 13580 CNOP 0,8 ALIGN ON DOUBLE WORD. 13590 LOOP1E LD F0,0(R6,R3) GET DX() 13600 LD F2,0(R6,R5) GET DY() 13610 MDR F2,F4 COMPUTE H12*DY() 13620 MDR F0,F6 COMPUTE H21*DX() 13630 AD F2,0(R6,R3) COMPUTE DX()+H12*DY() 13640 AD F0,0(R6,R5) COMPUTE H21*DX()+DY() 13650 STD F2,0(R6,R3) OVERWRITE DX() 13660 STD F0,0(R6,R5) OVERWRITE DY() 13670 BXLE R6,R10,LOOP1E 13680 B DONE 13690 C1 INCFX R3,R4,R9,R11,RSTAR8,ICY1 FIX DX() INCREMENT 13700 ICY1 INCFX R5,R6,R9,R11,RSTAR8,LOOP1N FIX DY() INCREMENT 13710 CNOP 0,8 ALIGN ON DOUBLE WORD. 13720 LOOP1N LD F0,0(R3) GET DX() 13730 LD F2,0(R5) GET DY() 13740 MDR F2,F4 COMPUTE H12*DY() 13750 MDR F0,F6 COMPUTE H21*DX() 13760 AD F2,0(R3) COMPUTE DX()+H12*DY() 13770 AD F0,0(R5) COMPUTE H21*DX()+DY() 13780 STD F2,0(R3) OVERWRITE DX() 13790 STD F0,0(R5) OVERWRITE DY() 13800 INCBR R3,R4,R5,R6,R2,LOOP1N 13810 B DONE 13820 B2 LD F4,H11 SAVE H11 AND H22 FOR MULTIPLYING 13830 LD F6,H22 IN LOOP2 13840 L R11,0(R4) GET INCX 13850 C R11,0(R6) COMPARE INCY WITH INCX 13860 BNE C2 BRANCH TO GEN. LOOP IF NOT EQUAL 13870 SLA R11,RSTAR8 MULTIPLY INCX * 8 13880 BM C2 GEN. LOOP IF INCX,INCY NEG. 13890 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 13900 MR R10,R9 COMPUTE INCX * 8 * (N-1) 13910 SR R6,R6 SET R6 = 0 13920 LR R10,R8 LOAD R10 WITH LOOP2E INCREMENT 13930 CNOP 0,8 ALIGN ON DOUBLE WORD. 13940 LOOP2E LD F0,0(R6,R3) GET DX() 13950 LD F2,0(R6,R5) GET DY() 13960 MDR F0,F4 COMPUTE H11*DX() 13970 MDR F2,F6 COMPUTE H22*DY() 13980 AD F0,0(R6,R5) COMPUTE H11*DX()+DY() 13990 SD F2,0(R6,R3) COMPUTE -DX()+H22*DY() 14000 STD F0,0(R6,R3) OVERWRITE DX() 14010 STD F2,0(R6,R5) OVERWRITE DY() 14020 BXLE R6,R10,LOOP2E 14030 B DONE 14040 C2 INCFX R3,R4,R9,R11,RSTAR8,ICY2 FIX DX() INCREMENT 14050 ICY2 INCFX R5,R6,R9,R11,RSTAR8,LOOP2N FIX DY() INCREMENT 14060 CNOP 0,8 ALIGN ON DOUBLE WORD. 14070 LOOP2N LD F0,0(R3) GET DX() 14080 LD F2,0(R5) GET DY() 14090 MDR F0,F4 COMPUTE H11*DX() 14100 MDR F2,F6 COMPUTE H22*DY() 14110 AD F0,0(R5) COMPUTE H11*DX()+DY() 14120 SD F2,0(R3) COMPUTE -DX()+H22*DY() 14130 STD F0,0(R3) OVERWRITE DX() 14140 STD F2,0(R5) OVERWRITE DY() 14150 INCBR R3,R4,R5,R6,R2,LOOP2N 14160 B DONE 14170 C3 INCFX R3,R4,R9,R11,RSTAR8,ICY3 FIX DX() INCREMENT 14180 ICY3 INCFX R5,R6,R9,R11,RSTAR8,LOOP3 FIX DY() INCREMENT 14190 CNOP 0,8 ALIGN ON DOUBLE WORD. 14200 LOOP3 LD F4,0(R3) GET DX() 14210 LD F6,0(R5) GET DY() 14220 LD F0,H11 GET H11 14230 LD F2,H12 GET H12 14240 MDR F0,F4 COMPUTE H11*DX() 14250 MDR F2,F6 COMPUTE H12*DY() 14260 ADR F2,F0 COMPUTE H11*DX()+H12*DY() 14270 LD F0,H21 GET H21 14280 MDR F0,F4 COMPUTE H21*DX() 14290 STD F2,0(R3) OVERWRITE DX() 14300 LD F2,H22 GET H22 14310 MDR F2,F6 COMPUTE H22*DY() 14320 ADR F0,F2 COMPUTE H21*DX()+H22*DY() 14330 STD F0,0(R5) OVERWRITE DY() 14340 INCBR R3,R4,R5,R6,R2,LOOP3 14350 DONE EPILOG 14360 LTORG 14370 DPARAM DSECT 14380 FLAG DS 2F 14390 H11 DS 2F 14400 H21 DS 2F 14410 H12 DS 2F 14420 H22 DS 2F 14430 END 14440 *********SINGLE PRECISION COPY ROUTINE, SCOPY, IBM/360 ASM.************ 14450 * USAGE STATEMENT 14 AUGUST 1975* 14460 * CALL SCOPY (N,SX,INCX,SY,INCY) WASH. ST. U/ANL* 14470 * SX( ),SY( ),REAL*4 N,INCX,INCY,INTEGER*4 * 14480 *********************************************************************** 14490 SCOPY PROLOG R11 14500 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 14510 NCHK R9,R2,DONE GET N AND EXIT IF N .LE. 0 14520 L R11,0(R4) GET INCX 14530 C R11,0(R6) COMPARE INCY WITH INCX 14540 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 14550 SLA R11,RSTAR4 MULTIPLY INCX * 4 14560 BM INCNE IF INCX,INCY NEG., GEN. LOOP 14570 LR R8,R11 SAVE INCX*4 IN UNOCCUPIED R8 14580 MR R10,R9 COMPUTE INCX * 4 * (N-1) 14590 SR R6,R6 SET R6 = 0 14600 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 14610 CNOP 0,8 ALIGN ON DOUBLE WORD. 14620 LOOPEQ LE F0,0(R6,R3) GET SX( ) AND 14630 STE F0,0(R6,R5) STORE IN LOCATION SY( ) 14640 BXLE R6,R10,LOOPEQ 14650 B DONE 14660 INCNE INCFX R3,R4,R9,R11,RSTAR4,INCYT FIX SX( ) INCREMENT 14670 INCYT INCFX R5,R6,R9,R11,RSTAR4,LOOPNE FIX SY( ) INCREMENT 14680 CNOP 0,8 ALIGN ON DOUBLE WORD. 14690 LOOPNE LE F0,0(R3) GET SX( ) AND 14700 STE F0,0(R5) STORE IN LOCATION SY( ) 14710 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE LOOP 14720 DONE EPILOG 14730 END 14740 *********DOUBLE PRECISION COPY ROUTINE, DCOPY, IBM/360 ASM.************ 14750 * USAGE STATEMENT 14 AUGUST 1975* 14760 * CALL COPY (N,DX,INCX,DY,INCY) WASH. ST. U/ANL* 14770 * DX( ),DY( ),REAL*8 N,INCX,INCY,INTEGER*4 * 14780 *********************************************************************** 14790 DCOPY PROLOG R11 14800 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 14810 NCHK R9,R2,DONE GET N AND EXIT IF N .LE. 0 14820 L R11,0(R4) GET INCX 14830 C R11,0(R6) COMPARE INCY WITH INCX 14840 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 14850 SLA R11,RSTAR8 MULTIPLY INCX * 8 14860 BM INCNE IF INCX,INCY NEG., GEN. LOOP 14870 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 14880 MR R10,R9 COMPUTE INCX * 8 * (N-1) 14890 SR R6,R6 SET R6 = 0 14900 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 14910 CNOP 0,8 ALIGN ON DOUBLE WORD. 14920 LOOPEQ LD F0,0(R6,R3) GET DX( ) AND 14930 STD F0,0(R6,R5) STORE IN LOCATION DY( ) 14940 BXLE R6,R10,LOOPEQ 14950 B DONE 14960 INCNE INCFX R3,R4,R9,R11,RSTAR8,INCYT FIX DX( ) INCREMENT 14970 INCYT INCFX R5,R6,R9,R11,RSTAR8,LOOPNE FIX DY( ) INCREMENT 14980 CNOP 0,8 ALIGN ON DOUBLE WORD. 14990 LOOPNE LD F0,0(R3) GET DX( ) AND 15000 STD F0,0(R5) STORE IN LOCATION DY( ) 15010 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE LOOP 15020 DONE EPILOG 15030 END 15040 *********COMPLEX COPY ROUTINE,CCOPY, IBM/360 ASM.********************** 15050 * USAGE STATEMENT 19 MAY 1974* 15060 * CALL CCOPY(N,CX,INCX,CY,INCY) WASH. ST. U* 15070 * CX( ),CY( ),COMPLEX*8, N,INCX,INCY,INTEGER*4 * 15080 *********************************************************************** 15090 CCOPY PROLOG R10 15100 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 15110 NCHK R10,R2,DONE GET N AND QUIT IF N .LE. 0 15120 INCFX R3,R4,R10,R9,CSTAR8,ICY FIX CX( ) INCREMENT 15130 ICY INCFX R5,R6,R10,R9,CSTAR8,LOOP FIX CY( ) INCREMENT 15140 CNOP 0,8 ALIGN ON DOUBLE WORD. 15150 LOOP LE F0,0(R3) GET REAL AND IMAGINARY PARTS 15160 LE F2,4(R3) OF CX( ) AND 15170 STE F0,0(R5) STORE THESE IN REAL AND 15180 STE F2,4(R5) IMAGINARY PARTS OF CY( ) 15190 INCBR R3,R4,R5,R6,R2,LOOP ADD INCREMENTS AND CONTINUE LOOP 15200 DONE EPILOG 15210 END 15220 *********SINGLE PRECISION SWAP ROUTINE, SSWAP, IBM/360 ASM.************ 15230 * USAGE STATEMENT 14 AUGUST 1975* 15240 * CALL SSWAP (N,SX,INCX,SY,INCY) WASH. ST. U/ANL* 15250 * SX( ),SY( ),REAL*4 N,INCX,INCY,INTEGER*4 * 15260 *********************************************************************** 15270 SSWAP PROLOG R11 15280 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 15290 NCHK R9,R2,DONE GET N AND EXIT IF N .LE. 0 15300 L R11,0(R4) GET INCX 15310 C R11,0(R6) COMPARE INCY WITH INCX 15320 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 15330 SLA R11,RSTAR4 MULTIPLY INCX * 4 15340 BM INCNE IF INCX,INCY NEG., GEN. LOOP 15350 LR R8,R11 SAVE INCX*4 IN UNOCCUPIED R8 15360 MR R10,R9 COMPUTE INCX * 4 * (N-1) 15370 SR R6,R6 SET R6 = 0 15380 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 15390 CNOP 0,8 ALIGN ON DOUBLE WORD. 15400 LOOPEQ LE F0,0(R6,R3) GET SX( ) 15410 LE F2,0(R6,R5) GET SY( ) 15420 STE F0,0(R6,R5) STORE SX( ) AT LOCATION SY( ) 15430 STE F2,0(R6,R3) STORE SY( ) AT LOCATION SX( ) 15440 BXLE R6,R10,LOOPEQ 15450 B DONE 15460 CNOP 0,8 ALIGN ON DOUBLE WORD. 15470 INCNE INCFX R3,R4,R9,R11,RSTAR4,ICY FIX SX( ) INCREMENT 15480 ICY INCFX R5,R6,R9,R11,RSTAR4,LOOPNE FIX SY( ) INCREMENT 15490 LOOPNE LE F0,0(R3) GET SX( ) 15500 LE F2,0(R5) GET SY( ) 15510 STE F0,0(R5) STORE SX( ) AT LOCATION SY( ) 15520 STE F2,0(R3) STORE SY( ) AT LOCATION SX( ) 15530 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE 15540 DONE EPILOG 15550 END 15560 *********DOUBLE PRECISION SWAP ROUTINE, DSWAP, IBM/360 ASM.************ 15570 * USAGE STATEMENT 14 AUGUST 1975* 15580 * CALL DSWAP (N,DX,INCX,DY,INCY) WASH. ST. U/ANL* 15590 * DX( ),DY( ),REAL*8 N,INCX,INCY,INTEGER*4 * 15600 *********************************************************************** 15610 DSWAP PROLOG R11 15620 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 15630 NCHK R9,R2,DONE GET N AND EXIT IF N .LE. 0 15640 L R11,0(R4) GET INCX 15650 C R11,0(R6) COMPARE INCY WITH INCX 15660 BNE INCNE BRANCH TO GEN. LOOP IF NOT EQUAL 15670 SLA R11,RSTAR8 MULTIPLY INCX * 8 15680 BM INCNE IF INCX,INCY NEG., GEN. LOOP 15690 LR R8,R11 SAVE INCX*8 IN UNOCCUPIED R8 15700 MR R10,R9 COMPUTE INCX * 8 * (N-1) 15710 SR R6,R6 SET R6 = 0 15720 LR R10,R8 LOAD R10 WITH LOOPEQ INCREMENT 15730 CNOP 0,8 ALIGN ON DOUBLE WORD. 15740 LOOPEQ LD F0,0(R6,R3) GET DX( ) 15750 LD F2,0(R6,R5) GET DY( ) 15760 STD F0,0(R6,R5) STORE DX( ) AT LOCATION DY( ) 15770 STD F2,0(R6,R3) STORE DY( ) AT LOCATION DX( ) 15780 BXLE R6,R10,LOOPEQ 15790 B DONE 15800 INCNE INCFX R3,R4,R9,R11,RSTAR8,ICY FIX DX( ) INCREMENT 15810 ICY INCFX R5,R6,R9,R11,RSTAR8,LOOPNE FIX DY( ) INCREMENT 15820 CNOP 0,8 ALIGN ON DOUBLE WORD. 15830 LOOPNE LD F0,0(R3) GET DX( ) 15840 LD F2,0(R5) GET DY( ) 15850 STD F0,0(R5) STORE DX( ) AT LOCATION DY( ) 15860 STD F2,0(R3) STORE DY( ) AT LOCATION DX( ) 15870 INCBR R3,R4,R5,R6,R2,LOOPNE ADD INCREMENTS AND CONTINUE 15880 DONE EPILOG 15890 END 15900 *********COMPLEX SWAPPING ROUTINE, CSWAP, IBM/360 ASM.************* 15910 * USAGE STATEMENT 19 MAY 1974* 15920 * CALL CSWAP(N,CX,INCX,CY,INCY) WASH. ST. U* 15930 * CX( ),CY( ),COMPLEX*8, N,INCX,INCY,INTEGER*4 * 15940 *********************************************************************** 15950 CSWAP PROLOG R10 15960 LM R2,R6,0(R1) GET POINTERS TO ARGUMENTS 15970 NCHK R10,R2,DONE GET N AND QUIT IF N .LE. 0 15980 INCFX R3,R4,R10,R9,CSTAR8,ICY FIX DX( ) INCREMENT 15990 ICY INCFX R5,R6,R10,R9,CSTAR8,LOOP FIX CY( ) INCREMENT 16000 CNOP 0,8 ALIGN ON DOUBLE WORD. 16010 LOOP LE F0,0(R3) GET REAL AND IMAGINARY 16020 LE F2,4(R3) PART OF CX( ) 16030 LE F4,0(R5) GET REAL AND IMAGINARY 16040 LE F6,4(R5) PART OF CY( ) 16050 STE F0,0(R5) STORE REAL AND IMAG. 16060 STE F2,4(R5) PARTS OF CX( ) AT CY( ) 16070 STE F4,0(R3) STORE REAL AND IMAG. 16080 STE F6,4(R3) PARTS OF CY( ) AT CX( ) 16090 INCBR R3,R4,R5,R6,R2,LOOP ADD INCREMENTS AND CONTINUE LOOP 16100 DONE EPILOG 16110 END 16120 *********EUCLIDEAN NORM SINGLE PREC.,SNRM2, IBM/360 ASM.*************** 16130 * USAGE STATEMENT 22 MAY 1974* 16140 * SW = SNRM2(N,SX,INCX) WASH. ST. U* 16150 * SW,SNRM2,SX( ) REAL *4, N,INCX INTEGER * 4 * 16160 *********************************************************************** 16170 SNRM2 PROLOG R6 16180 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 16190 SER F0,F0 SET SNRM2 = 0.0 16200 L R2,0(R2) GET VALUE OF N 16210 LTR R5,R2 CHECK IF N .LE. 0 AND SAVE N 16220 BNP DONE IF YES RETURN 16230 LR R6,R3 SAVE BASE ADDRESS OF SX( ) 16240 L R4,0(R4) GET VALUE OF INCX. 16250 SLA R4,RSTAR4 COMPUTE INCX*4 AND SET CODES 16260 BM DONE IF INCX .LT. 0 RETURN 16270 SER F6,F6 SET U = 0.0 (LEAVE IN REG. F6) 16280 CNOP 0,8 ALIGN ON DOUBLE WORD. 16290 LOOP1 LE F4,0(R3) GET SX( ) 16300 LPER F4,F4 COMPUTE ABS(SX( )) 16310 CE F4,ALPHA SET CODES FOR UNDERFLOW 16320 BH LOOP2 BRANCH IF UNFL. DON'T HURT NUM. 16330 CER F6,F4 FIND MAX. VALUE OF ABS(SX( )) 16340 BNL UBIG IF BRANCH OCCURS U(F6) IS LARGER 16350 LER F6,F4 F6 CONTAINS MAX SO FAR 16360 UBIG AR R3,R4 COMPUTE ADDRESS OF NEXT ELEMENT 16370 BCT R2,LOOP1 16380 CER F0,F6 SEE IF MAX. IS ZERO. 16390 BE DONE QUIT IF SO. 16400 LE F2,=E'1.0' 16410 DER F2,F6 COMPUTE SCALE FACTOR FOR UNFL 16420 LR R2,R5 RESTORE VALUES OF N AND 16430 LR R3,R6 BASE ADDRESS OF SX( ) 16440 B LOOP3 16450 CNOP 0,8 ALIGN ON DOUBLE WORD. 16460 LOOP2 LE F4,0(R3) MAIN LOOP BEGINS HERE 16470 LPER F4,F4 COMPUTE ABS(SX( )) 16480 CE F4,GAMMA CHECK FOR OVERFLOW 16490 BH OVRFL BRANCH TO OTHER LOOP IF OVERFL. 16500 MER F4,F4 SQUARE VALUE 16510 AER F0,F4 ACCUMULATE SUM IN F0 16520 AR R3,R4 GET ADDRESS OF NEXT ELEMENT 16530 BCT R2,LOOP2 END OF MAIN LOOP 16540 LE F6,=E'1.0' FINAL SCALE FACTOR 16550 B CALSQ BRANCH AND COMPUTE SQRT( ) 16560 OVRFL LE F6,U1 SET OVERFLOW PARAMETER 16570 LE F2,U2 RECIPROCAL OF SCALE FACTOR 16580 MER F0,F2 USE TWO MULTIPLIES BY OVERFLOW 16590 MER F0,F2 PARAMETER TO SCALE RESULT 16600 CNOP 0,8 ALIGN ON DOUBLE WORD. 16610 LOOP3 LE F4,0(R3) CONTINUE ACCUMULATION BY 16620 MER F4,F2 MULTIPLYING EACH ELEMENT BY THE 16630 MER F4,F4 SCALE FACTOR AND SQUARE RESULT 16640 AER F0,F4 CONTINUE ACCUMULATION 16650 AR R3,R4 GET ADDRESS OF NEXT ELEMENT 16660 BCT R2,LOOP3 END OF SCALED LOOP. 16670 CALSQ STE F0,VALUE STORE VALUE FOR BRANCH 16680 STE F6,U SAVE FINAL RESCALING VALUE. 16690 L R15,=V(SQRT) GET ADDRESS OF SQRT 16700 CNOP 0,4 16710 BAL R1,SQRTC 16720 DC X'80',AL3(VALUE) 16730 SQRTC BALR R14,R15 16740 ME F0,U MULTIPLY RESULT BY SCALE FACTOR 16750 DONE EPILOG 16760 ALPHA DC E'1.E-34' 16770 GAMMA DC E'1.E+35' 16780 U1 DC E'1.E+36' 16790 U2 DC E'1.E-36' 16800 VALUE DC E'0' 16810 U DS F 16820 END 16830 *********EUCLIDEAN NORM DOUBLE PREC., DNRM2, IBM/360 ASM.************** 16840 * USAGE STATEMENT 22 MAY 1974* 16850 * DW = DNRM2(N,DX,INCX) WASH. ST. U* 16860 * DW,DNRM2,DX( ), REAL * 8, N,INCX REAL * 4 * 16870 *********************************************************************** 16880 DNRM2 PROLOG R6 16890 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 16900 SDR F0,F0 SET DNRM2 = 0.0 16910 L R2,0(R2) GET VALUE OF N 16920 LTR R5,R2 CHECK IF N .LE. 0 AND SAVE N 16930 BNP DONE IF YES RETURN 16940 LR R6,R3 SAVE BASE ADDRESS OF DX( ) 16950 L R4,0(R4) GET VALUE OF INCX 16960 SLA R4,RSTAR8 COMPUTE INCX*8 AND SET CODES 16970 BM DONE IF INCX .LT. 0 RETURN 16980 SDR F6,F6 SET U = 0.0 (LEAVE IN REG. F6) 16990 CNOP 0,8 ALIGN ON DOUBLE WORD. 17000 LOOP1 LD F4,0(R3) GET DX( ) 17010 LPDR F4,F4 COMPUTE DABS(DX( )) 17020 CD F4,ALPHA SET CODES FOR UNDERFLOW 17030 BH LOOP2 BRANCH IF ELEMENT IS LARGER 17040 CDR F6,F4 FIND MAX. VALUE OF DABS(DX( )) 17050 BNL UBIG TEST FOR MAX. ELEMENT. 17060 LDR F6,F4 F6 CONTAINS MAX SO FAR 17070 UBIG AR R3,R4 COMPUTE ADDRESS OF NEXT ELEMENT 17080 BCT R2,LOOP1 END OF FIRST LOOP 17090 CDR F6,F0 CHECK IF MAX ELEMENT OF DX = 0.0 17100 BE DONE IF YES RETURN 17110 LD F2,=D'1.0' 17120 DDR F2,F6 COMPUTE SCALE FACTOR FOR UNDFLOW 17130 LR R2,R5 RESTORE VALUES OF N AND 17140 LR R3,R6 BASE ADDRESS OF DX( ) 17150 B LOOP3 17160 CNOP 0,8 ALIGN ON DOUBLE WORD. 17170 LOOP2 LD F4,0(R3) MAIN LOOP BEGINS HERE 17180 LPDR F4,F4 COMPUTE DABS(DX( )) 17190 CD F4,GAMMA CHECK FOR OVERFLOW 17200 BH OVRFL IF YES BRANCH FOR FIXUP 17210 MDR F4,F4 SQUARE VALUE 17220 ADR F0,F4 ACCUMULATE SUM IN F0 17230 AR R3,R4 GET ADDRESS OF NEXT ELEMENT 17240 BCT R2,LOOP2 END OF MAIN LOOP 17250 LD F6,=D'1.0' SCALE FACTOR 17260 B CALSQ BRANCH AND COMPUTE DSQRT( ) 17270 OVRFL LD F6,U1 SET OVERFLOW PARAMETER 17280 LD F2,U2 RECIPROCAL OF SCALE FACTOR 17290 MDR F0,F2 USE TWO MULTIPLIES BY OVERFLOW 17300 MDR F0,F2 PARAMETER TO SCALE RESOLT 17310 CNOP 0,8 ALIGN ON DOUBLE WORD. 17320 LOOP3 LD F4,0(R3) CONTINUE ACCUMULATION BY 17330 MDR F4,F2 MULTIPLYING EACH ELEMENT BY 17340 MDR F4,F4 SCALE FACTOR AND SQUARE RESULT 17350 ADR F0,F4 CONTINUE ACCUMULATION 17360 AR R3,R4 GET ADDRESS OF NEXT ELEMENT 17370 BCT R2,LOOP3 END OF SCALED LOOP. 17380 CALSQ STD F0,VALUE STORE VALUE FOR BRANCH 17390 STD F6,U SAVE FINAL RESCALING VALUE. 17400 L R15,=V(DSQRT) GET ADDRESS OF DSQRT 17410 CNOP 0,4 17420 BAL 1,SQRTC 17430 DC X'80',AL3(VALUE) 17440 SQRTC BALR R14,R15 BRANCH TO DSQRT 17450 MD F0,U MULTIPLY RESULT BY SCALE FACTOR 17460 DONE EPILOG 17470 ALPHA DC D'1.0E-29' 17480 GAMMA DC D'1.0E+35' 17490 U1 DC D'1.0E+36' 17500 U2 DC D'1.0E-36' 17510 VALUE DC D'0' 17520 U DS D 17530 END 17540 ***********EUCLIDEAN NORM, COMPLEX, SCNRM2, IBM/360 ASM.*************** 17550 * USAGE STATEMENT 30 OCTOBER 1975* 17560 * SW = SCNRM2 (N,CX,INCX) WASH. ST. U* 17570 * SW,SCNRM2 REAL*4, N,INCX INTEGER*4, CX( ) COMPLEX*8 * 17580 *********************************************************************** 17590 SCNRM2 PROLOG R6 17600 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS. 17610 SER F0,F0 SET SCNRM2 = 0.0 17620 L R2,0(R2) GET VALUE OF N. 17630 LTR R5,R2 CHECK IF N .LE. 0, SAVE N. 17640 BNP DONE IF YES RETURN. 17650 LR R6,R3 SAVE BASE ADDRESS OF CX( ) 17660 L R4,0(R4) GET VALUE OF INCX 17670 SLA R4,CSTAR8 COMPUTE INCX*8 AND SET CODES. 17680 BM DONE IF INCX .LT. 0 RETURN 17690 SER F6,F6 SET U = 0.0 (LEAVE IN REG. F6) 17700 CNOP 0,8 ALIGN ON DOUBLE WORD. 17710 LOOP1 LE F4,0(R3) GET REAL (CX()) 17720 LPER F4,F4 COMPUTE ABS REAL (CX()) 17730 CE F4,ALPHA SET CODES FOR UNDERFLOW. 17740 BH LOOP2 BRANCH IF UNFL. DON'T HURT NUM. 17750 CER F6,F4 FIND MAX VAL OF ABS REAL(CX()) 17760 BNL IMGPRT IF BRANCH OCCURS U(F6) IS LARGER 17770 LER F6,F4 F6 CONTAINS MAX SO FAR. 17780 IMGPRT LE F4,4(R3) GET AIMAG (CX()). 17790 LPER F4,F4 COMPUTE ABS(AIMAG(CX())). 17800 CE F4,ALPHA SET CODES FOR UNDERFLOW. 17810 BH LOOP2 BRANCH IF UNFL. DON'T HURT NUM. 17820 CER F6,F4 FIND MAX ABS(REAL),ABS(AIMAG). 17830 BNL UBIG IF BRANCH OCCURS U(F6) IS LARGER 17840 LER F6,F4 F6 CONTAINS MAX SO FAR. 17850 UBIG AR R3,R4 COMPUTE ADDRESS OF NEXT ELEMENT. 17860 BCT R2,LOOP1 END OF FIRST LOOP 17870 CER F0,F6 SEE IF MAX. IS ZERO. 17880 BE DONE QUIT IF SO. 17890 LE F2,=E'1.0' 17900 DER F2,F6 COMPUTE SCALE FACTOR FOR UNFL. 17910 LR R2,R5 RESTORE VALUE OF N AND 17920 LR R3,R6 BASE ADDRESS OF CX( ). 17930 B LOOP3 17940 CNOP 0,8 ALIGN ON DOUBLE WORD. 17950 LOOP2 LE F4,0(R3) MAIN LOOP BEGINS HERE. 17960 LPER F4,F4 COMPUTE ABS(REAL(CX())). 17970 CE F4,GAMMA CHECK FOR OVERFLOW. 17980 BH OVRFL BRANCH TO OTHER LOOP IF OVERFL. 17990 MER F4,F4 SQUARE VALUE. 18000 LE F2,4(R3) 18010 LPER F2,F2 COMPUTE ABS(AIMAG(CX())). 18020 CE F2,GAMMA CHECK FOR OVERFLOW. 18030 BH OVRFL 18040 MER F2,F2 SQUARE VALUE. 18050 AER F0,F2 18060 AER F0,F4 ACCUMULATE SUM IN F0 18070 AR R3,R4 GET ADDRESS OF NEXT ELEMENT. 18080 BCT R2,LOOP2 END OF MAIN LOOP. 18090 LE F6,=E'1.0' FINAL SCALE FACTOR 18100 B CALSQ BRANCH AND COMPUTE SQRT( ). 18110 OVRFL LE F2,U2 LOAD SCALE FACT, ALL COMPONENTS 18120 LE F6,U1 GET FINAL SCALE FACTOR. 18130 MER F0,F2 USE TWO MULTIPLIES BY OVERFLOW. 18140 MER F0,F2 PARAMETER TO SCALE RESULT. 18150 CNOP 0,8 ALIGN ON DOUBLE WORD. 18160 LOOP3 LE F4,0(R3) CONTINUE ACCUMULATION BY 18170 MER F4,F2 MULTIPLYING EACH ELEMENT BY THE 18180 MER F4,F4 SCALE FACTOR AND SCALE RESULT. 18190 AER F0,F4 CONTINUE ACCUMULATION. 18200 LE F4,4(R3) 18210 MER F4,F2 18220 MER F4,F4 18230 AER F0,F4 18240 AR R3,R4 GET ADDRESS OF NEXT ELEMENT. 18250 BCT R2,LOOP3 END OF SCALED LOOP. 18260 CALSQ STE F0,VALUE STORE VALUE FOR BRANCH 18270 STE F6,U SAVE FINAL RESCALING VALUE. 18280 L R15,=V(SQRT) GET ADDRESS OF SQRT 18290 CNOP 0,4 18300 BAL R1,SQRTC 18310 DC X'80',AL3(VALUE) 18320 SQRTC BALR R14,R15 18330 ME F0,U MULTIPLY RESULT BY SCALE FACTOR. 18340 DONE EPILOG 18350 ALPHA DC E'1.E-34' 18360 GAMMA DC E'1.E+35' 18370 U1 DC E'1.E+36' 18380 U2 DC E'1.E-36' 18390 VALUE DC E'0' 18400 U DS F 18410 END 18420 *********SUM OF MAGS. OF VECTORS, SNGL PREC., SASUM, IBM/360 ASM.****** 18430 * USAGE STATEMENT 24 MAY 1974* 18440 * SW = SASUM(N,SX,INCX) WASH. ST. U* 18450 * SW,SASUM,SX( ) REAL *4, N,INCX INTEGER * 4 * 18460 *********************************************************************** 18470 SASUM PROLOG R4 18480 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 18490 SER F0,F0 SET SASUM = 0. 18500 L R2,0(R2) GET N 18510 LTR R2,R2 SET COND. CODES 18520 BNP DONE EXIT IF N .LE. 0 18530 L R4,0(R4) GET INCX 18540 SLA R4,RSTAR4 COMPUTE INCX*4 AND SET COND. 18550 BM DONE EXIT IF INCX .LT. 0 18560 CNOP 0,8 ALIGN ON DOUBLE WORD. 18570 LOOP LE F2,0(R3) GET SX( ) IN F2 18580 LPER F2,F2 TAKE ABS. VALUE OF SX( ) 18590 AER F0,F2 ACCUMULATE SUM OF ABS. VALUES 18600 AR R3,R4 UPDATE SX( ) ADDRESS 18610 BCT 2,LOOP 18620 DONE EPILOG 18630 END 18640 *********SUM OF MAGS. OF VECTOR, DBLE PREC., DASUM, IBM/360 ASM.******* 18650 * USAGE STATEMENT 23 MAY 1974* 18660 * DW = DASUM(N,DX,INCX) WASH. ST. U* 18670 * DW,DASUM,DX( ) REAL * 8, N,INCX INTEGER * 4 * 18680 *********************************************************************** 18690 DASUM PROLOG R4 18700 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 18710 SDR F0,F0 SET DASUM = 0. 18720 L R2,0(R2) GET N 18730 LTR R2,R2 SET COND. CODES 18740 BNP DONE EXIT IF N .LE. 0 18750 L R4,0(R4) GET INCX 18760 SLA R4,RSTAR8 COMPUTE INCX*8 AND SET COMD. 18770 BM DONE EXIT IF INCX .LT. 0 18780 CNOP 0,8 ALIGN ON DOUBLE WORD. 18790 LOOP LD F2,0(R3) GET DX( ) IN F2 18800 LPDR F2,F2 TAKE ABS. VALUE OF DX( ) 18810 ADR F0,F2 ACCUMULATE SUM OF ABS. VALUES 18820 AR R3,R4 UPDATE DX( ) ADDRESS 18830 BCT 2,LOOP 18840 DONE EPILOG 18850 END 18860 *********SUM OF RE. AND IM. MAGS., CMPLX VECTOR, SCASUM, IBM/360 ASM.** 18870 * USAGE STATEMENT 23 MAY 1974* 18880 * SW = SCASUM(N,CX,INCX) WASH. ST. U* 18890 * SW,SCASUM REAL * 4, CX( ) COMPLEX * 8, (,INCX INTEGER * 4 * 18900 *********************************************************************** 18910 SCASUM PROLOG R4 18920 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 18930 SER F0,F0 SET SCASUM = 0. 18940 L R2,0(R2) GET N 18950 LTR R2,R2 SET COND. CODES 18960 BNP DONE EXIT IF N .LE. 0 18970 L R4,0(R4) GET INCX 18980 SLA R4,CSTAR8 COMPUTE INCX*8 AND SET COND. 18990 BM DONE EXIT IF INCX .LT. 0 19000 CNOP 0,8 ALIGN ON DOUBLE WORD. 19010 LOOP LE F2,0(R3) GET RE. AND IM. PARTS 19020 LE F4,4(R3) OF CX( ) IN F2,F4 19030 LPER F2,F2 TAKE ABS. VALUES OF 19040 LPER F4,F4 BOTH PARTS OF CX( ) 19050 AER F0,F2 19060 AER F0,F4 ACCUMULATE SUM OF ABS. VALUES 19070 AR R3,R4 UPDATE CX( ) ADDRESS 19080 BCT R2,LOOP 19090 DONE EPILOG 19100 END 19110 *********SNGL PREC. SCALING, SNGL PREC. VECTOR, SSCAL, IBM/360 ASM.*** 19120 * USAGE STATEMENT 22 MAY 1974* 19130 * CALL SSCAL (N,SA,SX,INCX) WASH. ST. U* 19140 * SA,SX( ) REAL * 4, N,INCX INTEGER * 4 * 19150 *********************************************************************** 19160 SSCAL PROLOG R5 19170 LM R2,R5,0(R1) GET POINTERS TO ARGUMENTS 19180 L R2,0(R2) GET N 19190 LTR R2,R2 SET COND. CODES 19200 BNP DONE EXIT IF N .LE. 0 19210 L R5,0(R5) GET INCX 19220 SLA R5,RSTAR4 COMPUTE INCX*4 AND SET COND. 19230 BM DONE EXIT IF INCX .LT. 0 19240 LE F4,0(R3) GET SA IN F4 19250 CNOP 0,8 ALIGN ON DOUBLE WORD. 19260 LOOP LE F0,0(R4) GET SX( ) IN F0 19270 MER F0,F4 COMPUTE SA*SX( ) 19280 STE F0,0(R4) STORE SA*SX( ) IN SX( ) 19290 AR R4,R5 UPDATE SX( ) ADDRESS 19300 BCT R2,LOOP 19310 DONE EPILOG 19320 END 19330 *********DBLE PREC. SCALING, DBLE PREC. VECTOR, DSCAL, IBM/360 ASM.*** 19340 * USAGE STATEMENT 21 MAY 1974* 19350 * CALL DSCAL (N,DA,DX,INCX) WASH. ST. U* 19360 * DA, DX( ) REAL * 8, N,INCX INTEGER * 4 * 19370 *********************************************************************** 19380 DSCAL PROLOG R5 19390 LM R2,R5,0(R1) GET POINTERS TO ARGUMENTS 19400 L R2,0(R2) GET N 19410 LTR R2,R2 SET COND. CODES 19420 BNP DONE EXIT IF N .LE. 0 19430 L R5,0(R5) GET INCX 19440 SLA R5,RSTAR8 COMPUTE INCX*8 AND SET COND. 19450 BM DONE EXIT IF INCX .LT. 0 19460 LD F4,0(R3) GET DA IN F4 19470 CNOP 0,8 ALIGN ON DOUBLE WORD. 19480 LOOP LD F0,0(R4) GET DX( ) IN F0 19490 MDR F0,F4 COMPUTE DA*DX( ) 19500 STD F0,0(R4) STORE DA*DX( ) IN DX( ) 19510 AR R4,R5 UPDATE DX( ) ADDRESS 19520 BCT R2,LOOP 19530 DONE EPILOG 19540 END 19550 *********COMPLEX SCALING, COMPLEX VECTOR, CSCAL, IBM/360 ASM.********* 19560 * USAGE STATEMENT 21 MAY 1974* 19570 * CALL CSCAL (N,CA,CX,INCX) WASH. ST. U* 19580 * CA,CX( ) COMPLEX * 8, N,INCX INTEGER * 4 * 19590 *********************************************************************** 19600 CSCAL PROLOG R10 19610 LM R2,R5,0(R1) GET POINTERS TO ARGUMENTS 19620 NCHK R10,R2,DONE EXIT IF N .LE. 0 19630 LE F4,0(R3) GET RE. PART OF CA IN F4 19640 LE F6,4(R3) AND IM. PART OF CA IN F6 19650 INCFX R4,R5,R10,R9,CSTAR8,LOOP FIX CX( ) INCREMENT 19660 CNOP 0,8 ALIGN ON DOUBLE WORD. 19670 LOOP LE F0,0(R4) GET RE. PART OF CX( ) IN F0 19680 LE F2,4(R4) GET IM. PART OF CX( ) IN F2 19690 MER F0,F4 19700 MER F2,F6 19710 SER F0,F2 NOW RE. PART OF CA*CX( ) IN F0 19720 LE F2,0(R4) GET RE. PART OF CX( ) IN F2 19730 STE F0,0(R4) STORE RE. PART OF CA*CX( ) 19740 LE F0,4(R4) GET IM. PART OF CX( ) IN F0 19750 MER F0,F4 19760 MER F2,F6 19770 AER F0,F2 NOW IM. PART OF CA*CX( ) IN F0 19780 STE F0,4(R4) STORE IM. PART OF CA*CX( ) 19790 AR R4,R5 UPDATE CX( ) ADDRESS 19800 BCT R2,LOOP 19810 DONE EPILOG 19820 END 19830 *********REAL SCALING, COMPLEX VECTOR, CSSCAL, IBM/360 ASM.************ 19840 * USAGE STATEMENT 21 MAY 1974* 19850 * CALL CSSCAL (N,SA,CX,INCX) WASH. ST. U* 19860 * SA REAL * 4, CX( ) COMPLEX * 8, N,INCX INTEGER * 4 * 19870 *********************************************************************** 19880 CSSCAL PROLOG R10 19890 LM R2,R5,0(R1) GET POINTERS TO ARGUMENTS 19900 NCHK R10,R2,DONE 19910 LE F4,0(R3) GET SA IN F.P. 19920 LER F6,F4 REGS. 4,6 19930 INCFX R4,R5,R10,R9,CSTAR8,LOOP FIX CX( ) INCREMENT 19940 CNOP 0,8 ALIGN ON DOUBLE WORD. 19950 LOOP LE F0,0(R4) GET RE. PART OF CX( ) IN F0 19960 LE F2,4(R4) GET IM. PART OF CX( ) IN F2 19970 MER F0,F4 SCALE 19980 MER F2,F6 COMPONENT 19990 STE F0,0(R4) STORE IN 20000 STE F2,4(R4) CX( ) 20010 AR R4,R5 UPDATE CX( ) ADDRESS 20020 BCT R2,LOOP 20030 DONE EPILOG 20040 END 20050 *********POINT TO MAX. ABS. VAL., SNGL PREC., ISAMAX, IBM/360 ASM****** 20060 * USAGE STATEMENT 21 MAY 1974* 20070 * IMAX = ISAMAX(N,SX,INCX) WASH. ST. U* 20080 * IMAX,ISAMAX,N,INCX INTEGER*4,SX( ) REAL*4 * 20090 *********************************************************************** 20100 ISAMAX PROLOG R5 20110 L R0,=F'0' NOMINAL 0 IN REG. 0 20120 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 20130 L R2,0(R2) GET N 20140 LTR R5,R2 SAVE N AND SET COND. CODES 20150 BNP DONE EXIT IF N .LE. 0 20160 L R4,0(R4) GET INCX 20170 SLA R4,RSTAR4 COMPUTE INCX*4 AND SET COND. 20180 BNP DONE EXIT IF INCX .LE. 0 20190 LR R0,R2 NOMINAL N IN REG. 0 20200 SER F4,F4 SET MAX. KEY TO ZERO 20210 CNOP 0,8 ALIGN ON DOUBLE WORD. 20220 LOOP LE F0,0(R3) GET SX( ) 20230 LPER F0,F0 TAKE ABS. VALUE 20240 CER F0,F4 COMPARE WITH CURRENT KEY 20250 BNH INCLOOP 20260 LR R0,R2 UPDATE POINTER AND 20270 LER F4,F0 CURRENT KEY 20280 INCLOOP AR R3,R4 UPDATE SX( ) ADDRESS 20290 BCT R2,LOOP 20300 SR R0,R5 COMPUTE 20310 BCTR R0,0 CORRECT VALUE 20320 LPR R0,R0 OF POINTER 20330 DONE EPILOG (0) 20340 END 20350 *********POINT TO MAX. ABS. VAL., DBLE PREC., IDAMAX, IBM/360 ASM***** 20360 * USAGE STATEMENT 21 MAY 1974* 20370 * IMAX = IDAMAX(N,DX,INCX) WASH. ST. U* 20380 * IMAX,IDAMAX,N,INCX INTEGER*4, DX( ) REAL*8 * 20390 *********************************************************************** 20400 IDAMAX PROLOG R5 20410 L R0,=F'0' NOMINAL 0 IN REG. 0 20420 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 20430 L R2,0(R2) GET N 20440 LTR R5,R2 SAVE N AND SET COND. CODES 20450 BNP DONE EXIT IF N .LE. 0 20460 L R4,0(R4) GET INCX 20470 SLA R4,RSTAR8 COMPUTE INCX*8 AND SET COND. 20480 BNP DONE EXIT IF INCX .LE. 0 20490 LR R0,R2 NOMINAL N IN REG. 0 20500 SDR F4,F4 SET MAX. KEY TO ZERO 20510 CNOP 0,8 ALIGN ON DOUBLE WORD. 20520 LOOP LD F0,0(R3) GET DX( ) 20530 LPDR F0,F0 TAKE ABS. VALUE 20540 CDR F0,F4 COMPARE WITH CURRENT KEY 20550 BNH INCLOOP 20560 LR R0,R2 UPDATE POINTER AND 20570 LDR F4,F0 CURRENT KEY 20580 INCLOOP AR R3,R4 UPDATE DX( ) ADDRESS 20590 BCT R2,LOOP 20600 SR R0,R5 COMPUTE 20610 BCTR R0,0 CORRECT VALUE 20620 LPR R0,R0 OF POINTER 20630 DONE EPILOG (0) 20640 END 20650 *********POINT TO MAX. SUM OF ABS. VALS., COMPLEX, ICAMAX, IBM/360 ASM* 20660 * USAGE STATEMENT 30 NOV. 1974* 20670 * IMAX = ICAMAX(N,CX,INCX) WASH. ST. U* 20680 * IMAX,ICAMAX,N,INCX INTEGER*4, CX( ) COMPLEX*8 * 20690 *********************************************************************** 20700 ICAMAX PROLOG R10 20710 LM R2,R4,0(R1) GET POINTERS TO ARGUMENTS 20720 SR R0,R0 NOMINAL 0 IN REG. R0 20730 NCHK R10,R2,DONE 20740 LR R5,R2 SAVE N IN R5 20750 LR R0,R5 LOAD STARTING N IN REG. R0 20760 SER F4,F4 SET MAX. KEY TO ZERO 20770 INCFX R3,R4,R10,R9,CSTAR8,LOOP FIX CX( ) INCREMENT 20780 CNOP 0,8 ALIGN ON DOUBLE WORD. 20790 LOOP LE F0,0(R3) GET REAL PART 20800 LPER F0,F0 TAKE ABS. VALUE 20810 LE F2,4(R3) GET IMAG. PART 20820 LPER F2,F2 TAKE ABS. VALUE 20830 AER F0,F2 ADD MAGNITUDES 20840 CER F0,F4 COMPARE WITH CURRENT KEY 20850 BNH INCLOOP 20860 LR R0,R2 UPDATE POINTER AND 20870 LER F4,F0 CURRENT KEY 20880 INCLOOP AR R3,R4 UPDATE CX( ) ADDRESS 20890 BCT R2,LOOP 20900 SR R0,R5 COMPUTE (N-ICAMAX( )+1)-N 20910 BCTR R0,0 CORRECT VALUE (-ICAMAX( ) ) 20920 LPR R0,R0 OF POINTER (ICAMAX( ) ) 20930 DONE EPILOG (0) 20940 END 20950 *DECK,SYSTXT BLA00001 IDENT SYSTEXT BLA00002 SYSTEXT TITLE BLA LIBRARY SYSTEMS TEXT BLA00003 STEXT BLA00004 INFTN SPACE 2,10 BLA00005 ** INFTN NAME,NUM PARAMETER CONVERSION BLA00006 * FOR NON-RUN COMPILER BLA00007 * ENTRY: BLA00008 * NAME = ENTRY/EXIT NAME BLA00009 * NUM = NUMBER OF PARAMETERS BLA00010 * BLA00011 * *F = 0 - COMPASS BLA00012 * = 1 - RUN/MNF BLA00013 * = 2 - FTN BLA00014 * BLA00015 INFTN MACRO NAME,NUM SET UP FOR NON-RUN COMPILER BLA00016 LOCAL M,RETURN BLA00017 .1 IFEQ *F,2 BLA00018 .2 IFNE NUM,0 BLA00019 I DECMIC 0 BLA00020 M MIN 6,NUM BLA00021 .D DUP M BLA00022 I DECMIC 'I'+1 BLA00023 SB'I' X1 BLA00024 SA1 A1+1 BLA00025 .D ENDD BLA00026 .2 IFGE NUM,7 BLA00027 .D DUP NUM-6 BLA00028 I DECMIC 'I'+1 BLA00029 BX6 X1 BLA00030 SA6 NAME-NUM-2+'I' BLA00031 .D ENDD BLA00032 .2 ENDIF BLA00033 SX6 A0 BLA00034 SA6 SETA0 BLA00035 EQ RETURN BLA00036 SETA0 BSS 1 BLA00037 RETURN BSS 0 BLA00038 .1 ENDIF BLA00039 INFTN ENDM BLA00040 OUTFTN SPACE 2,10 BLA00041 ** OUTFTN NAME EXIT FOR NON-RUN COMPILER BLA00042 * BLA00043 * ENTRY: BLA00044 * NAME = ENTRY/EXIT NAME BLA00045 * BLA00046 OUTFTN MACRO NAME EXIT FOR NON RUN COMPILER BLA00047 .1 IFEQ *F,2 BLA00048 SA1 SETA0 BLA00049 SA0 X1 BLA00050 .1 ENDIF BLA00051 EQ NAME BLA00052 OUTFTN ENDM BLA00053 CALL SPACE 2,10 BLA00054 ** CALL SUBR,(ARG,...,ARG) STANDARD RUN/FTN SUBROUTINE CALL.BLA00055 * BLA00056 * ENTRY: *F = 2, GENERATE FTN CALLING SEQUENCE. BLA00057 * ' 2, GENERATE RUN CALLING SEQUENCE. BLA00058 * SUBR = NAME OF THE SUBROUTINE. BLA00059 * ARG = (OPTIONAL), ADDRESS OF ARGUMENT TO BE PASSED. BLA00060 * , THE ADDRESS OF THE LITERAL VALUE BLA00061 * IS PASSED. BLA00062 * = (OMITTED), IF *F' 2 IRUN THE CORRESPONDING B BLA00063 * REGISTER OR ARGUMENT ADDRESS LOCATION IS NOT BLA00064 * SET AND IS ASSUMED TO BE PRESET BY THE USER. BLA00065 * = (OMITTED), IF *F = 2 IFTN THE CORRESPONDING BLA00066 * ARGUMENT ADDRESS LOCATION IS SET TO: BLA00067 * 42/0LNULL,18/*+400000B. BLA00068 * RUN USES: X - 1,6,7. (IF MORE THAN 6 ARGUMENTS SPECIFIED) BLA00069 * B - 1,..,N. (IF N ARGUMENTS SPECIFIED AND N @ 7) BLA00070 * B - ALL. (IF MORE THAN 6 ARGUMENTS SPECIFIED) BLA00071 * A - 1,6,7. (IF MORE THAN 6 ARGUMENTS SPECIFIED) BLA00072 * FTN USES: X - 1. BLA00073 * X - 1,6,7. (IF AN ARGUMENT EXPRESSION CONTAINS BLA00074 * A REGISTER) BLA00075 * B - NONE. BLA00076 * A - 0,1. BLA00077 * A - 0,1,6,7. (IF AN ARGUMENT EXPRESSION CONTAINS BLA00078 * A REGISTER) BLA00079 * CALLS: SUBR. BLA00080 * NOTE: TRACE BACK INFORMATION IS NOT DEFINED UNLESS THE BLA00081 * MICRO 'ENTRY' IS DEFINED. THE MICRO 'ENTRY' IS BLA00082 * DEFINED WITHIN THE BEGIN MACRO. IF NO ARGUMENTS ARE BLA00083 * SPECIFIED THEN THE COMMA AND PARENTHESES MAY BE BLA00084 * OMITTED. BOTH RUN AND FTN STYLE SUBROUTINES DO NOT BLA00085 * PRESERVE REGISTER CONTENTS, EXCEPT FTN SYTLE BLA00086 * SUBROUTINES PRESERVE REGISTER A0. IN THE FTN CALLING BLA00087 * SEQUENCE THE CONTENTS OF THE CALLER/S REGISTER A1 IS BLA00088 * PRESERVED BY ENTERING IT INTO REGISTER A0 BEFORE THE BLA00089 * SUBROUTINE IS ENTERED AND RESETTING REGISTER A1 TO BLA00090 * THE PRESERVED REGISTER A0 ON RETURN FROM THE BLA00091 * SUBROUTINE. BLA00092 * BLA00093 CALL MACRO SUBR,ARGS BLA00094 .1 IFEQ *F,2 BLA00095 FTN=1 SUBR,(ARGS) BLA00096 .1 ELSE BLA00097 RUN=1 SUBR,(ARGS) BLA00098 .1 ENDIF BLA00099 CALL ENDM BLA00100 FTN=1 SPACE 2,10 BLA00101 ** FTN=1 SUBR,ARGS PROCESS FTN FORTRAN ARGUMENTS. BLA00102 * BLA00103 * ENTRY: SUBR = SUBROUTINE NAME. BLA00104 * ARGS = ARGUMENT LIST. BLA00105 * BLA00106 FTN=1 MACRO SUBR,ARGS BLA00107 LOCAL E,I,J,P,ARGLIST BLA00108 I DECMIC 0 BLA00109 SA0 A1 BLA00110 .1 IFC NE,$ARGS$$ BLA00111 J DECMIC 6 BLA00112 USE FTN.ARG BLA00113 ARGLIST BSS 0 BLA00114 IRP ARGS BLA00115 I DECMIC 'I'+1 BLA00116 P ARG=2 (ARGS) BLA00117 .2 IF -REG,'P' BLA00118 IFC EQ,$'P'$$,1 BLA00119 P MICRO 1,,$0LNULL+*+400000B$ BLA00120 CON 'P' BLA00121 .2 ELSE BLA00122 BSS 1 BLA00123 USE * BLA00124 R= X'J','P' BLA00125 SA'J' ARGLIST+'I'-1 BLA00126 USE FTN.ARG BLA00127 J DECMIC 13D-'J' BLA00128 .2 ENDIF BLA00129 IRP BLA00130 CON 0 BLA00131 USE * BLA00132 SA1 ARGLIST BLA00133 .1 ENDIF BLA00134 .1 IF -MIC,ENTRY BLA00135 E MICRO 1,,$0$ BLA00136 .1 ELSE BLA00137 E MICRO 1,,$'ENTRY'-2$ BLA00138 .1 ENDIF BLA00139 + RJ =X#SUBR BLA00140 - VFD 12/0,18/'E' BLA00141 SA1 A0 BLA00142 FTN=1 ENDM BLA00143 RUN=1 SPACE 2,10 BLA00144 ** RUN=1 SUBR,ARGS PROCESS RUN FORTRAN ARGUMENTS. BLA00145 * BLA00146 * ENTRY: SUBR = NAME OF THE SUBROUTINE. BLA00147 * ARGS = LIST OF ARGUMENTS. BLA00148 * BLA00149 RUN=1 MACRO SUBR,ARGS BLA00150 LOCAL E,I,J,P BLA00151 I MICRO 1,,$0$ BLA00152 .1 IFC NE,$ARGS$$ BLA00153 IRP ARGS BLA00154 I DECMIC 'I'+1 BLA00155 P ARG=2 (ARGS) BLA00156 .2 IFLE 'I',6 BLA00157 IFC NE,$'P'$B'I'$,2 BLA00158 IFC NE,$'P'$$,1 BLA00159 SB'I' 'P' BLA00160 .2 ELSE BLA00161 .3 IFEQ 'I',7 BLA00162 SA1 =X#SUBR-1 BLA00163 SB7 X1-6 BLA00164 SB7 A1-B7 BLA00165 .4 IFC NE,$'P'$$ BLA00166 .4 IFC NE,$'P'$X6$ BLA00167 SX6 'P' BLA00168 SA6 B7 BLA00169 .4 ENDIF BLA00170 J DECMIC 6 BLA00171 .3 ELSE BLA00172 .4 IFC EQ,$'P'$$ BLA00173 SB7 B7+1 BLA00174 .4 ELSE BLA00175 J DECMIC 13D-'J' BLA00176 SX'J' 'P' BLA00177 SA'J' B7+1 BLA00178 SB7 A'J' BLA00179 .4 ENDIF BLA00180 .3 ENDIF BLA00181 .2 ENDIF BLA00182 IRP BLA00183 .1 ENDIF BLA00184 .1 IF -MIC,ENTRY BLA00185 E MICRO 1,,$0$ BLA00186 .1 ELSE BLA00187 E MICRO 1,,$'ENTRY'-1$ BLA00188 .1 ENDIF BLA00189 + RJ =X#SUBR BLA00190 - VFD 6/7,6/'I'D,18/'E' BLA00191 RUN=1 ENDM BLA00192 ARG=2 SPACE 2,10 BLA00193 ** MIC ARG=2 ARG1 PROCESS CALL MACRO ARGUMENT. BLA00194 * BLA00195 * ENTRY: MIC = NAME OF THE MICRO TO BE SET TO THE ARGUMENT BLA00196 * STRING ADJUSTED FOR LITERAL VALUES. BLA00197 * ARG1 = ARGUMENT STRING. BLA00198 * BLA00199 MACRO ARG=2,MIC,ARG1 BLA00200 LOCAL C BLA00201 C MICRO 1,1,$ARG1$ BLA00202 .1 IFC NE,$'C'$=$ BLA00203 .1 IFC GE,$'C'$0$ BLA00204 .2 IFC LT,$'C'$+$ BLA00205 MIC MICRO 1,,$=ARG1$ BLA00206 .2 ELSE BLA00207 .1 IFC LT,$'C'$*$ BLA00208 C MICRO 2,,$ARG1$ BLA00209 C ARG=2 'C' BLA00210 C MICRO 1,1,$'C'$ BLA00211 .1 IFC EQ,$'C'$=$ BLA00212 MIC MICRO 1,,$=ARG1$ BLA00213 .1 ELSE BLA00214 MIC MICRO 1,,$ARG1$ BLA00215 .2 ENDIF BLA00216 .1 ENDIF BLA00217 ARG=2 ENDM BLA00218 END BLA00219 *DECK,SDOT BLA00220 IDENT SDOT BLA00221 * BLA00222 *** REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) BLA00223 * BLA00224 * COMPUTED AS SUM FROM I=1 TO N OF SXII *SYII BLA00225 * BLA00226 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA00227 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA00228 * BLA00229 * SIMILAR DEFINITIONS FOR SYII BLA00230 * BLA00231 * SX( ),SY( ) SINGLE PRECISION BLA00232 * N,INCX,INCY INTEGER TYPE BLA00233 * SUM ACCUMULATED IN SINGLE PRECISION BLA00234 * RESULT SDOT IN SINGLE PRECISION BLA00235 * BLA00236 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA00237 * BLA00238 * WRITTEN BY CLEVE B. MOLER BLA00239 * UNIVERSITY OF NEW MEXICO BLA00240 * ALBUQUERQUE, NEW MEXICO BLA00241 C BLA00242 *** 1 JUNE 77 BLA00243 * BLA00244 ENTRY SDOT BLA00245 VFD 42/4HSDOT,18/5 BLA00246 * BLA00247 SDOT DATA 0 BLA00248 INFTN SDOT,5 PROPER LINKAGE (RUN,FTN) MACRO. BLA00249 * BLA00250 MX6 0 (X6)=SDOT=0. BLA00251 SA1 B1 (X1)=N BLA00252 SB7 1 (B7)=1 BLA00253 * BLA00254 SB1 X1 (B1)=N BLA00255 SB1 B1-B7 (B1)=N-1 BLA00256 MI B1,OUT IF (N .LE. 0), QUIT BLA00257 * BLA00258 SA1 B2 (X1)=SX(1) BLA00259 SA3 B3 (X3)=INCX BLA00260 * BLA00261 SA2 B4 (X2)=SY(1) BLA00262 SA4 B5 (X4)=INCY BLA00263 * BLA00264 NZ B1,NGT1 IF (N .GT. 1), LOOP NEEDED BLA00265 RX6 X1*X2 (X6)=SX(1)*SY(1) BLA00266 NX6 X6 (X7)=NORM.(X6) BLA00267 JP OUT BLA00268 NGT1 SX0 -B1 (X0)=-(N-1) BLA00269 * BLA00270 SB3 X3 (B3)=INCX BLA00271 SB4 X4 (B4)=INCY BLA00272 * BLA00273 GE B3,INCXNN IF (INCX .GE. 0) NO ADDRESS FIXUP NEEDED BLA00274 DX3 X0*X3 (X3)=-(N-1)*INCX BLA00275 SB7 A1 (B7)=LOC(SX(1)) BLA00276 SA1 B7+X3 (X1)=SX(1+(1-N)*INCX). (A1)=LOC(X(1)) BLA00277 * BLA00278 INCXNN SA3 A1+B3 (X3)=SX(2) BLA00279 GE B4,INCYNN IF (INCY .GE. 0) NO ADDRESS FIXUP NEEDED BLA00280 DX4 X0*X4 (X4)=-(N-1)*INCY BLA00281 SB7 A2 (B7)=LOC(SY(1)) BLA00282 SA2 B7+X4 (X2)=SY(1+(1-N)*INCY). (A2)=LOC(Y(1)) BLA00283 INCYNN SA4 A2+B4 (X4)=SY(2) BLA00284 SB5 1 (B5)=I=1 BLA00285 SB6 4 (B6)=4 BLA00286 SB1 B1-B6 (B1)=N-5 BLA00287 * BLA00288 MX0 0 (X0)=0. BLA00289 MX5 0 (X5)=0. BLA00290 MX7 0 (X7)=0. BLA00291 GT B5,B1,CLEAN IF (I .GT. N-5) CLEAN-UP LOGIC BLA00292 LOOP RX6 X1*X2 (X6)=SX(I)*SY(I) BLA00293 SA1 A3+B3 (X1)=SX(I+2) BLA00294 SA2 A4+B4 (X2)=SY(I+2) BLA00295 NX5 X5 (X5)=NORM.(X5) BLA00296 RX0 X0+X7 (X0)=SUM1=SUM1+SX(I-1)*SY(I-1) BLA00297 * BLA00298 RX7 X3*X4 (X7)=SX(I+1)*SY(I+1) BLA00299 SA3 A1+B3 (X3)=SX(I+3) BLA00300 SA4 A2+B4 (X4)=SX(I+3) BLA00301 NX0 X0 (X0)=NORM.(X0) BLA00302 RX5 X5+X6 (X5)=SUM2=SUM2+SX(I)*SY(I) BLA00303 * BLA00304 SB5 B5+B6 (B5)=I=I+4. INCREMENT I. BLA00305 RX6 X1*X2 (X6)=SX(I-2)*SY(I-2) BLA00306 SA1 A3+B3 (X1)=SX(I) BLA00307 SA2 A4+B4 (X2)=SY(I) BLA00308 NX5 X5 (X5)=NORM.(X5) BLA00309 RX0 X0+X7 (X0)=SUM1+SX(I-3)*SY(I-3) BLA00310 * BLA00311 RX7 X3*X4 (X7)=SX(I-1)*SY(I-1) BLA00312 SA3 A1+B3 (X3)=SX(I+1) BLA00313 SA4 A2+B4 (S4)=SY(I+1) BLA00314 NX0 X0 (X0)=NORM.(X0) BLA00315 RX5 X5+X6 (X5)=SUM2=SUM2+SX(I-2)*SY(I-2) BLA00316 * BLA00317 LE B5,B1,LOOP IF (I .LE. N-5) CONTINUE LOOP BLA00318 CLEAN SB6 2 (B6)=2 BLA00319 SB1 B1+B6 (B1)=N-3 BLA00320 GT B5,B1,SWAB IF (I .GT. N-3) 3 OR LESS COMPS. REMAIN BLA00321 RX6 X1*X2 (X6)=SX(I)*SY(I) BLA00322 SA1 A3+B3 (X1)=SX(I+2) BLA00323 SA2 A4+B4 (X2)=SY(I+2) BLA00324 NX5 X5 (X5)=NORM.(X5) BLA00325 RX0 X0+X7 (X0)=SUM1=SUM1+SX(I-1)*SY(I-1) BLA00326 * BLA00327 RX7 X3*X4 (X7)=SX(I+1)*SY(I+1) BLA00328 SA3 A1+B3 (X3)=SX(I+3) BLA00329 SA4 A2+B4 (X4)=SY(I+3) BLA00330 RX5 X5+X6 (X5)=SUM2=SUM2+SX(I)*SY(I) BLA00331 NX0 X0 (X0)=NORM.(X0) BLA00332 * BLA00333 SB5 B5+B6 (B5)=I=I+2. INCREMENT I BLA00334 SWAB SB1 B1+B6 (B1)=N-1 BLA00335 GT B5,B1,MOP IF (I .GT. N-1) AT MOST 1 COMP. REMAINS BLA00336 RX6 X1*X2 (X6)=SX(I)*SY(I) BLA00337 NX5 X5 (X5)=NORM.(X5) BLA00338 RX0 X0+X7 (X0)=SUM1=SUM1+SX(I-1)*SY(I-1) BLA00339 * BLA00340 RX7 X3*X4 (X7)=SX(I+1)*SY(I+1) BLA00341 RX5 X5+X6 (X5)=SUM2=SUM2+SX(I)*SY(I) BLA00342 NX0 X0 (X0)=NORM.(X0) BLA00343 SB5 B5+B6 (B5)=I=I+2. INCREMENT I. BLA00344 * BLA00345 MOP SB1 B1+B6 (B1)=N+1 BLA00346 GE B5,B1,WIPE IF (I .GT. N) PUT ODD-EVEN PARTS TOGETHER BLA00347 SA1 A3+B3 (X1)=SX(N) BLA00348 SA2 A4+B4 (X2)=SY(N) BLA00349 RX6 X1*X2 (X6)=SX(N)*SY(N) BLA00350 NX5 X5 (X5)=NORM.(X5) BLA00351 RX5 X5+X6 (X5)=SUM2=SUM2+SX(N)*SY(N) BLA00352 WIPE RX0 X0+X7 SUM EVEN INDEXED PRODUCTS. BLA00353 RX6 X0+X5 (X6)=SUM(SX(I)*SY(I)) BLA00354 NX6 X6 (X6)=NORM.(X6) BLA00355 OUT OUTFTN SDOT RETURN BLA00356 * END SDOT BLA00357 END BLA00358 *DECK,DSDOT BLA00359 IDENT DSDOT BLA00360 * BLA00361 *** DOUBLE FUNCTION DSDOT(N,SX,INCX,SY,INCY) BLA00362 * BLA00363 * COMPUTED AS SUM FROM I=1 TO N OF SXII *SYII BLA00364 * BLA00365 * SXII = SX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA00366 * = SX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA00367 * BLA00368 * SIMILAR DEFINITIONS FOR SYII BLA00369 * BLA00370 * SX( ),SY( ) SINGLE PRECISION BLA00371 * N,INCX,INCY INTEGER TYPE BLA00372 * SUM ACCUMULATED IN DOUBLE PRECISION BLA00373 * RESULT DSDOT IN DOUBLE PRECISION BLA00374 * BLA00375 * WRITTEN BY DAVID R. KINCAID BLA00376 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA00377 *** 1 JUNE 77 BLA00378 * BLA00379 ENTRY DSDOT BLA00380 VFD 42/5HDSDOT,18/5 BLA00381 * BLA00382 DSDOT DATA 0 ENTRY/EXIT BLA00383 INFTN DSDOT,5 BLA00384 SA1 B1 (X1) = N BLA00385 SB7 -1 (B7) = -1 BLA00386 MX6 0 BLA00387 SB1 X1+B7 (B1) = N-1 BLA00388 MX7 0 (X6,X7) = 0 BLA00389 * BLA00390 SA3 B3 (X3) = INCX BLA00391 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA00392 SA5 B5 (X5) = INCY BLA00393 SX1 -B1 (X1) = -(N-1) BLA00394 SB3 X3 (B3) = INCX BLA00395 SB5 X5 (B5) = INCY BLA00396 * BLA00397 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA00398 DX3 X1*X3 LOC(SXI1 ) = LOC(SX) - (N-1)*INCX BLA00399 SB2 X3+B2 (B2) = LOC(SXI1 ) BLA00400 * BLA00401 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA00402 DX5 X1*X5 LOC(SYI1 ) = LOC(SY) - (N-1)*INCY BLA00403 SB4 X5+B4 (B4) = LOC(SYI1 ) BLA00404 * BLA00405 * (I=1) BLA00406 TWO SA1 B2 (X1) = SXI1 BLA00407 SA3 B4 (X3) = SYI1 BLA00408 * BLA00409 FX0 X1*X3 (X0,X2) = SXI1 *SYI1 BLA00410 DX2 X1*X3 BLA00411 * BLA00412 ZR B1,EXIT IF I .EQ. N , GO TO EXIT BLA00413 * BLA00414 * (I = I+1) BLA00415 LOOP SA1 A1+B3 (X1) = SXII BLA00416 SA3 A3+B5 (X3) = SYII BLA00417 * BLA00418 FX4 X6+X0 (X6,X7) = (X6,X7) + (X0,X2) BLA00419 DX5 X6+X0 BLA00420 FX0 X7+X2 BLA00421 NX4 X4 BLA00422 FX2 X0+X5 BLA00423 FX0 X2+X4 BLA00424 NX5 X0 BLA00425 DX2 X2+X4 BLA00426 NX4 X2 BLA00427 FX6 X4+X5 BLA00428 DX7 X4+X5 BLA00429 * BLA00430 FX0 X1*X3 BLA00431 SB1 B1+B7 COUNT TERM BLA00432 DX2 X1*X3 (X0,X2) = SXII *SYII BLA00433 * BLA00434 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA00435 * BLA00436 * (I=N) BLA00437 EXIT FX4 X6+X0 (X6,X7) = (X6,X7) + (X0,X2) BLA00438 DX5 X6+X0 BLA00439 FX0 X7+X2 BLA00440 NX4 X4 BLA00441 FX2 X0+X5 BLA00442 FX0 X2+X4 BLA00443 NX5 X0 BLA00444 DX2 X2+X4 BLA00445 NX4 X2 BLA00446 FX6 X4+X5 BLA00447 DX7 X4+X5 BLA00448 * BLA00449 OUT OUTFTN DSDOT RETURN BLA00450 END BLA00451 *DECK,SDSDOT BLA00452 IDENT SDSDOT BLA00453 * BLA00454 *** REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) BLA00455 * BLA00456 * COMPUTED AS SUM FROM I=1 TO N OF SXII *SYII BLA00457 * BLA00458 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA00459 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA00460 * BLA00461 * SIMILAR DEFINITIONS FOR SYII BLA00462 * BLA00463 * SX( ),SY( ) SINGLE PRECISION BLA00464 * N,INCX,INCY INTEGER TYPE BLA00465 * SUM ACCUMULATED IN DOUBLE PRECISION BLA00466 * RESULT SDSDOT IN SINGLE PRECISION (ROUNDED) BLA00467 * BLA00468 * BLA00469 * WRITTEN BY DAVID R. KINCAID BLA00470 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA00471 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA00472 *** 1 JUNE 77 BLA00473 * BLA00474 ENTRY SDSDOT BLA00475 VFD 42/6HSDSDOT,18/6 BLA00476 * BLA00477 SDSDOT DATA 0 ENTRY/EXIT BLA00478 INFTN SDSDOT,6 BLA00479 * BLA00480 SX6 B2 BLA00481 SA6 ADRSB SAVE ADDRESS OF SB BLA00482 * BLA00483 CALL DSDOT,(B1,B3,B4,B5,B6) BLA00484 * BLA00485 SA4 ADRSB (X4) = SB BLA00486 SA4 X4 BLA00487 FX1 X4+X6 BLA00488 DX2 X4+X6 BLA00489 FX3 X2+X7 BLA00490 FX2 X1+X3 BLA00491 NX0 X2 BLA00492 DX3 X1+X3 BLA00493 NX1 X3 BLA00494 FX2 X0+X1 BLA00495 DX3 X0+X1 BLA00496 RX2 X2+X3 BLA00497 NX6 X2 BLA00498 * BLA00499 OUT OUTFTN SDSDOT RETURN BLA00500 * BLA00501 ADRSB BSS 1 ADDRESS OF SB BLA00502 * BLA00503 END BLA00504 *DECK,DDOT BLA00505 IDENT DDOT BLA00506 * BLA00507 *** DOUBLE FUNCTION DDOT(N,DX,INCX,DY,INCY) BLA00508 * BLA00509 * COMPUTED AS SUM FROM I=1 TO N OF DXII *DYII BLA00510 * BLA00511 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA00512 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA00513 * BLA00514 * SIMILAR DEFINITIONS FOR DYII BLA00515 * BLA00516 * DX( ),DY( ) DOUBLE PRECISION BLA00517 * N,INCX,INCY INTEGER TYPE BLA00518 * SUM ACCUMULATED IN DOUBLE PRECISION BLA00519 * RESULT DDOT IN DOUBLE PRECISION BLA00520 * BLA00521 * WRITTEN BY DAVID R. KINCAID BLA00522 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA00523 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA00524 *** 1 JUNE 77 BLA00525 * BLA00526 ENTRY DDOT BLA00527 VFD 42/4HDDOT,18/5 BLA00528 * BLA00529 DDOT DATA 0 ENTRY/EXIT BLA00530 INFTN DDOT,5 BLA00531 SA1 B1 (X1) = N BLA00532 SB7 -1 (B7) = -1 BLA00533 MX6 0 BLA00534 SB1 X1+B7 (B1) = N-1 BLA00535 MX7 0 (X6,X7) = 0 BLA00536 * BLA00537 SA3 B3 (X3) = INCX BLA00538 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA00539 SA5 B5 (X5) = INCY BLA00540 SX1 -B1 (X1) = -(N-1) BLA00541 LX3 1 INCX = 2*INCX BLA00542 IX5 X5+X5 INCY = 2*INCY BLA00543 SB3 X3 (B3) = INCX BLA00544 SB5 X5 (B5) = INCY BLA00545 * BLA00546 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA00547 DX3 X1*X3 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA00548 SB2 X3+B2 (B2) = LOC(DXI1 ) BLA00549 * BLA00550 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA00551 DX5 X1*X5 LOC(DYI1 ) = LOC(DY) - (N-1)*INCY BLA00552 SB4 X5+B4 (B4) = LOC(DYI1 ) BLA00553 * BLA00554 * (I=1) BLA00555 TWO SA1 B2 BLA00556 SA3 B4 BLA00557 SA2 B2-B7 (X1,X2) = DXI1 BLA00558 SA4 B4-B7 (X3,X4) = DYI1 BLA00559 * BLA00560 FX5 X2*X3 (X0,X2) = DXI1 *DYI1 BLA00561 FX0 X1*X4 BLA00562 FX5 X0+X5 BLA00563 FX4 X1*X3 BLA00564 DX0 X1*X3 BLA00565 FX5 X0+X5 BLA00566 FX0 X4+X5 BLA00567 DX2 X4+X5 BLA00568 * BLA00569 ZR B1,EXIT IF I .EQ. N , GO TO EXIT BLA00570 * BLA00571 * (I = I+1) BLA00572 LOOP SA1 A1+B3 BLA00573 SA3 A3+B5 BLA00574 * BLA00575 FX4 X6+X0 (X6,X7) = (X6,X7) + (X0,X2) BLA00576 DX5 X6+X0 BLA00577 FX0 X7+X2 BLA00578 NX4 X4 BLA00579 FX2 X0+X5 BLA00580 FX0 X2+X4 BLA00581 NX5 X0 BLA00582 DX2 X2+X4 BLA00583 NX4 X2 BLA00584 FX6 X4+X5 BLA00585 DX7 X4+X5 BLA00586 * BLA00587 SB1 B1+B7 COUNT TERM BLA00588 SA2 A1-B7 (X1,X2) = DXII BLA00589 SA4 A3-B7 (X3,X4) = DYII BLA00590 * BLA00591 FX5 X2*X3 (X0,X2) = DXII *DYII BLA00592 FX0 X1*X4 BLA00593 FX5 X0+X5 BLA00594 FX4 X1*X3 BLA00595 DX0 X1*X3 BLA00596 FX5 X0+X5 BLA00597 FX0 X4+X5 BLA00598 DX2 X4+X5 BLA00599 * BLA00600 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA00601 * BLA00602 * (I=N) BLA00603 EXIT FX4 X6+X0 (X6,X7) = (X6,X7) + (X0,X2) BLA00604 DX5 X6+X0 BLA00605 FX0 X7+X2 BLA00606 NX4 X4 BLA00607 FX2 X0+X5 BLA00608 FX0 X2+X4 BLA00609 NX5 X0 BLA00610 DX2 X2+X4 BLA00611 NX4 X2 BLA00612 FX6 X4+X5 BLA00613 DX7 X4+X5 BLA00614 * BLA00615 OUT OUTFTN DDOT RETURN BLA00616 END BLA00617 *DECK,DQDOTI BLA00618 IDENT DQDOTI BLA00619 ENTRY DQDOTI BLA00620 ARG7 BSS 1 BLA00621 VFD 42/6HDQDOTI,18/7 BLA00622 DQDOTI DATA 0 BLA00623 EQ DQDOTI BLA00624 END BLA00625 *DECK,DQDOTA BLA00626 IDENT DQDOTA BLA00627 ENTRY DQDOTA BLA00628 ARG7 BSS 1 BLA00629 VFD 42/6HDQDOTA,18/7 BLA00630 DQDOTA DATA 0 BLA00631 EQ DQDOTA BLA00632 END BLA00633 *DECK,CDOTC BLA00634 IDENT CDOTC BLA00635 * BLA00636 *** COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) BLA00637 * BLA00638 * COMPUTED AS SUM FROM I=1 TO N OF CONJ(CXII )*CYII BLA00639 * BLA00640 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA00641 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA00642 * BLA00643 * SIMILAR DEFINITIONS FOR CYII BLA00644 * BLA00645 * CX( ),CY( ) COMPLEX TYPE BLA00646 * N,INCX,INCY INTEGER TYPE BLA00647 * SUM ACCUMULATED IN SINGLE PRECISION BLA00648 * RESULT CDOTC IN COMPLEX TYPE BLA00649 * BLA00650 * ROUNDED ARITHMETRIC INSTRUCTIONS ARE USED BLA00651 * BLA00652 * WRITTEN BY DAVID R. KINCAID BLA00653 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA00654 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA00655 *** 1 JUNE 77 BLA00656 * BLA00657 ENTRY CDOTC BLA00658 VFD 42/5HCDOTC,18/5 BLA00659 * BLA00660 CDOTC DATA 0 ENTRY/EXIT BLA00661 INFTN CDOTC,5 BLA00662 SA1 B1 (X1) = N BLA00663 SB7 -1 (B7) = -1 BLA00664 MX6 0 BLA00665 SB1 X1+B7 (B1) = N-1 BLA00666 MX7 0 (X6,X7) = 0 BLA00667 * BLA00668 SA3 B3 (X3) = INCX BLA00669 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA00670 SA5 B5 (X5) = INCY BLA00671 SX1 -B1 (X1) = -(N-1) BLA00672 LX3 1 INCX = 2*INCX BLA00673 IX5 X5+X5 INCY = 2*INCY BLA00674 SB3 X3 (B3) = INCX BLA00675 SB5 X5 (B5) = INCY BLA00676 * BLA00677 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA00678 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA00679 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA00680 * BLA00681 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA00682 DX5 X1*X5 LOC(CYI1 ) = LOC(CY) - (N-1)*INCY BLA00683 SB4 X5+B4 (B4) = LOC(CYI1 ) BLA00684 * BLA00685 * (I=1) BLA00686 TWO SA1 B2 (X1) = REAL(CXI1 ) BLA00687 SA2 B4 (X2) = REAL(CYI1 ) BLA00688 * BLA00689 RX0 X1*X2 (X0) = REAL(CXI1 )*REAL(CYI1 ) BLA00690 * BLA00691 RX5 X6+X0 (X6) = (X6) + (X0) BLA00692 NX6 X5 BLA00693 * BLA00694 SA4 A2-B7 (X4) = IMAG(CYI1 ) BLA00695 * BLA00696 RX0 X1*X4 (X0) = REAL(CXI1 )*IMAG(CYI1 ) BLA00697 * BLA00698 RX5 X7+X0 (X7) = (X7) + (X0) BLA00699 NX7 X5 BLA00700 * BLA00701 SA3 A1-B7 (X3) = IMAG(CXI1 ) BLA00702 * BLA00703 RX0 X3*X4 (X0) = IMAG(CXI1 )*IMAG(CYI1 ) BLA00704 * BLA00705 RX5 X6+X0 (X6) = (X6) + (X0) BLA00706 NX6 X5 = REAL(CONJ(CXI1 )*CYI1 ) BLA00707 * BLA00708 RX0 X3*X2 (X0) = IMAG(CXI1 )*REAL(CYI1 ) BLA00709 * BLA00710 RX5 X7-X0 (X7) = (X7) - (X0) BLA00711 NX7 X5 = IMAG(CONJ(CXI1 )*CYI1 ) BLA00712 * BLA00713 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA00714 * BLA00715 * (I = I+1) BLA00716 LOOP SA1 A1+B3 (X1) = REAL(CXII ) BLA00717 SA2 A2+B5 (X2) = REAL(CYII ) BLA00718 * BLA00719 RX0 X1*X2 (X0) = REAL(CXII )*REAL(CYII ) BLA00720 * BLA00721 RX5 X6+X0 (X6) = (X6) + (X0) BLA00722 NX6 X5 BLA00723 * BLA00724 SA4 A2-B7 (X4) = IMAG(CYII ) BLA00725 * BLA00726 RX0 X1*X4 (X0) = REAL(CXII )*IMAG(CYII ) BLA00727 * BLA00728 RX5 X7+X0 (X7) = (X7) + (X0) BLA00729 NX7 X5 BLA00730 * BLA00731 SA3 A1-B7 (X3) = IMAG(CXII ) BLA00732 * BLA00733 RX0 X3*X4 (X0) = IMAG(CXII )*IMAG(CYII ) BLA00734 * BLA00735 RX5 X6+X0 (X6) = (X6) + (X0) BLA00736 NX6 X5 = REAL(CONJ(CXII )*CYII ) BLA00737 * BLA00738 RX0 X3*X2 (X0) = IMAG(CXII )*REAL(CYII ) BLA00739 SB1 B1+B7 COUNT TERM BLA00740 * BLA00741 RX5 X7-X0 (X7) = (X7) - (X0) BLA00742 NX7 X5 = IMAG(CONJ(CXII )*CYII ) BLA00743 * BLA00744 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA00745 * BLA00746 OUT OUTFTN CDOTC RETURN BLA00747 END BLA00748 *DECK,CDOTU BLA00749 IDENT CDOTU BLA00750 * BLA00751 *** COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) BLA00752 * BLA00753 * COMPUTED AS SUM FROM I=1 TO N OF CXII *CYII BLA00754 * BLA00755 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA00756 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA00757 * BLA00758 * SIMILAR DEFINITIONS FOR CYII BLA00759 * BLA00760 * CX( ),CY( ) COMPLEX TYPE BLA00761 * N,INCX,INCY INTEGER TYPE BLA00762 * SUM ACCUMULATED IN SINGLE PRECISION BLA00763 * RESULT CDOTU IN COMPLEX TYPE BLA00764 * BLA00765 * ROUNDED ARITHMETRIC INSTRUCTIONS ARE USED BLA00766 * BLA00767 * WRITTEN BY DAVID R. KINCAID BLA00768 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA00769 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA00770 *** 15 OCT 1974 BLA00771 *** 1 JUNE 77 BLA00772 * BLA00773 ENTRY CDOTU BLA00774 VFD 42/5HCDOTU,18/5 BLA00775 * BLA00776 CDOTU DATA 0 ENTRY/EXIT BLA00777 INFTN CDOTU,5 BLA00778 SA1 B1 (X1) = N BLA00779 SB7 -1 (B7) = -1 BLA00780 MX6 0 BLA00781 SB1 X1+B7 (B1) = N-1 BLA00782 MX7 0 (X6,X7) = 0 BLA00783 * BLA00784 SA3 B3 (X3) = INCX BLA00785 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA00786 SA5 B5 (X5) = INCY BLA00787 SX1 -B1 (X1) = -(N-1) BLA00788 LX3 1 INCX = 2*INCX BLA00789 IX5 X5+X5 INCY = 2*INCY BLA00790 SB3 X3 (B3) = INCX BLA00791 SB5 X5 (B5) = INCY BLA00792 * BLA00793 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA00794 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA00795 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA00796 * BLA00797 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA00798 DX5 X1*X5 LOC(CYI1 ) = LOC(CY) - (N-1)*INCY BLA00799 SB4 X5+B4 (B4) = LOC(CYI1 ) BLA00800 * BLA00801 * (I=1) BLA00802 TWO SA1 B2 (X1) = REAL(CXI1 ) BLA00803 SA2 B4 (X2) = REAL(CYI1 ) BLA00804 * BLA00805 RX0 X1*X2 (X0) = REAL(CXI1 )*REAL(CYI1 ) BLA00806 * BLA00807 RX5 X6+X0 (X6) = (X6) + (X0) BLA00808 NX6 X5 BLA00809 * BLA00810 SA4 A2-B7 (X4) = IMAG(CYI1 ) BLA00811 * BLA00812 RX0 X1*X4 (X0) = REAL(CXI1 )*IMAG(CYI1 ) BLA00813 * BLA00814 RX5 X7+X0 (X7) = (X7) + (X0) BLA00815 NX7 X5 BLA00816 * BLA00817 SA3 A1-B7 (X3) = IMAG(CXI1 ) BLA00818 * BLA00819 RX0 X3*X4 (X0) = IMAG(CXI1 )*IMAG(CYI1 ) BLA00820 * BLA00821 RX5 X6-X0 (X6) = (X6) - (X0) BLA00822 NX6 X5 = REAL(CXI1 *CYI1 ) BLA00823 * BLA00824 RX0 X3*X2 (X0) = IMAG(CXI1 )*REAL(CYI1 ) BLA00825 * BLA00826 RX5 X7+X0 (X7) = (X7) + (X0) BLA00827 NX7 X5 = IMAG(CXI1 *CYI1 ) BLA00828 * BLA00829 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA00830 * BLA00831 * (I = I+1) BLA00832 LOOP SA1 A1+B3 (X1) = REAL(CXII ) BLA00833 SA2 A2+B5 (X2) = REAL(CYII ) BLA00834 * BLA00835 RX0 X1*X2 (X0) = REAL(CXII )*REAL(CYII ) BLA00836 * BLA00837 RX5 X6+X0 (X6) = (X6) + (X0) BLA00838 NX6 X5 BLA00839 * BLA00840 SA4 A2-B7 (X4) = IMAG(CYII ) BLA00841 * BLA00842 RX0 X1*X4 (X0) = REAL(CXII )*IMAG(CYII ) BLA00843 * BLA00844 RX5 X7+X0 (X7) = (X7) + (X0) BLA00845 NX7 X5 BLA00846 * BLA00847 SA3 A1-B7 (X3) = IMAG(CXII ) BLA00848 * BLA00849 RX0 X3*X4 (X0) = IMAG(CXII )*IMAG(CYII ) BLA00850 * BLA00851 RX5 X6-X0 (X6) = (X6) - (X0) BLA00852 NX6 X5 = REAL(CXII *CYII ) BLA00853 * BLA00854 RX0 X3*X2 (X0) = IMAG(CXII )*REAL(CYII ) BLA00855 SB1 B1+B7 COUNT TERM BLA00856 * BLA00857 RX5 X7+X0 (X7) = (X7) + (X0) BLA00858 NX7 X5 = IMAG(CXII *CYII ) BLA00859 * BLA00860 NZ B1,LOOP IF I .NE. 0 , GO TO LOOP BLA00861 * BLA00862 OUT OUTFTN CDOTU RETURN BLA00863 END BLA00864 *DECK,CZDOTC BLA00865 IDENT CZDOTC BLA00866 * BLA00867 *** COMPLEX FUNCTION CZDOTC(N,CX,INCX,CY,INCY) BLA00868 * BLA00869 * COMPUTED AS SUM FROM I=1 TO N OF CONJ(CXII )*CYII BLA00870 * BLA00871 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA00872 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA00873 * BLA00874 * SIMILAR DEFINITIONS FOR CYII BLA00875 * BLA00876 * CX( ),CY( ) COMPLEX TYPE BLA00877 * N,INCX,INCY INTEGER TYPE BLA00878 * SUM ACCUMULATED IN DOUBLE PRECISION BLA00879 * RESULT CZDOTC IN COMPLEX TYPE (ROUNDED) BLA00880 * BLA00881 * WRITTEN BY DAVID R. KINCAID BLA00882 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA00883 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA00884 *** 1 JUNE 77 BLA00885 * BLA00886 ENTRY CZDOTC BLA00887 VFD 42/6HCZDOTC,18/6 BLA00888 * BLA00889 CZDOTC DATA 0 ENTRY/EXIT BLA00890 INFTN CZDOTC,6 BLA00891 SA1 B1 (X1) = N BLA00892 MX4 0 BLA00893 SB7 -1 (B7) = -1 BLA00894 SB1 X1 (B1) = N (I=0) BLA00895 MX5 0 BLA00896 SB6 X1+B7 (B6) = N-1 BLA00897 BX6 X4 BLA00898 BX7 X5 (X7,X5) = (X6,X4) = (0,0) BLA00899 * BLA00900 SA3 B3 (X3) = INCX BLA00901 NG B6,OUT IF N .LE. 0 , GO TO OUT BLA00902 SA2 B5 (X2) = INCY BLA00903 SX1 -B6 (X1) = -(N-1) BLA00904 LX3 1 INCX = 2*INCY BLA00905 IX2 X2+X2 INCY = 2*INCY BLA00906 SB3 X3 (B3) = INCX BLA00907 SB5 X2 (B5) = INCY BLA00908 * BLA00909 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA00910 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA00911 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA00912 * BLA00913 ONE GT B5,LOOP IF INCY .GT. 0 , GO TO LOOP BLA00914 DX2 X1*X2 LOC(CYI1 ) = LOC(CY) - (N-1)*INCY BLA00915 SB4 X2+B4 (B4) = LOC(CXI1 ) BLA00916 * BLA00917 * (I = I+1) BLA00918 LOOP SA1 B2 (X1) = REAL(CXII ) BLA00919 SB2 B2+B3 BLA00920 SA2 B4 (X2) = REAL(CYII ) BLA00921 SB4 B4+B5 BLA00922 * BLA00923 FX0 X1*X2 (X0,X1) = REAL(CXII )*REAL(CYII ) BLA00924 DX1 X1*X2 BLA00925 * BLA00926 FX2 X6+X0 (X6,X4) = (X6,X4) + (X0,X1) BLA00927 DX3 X6+X0 BLA00928 FX0 X4+X1 BLA00929 NX2 X2 BLA00930 FX1 X0+X3 BLA00931 FX0 X1+X2 BLA00932 NX3 X0 BLA00933 DX1 X1+X2 BLA00934 NX2 X1 BLA00935 FX6 X2+X3 BLA00936 DX4 X2+X3 BLA00937 * BLA00938 SA1 A1-B7 (X1) = IMAG(CXII ) BLA00939 SA2 A2-B7 (X2) = IMAG(CYII ) BLA00940 * BLA00941 FX0 X1*X2 (X0,X1) = IMAG(CXII )*IMAG(CYII ) BLA00942 DX1 X1*X2 BLA00943 * BLA00944 FX2 X6+X0 (X6,X4) = (X6,X4) + (X0,X1) BLA00945 DX3 X6+X0 BLA00946 FX0 X4+X1 = REAL(CONJ(CXII )*CYII ) BLA00947 NX2 X2 BLA00948 FX1 X0+X3 BLA00949 FX0 X1+X2 BLA00950 NX3 X0 BLA00951 DX1 X1+X2 BLA00952 NX2 X1 BLA00953 FX6 X2+X3 BLA00954 DX4 X2+X3 BLA00955 * BLA00956 SA1 A1 (X1) = IMAG(CXII ) BLA00957 SA2 A2+B7 (X2) = REAL(CYII ) BLA00958 * BLA00959 FX0 X1*X2 (X0,X1) = IMAG(CXII )*REAL(CYII ) BLA00960 DX1 X1*X2 BLA00961 * BLA00962 FX2 X7-X0 (X7,X5) = (X7,X5) - (X0,X1) BLA00963 DX3 X7-X0 BLA00964 FX0 X5-X1 BLA00965 NX2 X2 BLA00966 FX1 X0+X3 BLA00967 FX0 X1+X2 BLA00968 NX3 X0 BLA00969 DX1 X1+X2 BLA00970 NX2 X1 BLA00971 FX7 X2+X3 BLA00972 DX5 X2+X3 BLA00973 * BLA00974 SA1 A1+B7 (X1) = REAL(CXII ) BLA00975 SA2 A2-B7 (X2) = IMAG(CYII ) BLA00976 * BLA00977 FX0 X1*X2 (X0,X1) = REAL(CXII )*IMAG(CYII ) BLA00978 DX1 X1*X2 BLA00979 SB1 B1+B7 COUNT TERM BLA00980 * BLA00981 FX2 X7+X0 (X7,X5) = (X7,X5) + (X0,X1) BLA00982 DX3 X7+X0 BLA00983 FX0 X5+X1 = IMAG(CONJ(CXII )*CYII ) BLA00984 NX2 X2 BLA00985 FX1 X0+X3 BLA00986 FX0 X1+X2 BLA00987 NX3 X0 BLA00988 DX1 X1+X2 BLA00989 NX2 X1 BLA00990 FX7 X2+X3 BLA00991 DX5 X2+X3 BLA00992 * BLA00993 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA00994 * BLA00995 RX0 X6+X4 ROUNDED FINAL RESULT BLA00996 RX1 X7+X5 BLA00997 NX6 X0 BLA00998 NX7 X1 BLA00999 * BLA01000 OUT OUTFTN CZDOTC RETURN BLA01001 END BLA01002 *DECK,CZDOTU BLA01003 IDENT CZDOTU BLA01004 * BLA01005 *** COMPLEX FUNCTION CZDOTU(N,CX,INCX,CY,INCY) BLA01006 * BLA01007 * COMPUTED AS SUM FROM I=1 TO N OF CXII *CYII BLA01008 * BLA01009 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA01010 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA01011 * BLA01012 * SIMILAR DEFINITIONS FOR CYII BLA01013 * BLA01014 * CX( ),CY( ) COMPLEX TYPE BLA01015 * N,INCX,INCY INTEGER TYPE BLA01016 * SUM ACCUMULATED IN DOUBLE PRECISION BLA01017 * RESULT CZDOTU IN COMPLEX TYPE (ROUNDED) BLA01018 * BLA01019 * WRITTEN BY DAVID R. KINCAID BLA01020 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA01021 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA01022 *** 1 JUNE 77 BLA01023 * BLA01024 ENTRY CZDOTU BLA01025 VFD 42/6HCZDOTU,18/5 BLA01026 * BLA01027 CZDOTU DATA 0 ENTRY/EXIT BLA01028 INFTN CZDOTU,5 BLA01029 SA1 B1 (X1) = N BLA01030 MX4 0 BLA01031 SB7 -1 (B7) = -1 BLA01032 SB1 X1 (B1) = N (I=0) BLA01033 MX5 0 BLA01034 SB6 X1+B7 (B6) = N-1 BLA01035 BX6 X4 BLA01036 BX7 X5 (X7,X5) = (X6,X4) = (0,0) BLA01037 * BLA01038 SA3 B3 (X3) = INCX BLA01039 NG B6,OUT IF N .LE. 0 , GO TO OUT BLA01040 SA2 B5 (X2) = INCY BLA01041 SX1 -B6 (X1) = -(N-1) BLA01042 LX3 1 INCX = 2*INCY BLA01043 IX2 X2+X2 INCY = 2*INCY BLA01044 SB3 X3 (B3) = INCX BLA01045 SB5 X2 (B5) = INCY BLA01046 * BLA01047 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA01048 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA01049 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA01050 * BLA01051 ONE GT B5,LOOP IF INCY .GT. 0 , GO TO LOOP BLA01052 DX2 X1*X2 LOC(CYI1 ) = LOC(CY) - (N-1)*INCY BLA01053 SB4 X2+B4 (B4) = LOC(CXI1 ) BLA01054 * BLA01055 * (I = I+1) BLA01056 LOOP SA1 B2 (X1) = REAL(CXII ) BLA01057 SB2 B2+B3 BLA01058 SA2 B4 (X2) = REAL(CYII ) BLA01059 SB4 B4+B5 BLA01060 * BLA01061 FX0 X1*X2 (X0,X1) = REAL(CXII )*REAL(CYII ) BLA01062 DX1 X1*X2 BLA01063 * BLA01064 FX2 X6+X0 (X6,X4) = (X6,X4) + (X0,X1) BLA01065 DX3 X6+X0 BLA01066 FX0 X4+X1 BLA01067 NX2 X2 BLA01068 FX1 X0+X3 BLA01069 FX0 X1+X2 BLA01070 NX3 X0 BLA01071 DX1 X1+X2 BLA01072 NX2 X1 BLA01073 FX6 X2+X3 BLA01074 DX4 X2+X3 BLA01075 * BLA01076 SA1 A1-B7 (X1) = IMAG(CXII ) BLA01077 SA2 A2-B7 (X2) = IMAG(CYII ) BLA01078 * BLA01079 FX0 X1*X2 (X0,X1) = IMAG(CXII )*IMAG(CYII ) BLA01080 DX1 X1*X2 BLA01081 * BLA01082 FX2 X6-X0 (X6,X4) = (X6,X4) - (X0,X1) BLA01083 DX3 X6-X0 BLA01084 FX0 X4-X1 = REAL(CXII *CYII ) BLA01085 NX2 X2 BLA01086 FX1 X0+X3 BLA01087 FX0 X1+X2 BLA01088 NX3 X0 BLA01089 DX1 X1+X2 BLA01090 NX2 X1 BLA01091 FX6 X2+X3 BLA01092 DX4 X2+X3 BLA01093 * BLA01094 SA1 A1 (X1) = IMAG(CXII ) BLA01095 SA2 A2+B7 (X2) = REAL(CYII ) BLA01096 * BLA01097 FX0 X1*X2 (X0,X1) = IMAG(CXII )*REAL(CYII ) BLA01098 DX1 X1*X2 BLA01099 * BLA01100 FX2 X7+X0 (X7,X5) = (X7,X5) + (X0,X1) BLA01101 DX3 X7+X0 BLA01102 FX0 X5+X1 BLA01103 NX2 X2 BLA01104 FX1 X0+X3 BLA01105 FX0 X1+X2 BLA01106 NX3 X0 BLA01107 DX1 X1+X2 BLA01108 NX2 X1 BLA01109 FX7 X2+X3 BLA01110 DX5 X2+X3 BLA01111 * BLA01112 SA1 A1+B7 (X1) = REAL(CXII ) BLA01113 SA2 A2-B7 (X2) = IMAG(CYII ) BLA01114 * BLA01115 FX0 X1*X2 (X0,X1) = REAL(CXII )*IMAG(CYII ) BLA01116 DX1 X1*X2 BLA01117 SB1 B1+B7 COUNT TERM BLA01118 * BLA01119 FX2 X7+X0 (X7,X5) = (X7,X5) + (X0,X1) BLA01120 DX3 X7+X0 BLA01121 FX0 X5+X1 = IMAG(CXII *CYII ) BLA01122 NX2 X2 BLA01123 FX1 X0+X3 BLA01124 FX0 X1+X2 BLA01125 NX3 X0 BLA01126 DX1 X1+X2 BLA01127 NX2 X1 BLA01128 FX7 X2+X3 BLA01129 DX5 X2+X3 BLA01130 * BLA01131 NZ B1,LOOP IF I .NE. 0 , GO TO LOOP BLA01132 * BLA01133 RX0 X6+X4 ROUNDED FINAL RESULT BLA01134 RX1 X7+X5 BLA01135 NX6 X0 BLA01136 NX7 X1 BLA01137 * BLA01138 OUT OUTFTN CZDOTU RETURN BLA01139 END BLA01140 *DECK,SAXPY BLA01141 IDENT SAXPY BLA01142 * BLA01143 *** USE WITH FORTRAN STATEMENT BLA01144 * BLA01145 * CALL SAXPY(N,SA,SX,INCX,SY,INCY) BLA01146 * BLA01147 * SA*SXII + SYII REPLACES SYII FOR I=1,N BLA01148 * BLA01149 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA01150 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA01151 * BLA01152 * SIMILAR DEFINITIONS FOR SYII BLA01153 * BLA01154 * SX( ),SY( ) SINGLE PRECISION BLA01155 * N,INCX,INCY INTEGER TYPE BLA01156 * SA SINGLE PRECISION BLA01157 * BLA01158 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA01159 * BLA01160 * WRITTEN BY RICHARD J. HANSON BLA01161 * SANDIA LABORATORIES BLA01162 * ALBUQUERQUE, NEW MEXICO BLA01163 *** 1 JUNE 77 BLA01164 * BLA01165 ENTRY SAXPY BLA01166 VFD 42/5HSAXPY,18/6 BLA01167 * BLA01168 SAXPY DATA 0 BLA01169 INFTN SAXPY,6 PROPER LINKAGE (RUN,FTN) MACRO. BLA01170 SA1 B1 (X1)=N BLA01171 SB7 1 (B7)=1 BLA01172 * BLA01173 SB1 X1 (B1)=N BLA01174 SB1 B1-B7 (B1)=N-1 BLA01175 MI B1,OUT IF(N .LE. 0), QUIT. BLA01176 * BLA01177 SA5 B2 (X5)=SA BLA01178 ZR X5,OUT IF(SA .EQ. 0.), QUIT BLA01179 * BLA01180 SA1 B3 (X1)=SX(1) BLA01181 SA2 B5 (X2)=SY(1) BLA01182 SA3 B4 (X3)=INCX BLA01183 * BLA01184 SA4 B6 (X4)=INCY BLA01185 * BLA01186 NZ B1,NGT1 IF (N .GT. 1), LOOP NEEDED BLA01187 RX6 X1*X5 (X6)=SA*SX(1) BLA01188 RX6 X2+X6 (X6)=SA*SX(1)+SY(1) BLA01189 NX6 X6 (X6)=NORM.(X6) BLA01190 SA6 A2 SY(1)=(X6) BLA01191 JP OUT QUIT BLA01192 NGT1 SX0 -B1 (X0)=-(N-1) BLA01193 * BLA01194 SB3 X3 (B3)=INCX BLA01195 SB4 X4 (B4)=INCY BLA01196 * BLA01197 GE B3,INCXNN IF (INCX .GE. 0) NO ADDRESS FIXUP NEEDED BLA01198 DX3 X0*X3 COMPUTE -(N-1)*INCX BLA01199 SB7 A1 (B7)=LOC(SX(1)) BLA01200 SA1 B7+X3 (X1)=SX(1+(1-N)*INCX). (A1)=LOC(X(1)) BLA01201 * BLA01202 INCXNN SA3 A1+B3 (X3)=SX(2) BLA01203 GE B4,INCYNN IF (INCY .GE. 0) NO ADDRESS FIXUP NEEDED BLA01204 DX4 X0*X4 COMPUTE -(N-1)*INCY BLA01205 SB7 A2 (B7)=LOC(SY(1)) BLA01206 SA2 B7+X4 (X2)=SY(1+(1-N)*INCY). (A2)=LOC(Y(1)) BLA01207 * BLA01208 INCYNN SA4 A2+B4 (X4)=SY(2) BLA01209 SB5 1 (B5)=I=1 BLA01210 SB6 4 (B6)=4 BLA01211 SA0 A2-B4 (A0)=LOC(Y(1))-INCY BLA01212 SB1 B1-B6 (B1)=N-5 BLA01213 * BLA01214 GT B5,B1,CLEAN IF (I .GT. N-5) CLEAN-UP LOGIC BLA01215 LOOP RX6 X1*X5 (X6)=SA*SX(I) BLA01216 SA1 A3+B3 (X1)=SX(I+2) BLA01217 RX7 X3*X5 (X7)=SA*SX(I+1) BLA01218 NO 0 DEAD BLA01219 SA3 A1+B3 (X3)=SX(I+3) BLA01220 NO 0 DEAD BLA01221 RX6 X2+X6 (X6)=SA*SX(I)+SY(I) BLA01222 RX7 X4+X7 (X7)=SA*SX(I+1)+SY(I+1) BLA01223 SA2 A4+B4 (X2)=SY(I+2) BLA01224 RX0 X1*X5 (X0)=SA*SX(I+2) BLA01225 NX6 X6 (X6)=NORM.(X6) BLA01226 SA4 A2+B4 (X4)=SY(I+3) BLA01227 NX7 X7 (X7)=NORM.(X7) BLA01228 RX3 X3*X5 (X3)=SA*SX(I+3) BLA01229 * BLA01230 SA1 A3+B3 (X1)=SX(I+4). NEXT ITER. BLA01231 SA6 A0+B4 SY(I)=(X6) BLA01232 RX6 X0+X2 (X6)=SA*SX(I+2)+SY(I+2) BLA01233 SA2 A4+B4 (X2)=SY(I+4). NEXT ITER. BLA01234 SA7 A6+B4 SY(I+1)=(X7) BLA01235 RX7 X3+X4 (X7)=SA*SX(I+3)+SY(I+3) BLA01236 SA3 A1+B3 (X3)=SX(I+5). NEXT ITER. BLA01237 NX6 X6 (X6)=NORM.(X6) BLA01238 SA4 A2+B4 (X4)=SY(I+5). NEXT ITER. BLA01239 NX7 X7 (X7)=NORM.(X7) BLA01240 SA6 A7+B4 SY(I+2)=(X6) BLA01241 SB5 B5+B6 I=I+4. INCREMENT I BLA01242 SA7 A6+B4 SY(I-1)=(X7) BLA01243 SA0 A7 ADVANCE ADDRESS OF SY(I+4) FOR NEXT ITER. BLA01244 LE B5,B1,LOOP IF(I.LE.N-5) CONTINUE LOOP BLA01245 * BLA01246 CLEAN SB6 2 (B6)=2 BLA01247 SB1 B1+B6 (B1)=N-3 BLA01248 GT B5,B1,SWAB IF (I .GT. N-3) 3 OR LESS COMPS. REMAIN BLA01249 RX6 X1*X5 (X6)=SA*SX(I) BLA01250 SA1 A3+B3 (X1)=SX(I+2) BLA01251 RX7 X3*X5 (X7)=SA*SX(I+1) BLA01252 SA3 A1+B3 (X3)=SX(I+3) BLA01253 RX6 X2+X6 (X6)=SA*SX(I)+SY(I) BLA01254 RX7 X4+X7 (X7)=SA*SX(I+1)+SY(I+1) BLA01255 SA2 A4+B4 (X2)=SY(I+2) BLA01256 NX6 X6 (X6)=NORM.(X6) BLA01257 SA4 A2+B4 (X4)=SY(I+3) BLA01258 NX7 X7 (X7)=NORM.(X7) BLA01259 * BLA01260 SB5 B5+B6 I=I+2. INCREMENT I. BLA01261 SA6 A0+B4 SY(I-2)=(X6) BLA01262 SA7 A6+B4 SY(I-1)=(X7) BLA01263 SA0 A7 ADVANCE ADDRESS TO SY(I) BLA01264 * BLA01265 SWAB SB1 B1+B6 (B1)=N-1 BLA01266 GT B5,B1,MOP IF (I .GT. N-1) AT MOST 1 COMP. REMAINS BLA01267 RX6 X1*X5 (X6)=SA*SX(I) BLA01268 RX7 X3*X5 (X7)=SA*SX(I+1) BLA01269 SB5 B5+B6 I=I+2. INCREMENT I BLA01270 RX6 X2+X6 (X6)=SA*SX(I-2)+SY(I-2) BLA01271 RX7 X4+X7 (X7)=SA*SX(I-1)+SY(I-1) BLA01272 NX6 X6 (X6)=NORM.(X6) BLA01273 NX7 X7 (X7)=NORM.(X7) BLA01274 SA6 A0+B4 SY(I-2)=(X6) BLA01275 SA7 A6+B4 SY(I-1)=(X7) BLA01276 SA0 A7 ADVANCE ADDRESS TO SY(I) BLA01277 * BLA01278 MOP SB1 B1+B6 (B1)=N+1 BLA01279 GE B5,B1,OUT IF (I .GT. N) RETURN BLA01280 SA1 A3+B3 (X1)=SX(N) BLA01281 SA2 A4+B4 (X2)=SY(N) BLA01282 RX6 X1*X5 (X6)=SA*SX(N) BLA01283 RX6 X2+X6 (X6)=SA*SX(N)+SY(N) BLA01284 NX6 X6 (X6)=NORM.(X6) BLA01285 SA6 A0+B4 SY(N)=(X6) BLA01286 * BLA01287 OUT OUTFTN SAXPY RETURN BLA01288 * END SAXPY BLA01289 END BLA01290 *DECK,DAXPY BLA01291 IDENT DAXPY BLA01292 * BLA01293 *** USE WITH FORTRAN STATEMENT BLA01294 * BLA01295 * CALL DAXPY(N,DA,DX,INCX,DY,INCY) BLA01296 * BLA01297 * DA*DXII + DYII REPLACES DYII FOR I=1,N BLA01298 * BLA01299 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA01300 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA01301 * BLA01302 * SIMILAR DEFINITIONS FOR DYII BLA01303 * BLA01304 * DX( ),DY( ) DOUBLE PRECISION BLA01305 * N,INCX,INCY INTEGER TYPE BLA01306 * DA DOUBLE PRECISION BLA01307 * BLA01308 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA01309 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA01310 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA01311 *** 1 JUNE 77 BLA01312 * BLA01313 ENTRY DAXPY BLA01314 VFD 42/5HDAXPY,18/6 BLA01315 * BLA01316 DAXPY DATA 0 ENTRY/EXIT BLA01317 INFTN DAXPY,6 BLA01318 SA3 B1 (X3) = N BLA01319 SB7 -1 (B7) = -1 BLA01320 SB1 X3+B7 (B1) = N-1 BLA01321 SA1 B2 (X1,X2) = DA BLA01322 SA2 B2-B7 BLA01323 ZR X1,OUT IF(DA .EQ. 0) GO TO OUT BLA01324 * BLA01325 SA4 B4 (X4) = INCX BLA01326 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA01327 SA5 B6 (X5) = INCY BLA01328 SX3 -B1 (X3) = -(N-1) BLA01329 LX4 1 INCX = 2*INCX BLA01330 IX5 X5+X5 INCY = 2*INCY BLA01331 SB4 X4 (B4) = INCX BLA01332 SB6 X5 (B5) = INCY BLA01333 * BLA01334 GT B4,ONE IF INCX .GT. 0 , GO TO ONE BLA01335 DX4 X3*X4 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA01336 SB3 X4+B3 (B3) = LOC(DXI1 ) BLA01337 * BLA01338 ONE GT B6,TWO IF INCY .GT. 0 , GO TO TWO BLA01339 DX5 X3*X5 LOC(DYI1 ) = LOC(DY) - (N-1)*INCY BLA01340 SB5 X5+B5 (B5) = LOC(DYI1 ) BLA01341 * BLA01342 * (I = 1) BLA01343 TWO SA3 B3 (X3,X4) = DXI1 BLA01344 SA4 B3-B7 BLA01345 * BLA01346 FX5 X2*X3 (X6,X7) = DA*DXI1 BLA01347 FX0 X1*X4 BLA01348 FX5 X0+X5 BLA01349 FX4 X1*X3 BLA01350 DX0 X1*X3 BLA01351 FX5 X0+X5 BLA01352 FX6 X4+X5 BLA01353 DX7 X4+X5 BLA01354 * BLA01355 SA5 B5 (X5,X4) = DYI1 BLA01356 SA4 B5-B7 BLA01357 * BLA01358 FX0 X6+X5 (X6,X7) = (X6,X7) + DYI1 BLA01359 DX6 X6+X5 BLA01360 FX5 X7+X4 BLA01361 NX0 X0 BLA01362 FX4 X5+X6 BLA01363 FX5 X4+X0 BLA01364 NX6 X5 BLA01365 DX4 X4+X0 BLA01366 NX0 X4 BLA01367 FX6 X0+X6 BLA01368 DX7 X0+X6 BLA01369 * BLA01370 SA6 A5 DYI1 = (X6,X7) BLA01371 SA7 A4 BLA01372 * BLA01373 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA01374 * BLA01375 * (I = I+1) BLA01376 LOOP SA3 A3+B4 (X3,X4) = DXII BLA01377 SA4 A3-B7 BLA01378 * BLA01379 FX5 X2*X3 (X6,X7) = DA*DXII BLA01380 FX0 X1*X4 BLA01381 FX5 X0+X5 BLA01382 FX4 X1*X3 BLA01383 DX0 X1*X3 BLA01384 FX5 X0+X5 BLA01385 FX6 X4+X5 BLA01386 DX7 X4+X5 BLA01387 * BLA01388 SA5 A5+B6 (X5,X4) = DYII BLA01389 SA4 A5-B7 BLA01390 * BLA01391 FX0 X6+X5 (X6,X7) = (X6,X7) + DYII BLA01392 DX6 X6+X5 BLA01393 FX5 X7+X4 BLA01394 NX0 X0 BLA01395 FX4 X5+X6 BLA01396 FX5 X4+X0 BLA01397 NX6 X5 BLA01398 DX4 X4+X0 BLA01399 NX0 X4 BLA01400 FX6 X0+X6 BLA01401 DX7 X0+X6 BLA01402 * BLA01403 SB1 B1+B7 I = I+1 BLA01404 * BLA01405 SA6 A5 DYII = (X6,X7) BLA01406 SA7 A4 BLA01407 * BLA01408 NZ B1,LOOP IF I .EQ. N , GO TO LOOP BLA01409 * BLA01410 OUT OUTFTN DAXPY RETURN BLA01411 END BLA01412 *DECK,CAXPY BLA01413 IDENT CAXPY BLA01414 * BLA01415 *** USE WITH FORTRAN STATEMENT BLA01416 * BLA01417 * CALL CAXPY(N,CA,CX,INCX,CY,INCY) BLA01418 * BLA01419 * CA*CXII + CYII REPLACES CYII FOR I=1,N BLA01420 * BLA01421 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA01422 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA01423 * BLA01424 * SIMILAR DEFINITIONS FOR CYII BLA01425 * BLA01426 * CX( ),CY( ) COMPLEX TYPE BLA01427 * N,INCX,INCY INTEGER TYPE BLA01428 * CA COMPLEX TYPE BLA01429 * BLA01430 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA01431 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA01432 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA01433 *** 1 JUNE 77 BLA01434 * BLA01435 ENTRY CAXPY BLA01436 VFD 42/5HCAXPY,18/6 BLA01437 * BLA01438 CAXPY DATA 0 ENTRY/EXIT BLA01439 INFTN CAXPY,6 BLA01440 SA3 B1 (X3) = N BLA01441 SB7 -1 (B7) = -1 BLA01442 SB1 X3+B7 (B1) = N-1 BLA01443 * BLA01444 SA4 B4 (X4) = INCX BLA01445 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA01446 SA5 B6 (X5) = INCY BLA01447 SX3 -B1 (X3) = -(N-1) BLA01448 LX4 1 INCX = 2*INCX BLA01449 IX5 X5+X5 INCY = 2*INCY BLA01450 SB4 X4 (B4) = INCX BLA01451 SB6 X5 (B6) = INCY BLA01452 * BLA01453 GT B4,ONE IF INCX .GT. 0 , GO TO ONE BLA01454 DX4 X3*X4 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA01455 SB3 X4+B3 (B3) = LOC(CXI1 ) BLA01456 * BLA01457 ONE GT B6,TWO IF INCY .GT. 0 , GO TO TWO BLA01458 DX5 X3*X5 LOC(CYI1 ) = LOC(CY) - (N-1)*INCY BLA01459 SB5 X5+B5 BLA01460 * BLA01461 * (I = 1) BLA01462 TWO SA3 B3 (X3) = REAL(CXI1 ) BLA01463 SA1 B2 (X1) = REAL(CA) BLA01464 SA2 B2-B7 (X2) = IMAG(CA) BLA01465 * BLA01466 BX5 X1 BLA01467 AX5 59 BLA01468 BX5 X1-X5 (X5) = ABS(REAL(CA)) BLA01469 BX6 X2 BLA01470 AX6 59 BLA01471 BX6 X2-X6 (X6) = ABS(IMAG(CA)) BLA01472 RX6 X5+X6 BLA01473 NX6 X6 BLA01474 ZR X6,OUT IF(ABS(REAL(CA))+ABS(IMAG(CCA))=0.0) GOTOBLA01475 * BLA01476 SA4 B3-B7 (X4) = IMAG(CXI1 ) BLA01477 * (X6,X7) = CA*CXI1 BLA01478 FX0 X1*X3 (X0) = REAL(CA)*REAL(CXI1 ) BLA01479 FX5 X2*X4 (X5) = IMAG(CA)*IMAG(CXI1 ) BLA01480 FX6 X0-X5 (X6) = REAL(CA*CXI1 ) BLA01481 * BLA01482 FX0 X1*X4 (X0) = REAL(CA)*IMAG(CXI1 ) BLA01483 FX5 X2*X3 (X5) = IMAG(CA)*REAL(CXI1 ) BLA01484 FX7 X0+X5 (X7) = IMAG(CA*CXI1 ) BLA01485 * BLA01486 * BLA01487 * (X6,X7) = (X6,X7) + CYI1 BLA01488 SA5 B5 (X5) = REAL(CYI1 ) BLA01489 SA4 B5-B7 (X4) = IMAG(CYI1 ) BLA01490 * BLA01491 FX0 X6+X5 (X0) = REAL(CA*CXI1 ) + REAL(CYI1 ) BLA01492 FX3 X7+X4 (X3) = IMAG(CA*CXI1 ) + IMAG(CYI1 ) BLA01493 NX6 X0 BLA01494 NX7 X3 NORMALIZE RESULT BLA01495 * BLA01496 SA6 A5 REAL(CYI1 ) = (X6) BLA01497 SA7 A4 IMAG(CYI1 ) = (X7) BLA01498 * BLA01499 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA01500 * BLA01501 * (I = I+1) BLA01502 LOOP SA3 A3+B4 (X3) = REAL(CXII ) BLA01503 SA4 A3-B7 (X4) = IMAG(CXII ) BLA01504 * BLA01505 * (X6,X7) = CA*CXII BLA01506 FX0 X1*X3 (X0) = REAL(CA)*REAL(CXII ) BLA01507 FX5 X2*X4 (X5) = IMAG(CA)*IMAG(CXII ) BLA01508 FX6 X0-X5 (X6) = REAL(CA*CXII ) BLA01509 * BLA01510 FX0 X1*X4 (X0) = REAL(CA)*IMAG(CXII ) BLA01511 FX5 X2*X3 (X5) = IMAG(CA)*REAL(CXII ) BLA01512 FX7 X0+X5 (X7) = IMAG(CA*CXII ) BLA01513 * BLA01514 * (X6,X7) = (X6,X7) + CYII BLA01515 SA5 A5+B6 (X5) = REAL(CYII ) BLA01516 SA4 A5-B7 (X4) = IMAG(CYII ) BLA01517 * BLA01518 FX0 X6+X5 (X0) = REAL(CA*CXII ) + REAL(CYII ) BLA01519 FX3 X7+X4 (X3) = IMAG(CA*CXII ) + IMAG(CYII ) BLA01520 SB1 B1+B7 I = I+1 BLA01521 NX6 X0 BLA01522 NX7 X3 NORMALIZE RESULT BLA01523 * BLA01524 SA6 A5 REAL(CYII ) = (X6) BLA01525 SA7 A4 IMAG(CYII ) = (X7) BLA01526 * BLA01527 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA01528 * BLA01529 OUT OUTFTN CAXPY RETURN BLA01530 END BLA01531 *DECK,SROTG BLA01532 IDENT SROTG BLA01533 * BLA01534 *** USE WITH FORTRAN STATEMENT BLA01535 * BLA01536 * CALL SROTG(SA,SB,SC,SS) BLA01537 * BLA01538 * COMPUTE QUANTITIES : R = SQRT( SA**2 + SB**2 ) BLA01539 * SC = SA/R , SS = SB/R BLA01540 * SA = R BLA01541 * BLA01542 * DEFINING THE GIVENS REFLECTION MATRIX (SC SS) BLA01543 * (-SS SC) BLA01544 * BLA01545 * SA,SB,SC,SS SINGLE PRECISION BLA01546 * BLA01547 * ROUNDED ARITHMETRIC INSTRUCTIONS ARE USED BLA01548 * BLA01549 * BLA01550 * WRITTEN BY DAVID R. KINCAID BLA01551 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA01552 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA01553 *** 1 JUNE 77 BLA01554 * BLA01555 ENTRY SROTG BLA01556 VFD 42/5HSROTG,18/4 BLA01557 * BLA01558 SROTG DATA 0 ENTRY/EXIT BLA01559 INFTN SROTG,4 BLA01560 * BLA01561 SX6 B1 BLA01562 SX7 B2 BLA01563 SA6 ADRSA SAVE ADDRESS OF SA AND SB BLA01564 SA7 ADRSB BLA01565 SX6 B3 BLA01566 SX7 B4 BLA01567 SA6 ADRSC SAVE ADDRESS OF SC AND SS BLA01568 SA7 ADRSS BLA01569 SA2 B1 (X2) = SA BLA01570 SA3 B2 (X3) = SB BLA01571 SA5 UNIT (X5) = 1.0 BLA01572 * BLA01573 BX4 X3 BLA01574 AX4 59 BLA01575 BX7 X3-X4 (X7) = ABS(SB) BLA01576 ZR X7,THIRTY IF ABS(SB) .EQ. 0 , GO TO THIRTY BLA01577 BX1 X2 BLA01578 AX1 59 BLA01579 BX6 X2-X1 (X6) = ABS(SA) BLA01580 ZR X6,FORTY IF ABS(SA) .EQ. 0 , GO TO FORTY BLA01581 * BLA01582 RX6 X6-X7 BLA01583 NX6 X6 BLA01584 ZR X6,TWENTY BLA01585 NG X6,TWENTY IF ABS(SA) .LE. ABS(SB), GO TO TWENTY BLA01586 * BLA01587 RX6 X3/X2 (X6) = SB/SA (=XR) BLA01588 RX0 X6*X6 (X0) = XR**2 BLA01589 SA6 XR XR = (X6) BLA01590 RX0 X5+X0 BLA01591 NX6 X0 (X6) = 1.+XR**2 BLA01592 SA6 XR2P1 XR2P1 = (X6) BLA01593 * BLA01594 SB1 XR2P1 BLA01595 * BLA01596 CALL SQRT,(B1) (X6) = SQRT(1.+XR**2) (=YR) BLA01597 * BLA01598 SA1 ADRSA RESTORE B REGISTERS BLA01599 SB1 X1 BLA01600 SA2 ADRSB BLA01601 SB2 X2 BLA01602 SA3 ADRSC BLA01603 SB3 X3 BLA01604 SA4 ADRSS BLA01605 SB4 X4 BLA01606 * BLA01607 SA2 B1 (X2)=SA BLA01608 SA3 XR (A3) = XR BLA01609 * BLA01610 RX7 X2*X6 (X7) = SA*YR BLA01611 SA5 UNIT BLA01612 RX6 X5/X6 (X6) = 1./YR BLA01613 SA7 B1 SA=(X7) BLA01614 RX7 X6*X3 (X7) = SC*XR BLA01615 SA6 B3 SC=(X6) BLA01616 SA7 B4 SS=(X7) BLA01617 * BLA01618 EQ FIFTY GO TO FIFTY BLA01619 * BLA01620 TWENTY RX7 X2/X3 (X7) = SA/SB (= XR) BLA01621 RX0 X7*X7 (X0) = XR**2 BLA01622 SA7 XR XR = (X7) BLA01623 RX7 X5+X0 BLA01624 NX6 X7 (X6) = 1.+XR**2 BLA01625 SA6 XR2P1 XR2P1 = (X6) BLA01626 * BLA01627 SB1 XR2P1 BLA01628 * BLA01629 CALL SQRT,(B1) (X6) = SQRT(1.+XR**2) (=YR) BLA01630 * BLA01631 SA1 ADRSA RESTORE B REGISTERS BLA01632 SB1 X1 BLA01633 SA2 ADRSB BLA01634 SB2 X2 BLA01635 SA3 ADRSC BLA01636 SB3 X3 BLA01637 SA4 ADRSS BLA01638 SB4 X4 BLA01639 * BLA01640 SA3 B2 (X3)=SB BLA01641 SA1 XR (X1) = XR BLA01642 * BLA01643 RX7 X3*X6 (X7) = SB*YR BLA01644 SA5 UNIT BLA01645 RX6 X5/X6 (X6) = 1./YR BLA01646 SA7 B1 SA=(X7) BLA01647 RX7 X6*X1 (X7) = SS*XR BLA01648 SA6 B4 SS=(X6) BLA01649 SA7 B3 SC=(X7) BLA01650 * BLA01651 EQ FIFTY GO TO FIFTY BLA01652 * BLA01653 THIRTY BX6 X5 (X6) = 1. BLA01654 MX7 0 (X7) = 0. BLA01655 SA6 B3 SC = (X6) BLA01656 SA7 B4 SS = (X7) BLA01657 * BLA01658 EQ FIFTY GO TO FIFTY BLA01659 * BLA01660 FORTY BX6 X5 (X6) = 1. BLA01661 MX7 0 (X7) = 0. BLA01662 SA6 B4 SS = (X6) BLA01663 SA7 B3 SC = (X7) BLA01664 * BLA01665 BX6 X3 (X6) = SB BLA01666 SA6 B1 SA = (X1) BLA01667 * BLA01668 FIFTY SA2 B4 (X2) = SS BLA01669 SA3 B3 (X3) = SC BLA01670 SA5 UNIT (X5) = 1.0 BLA01671 ZR X3,SEVENTY IF SC .EQ. 0 , TO GO SEVENTY BLA01672 * BLA01673 BX1 X2 BLA01674 AX1 59 BLA01675 BX6 X2-X1 (X6) = ABS(SS) BLA01676 BX4 X3 BLA01677 AX4 59 BLA01678 BX7 X3-X4 (X7) = ABS(SC) BLA01679 * BLA01680 RX6 X6-X7 BLA01681 NX6 X6 BLA01682 NG X6,SIXTY IF ABS(SS) .LT. ABS(SC), GO TO SIXTY BLA01683 * BLA01684 RX6 X5/X3 (X6) = 1./SC BLA01685 SA6 B2 SB = (X6) BLA01686 EQ OUT GO TO OUT BLA01687 * BLA01688 SIXTY BX6 X2 (X6) = SC BLA01689 SA6 B2 SB = (X6) BLA01690 EQ OUT GO TO OUT BLA01691 * BLA01692 SEVENTY BX6 X5 (X6) = 1. BLA01693 SA6 B2 SB = (X6) BLA01694 EQ OUT GO TO OUT BLA01695 * BLA01696 OUT OUTFTN SROTG RETURN BLA01697 * BLA01698 ADRSA BSS 1 BLA01699 ADRSB BSS 1 BLA01700 ADRSC BSS 1 BLA01701 ADRSS BSS 1 BLA01702 * BLA01703 XR BSS 1 BLA01704 XR2P1 BSS 1 BLA01705 * BLA01706 UNIT DATA 1.0 BLA01707 * BLA01708 END BLA01709 *DECK,DROTG BLA01710 IDENT DROTG BLA01711 * BLA01712 *** USE WITH FORTRAN STATEMENT BLA01713 * BLA01714 * CALL DROTG(DA,DB,DC,DS) BLA01715 * BLA01716 * COMPUTE QUANTITIES: DR = DSQRT( DA**2 + DB**2 ) BLA01717 * DC = DA/DR , DS = DB/DR BLA01718 * DA = DR BLA01719 * BLA01720 * DEFINES THE GIVENS REFLECTION MATRIX (DC DS) BLA01721 * (-DS DC) BLA01722 * BLA01723 * DA,DB,DC,DS DOUBLE PRECISION BLA01724 * BLA01725 * BLA01726 * WRITTEN BY DAVID R. KINCAID AND JAMES SULLIVAN BLA01727 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA01728 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA01729 *** 1 JUNE 77 BLA01730 * BLA01731 ENTRY DROTG BLA01732 VFD 42/5HDROTG,18/4 BLA01733 DROTG DATA 0 ENTRY/EXIT BLA01734 INFTN DROTG,4 BLA01735 * BLA01736 SX6 B1 BLA01737 SX7 B2 BLA01738 SA6 ADRDA SAVE ADDRESS OF DA AND DB BLA01739 SA7 ADRDB BLA01740 SX6 B3 BLA01741 SX7 B4 BLA01742 SA6 ADRDC SAVE ADDRESS OF DC AND DS BLA01743 SA7 ADRDS BLA01744 * BLA01745 SB7 -1 (B7) = -1 BLA01746 * BLA01747 SA3 B2 (X3,) = DB BLA01748 BX7 X3 (X7) = X3 BLA01749 AX7 73B FILL X7 WITH THE SIGN BIT OF DB. BLA01750 BX4 X7-X3 (X4,) = DABS(DB) BLA01751 ZR X4,THIRTY IF(SNGL(ABS(DB)) = 0) GO TO THIRTY BLA01752 * BLA01753 SA1 B1 (X1,) = DA BLA01754 BX2 X1 (X2) = X1 BLA01755 BX6 X1 (X6) = X1 BLA01756 AX6 73B FILL X6 WITH THE SIGN BIT OF DA. BLA01757 BX2 X6-X1 (X2,) = DABS(DA) BLA01758 * BLA01759 ZR X2,FORTY IF(SNGL(ABS(DA)) = 0) GO TO FORTY BLA01760 FX5 X4-X2 COMPARE UPPER HALVES OF DABS(DA) AND DABSBLA01761 NX5 X5 MAKE SURE X5 DOES NOT CONTAIN A MINUS ZERBLA01762 NG X5,TEN IF (DABS(DA) > DABS(DB)) GO TO TEN. BLA01763 * ELSE IF (SNGL(DABS(DA)) @ SNGL(DABS(DB)))BLA01764 * FOLLOWING.... BLA01765 SA2 B1-B7 (X1,X2) = DA BLA01766 SA4 B2-B7 (X3,X4) = DB BLA01767 * BLA01768 FX5 X1/X3 (X6,X7) = DA / DB BLA01769 FX6 X3*X5 BLA01770 FX7 X1-X6 BLA01771 DX6 X1-X6 BLA01772 NX7 X7 BLA01773 FX6 X6+X7 BLA01774 DX7 X3*X5 BLA01775 FX0 X4*X5 BLA01776 FX6 X2+X6 BLA01777 FX6 X6-X7 BLA01778 FX6 X6-X0 BLA01779 FX0 X6/X3 BLA01780 FX6 X0+X5 BLA01781 DX7 X0+X5 BLA01782 NX5 X6 BLA01783 FX6 X5+X7 BLA01784 DX7 X5+X7 (X6,X7) = (X1,X2) / (X3,X4) BLA01785 * BLA01786 SA6 XR (XR) = (X6,X7) BLA01787 SA7 XR+1 (XR) = DA / DB BLA01788 * BLA01789 FX4 X6*X7 (X0,X1) = XR**2 BLA01790 DX5 X6*X6 BLA01791 FX4 X4+X4 BLA01792 FX1 X6*X6 BLA01793 FX5 X4+X5 BLA01794 FX0 X1+X5 BLA01795 DX1 X1+X5 (X0,X1) = (X6,X7) * (X6,X7) BLA01796 * BLA01797 SA4 ONE (X4) = +1. BLA01798 * BLA01799 FX2 X0+X4 (X6,X7) = 1.D0 + (XR*XR) BLA01800 DX3 X0+X4 BLA01801 NX2 X2 BLA01802 FX5 X1+X3 BLA01803 FX4 X2+X5 BLA01804 NX3 X4 BLA01805 DX5 X2+X5 BLA01806 NX2 X5 BLA01807 FX6 X2+X3 BLA01808 DX7 X2+X3 (X6,X7) = (1.,0) + (X0,X1) BLA01809 * BLA01810 SA6 XR2P1 BLA01811 SA7 XR2P1+1 BLA01812 * SET (XR2P1) = (X6,X7). BLA01813 SB1 XR2P1 BLA01814 CALL DSQRT,(B1) BLA01815 * BLA01816 SA1 ADRDA BLA01817 SB1 X1 RESTORE B REGISTERS BLA01818 SA2 ADRDB BLA01819 SB2 X2 BLA01820 SA3 ADRDC BLA01821 SB3 X3 BLA01822 SA4 ADRDS BLA01823 SB4 X4 BLA01824 SB7 -1 BLA01825 * NO ERROR CHECKS ARE MADE UPON RETURN BLA01826 SA6 YR BLA01827 SA7 YR+1 (YR) = SGN(B)*DSQRT(ONE+XR*XR) BLA01828 * BLA01829 SA2 ONE (X2) = +1. BLA01830 * BLA01831 FX1 X2/X6 (X6,X7) = 1.0D0 / YR BLA01832 FX4 X1*X6 BLA01833 FX5 X2-X4 BLA01834 DX4 X2-X4 BLA01835 NX5 X5 BLA01836 FX4 X4+X5 BLA01837 DX5 X1*X6 BLA01838 FX0 X1*X7 BLA01839 FX4 X4-X5 BLA01840 FX4 X4-X0 BLA01841 FX0 X4/X6 BLA01842 FX4 X0+X1 BLA01843 DX5 X0+X1 BLA01844 NX1 X4 BLA01845 FX6 X1+X5 BLA01846 DX7 X1+X5 (X6,X7) = (X2,) / (X6,X7) BLA01847 SA6 B4 DS=(X6,X7) BLA01848 SA7 B4-B7 BLA01849 * BLA01850 SA2 XR (X2,X3) = XR BLA01851 SA3 XR+1 BLA01852 * BLA01853 FX4 X2*X7 (X6,X7) = DS * XR BLA01854 FX5 X3*X6 BLA01855 FX4 X4+X5 BLA01856 FX7 X2*X6 BLA01857 DX5 X2*X6 BLA01858 FX5 X4+X5 BLA01859 FX6 X5+X7 BLA01860 DX7 X5+X7 (X6,X7) = (X6,X7) * (X2,X3) BLA01861 * BLA01862 SA6 B3 DC=(X6,X7) BLA01863 SA7 B3-B7 BLA01864 * BLA01865 SA2 B2 (X2,X3)=DB BLA01866 SA3 B2-B7 BLA01867 * BLA01868 SA4 YR (X4,X5) = YR BLA01869 SA5 YR+1 BLA01870 * BLA01871 FX0 X3*X4 (X6,X7) = DB * YR BLA01872 FX1 X2*X5 BLA01873 FX0 X0+X1 BLA01874 FX3 X2*X4 BLA01875 DX1 X2*X4 BLA01876 FX1 X0+X1 BLA01877 FX6 X1+X3 BLA01878 DX7 X1+X3 (X6,X7) = (X2,X3) * (X4,X5) BLA01879 * BLA01880 SA6 B1 DA=(X6,X7) BLA01881 SA7 B1-B7 BLA01882 * BLA01883 EQ FIFTY GO TO FIFTY BLA01884 * BLA01885 TEN SA2 B1-B7 (X1,X2) = DA BLA01886 SA4 B2-B7 (X3,X4) = DB BLA01887 * BLA01888 FX5 X3/X1 (X6,X7) = DB / DA BLA01889 FX6 X1*X5 BLA01890 FX7 X3-X6 BLA01891 DX6 X3-X6 BLA01892 NX7 X7 BLA01893 FX6 X6+X7 BLA01894 DX7 X1*X5 BLA01895 FX0 X2*X5 BLA01896 FX6 X4+X6 BLA01897 FX6 X6-X7 BLA01898 FX6 X6-X0 BLA01899 FX0 X6/X1 BLA01900 FX6 X0+X5 BLA01901 DX7 X0+X5 BLA01902 NX5 X6 BLA01903 FX6 X5+X7 BLA01904 DX7 X5+X7 (X6,X7) = (X3,X4) / (X1,X2) BLA01905 * BLA01906 SA6 XR (XR) = (X6,X7) BLA01907 SA7 XR+1 (XR) = DB / DA BLA01908 * BLA01909 FX4 X6*X7 (X0,X1) = XR**2 BLA01910 DX5 X6*X6 BLA01911 FX4 X4+X4 BLA01912 FX3 X6*X6 BLA01913 FX5 X4+X5 BLA01914 FX0 X3+X5 BLA01915 DX1 X3+X5 (X0,X1) = (X6,X7) * (X6,X7) BLA01916 * BLA01917 SA4 ONE (X4) = +1. BLA01918 * BLA01919 FX2 X0+X4 (X6,X7) = 1.D0 + (XR*XR) BLA01920 DX3 X0+X4 BLA01921 NX2 X2 BLA01922 FX5 X1+X3 BLA01923 FX4 X2+X5 BLA01924 NX3 X4 BLA01925 DX5 X2+X5 BLA01926 NX2 X5 BLA01927 FX6 X2+X3 BLA01928 DX7 X2+X3 (X6,X7) = (1.,0) + (X0,X1) BLA01929 * BLA01930 * BLA01931 SA6 XR2P1 BLA01932 SA7 XR2P1+1 BLA01933 * SET (XR2P1) = (X6,X7). BLA01934 SB1 XR2P1 BLA01935 CALL DSQRT,(B1) BLA01936 * BLA01937 SA1 ADRDA RESTORE B REGISTERS BLA01938 SB1 X1 BLA01939 SA2 ADRDB BLA01940 SB2 X2 BLA01941 SA3 ADRDC BLA01942 SB3 X3 BLA01943 SA4 ADRDS BLA01944 SB4 X4 BLA01945 SB7 -1 BLA01946 * BLA01947 * NO ERROR CHECKS ARE MADE UPON RETURN BLA01948 SA6 YR BLA01949 SA7 YR+1 (YR) = SGN(A)*DSQRT(ONE+XR*XR) BLA01950 * BLA01951 * BLA01952 SA2 ONE (X2) = +1. BLA01953 * BLA01954 FX1 X2/X6 (X6/X7) = 1.D0 / YR BLA01955 FX4 X1*X6 BLA01956 FX5 X2-X4 BLA01957 DX4 X2-X4 BLA01958 NX5 X5 BLA01959 FX4 X4+X5 BLA01960 DX5 X1*X6 BLA01961 FX0 X1*X7 BLA01962 FX4 X4-X5 BLA01963 FX4 X4-X0 BLA01964 FX0 X4/X6 BLA01965 FX4 X0+X1 BLA01966 DX5 X0+X1 BLA01967 NX1 X4 BLA01968 FX6 X1+X5 BLA01969 DX7 X1+X5 (X6,X7) = (X2,) / (X6,X7) BLA01970 SA6 B3 DC=(X6,X7) BLA01971 SA7 B3-B7 BLA01972 * BLA01973 SA2 XR (X2,X3) = XR BLA01974 SA3 XR+1 BLA01975 * BLA01976 FX4 X2*X7 (X6,X7) = DC * XR BLA01977 FX5 X3*X6 BLA01978 FX4 X4+X5 BLA01979 FX7 X2*X6 BLA01980 DX5 X2*X6 BLA01981 FX5 X4+X5 BLA01982 FX6 X5+X7 BLA01983 DX7 X5+X7 (X6,X7) = (X6,X7) * (X2,X3) BLA01984 * BLA01985 SA6 B4 DS=(X6,X7) BLA01986 SA7 B4-B7 BLA01987 * BLA01988 SA2 B1 BLA01989 SA3 B1-B7 (X2,X3)=DA BLA01990 * BLA01991 SA4 YR (X4,X5) = YR BLA01992 SA5 YR+1 BLA01993 * BLA01994 FX0 X3*X4 (X6,X7) = DA * YR BLA01995 FX1 X2*X5 BLA01996 FX0 X0+X1 BLA01997 FX3 X2*X4 BLA01998 DX1 X2*X4 BLA01999 FX1 X0+X1 BLA02000 FX6 X1+X3 BLA02001 DX7 X1+X3 (X6,X7) = (X2,X3) * (X4,X5) BLA02002 * BLA02003 SA6 B1 DA=(X6,X7) BLA02004 SA7 B1-B7 BLA02005 * BLA02006 EQ FIFTY GO TO FIFTY BLA02007 * BLA02008 THIRTY MX6 0 (X6) = 0 BLA02009 SA1 ONE (X1) = +1. BLA02010 MX7 0 (X7) = 0 BLA02011 SA6 B4 (DS) = (X6,X7) BLA02012 SA7 B4-B7 (DS) = (0.,0) BLA02013 BX6 X1 (X6) = X1 BLA02014 SA7 B3-B7 DC = (X6,X7) BLA02015 SA6 B3 BLA02016 EQ FIFTY GO TO FIFTY BLA02017 * BLA02018 FORTY MX6 0 (X6) = 0 BLA02019 SA1 ONE (X1) = +1. BLA02020 MX7 0 (X7) = 0 BLA02021 SA6 B3 DC = (X6,X7) BLA02022 SA7 B3-B7 BLA02023 BX6 X1 (X6) = +1. BLA02024 SA6 B4 BLA02025 SA7 B4-B7 DS = (X6,X7) BLA02026 * BLA02027 SA1 B2 (X1,X2) = DB BLA02028 SA2 B2-B7 BLA02029 BX6 X1 BLA02030 BX7 X2 BLA02031 SA6 B1 BLA02032 SA7 B1-B7 DA = (X1,X2) BLA02033 * BLA02034 FIFTY SA1 B3 (X1,) = DC BLA02035 ZR X1,SEVENTY IF(SNGL(DC) = 0) GO TO SEVENTY BLA02036 * BLA02037 BX6 X1 (X6) = X1 BLA02038 AX1 59 BLA02039 BX2 X6-X1 (X2,) = DABS(DC) BLA02040 SA3 B4 (X3,) = DS BLA02041 BX7 X3 (X7) = X3 BLA02042 AX3 59 BLA02043 BX4 X7-X3 (X4,) = DABS(DS) BLA02044 * BLA02045 FX5 X4-X2 COMPARE UPPER HALVES:DABS(DC),DABS(DS) BLA02046 NX5 X5 MAKE SURE X5 DOES NOT CONTAIN A MINUS 0 BLA02047 NG X5,SIXTY IF(DABS(DC) > ABS(DS)) GO TO SIXTY BLA02048 * BLA02049 SA4 B3 (X4,X5) = DC BLA02050 SA5 B3-B7 BLA02051 SA2 ONE (X2) = +1. BLA02052 BX6 X4 BLA02053 BX7 X5 (X6,X7) = DC BLA02054 * BLA02055 FX1 X2/X6 (X6,X7) = 1.D0 / DC BLA02056 FX4 X1*X6 BLA02057 FX5 X2-X4 BLA02058 DX4 X2-X4 BLA02059 NX5 X5 BLA02060 FX4 X4+X5 BLA02061 DX5 X1*X6 BLA02062 FX0 X1*X7 BLA02063 FX4 X4-X5 BLA02064 FX4 X4-X0 BLA02065 FX0 X4/X6 BLA02066 FX4 X0+X1 BLA02067 DX5 X0+X1 BLA02068 NX1 X4 BLA02069 FX6 X1+X5 BLA02070 DX7 X1+X5 (X6,X7) = (X2,)/(X6,X7) BLA02071 * BLA02072 SA6 B2 DB = 1.D0 / DC BLA02073 SA7 B2-B7 BLA02074 * BLA02075 EQ OUT GO TO OUT BLA02076 * BLA02077 SIXTY SA4 B4 (X4,X5) = DS BLA02078 SA5 B4-B7 BLA02079 BX6 X4 BLA02080 BX7 X5 (X6,X7) = (X4,X5) BLA02081 SA6 B2 BLA02082 SA7 B2-B7 DB = (X6,X7) BLA02083 * BLA02084 EQ OUT GO TO OUT BLA02085 * BLA02086 SEVENTY SA2 ONE (X2) = +1. BLA02087 MX7 0 (X7) = 0. BLA02088 BX6 X2 BLA02089 SA6 B2 BLA02090 SA7 B2-B7 DB = (X6,X7) BLA02091 * BLA02092 OUT OUTFTN DROTG RETURN BLA02093 * BLA02094 ONE DATA 17204000000000000000B BLA02095 XR BSS 2 BLA02096 XR2P1 BSS 2 TEMPORARY STORAGE FOR THE QUANTITY (1.+XRBLA02097 YR BSS 2 BLA02098 ADRDA BSS 1 BLA02099 ADRDB BSS 1 BLA02100 ADRDC BSS 1 BLA02101 ADRDS BSS 1 BLA02102 * BLA02103 END BLA02104 *DECK,SROT BLA02105 IDENT SROT BLA02106 * BLA02107 *** USE WITH FORTRAN STATEMENT BLA02108 * BLA02109 * CALL SROT(N,SX,INCX,SY,INCY,SC,SS) BLA02110 * BLA02111 * APPLY GIVENS REFLECTION MATRIX BLA02112 * BLA02113 * APPLY 2X2 MATRIX ( SC SS) TO 2XN MATRIX (SXI1 ... SXIN ) BLA02114 * (-SS SC) (SYI1 ... SYIN ) BLA02115 * BLA02116 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA02117 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA02118 * BLA02119 * SIMILAR DEFINITIONS FOR SYII BLA02120 * BLA02121 * SX( ),SY( ) SINGLE PRECISION BLA02122 * N,INCX,INCY INTEGER TYPE BLA02123 * SC,SS SINGLE PRECISION BLA02124 * BLA02125 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA02126 * BLA02127 * WRITTEN BY RICHARD J. HANSON BLA02128 * SANDIA LABORATORIES BLA02129 * ALBUQUERQUE, NEW MEXICO BLA02130 *** 1 JUNE 77 BLA02131 * BLA02132 ENTRY SROT BLA02133 SS BSS 1 BLA02134 VFD 42/4HSROT,18/7 BLA02135 * BLA02136 SROT DATA 0 BLA02137 INFTN SROT,7 PROPER LINKAGE (RUN,FTN) MACRO. BLA02138 SA1 B1 (X1)=N BLA02139 SB7 1 (B7)=1 BLA02140 * BLA02141 SB1 X1 (B1)=N BLA02142 SB1 B1-B7 (B1)=N-1 BLA02143 * BLA02144 MI B1,OUT IF (N .LE. 0), QUIT BLA02145 * BLA02146 SA5 SS (X5)=LOC(SS) BLA02147 SA5 X5 (X5)=SS BLA02148 * BLA02149 NZ X5,APPLY IF(SS.EQ.0..AND.SC.EQ.1.) QUIT. BLA02150 SA2 B6 (X2)=SC BLA02151 SA3 SONE (X3)=1. BLA02152 RX2 X2-X3 (X2)=SC-1. BLA02153 NX2 X2 (X2)=NORM.(X2) BLA02154 ZR X2,OUT IF(SC.EQ.1.) QUIT. BLA02155 APPLY SA1 B2 (X1)=SX(1) BLA02156 SA2 B3 (X2)=INCX BLA02157 * BLA02158 SA3 B4 (X3)=SY(1) BLA02159 SA4 B5 (X4)=INCY BLA02160 * BLA02161 ZR B1,INCYNN IF (N .EQ. 1) NO NEED TO TEST FOR NEG. INC.BLA02162 SX0 -B1 (X0)=-(N-1) BLA02163 SB2 X2 (B2)=INCX BLA02164 SB3 X4 (B3)=INCY BLA02165 * BLA02166 GE B2,INCXNN IF (INCX .GE. 0) NO ADDRESS FIXUP NEEDED BLA02167 DX2 X0*X2 (X2)=-(N-1)*INCX BLA02168 SB7 A1 (B7)=LOC(SX(1)) BLA02169 SA1 B7+X2 (X1)=SX(1+(1-N)*INCX),(A1)=LOC(X(1)) BLA02170 * BLA02171 INCXNN GE B3,INCYNN IF (INCY .GE. 0) NO ADDRESS FIXUP NEEDED BLA02172 DX4 X0*X4 (X4)=-(N-1)*INCY BLA02173 SB7 A3 (B7)=LOC(SY(1)) BLA02174 SA3 B7+X4 (X3)=SY(1+(1-N)*INCY),(A3)=LOC(Y(1)) BLA02175 * BLA02176 INCYNN SA2 B6 (X2)=SC BLA02177 SB7 1 (B7)=1 BLA02178 SB6 B7 (B6)=I=1 BLA02179 BX0 X2 (X0)=SC BLA02180 * BLA02181 SB1 B1-B7 (B1)=N-2 BLA02182 GT B6,B1,FIX IF (I .GT. N-2) CLEAN-UP LOGIC BLA02183 * BLA02184 LOOP SA2 A1+B2 (X2)=SX(I+1) BLA02185 SA4 A3+B3 (X4)=SY(I+1) BLA02186 RX6 X3*X5 (X6)=SS*SY(I) BLA02187 RX7 X0*X3 (X7)=SC*SY(I) BLA02188 RX3 X0*X1 (X3)=SC*SX(I) BLA02189 RX1 X1*X5 (X1)=SS*SX(I) BLA02190 * BLA02191 SB6 B6+B7 (B6)=I=I+1. INCREMENT I BLA02192 RX6 X3+X6 (X6)=SC*SX(I-1)+SS*SY(I-1) BLA02193 RX3 X4*X5 (X3)=SS*SY(I) BLA02194 RX7 X7-X1 (X7)=-SS*SX(I-1)+SC*SY(I-1) BLA02195 RX1 X0*X4 (X1)=SC*SY(I) BLA02196 RX4 X0*X2 (X4)=SC*SX(I) BLA02197 NX6 X6 (X6)=NORM.(X6) BLA02198 RX2 X2*X5 (X2)=SS*SX(I) BLA02199 NX7 X7 (X7)=NORM.(X7) BLA02200 NO 0 DEAD BLA02201 SA6 A1 SX(I-1)=(X6) BLA02202 NO 0 DEAD BLA02203 RX4 X3+X4 (X4)=SC*SX(I)+SS*SY(I) BLA02204 SA7 A3 SY(I-1)=(X7) BLA02205 SA3 A4+B3 (X3)=SY(I+1). NEXT ITERATION. BLA02206 RX2 X1-X2 (X2)=-SS*SX(I)+SC*SY(I) BLA02207 SA1 A2+B2 (X1)=SX(I+1). NEXT ITERATION. BLA02208 NX6 X4 (X6)=NORM.(X4) BLA02209 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA02210 NO 0 DEAD BLA02211 NX7 X2 (X7)=NORM(X2) BLA02212 SA6 A2 SX(I-1)=(X6) BLA02213 NO 2 DEAD BLA02214 SA7 A4 SY(I-1)=(X7) BLA02215 LE B6,B1,LOOP IF (I .LE. N-2) CONTINUE LOOP BLA02216 FIX SB1 B1+B7 (B1)=N-1 BLA02217 SB1 B1+B7 (B1)=N BLA02218 CL RX6 X3*X5 (X6)=SS*SY(I) BLA02219 RX7 X0*X3 (X7)=SC*SY(I) BLA02220 RX3 X0*X1 (X3)=SC*SX(I) BLA02221 RX1 X1*X5 (X1)=SS*SX(I) BLA02222 * BLA02223 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA02224 RX6 X3+X6 (X6)=SC*SX(I-1)+SS*SY(I-1) BLA02225 RX7 X7-X1 (X7)=-SS*SX(I-1)+SC*SY(I-1) BLA02226 * BLA02227 NX6 X6 (X6)=NORM.(X6) BLA02228 NX7 X7 (X7)=NORM.(X7) BLA02229 * BLA02230 SA6 A1 SX(I-1)=(X6) BLA02231 SA7 A3 SY(I-1)=(X7) BLA02232 * BLA02233 GT B6,B1,OUT IF (I .GT. N), QUIT BLA02234 SA3 A3+B3 (X3)=SY(I) BLA02235 SA1 A1+B2 (X1)=SX(I) BLA02236 JP CL ONE COMP. REMAINS. BLA02237 OUT OUTFTN SROT BLA02238 SONE DATA 1.0 BLA02239 * END SROT BLA02240 END BLA02241 *DECK,DROT BLA02242 IDENT DROT BLA02243 * BLA02244 *** USE WITH FORTRAN STATEMENT BLA02245 * BLA02246 * CALL DROT(N,DX,INCX,DY,INCY,DC,DS) BLA02247 * BLA02248 * APPLY GIVENS REFLECTION MATRIX BLA02249 * BLA02250 * APPLY 2X2 MATRIX ( DC DS) TO 2XN MATRIX (DXI1 ... DXIN ) BLA02251 * (-DS DC) (DYI1 ... DYIN ) BLA02252 * BLA02253 * DXII = DX(1 + (I-N)*2*INCX) IF INCX .GE. 0 BLA02254 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA02255 * BLA02256 * SIMILAR DEFINITIONS FOR DYII BLA02257 * BLA02258 * DX( ),DY( ) DOUBLE PRECISION BLA02259 * N,INCX,INCY INTEGER TYPE BLA02260 * DC,DS DOUBLE PRECISION BLA02261 * BLA02262 * WRITTEN BY DAVID R. KINCAID BLA02263 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA02264 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA02265 *** 1 JUNE 77 BLA02266 * BLA02267 ENTRY DROT BLA02268 ARG7 BSS 1 BLA02269 VFD 42/4HDROT,18/7 BLA02270 * BLA02271 DROT DATA 0 ENTRY/EXIT BLA02272 INFTN DROT,7 BLA02273 SA1 B1 (X1) = N BLA02274 SB7 -1 (B7) = -1 BLA02275 SB1 X1+B7 (B1) = N-1 BLA02276 * BLA02277 SA2 B3 (X2) = INCX BLA02278 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA02279 SA3 ARG7 (X3) = LOC(DS) BLA02280 SA3 X3 (X3,) = DS BLA02281 NZ X3,DROT5 IF DS.NE.0.0EE0, GO TO DROT5 BLA02282 * BLA02283 SA3 B6 (X3,X4) = DC BLA02284 SA4 B6-B7 BLA02285 SA1 DONE (X1,X5) = 1.0EE0 BLA02286 SA5 A1-B7 BLA02287 * BLA02288 FX4 X4-X5 BLA02289 FX5 X3-X1 BLA02290 DX3 X3-X1 BLA02291 NX5 X5 BLA02292 FX3 X3+X4 BLA02293 NX3 X3 BLA02294 FX5 X3+X5 BLA02295 ZR X5,OUT IF DC.EQ.1.0EE0.AND.DS.EQ.0.0EE0, GOTO OUBLA02296 * BLA02297 DROT5 SA3 B5 (X3) = INCX BLA02298 SX1 -B1 (X1) = -(N-1) BLA02299 LX2 1 INCX = 2*INCX BLA02300 IX3 X3+X3 INCY = 2*INCY BLA02301 SB3 X2 (B3) = INCX BLA02302 SB5 X3 (B5) = INCY BLA02303 * BLA02304 GT B3,DROT10 IF INCX .GT. 0 , GO TO DROT10 BLA02305 ZR B3,OUT IF INCX .EQ. 0 , GO TO OUT BLA02306 DX0 X1*X2 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA02307 SB2 X0+B2 (B2) = LOC(DXI1 ) BLA02308 * BLA02309 DROT10 GT B5,DROT20 IF INCY .GT. 0, GO TO DROT20 BLA02310 ZR B5,OUT IF INCY .EQ. 0 , GO TO OUT BLA02311 DX0 X1*X3 LOC(DYI1 ) = LOC(DY) - (N-1)*INCY BLA02312 SB4 X0+B4 (B4) = LOC(DYI1 ) BLA02313 * BLA02314 DROT20 SA5 ARG7 BLA02315 SA0 X5 (A0) = LOC(DS) BLA02316 SB1 B1-B7 (B1) = N BLA02317 * BLA02318 LOOP SA1 A0 (X1,X2) = DS BLA02319 SA2 A0-B7 BLA02320 * BLA02321 SA3 B4 (X3,X4) = DYII BLA02322 SA4 B4-B7 BLA02323 * BLA02324 FX5 X2*X3 (X6,X7) = DS*DYII BLA02325 FX0 X1*X4 BLA02326 FX5 X0+X5 BLA02327 FX4 X1*X3 BLA02328 DX0 X1*X3 BLA02329 FX5 X0+X5 BLA02330 FX6 X4+X5 BLA02331 DX7 X4+X5 BLA02332 * BLA02333 SA1 B2 (X1,X2) = DXII BLA02334 SA2 B2-B7 BLA02335 * BLA02336 SA3 B6 (X3,X4) = DC BLA02337 SA4 B6-B7 BLA02338 * BLA02339 FX5 X2*X3 (X0,X3) = DC*DXII BLA02340 FX0 X1*X4 BLA02341 FX5 X0+X5 BLA02342 FX4 X1*X3 BLA02343 DX0 X1*X3 BLA02344 FX5 X0+X5 BLA02345 FX0 X4+X5 BLA02346 DX3 X4+X5 BLA02347 * BLA02348 FX4 X6+X0 (X6,X7) = (X6,X7)+(X0,X3) BLA02349 DX5 X6+X0 BLA02350 FX0 X7+X3 BLA02351 NX4 X4 BLA02352 FX3 X0+X5 BLA02353 FX0 X3+X4 BLA02354 NX5 X0 BLA02355 DX3 X3+X4 BLA02356 NX4 X3 BLA02357 FX6 X4+X5 BLA02358 DX7 X4+X5 BLA02359 * BLA02360 SA6 DW DW = (X6,X7) BLA02361 SA7 DW+1 BLA02362 * BLA02363 SA3 A0 (X3,X4) = DS BLA02364 SA4 A0-B7 BLA02365 * BLA02366 FX5 X2*X3 (X6,X7) = DS*DXII BLA02367 FX0 X1*X4 BLA02368 FX5 X0+X5 BLA02369 FX4 X1*X3 BLA02370 DX0 X1*X3 BLA02371 FX5 X0+X5 BLA02372 FX6 X4+X5 BLA02373 DX7 X4+X5 BLA02374 * BLA02375 SA1 B6 (X1,X2) = DC BLA02376 SA2 B6-B7 BLA02377 SA3 B4 (X3,X4) = DYII BLA02378 SA4 B4-B7 BLA02379 * BLA02380 FX5 X2*X3 (X0,X2) = DC*DYII BLA02381 FX0 X1*X4 BLA02382 FX5 X0+X5 BLA02383 FX4 X1*X3 BLA02384 DX0 X1*X3 BLA02385 FX5 X0+X5 BLA02386 FX0 X4+X5 BLA02387 DX2 X4+X5 BLA02388 * BLA02389 FX4 X0-X6 (X6,X7) = (X0,X2)-(X6,X7) BLA02390 DX5 X0-X6 BLA02391 FX0 X2-X7 BLA02392 NX4 X4 BLA02393 FX2 X0+X5 BLA02394 FX0 X2+X4 BLA02395 NX5 X0 BLA02396 DX2 X2+X4 BLA02397 NX4 X2 BLA02398 FX6 X4+X5 BLA02399 DX7 X4+X5 BLA02400 * BLA02401 SA6 B4 DYII = (X6,X7) BLA02402 SA7 B4-B7 BLA02403 * BLA02404 SB1 B1+B7 COUNT TERM BLA02405 SA1 DW BLA02406 SA2 DW+1 BLA02407 BX6 X1 BLA02408 BX7 X2 BLA02409 SA6 B2 BLA02410 SA7 B2-B7 DXII = DW BLA02411 * BLA02412 SB2 B2+B3 (B2) = LOC(DXII+1 ) BLA02413 SB4 B4+B5 (B4) = LOC(DYII+1 ) BLA02414 * BLA02415 NZ B1,LOOP IF I .NE. N, LOOP BLA02416 * BLA02417 OUT OUTFTN DROT RETURN BLA02418 * BLA02419 DONE DATA 1.0EE0 BLA02420 DW BSS 2 BLA02421 * BLA02422 END BLA02423 *DECK,SROTMG BLA02424 IDENT SROTMG BLA02425 * BLA02426 *** USE WITH FORTRAN STATEMENT BLA02427 * BLA02428 * CALL SROTMG(SD1,SD2,SB1,SB2,SPARAM) BLA02429 * BLA02430 * CONSTRUCT THE TWO-MULTIPLY,TWO-ADD,NO-SQUARE-RO0T BLA02431 * GIVENS ROTATION BLA02432 * BLA02433 * BLA02434 * THIS SUBROUTINE STORES VALUES IN SPARAM( ) BLA02435 * DEFINING THE MATRIX H BLA02436 * BLA02437 * SPARAM(1) = FLAG , INDICATES THE FORM OF THE MATRIX H BLA02438 * SPARAM(2) = H11 BLA02439 * SPARAM(3) = H21 BLA02440 * SPARAM(4) = H12 BLA02441 * SPARAM(5) = H22 BLA02442 * BLA02443 * THE FLAG VALUES AND THE CORRESPONDING FORMS OF THE MATRIX H BLA02444 * -2. (1 0) -1. (H11 H12) 0. ( 1 H12) 1. (H11 1 ) BLA02445 * (0 1) (H21 H22) (H21 1 ) (-1 H22) BLA02446 * BLA02447 * SD1,SD2,SB1,SB2 SINGLE PRECISION BLA02448 * SPARAM( ) SINGLE PRECISION BLA02449 * BLA02450 * THIS ALGORITHM ASSUMES THAT THE INPUT VALUE OF SD1 IS BLA02451 * POSITIVE OR ZERO BUT NON-NEGATIVE. THE VALUE OF SD2 IS BLA02452 * UNRESTRICTED. BLA02453 * BLA02454 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA02455 * BLA02456 * WRITTEN BY DAVID R. KINCAID AND JAMES SULLIVAN BLA02457 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA02458 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA02459 *** 1 JUNE 77 BLA02460 * BLA02461 ENTRY SROTMG BLA02462 VFD 42/6HSROTMG,18/5 BLA02463 * BLA02464 SROTMG DATA 0 ENTRY/EXIT BLA02465 INFTN SROTMG,5 BLA02466 SA1 B1 (X1) = SD1 BLA02467 SA3 B3 (X3) = SB1 BLA02468 RX0 X1*X3 (X0) = P1 = SD1*SB1 BLA02469 SA2 B2 (X2) = SD2 BLA02470 SA4 B4 (X4) = SB2 BLA02471 RX5 X2*X4 (X5) = P2 = SD2*SB2 BLA02472 RX6 X0*X3 (X6) = P1*SB1 BLA02473 RX7 X5*X4 (X7) = P2*SB2 BLA02474 * BLA02475 BX1 X6 BLA02476 AX6 59 BLA02477 BX6 X6-X1 (X6) = ABS(P1*SB1) BLA02478 * BLA02479 BX2 X7 BLA02480 AX7 59 BLA02481 BX7 X7-X2 (X7) = ABS(P2*SB2) BLA02482 * BLA02483 RX6 X7-X6 BLA02484 NX6 X6 BLA02485 NG X6,TWELVE IF( ABS(P1*SB1) .GT. ABS(P2*SB2) ) BLA02486 * GO TO 12 BLA02487 * BLA02488 ZR X2,FOUR BLA02489 NG X2,SIXTN IF( P2*SB2 ) 16,4,10 BLA02490 * BLA02491 * BLA02492 RX7 X3/X4 (X7) = SB1/SB2 ITEN BLA02493 SA1 B1 (X1) = SD1 BLA02494 SA2 B2 (X2) = SD2 BLA02495 RX6 X0/X5 (X6) = P1/P2 BLA02496 SA7 B5+4 SPARAM(5) = (X7) BLA02497 SA6 B5+1 SPARAM(2) = (X6) BLA02498 RX0 X6*X7 (X0) = SPARAM(2)*SPARAM(5) BLA02499 SA5 UNIT (X5) = 1.0 BLA02500 RX0 X5+X0 (X0) = 1.0 + SPARAM(2)*SPARAM(5) = U BLA02501 NX0 X0 BLA02502 BX7 X5 (X7) = X5 BLA02503 RX5 X5/X0 (X5) = 1./U BLA02504 SA7 B5 SPARAM(1) = 1.0 BLA02505 RX7 X4*X0 (X7) = SB2*(X0) BLA02506 SA7 B3 SB1 = (X7) BLA02507 BX3 X7 (X3) = SB1 BLA02508 RX6 X2*X5 (X6) = SD2*(X5) BLA02509 RX7 X1*X5 (X7) = SD1*(X5) BLA02510 SA6 B1 SD1 = (X6) BLA02511 SA7 B2 SD2 = (X7) BLA02512 BX1 X6 (X1) = SD1 BLA02513 BX2 X7 (X2) = SD2 BLA02514 EQ TWENTY4 GO TO 24 BLA02515 * BLA02516 FOUR SA5 RTWO BLA02517 BX6 -X5 BLA02518 SA6 B5 SPARAM(1) = -2.0 BLA02519 * BLA02520 EQ OUT GO TO OUT BLA02521 * BLA02522 * BLA02523 TWELVE RX7 X4/X3 (X7) = SB2/SB1 BLA02524 SA1 B1 (X1) = SD1 BLA02525 SA2 B2 (X2) = SD2 BLA02526 RX6 X5/X0 (X6) = P2/P1 BLA02527 BX7 -X7 (X7) = -SB2/SB1 BLA02528 SA7 B5+2 SPARAM(3) = (X7) BLA02529 SA6 B5+3 SPARAM(4) = (X6) BLA02530 RX0 X6*X7 (X0) = SPARAM(4)*SPARAM(3) BLA02531 SA5 UNIT (X5) = 1.0 BLA02532 RX5 X5-X0 (X0) = 1.0 - SPARAM(4)*SPARAM(3) = U BLA02533 NX0 X5 BLA02534 * BLA02535 SA5 TOL (X5) = TOL BLA02536 RX5 X5-X0 BLA02537 NX5 X5 BLA02538 PL X5,SIXTN IF( U .LE. TOL ) GO TO 16 BLA02539 * BLA02540 * HERE WHEN U IS ZERO OR NEARLY ZERO. BLA02541 * ALSO WHEN SD1 IS NEGATIVE AND BLA02542 * ABS(SD1*SB1**1) .LE. ABS(SD2*SB2**2) BLA02543 * SINCE IN SUCH A CASE U SHOULD BE SMALL. BLA02544 * BLA02545 SA5 UNIT (X5) = 1.0 BLA02546 RX5 X5/X0 (X5) = 1./U BLA02547 RX7 X3*X0 (X7) = SB1*U BLA02548 SA7 B3 SB1 = (X7) BLA02549 MX6 0 (X6) = 0.0 BLA02550 SA6 B5 SPARAM(1) = 0.0 BLA02551 BX3 X7 (X3) = SB1 BLA02552 RX6 X1*X5 (X6) = SD1*(X5) BLA02553 RX7 X2*X5 (X7) = SD2*(X5) BLA02554 SA6 A1 SD1 = (X6) BLA02555 SA7 A2 SD2 = (X7) BLA02556 BX1 X6 (X1) = SD1 BLA02557 BX2 X7 (X2) = SD2 BLA02558 * BLA02559 EQ TWENTY4 RETURN BLA02560 * BLA02561 SIXTN MX7 0 (X7) = 0.0 BLA02562 SA5 UNIT (X5) = -1.0 BLA02563 BX6 -X5 BLA02564 SA6 B5 SPARAM(1) = -1.0 BLA02565 SA7 B5+1 SPARAM(2) = 0.0 BLA02566 MX6 0 (X6) = 0.0 BLA02567 SA6 B5+2 SPARAM(3) = 0.0 BLA02568 SA7 B5+3 SPARAM(4) = 0.0 BLA02569 SA6 B5+4 SPARAM(5) = 0.0 BLA02570 SA7 B1 SD1 = 0.0 BLA02571 SA6 B2 SD2 = 0.0 BLA02572 SA7 B3 SB1 = 0.0 BLA02573 * BLA02574 EQ OUT GO TO OUT BLA02575 * BLA02576 TWENTY4 BX6 X1 BLA02577 SA5 BIGINV BLA02578 AX6 59 BLA02579 BX6 X6-X1 BLA02580 RX5 X5-X6 BLA02581 NX5 X5 BLA02582 NG X5,THIRTY6 BLA02583 ZR X1,FOURTY8 BLA02584 SA5 B5 BLA02585 ZR X5,A84 BLA02586 NG X5,A32 BLA02587 SA5 UNIT BLA02588 BX6 X5 BLA02589 BX7 -X5 BLA02590 SA6 B5+3 BLA02591 SA7 B5+2 BLA02592 EQ A92 BLA02593 A84 SA5 UNIT BLA02594 BX6 X5 BLA02595 BX7 X5 BLA02596 SA6 B5+1 BLA02597 SA7 B5+4 BLA02598 BX7 -X5 BLA02599 A92 SA7 B5 BLA02600 A32 SA5 SQRBIG2 BLA02601 RX6 X1*X5 BLA02602 SA5 SQRBIGI BLA02603 BX1 X6 BLA02604 SA6 B1 BLA02605 SA4 B5+1 BLA02606 RX6 X3*X5 BLA02607 RX7 X4*X5 BLA02608 SA6 B3 BLA02609 SA7 B5+1 BLA02610 BX3 X6 BLA02611 SA4 B5+3 BLA02612 RX6 X4*X5 BLA02613 SA6 B5+3 BLA02614 EQ TWENTY4 BLA02615 THIRTY6 BX6 X1 BLA02616 SA5 BIG BLA02617 AX6 59 BLA02618 BX6 X6-X1 BLA02619 RX5 X6-X5 BLA02620 NX5 X5 BLA02621 NG X5,FOURTY8 BLA02622 SA5 B5 BLA02623 ZR X5,B84 BLA02624 NG X5,B32 BLA02625 SA5 UNIT BLA02626 BX6 X5 BLA02627 BX7 -X5 BLA02628 SA6 B5+3 BLA02629 SA7 B5+2 BLA02630 EQ B92 BLA02631 B84 SA5 UNIT BLA02632 BX6 X5 BLA02633 BX7 X5 BLA02634 SA6 B5+1 BLA02635 SA7 B5+4 BLA02636 BX7 -X5 BLA02637 B92 SA7 B5 BLA02638 B32 SA5 SQRBI2I BLA02639 RX6 X1*X5 BLA02640 SA5 SQRBIG BLA02641 BX1 X6 BLA02642 SA6 B1 BLA02643 SA4 B5+1 BLA02644 RX6 X3*X5 BLA02645 RX7 X4*X5 BLA02646 SA6 B3 BLA02647 SA7 B5+1 BLA02648 BX3 X6 BLA02649 SA4 B5+3 BLA02650 RX6 X4*X5 BLA02651 SA6 B5+3 BLA02652 EQ THIRTY6 BLA02653 FOURTY8 BX4 X2 BLA02654 SA5 BIGINV BLA02655 AX4 59 BLA02656 BX4 X4-X2 BLA02657 RX5 X5-X4 BLA02658 NX5 X5 BLA02659 NG X5,SIXTY BLA02660 ZR X2,OUT BLA02661 SA5 B5 BLA02662 ZR X5,C84 BLA02663 NG X5,C32 BLA02664 SA5 UNIT BLA02665 BX6 X5 BLA02666 BX7 -X5 BLA02667 SA6 B5+3 BLA02668 SA7 B5+2 BLA02669 EQ C92 BLA02670 C84 SA5 UNIT BLA02671 BX6 X5 BLA02672 BX7 X5 BLA02673 SA6 B5+1 BLA02674 SA7 B5+4 BLA02675 BX7 -X5 BLA02676 C92 SA7 B5 BLA02677 C32 SA5 SQRBIG2 BLA02678 RX6 X2*X5 BLA02679 SA5 SQRBIGI BLA02680 BX2 X6 BLA02681 SA6 B2 BLA02682 SA4 B5+2 BLA02683 RX7 X4*X5 BLA02684 SA7 B5+2 BLA02685 SA4 B5+4 BLA02686 RX6 X4*X5 BLA02687 SA6 B5+4 BLA02688 EQ FOURTY8 BLA02689 SIXTY BX4 X2 BLA02690 SA5 BIG BLA02691 AX4 59 BLA02692 BX4 X4-X2 BLA02693 RX5 X4-X5 BLA02694 NX5 X5 BLA02695 NG X5,OUT BLA02696 SA5 B5 BLA02697 ZR X5,D84 BLA02698 NG X5,D32 BLA02699 SA5 UNIT BLA02700 BX6 X5 BLA02701 BX7 -X5 BLA02702 SA6 B5+3 BLA02703 SA7 B5+2 BLA02704 EQ D92 BLA02705 D84 SA5 UNIT BLA02706 BX6 X5 BLA02707 BX7 X5 BLA02708 SA6 B5+1 BLA02709 SA7 B5+4 BLA02710 BX7 -X5 BLA02711 D92 SA7 B5 BLA02712 D32 SA5 SQRBI2I BLA02713 RX6 X2*X5 BLA02714 SA5 SQRBIG BLA02715 BX2 X6 BLA02716 SA6 B2 BLA02717 SA4 B5+2 BLA02718 RX7 X4*X5 BLA02719 SA7 B5+2 BLA02720 SA4 B5+4 BLA02721 RX6 X4*X5 BLA02722 SA6 B5+4 BLA02723 EQ SIXTY BLA02724 OUT OUTFTN SROTMG RETURN BLA02725 * BLA02726 BIG DATA 1.67772E7 BLA02727 BIGINV DATA 5.96046E-8 BLA02728 RTWO DATA 2.0 BLA02729 SQRBIG DATA 4096.0 BLA02730 SQRBIGI DATA 17044000000000000000B BLA02731 SQRBIG2 DATA 17504000000000000000B BLA02732 SQRBI2I DATA 16704000000000000000B BLA02733 TOL DATA 0.0 BLA02734 UNIT DATA 1.0 BLA02735 * BLA02736 END BLA02737 *DECK,DROTMG BLA02738 IDENT DROTMG BLA02739 * BLA02740 *** USE WITH FORTRAN STATEMENT BLA02741 * BLA02742 * CALL DROTMG(DD1,DD2,DB1,DB2,DPARAM) BLA02743 * BLA02744 * CONSTRUCT THE TWO-MULTIPLY,TWO-ADD,NO-SQUARE-RO0T BLA02745 * GIVENS ROTATION BLA02746 * BLA02747 * BLA02748 * THIS SUBROUTINE STORES VALUES IN DPARAM( ) BLA02749 * DEFINING THE MATRIX H BLA02750 * BLA02751 * DPARAM(1) = FLAG , INDICATES THE FORM OF THE MATRIX H BLA02752 * DPARAM(2) = H11 BLA02753 * DPARAM(3) = H21 BLA02754 * DPARAM(4) = H12 BLA02755 * DPARAM(5) = H22 BLA02756 * BLA02757 * THE FLAG VALUES AND THE CORRESPONDING FORMS OF THE MATRIX H BLA02758 * -2. (1 0) -1. (H11 H12) 0. ( 1 H12) 1. (H11 1 ) BLA02759 * (0 1) (H21 H22) (H21 1 ) (-1 H22) BLA02760 * BLA02761 * DD1,DD2,DB1,DB2 DOUBLE PRECISION BLA02762 * DPARAM( ) DOUBLE PRECISION BLA02763 * BLA02764 * THIS ALGORITHM ASSUMES THAT THE INPUT VALUE OF DD1 IS BLA02765 * POSITIVE OR ZERO BUT NON-NEGATIVE. THE VALUE OF DD2 IS BLA02766 * UNRESTRICTED. BLA02767 * BLA02768 * WRITTEN BY DAVID R. KINCAID AND JAMES SULLIVAN BLA02769 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA02770 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA02771 *** 1 JUNE 77 BLA02772 * BLA02773 ENTRY DROTMG BLA02774 VFD 42/6HDROTMG,18/5 BLA02775 * BLA02776 DROTMG DATA 0 ENTRY/EXIT BLA02777 INFTN DROTMG,5 BLA02778 SA1 B1 (X1,X2) = DD1 BLA02779 SA2 B1+1 BLA02780 SA3 B3 (X3,X4) = DB1 BLA02781 SA4 B3+1 BLA02782 * BLA02783 FX7 X2*X3 (X6,X7) = DD1 * DB1 BLA02784 FX6 X1*X4 BLA02785 FX7 X6+X7 BLA02786 DX6 X1*X3 BLA02787 FX0 X1*X3 BLA02788 FX7 X6+X7 BLA02789 FX6 X0+X7 BLA02790 DX7 X0+X7 (X6,X7) = (X1,X2) * (X3,X4) BLA02791 * BLA02792 SA6 P1 (P1) = (X6,X7) BLA02793 SA7 P1+1 (P1) = DD1 * DB1 BLA02794 * BLA02795 FX1 X4*X6 (X0,X1) = P1 * DB1 BLA02796 FX2 X3*X7 BLA02797 FX1 X1+X2 BLA02798 DX0 X3*X6 BLA02799 FX2 X3*X6 BLA02800 FX1 X0+X1 BLA02801 FX0 X1+X2 BLA02802 DX1 X1+X2 (X0,X1) = (X3,X4) * (X6,X7) BLA02803 * BLA02804 BX2 X0 BLA02805 AX2 59 BLA02806 BX0 X2-X0 BLA02807 BX1 X2-X1 (X0,X1) = DABS( P1*DB1 ) BLA02808 * BLA02809 SA2 B2 (X2,X3) = DD2 BLA02810 SA3 B2+1 BLA02811 SA4 B4 (X4,X5) = DB2 BLA02812 SA5 B4+1 BLA02813 * BLA02814 FX7 X3*X4 (X6,X7) = DD2 * DB2 BLA02815 FX6 X2*X5 BLA02816 FX7 X6+X7 BLA02817 FX3 X2*X4 BLA02818 DX6 X2*X4 BLA02819 FX7 X6+X7 BLA02820 FX6 X3+X7 BLA02821 DX7 X3+X7 (X6,X7) = (X2,X3) * (X4,X5) BLA02822 * BLA02823 SA6 P2 (P2) = (X6,X7) BLA02824 SA7 P2+1 (P2) = DD2 * DB2 BLA02825 * BLA02826 FX2 X5*X6 (X2,X3) = P2 * DB2 BLA02827 FX3 X4*X7 BLA02828 FX2 X2+X3 BLA02829 FX7 X4*X6 BLA02830 DX3 X4*X6 BLA02831 FX3 X2+X3 BLA02832 FX2 X3+X7 BLA02833 DX3 X3+X7 (X2,X3) = (X4,X5) * (X6,X7) BLA02834 * BLA02835 BX6 X2 BLA02836 BX7 X3 BLA02837 SA6 TEMP BLA02838 SA7 TEMP+1 TEMP = P2*DB2 BLA02839 * BLA02840 AX6 59 BLA02841 BX2 X6-X2 BLA02842 BX3 X6-X3 (X2,X3) = DABS( P2*DB2 ) BLA02843 * BLA02844 FX6 X2-X0 COMPUTE DABS(P2*DB2) - DABS(P1*DB1). BLA02845 DX7 X2-X0 BLA02846 FX2 X3-X1 BLA02847 NX6 X6 BLA02848 FX0 X2+X7 BLA02849 FX2 X0+X6 BLA02850 NX7 X2 BLA02851 DX0 X0+X6 BLA02852 NX6 X0 BLA02853 FX2 X6+X7 BLA02854 DX3 X6+X7 (X2,X3) = (X2,X3) - (X0,X1) BLA02855 * BLA02856 * BLA02857 NG X2,TWELVE IF( DABS(P1*DB1) .GT. DABS(P2*DB2) ) BLA02858 * GO TO TWELVE BLA02859 * BLA02860 SA2 TEMP (X2,X3) = P2*DB2 BLA02861 SA3 TEMP+1 BLA02862 ZR X2,FOUR BLA02863 NG X2,SIXTN IF( P2*DB2 ) SIXTN,FOUR,TEN BLA02864 * BLA02865 SA2 B3 (X2,X3) = DB1 ITEN BLA02866 SA3 B3+1 BLA02867 SA4 B4 (X4,X5) = DB2 BLA02868 SA5 B4+1 BLA02869 * BLA02870 FX1 X2/X4 (X6,X7) = DB1 / DB2 BLA02871 FX6 X1*X4 BLA02872 FX7 X2-X6 BLA02873 DX6 X2-X6 BLA02874 NX7 X7 BLA02875 FX6 X6+X7 BLA02876 DX7 X1*X4 BLA02877 FX0 X1*X5 BLA02878 FX6 X3+X6 BLA02879 FX6 X6-X7 BLA02880 FX6 X6-X0 BLA02881 FX0 X6/X4 BLA02882 FX6 X0+X1 BLA02883 DX7 X0+X1 BLA02884 NX1 X6 BLA02885 FX6 X1+X7 BLA02886 DX7 X1+X7 (X6,X7) = (X2,X3) / (X4,X5) BLA02887 * BLA02888 SA6 B5+8 (DPARAM(5)) = (X6,X7) BLA02889 SA7 B5+9 (DPARAM(5)) = DB1 / DB2 BLA02890 * BLA02891 SA2 P1 (X2,X3) = P1 BLA02892 SA3 P1+1 BLA02893 SA4 P2 (X4,X5) = P2 BLA02894 SA5 P2+1 BLA02895 * BLA02896 FX1 X2/X4 (X6,X7) = P1 / P2 BLA02897 FX6 X1*X4 BLA02898 FX7 X2-X6 BLA02899 DX6 X2-X6 BLA02900 NX7 X7 BLA02901 FX6 X6+X7 BLA02902 DX7 X1*X4 BLA02903 FX0 X1*X5 BLA02904 FX6 X3+X6 BLA02905 FX6 X6-X7 BLA02906 FX6 X6-X0 BLA02907 FX0 X6/X4 BLA02908 FX6 X0+X1 BLA02909 DX7 X0+X1 BLA02910 NX1 X6 BLA02911 FX6 X1+X7 BLA02912 DX7 X1+X7 (X6,X7) = (X2,X3) / (X4,X5) BLA02913 * BLA02914 SA6 B5+2 (DPARAM(2)) = (X6,X7) BLA02915 SA7 B5+3 (DPARAM(2)) = P1 / P2 BLA02916 * BLA02917 SA4 B5+8 (X4,X5) = B5+8 BLA02918 SA5 B5+9 BLA02919 * BLA02920 FX1 X4*X7 (X1,X2) = DPARAM(2) * DPARAM(5) BLA02921 FX2 X5*X6 BLA02922 FX1 X1+X2 BLA02923 DX2 X4*X6 BLA02924 FX0 X4*X6 BLA02925 FX1 X1+X2 BLA02926 DX2 X0+X1 BLA02927 FX1 X0+X1 (X1,X2) = (X4,X5) * (X6,X7) BLA02928 * BLA02929 SA3 UNIT (X3) = +1. BLA02930 * BLA02931 FX6 X1+X3 (X4,X5) = 1.D0 + (DPARAM(2)*DPARAM(5)) BLA02932 DX7 X1+X3 BLA02933 NX6 X6 BLA02934 FX5 X2+X7 BLA02935 FX4 X5+X6 BLA02936 NX7 X4 BLA02937 DX5 X5+X6 BLA02938 NX6 X5 BLA02939 FX4 X6+X7 BLA02940 DX5 X6+X7 (X4,X5) = (X3,0) + (X1,X2) IU BLA02941 * BLA02942 SA1 B4 (X1,X2) = DB2 BLA02943 SA2 B4+1 BLA02944 * BLA02945 FX6 X1*X5 (X6,X7) = DB2 * U BLA02946 FX7 X2*X4 BLA02947 FX6 X6+X7 BLA02948 DX7 X1*X4 BLA02949 FX0 X1*X4 BLA02950 FX7 X6+X7 BLA02951 FX6 X0+X7 BLA02952 DX7 X0+X7 (X6,X7) = (X1,X2) * (X4,X5) BLA02953 * BLA02954 SA6 B3 (DB1) = (X6,X7) BLA02955 SA7 B3+1 (DB1) = DB2 * U BLA02956 * BLA02957 FX7 X3/X4 (X0,X1) = 1.D0 / U BLA02958 FX0 X4*X7 BLA02959 FX1 X3-X0 BLA02960 DX0 X3-X0 BLA02961 NX1 X1 BLA02962 FX0 X0+X1 BLA02963 DX1 X4*X7 BLA02964 FX6 X5*X7 BLA02965 FX0 X0-X1 BLA02966 FX0 X0-X6 BLA02967 FX6 X0/X4 BLA02968 FX0 X6+X7 BLA02969 DX1 X6+X7 BLA02970 NX7 X0 BLA02971 FX0 X1+X7 BLA02972 DX1 X1+X7 (X0,X1) = (X3,0) / (X4,X5) BLA02973 * BLA02974 SA2 B2 (X2,X3) = DD2 BLA02975 SA3 B2+1 BLA02976 * BLA02977 FX6 X1*X2 (X6,X7) = DD2 * (1.D0/U) BLA02978 FX7 X0*X3 BLA02979 FX6 X6+X7 BLA02980 DX7 X0*X2 BLA02981 FX4 X0*X2 BLA02982 FX7 X6+X7 BLA02983 FX6 X4+X7 BLA02984 DX7 X4+X7 (X6,X7) = (X0,X1) * (X2,X3) IZ BLA02985 * BLA02986 SA4 B1 (X4,X5) = DD1 BLA02987 SA5 B1+1 BLA02988 * BLA02989 SA6 A4 (DD1) = (X6,X7) BLA02990 SA7 A5 (DD1) = DD2 * (1.D0/U) = Z BLA02991 * BLA02992 FX2 X1*X4 (X6,X7) = DD1 * (1.D0/U) BLA02993 FX3 X0*X5 BLA02994 FX2 X2+X3 BLA02995 DX3 X0*X4 BLA02996 FX7 X0*X4 BLA02997 FX3 X2+X3 BLA02998 FX6 X3+X7 BLA02999 DX7 X3+X7 (X6,X7) = (X0,X1) * (X4,X5) BLA03000 * BLA03001 SA6 A2 (DD2) = (X6,X7) BLA03002 SA7 A3 (DD2) = DD1 * (1.D0/U) BLA03003 SA1 UNIT BLA03004 MX7 0 BLA03005 BX6 X1 BLA03006 SA7 B5+1 BLA03007 SA6 B5 BLA03008 * BLA03009 EQ TWENTY4 GO TO TWENTY4 BLA03010 FOUR SA1 RTWO (X1) = 2.0 BLA03011 MX7 0 (X7) = 0.0 BLA03012 BX6 -X1 (X6) = -(X1) BLA03013 SA7 B5+1 BLA03014 SA6 B5 DPARAM(1) = -2.0 BLA03015 EQ OUT GO TO OUT BLA03016 * BLA03017 * BLA03018 TWELVE SA2 B3 (X2,X3) = DB1 BLA03019 SA3 B3+1 BLA03020 SA4 B4 (X4,X5) = DB2 BLA03021 SA5 B4+1 BLA03022 * BLA03023 FX1 X4/X2 (X6,X7) = DB2 / DB1 BLA03024 FX6 X1*X2 BLA03025 FX7 X4-X6 BLA03026 DX6 X4-X6 BLA03027 NX7 X7 BLA03028 FX6 X6+X7 BLA03029 DX7 X1*X2 BLA03030 FX0 X1*X3 BLA03031 FX6 X5+X6 BLA03032 FX6 X6-X7 BLA03033 FX6 X6-X0 BLA03034 FX0 X6/X2 BLA03035 FX6 X0+X1 BLA03036 DX7 X0+X1 BLA03037 NX1 X6 BLA03038 FX6 X1+X7 BLA03039 DX7 X1+X7 (X6,X7) = (X4,X5) / (X2,X3) BLA03040 * BLA03041 BX6 -X6 (X6,X7) = -DB2/DB1 BLA03042 BX7 -X7 BLA03043 * BLA03044 SA6 B5+4 (DPARAM(3)) = (X6,X7) BLA03045 SA7 B5+5 = - DB2 / DB1 BLA03046 * BLA03047 SA2 P2 (X2,X3) = P2 BLA03048 SA3 P2+1 BLA03049 SA4 P1 (X4,X5) = P1 BLA03050 SA5 P1+1 BLA03051 * BLA03052 FX1 X2/X4 (X6,X7) = P2 / P1 BLA03053 FX6 X1*X4 BLA03054 FX7 X2-X6 BLA03055 DX6 X2-X6 BLA03056 NX7 X7 BLA03057 FX6 X6+X7 BLA03058 DX7 X1*X4 BLA03059 FX0 X1*X5 BLA03060 FX6 X3+X6 BLA03061 FX6 X6-X7 BLA03062 FX6 X6-X0 BLA03063 FX0 X6/X4 BLA03064 FX6 X0+X1 BLA03065 DX7 X0+X1 BLA03066 NX1 X6 BLA03067 FX6 X1+X7 BLA03068 DX7 X1+X7 (X6,X7) = (X2,X3) / (X4,X5) BLA03069 * BLA03070 SA6 B5+6 (DPARAM(4) = (X6,X7) BLA03071 SA7 B5+7 (DPARAM(4) = P2 / P1 BLA03072 * BLA03073 SA4 B5+4 (X4,X5) = DPARAM(3) BLA03074 SA5 B5+5 BLA03075 * BLA03076 FX1 X4*X7 (X1,X2) = DPARAM(4) * DPARAM(3) BLA03077 FX2 X5*X6 BLA03078 FX1 X1+X2 BLA03079 DX2 X4*X6 BLA03080 FX0 X4*X6 BLA03081 FX1 X1+X2 BLA03082 DX2 X0+X1 BLA03083 FX1 X0+X1 (X1,X2) = (X4,X5) * (X6,X7) BLA03084 * BLA03085 SA3 UNIT (X3) = +1. BLA03086 * BLA03087 FX6 X3-X1 (X4,X5) = 1.D0 - (DPARAM(4)*DPARAM(3)) BLA03088 DX7 X3-X1 BLA03089 NX6 X6 BLA03090 FX5 X7-X2 BLA03091 FX4 X5+X6 BLA03092 NX7 X4 BLA03093 DX5 X5+X6 BLA03094 NX6 X5 BLA03095 FX4 X6+X7 BLA03096 DX5 X6+X7 (X4,X5) = (X3,0) - (X1,X2) IU BLA03097 * BLA03098 * INSERT IF(U .LE. TOL) GO TO 16 HERE BLA03099 ZR X4,SIXTN BLA03100 SA1 B3 (X1,X2) = DB1 BLA03101 SA2 B3+1 BLA03102 * BLA03103 FX6 X1*X5 (X6,X7) = DB1 * U BLA03104 FX7 X2*X4 BLA03105 FX6 X6+X7 BLA03106 DX7 X1*X4 BLA03107 FX0 X1*X4 BLA03108 FX7 X6+X7 BLA03109 FX6 X0+X7 BLA03110 DX7 X0+X7 (X6,X7) = (X1,X2) * (X4,X5) BLA03111 * BLA03112 SA6 A1 (DB1) = (X6,X7) BLA03113 SA7 A2 (DB1) = DB1 * U BLA03114 * BLA03115 FX7 X3/X4 (X0,X1) = 1.D0 / U BLA03116 FX0 X4*X7 BLA03117 FX1 X3-X0 BLA03118 DX0 X3-X0 BLA03119 NX1 X1 BLA03120 FX0 X0+X1 BLA03121 DX1 X4*X7 BLA03122 FX6 X5*X7 BLA03123 FX0 X0-X1 BLA03124 FX0 X0-X6 BLA03125 FX6 X0/X4 BLA03126 FX0 X6+X7 BLA03127 DX1 X6+X7 BLA03128 NX7 X0 BLA03129 FX0 X1+X7 BLA03130 DX1 X1+X7 (X0,X1) = (X3,0) / (X4,X5) BLA03131 * BLA03132 SA2 B1 (X2,X3) = DD1 BLA03133 SA3 B1+1 BLA03134 * BLA03135 FX6 X1*X2 (X6,X7) = DD1 * (1.D0/U) BLA03136 FX7 X0*X3 BLA03137 FX6 X6+X7 BLA03138 DX7 X0*X2 BLA03139 FX4 X0*X2 BLA03140 FX7 X6+X7 BLA03141 FX6 X4+X7 BLA03142 DX7 X4+X7 (X6,X7) = (X0,X1) * (X2,X3) BLA03143 * BLA03144 SA6 A2 (DD1) = (X6,X7) BLA03145 SA7 A3 (DD1) = DD1 / U BLA03146 * BLA03147 SA4 B2 (X4,X5) = DD2 BLA03148 SA5 B2+1 BLA03149 * BLA03150 FX6 X1*X4 (X6,X7) = DD2 * (1.D0/U) BLA03151 FX7 X0*X5 BLA03152 FX6 X6+X7 BLA03153 DX7 X0*X4 BLA03154 FX2 X0*X4 BLA03155 FX7 X6+X7 BLA03156 FX6 X2+X7 BLA03157 DX7 X2+X7 (X6,X7) = (X0,X1) * (X4,X5) BLA03158 * BLA03159 SA6 A4 (DD2) = (X6,X7) BLA03160 SA7 A5 (DD2) = DD2 / U BLA03161 MX6 0 BLA03162 BX7 X6 BLA03163 SA6 B5 BLA03164 SA7 B5+1 BLA03165 * BLA03166 EQ TWENTY4 BLA03167 * BLA03168 * BLA03169 * BLA03170 * HERE WHEN U IS ZERO OR NEARLY ZERO. BLA03171 * ALSO WHEN D1 IS NEGATIVE AND BLA03172 * DABS(D1*B1**2) .LE. DABS(D2*B2**2) BLA03173 * SINCE IN SUCH A CASE U SHOULD BE SMALL. BLA03174 * BLA03175 * BLA03176 SIXTN SA5 UNIT (X5) = +1.0 BLA03177 MX4 0 (X4) = 0.0 BLA03178 BX7 X4 (X7) = 0.0 BLA03179 BX6 -X5 (X6) = -X5 BLA03180 SA6 B5 (SPARAM(1)) = (X6,X7) = -1.0D BLA03181 SA7 B5+1 BLA03182 BX6 X7 (X6,X7) = 0.0D BLA03183 SA6 B5+2 (SPARAM(2)) = 0.0D BLA03184 SA7 B5+3 BLA03185 SA6 B5+4 (SPARAM(3)) = 0.0D BLA03186 SA7 B5+5 BLA03187 SA6 B5+6 (SPARAM(4)) = 0.0D BLA03188 SA7 B5+7 BLA03189 SA6 B5+8 (SPARAM(5)) = 0.0D BLA03190 SA7 B5+9 BLA03191 * BLA03192 SA6 B1 DD1 = 0.0D BLA03193 SA7 B1+1 BLA03194 SA6 B2 DD2 = 0.0D BLA03195 SA7 B2+1 BLA03196 SA6 B3 DB1 = 0.0D BLA03197 SA7 B3+1 BLA03198 * BLA03199 EQ OUT GO TO OUT BLA03200 * BLA03201 * BLA03202 * HERE TO RESCALE IF NECESSARY TO KEEP BLA03203 * DD1 AND DD2 BETWEEN BIG AND 1/BIG BLA03204 * IF NONZERO BLA03205 * BLA03206 * BLA03207 TWENTY4 SA3 B1 (X3,X4) = DD1 BLA03208 SA4 B1+1 BLA03209 SA5 BIGINV (X5,) = BIGINV BLA03210 BX0 X3 BLA03211 AX0 59 BLA03212 BX0 X0-X3 (X0,) = DABS(DD1) BLA03213 FX0 X5-X0 IF ( DABS(DD1) .GT. BIGINV ) GO TO 36 BLA03214 NX0 X0 BLA03215 NG X0,THIRTY6 BLA03216 ZR X3,FOURTY8 IF (DD1) 28,48,28 BLA03217 SA1 B5 (X1,) = DPARAM(1) I28 BLA03218 SA2 UNIT BLA03219 ZR X1,A84 IF (DPARAM(1)) 96,84,88(A) BLA03220 NG X1,A96 BLA03221 BX6 X2 IA88 BLA03222 MX7 0 BLA03223 SA6 B5+6 DPARAM(4) = 1.0 BLA03224 SA7 B5+7 BLA03225 BX6 -X6 BLA03226 SA6 B5+4 DPARAM(3) = -1.0 BLA03227 SA7 B5+5 BLA03228 EQ A92 GO TO 92(A) BLA03229 A84 BX6 X2 BLA03230 MX7 0 BLA03231 SA6 B5+2 DPARAM(2) = 1.0 BLA03232 SA7 B5+3 BLA03233 SA6 B5+8 DPARAM(5) = 1.0 BLA03234 SA7 B5+9 BLA03235 BX6 -X6 BLA03236 A92 SA7 B5+1 DPARAM(1) = -1.0 BLA03237 SA6 B5 BLA03238 A96 SA5 BIG (X5,) = BIG BLA03239 FX1 X4*X5 DD1 = DD1 * (SQRBIG*SQRBIG) BLA03240 DX7 X3*X5 BLA03241 FX6 X3*X5 BLA03242 FX1 X1+X7 BLA03243 DX7 X1+X6 BLA03244 FX6 X1+X6 (X6,X7) = (X3,X4) * (X5,0) BLA03245 SA7 B1+1 DD1 = (X6,X7) BLA03246 SA6 B1 BLA03247 SA2 B3 (X2,X3) = DB1 BLA03248 SA3 B3+1 BLA03249 SA4 SQRBIGI (X4,) = SQRBIGI BLA03250 FX1 X3*X4 (X6,X7) = DB1/SQRBIG BLA03251 DX7 X2*X4 BLA03252 FX6 X2*X4 BLA03253 FX1 X1+X7 BLA03254 DX7 X1+X6 BLA03255 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03256 SA7 B3+1 DB1 = (X6,X7) BLA03257 SA6 B3 BLA03258 SA2 B5+2 (X2,X3) = DPARAM(2) BLA03259 SA3 B5+3 BLA03260 FX1 X3*X4 (X6,X7) = DPARAM(2)/SQRBIG BLA03261 DX7 X2*X4 BLA03262 FX6 X2*X4 BLA03263 FX1 X1+X7 BLA03264 DX7 X1+X6 BLA03265 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03266 SA7 B5+3 DPARAM(2) = (X6,X7) BLA03267 SA6 B5+2 BLA03268 SA2 B5+6 (X2,X3) = DPARAM(4) BLA03269 SA3 B5+7 BLA03270 FX1 X3*X4 (X6,X7) = DPARAM(4)/SQRBIG BLA03271 DX7 X2*X4 BLA03272 FX6 X2*X4 BLA03273 FX1 X1+X7 BLA03274 DX7 X1+X6 BLA03275 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03276 SA7 B5+7 DPARAM(4) = (X6,X7) BLA03277 SA6 B5+6 BLA03278 EQ TWENTY4 GO TO 24 BLA03279 THIRTY6 SA3 B1 (X3,X4) = DD1 BLA03280 SA4 B1+1 BLA03281 SA5 BIG (X5,) = BIG BLA03282 BX0 X3 BLA03283 AX0 59 BLA03284 BX0 X0-X3 (X0,) = DABS(DD1) BLA03285 FX0 X0-X5 IF ( DABS(DD1) .LT. BIG ) GO TO 48 BLA03286 NX0 X0 BLA03287 NG X0,FOURTY8 BLA03288 SA1 B5 (X1,) = DPARAM(1) BLA03289 SA2 UNIT BLA03290 ZR X1,B84 IF (DPARAM(1)) 96,84,88(B) BLA03291 NG X1,B96 BLA03292 BX6 X2 IB88 BLA03293 MX7 0 BLA03294 SA6 B5+6 DPARAM(4) = 1.0 BLA03295 SA7 B5+7 BLA03296 BX6 -X6 BLA03297 SA6 B5+4 DPARAM(3) = -1.0 BLA03298 SA7 B5+5 BLA03299 EQ B92 GO TO 92(B) BLA03300 B84 BX6 X2 BLA03301 MX7 0 BLA03302 SA6 B5+2 DPARAM(2) = 1.0 BLA03303 SA7 B5+3 BLA03304 SA6 B5+8 DPARAM(5) = 1.0 BLA03305 SA7 B5+9 BLA03306 BX6 -X6 BLA03307 B92 SA7 B5+1 DPARAM(1) = -1.0 BLA03308 SA6 B5 BLA03309 B96 SA5 BIGINV (X5,) = BIGINV BLA03310 FX1 X4*X5 DD1 = DD1 / (SQRBIG*SQRBIG) BLA03311 DX7 X3*X5 BLA03312 FX6 X3*X5 BLA03313 FX1 X1+X7 BLA03314 DX7 X1+X6 BLA03315 FX6 X1+X6 (X6,X7) = (X3,X4) * (X5,0) BLA03316 SA7 B1+1 DD1 = (X6,X7) BLA03317 SA6 B1 BLA03318 SA2 B3 (X2,X3) = DB1 BLA03319 SA3 B3+1 BLA03320 SA4 SQRBIG (X4,) = SQRBIG BLA03321 FX1 X3*X4 (X6,X7) = DB1*SQRBIG BLA03322 DX7 X2*X4 BLA03323 FX6 X2*X4 BLA03324 FX1 X1+X7 BLA03325 DX7 X1+X6 BLA03326 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03327 SA7 B3+1 DB1 = (X6,X7) BLA03328 SA6 B3 BLA03329 SA2 B5+2 (X2,X3) = DPARAM(2) BLA03330 SA3 B5+3 BLA03331 FX1 X3*X4 (X6,X7) = DPARAM(2)*SQRBIG BLA03332 DX7 X2*X4 BLA03333 FX6 X2*X4 BLA03334 FX1 X1+X7 BLA03335 DX7 X1+X6 BLA03336 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03337 SA7 B5+3 DPARAM(2) = (X6,X7) BLA03338 SA6 B5+2 BLA03339 SA2 B5+6 (X2,X3) = DPARAM(4) BLA03340 SA3 B5+7 BLA03341 FX1 X3*X4 (X6,X7) = DPARAM(4)*SQRBIG BLA03342 DX7 X2*X4 BLA03343 FX6 X2*X4 BLA03344 FX1 X1+X7 BLA03345 DX7 X1+X6 BLA03346 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03347 SA7 B5+7 DPARAM(4) = (X6,X7) BLA03348 SA6 B5+6 BLA03349 EQ THIRTY6 GO TO 36 BLA03350 FOURTY8 SA3 B2 (X3,X4) = DD2 BLA03351 SA4 B2+1 BLA03352 SA5 BIGINV (X5,) = BIGINV BLA03353 BX0 X3 BLA03354 AX0 59 BLA03355 BX0 X0-X3 (X0,) = DABS(DD2) BLA03356 FX0 X5-X0 IF ( DABS(DD2) .GT. BIGINV ) GO TO 60 BLA03357 NX0 X0 BLA03358 NG X0,SIXTY BLA03359 ZR X3,OUT IF(DD2 .EQ. 0.0) GO TO OUT BLA03360 SA1 B5 (X1,) = DPARAM(1) BLA03361 SA2 UNIT BLA03362 ZR X1,C84 IF (DPARAM(1)) 96,84,88(C) BLA03363 NG X1,C96 BLA03364 BX6 X2 IC88 BLA03365 MX7 0 BLA03366 SA6 B5+6 DPARAM(4) = 1.0 BLA03367 SA7 B5+7 BLA03368 BX6 -X6 BLA03369 SA6 B5+4 DPARAM(3) = -1.0 BLA03370 SA7 B5+5 BLA03371 EQ C92 GO TO 92(C) BLA03372 C84 BX6 X2 BLA03373 MX7 0 BLA03374 SA6 B5+2 DPARAM(2) = 1.0 BLA03375 SA7 B5+3 BLA03376 SA6 B5+8 DPARAM(5) = 1.0 BLA03377 SA7 B5+9 BLA03378 BX6 -X6 BLA03379 C92 SA7 B5+1 DPARAM(1) = -1.0 BLA03380 SA6 B5 BLA03381 C96 SA5 BIG (X5,) = BIG BLA03382 FX1 X4*X5 DD2 = DD2 * (SQRBIG*SQRBIG) BLA03383 DX7 X3*X5 BLA03384 FX6 X3*X5 BLA03385 FX1 X1+X7 BLA03386 DX7 X1+X6 BLA03387 FX6 X1+X6 (X6,X7) = (X3,X4) * (X5,0) BLA03388 SA7 B2+1 DD2 = (X6,X7) BLA03389 SA6 B2 BLA03390 SA2 B5+4 (X2,X3) = DPARAM(3) BLA03391 SA3 B5+5 BLA03392 SA4 SQRBIGI (X4,) = SQRBIGI BLA03393 FX1 X3*X4 (X6,X7) = DPARAM(3)/SQRBIG BLA03394 DX7 X2*X4 BLA03395 FX6 X2*X4 BLA03396 FX1 X1+X7 BLA03397 DX7 X1+X6 BLA03398 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03399 SA7 B5+5 DPARAM(3) = (X6,X7) BLA03400 SA6 B5+4 BLA03401 SA2 B5+8 (X2,X3) = DPARAM(5) BLA03402 SA3 B5+9 BLA03403 FX1 X3*X4 (X6,X7) = DPARAM(5)/SQRBIG BLA03404 DX7 X2*X4 BLA03405 FX6 X2*X4 BLA03406 FX1 X1+X7 BLA03407 DX7 X1+X6 BLA03408 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03409 SA7 B5+9 DPARAM(5) = (X6,X7) BLA03410 SA6 B5+8 BLA03411 EQ FOURTY8 GO TO 48 BLA03412 SIXTY SA3 B2 (X3,X4) = DD2 BLA03413 SA4 B2+1 BLA03414 SA5 BIG (X5,) = BIG BLA03415 BX0 X3 BLA03416 AX0 59 BLA03417 BX0 X0-X3 (X0,) = DABS(DD2) BLA03418 FX0 X0-X5 IF ( DABS(DD2) .LT. BIG ) RETURN BLA03419 NX0 X0 BLA03420 NG X0,OUT GO TO OUT BLA03421 SA1 B5 (X1,) = DPARAM(1) BLA03422 SA2 UNIT BLA03423 ZR X1,D84 IF (DPARAM(1)) 96,84,88(D) BLA03424 NG X1,D96 BLA03425 BX6 X2 ID88 BLA03426 MX7 0 BLA03427 SA6 B5+6 DPARAM(4) = 1.0 BLA03428 SA7 B5+7 BLA03429 BX6 -X6 BLA03430 SA6 B5+4 DPARAM(3) = -1.0 BLA03431 SA7 B5+5 BLA03432 EQ D92 GO TO 92(D) BLA03433 D84 BX6 X2 BLA03434 MX7 0 BLA03435 SA6 B5+2 DPARAM(2) = 1.0 BLA03436 SA7 B5+3 BLA03437 SA6 B5+8 DPARAM(5) = 1.0 BLA03438 SA7 B5+9 BLA03439 BX6 -X6 BLA03440 D92 SA7 B5+1 DPARAM(1) = -1.0 BLA03441 SA6 B5 BLA03442 D96 SA5 BIGINV (X5,) = BIGINV BLA03443 FX1 X4*X5 DD2 = DD2 / (SQRBIG*SQRBIG) BLA03444 DX7 X3*X5 BLA03445 FX6 X3*X5 BLA03446 FX1 X1+X7 BLA03447 DX7 X1+X6 BLA03448 FX6 X1+X6 (X6,X7) = (X3,X4) * (X5,0) BLA03449 SA7 B2+1 DD2 = (X6,X7) BLA03450 SA6 B2 BLA03451 SA2 B5+4 (X2,X3) = DPARAM(3) BLA03452 SA3 B5+5 BLA03453 SA4 SQRBIG (X4,) = SQRBIG BLA03454 FX1 X3*X4 (X6,X7) = DPARAM(3)*SQRBIG BLA03455 DX7 X2*X4 BLA03456 FX6 X2*X4 BLA03457 FX1 X1+X7 BLA03458 DX7 X1+X6 BLA03459 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03460 SA7 B5+5 DPARAM(3) = (X6,X7) BLA03461 SA6 B5+4 BLA03462 SA2 B5+8 (X2,X3) = DPARAM(5) BLA03463 SA3 B5+9 BLA03464 FX1 X3*X4 (X6,X7) = DPARAM(5)*SQRBIG BLA03465 DX7 X2*X4 BLA03466 FX6 X2*X4 BLA03467 FX1 X1+X7 BLA03468 DX7 X1+X6 BLA03469 FX6 X1+X6 (X6,X7) = (X2,X3) * (X4,0) BLA03470 SA7 B5+9 DPARAM(5) = (X6,X7) BLA03471 SA6 B5+8 BLA03472 EQ SIXTY GO TO 60 BLA03473 OUT OUTFTN DROTMG RETURN BLA03474 * BLA03475 P1 BSS 2 BLA03476 P2 BSS 2 BLA03477 TEMP BSS 2 BLA03478 BIG DATA 17504000000000000000B BLA03479 BIGINV DATA 16704000000000000000B BLA03480 RTWO DATA 17214000000000000000B BLA03481 SQRBIG DATA 17344000000000000000B BLA03482 SQRBIGI DATA 17044000000000000000B BLA03483 TOL DATA 0.0 BLA03484 UNIT DATA 17204000000000000000B BLA03485 * BLA03486 END BLA03487 *DECK,SROTM BLA03488 IDENT SROTM BLA03489 * BLA03490 *** USE WITH FORTRAN STATEMENT BLA03491 * BLA03492 * CALL SROTM(N,SX,INCX,SY,INCY,SPARAM) BLA03493 * BLA03494 * APPLY THE TWO-MULTIPLY,TWO-ADD,GIVENS TRANSFORMATION BLA03495 * BLA03496 * TO 2XN MATRIX (SXI1 ... SXIN ) BLA03497 * (SYI1 ... SYIN ) BLA03498 * BLA03499 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA03500 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA03501 * BLA03502 * SIMILAR DEFINITIONS FOR SYII BLA03503 * BLA03504 * CONTENTS OF SPARAM( ) MUST BE PREVIOUSLY DEFINED BY BLA03505 * SROTMG BLA03506 * BLA03507 * SPARAM(1) = FLAG , INDICATES THE FORM OF THE MATRIX H BLA03508 * SPARAM(2) = H11 BLA03509 * SPARAM(3) = H21 BLA03510 * SPARAM(4) = H12 BLA03511 * SPARAM(5) = H22 BLA03512 * BLA03513 * THE FLAG VALUES AND THE CORRESPONDING FORMS OF THE MATRIX H BLA03514 * -2. (1 0) -1. (H11 H12) 0. ( 1 H12) 1. (H11 1 ) BLA03515 * (0 1) (H21 H22) (H21 1 ) (-1 H22) BLA03516 * BLA03517 * BLA03518 * SX( ),SY( ) SINGLE PRECISION BLA03519 * N,INCX,INCY INTEGER TYPE BLA03520 * SPARAM( ) SINGLE PRECISION BLA03521 * BLA03522 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA03523 * BLA03524 * WRITTEN BY RICHARD J. HANSON BLA03525 * SANDIA LABORATORIES BLA03526 * ALBUQUERQUE, NEW MEXICO BLA03527 *** 1 JUNE 77 BLA03528 * BLA03529 ENTRY SROTM BLA03530 VFD 42/5HSROTM,18/6 BLA03531 * BLA03532 SROTM DATA 0 BLA03533 INFTN SROTM,6 PROPER LINKAGE (RUN,FTN) MACRO BLA03534 * BLA03535 SA1 B1 (X1)=N BLA03536 SB7 1 (B7)=1 BLA03537 * BLA03538 SB1 X1 (B1)=N BLA03539 SB1 B1-B7 (B1)=N-1 BLA03540 * BLA03541 MI B1,OUT IF (N .LE. 0), QUIT BLA03542 * BLA03543 * BLA03544 SA1 B2 (X1)=SX(1) BLA03545 SA2 B3 (X2)=INCX BLA03546 * BLA03547 SA3 B4 (X3)=SY(1) BLA03548 SA4 B5 (X4)=INCY BLA03549 SA5 B6 (X5)=SPARAM(1), (A5)=LOC(SPARAM(1)) BLA03550 * BLA03551 ZR B1,INCYNN IF (N .EQ. 1) NO NEED TO TEST FOR NEG. INC.BLA03552 SX0 -B1 (X0)=-(N-1) BLA03553 * BLA03554 * BLA03555 SB2 X2 (B2)=INCX BLA03556 SB3 X4 (B3)=INCY BLA03557 * BLA03558 GE B2,INCXNN IF (INCX .GE. 0) NO ADDRESS FIXUP NEEDED BLA03559 DX2 X0*X2 COMPUTE -(N-1)*INCX BLA03560 SB7 A1 (B7)=LOC(SX(1)) BLA03561 SA1 B7+X2 (X1)=SX(1+(1-N)*INCX),(A1)=LOC(X(1)) BLA03562 * BLA03563 INCXNN GE B3,INCYNN IF (INCY .GE. 0) NO ADDRESS FIXUP NEEDED BLA03564 DX4 X0*X4 COMPUTE -(N-1)*INCY BLA03565 SB7 A3 (B7)=LOC(SY(1)) BLA03566 SA3 B7+X4 (X3)=SY(1+(1-N)*INCY),(A3)=LOC(Y(1)) BLA03567 * BLA03568 INCYNN SB7 1 (B7)=1 BLA03569 SB6 B7 (B6)=I=1 BLA03570 ZR X5,SP1E0 IF (SPARAM(1) .EQ. 0.0) BLA03571 PL X5,SP1E1 IF (SPARAM(1) .EQ. 1.0) BLA03572 SA4 STWO (X4)=2.0 BLA03573 * BLA03574 RX4 X4+X5 (X4)=SPARAM(1)+2.0 BLA03575 NX4 X4 (X4)=NORM.(X4) BLA03576 ZR X4,OUT IF (SPARAM(1) .EQ. -2.0), QUIT BLA03577 * BLA03578 * HERE SPARAM(1)=-1.0. PERFORM (RARELY USED) RESCALING LOOP BLA03579 SA2 A5+1 (X2)=SPARAM(2)=H11 BLA03580 SA4 A5+3 (X4)=SPARAM(4)=H12 BLA03581 BX0 X2 (X0)=H11 BLA03582 SA2 A5+2 (X2)=SPARAM(3)=H21 BLA03583 SA5 A5+4 (X5)=SPARAM(5)=H22 BLA03584 * BLA03585 * APPLY (H11 H12) TO (SX(1) ... SX(N)) BLA03586 * ( ) ( ) BLA03587 * (H21 H22) (SY(1) ... SY(N)) BLA03588 GT B6,B1,CLR IF (I .GT. N-1) CLEAN-UP LOGIC BLA03589 LOOP RX6 X0*X1 (X6)=H11*SX(I) BLA03590 RX7 X1*X2 (X7)=H21*SX(I) BLA03591 RX1 X3*X4 (X1)=H12*SY(I) BLA03592 RX3 X3*X5 (X3)=H22*SY(I) BLA03593 RX6 X1+X6 (X6)=H11*SX(I)+H12*SY(I) BLA03594 * BLA03595 SA1 A1+B2 (X1)=SX(I+1). NEXT ITER. BLA03596 NX6 X6 (X6)=NORM.(X6) BLA03597 RX7 X3+X7 (X7)=H21*SX(I)+H22*SY(I) BLA03598 SA3 A3+B3 (X3)=SY(I+1). NEXT ITER. BLA03599 SA6 A1-B2 SX(I)=(X6) BLA03600 NX7 X7 (X7)=NORM.(X7) BLA03601 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA03602 SA7 A3-B3 SY(I-1)=(X7) BLA03603 * BLA03604 LE B6,B1,LOOP IF (I .LE. N-1) CONTINUE LOOP BLA03605 CLR RX6 X0*X1 (X6)=H11*SX(N) BLA03606 RX7 X1*X2 (X7)=H21*SX(N) BLA03607 RX1 X3*X4 (X1)=H12*SY(N) BLA03608 RX3 X3*X5 (X3)=H22*SY(N) BLA03609 RX6 X1+X6 (X6)=H11*SX(N)+H12*SY(N) BLA03610 RX7 X3+X7 (X7)=H21*SX(N)+H22*SY(N) BLA03611 NX6 X6 (X6)=NORM.(X6) BLA03612 NX7 X7 (X7)=NORM.(X7) BLA03613 SA6 A1 SX(N)=(X6) BLA03614 SA7 A3 SY(N)=(X7) BLA03615 JP OUT QUIT BLA03616 * BLA03617 * APPLY ( 1 H12) TO (SX(1) ... SX(N)) BLA03618 * ( ) ( ) BLA03619 * (H21 1 ) (SY(1) ... SY(N)) BLA03620 SP1E0 SA2 A5+2 (X2)=SPARAM(3)=H21 BLA03621 SA5 A5+3 (X5)=SPARAM(4)=H12 BLA03622 BX0 X2 (X0)=H21 BLA03623 SB1 B1-B7 (B1)=N-2 BLA03624 GT B6,B1,FIXN0 IF (I .GT. N-2) CLEAN-UP LOGIC BLA03625 * BLA03626 LOOP0 SA2 A1+B2 (X2)=SX(I+1) BLA03627 SA4 A3+B3 (X4)=SY(I+1) BLA03628 RX7 X0*X1 (X7)=H21*SX(I) BLA03629 RX6 X3*X5 (X6)=H12*SY(I) BLA03630 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA03631 NO 3 DEAD BLA03632 * BLA03633 RX7 X3+X7 (X7)=SY(I-1)+H21*SX(I-1) BLA03634 RX3 X0*X2 (X3)=H21*SX(I) BLA03635 RX6 X1+X6 (X6)=SX(I-1)+H12*SY(I-1) BLA03636 RX1 X4*X5 (X1)=H12*SY(I) BLA03637 NO 0 DEAD BLA03638 NX7 X7 (X7)=NORM.(X7) BLA03639 RX4 X4+X3 (X2)=SY(I)+H21*SX(I) BLA03640 NX6 X6 (X6)=NORM.(X6) BLA03641 * BLA03642 SA3 A4+B3 (X3)=SY(I+1) NEXT ITERATION BLA03643 SA7 A4-B3 SY(I-1)=(X7) BLA03644 RX2 X1+X2 (X4)=SX(I)+H12*SY(I) BLA03645 SA6 A2-B2 SX(I-1)=(X6) BLA03646 NX7 X4 (X7)=NORM.(X4) BLA03647 SA1 A2+B2 (X1)=SX(I+1) NEXT ITERATION BLA03648 NX6 X2 (X6)=NORM.(X2) BLA03649 NO 0 DEAD BLA03650 SA7 A4 SY(I)=(X7) BLA03651 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA03652 NO 0 DEAD BLA03653 SA6 A2 SX(I-1)=(X6) BLA03654 LE B6,B1,LOOP0 IF (I .LE. N-2) CONTINUE LOOP BLA03655 FIXN0 SB1 B1+B7 (B1)=N-1 BLA03656 SB1 B1+B7 (B1)=N BLA03657 * HERE ONE VECTOR IS PRE-FETCHED. AT MOST TWO COMPS. REMAIN BLA03658 CL0 RX7 X0*X1 (X7)=H21*SX(I) BLA03659 RX6 X3*X5 (X6)=H12*SY(I) BLA03660 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA03661 RX7 X3+X7 (X7)=SY(I-1)+H21*SX(I-1) BLA03662 RX6 X1+X6 (X6)=SX(I-1)+H12*SY(I-1) BLA03663 NX7 X7 (X7)=NORM.(X7) BLA03664 NX6 X6 (X6)=NORM.(X6) BLA03665 SA7 A3 SY(I-1)=(X7) BLA03666 SA6 A1 SX(I-1)=(X6) BLA03667 GT B6,B1,OUT IF (I .GT. N) QUIT BLA03668 SA1 A1+B2 (X1)=SX(I) BLA03669 SA3 A3+B3 (X3)=SY(I) BLA03670 JP CL0 BLA03671 * BLA03672 * APPLY (H11 1 ) TO (SX(1) ... SX(N)) BLA03673 * ( ) ( ) BLA03674 * (-1 H22) (SY(1) ... SY(N)) BLA03675 SP1E1 SA2 A5+1 (X2)=SPARAM(2)=H11 BLA03676 SA5 A5+4 (X5)=SPARAM(5)=H22 BLA03677 BX0 X2 (X0)=H11 BLA03678 SB1 B1-B7 (B1)=N-2 BLA03679 GT B6,B1,FIXN1 IF (I .GT. N-2) CLEAN-UP LOGIC BLA03680 * BLA03681 LOOP1 SA2 A1+B2 (X2)=SX(I+1) BLA03682 SA4 A3+B3 (X4)=SY(I+1) BLA03683 RX7 X3*X5 (X7)=H22*SY(I) BLA03684 RX6 X0*X1 (X6)=H11*SX(I) BLA03685 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA03686 NO 3 DEAD BLA03687 * BLA03688 RX7 X7-X1 (X7)=-SX(I-1)+H22*SY(I-1) BLA03689 RX1 X0*X2 (X1)=H11*SX(I) BLA03690 RX6 X3+X6 (X6)=SY(I-1)+H11*SX(I-1) BLA03691 RX3 X4*X5 (X3)=H22*SY(I) BLA03692 NO 0 DEAD BLA03693 NX7 X7 (X7)=NORM.(X7) BLA03694 RX4 X1+X4 (X4)=SY(I)+H11*SX(I) BLA03695 NX6 X6 (X6)=NORM.(X6) BLA03696 * BLA03697 SA7 A4-B3 SY(I-1)=(X7) BLA03698 RX2 X3-X2 (X2)=-SX(I)+H22*SY(I) BLA03699 SA3 A4+B3 (X3)=SY(I+1) NEXT ITERATION BLA03700 SA6 A2-B2 SX(I-1)=(X6) BLA03701 NX6 X4 (X6)=NORM.(X4) BLA03702 SA1 A2+B2 (X1)=SX(I+1) NEXT ITERATION BLA03703 NO 0 DEAD BLA03704 NX7 X2 (X7)=NORM.(X2) BLA03705 SA6 A2 SX(I)=(X6) BLA03706 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA03707 NO 0 DEAD BLA03708 SA7 A4 SY(I-1)=(X7) BLA03709 LE B6,B1,LOOP1 IF (I .LE. N-2) CONTINUE LOOP BLA03710 FIXN1 SB1 B1+B7 (B1)=N-1 BLA03711 SB1 B1+B7 (B1)=N BLA03712 * HERE ONE VECTOR IS PRE-FETCHED. AT MOST TWO COMPS. REMAIN BLA03713 CL1 RX7 X0*X1 (X7)=H11*SX(I) BLA03714 RX6 X3*X5 (X6)=H22*SY(I) BLA03715 SB6 B6+B7 (B6)=I=I+1. INCREMENT I. BLA03716 RX7 X3+X7 (X7)=SY(I-1)+H11*SX(I-1) BLA03717 RX6 X6-X1 (X6)=-SX(I-1)+H22*SY(I-1) BLA03718 NX7 X7 (X7)=NORM.(X7) BLA03719 NX6 X6 (X6)=NORM.(X6) BLA03720 SA7 A1 SX(I-1)=(X7) BLA03721 SA6 A3 SY(I-1)=(X6) BLA03722 GT B6,B1,OUT IF (I .GT. N), QUIT BLA03723 SA1 A1+B2 (X1)=SX(I) BLA03724 SA3 A3+B3 (X3)=SY(I) BLA03725 JP CL1 BLA03726 * BLA03727 OUT OUTFTN SROTM BLA03728 STWO DATA 2.0 BLA03729 * END SROTM BLA03730 END BLA03731 *DECK,DROTM BLA03732 IDENT DROTM BLA03733 * BLA03734 *** USE WITH FORTRAN STATEMENT BLA03735 * BLA03736 * CALL DROTM(N,DX,INCX,DY,INCY,DPARAM) BLA03737 * BLA03738 * APPLY THE TWO-MULTIPLY,TWO-ADD,GIVENS TRANSFORMATION BLA03739 * BLA03740 * TO 2XN MATRIX (DXI1 ... DXIN ) BLA03741 * (DYI1 ... DYIN ) BLA03742 * BLA03743 * DXII = DX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA03744 * = DX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA03745 * BLA03746 * SIMILAR DEFINITIONS FOR DYII BLA03747 * BLA03748 * CONTENTS OF DPARAM( ) MUST BE PREVIOUSLY DEFINED BY BLA03749 * DROTMG BLA03750 * BLA03751 * DPARAM(1) = FLAG , INDICATES THE FORM OF THE MATRIX H BLA03752 * DPARAM(2) = H11 BLA03753 * DPARAM(3) = H21 BLA03754 * DPARAM(4) = H12 BLA03755 * DPARAM(5) = H22 BLA03756 * BLA03757 * THE FLAG VALUES AND THE CORRESPONDING FORMS OF THE MATRIX H BLA03758 * -2. (1 0) -1. (H11 H12) 0. ( 1 H12) 1. (H11 1 ) BLA03759 * (0 1) (H21 H22) (H21 1 ) (-1 H22) BLA03760 * BLA03761 * BLA03762 * DX( ),DY( ) DOUBLE PRECISION BLA03763 * N,INCX,INCY INTEGER TYPE BLA03764 * DPARAM( ) DOUBLE PRECISION BLA03765 * BLA03766 * WRITTEN BY DAVID R. KINCAID BLA03767 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA03768 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA03769 *** 1 JUNE 77 BLA03770 * BLA03771 ENTRY DROTM BLA03772 VFD 42/5HDROTM,18/6 BLA03773 * BLA03774 DROTM DATA 0 ENTRY/EXIT BLA03775 INFTN DROTM,6 BLA03776 SA1 B1 (X1) = N BLA03777 SB7 -1 (B7) = -1 BLA03778 SB1 X1+B7 (B1) = N-1 BLA03779 * BLA03780 SA3 B3 (X3) = INCX BLA03781 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA03782 SA5 B5 (X5) = INCY BLA03783 SX1 -B1 (X1) = -(N-1) BLA03784 LX3 1 INCX = 2*INCY BLA03785 IX5 X5+X5 INCY = 2*INCY BLA03786 SB3 X3 (B3) = INCX BLA03787 SB5 X5 (B5) = INCY BLA03788 * BLA03789 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA03790 DX3 X1*X3 LOC(DXI1 ) = LOC(DX)-(N-1)*INCX BLA03791 SB2 X3+B2 (B2) = LOC(DXI1 ) BLA03792 * BLA03793 ONE GT B5,TWO IF INCY .GT. 0 ,GO TO TWO BLA03794 DX5 X1*X5 LOC(DYI1 ) = LOC(DY)-(N-1)*INCY BLA03795 SB4 X5+B4 (B4) = LOC(DYI1 ) BLA03796 * BLA03797 TWO SA3 B6 (X3) = DPARAM(1) IFLAG BLA03798 SA2 RTWO (X2) = 2.0 BLA03799 RX2 X3+X2 BLA03800 NX2 X2 BLA03801 ZR X2,OUT IF FLAG .EQ. -2.0 , GO TO OUT BLA03802 * BLA03803 SA1 A3+2 (X1,X2) = DPARAM(2) BLA03804 SA2 A3+3 BLA03805 BX6 X1 (X6,X7) = (X1,X2) BLA03806 BX7 X2 BLA03807 SA6 H11 H11 = (X6,X7) BLA03808 SA7 H11+1 BLA03809 * BLA03810 SA1 A2+1 (X1,X2) = DPARAM(3) BLA03811 SA2 A2+2 BLA03812 BX6 X1 (X6,X7) = (X1,X2) BLA03813 BX7 X2 BLA03814 SA6 H21 H21 = (X6,X7) BLA03815 SA7 H21+1 BLA03816 * BLA03817 SA1 A2+1 (X1,X2) = DPARAM(4) BLA03818 SA2 A2+2 BLA03819 BX6 X1 (X6,X7) = (X1,X2) BLA03820 BX7 X2 BLA03821 SA6 H12 H12 = (X6,X7) BLA03822 SA7 H12+1 BLA03823 * BLA03824 SA1 A2+1 (X1,X2) = DPARAM(5) BLA03825 SA2 A2+2 BLA03826 BX6 X1 (X6,X7) = (X1,X2) BLA03827 BX7 X2 BLA03828 SA6 H22 H22 = (X6,X7) BLA03829 SA7 H22+1 BLA03830 * BLA03831 SB1 B1-B7 (B1) = N BLA03832 ZR X3,LOOP1 IF FLAG .EQ. 0.0, GO TO LOOP1 BLA03833 NG X3,LOOP3 IF FLAG .EQ.-1.0, GO TO LOOP3 BLA03834 EQ LOOP2 IF FLAG .EQ. 1.0, GO TO LOOP2 BLA03835 * BLA03836 * BLA03837 LOOP1 SA1 H12 (X1,X2) = H12 ITEN BLA03838 SA2 H12+1 BLA03839 SA3 B4 (X3,X4) = DYII BLA03840 SA4 B4-B7 BLA03841 * BLA03842 FX5 X2*X3 (X0,X3) = H12*DYII BLA03843 FX0 X1*X4 BLA03844 FX5 X0+X5 BLA03845 FX4 X1*X3 BLA03846 DX0 X1*X3 BLA03847 FX5 X0+X5 BLA03848 FX0 X4+X5 BLA03849 DX3 X4+X5 BLA03850 * BLA03851 SA1 B2 (X1,X2) = DXII BLA03852 SA2 B2-B7 BLA03853 BX6 X1 (X6,X7) = DXII BLA03854 BX7 X2 BLA03855 * BLA03856 FX4 X6+X0 (X6,X7) = (X6,X7)+(X0,X3) BLA03857 DX5 X6+X0 BLA03858 FX0 X7+X3 BLA03859 NX4 X4 BLA03860 FX3 X0+X5 BLA03861 FX0 X3+X4 BLA03862 NX5 X0 BLA03863 DX3 X3+X4 BLA03864 NX4 X3 BLA03865 FX6 X4+X5 BLA03866 DX7 X4+X5 BLA03867 * BLA03868 SA6 A1 DXII = (X6,X7) BLA03869 SA7 A2 BLA03870 * BLA03871 SA3 H21 (X3,X4) = H21 BLA03872 SA4 H21+1 BLA03873 * BLA03874 FX5 X2*X3 (X6,X7) = H21*(X1,X2) BLA03875 FX0 X1*X4 BLA03876 FX5 X0+X5 BLA03877 FX4 X1*X3 BLA03878 DX0 X1*X3 BLA03879 FX5 X0+X5 BLA03880 FX6 X4+X5 BLA03881 DX7 X4+X5 BLA03882 * BLA03883 SA1 B4 (X1,X2) = DYII BLA03884 SA2 B4-B7 BLA03885 * BLA03886 FX4 X6+X1 (X6,X7) = (X6,X7)+(X1,X2) BLA03887 DX5 X6+X1 BLA03888 FX1 X7+X2 BLA03889 NX4 X4 BLA03890 FX2 X1+X5 BLA03891 FX1 X2+X4 BLA03892 NX5 X1 BLA03893 DX2 X2+X4 BLA03894 NX4 X2 BLA03895 FX6 X4+X5 BLA03896 DX7 X4+X5 BLA03897 * BLA03898 SA6 A1 DYII = (X6,X7) BLA03899 SA7 A2 BLA03900 * BLA03901 SB2 B2+B3 (B2) = LOC(DXII+1 ) BLA03902 SB4 B4+B5 (B4) = LOC(DYII+1 ) BLA03903 * BLA03904 SB1 B1+B7 COUNT TERM BLA03905 NZ B1,LOOP1 IF I .NE. N , LOOP1 BLA03906 * BLA03907 EQ OUT GO TO OUT BLA03908 * BLA03909 * BLA03910 * BLA03911 LOOP2 SA1 B2 (X1,X2) = DXII ITHIRTY BLA03912 SA2 B2-B7 BLA03913 SA3 H11 (X3,X4) = H11 BLA03914 SA4 H11+1 BLA03915 * BLA03916 FX5 X2*X3 (X0,X3) = H11*DXII BLA03917 FX0 X1*X4 BLA03918 FX5 X0+X5 BLA03919 FX4 X1*X3 BLA03920 DX0 X1*X3 BLA03921 FX5 X0+X5 BLA03922 FX0 X4+X5 BLA03923 DX3 X4+X5 BLA03924 * BLA03925 SA4 B4 (X4,X5) = DYII BLA03926 SA5 B4-B7 BLA03927 BX6 X4 BLA03928 BX7 X5 (X6,X7) = DYII BLA03929 * BLA03930 FX4 X6+X0 (X6,X7) = (X6,X7)+(X0,X3) BLA03931 DX5 X6+X0 BLA03932 FX0 X7+X3 BLA03933 NX4 X4 BLA03934 FX3 X0+X5 BLA03935 FX0 X3+X4 BLA03936 NX5 X0 BLA03937 DX3 X3+X4 BLA03938 NX4 X3 BLA03939 FX6 X4+X5 BLA03940 DX7 X4+X5 BLA03941 * BLA03942 SA6 A1 DXII = (X6,X7) BLA03943 SA7 A2 BLA03944 * BLA03945 SA3 H22 (X3,X4) = H22 BLA03946 SA4 H22+1 BLA03947 * BLA03948 BX6 X1 (X6,X7) = (X1,X2) ISAVE OLD DX BLA03949 BX7 X2 BLA03950 * BLA03951 SA1 B4 (X1,X2) = DYII BLA03952 SA2 B4-B7 BLA03953 * BLA03954 FX5 X2*X3 (X1,X2) = H22*DYII BLA03955 FX0 X1*X4 BLA03956 FX5 X0+X5 BLA03957 FX4 X1*X3 BLA03958 DX0 X1*X3 BLA03959 FX5 X0+X5 BLA03960 FX1 X4+X5 BLA03961 DX2 X4+X5 BLA03962 * BLA03963 FX4 X1-X6 (X6,X7) = -(X6,X7)+(X1,X2) BLA03964 DX5 X1-X6 BLA03965 FX1 X2-X7 BLA03966 NX4 X4 BLA03967 FX2 X1+X5 BLA03968 FX1 X2+X4 BLA03969 NX5 X1 BLA03970 DX2 X2+X4 BLA03971 NX4 X2 BLA03972 FX6 X4+X5 BLA03973 DX7 X4+X5 BLA03974 * BLA03975 SA6 A1 DYII = (X6,X7) BLA03976 SA7 A2 BLA03977 * BLA03978 SB2 B2+B3 (B2) = LOC(DXII+1 ) BLA03979 SB4 B4+B5 (B4) = LOC(DYII+1 ) BLA03980 * BLA03981 SB1 B1+B7 COUNT TERM BLA03982 NZ B1,LOOP2 IF I .NE. N , LOOP2 BLA03983 * BLA03984 EQ OUT GO TO OUT BLA03985 * BLA03986 * BLA03987 * BLA03988 LOOP3 SA1 B2 (X1,X2) = DXII IFIFTY BLA03989 SA2 B2-B7 BLA03990 SA3 H11 (X3,X4) = H11 BLA03991 SA4 H11+1 BLA03992 * BLA03993 FX5 X2*X3 (X6,X7) = DXII *H11 BLA03994 FX0 X1*X4 BLA03995 FX5 X0+X5 BLA03996 FX4 X1*X3 BLA03997 DX0 X1*X3 BLA03998 FX5 X0+X5 BLA03999 FX6 X4+X5 BLA04000 DX7 X4+X5 BLA04001 * BLA04002 SA1 B4 (X1,X2) = DYII BLA04003 SA2 B4-B7 BLA04004 SA3 H12 (X3,X4) = H12 BLA04005 SA4 H12+1 BLA04006 * BLA04007 FX5 X2*X3 (X1,X2) = DYII *H12 BLA04008 FX0 X1*X4 BLA04009 FX5 X0+X5 BLA04010 FX4 X1*X3 BLA04011 DX0 X1*X3 BLA04012 FX5 X0+X5 BLA04013 FX1 X4+X5 BLA04014 DX2 X4+X5 BLA04015 * BLA04016 FX4 X6+X1 (X6,X7) = (X6,X7)+(X1,X2) BLA04017 DX5 X6+X1 BLA04018 FX1 X7+X2 BLA04019 NX4 X4 BLA04020 FX2 X1+X5 BLA04021 FX1 X2+X4 BLA04022 NX5 X1 BLA04023 DX2 X2+X4 BLA04024 NX4 X2 BLA04025 FX6 X4+X5 BLA04026 DX7 X4+X5 BLA04027 * BLA04028 SA6 DW DW = (X6,X7) BLA04029 SA7 DW+1 BLA04030 * BLA04031 SA1 B2 (X1,X2) = DXII BLA04032 SA2 B2-B7 BLA04033 * BLA04034 SA3 H21 (X3,X4) = H21 BLA04035 SA4 H21+1 BLA04036 * BLA04037 FX5 X2*X3 (X6,X7) = DXII *H21 BLA04038 FX0 X1*X4 BLA04039 FX5 X0+X5 BLA04040 FX4 X1*X3 BLA04041 DX0 X1*X3 BLA04042 FX5 X0+X5 BLA04043 FX6 X4+X5 BLA04044 DX7 X4+X5 BLA04045 * BLA04046 SA1 B4 (X1,X2) = DYII BLA04047 SA2 B4-B7 BLA04048 SA3 H22 (X3,X4) = H22 BLA04049 SA4 H22+1 BLA04050 * BLA04051 FX5 X2*X3 (X1,X2) = DYII *H22 BLA04052 FX0 X1*X4 BLA04053 FX5 X0+X5 BLA04054 FX4 X1*X3 BLA04055 DX0 X1*X3 BLA04056 FX5 X0+X5 BLA04057 FX1 X4+X5 BLA04058 DX2 X4+X5 BLA04059 * BLA04060 * BLA04061 FX4 X6+X1 (X6,X7) = (X6,X7)+(X1,X2) BLA04062 DX5 X6+X1 BLA04063 FX1 X7+X2 BLA04064 NX4 X4 BLA04065 FX2 X1+X5 BLA04066 FX1 X2+X4 BLA04067 NX5 X1 BLA04068 DX2 X2+X4 BLA04069 NX4 X2 BLA04070 FX6 X4+X5 BLA04071 DX7 X4+X5 BLA04072 * BLA04073 SA6 A1 DYII = (X6,X7) BLA04074 SA7 A2 BLA04075 * BLA04076 SA3 DW (X3,X4) = DW BLA04077 SA4 DW+1 BLA04078 BX6 X3 (X6,X7) = (X3,X4) BLA04079 BX7 X4 BLA04080 SA6 B2 DXII = (X6,X7) BLA04081 SA7 B2+1 BLA04082 * BLA04083 SB1 B1+B7 COUNT TERM BLA04084 SB2 B2+B3 (B2) = LOC(DXII+1 ) BLA04085 SB4 B4+B5 (B4) = LOC(DYII+1 ) BLA04086 * BLA04087 NZ B1,LOOP3 IF I .NE. N ,LOOP3 BLA04088 * BLA04089 OUT OUTFTN DROTM RETURN BLA04090 * BLA04091 DW BSS 2 BLA04092 H11 BSS 2 BLA04093 H21 BSS 2 BLA04094 H12 BSS 2 BLA04095 H22 BSS 2 BLA04096 * BLA04097 RTWO DATA 2.0 BLA04098 * BLA04099 END BLA04100 *DECK,SCOPY BLA04101 IDENT SCOPY BLA04102 * BLA04103 *** USE WITH FORTRAN STATEMENT BLA04104 * BLA04105 * CALL SCOPY(N,SX,INCX,SY,INCY) BLA04106 * BLA04107 * COPY VECTOR ELEMENT SXII INTO SYII FOR I=1 TO N BLA04108 * BLA04109 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA04110 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA04111 * BLA04112 * SIMILAR DEFINITIONS FOR SYII BLA04113 * BLA04114 * SX( ),SY( ) SINGLE PRECISION BLA04115 * N,INCX,INCY INTEGER TYPE BLA04116 * BLA04117 * WRITTEN BY DAVID R. KINCAID BLA04118 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04119 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04120 *** 1 JUNE 77 BLA04121 * BLA04122 ENTRY SCOPY BLA04123 VFD 42/5HSCOPY,18/5 BLA04124 * BLA04125 SCOPY DATA 0 ENTRY/EXIT BLA04126 INFTN SCOPY,5 BLA04127 SA1 B1 (X1) = N BLA04128 SB7 -1 (B7) = -1 BLA04129 SB1 X1+B7 (B1) = N-1 BLA04130 * BLA04131 SA3 B3 (X3) = INCX BLA04132 NG B1,OUT IF N .LE. O , GO TO OUT BLA04133 SA5 B5 (X5) = INCY BLA04134 SX1 -B1 (X1) = -(N-1) BLA04135 SB3 X3 (B3) = INCX BLA04136 SB5 X5 (B5) = INCY BLA04137 * BLA04138 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04139 DX3 X1*X3 LOC(SXI1 ) = LOC(SX) - (N-1)*INCX BLA04140 SB2 X3+B2 (B2) = LOC(SXI1 ) BLA04141 * BLA04142 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA04143 DX5 X1*X5 LOC(SYI1 ) = LOC(SY) - (N-1)*INCY BLA04144 SB4 X5+B4 (B4) = LOC(SYI1 ) BLA04145 * BLA04146 * (I = 1) BLA04147 TWO SA2 B2 (X2) = SXI1 BLA04148 SA4 B4 (A4) = LOC(SYI1 ) BLA04149 BX6 X2 BLA04150 SA6 B4 SXI1 TO SYI1 BLA04151 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04152 * BLA04153 * (I = I+1) BLA04154 LOOP SA2 A2+B3 (X2) = SXII BLA04155 SA4 A4+B5 (A4) = LOC(SYII ) BLA04156 BX6 X2 BLA04157 SB1 B1+B7 COUNT TERM BLA04158 SA6 A4 SXII TO SYII BLA04159 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04160 * BLA04161 OUT OUTFTN SCOPY RETURN BLA04162 END BLA04163 *DECK,DCOPY BLA04164 IDENT DCOPY BLA04165 * BLA04166 *** USE WITH FORTRAN STATEMENT BLA04167 * BLA04168 * CALL DCOPY(N,DX,INCX,DY,INCY) BLA04169 * BLA04170 * COPY VECTOR ELEMENT DXII INTO DYII FOR I=1 TO N BLA04171 * BLA04172 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04173 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04174 * BLA04175 * SIMILAR DEFINITIONS FOR DYII BLA04176 * BLA04177 * DX( ),DY( ) DOUBLE PRECISION BLA04178 * N,INCX,INCY INTEGER TYPE BLA04179 * BLA04180 * WRITTEN BY DAVID R.KINCAID BLA04181 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04182 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04183 *** 1 JUNE 77 BLA04184 * BLA04185 ENTRY DCOPY BLA04186 VFD 42/5HDCOPY,18/5 BLA04187 * BLA04188 DCOPY DATA 0 ENTRY/EXIT BLA04189 INFTN DCOPY,5 BLA04190 SA1 B1 (X1) = N BLA04191 SB7 -1 (B7) = -1 BLA04192 SB1 X1+B7 (B1) = N-1 BLA04193 * BLA04194 SA3 B3 (X3) = INCX BLA04195 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04196 SA5 B5 (X5) = INCY BLA04197 SX1 -B1 (X1) = -(N-1) BLA04198 LX3 1 INCX = 2*INCX BLA04199 IX5 X5+X5 INCY = 2*INCY BLA04200 SB3 X3 (B3) = INCX BLA04201 SB5 X5 (B5) = INCY BLA04202 * BLA04203 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04204 DX3 X1*X3 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA04205 SB2 X3+B2 (B2) = LOC(DXI1 ) BLA04206 * BLA04207 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA04208 DX5 X1*X5 LOC(DYI1 ) = LOC(DY) - (N-1)*INCY BLA04209 SB4 X5+B4 (B4) = LOC(DYI1 ) BLA04210 * BLA04211 * (I = 1) BLA04212 TWO SA2 B2 (X2) = DXI1 BLA04213 SA4 B4 (A4) = LOC(DYI1 ) BLA04214 BX6 X2 BLA04215 SA5 B2-B7 (X4,X5) = DXI1 BLA04216 SA6 B4 BLA04217 BX7 X5 BLA04218 SA7 B4-B7 DXI1 TO DYI1 BLA04219 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04220 * BLA04221 * (I = I+1) BLA04222 LOOP SA2 A2+B3 (X2) = DXII BLA04223 SA4 A4+B5 (A4) = LOC(DYII ) BLA04224 BX6 X2 BLA04225 SA5 A2-B7 (X4,X5) = DXII BLA04226 SA6 A4 BLA04227 BX7 X5 BLA04228 SB1 B1+B7 COUNT TERM BLA04229 SA7 A4-B7 DXII TO DYII BLA04230 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04231 * BLA04232 OUT OUTFTN DCOPY RETURN BLA04233 END BLA04234 *DECK,CCOPY BLA04235 IDENT CCOPY BLA04236 * BLA04237 *** USE WITH FORTRAN STATEMENT BLA04238 * BLA04239 * CALL CCOPY(N,CX,INCX,CY,INCY) BLA04240 * BLA04241 * COPY VECTOR ELEMENT CXII INTO CYII FOR I=1 TO N BLA04242 * BLA04243 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04244 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04245 * BLA04246 * SIMILAR DEFINITIONS FOR CYII BLA04247 * BLA04248 * CX( ),CY( ) COMPLEX TYPE BLA04249 * N,INCX,INCY INTEGER TYPE BLA04250 * BLA04251 * WRITTEN BY DAVID R.KINCAID BLA04252 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04253 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04254 *** 1 JUNE 77 BLA04255 * BLA04256 ENTRY CCOPY BLA04257 VFD 42/5HCCOPY,18/5 BLA04258 * BLA04259 CCOPY DATA 0 ENTRY/EXIT BLA04260 INFTN CCOPY,5 BLA04261 SA1 B1 (X1) = N BLA04262 SB7 -1 (B7) = -1 BLA04263 SB1 X1+B7 (B1) = N-1 BLA04264 * BLA04265 SA3 B3 (X3) = INCX BLA04266 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04267 SA5 B5 (X5) = INCY BLA04268 SX1 -B1 (X1) = -(N-1) BLA04269 LX3 1 INCX = 2*INCX BLA04270 IX5 X5+X5 INCY = 2*INCY BLA04271 SB3 X3 (B3) = INCX BLA04272 SB5 X5 (B5) = INCY BLA04273 * BLA04274 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04275 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA04276 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA04277 * BLA04278 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA04279 DX5 X1*X5 LOC(CYI1 ) = LOC(CY) - (N-1)*INCY BLA04280 SB4 X5+B4 (B4) = LOC(CYI1 ) BLA04281 * BLA04282 * (I = 1) BLA04283 TWO SA2 B2 (X2) = CXI1 BLA04284 SA4 B4 (A4) = LOC(CYI1 ) BLA04285 BX6 X2 BLA04286 SA5 B2-B7 (X4,X5) = CXI1 BLA04287 SA6 B4 BLA04288 BX7 X5 BLA04289 SA7 B4-B7 CXI1 TO CYII BLA04290 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04291 * BLA04292 * (I = I+1) BLA04293 LOOP SA2 A2+B3 (X2) = CXII BLA04294 SA4 A4+B5 (A4) = LOC(CYII ) BLA04295 BX6 X2 BLA04296 SA5 A2-B7 (X4,X5) = CXII BLA04297 SA6 A4 BLA04298 BX7 X5 BLA04299 SB1 B1+B7 COUNT TERM BLA04300 SA7 A4-B7 CXII TO CYII BLA04301 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04302 * BLA04303 OUT OUTFTN CCOPY RETURN BLA04304 END BLA04305 *DECK,SSWAP BLA04306 IDENT SSWAP BLA04307 * BLA04308 *** USE WITH FORTRAN STATEMENT BLA04309 * BLA04310 * CALL SSWAP(N,SX,INCX,SY,INCY) BLA04311 * BLA04312 * INTERCHANGE VECTOR ELEMENTS SXII AND SYII FOR I=1 TO N BLA04313 * BLA04314 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA04315 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA04316 * BLA04317 * SIMILAR DEFINITIONS FOR SYII BLA04318 * BLA04319 * SX( ),SY( ) SINGLE PRECISION BLA04320 * N,INCX,INCY INTEGER TYPE BLA04321 * BLA04322 * WRITTEN BY DAVID R. KINCAID BLA04323 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04324 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04325 *** 1 JUNE 77 BLA04326 * BLA04327 ENTRY SSWAP BLA04328 VFD 42/5HSSWAP,18/5 BLA04329 * BLA04330 SSWAP DATA 0 ENTRY/EXIT BLA04331 INFTN SSWAP,5 BLA04332 SA1 B1 (X1) = N BLA04333 SB7 -1 (B7) = -1 BLA04334 SB1 X1+B7 (B1) = N-1 BLA04335 * BLA04336 SA3 B3 (X3) = INCX BLA04337 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04338 SA5 B5 (X5) = INCY BLA04339 SX1 -B1 (X1) = -(N-1) BLA04340 SB3 X3 (B3) = INCX BLA04341 SB5 X5 (B5) = INCY BLA04342 * BLA04343 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04344 DX3 X1*X3 LOC(XI1 ) = LOC(SX) - (N-1)*INCX BLA04345 SB2 X3+B2 (B2) = LOC(SXI1 ) BLA04346 * BLA04347 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA04348 DX5 X1*X5 LOC(YI1 ) = LOC(SY) - (N-1)*INCY BLA04349 SB4 X5+B4 (B4) = LOC(SYI1 ) BLA04350 * BLA04351 * (I = 1) BLA04352 TWO SA2 B2 (X2) = SXI1 BLA04353 SA4 B4 (X4) = SYI1 BLA04354 BX6 X2 (X6) = (X2) BLA04355 BX7 X4 (X7) = (X4) BLA04356 SA6 B4 SXI1 TO SYI1 BLA04357 SA7 B2 SYI1 TO SXI1 BLA04358 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04359 * BLA04360 * (I = I+1) BLA04361 LOOP SA2 A2+B3 (X2) = SXII BLA04362 SA4 A4+B5 (X4) = SYII BLA04363 BX6 X2 (X6) = (X2) BLA04364 BX7 X4 (X7) = (X4) BLA04365 SB1 B1+B7 COUNT TERM BLA04366 SA6 A4 SXII TO SYII BLA04367 SA7 A2 SYII TO SXII BLA04368 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04369 * BLA04370 OUT OUTFTN SSWAP RETURN BLA04371 END BLA04372 *DECK,DSWAP BLA04373 IDENT DSWAP BLA04374 * BLA04375 *** USE WITH FORTRAN STATEMENT BLA04376 * BLA04377 * CALL DSWAP(N,DX,INCX,DY,INCY) BLA04378 * BLA04379 * INTERCHANGE VECTOR ELEMENTS DXII AND DYII FOR I=1 TO N BLA04380 * BLA04381 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04382 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04383 * BLA04384 * SIMILAR DEFINITIONS FOR DYII BLA04385 * BLA04386 * DX( ),DY( ) DOUBLE PRECISION BLA04387 * N,INCX,INCY INTEGER TYPE BLA04388 * BLA04389 * WRITTEN BY DAVID R. KINCAID BLA04390 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04391 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04392 *** 1 JUNE 77 BLA04393 * BLA04394 ENTRY DSWAP BLA04395 VFD 42/5HDSWAP,18/5 BLA04396 * BLA04397 DSWAP DATA 0 ENTRY/EXIT BLA04398 INFTN DSWAP,5 BLA04399 SA1 B1 (X1) = N BLA04400 SB7 -1 (B7) = -1 BLA04401 SB1 X1+B7 (B1) = N-1 BLA04402 * BLA04403 SA3 B3 (X3) = INCX BLA04404 NG B1,OUT IF N .LE.0 , GO TO OUT BLA04405 SA5 B5 (X5) = INCY BLA04406 SX1 -B1 (X1) = -(N-1) BLA04407 LX3 1 INCX = 2*INCX BLA04408 IX5 X5+X5 INCY = 2*INCY BLA04409 SB3 X3 (B3) = INCX BLA04410 SB5 X5 (B5) = INCY BLA04411 * BLA04412 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04413 DX3 X1*X3 LOC(XI1 ) = LOC(DX) - (N-1)*INCX BLA04414 SB2 X3+B2 (B2) = LOC(DXI1 ) BLA04415 * BLA04416 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA04417 DX5 X1*X5 LOC(YI1 ) = LOC(DY) - (N-1)*INCY BLA04418 SB4 X5+B4 (B4) = LOC(DYI1 ) BLA04419 * BLA04420 * (I = 1) BLA04421 TWO SA2 B2 BLA04422 SA4 B4 BLA04423 BX6 X2 BLA04424 BX7 X4 BLA04425 SA6 B4 BLA04426 SA7 B2 BLA04427 * BLA04428 SA3 A2-B7 (X2,X3) = DXI1 BLA04429 SA5 A4-B7 (X4,X5) = DYI1 BLA04430 BX6 X3 BLA04431 BX7 X5 BLA04432 SA6 A5 DXI1 = DYI1 BLA04433 SA7 A3 DYI1 = DXI1 BLA04434 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04435 * BLA04436 * (I = I+1) BLA04437 LOOP SA2 A2+B3 BLA04438 SA4 A4+B5 BLA04439 BX6 X2 BLA04440 BX7 X4 BLA04441 SA6 A4 BLA04442 SA7 A2 BLA04443 * BLA04444 SA3 A2-B7 (X2,X3) = DXII BLA04445 SA5 A4-B7 (X4,X5) = DYII BLA04446 BX6 X3 BLA04447 BX7 X5 BLA04448 SB1 B1+B7 COUNT TERM BLA04449 SA6 A5 DXII = DYII BLA04450 SA7 A3 DYII = DXII BLA04451 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04452 * BLA04453 OUT OUTFTN DSWAP RETURN BLA04454 END BLA04455 *DECK,CSWAP BLA04456 IDENT CSWAP BLA04457 * BLA04458 *** USE WITH FORTRAN STATEMENT BLA04459 * BLA04460 * CALL CSWAP(N,CX,INCX,CY,INCY) BLA04461 * BLA04462 * INTERCHANGE VECTOR ELEMENTS CXII AND CYII FOR I=1 TO N BLA04463 * BLA04464 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04465 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04466 * BLA04467 * SIMILAR DEFINITIONS FOR CYII BLA04468 * BLA04469 * CX( ),CY( ) COMPLEX TYPE BLA04470 * N,INCX,INCY INTEGER TYPE BLA04471 * BLA04472 * WRITTEN BY DAVID R. KINCAID BLA04473 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04474 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04475 *** 1 JUNE 77 BLA04476 * BLA04477 ENTRY CSWAP BLA04478 VFD 42/5HCSWAP,18/5 BLA04479 * BLA04480 CSWAP DATA 0 ENTRY/EXIT BLA04481 INFTN CSWAP,5 BLA04482 SA1 B1 (X1) = N BLA04483 SB7 -1 (B7) = -1 BLA04484 SB1 X1+B7 (B1) = N-1 BLA04485 * BLA04486 SA3 B3 (X3) = INCX BLA04487 NG B1,OUT IF N .LE. N , GO TO OUT BLA04488 SA5 B5 (X5) = INCY BLA04489 SX1 -B1 (X1) = -(N-1) BLA04490 LX3 1 INCX = 2*INCX BLA04491 IX5 X5+X5 INCY = 2*INCY BLA04492 SB3 X3 (B3) = INCX BLA04493 SB5 X5 (B5) = INCY BLA04494 * BLA04495 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04496 DX3 X1*X3 LOC(XI1 ) = LOC(CX) - (N-1)*INCX BLA04497 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA04498 * BLA04499 ONE GT B5,TWO IF INCY .GT. 0 , GO TO TWO BLA04500 DX5 X1*X5 LOC(YI1 ) = LOC(CY) - (N-1)*INCY BLA04501 SB4 X5+B4 (B4) = LOC(CYI1 ) BLA04502 * BLA04503 * (I = 1) BLA04504 TWO SA2 B2 BLA04505 SA4 B4 BLA04506 BX6 X2 BLA04507 BX7 X4 BLA04508 SA6 B4 BLA04509 SA7 B2 BLA04510 * BLA04511 SA3 A2-B7 (X2,X3) = CXI1 BLA04512 SA5 A4-B7 (X4,X5) = CYI1 BLA04513 BX6 X3 BLA04514 BX7 X5 BLA04515 SA6 A5 CXI1 = CYI1 BLA04516 SA7 A3 CYI1 = CXI1 BLA04517 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04518 * BLA04519 * (I = I+1) BLA04520 LOOP SA2 A2+B3 BLA04521 SA4 A4+B5 BLA04522 BX6 X2 BLA04523 BX7 X4 BLA04524 SA6 A4 BLA04525 SA7 A2 BLA04526 * BLA04527 SA3 A2-B7 (X2,X3) = CXII BLA04528 SA5 A4-B7 (X4,X5) = CYII BLA04529 BX6 X3 BLA04530 BX7 X5 BLA04531 SB1 B1+B7 COUNT TERM BLA04532 SA6 A5 CXII = CYII BLA04533 SA7 A3 CYII = CXII BLA04534 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04535 * BLA04536 OUT OUTFTN CSWAP RETURN BLA04537 END BLA04538 *DECK,SNRM2 BLA04539 IDENT SNRM2 BLA04540 * BLA04541 *** REAL FUNCTION SNRM2(N,SX,INCX) BLA04542 * BLA04543 * COMPUTES 2-VECTOR NORM (EUCLIDEAN NORM) BLA04544 * BLA04545 * COMPUTED AS THE SQUARE ROOT OF THE SUM FROM I=1 TO N OF SXII *BLA04546 * BLA04547 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA04548 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA04549 * BLA04550 * SX( ) SINGLE PRECISION BLA04551 * N,INCX INTEGER TYPE BLA04552 * SUM ACCUMULATED IN SINGLE PRECISION BLA04553 * RESULT SNRM2 IN SINGLE PRECISION BLA04554 * BLA04555 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA04556 * BLA04557 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA04558 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04559 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04560 *** 1 JUNE 77 BLA04561 * BLA04562 ENTRY SNRM2 BLA04563 VFD 42/5HSNRM2,18/3 BLA04564 * BLA04565 SNRM2 DATA 0 ENTRY/EXIT BLA04566 INFTN SNRM2,3 BLA04567 SA1 B1 (X1) = N BLA04568 SB7 -1 (B7) = -1 BLA04569 MX6 0 (X6) = 0 BLA04570 SB1 X1+B7 (B1) = N-1 BLA04571 * BLA04572 SA3 B3 (X3) = INCX BLA04573 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04574 SX1 -B1 (X1) = -(N-1) BLA04575 SB3 X3 (B3) = INCX BLA04576 * BLA04577 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04578 DX3 X1*X3 LOC(SXI1 ) = LOC(SX) - (N-1)*INCX BLA04579 SB2 X3+B2 (B2) = LOC(SXI1 ) BLA04580 * BLA04581 * (I = 1) BLA04582 ONE SA2 B2 (X2) = SXI1 BLA04583 RX1 X2*X2 (X2) = SXI1 *SXI1 BLA04584 * BLA04585 ZR B1,EXIT IF I .EQ. N , GO TO EXIT BLA04586 * BLA04587 * (I = I+1) BLA04588 LOOP SA2 A2+B3 (X2) = SXII BLA04589 RX0 X1+X6 (X6) = (X6) + (X1) BLA04590 SB1 B1+B7 I = I+1 BLA04591 NX6 X0 BLA04592 RX1 X2*X2 (X1) = SXII *SXII BLA04593 * BLA04594 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04595 * BLA04596 * (I = N) BLA04597 EXIT RX0 X1+X6 (X6) = (X6) + (X1) BLA04598 NX6 X0 BLA04599 SB1 RES (B1) = LOC(RES) BLA04600 SA6 B1 RES = (X6) BLA04601 CALL SQRT,(B1) (X6) = SQRT(RES) BLA04602 * BLA04603 OUT OUTFTN SNRM2 RETURN BLA04604 * BLA04605 RES BSS 1 BLA04606 END BLA04607 *DECK,DNRM2 BLA04608 IDENT DNRM2 BLA04609 * BLA04610 *** REAL FUNCTION DNRM2(N,DX,INCX) BLA04611 * BLA04612 * COMPUTES 2-VECTOR NORM (EUCLIDEAN NORM) BLA04613 * BLA04614 * COMPUTED AS THE SQUARE ROOT OF THE SUM FROM I=1 TO N OF DXII *BLA04615 * BLA04616 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04617 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04618 * BLA04619 * DX( ) DOUBLE PRECISION BLA04620 * N,INCX INTEGER TYPE BLA04621 * SUM ACCUMULATED IN DOUBLE PRECISION BLA04622 * RESULT DNRM2 IN DOUBLE PRECISION BLA04623 * BLA04624 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA04625 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04626 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04627 *** 1 JUNE 77 BLA04628 * BLA04629 ENTRY DNRM2 BLA04630 VFD 42/5HDNRM2,18/3 BLA04631 * BLA04632 DNRM2 DATA 0 ENTRY/EXIT BLA04633 INFTN DNRM2,3 BLA04634 SA1 B1 (X1) = N BLA04635 SB7 -1 (B7) = -1 BLA04636 MX6 0 BLA04637 SB1 X1+B7 (B1) = N-1 BLA04638 MX7 0 (X6,X7) = 0 BLA04639 * BLA04640 SA3 B3 (X3) = INCX BLA04641 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04642 SX1 -B1 (X1) = -(N-1) BLA04643 LX3 1 INCX = 2*INCX BLA04644 SB3 X3 (B3) = INCX BLA04645 * BLA04646 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04647 DX3 X1*X3 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA04648 SB2 X3+B2 (B2) = LOC(DXI1 ) BLA04649 * BLA04650 * BLA04651 ONE SA1 B2 (X1,X2) = DXI1 BLA04652 SA2 B2-B7 BLA04653 * BLA04654 FX0 X1*X2 (X0,X2) = DXI1 *DXI1 BLA04655 FX5 X0+X0 BLA04656 FX4 X1*X1 BLA04657 DX0 X1*X1 BLA04658 FX5 X0+X5 BLA04659 FX0 X4+X5 BLA04660 DX2 X4+X5 BLA04661 * BLA04662 ZR B1,EXIT IF I .EQ. N , GO TO EXIT BLA04663 * BLA04664 * (I = I+1) BLA04665 LOOP SA1 A1+B3 BLA04666 * BLA04667 FX4 X6+X0 (X6,X7) = (X6,X7) + (X0,X2) BLA04668 DX5 X6+X0 BLA04669 FX0 X7+X2 BLA04670 NX4 X4 BLA04671 FX2 X0+X5 BLA04672 FX0 X2+X4 BLA04673 NX5 X0 BLA04674 DX2 X2+X4 BLA04675 NX4 X2 BLA04676 FX6 X4+X5 BLA04677 DX7 X4+X5 BLA04678 * BLA04679 SA2 A1-B7 (X1,X2) = DXII BLA04680 SB1 B1+B7 I = I+1 BLA04681 * BLA04682 FX0 X1*X2 (X0,X2) = DXII *DXII BLA04683 FX5 X0+X0 BLA04684 FX4 X1*X1 BLA04685 DX0 X1*X1 BLA04686 FX5 X0+X5 BLA04687 FX0 X4+X5 BLA04688 DX2 X4+X5 BLA04689 * BLA04690 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04691 * BLA04692 * (I = N) BLA04693 EXIT FX4 X6+X0 (X6,X7) = (X6,X7) + (X0,X2) BLA04694 DX5 X6+X0 BLA04695 FX0 X7+X2 BLA04696 NX4 X4 BLA04697 FX2 X0+X5 BLA04698 FX0 X2+X4 BLA04699 NX5 X0 BLA04700 DX2 X2+X4 BLA04701 NX4 X2 BLA04702 FX6 X4+X5 BLA04703 DX7 X4+X5 BLA04704 * BLA04705 SB1 RES (B1) = RES BLA04706 SA6 B1 (RES) = (X6,X7) BLA04707 SA7 B1-B7 BLA04708 * BLA04709 CALL DSQRT,(B1) (X6,X7) = SQRT(RES) BLA04710 * BLA04711 OUT OUTFTN DNRM2 RETURN BLA04712 * BLA04713 RES BSS 2 BLA04714 END BLA04715 *DECK,SCNRM2 BLA04716 IDENT SCNRM2 BLA04717 * BLA04718 *** REAL FUNCTION SCNRM2(N,CX,INCX) BLA04719 * BLA04720 * COMPUTES 2-VECTOR NORM (EUCLIDEAN NORM) BLA04721 * BLA04722 * COMPUTED AS THE SQUARE ROOT OF THE SUM BLA04723 * FROM I=1 TO N OF CONJ(CXII ) * CXII BLA04724 * BLA04725 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04726 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04727 * BLA04728 * CX( ) COMPLEX TYPE BLA04729 * N,INCX INTEGER TYPE BLA04730 * SUM ACCUMULATED IN SINGLE PRECISION BLA04731 * RESULT SCNRM2 IN SINGLE PRECISION BLA04732 * BLA04733 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA04734 * BLA04735 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA04736 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04737 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04738 *** 1 JUNE 77 BLA04739 * BLA04740 ENTRY SCNRM2 BLA04741 VFD 42/6HSCNRM2,18/3 BLA04742 * BLA04743 SCNRM2 DATA 0 ENTRY/EXIT BLA04744 INFTN SCNRM2,3 BLA04745 SA1 B1 (X1) = N BLA04746 SB7 -1 (B7) = -1 BLA04747 MX6 0 BLA04748 SB1 X1+B7 (B1) = N-1 BLA04749 * BLA04750 SA3 B3 (X3) = INCX BLA04751 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04752 SX1 -B1 (X1) = -(N-1) BLA04753 LX3 1 INCX = 2*INCX BLA04754 SB3 X3 (B3) = INCX BLA04755 * BLA04756 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04757 ZR B3,OUT IF INCX .EQ. 0 ,GO TO OUT BLA04758 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA04759 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA04760 * BLA04761 * (I = 1) BLA04762 ONE SA1 B2 (X1) = REAL(CXI1 ) BLA04763 SA2 B2-B7 (X2) = IMAG(CXI1 ) BLA04764 * BLA04765 RX0 X1*X1 (X0) = (REAL(CXI1 )**2 BLA04766 RX5 X2*X2 (X5) = (IMAG(CXI1 )**2 BLA04767 RX4 X0+X5 (X4) = (X0) + (X5) BLA04768 NX4 X4 BLA04769 * BLA04770 ZR B1,EXIT IF I .EQ. N , GO TO EXIT BLA04771 * BLA04772 * (I = I+1) BLA04773 LOOP SA1 A1+B3 (X1) = REAL(CXII ) BLA04774 * BLA04775 RX5 X6+X4 (X6) = (X6) + (X4) BLA04776 SA2 A1-B7 (X2) = IMAG(CXII ) BLA04777 NX6 X5 BLA04778 RX0 X1*X1 (X0) = (REAL(CXII )**2 BLA04779 RX5 X2*X2 (X5) = (IMAG(CXII )**2 BLA04780 SB1 B1+B7 I = I+1 BLA04781 RX4 X0+X5 (X4) = (X0) + (X5) BLA04782 NX4 X4 BLA04783 * BLA04784 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04785 * BLA04786 * (I = N) BLA04787 EXIT RX5 X6+X4 (X6) = (X6) + (X4) BLA04788 NX6 X5 BLA04789 * BLA04790 SB1 RES (B1) = RES BLA04791 SA6 B1 (RES) = (X6) BLA04792 * BLA04793 CALL SQRT,(B1) (X6) = SQRT(RES) BLA04794 * BLA04795 OUT OUTFTN SCNRM2 RETURN BLA04796 * BLA04797 RES BSS 1 BLA04798 END BLA04799 *DECK,SASUM BLA04800 IDENT SASUM BLA04801 * BLA04802 *** REAL FUNCTION SASUM(N,SX,INCX) BLA04803 * BLA04804 * COMPUTES 1-VECTOR NORM BLA04805 * BLA04806 * COMPUTED AS THE SUM FROM I=1 TO N OF THE ABSOLUTE VALUE OF SXIBLA04807 * BLA04808 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA04809 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA04810 * BLA04811 * SX( ) SINGLE PRECISION BLA04812 * N,INCX INTEGER TYPE BLA04813 * SUM ACCUMULATED IN SINGLE PRECISION BLA04814 * RESULT SASUM IN SINGLE PRECISION BLA04815 * BLA04816 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA04817 * BLA04818 * WRITTEN BY DAVID R. KINCAID BLA04819 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04820 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04821 *** 1 JUNE 77 BLA04822 * BLA04823 ENTRY SASUM BLA04824 VFD 42/5HSASUM,18/3 BLA04825 * BLA04826 SASUM DATA 0 ENTRY/EXIT BLA04827 INFTN SASUM,3 BLA04828 SA1 B1 (X1) = N BLA04829 SB7 -1 (B7) = -1 BLA04830 MX6 0 (X6) = 0 BLA04831 SB1 X1+B7 (B1) = N-1 BLA04832 * BLA04833 SA3 B3 (X3) = INCX BLA04834 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04835 SX1 -B1 (X1) = -(N-1) BLA04836 SB3 X3 (B3) = INCX BLA04837 * BLA04838 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04839 DX3 X1*X3 LOC(RXI1 ) = LOC(RX) - (N-1)*INCX BLA04840 SB2 X3+B2 (B2) = LOC(RXI1 ) BLA04841 * BLA04842 * (I=1) BLA04843 ONE SA2 B2 (X2) = RXI1 BLA04844 BX4 X2 BLA04845 AX2 59 BLA04846 BX5 X2-X4 (X5) = ABS(RXI1 ) BLA04847 * BLA04848 FX3 X6+X5 (X6) = (X6) + (X5) BLA04849 NX6 X3 BLA04850 * BLA04851 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04852 * BLA04853 * (I = I+1) BLA04854 LOOP SA2 A2+B3 (X2) = RXII BLA04855 BX4 X2 BLA04856 AX2 59 BLA04857 BX5 X2-X4 (X5) = ABS(RXII ) BLA04858 * BLA04859 FX3 X6+X5 (X6) = (X6) + (X5) BLA04860 SB1 B1+B7 COUNT TERM BLA04861 NX6 X3 BLA04862 * BLA04863 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04864 * BLA04865 OUT OUTFTN SASUM RETURN BLA04866 END BLA04867 *DECK,DASUM BLA04868 IDENT DASUM BLA04869 * BLA04870 *** REAL FUNCTION DASUM(N,DX,INCX) BLA04871 * BLA04872 * COMPUTES 1-VECTOR NORM BLA04873 * BLA04874 * COMPUTED AS THE SUM FROM I=1 TO N OF THE ABSOLUTE VALUE OF DXIBLA04875 * BLA04876 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04877 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04878 * BLA04879 * DX( ) DOUBLE PRECISION BLA04880 * N,INCX INTEGER TYPE BLA04881 * SUM ACCUMULATED IN DOUBLE PRECISION BLA04882 * RESULT DASUM IN DOUBLE PRECISION BLA04883 * BLA04884 * WRITTEN BY DAVID R. KINCAID BLA04885 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04886 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04887 *** 1 JUNE 77 BLA04888 * BLA04889 ENTRY DASUM BLA04890 VFD 42/5HDASUM,18/3 BLA04891 * BLA04892 DASUM DATA 0 ENTRY/EXIT BLA04893 INFTN DASUM,3 BLA04894 SA1 B1 (X1) = N BLA04895 SB7 -1 (B7) = -1 BLA04896 MX6 0 BLA04897 SB1 X1+B7 (B1) = N-1 BLA04898 MX7 0 (X6,X7) = 0 BLA04899 * BLA04900 SA3 B3 (X3) = INCX BLA04901 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04902 LX3 1 INCX = 2*INCX BLA04903 SX1 -B1 (X1) = -(N-1) BLA04904 SB3 X3 (B3) = INCX BLA04905 * BLA04906 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA04907 DX3 X1*X3 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA04908 SB2 X3+B2 (B2) = LOC(DXI1 ) BLA04909 * (I=1) BLA04910 ONE SA2 B2 BLA04911 SA3 B2-B7 (X2,X3) = DXI1 BLA04912 BX0 X2 BLA04913 BX1 X3 BLA04914 AX2 59 BLA04915 AX3 59 BLA04916 BX4 X2-X0 BLA04917 BX5 X3-X1 (X4,X5) = DABS(DXI1 ) BLA04918 * BLA04919 FX0 X6+X4 (X6,X7) = (X6,X7) + (X4,X5) BLA04920 DX1 X6+X4 BLA04921 FX4 X7+X5 BLA04922 NX0 X0 BLA04923 FX5 X4+X1 BLA04924 FX4 X5+X0 BLA04925 NX1 X4 BLA04926 DX5 X5+X0 BLA04927 NX0 X5 BLA04928 FX6 X0+X1 BLA04929 DX7 X0+X1 BLA04930 * BLA04931 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA04932 * BLA04933 * (I = I+1) BLA04934 LOOP SA2 A2+B3 BLA04935 SA3 A2-B7 (X2,X3) = DXII BLA04936 BX0 X2 BLA04937 BX1 X3 BLA04938 AX2 59 BLA04939 AX3 59 BLA04940 BX4 X2-X0 BLA04941 BX5 X3-X1 (X4,X5) = DABS(DXII ) BLA04942 * BLA04943 SB1 B1+B7 COUNT TERM BLA04944 * BLA04945 FX0 X6+X4 (X6,X7) = (X6,X7) + (X4,X5) BLA04946 DX1 X6+X4 BLA04947 FX4 X7+X5 BLA04948 NX0 X0 BLA04949 FX5 X4+X1 BLA04950 FX4 X5+X0 BLA04951 NX1 X4 BLA04952 DX5 X5+X0 BLA04953 NX0 X5 BLA04954 FX6 X0+X1 BLA04955 DX7 X0+X1 BLA04956 * BLA04957 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA04958 * BLA04959 OUT OUTFTN DASUM RETURN BLA04960 END BLA04961 *DECK,SCASUM BLA04962 IDENT SCASUM BLA04963 * BLA04964 *** REAL FUNCTION SCASUM(N,CX,INCX) BLA04965 * BLA04966 * COMPUTED AS THE SUM FROM I=1 TO N OF THE ABSOLUTE VALUE BLA04967 * OF REAL(CXII ) AND THE ABSOLUTE VALUE OF IMAG(CXII ) BLA04968 * BLA04969 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA04970 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA04971 * BLA04972 * CX( ) COMPLEX TYPE BLA04973 * N,INCX INTEGER TYPE BLA04974 * SUM ACCUMULATED IN SINGLE PRECISION BLA04975 * RESULT SCASUM IN SINGLE PRECISION BLA04976 * BLA04977 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA04978 * BLA04979 * WRITTEN BY DAVID R. KINCAID BLA04980 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA04981 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA04982 *** 1 JUNE 77 BLA04983 * BLA04984 ENTRY SCASUM BLA04985 VFD 42/6HSCASUM,18/3 BLA04986 * BLA04987 SCASUM DATA 0 ENTRY/EXIT BLA04988 INFTN SCASUM,3 BLA04989 SA1 B1 (X1) = N BLA04990 SB7 -1 (B7) = -1 BLA04991 MX6 0 BLA04992 SB1 X1+B7 (B1) = N-1 BLA04993 * BLA04994 SA3 B3 (X3) = INCX BLA04995 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA04996 LX3 1 INCX = 2*INCX BLA04997 SX1 -B1 (X1) = -(N-1) BLA04998 SB3 X3 (B3) = INCX BLA04999 * BLA05000 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA05001 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA05002 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA05003 * (I=1) BLA05004 ONE SA2 B2 (X2) = REAL(CXI1 ) BLA05005 SA3 B2-B7 (X3) = IMAG(CXI1 ) BLA05006 BX0 X2 BLA05007 BX1 X3 BLA05008 AX2 59 BLA05009 AX3 59 BLA05010 BX4 X2-X0 (X4) = ABS(REAL(CXI1 )) BLA05011 BX5 X3-X1 (X5) = ABS(IMAG(CXI1 )) BLA05012 * BLA05013 RX0 X6+X4 BLA05014 NX0 X0 BLA05015 RX1 X0+X5 (X6) = (X6) + (X5) + (X4) BLA05016 NX6 X1 BLA05017 * BLA05018 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA05019 * BLA05020 * (I = I+1) BLA05021 LOOP SA2 A2+B3 (X2) = REAL(CXII ) BLA05022 SA3 A2-B7 (X3) = IMAG(CXII ) BLA05023 BX0 X2 BLA05024 BX1 X3 BLA05025 AX2 59 BLA05026 AX3 59 BLA05027 BX4 X2-X0 (X4) = ABS(REAL(CXII )) BLA05028 BX5 X3-X1 (X5) = ABS(IMAG(CXII )) BLA05029 * BLA05030 RX0 X6+X4 (X6) = (X6) + (X5) + (X4) BLA05031 NX0 X0 BLA05032 RX1 X0+X5 BLA05033 SB1 B1+B7 COUNT TERM BLA05034 NX6 X1 BLA05035 * BLA05036 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05037 * BLA05038 OUT OUTFTN SCASUM RETURN BLA05039 END BLA05040 *DECK,SSCAL BLA05041 IDENT SSCAL BLA05042 * BLA05043 *** USE WITH FORTRAN STATEMENT BLA05044 * BLA05045 * CALL SSCAL(N,SA,SX,INCX) BLA05046 * BLA05047 * SA*SXII REPLACES SXII FOR I=1,N BLA05048 * BLA05049 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA05050 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA05051 * BLA05052 * SX( ) SINGLE PRECISION BLA05053 * N,INCX INTEGER TYPE BLA05054 * SA SINGLE PRECISION BLA05055 * BLA05056 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA05057 * BLA05058 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA05059 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05060 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA05061 *** 1 JUNE 77 BLA05062 * BLA05063 ENTRY SSCAL BLA05064 VFD 42/5HSSCAL,18/4 BLA05065 * BLA05066 SSCAL DATA 0 ENTRY/EXIT BLA05067 INFTN SSCAL,4 BLA05068 SA1 B1 (X1) = N BLA05069 SB7 -1 (B7) = -1 BLA05070 SB1 X1+B7 (B1) = N-1 BLA05071 SA2 B2 (X2) = SA BLA05072 * BLA05073 SA4 B4 (X4) = INCX BLA05074 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA05075 SX1 -B1 (X1) = -(N-1) BLA05076 SB4 X4 (B4) = INCX BLA05077 * BLA05078 GT B4,ONE IF INCX .GT. 0 , GO TO ONE BLA05079 DX4 X1*X4 LOC(SXI1 ) = LOC(SX) - (N-1)*INCX BLA05080 SB3 X4+B3 (B3) = LOC(SXI1 ) BLA05081 * BLA05082 * (I = 1) BLA05083 ONE SA3 B3 (X3) = SXI1 BLA05084 FX6 X2*X3 (X6) = SA*SXI1 BLA05085 SA6 B3 BLA05086 * BLA05087 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA05088 * BLA05089 * (I = I+1) BLA05090 LOOP SA3 A3+B4 (X3) = SXII BLA05091 FX6 X2*X3 (X6) = SA*SXII BLA05092 SB1 B1+B7 I = I+1 BLA05093 SA6 A3 SXII = (X6) BLA05094 * BLA05095 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05096 * BLA05097 OUT OUTFTN SSCAL RETURN BLA05098 END BLA05099 *DECK,DSCAL BLA05100 IDENT DSCAL BLA05101 * BLA05102 *** USE WITH FORTRAN STATEMENT BLA05103 * BLA05104 * CALL DSCAL(N,DA,DX,INCX) BLA05105 * BLA05106 * DA*DXII REPLACES DXII FOR I=1,N BLA05107 * BLA05108 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA05109 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA05110 * BLA05111 * DX( ) DOUBLE PRECISION BLA05112 * N,INCX INTEGER TYPE BLA05113 * DA DOUBLE PRECISION BLA05114 * BLA05115 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA05116 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05117 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA05118 *** 1 JUNE 77 BLA05119 * BLA05120 ENTRY DSCAL BLA05121 VFD 42/5HDSCAL,18/4 BLA05122 * BLA05123 DSCAL DATA 0 ENTRY/EXIT BLA05124 INFTN DSCAL,4 BLA05125 SA3 B1 (X3) = N BLA05126 SB7 -1 (B7) = -1 BLA05127 SB1 X3+B7 (B1) = N-1 BLA05128 SA1 B2 (X1,X2) = DA BLA05129 SA2 B2-B7 BLA05130 * BLA05131 SA4 B4 (X4) = INCX BLA05132 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA05133 LX4 1 INCX = 2*INCX BLA05134 SX3 -B1 (X3) = -(N-1) BLA05135 SB4 X4 (B4) = INCX BLA05136 * BLA05137 GT B4,ONE IF INCX .GT. 0 , GO TO ONE BLA05138 DX4 X3*X4 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA05139 SB3 X4+B3 BLA05140 * BLA05141 * (I = 1) BLA05142 ONE SA3 B3 (X3,X4) = DXI1 BLA05143 SA4 B3-B7 BLA05144 * BLA05145 FX5 X2*X3 (X6,X7) = DA*DXI1 BLA05146 FX0 X1*X4 BLA05147 FX5 X0+X5 BLA05148 FX4 X1*X3 BLA05149 DX0 X1*X3 BLA05150 FX5 X0+X5 BLA05151 FX6 X4+X5 BLA05152 DX7 X4+X5 BLA05153 * BLA05154 SA6 A3 DXI1 = (X6,X7) BLA05155 SA7 A4 BLA05156 * BLA05157 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA05158 * BLA05159 * (I = I+1) BLA05160 LOOP SA3 A3+B4 (X3,X4) = DXII BLA05161 SA4 A3-B7 BLA05162 * BLA05163 * BLA05164 FX5 X2*X3 (X6,X7) = DA*DXII BLA05165 FX0 X1*X4 BLA05166 FX5 X0+X5 BLA05167 FX4 X1*X3 BLA05168 DX0 X1*X3 BLA05169 FX5 X0+X5 BLA05170 FX6 X4+X5 BLA05171 DX7 X4+X5 BLA05172 * BLA05173 SB1 B1+B7 I = I+1 BLA05174 * BLA05175 SA6 A3 DXII = (X6,X7) BLA05176 SA7 A4 BLA05177 * BLA05178 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05179 * BLA05180 OUT OUTFTN DSCAL RETURN BLA05181 END BLA05182 *DECK,CSCAL BLA05183 IDENT CSCAL BLA05184 * BLA05185 *** USE WITH FORTRAN STATEMENT BLA05186 * BLA05187 * CALL CSCAL(N,CA,CX,INCX) BLA05188 * BLA05189 * CA*CXII REPLACES CXII FOR I=1,N BLA05190 * BLA05191 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA05192 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA05193 * BLA05194 * CX( ) COMPLEX TYPE BLA05195 * N,INCX INTEGER TYPE BLA05196 * CA COMPLEX TYPE BLA05197 * BLA05198 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA05199 * BLA05200 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA05201 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05202 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05203 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05204 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA05205 *** 1 JUNE 77 BLA05206 * BLA05207 ENTRY CSCAL BLA05208 VFD 42/5HCSCAL,18/4 BLA05209 * BLA05210 CSCAL DATA 0 ENTRY/EXIT BLA05211 INFTN CSCAL,4 BLA05212 SA3 B1 (X3) = N BLA05213 SB7 -1 (B7) = -1 BLA05214 SB1 X3+B7 (B1) = N-1 BLA05215 SA1 B2 (X1) = REAL(CA) BLA05216 SA2 B2-B7 (X2) = IMAG(CA) BLA05217 * BLA05218 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA05219 SA4 B4 (X4) = INCX BLA05220 LX4 1 INCX = 2*INCX BLA05221 SX3 -B1 (X3) = -(N-1) BLA05222 SB4 X4 (B4) = INCX BLA05223 * BLA05224 GT B4,ONE IF INCX .GT. 0 , GO TO ONE BLA05225 DX4 X3*X4 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA05226 SB3 X4+B3 (B3) = LOC(CXI1 ) BLA05227 * BLA05228 * (I = 1) BLA05229 ONE SA3 B3 (X3) = REAL(CXI1 ) BLA05230 SA4 B3-B7 (X4) = IMAG(CXI1 ) BLA05231 * BLA05232 * (X6,X7) = CA*CXI1 BLA05233 RX6 X1*X3 (X6) = REAL(CA)*REAL(CXI1 ) BLA05234 RX5 X2*X4 (X5) = IMAG(CA)*IMAG(CXI1 ) BLA05235 RX0 X6-X5 (X0) = REAL(CA*CXI1 ) BLA05236 NX6 X0 BLA05237 * BLA05238 RX7 X1*X4 (X7) = REAL(CA)*IMAG(CXI1 ) BLA05239 RX5 X2*X3 (X5) = IMAG(CA)*REAL(CXI1 ) BLA05240 RX0 X7+X5 (X0) = IMAG(CA*CXI1 ) BLA05241 NX7 X0 BLA05242 * BLA05243 SA6 A3 REAL(CXI1 ) = (X6) BLA05244 SA7 A4 IMAG(CXI1 ) = (X7) BLA05245 * BLA05246 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA05247 * BLA05248 * (I = I+1) BLA05249 LOOP SA3 A3+B4 (X3) = REAL(CXII ) BLA05250 SA4 A3-B7 (X4) = IMAG(CXII ) BLA05251 * BLA05252 RX6 X1*X3 (X6) = REAL(CA)*REAL(CXII ) BLA05253 RX5 X2*X4 (X5) = IMAG(CA)*IMAG(CXII ) BLA05254 RX0 X6-X5 (X0) = REAL(CA*CXII ) BLA05255 NX6 X0 BLA05256 * BLA05257 RX7 X1*X4 (X7) = REAL(CA)*IMAG(CXII ) BLA05258 RX5 X2*X3 (X5) = IMAG(CA)*REAL(CXII ) BLA05259 RX0 X7+X5 (X0) = IMAG(CA*CXII ) BLA05260 SB1 B1+B7 I = I+1 BLA05261 NX7 X0 BLA05262 * BLA05263 SA6 A3 REAL(CXII ) = (X6) BLA05264 SA7 A4 IMAG(CXII ) = (X7) BLA05265 * BLA05266 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05267 * BLA05268 OUT OUTFTN CSCAL RETURN BLA05269 END BLA05270 *DECK,CSSCAL BLA05271 IDENT CSSCAL BLA05272 * BLA05273 *** USE WITH FORTRAN STATEMENT BLA05274 * BLA05275 * CALL CSSCAL(N,SA,CX,INCX) BLA05276 * BLA05277 * SA*CXII REPLACES CXII FOR I=1,N BLA05278 * BLA05279 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA05280 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA05281 * BLA05282 * CX( ) COMPLEX TYPE BLA05283 * N,INCX INTEGER TYPE BLA05284 * SA SINGLE PRECISION BLA05285 * BLA05286 * ROUNDED ARITHMETIC INSTRUCTIONS ARE USED BLA05287 * BLA05288 * WRITTEN BY DAVID R. KINCAID AND ELIZABETH WILLIAMS BLA05289 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05290 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA05291 *** 1 JUNE 77 BLA05292 * BLA05293 ENTRY CSSCAL BLA05294 VFD 42/6HCSSCAL,18/4 BLA05295 * BLA05296 CSSCAL DATA 0 ENTRY/EXIT BLA05297 INFTN CSSCAL,4 BLA05298 SA3 B1 (X3) = N BLA05299 SB7 -1 (B7) = -1 BLA05300 SB1 X3+B7 (B1) = N-1 BLA05301 SA2 B2 (X2) = SA BLA05302 * BLA05303 SA4 B4 (X4) = INCX BLA05304 NG B1,OUT IF N .LE. 0 , GO TO OUT BLA05305 LX4 1 INCX = 2*INCX BLA05306 SX3 -B1 (X3) = -(N-1) BLA05307 SB4 X4 (B4) = INCX BLA05308 * BLA05309 GT B4,ONE IF INCX .GT. 0 , GO TO ONE BLA05310 DX4 X3*X4 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA05311 SB3 X4+B3 (B3) = LOC(CXI1 ) BLA05312 * BLA05313 * (I = 1) BLA05314 ONE SA3 B3 (X3) = REAL(CXI1 ) BLA05315 SA4 B3-B7 (X4) = IMAG(CXI1 ) BLA05316 * BLA05317 * (X6,X7) = SA*CXI1 BLA05318 RX6 X2*X3 (X6) = SA*REAL(CXI1 ) BLA05319 RX7 X2*X4 (X7) = SA*IMAG(CXI1 ) BLA05320 * BLA05321 SA6 A3 REAL(CXI1 ) = (X6) BLA05322 SA7 A4 IMAG(CXI1 ) = (X7) BLA05323 * BLA05324 ZR B1,OUT IF I .EQ. N , GO TO OUT BLA05325 * BLA05326 * (I = I+1) BLA05327 LOOP SA3 A3+B4 (X3) = REAL(CXII ) BLA05328 SB1 B1+B7 I = I+1 BLA05329 SA4 A3-B7 (X4) = IMAG(CXII ) BLA05330 * BLA05331 * (X6,X7) = SA*CXII BLA05332 RX6 X2*X3 (X6) = SA*REAL(CXII ) BLA05333 RX7 X2*X4 (X7) = SA*IMAG(CXII ) BLA05334 * BLA05335 SA6 A3 REAL(CXII ) = (X6) BLA05336 SA7 A4 IMAG(CXII ) = (X7) BLA05337 * BLA05338 NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05339 * BLA05340 OUT OUTFTN CSSCAL RETURN BLA05341 END BLA05342 *DECK,ISAMAX BLA05343 IDENT ISAMAX BLA05344 * BLA05345 *** INTEGER FUNCTION ISAMAX(N,SX,INCX) BLA05346 * BLA05347 * FIND AN INDEX I(MAX) CORRESPONDING TO THE MAXIMUM ABSOLUTE VBLA05348 * COMPONENTS SXII OF THE VECTOR SX. BLA05349 * BLA05350 * SXII = SX(1 + (I-1)*INCX) IF INCX .GE. 0 BLA05351 * = SX(1 + (I-N)*INCX) IF INCX .LT. 0 BLA05352 * BLA05353 * SX( ) SINGLE PRECISION BLA05354 * N,INCX INTEGER TYPE BLA05355 * RESULT ISAMAX INTEGER TYPE BLA05356 * BLA05357 * WRITTEN BY DAVID R. KINCAID BLA05358 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05359 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA05360 *** 1 JUNE 77 BLA05361 * BLA05362 ENTRY ISAMAX BLA05363 VFD 42/6HISAMAX,18/3 BLA05364 * BLA05365 ISAMAX DATA 0 ENTRY/EXIT BLA05366 INFTN ISAMAX,3 BLA05367 MX6 0 (X6)=ISAMAX=0 BLA05368 SA1 B1 (X1) = N BLA05369 SB7 -1 (B7) = -1 BLA05370 SB4 X1 (B4) = N BLA05371 SB1 X1+B7 (B1) = N-1 BLA05372 NG B1,OUT IF(N .LE. 0) GO TO OUT BLA05373 * BLA05374 SX6 -B7 (X6) = 1 (ISAMAX) BLA05375 LE B1,OUT IF N .LE. 1 , GO TO OUT BLA05376 * BLA05377 SA3 B3 (X3) = INCX BLA05378 SX1 -B1 (X1) = -(N-1) BLA05379 SB3 X3 (B3) = INCX BLA05380 * BLA05381 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA05382 DX3 X1*X3 LOC(XI1 ) = LOC(SX) - (N-1)*INCX BLA05383 SB2 X3+B2 (B2) = LOC(SXI1 ) BLA05384 * BLA05385 * (I = 1) BLA05386 ONE SA2 B2 (X2) = SXI1 BLA05387 BX3 X2 BLA05388 AX2 59 BLA05389 BX5 X2-X3 (X5) = ABS(SXI1 ) (SAMAX) BLA05390 * BLA05391 * BLA05392 * (I=I+1) BLA05393 LOOP SA2 A2+B3 (X2) = SXII BLA05394 BX3 X2 BLA05395 AX2 59 BLA05396 BX2 X2-X3 (X2) = ABS(SXII ) BLA05397 SB1 B1+B7 COUNT TERM BLA05398 * BLA05399 NX5 X5 BLA05400 FX0 X5-X2 BLA05401 PL X0,TEST IF ABS(SXII ) .LE. SAMAX , GO TO TEST BLA05402 * BLA05403 BX5 X2 (X5) = ABS(SXII ) (SAMAX) BLA05404 SX6 B4-B1 (X6) = I (ISAMAX) BLA05405 * BLA05406 TEST NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05407 * BLA05408 OUT OUTFTN ISAMAX RETURN BLA05409 END BLA05410 *DECK,IDAMAX BLA05411 IDENT IDAMAX BLA05412 * BLA05413 *** INTEGER FUNCTION IDAMAX(N,DX,INCX) BLA05414 * BLA05415 * FIND AN INDEX I(MAX) CORRESPONDING TO THE MAXIMUM ABSOLUTE VBLA05416 * COMPONENTS DXII OF THE VECTOR DX BLA05417 * BLA05418 * DXII = DX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA05419 * = DX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA05420 * BLA05421 * DX( ) DOUBLE PRECISION BLA05422 * N,INCX INTEGER TYPE BLA05423 * RESULT IDAMAX INTEGER TYPE BLA05424 * BLA05425 * WRITTEN BY DAVID R. KINCAID BLA05426 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05427 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA05428 *** 1 JUNE 77 BLA05429 * BLA05430 ENTRY IDAMAX BLA05431 VFD 42/6HIDAMAX,18/3 BLA05432 * BLA05433 IDAMAX DATA 0 ENTRY/EXIT BLA05434 INFTN IDAMAX,3 BLA05435 MX6 0 (X6)=IDAMAX=0 BLA05436 SA1 B1 (X1) = N BLA05437 SB7 -1 (B7) = -1 BLA05438 SB4 X1 (B4) = N BLA05439 SB1 X1+B7 (B1) = N-1 BLA05440 NG B1,OUT IF(N .LE. 0) GO TO OUT BLA05441 * BLA05442 SX6 -B7 (X6) = 1 BLA05443 LE B1,OUT IF N .LE. 1 , GO TO OUT BLA05444 * BLA05445 SA3 B3 (X3) = INCX BLA05446 SX1 -B1 (X1) = -(N-1) BLA05447 LX3 1 INCX = 2*INCX BLA05448 SB3 X3 (B3) = INCX BLA05449 * BLA05450 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA05451 DX3 X1*X3 LOC(DXI1 ) = LOC(DX) - (N-1)*INCX BLA05452 SB2 X3+B2 (B2) = LOC(DXI1 ) BLA05453 * BLA05454 * (I=1) BLA05455 ONE SA2 B2 BLA05456 SA3 B2-B7 (X2,X3) = DXI1 BLA05457 BX0 X2 BLA05458 AX0 59 BLA05459 BX4 X0-X2 BLA05460 BX5 X0-X3 (X4,X5) = DABS(DXI1 ) BLA05461 * BLA05462 * (I=I+1) BLA05463 LOOP SA2 A2+B3 BLA05464 SA3 A3+B3 (X2,X3) = DXII BLA05465 BX0 X2 BLA05466 AX0 59 BLA05467 BX2 X0-X2 BLA05468 BX3 X0-X3 (X2,X3) = DABS(DXII ) BLA05469 SB1 B1+B7 COUNT TERM BLA05470 * BLA05471 FX1 X4-X2 IF DABS(DXII ) .LE. DAMAX , GO TO TEST BLA05472 FX5 X5-X3 BLA05473 DX4 X4-X2 BLA05474 NX1 X1 BLA05475 FX4 X4+X5 BLA05476 NX5 X4 BLA05477 FX4 X1+X5 BLA05478 PL X4,TEST BLA05479 * BLA05480 SX6 B4-B1 (X6) = I (IDAMAX) BLA05481 BX4 X2 (X4,X5) = DABX(DXII ) (DAMAX) BLA05482 BX5 X3 BLA05483 * BLA05484 TEST NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05485 * BLA05486 OUT OUTFTN IDAMAX RETURN BLA05487 END BLA05488 *DECK,ICAMAX BLA05489 IDENT ICAMAX BLA05490 * BLA05491 *** INTEGER FUNCTION ICAMAX(N,CX,INCX) BLA05492 * BLA05493 * FIND AN INDEX I(MAX) CORRESPONDING TO THE MAXIMUM SUM OF THEBLA05494 * ABSOLUTE VALUE OF THE REAL PART AND THE ABSOLUTE VALUE OF THE BLA05495 * IMAGINARY PART OF THE COMPONENTS CXII OF THE VECTOR CX BLA05496 * BLA05497 * CXII = CX(1 + (I-1)*2*INCX) IF INCX .GE. 0 BLA05498 * = CX(1 + (I-N)*2*INCX) IF INCX .LT. 0 BLA05499 * BLA05500 * CX( ) COMPLEX TYPE BLA05501 * N,INCX INTEGER TYPE BLA05502 * RESULT ICAMAX INTEGER TYPE BLA05503 * BLA05504 * WRITTEN BY DAVID R. KINCAID BLA05505 * CENTER FOR NUMERICAL ANALYSIS/COMPUTATION CENTER BLA05506 * THE UNIVERSITY OF TEXAS AT AUSTIN BLA05507 *** 1 JUNE 77 BLA05508 * BLA05509 ENTRY ICAMAX BLA05510 VFD 42/6HICAMAX,18/3 BLA05511 * BLA05512 ICAMAX DATA 0 ENTRY/EXIT BLA05513 INFTN ICAMAX,3 BLA05514 MX6 0 (X6)=ICAMAX=0 BLA05515 SA1 B1 (X1) = N BLA05516 SB7 -1 (B7) = -1 BLA05517 SB4 X1 (B4) = N BLA05518 SB1 X1+B7 (B1) = N-1 BLA05519 NG B1,OUT IF(N .LE. 0) GO TO OUT BLA05520 * BLA05521 SX6 -B7 (X6) = 1 BLA05522 LE B1,OUT IF N .LE. 1 , GO TO OUT BLA05523 * BLA05524 SA3 B3 (X3) = INCX BLA05525 SX1 -B1 (X1) = -(N-1) BLA05526 LX3 1 (X3) = 2*INCX BLA05527 SB3 X3 (B3) = INCX BLA05528 * BLA05529 GT B3,ONE IF INCX .GT. 0 , GO TO ONE BLA05530 DX3 X1*X3 LOC(CXI1 ) = LOC(CX) - (N-1)*INCX BLA05531 SB2 X3+B2 (B2) = LOC(CXI1 ) BLA05532 * BLA05533 * (I = 1) BLA05534 ONE SA2 B2 (X2) = REAL(CXI1 ) BLA05535 BX3 X2 BLA05536 AX2 59 BLA05537 BX5 X2-X3 (X5) = ABS(REAL(CXI1 )) BLA05538 SA3 B2-B7 (X3) = IMAG(CXI1 ) BLA05539 BX2 X3 BLA05540 AX3 59 BLA05541 BX4 X3-X2 (X4) = ABS(IMAG(CXI1 ) BLA05542 * BLA05543 RX5 X4+X5 BLA05544 NX5 X5 (X5) = (X4) + (X5) (AMAX) BLA05545 * BLA05546 * (I = I+1) BLA05547 LOOP SA2 A2+B3 (X2) = REAL(CXII ) BLA05548 BX3 X2 BLA05549 AX2 59 BLA05550 BX2 X2-X3 (X2) = ABS(REAL(CXII )) BLA05551 SA3 A2-B7 (X3) = IMAG(CXII ) BLA05552 BX7 X3 BLA05553 AX3 59 BLA05554 BX3 X3-X7 (X3) = ABS(IMAG(CXII ) BLA05555 * BLA05556 RX2 X2+X3 BLA05557 SB1 B1+B7 COUNT TERM BLA05558 NX2 X2 (X2) = (X2) + (X3) BLA05559 * BLA05560 FX0 X5-X2 BLA05561 PL X0,TEST IF ABS(REAL(CXII )) + ABS(IMAG(CXII )) .BLA05562 * BLA05563 BX5 X2 (X5) = ABS(REAL(CXII )) (AMAX) BLA05564 SX6 B4-B1 (X6) = I (ICAMAX) BLA05565 * BLA05566 TEST NZ B1,LOOP IF I .NE. N , GO TO LOOP BLA05567 * BLA05568 OUT OUTFTN ICAMAX RETURN BLA05569 END BLA05570 AXR$ 10 $(1). 20 . 30 . SINGLE PRECISION INNER PRODUCT 40 . 50 . TO BE USED AS FORTRAN FUNCTION SDOT(N,X,INCX,Y,INCY) 60 . WHERE SDOT, X, AND Y ARE OF TYPE REAL 70 . AND SDOT= SUM FROM I=1 TO N OF A(I)*B(I) WHERE 80 . A(I) = X(1-INCX+I*INCX) IF INCX.GE.0 90 . A(I) = X(1-N*INCX+I*INCX) IF INCX.LT.0 100 . B(I) DEFINED SIMILARLY, WITH X AND INCX REPLACED BY Y AND INCY 110 . 120 SDOT* SZ A0 . STORE 0 IN A0 130 SZ A3 . 0 A3 FOR INDIRECT ADDRESS. OPT. 140 LR R3,*0,X11 . STORE N IN R3 150 JGD R3,NPOS . STORE N-1 IN R3 AND TEST N 160 J 6,X11 . EXIT IF N.LE.0 170 NPOS LA,U A2,*1,X11 . LOAD ADDRESS OF X 180 LXI A2,*2,X11 . LOAD INCREMENT ON X 190 LXI A3,*4,X11 . LOAD INCREMENT ON Y 200 LXM,U A3,*3,X11 . LOAD ADDRESS OF Y 210 JP A2,TINCY . TEST IF INCX.GE.0 220 LNA A4,A2 . ADD -INCX*(N-1) 230 SSA A4,18 . TO THE BASE 240 MSI A4,R3 . ADDRESS 250 AH A2,A4 . FOR X 260 TINCY JP A3,LOOP . TEST IF INCY.GE.0 270 LNA A4,A3 . ADD -INCY*(N-1) 280 SSA A4,18 . TO THE BASE 290 MSI A4,R3 . ADDRESS 300 AH A3,A4 . FOR Y 310 . BEGIN LOOP TO FORM INNER PRODUCT 320 LOOP LA A4,0,*A2 . LOAD X AND INCREMENT INDEX 330 FM A4,0,*A3 . MULTIPLY BY Y AND INCREMENT INDEX 340 FA A0,A4 . ACCUMULATE INNER PRODUCT 350 JGD R3,LOOP . END OF INNER PRODUCT LOOP 360 J 6,X11 . RETURN FOR N.GT.0 370 . 380 END . 390 AXR$ 400 $(1). 410 . 420 . DOUBLE PRECISION ACCUMULATION INNER PRODUCT 430 . 440 . TO BE USED AS FORTRAN FUNCTION DSDOT(N,X,INCX,Y,INCY) 450 . WHERE DSDOT IS OF TYPE DOUBLE PRECISION, X AND Y ARE OF TYPE REAL, 460 . AND DSDOT= SUM FROM I=1 TO N OF A(I)*B(I) WHERE 470 . A(I) = X(1-INCX+I*INCX) IF INCX.GE.0 480 . A(I) = X(1-N*INCX+I*INCX) IF INCX.LT.0 490 . B(I) DEFINED SIMILARLY, WITH X AND INCX REPLACED BY Y AND INCY 500 . 510 DSDOT* DSL A0,72 . STORE 0 IN A0 AND A1 520 SZ A3 . 0 A3 FOR INDIRECT ADDRESS. OPT. 530 LR R3,*0,X11 . STORE N IN R3 540 JGD R3,NPOS . STORE N-1 IN R3 AND TEST N 550 J 6,X11 . EXIT IF N.LE.0 560 NPOS DS A6,SAVE . SAVE REGISTERS A6 AND A7 570 LA,U A2,*1,X11 . LOAD ADDRESS OF X 580 LXI A2,*2,X11 . LOAD INCREMENT ON X 590 LXI A3,*4,X11 . LOAD INCREMENT ON Y 600 LXM,U A3,*3,X11 . LOAD ADDRESS OF Y 610 JP A2,TINCY . TEST IF INCX.GE.0 620 LNA A4,A2 . ADD -INCX*(N-1) 630 SSA A4,18 . TO THE BASE 640 MSI A4,R3 . ADDRESS 650 AH A2,A4 . FOR X 660 TINCY JP A3,LOOP . TEST IF INCY.GE.0 670 LNA A4,A3 . ADD -INCY*(N-1) 680 SSA A4,18 . TO THE BASE 690 MSI A4,R3 . ADDRESS 700 AH A3,A4 . FOR Y 710 . BEGIN LOOP TO FORM INNER PRODUCT 720 LOOP FEL A4,0,*A2 . LOAD X, CONVERT TO DOUBLE, AND IN 730 FEL A6,0,*A3 . LOAD Y, CONVERT TO DOUBLE, AND IN 740 DFM A4,A6 . MULTIPLY X TIMES Y 750 DFA A0,A4 . ACCUMULATE INNER PRODUCT 760 JGD R3,LOOP . END OF INNER PRODUCT LOOP 770 DL A6,SAVE . RESTORE REGISTERS A6 AND A7 780 J 6,X11 . RETURN FOR N.GT.0 790 . 800 $(0) 810 SAVE + 0D . PLACE TO SAVE A6 AND A7 820 END . 830 AXR$ 840 $(1). 850 . 860 . DOUBLE PRECISION INNER PRODUCT 870 . 880 . TO BE USED AS FORTRAN FUNCTION DDOT(N,X,INCX,Y,INCY) 890 . WHERE DDOT, X, AND Y ARE OF TYPE DOUBLE PRECISION 900 . AND DDOT= SUM FROM I=1 TO N OF A(I)*B(I) WHERE 910 . A(I) = X(1-INCX+I*INCX) IF INCX.GE.0 920 . A(I) = X(1-N*INCX+I*INCX) IF INCX.LT.0 930 . B(I) DEFINED SIMILARLY, WITH X AND INCX REPLACED BY Y AND INCY 940 . 950 DDOT* DSL A0,72 . STORE 0 IN A0 AND A1 960 SZ A3 . 0 A3 FOR INDIRECT ADDRESS. OPT. 970 LR R3,*0,X11 . STORE N IN R3 980 JGD R3,NPOS . STORE N-1 IN R3 AND TEST N 990 J 6,X11 . EXIT IF N.LE.0 1000 NPOS LA,XH2 A2,*2,X11 . LOAD INCREMENT ON X 1010 LA,XH2 A3,*4,X11 . LOAD INCREMENT ON Y 1020 LSSC A2,19 . DOUBLE INCREMENTS FOR 1030 LSSC A3,19 . DOUBLE PRECISION 1040 LXM,U A2,*1,X11 . LOAD ADDRESS OF X 1050 LXM,U A3,*3,X11 . LOAD ADDRESS OF Y 1060 JP A2,TINCY . TEST IF INCX.GE.0 1070 LNA A4,A2 . ADD -INCX*(N-1) 1080 SSA A4,18 . TO THE BASE 1090 MSI A4,R3 . ADDRESS 1100 AH A2,A4 . FOR X 1110 TINCY JP A3,LOOP . TEST IF INCY.GE.0 1120 LNA A4,A3 . ADD -INCY*(N-1) 1130 SSA A4,18 . TO THE BASE 1140 MSI A4,R3 . ADDRESS 1150 AH A3,A4 . FOR Y 1160 . BEGIN LOOP TO FORM INNER PRODUCT 1170 LOOP DL A4,0,*A2 . LOAD X AND INCREMENT INDEX 1180 DFM A4,0,*A3 . MULTIPLY BY Y AND INCREMENT INDEX 1190 DFA A0,A4 . ACCUMULATE INNER PRODUCT 1200 JGD R3,LOOP . END OF INNER PRODUCT LOOP 1210 J 6,X11 . RETURN FOR N.GT.0 1220 . 1230 END . 1240 AXR$ 1250 $(1). 1260 . 1270 . COMPLEX ACCUMULATION INNER PRODUCT 1280 . 1290 . TO BE USED AS FORTRAN FUNCTION CDOTC(N,X,INCX,Y,INCY) 1300 . WHERE CDOTC, X AND Y ARE OF TYPE COMPLEX 1310 . AND CDOTC = SUM FROM 1 TO N OF B(I) * COMPLEX CONJUGATE OF A(I) 1320 . WHERE A(I)=X(1-INCX+I*INCX) IF INCX.GE.0 1330 . AND A(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 1340 . AND B(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED 1350 . BY Y AND INCY 1360 . 1370 CDOTC* DSL A0,72 . STORE ZERO IN A4 AND A5 1380 SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 1390 LR R3,*0,X11 . LOAD N IN R3 1400 JGD R3,NPOS . STORE N-1 IN R3, TEST N 1410 J 6,X11 . IF N.LE.0 RETURN 1420 NPOS SR R3,A5 . STORE N-1 IN A5 1430 DS A6,A6A7 . SAVE CONTENTS OF A6 AND A7 REGISTERS 1440 DS A8,A8A9 . SAVE CONTENTS OF A8 AND A9 REGISTERS 1450 SZ A8 . STORE ZERO IN A8 1460 LA,XH2 A2,*2,X11 . LOAD 2*INCX AND 2*INCY 1470 LA,XH2 A3,*4,X11 . IN THE LEFT HALVES 1480 LSSC A2,19 . OF A2 AND A3, 1490 LSSC A3,19 . RESPECTIVELY 1500 LXM,U A2,*1,X11 . LOAD ADDRESS OF X 1510 LXM,U A3,*3,X11 . LOAD ADDRESS OF Y 1520 LSSC A5,1 . FORM 2*(N-1) IN A5 1530 JP A2,TINCY . IF INCX IS NEGATIVE 1540 LNA A4,*2,X11 . ADD -2*INCX*(N-1) 1550 MSI A4,A5 . TO THE BASE 1560 AH A2,A4 . ADDRESS FOR X 1570 TINCY JP A3,LOOP . IF INCY IS NEGATIVE 1580 MSI A5,*4,X11 . ADD -2*INCY*(N-1) 1590 ANH A3,A5 . TO THE BASE ADDRESS FOR Y 1600 . BEGIN LOOP 1610 LOOP LA A5,0,A2 . LOAD REAL PART OF X 1620 FM A5,0,A3 . FORM REAL X * REAL Y 1630 LOAD LNA A4,1,A2 . LOAD IMAG. PART OF X 1640 SA A4,A6 . STORE IMAG. X IN A6 1650 FM A6,1,A3 . FORM IMAG. X * IMAG. Y 1660 FAN A5,A6 . FORM REAL X*Y AND 1670 FA A0,A5 . ACCUMULATE IN A0 1680 FM A4,0,A3 . FORM IMAG. X * REAL Y 1690 LA A5,0,*A2 . LOAD REAL X AND INCREMENT X INDEX 1700 FM A5,1,*A3 . FORM REAL X * IMAG. Y, INCREMENT Y IN 1710 FA A4,A5 . FORM IMAG. X*Y AND 1720 FA A8,A4 . ACCUMULATE IN A8 1730 JGD R3,LOOP . END OF LOOP 1740 SA A8,A1 . STORE SUM OF IMAG X*Y IN A1 1750 DL A6,A6A7 . RESTORE A6 AND A7 REGISTERS 1760 DL A8,A8A9 . RESTORE A8 AND A9 REGISTERS 1770 J 6,X11 . RETURN 1780 $(0). 1790 A6A7 + 0D . PLACE TO SAVE A6 AND A7 REGISTERS 1800 A8A9 + 0D . PLACE TO SAVE A8 AND A9 REGISTERS 1810 . 1820 END . 1830 AXR$ 1840 $(1). 1850 . 1860 . COMPLEX ACCUMULATION INNER PRODUCT 1870 . 1880 . TO BE USED AS FORTRAN FUNCTION CDOTU(N,X,INCX,Y,INCY) 1890 . WHERE CDOTU, X AND Y ARE OF TYPE COMPLEX 1900 . AND CDOTU = SUM FROM 1 TO N OF A(I)*B(I) 1910 . WHERE A(I)=X(1-INCX+I*INCX) IF INCX.GE.0 1920 . AND A(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 1930 . AND B(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED 1940 . BY Y AND INCY 1950 . 1960 CDOTU* DSL A0,72 . STORE ZERO IN A4 AND A5 1970 SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 1980 LR R3,*0,X11 . LOAD N IN R3 1990 JGD R3,NPOS . STORE N-1 IN R3, TEST N 2000 J 6,X11 . IF N.LE.0 RETURN 2010 NPOS SR R3,A5 . STORE N-1 IN A5 2020 DS A6,A6A7 . SAVE CONTENTS OF A6 AND A7 REGISTERS 2030 DS A8,A8A9 . SAVE CONTENTS OF A8 AND A9 REGISTERS 2040 SZ A8 . STORE ZERO IN A8 2050 LA,XH2 A2,*2,X11 . LOAD 2*INCX AND 2*INCY 2060 LA,XH2 A3,*4,X11 . IN THE LEFT HALVES 2070 LSSC A2,19 . OF A2 AND A3, 2080 LSSC A3,19 . RESPECTIVELY 2090 LXM,U A2,*1,X11 . LOAD ADDRESS OF X 2100 LXM,U A3,*3,X11 . LOAD ADDRESS OF Y 2110 LSSC A5,1 . FORM 2*(N-1) IN A5 2120 JP A2,TINCY . IF INCX IS NEGATIVE 2130 LNA A4,*2,X11 . ADD -2*INCX*(N-1) 2140 MSI A4,A5 . TO THE BASE 2150 AH A2,A4 . ADDRESS FOR X 2160 TINCY JP A3,LOOP . IF INCY IS NEGATIVE 2170 MSI A5,*4,X11 . ADD -2*INCY*(N-1) 2180 ANH A3,A5 . TO THE BASE ADDRESS FOR Y 2190 . BEGIN LOOP 2200 LOOP LA A5,0,A2 . LOAD REAL PART OF X 2210 FM A5,0,A3 . FORM REAL X * REAL Y 2220 LOAD LA A4,1,A2 . LOAD IMAG. PART OF X 2230 SA A4,A6 . STORE IMAG. X IN A6 2240 FM A6,1,A3 . FORM IMAG. X * IMAG. Y 2250 FAN A5,A6 . FORM REAL X*Y AND 2260 FA A0,A5 . ACCUMULATE IN A0 2270 FM A4,0,A3 . FORM IMAG. X * REAL Y 2280 LA A5,0,*A2 . LOAD REAL X AND INCREMENT X INDEX 2290 FM A5,1,*A3 . FORM REAL X * IMAG. Y, INCREMENT Y IN 2300 FA A4,A5 . FORM IMAG. X*Y AND 2310 FA A8,A4 . ACCUMULATE IN A8 2320 JGD R3,LOOP . END OF LOOP 2330 SA A8,A1 . STORE SUM OF IMAG X*Y IN A1 2340 DL A6,A6A7 . RESTORE A6 AND A7 REGISTERS 2350 DL A8,A8A9 . RESTORE A8 AND A9 REGISTERS 2360 J 6,X11 . RETURN 2370 $(0). 2380 A6A7 + 0D . PLACE TO SAVE A6 AND A7 REGISTERS 2390 A8A9 + 0D . PLACE TO SAVE A8 AND A9 REGISTERS 2400 . 2410 END . 2420 AXR$ 2430 $(1). 2440 . 2450 . SINGLE PRECISION ELEMENTARY VECTOR OPERATION 2460 . 2470 . TO BE USED AS FORTRAN SUBROUTINE SAXPY(N,A,X,INCX,Y,INCY) 2480 . A, X, AND Y ARE TYPE SINGLE PRECISION 2490 . YY(I) IS REPLACED BY A*XX(I) + YY(I), I = 1,N 2500 . WHERE XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 2510 . AND XX(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 2520 . AND YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED BY 2530 . Y AND INCY 2540 . 2550 SAXPY* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 2560 LR R3,*0,X11 . LOAD N IN R3 2570 JGD R3,NPOS . STORE N-1 IN R3, TEST N 2580 J 7,X11 . IF N.LE.0 RETURN 2590 NPOS LA A0,*1,X11 . STORE A IN A0 2600 JZ A0,EXIT . FAST EXIT IF A=0 2610 LA,U A2,*2,X11 . LOAD THE ADDRESS OF X AND 2620 LXI A2,*3,X11 . INCX 2630 LXI A3,*5,X11 . LOAD INCY AND 2640 LXM,U A3,*4,X11 . THE ADDRESS OF Y 2650 JP A2,TINCY . TEST IF INCX .GE. 0 2660 LNA A4,A2 . ADD -INCX*(N-1) 2670 SSA A4,18 . TO THE BASE 2680 MSI A4,R3 . ADDRESS 2690 AH A2,A4 . FOR X 2700 TINCY JP A3,LOOP . TEST IF INCY .GE. 0 2710 LNA A4,A3 . ADD -INCY*(N-1) 2720 SSA A4,18 . TO THE BASE 2730 MSI A4,R3 . ADDRESS 2740 AH A3,A4 . FOR Y 2750 . BEGIN LOOP TO 2760 LOOP LA A4,0,*A2 . LOAD X AND INCREMENT INDEX 2770 FM A4,A0 . FORM A*X 2780 FA A4,0,A3 . FORM A*X+Y AND 2790 SA A4,0,*A3 . STORE RESULT IN Y AND INCREMENT INDEX 2800 JGD R3,LOOP . END OF LOOP 2810 EXIT J 7,X11 . RETURN 2820 . 2830 END . 2840 AXR$ 2850 $(1). 2860 . 2870 . DOUBLE PRECISION ELEMENTARY VECTOR OPERATION 2880 . 2890 . TO BE USED AS FORTRAN SUBROUTINE DAXPY(N,A,X,INCX,Y,INCY) 2900 . A, X, AND Y ARE TYPE DOUBLE PRECISION 2910 . YY(I) IS REPLACED BY A*XX(I) + YY(I), I = 1,N 2920 . WHERE XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 (I=1,N) 2930 . AND XX(I)=X(1-N*INCX+INCX*I) IF INCX.LT.0 (I=1,N) 2940 . AND YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED 2950 . BY Y AND INCY 2960 . 2970 DAXPY* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 2980 LR R3,*0,X11 . LOAD N IN R3 2990 JGD R3,NPOS . STORE N-1 IN R3, TEST N 3000 J 7,X11 . IF N.LE.0 RETURN 3010 NPOS DL A0,*1,X11 . STORE A IN A0 AND A1 3020 JZ A0,EXIT . FAST EXIT IF A=0 3030 LA,XH2 A2,*3,X11 . STORE 2*INCX IN 3040 LSSC A2,19 . THE LEFT HALF OF A2 3050 LA,XH2 A3,*5,X11 . STORE 2*INCY IN 3060 LSSC A3,19 . THE LEFT HALF OF A3 3070 LXM,U A2,*2,X11 . LOAD THE ADDRESS OF X 3080 LXM,U A3,*4,X11 . LOAD THE ADDRESS OF Y 3090 JP A2,TINCY . TEST IF INCX .GE. 0 3100 LNA A4,A2 . ADD -INCX*(N-1) 3110 SSA A4,18 . TO THE BASE 3120 MSI A4,R3 . ADDRESS 3130 AH A2,A4 . FOR X 3140 TINCY JP A3,LOOP . TEST IF INCY .GE. 0 3150 LNA A4,A3 . ADD -INCY*(N-1) 3160 SSA A4,18 . TO THE BASE 3170 MSI A4,R3 . ADDRESS 3180 AH A3,A4 . FOR V 3190 LOOP DL A4,0,*A2 . LOAD X AND INCREMENT INDEX 3200 DFM A4,A0 . FORM A*X 3210 DFA A4,0,A3 . FORM A*X+Y AND 3220 DS A4,0,*A3 . STORE IN Y, INCREMENT Y INDEX 3230 JGD R3,LOOP . END OF LOOP 3240 EXIT J 7,X11 . RETURN 3250 . 3260 END . 3270 $(1). 3280 AXR$ . 3290 . 3300 . APPLY MODIFIED GIVENS TRANSFORMATION TO (XX(1) ... XX(N)) 3310 . (YY(1) ... YY(N)) 3320 . TO BE USED AS FORTRAN SUBROUTINE SROT(N,X,INCX,Y,INCY,PARAM) 3330 . X,Y, AND PARAM ARE SINGLE PRECISION -- SEE SROTMG FOR DEF. OF PARAM 3340 . 3350 . XX(I)=X(1-INCX+I*INCX) IF INCX .GE. 0 3360 . XX(I)=X(1-N*INCX+I*INCX) IF INCY .LT. 0 3370 . YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED 3380 . BY Y AND INCY. 3390 . 3400 SROTM* SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 3410 LR R3,*0,X11 . LOAD N IN R3 3420 JGD R3,NPOS . STORE N-1 IN R3, TEST N 3430 J 7,X11 . IF N .LE. 0 RETURN 3440 . 3450 NPOS LA,U A1,*1,X11 . LOAD X ADDRESS 3460 LA,U A2,*3,X11 . LOAD Y ADDRESS 3470 LXI A1,*2,X11 . LOAD INCX 3480 LXI A2,*4,X11 . LOAD INCY 3490 JP A1,TINCY . IF INCX IS NEGATIVE 3500 LNA A5,*2,X11 . ADD -INCX*(N-1) 3510 MSI A5,R3 . TO THE BASE 3520 AH A1,A5 . ADDRESS FOR X 3530 TINCY JP A2,LOOP . IF INCY IS NEGATIVE 3540 LNA A4,*4,X11 . ADD -INCY*(N-1) 3550 MSI A4,R3 . TO THE BASE 3560 AH A2,A4 . ADDRESS FOR Y 3570 . 3580 LOOP LA,U A0,*5,X11 . LOAD PARAM STARTING ADDRESS 3590 LA A3,0,A0 . LOAD FLAG 3600 JZ A3,ZERO . IF FLAG=0, TAKE ROUTE ZERO 3610 JN A3,NEG . IF FLAG .LT. 0, TAKE ROUTE NEG 3620 . FLAG IS POSITIVE 3630 POS LA A3,0,A1 . LOAD X 3640 FM A3,1,A0 . FORM H11 * X 3650 FA A3,0,A2 . ADD Y TO IT 3660 LA A4,0,A2 . LOAD Y 3670 FM A4,4,A0 . FORM H22 * 4 3680 FAN A4,0,A1 . ADD -X TO IT 3690 SA A3,0,*A1 . STORE NEW X, INCREMENT INDEX 3700 SA A4,0,*A2 . STORE NEW Y, INCREMENT INDEX 3710 JGD R3,POS . BOTTOM OF LOOP 3720 J 7,X11 . RETURN 3730 . FLAG IS ZERO 3740 ZERO LA A3,0,A2 . LOAD Y 3750 FM A3,3,A0 . FORM H12 * Y 3760 FA A3,0,A1 . ADD X TO IT 3770 LA A4,0,A1 . LOAD X 3780 FM A4,2,A0 . FORM H21 * X 3790 FA A4,0,A2 . ADD Y TO IT 3800 SA A3,0,*A1 . STORE NEW X, INCREMENT INDEX 3810 SA A4,0,*A2 . STORE NEW Y, INCREMENT INDEX 3820 JGD R3,ZERO . BOTTOM OF LOOP 3830 J 7,X11 . RETURN 3840 . FLAG IS NEGATIVE 3850 NEG TNE A3,(-2.0) . TEST FOR FLAG = -2 3860 J 7,X11 . IF FLAG = -2, RETURN 3870 SA A6,SAVE . SAVE A6 CONTENTS 3880 NEGL LA A3,0,A1 . LOAD X 3890 FM A3,1,A0 . FORM H11 * X 3900 LA A4,0,A2 . LOAD Y 3910 FM A4,3,A0 . FORM H12 * Y AND 3920 FA A3,A4 . ADD TO H11 * X 3930 LA A4,0,A1 . LOAD X 3940 FM A4,2,A0 . FORM H21 * X 3950 LA A5,0,A2 . LOAD Y 3960 FM A5,4,A0 . FORM H22 * Y AND 3970 FA A4,A5 . ADD TO H21 * X 3980 SA A3,0,*A1 . STORE NEW X, INCREMENT INDEX 3990 SA A4,0,*A2 . STORE NEW Y, INCREMENT INDEX 4000 JGD R3,NEGL . BOTTOM OF LOOP 4010 LA A6,SAVE . RESTORE A6 4020 J 7,X11 . RETURN 4030 . 4040 $(0). 4050 SAVE + 0 . PLACE TO SAVE A6 4060 END 4070 AXR$ 4080 $(1). 4090 . 4100 . SINGLE PRECISION COPY X INTO Y 4110 . 4120 . TO BE USED AS FORTRAN SUBROUTINE SCOPY(N,X,INCX,Y,INCY) 4130 . WHERE X AND Y ARE OF TYPE SINGLE PRECISION. 4140 . XX(I) IS COPIED INTO YY(I), I=1,N WHERE 4150 . XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 AND 4160 . XX(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 AND 4170 . YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED BY Y AND INCY 4180 . 4190 SCOPY* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 4200 LR R1,*0,X11 . LOAD N IN R1 4210 LA A4,R1 . LOAD N IN A4 4220 JGD A4,NPOS . STORE N-1 IN A4, TEST N 4230 J 6,X11 . IF N.LE.0 RETURN 4240 NPOS LA,U A0,*1,X11 . LOAD ADDRESS OF X 4250 LA,U A1,*3,X11 . LOAD ADDRESS OF Y 4260 LXI A0,*2,X11 . LOAD INCX 4270 LXI A1,*4,X11 . LOAD INCY 4280 JP A0,TINCY . IF INCX IS NEGATIVE, 4290 LNA A2,*2,X11 . ADD -INCX*(N-1) 4300 MSI A2,A4 . TO THE BASE 4310 AH A0,A2 . ADDRESS FOR X 4320 TINCY JP A1,LOOP . IF INCY IS NEGATIVE, 4330 MSI A4,*4,X11 . ADD -INCY*(N-1) 4340 ANH A1,A4 . TO THE BASE ADDRESS FOR Y 4350 . 4360 LOOP BT A1,0,*A0 . COPY X INTO Y 4370 J 6,X11 . RETURN 4380 END . 4390 AXR$ 4400 $(1). 4410 . 4420 . DOUBLE PRECISION COPY X INTO Y AND COMPLEX COPY X INTO Y 4430 . 4440 . TO BE USED AS FORTRAN SUBROUTINE DCOPY(N,X,INCX,Y,INCY) 4450 . OR CCOPY(N,X,INCX,Y,INCY) 4460 . WHERE X AND Y ARE OF TYPE DOUBLE PRECISION FOR DCOPY 4470 . AND TYPE COMPLEX FOR CCOPY. 4480 . XX(I) IS COPIED INTO YY(I), I=1,N WHERE 4490 . XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 AND 4500 . XX(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 AND 4510 . YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED BY Y AND INCY 4520 CCOPY* 4530 DCOPY* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 4540 LR R1,*0,X11 . STORE N IN R1 4550 LA A4,R1 . LOAD N INTO A4 4560 JGD A4,NPOS . TEST N, STORE N-1 IN A4 4570 J 6,X11 . IF N.LE.0 RETURN 4580 NPOS SR R1,R3 . STORE N IN R3 4590 LA,XH2 A0,*2,X11 . LOAD 2*INCX IN THE 4600 LSSC A0,19 . LEFT HALF OF A0 4610 LA,XH2 A1,*4,X11 . LOAD 2*INCY IN THE 4620 LSSC A1,19 . LEFT HALF OF A1 4630 LXM,U A0,*1,X11 . LOAD THE ADDRESS OF X 4640 LXM,U A1,*3,X11 . LOAD THE ADDRESS OF Y 4650 LSSC A4,1 . FORM 2*(N-1) 4660 JP A0,TINCY . IF INCX IS NEGATIVE 4670 LNA A2,*2,X11 . ADD -2*INCX*(N-1) 4680 MSI A2,A4 . TO THE BASE 4690 AH A0,A2 . ADDRESS FOR X 4700 TINCY JP A1,SAVE . IF INCY IS NEGATIVE, 4710 MSI A4,*4,X11 . ADD -2*INCY*(N-1) 4720 ANH A1,A4 . TO THE BASE ADDRESS FOR Y 4730 SAVE DS A0,A2 . STORE X AND Y INDEXES 4740 BT A1,0,*A0 . BLOCK TRANSFER FIRST HALF OF EACH NO. 4750 SR R3,R1 . RELOAD R1 WITH N 4760 AH A2,(1) . ADD 1 TO THE BASE ADDRESS FOR X 4770 AH A3,(1) . ADD 1 TO THE BASE ADDRESS FOR Y 4780 BT A3,0,*A2 . BLOCK TRANS. SECOND HALF OF EACH NO. 4790 J 6,X11 . RETURN 4800 . 4810 END . 4820 AXR$ 4830 $(1). 4840 . 4850 . INTERCHANGE INCREMENTED X AND Y COMPONENTS 4860 . 4870 . TO BE USED AS FORTRAN SUBROUTINE DSWAP(N,X,INCX,Y,INCY) 4880 . AND AS FORTRAN SUBROUTINE CSWAP(N,X,INCX,Y,INCY) 4890 . WHERE X AND Y ARE OF TYPE DOUBLE PRECISION FOR DSWAP 4900 . AND TYPE COMPLEX FOR CSWAP 4910 . XX(I) IS INTERCHANGED WITH YY(I), I=1,N WHERE 4920 . XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 AND 4930 . XX(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 AND 4940 . YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED BY Y AND INCY 4950 . 4960 CSWAP* 4970 DSWAP* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 4980 LR R3,*0,X11 . LOAD N IN R3 4990 JGD R3,NPOS . STORE N-1 IN R3, TEST N 5000 J 6,X11 . IF N.LE.0 RETURN 5010 NPOS LA,XH2 A2,*2,X11 . LOAD 2*INCX IN THE 5020 LSSC A2,19 . LEFT HALF OF A2 5030 LA,XH2 A3,*4,X11 . LOAD 2*INCY IN THE 5040 LSSC A3,19 . LEFT HALF OF A3 5050 LXM,U A2,*1,X11 . LOAD THE ADDRESS OF X 5060 LXM,U A3,*3,X11 . LOAD THE ADDRESS OF Y 5070 JP A2,TINCY . TEST IF INCX .GE. 0 5080 LNA A4,A2 . ADD -INCX*(N-1) 5090 SSA A4,18 . TO THE BASE 5100 MSI A4,R3 . ADDRESS 5110 AH A2,A4 . FOR X 5120 TINCY JP A3,LOOP . TEST IF INCY .GE. 0 5130 LNA A4,A3 . ADD -INCY*(N-1) 5140 SSA A4,18 . TO THE BASE 5150 MSI A4,R3 . ADDRESS 5160 AH A3,A4 . FOR Y 5170 LOOP DL A0,0,A2 . LOAD X 5180 DL A4,0,A3 . LOAD Y 5190 DS A4,0,*A2 . STORE Y IN X AND INCREMENT X INDEX 5200 DS A0,0,*A3 . STORE X IN Y AND INCREMENT Y INDEX 5210 JGD R3,LOOP . END OF LOOP 5220 J 6,X11 . RETURN 5230 END . 5240 AXR$ 5250 $(1). 5260 . 5270 . SQRT OF SUM OF SQUARES OF COMPONENTS OF X 5280 . 5290 . TO BE USED AS FORTRAN FUNCTION SNRM2(N,X,INCX) 5300 . WHERE SNRM2 IS THE SQUARE ROOT OF THE SUM FROM I=1 TO N OF 5310 . X(1-INCX+I*INCX) 5320 . SNRM2 AND X ARE OF TYPE REAL 5330 . 5340 . THIS VERSION OF SNRM2 USES MACHINE-DEPENDENT CONSTANTS TO 5350 . AVOID UNDERFLOW AND OVERFLOW. 5360 . THE CONSTANTS FOR THE UNIVAC 1108 ARE... 5370 . UNDERFLOW -- 1.E-15 5380 . OVERFLOW-- 1.E17 OVERFLOW PROTECTION-- 1.E21 5390 . 5400 SNRM2* SZ A0 . STORE ZERO IN A0 5410 SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 5420 LR R3,*0,X11 . LOAD N IN R3 5430 JGD R3,NPOS . STORE N-1 IN R3, TEST N 5440 J 4,X11 . IF N.LE.0 RETURN 5450 NPOS LA,U A2,*1,X11 . LOAD X ADDRESS AND 5460 LXI A2,*2,X11 . INCX IN A2 5470 SA A2,A3 . AND A3 5480 SZ A5 . STORE ZERO IN A5 5490 DS A6,A6A7 . SAVE THE CONTENTS OF A6 AND A7 REGIST 5500 SR R3,R1 . STORE N-1 IN R1 5510 . BEGIN UNDERFLOW LOOP 5520 UNDER LMA A4,0,*A3 . LOAD ABS X AND INCREMENT X INDEX 5530 TG A4,MIN . IF ABS X .GT. MACHINE MIN, 5540 J OVER . GO TO TEST FOR OVERFLOW. OTHERWISE 5550 TLE A5,A4 . IF U .LT. ABS X, 5560 SA A4,A5 . U= ABS X THAT WAS .GT. U 5570 JGD R3,UNDER . END OF UNDERFLOW LOOP 5580 JZ A5,4,X11 . IF U=0, RETURN. OTHERWISE 5590 AND A5,MASK . STORE A5 EXPONENT IN A6 5600 J EXP+1 . GO COMPUTE SNRM2 5610 . BEGIN OVERFLOW LOOP 5620 OVER LMA A4,0,*A2 . LOAD ABS X AND INCREMENT X INDEX 5630 TG A4,MAX . IF ABS X IS TOO LARGE, 5640 J EXP . GO PROTECT FROM OVERFLOW. OTHERWISE 5650 FM A4,A4 . SQUARE X 5660 FA A0,A4 . ACCUMULATE SUM OF SQUARES 5670 JGD R1,OVER . END OF OVERFLOW LOOP 5680 LA A7,(1.0) . STORE 1.E0 IN A7 5690 ROOT SX X11,WB+1 . SAVE X11 CONTENTS 5700 SA A0,SUM . STORE SUM OF SQUARES IN SUM 5710 LMJ X11,SQRT . GO COMPUTE SQUARE ROOT OF SUM 5720 + SUM . 5730 + $-SNRM2,WB . 5740 FM A0,A7 . COMPUTE THE TRUE VALUE OF SNRM2 5750 LX X11,WB+1 . RESTORE X11 5760 DL A6,A6A7 . RESTORE A6 AND A7 5770 J 4,X11 . RETURN 5780 EXP LA A6,COMP . STORE 1.E22 EXPONENT IN A6 5790 AU A6,FRAC . STORE 1.E22 IN A7 5800 ANA A6,BIAS . COMPUTE BIASED EXPONENT 5810 JZ A0,MOD+1 . IF SNRM2=0, GO COMPUTE SNRM2. OTHERWI 5820 ANA A0,A6 . COMPUTE SNRM2/U 5830 ANA A0,A6 . /U 5840 JP A0,MOD+1 . IF SNRM2 .GT.0 GO COMPUTE THE REST OF 5850 SZ A0 . OTHERWISE ZERO IT OUT, THEN 5860 J MOD+1 . GO FINISH THE COMPUTATIONS 5870 MOD LMA A4,0,*A2 . LOAD ABS X AND INCREMENT X INDEX 5880 ANA A4,A6 . MODIFY EXPONENT OF X 5890 FM A4,A4 . SQUARE X 5900 FA A0,A4 . ACCUMULATE SUM OF SQUARES 5910 JGD R1,MOD . END OF LOOP TO ACCUMULATE SQUARES 5920 J ROOT . GO COMPUTE SQUARE ROOT 5930 $(0) . 5940 A6A7 + 0D . PLACE TO SAVE A6 AND A7 CONTENTS 5950 SUM + 0 . PLACE TO SAVE SUM OF SQUARES 5960 WB + 'SNRM2' . WALKBACK WORD 5970 + 0 . PLACE TO STORE X11 5980 MIN + (01150,0,0) MACHINE MINIMUM EXPONENT 5990 MAX + (02700,0,0) MACHINE MAXIMUM EXPONENT 6000 COMP + (03130,0,0) VALUE TO COMPENSATE FOR OVERFLOW (EXP 6010 BIAS + (02000,0,0) BIAS ON THE EXPONENT 6020 MASK + (07770,0,0) MASK FOR 1.E-15 EXPONENT 6030 FRAC + (00014,0,0) MANTISSA FOR 1.E-15 AND 1.E22 6040 . 6050 END . 6060 AXR$ 6070 $(1). 6080 . 6090 . DOUBLE PRECISION SQRT OF SUM OF SQUARES OF X COMPONENTS 6100 . TO BE USED AS FORTRAN SUBROUTINE DNRM2(N,X,INCX) 6110 . WHERE DNRM2 IS THE SQUARE ROOT OF THE SUM FROM I=1 TO N OF 6120 . X(1-INCX+I*INCX) 6130 . DNRM2 AND X ARE OF TYPE DOUBLE PRECISION 6140 . 6150 . THIS VERSION OF DNRM2 USES MACHINE-DEPENDENT CONSTANTS TO 6160 . AVOID OVERFLOW AND UNDERFLOW 6170 . THE CONSTANTS FOR THE UNIVAC 1108 ARE ... 6180 . UNDERFLOW-- 1.D-149 6190 . OVERFLOW-- 1.D+149 OVERFLOW PROTECTION-- 1.D+157 6200 DNRM2* DSL A0,72 . STORE ZERO IN A0 AND A1 6210 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 6220 LR R3,*0,X11 . LOAD N IN R3 6230 JGD R3,NPOS . STORE N-1 IN R3, TEST N 6240 J 4,X11 . IF N.LE.0, RETURN 6250 NPOS LA,XH2 A3,*2,X11 . LOAD 2*INCX IN THE 6260 LSSC A3,19 . LEFT HALF OF A3 6270 LXM,U A3,*1,X11 . LOAD THE ADDRESS OF X 6280 SA A3,A2 . STORE X INDEX IN A2 6290 DS A6,A6A7 . SAVE CONTENTS OF A6 AND A7 REGISTERS 6300 SA A8,SAVE . SAVE CONTENTS OF A8 REGISTER 6310 SZ A5 . STORE ZERO IN A5 6320 SZ A8 . STORE ZERO IN A8 6330 SR R3,R1 . STORE N-1 IN R1 6340 . BEGIN UNDERFLOW LOOP 6350 UNDER LMA A4,0,*A3 . LOAD TOP HALF OF ABS X, INCREMENT X I 6360 TG A4,MIN . IF ABS X .GT. MACHINE MIN, 6370 J OVER . GO TO TEST FOR OVERFLOW. OTHERWISE 6380 TLE A5,A4 . IF U .LT. ABS X 6390 SA A4,A5 . U= ABS X THAT WAS .GT. U 6400 JGD R3,UNDER . END OF UNDERFLOW LOOP 6410 JZ A5,4,X11 . IF U=0, RETURN. OTHERWISE 6420 AND A5,MASK . STORE AS EXPONENT IN A6 6430 . BEGIN OVERFLOW LOOP (USUAL CASE) 6440 AU A6,FRAC . STORE U IN A7 6450 ANA A6,BIAS . COMPUTE BIASED EXPONENT 6460 J MOD . GO COMPUTE DNRM2 6470 OVER DLM A4,0,*A2 . LOAD ABS X 6480 TG A4,MAX . IF ABS X IS TOO LARGE, 6490 J EXP . GO PROTECT FROM OVERFLOW. OTHERWISE 6500 DFM A4,A4 . SQUARE X 6510 DFA A0,A4 . ACCUMULATE SUM OF SQUARES 6520 JGD R1,OVER . END OF OVERFLOW LOOP 6530 LA A7,ONE . STORE 1.DO IN A7 (A8 ALREADY = ZERO) 6540 ROOT SX X11,WB+1 . SAVE X11 CONTENTS 6550 DS A0,SUM . STORE SUM OF SQUARES IN SUM 6560 LMJ X11,DSQRT . GO COMPUTE SQUARE ROOT OF SUM 6570 + SUM . 6580 + $-DNRM2,WB . 6590 DFM A0,A7 . COMPUTE THE TRUE VALUE OF DNRM2 6600 LX X11,WB+1 . RESTORE X11 6610 DL A6,A6A7 . RESTORE A6 AND A7 6620 LA A8,SAVE . RESTORE A8 6630 J 4,X11 . RETURN 6640 EXP LA A6,COMP . STORE 1.D157 EXPONENT IN A6 6650 AU A6,FRAC . STORE U IN A7 6660 ANA A6,BIAS . COMPUTE BIASED EXPONENT 6670 ANA A0,A6 . COMPUTE DNRM2/U 6680 ANA A0,A6 . /U 6690 JP A0,MOD+1 . IF DNRM2 .GE.0 GO COMPUTE THE REST OF 6700 DSL A0,72 . OTHERWISE ZERO IT OUT, THEN 6710 J MOD+1 . GO FINISH THE COMPUTATIONS 6720 MOD DLM A4,0,*A2 . LOAD ABS X AND INCREMENT X INDEX 6730 ANA A4,A6 . MODIFY EXPONENT OF X 6740 DFM A4,A4 . SQUARE X 6750 DFA A0,A4 . ACCUMULATE SUM OF SQUARES 6760 JGD R1,MOD . END OF LOOP TO ACCUMULATE SQUARES 6770 J ROOT . GO COMPUTE SQUARE ROOT 6780 $(0). 6790 A6A7 + 0D . PLACE TO SAVE A6 AND A7 CONTENTS 6800 SAVE + 0 . PLACE TO SAVE A8 CONTENTS 6810 SUM + 0D . PLACE TO SAVE SUM OF SQUARES 6820 WB + 'DNRM2' . WALKBACK WORD 6830 + 0 . PLACE TO STORE X11 6840 MIN + (01036,0,0) . MIN EXPONEN,2**-482, APPROX 1.D- 6850 MAX + (02761,0,0) . MAX EXPONENT=2**497, APPROX 1.D1 6860 COMP + (03016,0,0) . OVERFLOW PROTECTION EXPONENT 6870 BIAS + (02000,0,0) . BIAS ON THE EXPONENT 6880 MASK + (03777,0,0) . MASK FOR MIN EXPONENT 6890 FRAC + (00001,04000,0) . CONVERTS EXPONENT TO EXPONENT W 6900 . FRACTION OF .5 6910 ONE + (02001,04000,0) . TOP PART OF 1.D0 6920 . 6930 END . 6940 AXR$ 6950 $(1). 6960 . 6970 . SQRT OF SUM OF SQUARES OF COMPONENTS OF X 6980 . 6990 . TO BE USED AS FORTRAN FUNCTION SCNRM2(N,X,INCX) 7000 . WHERE SCNRM2 IS THE SQUARE ROOT OF THE SUM FROM I=1 TO N OF 7010 . (ABS(X(1-INCX+I*INCX)))**2 7020 . SCNRM2 IS OF TYPE REAL AND X IS OF TYPE COMPLEX 7030 . 7040 . THIS VERSION OF SCNRM2 USES MACHINE DEPENDENT CONSTANTS TO 7050 . AVOID UNDERFLOW AND OVERFLOW 7060 . THE CONSTANTS FOR THE UNIVAC 1108 ARE ... 7070 . UNDERFLOW -- 1.E-15 7080 . OVERFLOW -- 1.E+17 OVERFLOW PROTECTION -- 1.E+22 7090 . 7100 SCNRM2* SZ A0 . STORE ZERO IN A0 7110 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 7120 LR R3,*0,X11 . LOAD N IN R3 7130 JGD R3,NPOS . STORE N-1 IN R3, TEST N 7140 J 4,X11 . IN N.LE.0 RETURN 7150 NPOS SR R3,R1 . STORE N-1 IN R1 7160 DS A6,A6A7 . SAVE THE CONTENTS OF A6 AND A7 REGIST 7170 SZ A6 . STORE ZERO IN A6 7180 LA,XH2 A3,*2,X11 . LOAD 2* INCX IN THE 7190 LSSC A3,19 . LEFT HALF OF A3 7200 LXM,U A3,*1,X11 . LOAD THE ADDRESS OF X 7210 SA A3,A2 . STORE X INDEX IN A2 7220 . TOP OF UNDERFLOW LOOP 7230 UNDER LMA A4,0,A3 . LOAD ABS REAL X 7240 LMA A5,1,*A3 . LOAD ABS IMAG X AND INCREMENT INDEX 7250 FA A4,A5 . ADD THE TWO PARTS OF X 7260 TG A4,MIN . IF ABS X .GT. MACHINE MIN 7270 J OVER . GO TO TEST FOR OVERFLOW. OTHERWISE 7280 TLE A6,A4 . IF U .LT. ABS X 7290 SA A4,A6 . STORE ABS X IN U 7300 JGD R3,UNDER . BOTTOM OF UNDERFLOW LOOP 7310 JZ A6,4,X11 . IF U=0, RETURN. OTHERWISE 7320 SA A6,A5 . STORE U IN A5 7330 AND A5,MASK . STORE EXPONENT OF U IN A6 7340 AU A6,FRAC . STORE U IN A7 7350 ANA A6,BIAS . COMPUTE BIASED EXPONENT AND 7360 SA A6,BIAS . STORE IN BIAS 7370 J MOD . GO COMPUTE SCNRM2 7380 . TOP OF OVERFLOW LOOP 7390 OVER LMA A3,0,A2 . LOAD ABS REAL X 7400 LMA A5,1,*A2 . LOAD ABS IMAG X AND INCREMENT INDEX 7410 TLE A3,MAX . TEST OT SEE IF EITHER PART OF X 7420 TG A5,MAX . WILL CAUSE AN OVERFLOW 7430 J EXP . IF YES, GO PROTECT FROM OVERFLOW. EL 7440 FM A3,A3 . SQUARE REAL X 7450 FM A5,A5 . SQUARE IMAG X AND 7460 FA A3,A5 . ADD TO REAL PART, THEN 7470 FA A0,A3 . ACCUMULATE THE SUM OF SQUARES 7480 JGD R1,OVER . BOTTOM OF OVERFLOW LOOP 7490 LA A7,ONE . STORE 1.E0 IN A7 7500 ROOT SX X11,WB+1 . SAVE X11 CONTENTS 7510 SA A0,SUM . STORE SUM OF SQUARES IN SUM 7520 LMJ X11,SQRT . GO COMPUTE SQUARE ROOT OF SUM 7530 + SUM . 7540 + $-SCNRM2,WB . 7550 FM A0,A7 . COMPUTE THE TRUE VALUE OF SCNRM2 7560 LX X11,WB+1 . RESTORE X11 7570 DL A6,A6A7 . RESTORE A6 AND A7 7580 J 4,X11 . 7590 EXP LA A6,COMP . STORE 1.E22 EXPONENT IN A6 7600 AU A6,FRAC . STORE U IN A7 7610 ANA A6,BIAS . COMPUTE BIASED EXPONENT 7620 SA A6,BIAS . AND STORE IN BIAS 7630 ANA A0,BIAS . COMPUTE SCNRM2/U 7640 ANA A0,BIAS . /U 7650 JP A0,MOD+2 . IF SCNRM2.GT.0, GO COMPUTE THE REST O 7660 SZ A0 . OTHERWISE ZERO IT OUT, THEN 7670 J MOD+2 . GO FINISH THE COMPUTATIONS 7680 . TOP OF LOOP WITH MODIFIED EXPONENT 7690 MOD LMA A3,0,A2 . LOAD ABS REAL X 7700 LMA A5,1,*A2 . LOAD ABS IMAG X AND INCREMENT INDEX 7710 ANA A3,BIAS . MODIFY EXPONENT OF REAL X 7720 ANA A5,BIAS . AND IMAG X 7730 FM A3,A3 . SQUARE REAL X 7740 FM A5,A5 . SQUARE IMAG X AND 7750 FA A3,A5 . ADD TO REAL PART, THEN 7760 FA A0,A3 . ACCUMULATE THE SUM IN A0 7770 JGD R1,MOD . BOTTOM OF LOOP WITH MODIFIED EXPONENT 7780 J ROOT . GO COMPUTE SQUARE ROOT 7790 $(0). 7800 A6A7 + 0D . PLACE TO SAVE A6 AND A7 CONTENTS 7810 SUM + 0 . PLACE TO SAVE SUM OF SQUARES 7820 WB + 'SCNRM2' . WALKBACK WORD 7830 + 0 . PLACE TO STORE X11 7840 MIN + (01150,0,0) . MACHINE MINIMUM EXPONENT 7850 MAX + (02700,0,0) . MACHINE MAXIMUM EXPONENT 7860 COMP + (03130,0,0) . EXPONENT OF VALUE TO COMPENSATE FOR O 7870 BIAS + (02000,0,0) . BIAS ON THE EXPONENT 7880 MASK + (07770,0,0) . MASK FOR MINIMUM EXPONENT 7890 FRAC + (00014,0,0) . MANTISSA FOR U 7900 ONE + (02014,0,0) . 1.E0 7910 . 7920 END . 7930 AXR$ 7940 $(1). 7950 . SINGLE PRECISION 7960 . SUM OF ABSOLUTE VALUES OF INCREMENTED X COMPONENTS 7970 . 7980 . TO BE USED AS FORTRAN FUNCTION SASUM(N,X,INCX) 7990 . WHERE SASUM IS THE SUM FROM 1 TO N OF ABS(X(I*INCX-INCX+1)) 8000 . AND SASUM AND X ARE OF TYPE SINGLE PRECISION 8010 . 8020 SASUM* SZ A0 . STORE ZERO IN A0 8030 SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 8040 LR R3,*0,X11 . LOAD N IN R3 8050 JGD R3,NPOS . STORE N-1 IN R3, TEST N 8060 J 4,X11 . IF N.LE.0 RETURN 8070 NPOS LA,U A2,*1,X11 . LOAD ADDRESS OF X 8080 LXI A2,*2,X11 . LOAD INCX 8090 . BEGIN LOOP TO 8100 LOOP LMA A3,0,*A2 . LOAD ABS X AND 8110 FA A0,A3 . ACCUMULATE SUM OF ABS X IN A0 8120 JGD R3,LOOP . END LOOP 8130 J 4,X11 . RETURN 8140 END . 8150 AXR$ 8160 $(1). 8170 . DOUBLE PRECISION 8180 . SUM OF ABSOLUTE VALUES OF INCREMENTED X COMPONENTS 8190 . 8200 . TO BE USED AS FORTRAN FUNCTION DASUM(N,X,INCX) 8210 . WHERE DASUM IS THE SUM FROM 1 TO N OF ABS(X(I*INCX-INCX+1)) 8220 . AND DASUM AND X ARE OF TYPE DOUBLE PRECISION 8230 . 8240 DASUM* DSL A0,72 . STORE ZERO IN A0 AND A1 8250 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 8260 LR R3,*0,X11 . LOAD N IN R3 8270 JGD R3,NPOS . STORE N-1 IN R3, TEST N 8280 J 4,X11 . IF N.LE.0 RETURN 8290 NPOS LA,XH2 A2,*2,X11 . LOAD 2*INCX IN THE 8300 LSSC A2,19 . LEFT HALF OF A2 8310 LXM,U A2,*1,X11 . LOAD THE ADDRESS OF X 8320 . BEGIN LOOP TO 8330 LOOP DLM A3,0,*A2 . LOAD ABS X AND 8340 DFA A0,A3 . ACCUMULATE SUM OF ABS X 8350 JGD R3,LOOP . END LOOP 8360 J 4,X11 . RETURN 8370 END . 8380 AXR$ 8390 $(1). 8400 . 8410 . SUM OF ABSOLUTE VALUES OF REAL AND IMAGINARY PARTS OF X 8420 . 8430 . TO BE USED AS FORTRAN FUNCTION SCASUM(N,X,INCX) 8440 . WHERE SCASUM IS THE SUM FROM I=1 TO N OF REAL X(I) + IMAG. X(I), 8450 . X IS OF TYPE COMPLEX AND SCASUM IS OF TYPE REAL 8460 . 8470 SCASUM* SZ A0 . STORE ZERO IN A0 8480 SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 8490 LR R3,*0,X11 . LOAD N IN R3 8500 JGD R3,NPOS . STORE N-1 IN R3, TEST N 8510 J 4,X11 . IF N.LE.0 RETURN 8520 NPOS LA,XH2 A3,*2,X11 . LOAD 2*INCX IN THE 8530 LSSC A3,19 . LEFT HALF OF A3 8540 LXM,U A3,*1,X11 . LOAD THE ADDRESS OF X 8550 LOOP LMA A4,0,A3 . LOAD ABS REAL X 8560 LMA A5,1,*A3 . LOAD ABS IMAG. X 8570 FA A4,A5 . ADD THE TWO PARTS OF X AND 8580 FA A0,A4 . ACCUMULATE THE SUM IN A0 8590 JGD R3,LOOP . END OF LOOP 8600 J 4,X11 . RETURN 8610 END . 8620 AXR$ 8630 $(1). 8640 . 8650 . SINGLE PRECISION SCALING 8660 . 8670 . TO BE USED AS FORTRAN SUBROUTINE SSCAL(N,A,X,INCX). 8680 . REPLACES X(I*INCX-INCX+1) WITH A*X(I*INCX-INCX+1), I=1,N 8690 . 8700 SSCAL* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 8710 LR R3,*0,X11 . LOAD N IN R3 8720 JGD R3,NPOS . STORE N-1 IN R3, TEST N 8730 J 5,X11 . IF N.LE.0 RETURN 8740 NPOS LA A0,*1,X11 . LOAD A IN A0 8750 LA,U A2,*2,X11 . LOAD ADDRESS OF X, AND 8760 LXI A2,*3,X11 . INCX IN A2 8770 . BEGIN LOOP TO 8780 LOOP LA A4,0,A2 . LOAD X 8790 FM A4,A0 FORM A*X AND 8800 SA A4,0,*A2 . STORE IN X, INCREMENT X INDEX 8810 JGD R3,LOOP . END OF LOOP 8820 J 5,X11 . RETURN 8830 . 8840 END . 8850 AXR$ 8860 $(1). 8870 . 8880 . DOUBLE PRECISION SCALING 8890 . 8900 . TO BE USED AS FORTRAN SUBROUTINE DSCAL(N,A,X,INCX). 8910 . REPLACES X(I*INCX-INCX+1) WITH A*X(I*INCX-INCX+1), I=1,N. 8920 . A AND X ARE TYPE DOUBLE PRECISION 8930 . 8940 DSCAL* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 8950 LR R3,*0,X11 . LOAD N IN R3 8960 JGD R3,NPOS . STORE N-1 IN R3, TEST N 8970 J 5,X11 . IF N.LE.0 RETURN 8980 NPOS DL A0,*1,X11 . LOAD A IN A0 AND A1 8990 LA,XH2 A3,*3,X11 . LOAD 2*INCX IN THE 9000 LSSC A3,19 . LEFT HALF OF A3 9010 LXM,U A3,*2,X11 . LOAD THE ADDRESS OF X 9020 . BEGIN LOOP TO 9030 LOOP DL A4,0,A3 . LOAD X IN A4 AND A5 9040 DFM A4,A0 . FORM A*X AND 9050 DS A4,0,*A3 . STORE IN X, INCREMENT X INDEX 9060 JGD R3,LOOP . END OF LOOP 9070 J 5,X11 . RETURN 9080 . 9090 END . 9100 AXR$ 9110 $(1). 9120 . 9130 . COMPLEX SCALING 9140 . 9150 . TO BE USED AS FORTRAN SUBROUTINE CSCAL(N,A,X,INCX). 9160 . REPLACES X(I*INCX-INCX+1) WITH A*X(I*INCX-INCX+1), I=1,N. 9170 . A AND X ARE TYPE COMPLEX 9180 . 9190 CSCAL* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 9200 LR R3,*0,X11 . LOAD N IN R3 9210 JGD R3,NPOS . STORE N-1 IN R3, TEST N 9220 J 5,X11 . IF N.LE.0 RETURN 9230 NPOS LA,U A1,*1,X11 . LOAD THE ADDRESS OF A 9240 LR R1,0,A1 . LOAD REAL A IN R1 9250 LR R2,1,A1 . LOAD IMAG. A IN R2 9260 SA A6,SAVE . SAVE THE CONTENTS OF A6 REGISTER 9270 LA,XH2 A3,*3,X11 . LOAD 2*INCX IN THE 9280 LSSC A3,19 . LEFT HALF OF A3 9290 LXM,U A3,*2,X11 . LOAD THE ADDRESS OF X 9300 LOOP LA A0,0,A3 . LOAD REAL X IN A0 9310 SA A0,A1 . AND A1 9320 FM A1,R1 . FORM REAL A * REAL X 9330 LA A4,1,A3 . LOAD IMAG. X IN A4 9340 LNA A5,A4 . STORE -IMAG. X IN A5 9350 FM A5,R2 . FORM IMAG. A * -IMAG. X 9360 FA A5,A1 . FORM REAL A*X AND 9370 SA A5,0,A3 . STORE IN REAL X 9380 FM A0,R2 . FORM IMAG. A * REAL X 9390 FM A4,R1 . FORM REAL A * IMAG. X 9400 FA A0,A4 . FORM IMAG. A*X AND STORE 9410 SA A0,1,*A3 . IN IMAG. X, INCREMENT X INDEX 9420 JGD R3,LOOP . END OF LOOP 9430 LA A6,SAVE . RESTORE A6 9440 J 5,X11 . RETURN 9450 $(0). 9460 SAVE + 0. 9470 . 9480 END . 9490 AXR$ 9500 $(1). 9510 . 9520 . REAL SCALING ON COMPLEX VECTORS 9530 . 9540 . TO BE USED AS FORTRAN SUBROUTINE CSSCAL(N,A,X,INCX) 9550 . WHERE A IS OF TYPE SINGLE PRECISION AND X IS OF TYPE COMPLEX. 9560 . X(REAL)+X(IMAGINARY) IS REPLACED BY A*X(REAL)+A*X(IMAGINARY) 9570 . X=X(I*INCX-INCX+1), I=1,N 9580 . 9590 CSSCAL* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 9600 LR R3,*0,X11 . LOAD N IN R3 9610 JGD R3,NPOS . STORE N-1 IN R3, TEST N 9620 J 5,X11 . IF N.LE.0 RETURN 9630 NPOS LA A0,*1,X11 . LOAD A IN A0 9640 LA,XH2 A3,*3,X11 . LOAD 2*INCX IN THE 9650 LSSC A3,19 . LEFT HALF OF A1 9660 LXM,U A3,*2,X11 . LOAD THE ADDRESS OF X 9670 . BEGIN LOOP TO 9680 LOOP LA A1,0,A3 . LOAD REAL X IN A1 9690 FM A1,A0 . FORM A*REAL X 9700 SA A1,0,A3 . STORE A*REAL X 9710 LA A1,1,A3 . LOAD IMAG. X IN A1 9720 FM A1,A0 . FORM A*IMAG. X 9730 SA A1,1,*A3 STORE A*IMAG. X AND INCREMENT X INDEX 9740 JGD R3,LOOP . END OF LOOP 9750 J 5,X11 . RETURN 9760 . 9770 END . 9780 AXR$ 9790 $(1). 9800 . 9810 . FIND THE INDEX OF MAX. ABSOLUTE VALUE OF X COMPONENTS 9820 . 9830 . TO BE USED AS FORTRAN FUNCTION ISAMAX(N,X,INCX) 9840 . WHERE X IS OF TYPE REAL AND ISAMAX IS THE INDEX OF THE MAXIMUM 9850 . ABSOLUTE VALUE OF X(I), I=1,N. X(I)=X(1-INCX+I*INCX) 9860 . 9870 ISAMAX* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 9880 LR R3,*0,X11 . LOAD N IN R3 9890 LA A0,R3 . AND A0 9900 JGD R3,NPOS . STORE N-1 IN R3, TEST N 9910 J 4,X11 . IF N.LE.0 RETURN 9920 NPOS LXI A3,*2,X11 . LOAD INCX IN LEFT OF A3 9930 LXM,U A3,*1,X11 . LOAD THE ADDRESS OF X 9940 LA,XU A2,-1 . LOAD -1 IN A2 9950 LOOP LMA A4,0,*A3 . LOAD ABS X, INCREMENT INDEX 9960 TG A2,A4 . TEST IF X IS OUT OF BOUNDS 9970 J END . IF NO, GO TO BOTTOM OF LOOP 9980 LA A2,A4 . IF YES, RESET MAXIMUJM VALUE AND 9990 MOVEI LA A1,R3 . STORE THE INDEX OF X 10000 END JGD R3,LOOP . BOTTOM OF LOOP 10010 ANA A0,A1 . GET THE CORRECT INDEX FOR MAX X 10020 J 4,X11 . RETURN 10030 END . 10040 AXR$ 10050 $(1). 10060 . 10070 . DOUBLE PRECISION 10080 . FIND THE INDEX OF MAX. ABSOLUTE VALUE OF X COMPONENTS 10090 . 10100 . TO BE USED AS FORTRAN FUNCTION IDAMAX(N,X,INCX) 10110 . WHERE X IS OF TYPE DOUBLE PRECISION AND IDAMAX IS THE INDEX OF 10120 . THE MAXIMUM ABSOLUTE VALUE OF X(I), I=1,N. X(I)=X(1-INCX+I*INCX) 10130 . 10140 IDAMAX* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 10150 LR R3,*0,X11 . LOAD N IN R3 10160 LA A0,R3 . AND A0 10170 JGD R3,NPOS . STORE N-1 IN R3, TEST N 10180 J 4,X11 . IF N.LE.0 RETURN 10190 NPOS LA,XH2 A3,*2,X11 . LOAD 2*INCX IN THE 10200 LSSC A3,19 . LEFT HALF OF A3 10210 LXM,U A3,*1,X11 . LOAD THE ADDRESS OF X 10220 DL A1,(-1D) . LOAD -1 IN A1 AND A2 10230 LOOP DLM A4,0,*A3 . LOAD ABS X, INCREMENT INDEX 10240 TLE A1,A4 . TEST IF 1ST HALF OF X IS OUT OF BOUND 10250 J MOVEX . IF YES, GO STORE NEW MAX 10260 TNE A4,A1 . TEST IF IT IS EQUAL TO LAST MAX 10270 TG A2,A5 . IF YES, TEST IF 2ND HALF OF X EXCEEDS 10280 J END . IF NO, GO TO BOTTOM OF LOOP 10290 MOVEX DL A1,A4 . IF YES, RESET MAXIMUM VAUE AND 10300 MOVEI LR R1,R3 . STORE THE INDEX OF X 10310 END JGD R3,LOOP . BOTTOM OF LOOP 10320 ANA A0,R1 . GET THE CORRECT INDEX FOR MAX X 10330 J 4,X11 . RETURN 10340 END . 10350 AXR$ 10360 $(1). 10370 . 10380 . FIND THE INDEX OF COMPLEX X COMPONENT HAVING MAXIMUM SUM OF 10390 . MAGNITUDES OF REAL AND IMAGINARY PARTS 10400 . 10410 . TO BE USED AS FORTRAN FUNCTION ICAMAX(N,X,INCX) 10420 . WHERE X IS OF TYPE COMPLEX AND ICAMAX IS THE INDEX OF THE MAXIMUM 10430 . VALUE OF ABS(REAL X(I)) + ABS(IMAG. X(I)), I=1,N. 10440 . X(I)=X(1-INCX+I*INCX) 10450 . 10460 ICAMAX* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 10470 LR R3,*0,X11 . LOAD N IN R3 10480 LA A0,R3 . AND A0 10490 JGD R3,NPOS . STORE N-1 IN R3, TEST N 10500 J 4,X11 . IF N.LE.0 RETURN 10510 NPOS LA,XH2 A3,*2,X11 . LOAD 2*INCX IN THE 10520 LSSC A3,19 . LEFT HALF OF A3 10530 LXM,U A3,*1,X11 . LOAD THE ADDRESS OF X 10540 LA,XU A2,-1 . LOAD -1 IN A2 10550 LOOP LMA A4,0,A3 . LOAD ABS REAL X 10560 LMA A5,1,*A3 . LOAD ABS IMAG X 10570 FA A4,A5 . ADD THE TWO PARTS OF X 10580 TG A2,A4 . TEST IF X IS OUT OF BOUNDS 10590 J END . IF NO, GO TO BOTTOM OF LOOP 10600 LA A2,A4 . IF YES, RESET MAXIMUM VALUE AND 10610 MOVEI LA A1,R3 . STORE THE INDEX OF X 10620 END JGD R3,LOOP . BOTTOM OF LOOP 10630 ANA A0,A1 . GET THE CORRECT INDEX FOR MAX X 10640 J 4,X11 . RETURN 10650 . 10660 END . 10670 AXR$ 10680 $(1). 10690 . 10700 . COMPLEX TYPE ELEMENTARY VECTOR OPERATION 10710 . 10720 . TO BE USED AS FORTRAN SUBROUTINE CAXPY(N,A,X,INCX,Y,INCY) 10730 . A, X, AND Y ARE TYPE COMPLEX 10740 . YY(I) IS REPLACED BY A*XX(I) + YY(I), I = 1,N 10750 . WHERE XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 10760 . AND XX(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 10770 . AND YY(I) IS SIMILARLY DEFINED, WITH X AND INCY REPLACED 10780 . BY Y AND INCY 10790 . 10800 CAXPY* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 10810 LR R3,*0,X11 LOAD N IN R3 10820 JGD R3,NPOS . STORE N-1 IN R3, TEST N 10830 J 7,X11 . IF N.LE.0 RETURN 10840 NPOS DL A4,*1,X11 . LOAD A IN A4 AND A5 10850 JNZ A4,$+2 . FAST EXIT 10860 JZ A5,EXIT . IF A = 0 10870 DS A6,A6A7 . SAVE A6 AND A7 10880 DS A4,R1 . STORE A IN R1 AND R2 10890 LA,XH2 A2,*3,X11 . STORE 2*INCX IN THE 10900 LSSC A2,19 . LEFT HALF OF A2 10910 LA,XH2 A3,*5,X11 . STORE 2*INCY IN THE 10920 LSSC A3,19 . LEFT HALF OF A3 10930 LXM,U A2,*2,X11 . LOAD THE ADDRESS OF X 10940 LXM,U A3,*4,X11 . LOAD THE ADDRESS OF Y 10950 JP A2,TINCY . TEST IF INCX .GE. 0 10960 LNA A4,A2 . ADD -INCX*(N-1) 10970 SSA A4,18 . TO THE BASE 10980 MSI A4,R3 . ADDRESS 10990 AH A2,A4 . FOR X 11000 TINCY JP A3,LOOP . TEST IF INCY .GE. 0 11010 LNA A4,A3 . ADD -INCY*(N-1) 11020 SSA A4,18 . TO THE BASE 11030 MSI A4,R3 . ADDRESS 11040 AH A3,A4 . FOR Y 11050 LOOP LA A4,0,A2 . LOAD THE REAL PART OF X IN A4 11060 SA A4,A0 . AND A0 11070 FM A4,R1 . FORM REAL A * REAL X 11080 LA A5,1,*A2 . LOAD IMAG. X IN A5 AND 11090 LNA A6,A5 . STORE -IMAG. X IN A6 11100 FM A6,R2 . FORM IMAG A * -IMAG. X 11110 FA A6,A4 . FORM REAL A*X 11120 FA A6,0,A3 . FORM REAL A*X+Y AND 11130 SA A6,0,A3 . STORE IN REAL Y 11140 FM A0,R2 . FORM IMAG. A * REAL X 11150 FM A5,R1 . FORM REAL A * IMAG. X 11160 FA A0,A5 . FORM IMAG. A*X 11170 FA A0,1,A3 . FORM IMAG. A*X+Y AND 11180 SA A0,1,*A3 . STORE IN IMAG. Y, INCREMENT Y INDEX 11190 JGD R3,LOOP . END OF LOOP 11200 DL A6,A6A7 . RESTORE A6 AND A7 REGISTERS 11210 EXIT J 7,X11 . RETURN 11220 $(0). 11230 A6A7 + 0D . PLACE TO SAVE A6 AND A7 REGISTERS 11240 . 11250 END . 11260 $(1). 11270 AXR$ . 11280 . 11290 . APPLY MODIFIED GIVENS TRANSFORMATION TO (XX(1) ... XX(N)) 11300 . (YY(1) ... YY(N)) 11310 . TO BE USED AS FORTRAN SUBROUTINE DROT(N,X,INCX,Y,INCY,PARAM) 11320 . X,Y, AND PARAM ARE DOUBLE PRECISION -- SEE DROTMG FOR DEF. OF PARAM 11330 . 11340 . XX(I)=X(1-INCX+I*INCX) IF INCX .GE. 0 11350 . XX(I)=X(1-N*INCX+I*INCX) IF INCY .LT. 0 11360 . YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED 11370 . BY Y AND INCY. 11380 . 11390 DROTM* SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 11400 LR R3,*0,X11 . LOAD N IN R3 11410 JGD R3,NPOS . STORE N-1 IN R3, TEST N 11420 J 7,X11 . IF N.LE.0 RETURN 11430 NPOS 11440 SA A6,SAVE . SAVE A6 CONTENTS 11450 LA,XH2 A1,*2,X11 . LOAD 2*INCX 11460 LA,XH2 A2,*4,X11 . AND 11470 LSSC A1,19 . 2*INCY 11480 LSSC A2,19 . IN A1 AND A2 11490 LXM,U A1,*1,X11 . LOAD X ADDRESS 11500 LXM,U A2,*3,X11 . LOAD Y ADDRESS 11510 JP A1,TINCY . TEST IF INCX .GE. 0 11520 LNA A4,A1 . ADD -INCX*(N-1) 11530 SSA A4,18 . TO THE BASE 11540 MSI A4,R3 . ADDRESS 11550 AH A1,A4 . FOR X 11560 TINCY JP A2,LOOP . TEST IF INCY .GE. 0 11570 LNA A4,A2 . ADD -INCY*(N-1) 11580 SSA A4,18 . TO THE BASE 11590 MSI A4,R3 . ADDRESS 11600 AH A2,A4 . FOR Y 11610 LOOP 11620 LA,U A0,*5,X11 . LOAD SPARAM STARTING ADDRESS 11630 LA A3,0,A0 . LOAD FLAG 11640 JZ A3,ZERO . IF FLAG = 0, TAKE ROUTE ZERO 11650 JN A3,NEG . IF FLAG.LT.0, TAKE ROUTE NEG 11660 . FLAG IS POSITIVE 11670 POS DL A3,0,A1 . LOAD X 11680 DFM A3,2,A0 . FORM H11 * X 11690 DFA A3,0,A2 . ADD Y TO IT 11700 DL A5,0,A2 . LOAD Y 11710 DFM A5,8,A0 . FORM H22 * Y 11720 DFAN A5,0,A1 . ADD -X TO IT 11730 DS A3,0,*A1 . STORE NEW X, INCREMENT INDEX 11740 DS A5,0,*A2 . STORE NEW Y, INCREMENT INDEX 11750 JGD R3,POS . BOTTOM OF LOOP 11760 RETN 11770 LA A6,SAVE . RESTORE A6 11780 J 7,X11 . RETURN 11790 . FLAG IS ZERO 11800 ZERO DL A3,0,A2 . LOAD Y 11810 DFM A3,6,A0 . FORM H12 * Y 11820 DFA A3,0,A1 . ADD X TO IT 11830 DL A5,0,A1 . LOAD X 11840 DFM A5,4,A0 . FORM H21 * X 11850 DFA A5,0,A2 . ADD Y TO IT 11860 DS A3,0,*A1 . STORE NEW X, INCREMENT INDEX 11870 DS A5,0,*A2 . STORE NEW Y, INCREMENT INDEX 11880 JGD R3,ZERO . BOTTOM OF LOOP 11890 J RETN . RETURN 11900 . FLAG IS NEGATIVE 11910 NEG TNE A3,MTWO . TEST FOR FLAG = -2.D0 11920 J RETN . IF FLAG = -2, RETURN 11930 DS A7,A7A8 . SAVE A7 AND A8 CONTENTS 11940 NEGL DL A3,0,A1 . LOAD X 11950 DFM A3,2,A0 . FORM H11 * X 11960 DL A5,0,A2 . LOAD Y 11970 DFM A5,6,A0 . FORM H12 * Y AND 11980 DFA A3,A5 . ADD TO H11 * X 11990 DL A5,0,A1 . LOAD X 12000 DFM A5,4,A0 . FORM H21 * X 12010 DL A7,0,A2 . LOAD Y 12020 DFM A7,8,A0 . FORM H22 * Y AND 12030 DFA A5,A7 . ADD TO H21 * X 12040 DS A3,0,*A1 . STORE NEW X, INCREMENT INDEX 12050 DS A5,0,*A2 . STORE NEW Y, INCREMENT INDEX 12060 JGD R3,NEGL . BOTTOM OF LOOP 12070 DL A7,A7A8 . RESTORE A7 AND A8 12080 J RETN . RETURN 12090 $(0). 12100 SAVE + 0 . 12110 A7A8 + 0D . 12120 MTWO - 2.0D . 12130 END 12140 $(1) . 12150 AXR$ . 12160 . 12170 . COMPUTE CONSTANTS FOR MODIFIED GIVENS TRANSFORMATION 12180 . 12190 . TO BE USED AS FORTRAN SUBROUTINE DROTMG(D1,D2,B1,B2,PARAM) 12200 . ALL VARIABLES ARE DOUBLE PRECISION 12210 . THE MATRIX H IS DETERMINED SUCH THAT 12220 . 12230 . (H11 H12) * (SQRT(D1) 0 ) * (B1) = (SQRT(ND1) 0 ) = ( 12240 . (H21 H22) ( 0 SQRT(D2)) (B2) ( 0 SQRT(ND2)) ( 12250 . 12260 . WHERE ND1, ND2, NB1 ARE NEW VALUES STORED IN D1,D2, AND B1. THE 12270 . MATRIX H IS STORED IN PARAM, WITH PARAM(2)=H11, PARAM(3)=H12, 12280 . PARAM(4)=H21, PARAM(5)=H22, AS FOLLOWS 12290 . 12300 . PARAM(1)=1 PARAM(1)=0 PARAM(1)=-1 PARAM(1)=-2 12310 . 12320 . H= (H11 1.) (1. H12) (H11 H12) ( 1. 0.) 12330 . (-1. H22) (H21 1.) (H21 H22) ( 0. 1.) 12340 . 12350 . VALUE OF + OR - 1 ARE NOT STORED, PARAM(1) IS SET BY THE SUBROUTINE 12360 . 12370 DROTMG* SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 12380 LA,U A0,*4,X11 . LOAD PARAM STARTING ADDRESS 12390 DS A6,A6A7 . SAVE 12400 DS A8,A8A9 . CONTENTS 12410 DS A10,A10A11 . OF 12420 DS A12,A12A13 . 'A' 12430 DS A14,A14A15 . REGISTERS 12440 DL A6,*0,X11 . LOAD D1 12450 DL A8,*1,X11 . LOAD D2 12460 DL A10,*2,X11 . LOAD B1 12470 DL A12,*3,X11 . LOAD B2 12480 DL A14,A6 . FORM P1 = 12490 DFM A14,A10 . D1 * B1 12500 DL A4,A8 . FORM P2 = 12510 DFM A4,A12 . D2 * B2 12520 DL A2,A14 . STORE ABS(P1*B1) 12530 DFM A2,A10 . INTO 12540 DLM A2,A2 . 12550 DS A2,R1 . R1 . 12560 DL A2,A4 . STORE P2*B2 INTO 12570 DFM A2,A12 . TEMP 12580 DS A2,TEMP . AND 12590 DLM A2,A2 . ABS(P2*B2) INTO A2 12600 DFAN A2,R1 . GET ABS(P2*B2)-ABS(P1*B1) 12610 JP A2,LESS . GO TO LESS IF RESULT.GT.0 12620 DFD A4,A14 . STORE P2/P1 12630 DS A4,6,A0 . INTO H12 12640 DFD A12,A10 . STORE -B2/B1 12650 SNA A12,4,A0 . INTO H21 12660 SNA A13,5,A0 . (A12 = -H21) 12670 DFM A4,A12 . FORM U=1-H12*H21 12680 DFA A4,ONE . AND STORE IN A4 12690 DL A2,A4 IF U 12700 DFAN A2,TOL . .LT. TOL 12710 JN A2,FALSE . JUMP TO FALSE 12720 DFD A6,A4 . DIVIDE D1 AND 12730 DFD A8,A4 . D2 BY U 12740 DFM A10,A4 . MULTIPLY B1 BY U 12750 DSL A14,72 . STORE 0 IN FLAG 12760 J SCALE . GO TEST FOR SCALING PROBLEMS 12770 LESS 12780 DL A2,TEMP . 12790 JZ A2,ZEROP . IF P2*B2 = 0 JUMP TO ZEROP 12800 JN A2,FALSE . IF P2*B2.LT.0 JUMP TO FALSE 12810 DFD A14,A4 . STORE P1/P2 12820 DS A14,2,A0 . INTO H11 12830 DFD A10,A12 . STORE B1/B2 12840 DS A10,8,A0 . INTO H22 12850 DFM A10,A14 . FORM U=1+H11*H22 12860 DFA A10,ONE . AND STORE IN A10 12870 DFD A6,A10 . SET 12880 DL A4,A6 . D2= 12890 DFD A8,A10 . D1/U 12900 DL A6,A8 . AND D1= 12910 DL A8,A4 . D2/U. 12920 DFM A10,A12 . SET B1=U*B2 12930 DL A14,ONE . STORE 1.D0 IN FLAG 12940 J SCALE . GO TEST FOR SCALING PROBLEMS 12950 ZEROP 12960 DLN A14,TWO . STORE -2.0D IN FLAG 12970 J EXIT . JUMP TO EXIT CODE 12980 FALSE 12990 DLN A14,ONE . STORE -1.0D IN FLAG 13000 DL A2,(0D) . 0 A2 AND A3 (NOTE A3=0 FOR IND. ADD.) 13010 DS A2,2,A0 . STORE ZERO IN 13020 DS A2,4,A0 . THE 13030 DS A2,6,A0 . MATRIX H, 13040 DS A2,8,A0 . AND IN 13050 DS A2,*0,X11 . D1, 13060 DS A2,*1,X11 . D2, 13070 DS A2,*2,X11 . AND B1 13080 J EXIT JUMP TO EXIT CODE 13090 SCALE DLM A12,A6 . LOAD ABS(D1) 13100 DFAN A12,CSQINV . IF ABS(D1) .LT. 13110 JP A12,$+2 . C**-2 13120 LMJ A3,CASE1 . JUMP TO CASE1 13130 DLM A12,A6 . IF ABS(D1) 13140 DFAN A12,CSQ . .GT. 13150 JN A12,$+2 . C**2 13160 LMJ A3,CASE2 . JUMP TO CASE2 13170 STD1B1 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 13180 DS A6,*0,X11 . STORE D1 13190 DS A10,*2,X11 . STORE B1 13200 DL A6,A8 . STORE D2 IN A6 13210 DLM A12,A6 . LOAD ABS(D2) 13220 DFAN A12,CSQINV . IF ABS(D2) 13230 JP A12,$+2 . .LT. C**-2 13240 LMJ A3,CASE3 . JUMP TO CASE3 13250 DLM A12,A6 . IF ABS(D2) 13260 DFAN A12,CSQ . .GT. 13270 JN A12,$+2 . C**2 13280 LMJ A3,CASE4 . JUMP TO CASE4 13290 STD2 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 13300 DS A6,*1,X11 . STORE D2 13310 EXIT 13320 DS A14,0,A0 . STORE FLAG 13330 DL A6,A6A7 . RESTORE REGISTER CONTENTS 13340 DL A8,A8A9 . 13350 DL A10,A10A11 . 13360 DL A12,A12A13 . 13370 DL A14,A14A15 . 13380 J 6,X11 . RETURN 13390 CASE1 13400 JZ A6,STD1B1 IF D1=0, JUMP TO STD1B1 13410 LA,XU A2,4 . LOAD C INDEX OF 2 13420 J CASE2+1 . 13430 CASE2 13440 LA,XU A2,0 . LOAD C INDEX OF 0 13450 DFM A10,C,A2 . COMPUTE NEW B1 13460 AU,U A0,2 . STORE FIRST H INDEX IN A1 13470 J TFLAG . 13480 CASE3 13490 JZ A6,STD2 . IF D2=0, JUMP TO STD2 13500 LA,XU A2,4 . LOAD C INDEX OF 2 13510 J CASE4+1 . 13520 CASE4 13530 LA,XU A2,0 . LOAD C INDEX OF 0 13540 AU,U A0,4 . STORE SECOND H INDEX IN A1 13550 TFLAG 13560 DL A4,ONE . LOAD 1.D0 IN A4 13570 JZ A14,FLAG0 . IF FLAG=0, JUMP TO FLAG0 13580 JN A14,CONT . IF FLAG.LT.0, JUMP TO CONT 13590 DS A4,6,A0 . H12 = 1.D0 13600 SNA A4,4,A0 . H21 = 13610 SNA A5,5,A0 . -1.D0 13620 J FLAG0+2 . 13630 FLAG0 13640 DS A4,2,A0 . H11 = 1.D0 13650 DS A4,8,A0 . H22 = 1.D0 13660 DLN A14,ONE . FLAG = 13670 CONT 13680 DFM A6,C+2,A2 . (D1 OR D2) * (C**2 OR C**-2) 13690 DLM A12,A6 . A12 = ABS(NEW D1 OR D2) 13700 DL A4,0,A1 . (H11 OR H12) * 13710 DFM A4,C,A2 . (C OR C**-1) 13720 DS A4,0,A1 . IS STORED IN (H11 OR H12) 13730 DL A4,4,A1 . (H21 OR H22) * 13740 DFM A4,C,A2 . (C OR C**-1) 13750 DS A4,4,A1 . IS STORED IN (H21 OR H22) 13760 AN,XU A3,3 . SUBTRACT 3 FROM RETURN ADDRESS 13770 J 0,A3 . JUMP TO REPEAT TEST ON ABS(D1 OR D2) 13780 $(0). 13790 C + 4096.0D . 13800 CSQINV + 5.9604644775390625D*-8 . 13810 CINV + 2.44140625D*-4 . 13820 CSQ + 16777216.0D . 13830 TOL + 0D . 13840 ONE + 1.0D . 13850 TWO + 2.0D . 13860 TEMP + 0D . 13870 A6A7 + 0D . 13880 A8A9 + 0D . 13890 A10A11 + 0D . 13900 A12A13 + 0D . 13910 A14A15 + 0D . 13920 END . 13930 AXR$ . 13940 $(1). 13950 . 13960 . COMPUTE CONSTANTS FOR MODIFIED GIVENS TRANSFORMATION 13970 . 13980 . TO BE USED AS FORTRAN SUBROUTINE SROTMG(D1,D2,B1,B2,PARAM) 13990 . ALL VARIABLES ARE SINGLE PRECISION 14000 . THE MATRIX H IS DETERMINED SUCH THAT 14010 . 14020 . (H11 H12) * (SQRT(D1) 0 ) * (B1) = (SQRT(ND1) 0 ) = ( 14030 . (H21 H22) ( 0 SQRT(D2)) (B2) ( 0 SQRT(ND2)) ( 14040 . 14050 . WHERE ND1, ND2, NB1 ARE NEW VALUES STORED IN D1,D2, AND B1. THE 14060 . MATRIX H IS STORED IN PARAM, WITH PARAM(2)=H11, PARAM(3)=H12, 14070 . PARAM(4)=H21, PARAM(5)=H22, AS FOLLOWS 14080 . 14090 . PARAM(1)=1 PARAM(1)=0 PARAM(1)=-1 PARAM(1)=-2 14100 . 14110 . H= (H11 1.) (1. H12) (H11 H12) ( 1. 0.) 14120 . (-1. H22) (H21 1.) (H21 H22) ( 0. 1.) 14130 . 14140 . VALUE OF + OR - 1 ARE NOT STORED, PARAM(1) IS SET BY THE SUBROUTINE 14150 . 14160 . REGISTER ALLOCATION (SOME USE AS TEMPOARY STORAGE IS NOT MENTIONED) 14170 . A0 SPARAM STARTING ADDRESS. 14180 . A1 USED FOR FIRST H ADDRESS WHEN SCALING. 14190 . A2 TEMP. STORAGE OF P1*B1, P2*B2, ABS(P2*B2) ALSO USED 14200 . FOR C INDEX WHEN SCALING 14210 . A3 USED TO STORE RETURN ADDRESS + 2 WHEN SCALING 14220 . A4 P2=D2*B2 AND P2/P1 U AND TEMP. STORAGE WHEN SCALING 14230 . A6 D1 ALSO USED FOR D2 WHEN SCALING 14240 . A8 D2 14250 . A10 B1 14260 . A12 B2 ALSO USED FOR ABS(D1 OR D2) WHEN SCALING 14270 . A14 P1=D1*B1 ALSO USED TO STORE VALUE OF FLAG (= SPARAM(1)) 14280 . 14290 SROTMG* SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 14300 LA,U A0,*4,X11 . LOAD PARAM STARTING ADDRESS. 14310 DS A6,A6A7 . SAVE CONTENTS OF A REGISTERS. 14320 DS A8,A8A9 . 14330 DS A10,A10A11 . 14340 DS A12,A12A13 . 14350 DS A14,A14A15 . 14360 LA A6,*0,X11 . LOAD D1. 14370 LA A8,*1,X11 . LOAD D2. 14380 LA A10,*2,X11 . LOAD B1. 14390 LA A12,*3,X11 . LOAD B2. 14400 LA A14,A6 . FORM P1 = 14410 FM A14,A10 . D1 * B1. 14420 LA A4,A8 . FORM P2 = 14430 FM A4,A12 . D2 * B2. 14440 LA A2,A14 . STORE ABS(P1*B1) 14450 FM A2,A10 . INTO 14460 SMA A2,R1 . R1. 14470 LA A2,A4 . STORE P2 * B2 INTO 14480 FM A2,A12 . TEMP 14490 SA A2,TEMP . AND ABS(P2*B2) INTO 14500 SMA A2,A2 . A2. 14510 TG A2,R1 . JUMP TO LESS IF 14520 J LESS . ABS(P2*B2) .GE. ABS(P1*B1). 14530 FD A4,A14 . STORE P2/P1 14540 SA A4,3,A0 . INTO H12. 14550 FD A12,A10 . STORE -B2/B1 14560 SNA A12,2,A0 . INTO H21. (A12 = -H21.) 14570 FM A4,A12 . FORM U = 1 - H12 * H21 14580 FA A4,ONE . AND STORE IN A4. 14590 TLE A4,TOL . IF U .LT. TOL 14600 J FALSE . JUMP TO FALSE. 14610 FD A6,A4 . DIVIDE D1 AND 14620 FD A8,A4 . D2 BY U. 14630 FM A10,A4 . MULTIPLY B1 BY U. 14640 SZ A14 . STORE 0 IN A14 (FLAG) 14650 J SCALE . GO TEST FOR SCALING PROBLEMS. 14660 LESS JZ A2,ZEROP IF P2 * B2 = 0 JUMP TO ZEROP 14670 LA A2,TEMP . IF P2 * B2 .LT. 0 14680 JN A2,FALSE . THEN JUMP TO FALSE 14690 FD A14,A4 . STORE P1/P2 14700 SA A14,1,A0 . INTO H11 14710 FD A10,A12 . STORE B1/B2 14720 SA A10,4,A0 . INTO H22. 14730 FM A10,A14 . FORM U = 1 + H11 * H22 14740 FA A10,ONE . AND STORE IN A10. 14750 FD A6,A10 . SET 14760 LA A4,A6 . D2 = 14770 FD A8,A10 . D1 / U 14780 LA A6,A8 . AND D1 = 14790 LA A8,A4 . D2 / U. 14800 FM A10,A12 . SET B1 = U * B2 14810 LA A14,ONE . STORE 1.0 IN A14 (FLAG) 14820 J SCALE . GO TEST FOR SCALING PROBLEMS. 14830 ZEROP LNA A14,TWO . STORE -2.0 IN A14 (FLAG) 14840 J EXIT . JUMP TO EXIT CODE. 14850 FALSE LNA A14,ONE . STORE -1.0 IN A14 (FLAG). 14860 SZ 1,A0 . STORE ZERO IN 14870 SZ 2,A0 . IN 14880 SZ 3,A0 . THE 14890 SZ 4,A0 . MATRIX H, AND IN 14900 SZ *0,X11 . D1, 14910 SZ *1,X11 . D2, 14920 SZ *2,X11 . AND B1. 14930 J EXIT . JUMP TO EXIT CODE 14940 SCALE LMA A12,A6 . LOAD ABS(D1). 14950 TLE A12,CSQINV . IF ABS(D1) .LT. C ** -2 14960 LMJ A3,CASE1 . JUMP TO CASE1. 14970 TG A12,CSQ . IF ABS(D1) .GE. C ** 2 14980 LMJ A3,CASE2 . JUMP TO CASE2. 14990 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 15000 STD1B1 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 15010 SA A6,*0,X11 . STORE D1. 15020 SA A10,*2,X11 . STORE B1. 15030 LA A6,A8 . STORE D2 IN A6. 15040 LMA A12,A6 . LOAD ABS(D2). 15050 TLE A12,CSQINV . IF ABS(D2) .LT. C ** -2 15060 LMJ A3,CASE3 . JUMP TO CASE3. 15070 TG A12,CSQ . IF ABS(D2) .GE. C ** 2 15080 LMJ A3,CASE4 . JUMP TO CASE4. 15090 STD2 SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 15100 SA A6,*1,X11 . STORE D2. 15110 EXIT SA A14,0,A0 . STORE FLAG 15120 DL A6,A6A7 . RESTORE REGISTER CONTENTS. 15130 DL A8,A8A9 . 15140 DL A10,A10A11 . 15150 DL A12,A12A13 . 15160 DL A14,A14A15 . 15170 J 6,X11 . RETURN. 15180 CASE1 JZ A12,STD1B1 . IF D1 = 0 JUMP TO STD1B1. 15190 LA,XU A2,2 . LOAD C INDEX OF 2. 15200 J CASE2+1 . 15210 CASE2 LA,XU A2,0 . LOAD C INDEX OF 0. 15220 FM A10,C,A2 . COMPUTE NEW B1. 15230 AU,U A0,1 . STORE FIRST H INDEX IN A1. 15240 J TFLAG 15250 CASE3 JZ A12,STD2 . IF D2 = 0 JUMP TO STD2. 15260 LA,XU A2,2 . LOAD C INDEX OF 2 15270 J CASE4+1 . 15280 CASE4 LA,XU A2,0 . LOAD C INDEX OF 0. 15290 AU,U A0,2 . STORE FIRST H INDEX IN A1. 15300 TFLAG LA A4,ONE . LOAD 1.0 IN A4. 15310 JZ A14,FLAG0 . IF FLAG=0, JUMP TO FLAG0. 15320 JN A14,CONT . IF FLAG .LT. 0, JUMP TO CONT. 15330 SA A4,3,A0 . H12 = 1.0 15340 SNA A4,2,A0 . H21 = -1.0 15350 J FLAG0+2 . 15360 FLAG0 SA A4,1,A0 . H11 = 1.0 15370 SA A4,4,A0 . H22 = 1.0 15380 LNA A14,A4 FLAG = -1.0 15390 CONT FM A6,C+1,A2 . (D1 OR D2) * (C**2 OR C**-2). 15400 SMA A6,A12 . A12 = ABS(NEW(D1 OR D2)). 15410 LA A4,0,A1 . (H11 OR H12) * (C OR C**-1) 15420 FM A4,C,A2 . IS STORED IN 15430 SA A4,0,A1 . (H11 OR H12). 15440 LA A4,2,A1 . (H21 OR H22) * (C OR C**-1) 15450 FM A4,C,A2 . IS STORED IN 15460 SA A4,2,A1 . (H21 OR H22) 15470 AN,XU A3,2 . SUBTRACT 2 FROM RETURN ADDRESS 15480 J 0,A3 . JUMP TO REPEAT TEST ON ABS(D1 OR D2) 15490 $(0). 15500 C + 4096.0 . 2**12 15510 CSQINV + 5.96046448*-8 . 2**-24 15520 CINV + 2.44140625*-4 . 2**-12 15530 CSQ + 16777216.0 . 2**24 15540 TOL + 0 . 15550 ONE + 1.0 . 15560 TWO + 2.0 . 15570 TEMP + 0 . 15580 A6A7 + 0D . 15590 A8A9 + 0D . 15600 A10A11 + 0D . 15610 A12A13 + 0D . 15620 A14A15 + 0D . 15630 END . 15640 AXR$ 15650 $(1). 15660 . 15670 . INTERCHANGE INCREMENTED X AND Y COMPONENTS 15680 . 15690 . TO BE USED AS FORTRAN SUBROUTINE SSWAP(N,X,INCX,Y,INCY) 15700 . WHERE X AND Y ARE OF TYPE REAL 15710 . XX(I) IS INTERCHANGED WITH YY(I), I=1,N WHERE 15720 . XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 AND 15730 . XX(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 AND 15740 . YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED BY Y AND INCY 15750 . 15760 SSWAP* SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 15770 LR R3,*0,X11 . LOAD N IN R3 15780 JGD R3,NPOS . STORE N-1 IN R3, TEST N 15790 J 6,X11 . IF N.LE.0 RETURN 15800 NPOS LA,U A2,*1,X11 . LOAD ADDRESS OF X AND 15810 LXI A2,*2,X11 . INCX 15820 LXI A3,*4,X11 . LOAD INCY AND 15830 LXM,U A3,*3,X11 . ADDRESS OF Y 15840 JP A2,TINCY . TEST IF INCX .GE. 0 15850 LNA A4,A2 . ADD -INCX*(N-1) 15860 SSA A4,18 . TO THE BASE 15870 MSI A4,R3 . ADDRESS 15880 AH A2,A4 . FOR X 15890 TINCY JP A3,LOOP . TEST IF INCY .GE. 0 15900 LNA A4,A3 . ADD -INCY*(N-1) 15910 SSA A4,18 . TO THE BASE 15920 MSI A4,R3 . ADDRESS 15930 AH A3,A4 . FOR Y 15940 LOOP LA A0,0,A2 . LOAD X 15950 LA A1,0,A3 . LOAD Y 15960 SA A1,0,*A2 . STORE Y IN X AND INCREMENT X INDEX 15970 SA A0,0,*A3 . STORE X IN Y AND INCREMENT Y INDEX 15980 JGD R3,LOOP . END OF LOOP 15990 J 6,X11 . RETURN 16000 END . 16010 AXR$ 16020 $(1). 16030 . 16040 . EXTENDED PRECISION ACCUMULATION INNER PRODUCT 16050 . 16060 . TO BE USED AS FORTRAN FUNCTIONS 16070 . DQDOTI(N,B,C,X,INCX,Y,INCY) 16080 . DQDOTA(N,B,C,X,INCX,Y,INCY) 16090 . WHERE DQDOTI, DQDOTA, B, X, AND Y ARE ALL OF TYPE DOUBLE PRECISION 16100 . C IS AN EXTENDED PRECISION RESULT REPRESENTED IN A REAL ARRAY OF 16110 . LENGTH 5. FOR THE TWO CALLS, 16120 . DQDOTI AND C ARE REPLACED BY B + XX(I)*YY(I), I = 1,N 16130 . DQDOTA AND C ARE REPLACED BY B + C + XX(I)*YY(I), I = 1,N 16140 . WHERE FOR DQDOTA, C HAS BEEN COMPUTED BY AN EARLIER CALL TO EITHER 16150 . DQDOTI OR DQDOTA. XX(I) IS DEFINED BY 16160 . XX(I) = X(1-INCX+I*INCX) FOR INCX .GE. 0 16170 . XX(I) = X(1-N*INCX+I*INCX FOR INCX .LT. 0 16180 . AND YY(I) IS DEFINED SIMILARLY, WITH X, INCX REPLACED BY Y, INCY. 16190 . EXTENDED PRECISION ARITHMETIC IS USED INTERNALLY. 16200 . 16210 DQDOTA* LA,U A2,MODEA . SET UP TO INCLUDE C 16220 J START 16230 DQDOTI* LA,U A2,MODEI . SET UP TO EXCLUDE C 16240 START SZ A3 . 0 A3 FOR INDIRECT ADDRESS. OPT. 16250 DS A6,A6A7 . STORE A REGISTERS 16260 DS A8,A8A9 . 16270 DS A10,A10A11 . 16280 DS A12,A12A13 . 16290 DS A14,A14A15 . 16300 LR,U R1,*2,X11 . R1 = ADDRESS OF SAVED VALUE 16310 J 0,A2 . JUMP TO MODEA OR MODEI 16320 MODEA LA A0,R1 . LOAD SAVED VALUE (5 CELLS) 16330 LA A11,0,A0 . EXPONENT IN A11 16340 DL A12,1,A0 . S... ... IN A12 AND A13 16350 DL A14,3,A0 . S... ... IN A14 AND A15 16360 . WHERE S IS A SIGN BIT, AND 16370 . ... ARE BINARY BITS 16380 J $+2 16390 MODEI LNA,XU A11,32768 . EFFECTIVELY SETS SAVED VALUE =0 16400 LR R3,*0,X11 . R3=N 16410 DFU A6,*1,X11 . GET B -- A6=EXPONENT, A7,A8 = FR 16420 LA A2,*4,X11 . INCX IN LEFT OF 16430 LSSC A2,19 . A2 AND X ADDRESS 16440 LXM,U A2,*3,X11 . IN RIGHT OF A2 . 16450 LA A3,*6,X11 . STORE INCY IN LEFT OF A3 AND 16460 LSSC A3,19 . 0 IN RIGHT OF A3 16470 LXM,U A3,*5,X11 . Y ADDRESS IN RIGHT OF A3. 16480 LA A5,R3 . STORE 16490 AN,XU A5,1 . N - 1 IN A5 16500 JP A2,TINCY . TEST IF INCX.GE.0 16510 LNA A4,A2 . ADD -INCX*(N-1) 16520 SSA A4,18 . TO THE BASE 16530 MSI A4,A5 . ADDRESS 16540 AH A2,A4 . FOR X 16550 TINCY JP A3,BSET . TEST IF INCY.GE.0 16560 LNA A4,A3 . ADD -INCY*(N-1) 16570 SSA A4,18 . TO THE BASE 16580 MSI A4,A5 . ADDRESS 16590 AH A3,A4 . FOR Y 16600 . TAKE CARE OF B 16610 BSET SA A7,A9 . LOAD SIGNS IN 16620 DSA A9,71 . A9 AND A10 16630 SA A6,A4 . STORE EXPONENT IN A4 16640 JNZ A4,GETDIF . ADD TO C IF B IS NON-ZERO 16650 . START OF LOOP 16660 . BEGIN BY FORMING X(I)*Y(I) 16670 LOOP DFU A4,0,*A2 . GET X(I), A4 = BIASED EXPONENT 16680 LDSC A5,6 . A5 = FIRST PART OF FRACTION = X1 16690 SSC A6,1 . A6 = 2-ND PART OF FRACTION = X2 16700 SA A5,X1F . SAVE X1F 16710 DFU A7,0,*A3 . GET Y(I), A7 = BIASED EXPONENT 16720 LDSC A8,6 . A8 = FIRST PART OF FRACTION = Y1 16730 SSC A9,1 . A9 = 2-ND PART OF FRACTION =Y2F 16740 SA A8,Y1F . SAVE Y1F 16750 A A4,A7 . ADD EXPONENTS 16760 ANA,U A4,0002000 . ACCOUNT FOR BIAS AND SHIFTING 16770 SA A6,A7 . A7 = X2F 16780 MF A5,A9 . A5-A6 = X1F*Y2F 16790 MF A9,A7 . A9-A10= X2F*Y2F 16800 MF A7,A8 . A7-A8 = X2F*Y1F 16810 DA A7,A5 . A7-A8 = X2F*Y1F + X1F*Y2F =MID 16820 . LEFTMOST BIT NOT USED FOR SIGN 16830 SSC A8,1 . GET SIGN BIT FOR A8 16840 AA A9,A8 . ADD RIGHT OF MID TO X2F*Y2F 16850 SA A7,A8 . LEFT OF MID MOVED TO A8 16860 JNO $+5 . JUMP IF NO OVERFLOW 16870 JP A9,$+3 . COMPENSATE FOR OVERFLOW **** 16880 DAN A8,DBIGM . RESULT SHOULD BE .GE. 0 * 16890 J $+2 . * 16900 DA A8,DBIGM . RESULT SHOULD BE .LE. 0 **** 16910 LA A5,X1F . A5-A6 = 16920 MI A5,Y1F . X1F*Y1F 16930 SA A5,A7 . STORE SIGN BITS 16940 SSA A7,35 . IN A7. 16950 DA A7,A5 . ADD IN MOST SIG. PART OF FRAC. 16960 . END OF CODE FOR FORMING X(I)*Y(I) 16970 . END OF CODE FOR FORMING X(I)*Y(I) 16980 . SHIFT A7-A10 OR A12-A15 TO RIGHT IF NECESSARY 16990 GETDIF ANU A4,A11 . A5 = DIFFERENCE IN EXPONENTS 17000 LMA A0,A5 . A0 = SHIFT COUNT 17010 JZ A5,DONESH . IF A5=0 NO SHIFTING IS REQUIRED 17020 ANU,U A0,35 . A1= A0 - 35 17030 JN A1,TESTSH 17040 LA,U A0,35 . SET A0=35 17050 TLE,U A1,86 . 17060 J TESTSH . 17070 JN A5,ELOOP . NO ADD NECESSARY, IF A4.GT.A11 17080 DS A7,A12 . MOVE A7-A10 TO A12-A15, 17090 DS A9,A14 . 17100 SA A4,A11 . AND MOVE A4 TO A11 17110 J TEST0 . BEFORE GOING TO END OF LOOP 17120 TESTSH JN A5,SA7A10 . TEST WHICH TO SHIFT 17130 SA A4,A11 . MOVE A4 TO A11 (A4.GT.A11) 17140 DSA A14,0,A0 . SHIFT A12-A15 TO THE RIGHT 17150 LSSC A14,1,A0 . A0 POSITIONS (A0.LE.35) 17160 DSA A13,0,A0 . 17170 SSC A14,1 . 17180 LSSC A13,0,A0 . 17190 DSA A12,0,A0 . END OF SHIFT (A12-A15) 17200 JN A1,DONESH . JUMP IF DONE SHIFTING 17210 JZ A5,ELOOP . JUMP IF SHIFT DUE TO LARGE FRAC. 17220 CONTSH JZ A1,DONESH . JUMP IF DONE SHIFTING 17230 LA A0,A1 . GET NEXT 17240 ANU,U A0,35 . SHIFT 17250 JN A1,TESTSH . INDEX AND 17260 LA,U A0,35 . CONTINUE 17270 JP A5,TESTSH+2 . SHIFTING 17280 SA7A10 DSA A9,0,A0 . SHIFT A7-A10 TO THE RIGHT 17290 LSSC A9,1,A0 . A0 POSITIONS (A0.LE.35) 17300 DSA A8,0,A0 . 17310 SSC A9,1 . 17320 LSSC A8,0,A0 . 17330 DSA A7,0,A0 . END OF SHIFT (A7-A10) 17340 JP A1,CONTSH 17350 . END OF CODE FOR SHIFTING TO THE RIGHT 17360 . ADD A7-A10 TO A12-A15 17370 DONESH DA A14,A9 . ADD LEAST SIGNIFICANT PARTS 17380 JNO NOOVER . JUMP IF NO OVERFLOW 17390 DA A12,A7 . ADD MOST SIGNIFICANT PARTS 17400 JP A14,POSA14 . COMPENSATE FOR OVERFLOW **** 17410 DA A12,(1D) . RESULT SHOULD BE .GE.0 * 17420 AA A14,DBIG . * 17430 JP A14,BIGTST . * 17440 A14ZER LNA A14,A14 . A14 = 0 AND HAD WRONG SIGN * 17450 J BIGTST . * 17460 POSA14 DAN A12,(1D) . RESULT SHOULD BE .LE.0 * 17470 ANA A14,DBIG . * 17480 JP A14,A14ZER . * 17490 J BIGTST . **** 17500 NOOVER DA A12,A7 . ADD MOST SIGNIFICANT PARTS 17510 JP A12,A12POS . TEST IF LEAST AND MOST SIGNIF. 17520 JN A14,TEST0 . PARTS HAVE THE SAME SIGN 17530 DJZ A14,ZERA14 . 17540 DJZ A12,ZERA12 . 17550 DA A12,(1D) . A14-A15 SHOULD BE .LT.0 17560 DA A14,DBIG . 17570 J TEST0 17580 A12POS JP A14,TEST0 . 17590 DJZ A14,ZERA14 . 17600 DJZ A12,ZERA12 . 17610 DAN A12,(1D) . A14-A15 SHOULD BE .GT.0 17620 DAN A14,DBIG . 17630 J TEST0 . 17640 ZERA14 DLN A14,A14 . A14 WAS =0 AND OF WRONG SIGN 17650 J TEST0 . 17660 ZERA12 DLN A12,A12 . A12 WAS =0 AND OF WRONG SIGN 17670 . A12 IS ZERO, SHIFT A12-A15 LEFT 35 PLACES 17680 LDSC A12,35 . 17690 SSC A13,35 . 17700 LSSC A14,1 . 17710 LDSC A13,35 . 17720 LDSC A14,35 . END OF SHIFT 17730 ANA,U A11,35 . ADJUST EXPONENT FOR THE SHIFT 17740 TEST0 JNZ A12,BIGTST . IF A12 IS 0, EITHER A SHIFT 17750 JNZ A13,ZERA12+1 . TO THE LEFT IS MADE, OR IF 17760 JNZ A14,ZERA12+1 . 17770 JNZ A15,ZERA12+1 . 17780 LNA,XU A11,32768 . RESULT=0, SET EXPONENT SMALL 17790 J ELOOP . AND GO TO END OF LOOP 17800 BIGTST LSC A4,A12 . SET A5=NO. OF BITS=TO SIGN BIT-1 17810 JNZ A5,ELOOP . IF A5=0,A12-15 IS SHIFTED TO THE 17820 LA,U A0,10 . RIGHT 10 PLACES TO ELIMINATE 17830 SZ A1 . DANGER OF OVERFLOW. 17840 AA A11,A0 . INCREASE EXPONENT, AND GO SHIFT 17850 J TESTSH+2 . A12-A15 TO RIGHT 10 PLACES 17860 ELOOP JGD R3,LOOP . END OF LOOP 17870 . END OF LOOP -- STORE RESULTS 17880 LA A0,R1 . SAVE THE RESULT 17890 SA A11,0,A0 . 17900 DS A12,1,A0 . 17910 DS A14,3,A0 . 17920 LSC A0,A12 . GET FINAL EXPONENT 17930 ANU,U A1,11 . 17940 ANA A11,A2 . 17950 JP A11,$+3 . IF BIASED EXPONENT IS NEGATIVE 17960 DSL A0,72 . STORE ZERO FOR RESULT AND 17970 J SAVE . GET READY TO RETURN 17980 LDSC A12,0,A1 . SHIFT A12 - A14 TO THE 17990 SSC A13,0,A1 . LEFT A1 18000 LSSC A14,1 . POSITIONS 18010 LDSC A13,0,A1 . 18020 DSA A12,11 . SHIFT A12 - A13 BACK 11 POSITIO 18030 DLCF A11,A12 . STORE RESULT AS D.P. NUMBER 18040 DS A12,A0 . IN A0 - A1 18050 SAVE DL A6,A6A7 . RESTORE A REGISTERS 18060 DL A8,A8A9 . 18070 DL A10,A10A11 . 18080 DL A12,A12A13 . 18090 DL A14,A14A15 . 18100 J 8,X11 . 18110 $(0). 18120 X1F + 0 . 18130 Y1F + 0 . 18140 A6A7 + 0D . 18150 A8A9 + 0D . 18160 A10A11 + 0D . 18170 A12A13 + 0D . 18180 A14A15 + 0D . 18190 DBIGM + 0777777777777 . 18200 DBIG + 0377777777777 . 18210 + 0777777777777 . 18220 . 18230 END . 18240 AXR$ 18250 $(1). 18260 . 18270 . DOUBLE PRECISION ACCUMULATION INNER PRODUCT 18280 . 18290 . TO BE USED AS FORTRAN FUNCTION SDSDOT(N,SB,X,INCX,Y,INCY) 18300 . AND SDSDOT= SB + SUM FROM I=1 TO N OF A(I)*B(I) WHERE 18310 . WHERE SDSDOT, SB, X, AND Y ARE ALL OF TYPE REAL, 18320 . A(I) = X(1-INCX+I*INCX) IF INCX.GE.0 18330 . A(I) = X(1-N*INCX+I*INCX) IF INCX.LT.0 18340 . B(I) DEFINED SIMILARLY, WITH X AND INCX REPLACED BY Y AND INCY 18350 . 18360 SDSDOT* SZ A3 . 0 A3 FOR INDIRECT ADDRESS. OPT. 18370 FEL A0,*1,X11 . LOAD SB IN A0 18380 LR R3,*0,X11 . STORE N IN R3 18390 JGD R3,NPOS . STORE N-1 IN R3 AND TEST N 18400 J END . EXIT IF N.LE.0 18410 NPOS DS A6,SAVE . SAVE REGISTERS A6 AND A7 18420 LA,U A2,*2,X11 . LOAD ADDRESS OF X 18430 LXI A2,*3,X11 . LOAD INCREMENT ON X 18440 LXI A3,*5,X11 . LOAD INCREMENT ON Y 18450 LXM,U A3,*4,X11 . LOAD ADDRESS OF Y 18460 JP A2,TINCY . TEST IF INCX.GE.0 18470 LNA A4,A2 . ADD -INCX*(N-1) 18480 SSA A4,18 . TO THE BASE 18490 MSI A4,R3 . ADDRESS 18500 AH A2,A4 . FOR X 18510 TINCY JP A3,LOOP . TEST IF INCY.GE.0 18520 LNA A4,A3 . ADD -INCY*(N-1) 18530 SSA A4,18 . TO THE BASE 18540 MSI A4,R3 . ADDRESS 18550 AH A3,A4 . FOR Y 18560 . BEGIN LOOP TO FORM INNER PRODUCT 18570 LOOP FEL A4,0,*A2 . LOAD X, CONVERT TO DOUBLE, AND IN 18580 FEL A6,0,*A3 . LOAD Y, CONVERT TO DOUBLE, AND IN 18590 DFM A4,A6 . MULTIPLY X TIMES Y 18600 DFA A0,A4 . ACCUMULATE INNER PRODUCT 18610 JGD R3,LOOP . END OF INNER PRODUCT LOOP 18620 DL A6,SAVE . RESTORE REGISTERS A6 AND A7 18630 END FCL A0,A0 . ANSWER = SNGL(ANSWER) 18640 J 7,X11 . RETURN FOR N.GT.0 18650 . 18660 $(0) 18670 SAVE + 0D . PLACE TO SAVE A6 AND A7 18680 END . 18690 AXR$ 18700 $(1). 18710 . 18720 . DOUBLE PRECISION APPLICATION OF A GIVENS TRANSFORMATION 18730 . 18740 . TO BE USED AS FORTRAN SUBROUTINE DROT(N,X,INCX,Y,INCY,C,S) 18750 . APPLY ( C S) TO A 2 BY N MATRIXX (XX(1) ... XX(N)) 18760 . (-S C) (YY(1) ... YY(N)) 18770 . WHERE XX(I)=X(1-INCX+I*INCX) IF INCX.GE.0 18780 . AND XX(I)=X(1-N*INCX+I*INCX) IF INCX.LT.0 18790 . AND YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED 18800 . BY Y AND INCY 18810 . 18820 DROT* SZ A3 0 A3 FOR INDIRECT ADDRESSING OPTION 18830 LR R3,*0,X11 . STORE N IN R3 18840 DL A0,*5,X11 . STORE C IN A0 AND A1 18850 DL A4,*6,X11 . STORE S IN A4 AND A5 18860 JNZ A4,$+2 . TEST FOR RETURN S=0 18870 DTE A0,ONE . AND C=1 18880 JGD R3,NPOS . OR N.LE.0 18890 J 8,X11 . RETURN 18900 NPOS DS A6,A6A7 . SAVE CONTENTS OF A6 AND A7 REGISTERS 18910 DS A8,A8A9 . SAVE CONTENTS OF A8 AND A9 REGISTERS 18920 LA,XH2 A2,*2,X11 . LOAD INCREMENT ON X 18930 LA,XH2 A3,*4,X11 . LOAD INCREMENT ON Y 18940 LSSC A2,19 . DOUBLE INCREMENTS FOR 18950 LSSC A3,19 . DOUBLE PRECISION 18960 LXM,U A2,*1,X11 . LOAD ADDRESS OF X 18970 LXM,U A3,*3,X11 . LOAD ADDRESS OF Y 18980 JP A2,TINCY . TEST IF INCX .GE. 0 18990 LNA A6,A2 . ADD -INCX*(N-1) 19000 SSA A6,18 . TO THE BASE 19010 MSI A6,R3 . ADDRESS 19020 AH A2,A6 . FOR X 19030 TINCY JP A3,LOOP . TEST IF INCY .GE. 0 19040 LNA A6,A3 . ADD -INCY*(N-1) 19050 SSA A6,18 . TO THE BASE 19060 MSI A6,R3 . ADDRESS 19070 AH A3,A6 . FOR Y 19080 LOOP DL A6,0,A2 . LOAD X 19090 DL A8,0,A3 . LOAD Y 19100 XPART DFM A6,A0 . FORM C*X 19110 DFM A8,A4 . FORM S*Y 19120 DFA A8,A6 . FORM C*X+S*Y 19130 DL A6,0,A2 . LOAD X 19140 DS A8,0,*A2 . STORE NEW X, AND INCREMENT INDEX 19150 DL A8,0,A3 . LOAD Y 19160 DFM A6,A4 . FORM S*X 19170 DFM A8,A0 . FORM C*Y 19180 DFAN A8,A6 . FORM C*Y-S*X 19190 DS A8,0,*A3 . STORE NEW Y, AND INCREMENT INDEX 19200 ENDLOOP JGD R3,LOOP . END OF LOOP 19210 DL A6,A6A7 . RESTORE A6 AND A7 REGISTERS 19220 DL A8,A8A9 . RESTORE A8 AND A9 REGISTERS 19230 J 8,X11 . RETURN 19240 . 19250 $(0). 19260 ONE + 1.0D 1.0D0 19270 A6A7 + 0D . PLACE TO SAVE A6 AND A7 CONTENTS 19280 A8A9 + 0D . PLACE TO SAVE A8 AND A9 CONTENTS 19290 . 19300 END . 19310 AXR$ 19320 $(1). 19330 . 19340 . COMPUTE CONSTANTS FOR GIVENS TRANSFORMATION 19350 . 19360 . TO BE USED AS FORTRAN SUBROUTINE SROTG(A,B,C,S) 19370 . TO COMPUTE (ALL VARIABLES OF TYPE REAL) 19380 . C = A/R, S = B/R, WHERE R = (+ OR -) SQRT(A*A + B*B) 19390 . (R HAS THE SAME SIGN AS A IF ABS(A) .GT. ABS(B) AND 19400 . OTHERWISE HAS THE SIGN OF B.) 19410 . R IS STORED IN A AND S (IF ABS(C) .GT. ABS(S)) OR 1/C 19420 . (IF (ABS(C) .LE. ABS(S)) IS STORED IN B. (IF C = 0, 1 19430 . IS STORED IN B.) 19440 . THE GIVENS ROTATION MATRIX IS GIVEN BY (C S) 19450 . (-S C) 19460 . 19470 SROTG* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 19480 LMA A0,*0,X11 . LOAD ABS A 19490 LMA A1,*1,X11 . LOAD ABS B 19500 TG A1,A0 . TEST IF ABS A .LE. ABS B 19510 J BFIRST . IF YES GO TO BFIRST 19520 AFIRST SNA A3,CASE . STORE -0 IN CASE IF ABS A .GT. ABS B 19530 LA A0,*0,X11 . LOAD A IN A0 19540 LA A2,*1,X11 . LOAD B IN A2 19550 J STORE . GO STORE VARIABLE VALUES 19560 BFIRST LA A0,*1,X11 . LOAD B IN A0 19570 LA A2,*0,X11 . LOAD A IN A2 19580 JZ A2,ZIP . ZIP IS SPECIAL CASE FOR A=0 19590 SZ CASE . STORE 0 IN CASE IF ABS A .LT. ABS B 19600 STORE SA A0,RMULT . STORE CONTENTS OF A0 IN RMULT 19610 FD A2,A0 . FORM A/B (OR B/A) AND 19620 SA A2,SMULT . STORE IN SMULT 19630 FM A2,A2 . SQUARE A/B (OR B/A) AND 19640 FA A2,ONE . ADD 1.E0 AND 19650 SA A2,YR . STORE RESULT IN YR 19660 SX X11,WB+1 . SAVE X11 CONTENTS 19670 LMJ X11,SQRT . GET THE SQUARE ROOT OF YR 19680 + YR . 19690 + $-SROTG,WB . 19700 LX X11,WB+1 . RESTORE X11 19710 LA A4,ONE . PUT 1.E0 IN A4 19720 FD A4,A0 . GET THE INVERSE OF SQRT(YR) 19730 FM A0,RMULT . GET R WITH APPROPRIATE SIGN 19740 SA A0,*0,X11 . STORE R IN A 19750 TN CASE . JUMP TO BIGA 19760 J BIGA . IF ABS A .LE. ABS B 19770 SA A4,*2,X11 . STORE C = 1 / SQRT(1 + (B/A)**2) 19780 FM A4,SMULT . MULTIPLY BY B/A 19790 SA A4,*3,X11 . STORE S 19800 SA A4,*1,X11 . STORE S IN B 19810 J 5,X11 . RETURN 19820 BIGA SA A4,*3,X11 . STORE S = 1 / SQRT(1 + (A/B)**2) 19830 FM A4,SMULT . MULTIPLY BY A/B 19840 SA A4,*2,X11 . STORE C 19850 LA A0,ONE . STORE 19860 FD A0,A4 . 1 / C IN 19870 SA A0,*1,X11 . B. 19880 J 5,X11 . RETURN 19890 ZIP LA A4,ONE . LOAD A 1. 19900 JZ A0,BZERO . JUMP IF B=0 (A IS ALSO 0) 19910 SA A0,*0,X11 . STORE B IN A, 19920 SA A4,*1,X11 . 1 IN B (CASE OF C=0), 19930 SA A4,*3,X11 . 1 IN S, AND 19940 SZ *2,X11. 0 IN C. 19950 J 5,X11 . RETURN 19960 BZERO SZ *3,X11 . STORE 0 IN S AND 19970 SA A4,*2,X11 . 1 IN C. 19980 J 5,X11 . RETURN 19990 $(0). 20000 ONE + 1.0 . 1.E0 20010 CASE + 0 . PLACE TO SAVE CASE 20020 RMULT + 0 . PLACE TO STORE A (OR B) 20030 SMULT + 0 . PLACE TO STORE A/B (OR B/A) 20040 YR + 0 . 20050 WB + 'SROTG' . WALKBACK WORD 20060 + 0 . PLACE TO SAVE X11 20070 . 20080 END . 20090 AXR$ 20100 $(1). 20110 . 20120 . COMPUTE CONSTANTS FOR GIVENS TRANSFORMATION 20130 . 20140 . TO BE USED AS FORTRAN SUBROUTINE DROTG(A,B,C,C) 20150 . TO COMPUTE (ALL VARIABLES OF TYPE DOUBLE PRECISION) 20160 . C = A/R, S = B/R, WHERE R = (+ OR -) SQRT(A*A + B*B) 20170 . (R HAS THE SAME SIGN AS A IF ABS(A) .GT. ABS(B) AND 20180 . OTHERWISE HAS THE SIGN OF B.) 20190 . R IS STORED IN A AND S (IF ABS(C) .GT. ABS(S)) OR 1/C 20200 . (IF (ABS(C) .LE. ABS(S)) IS STORED IN B. (IF C = 0, 1 20210 . IS STORED IN B.) 20220 . THE GIVENS ROTATION MATRIX IS GIVEN BY (C S) 20230 . (-S C) 20240 . 20250 DROTG* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 20260 LMA A0,*0,X11 . LOAD ABS A 20270 LMA A1,*1,X11 . LOAD ABS B 20280 TG A1,A0 . TEST IF ABS A .LE. ABS B 20290 J BFIRST . IF YES GO TO BFIRST 20300 AFIRST SNA A3,CASE . STORE -0 IN CASE IF ABS A .GT. ABS B 20310 DL A0,*0,X11 . LOAD A IN A0 20320 DL A2,*1,X11 . LOAD B IN A2 20330 J STORE . GO STORE VARIABLE VALUES 20340 BFIRST DL A0,*1,X11 . LOAD B IN A0 20350 DL A2,*0,X11 . LOAD A IN A2 20360 JZ A2,ZIP . ZIP IS SPECIAL CASE FOR A=0 20370 SZ CASE . STORE 0 IN CASE IF ABS A .LT. ABS B 20380 STORE DS A0,RMULT . STORE CONTENTS OF A0 IN RMULT 20390 DFD A2,A0 . FORM A/B (OR B/A) AND 20400 DS A2,SMULT . STORE IN SMULT 20410 DFM A2,A2 . SQUARE A/B (OR B/A) AND 20420 DFA A2,ONE . ADD 1.D0 AND 20430 DS A2,YR . STORE RESULT IN YR 20440 SX X11,WB+1 . SAVE X11 CONTENTS 20450 LMJ X11,DSQRT . GET THE SQUARE ROOT OF YR 20460 + YR . 20470 + $-DROTG,WB . 20480 LX X11,WB+1 . RESTORE X11 20490 DL A4,ONE . PUT 1.D0 IN A4 20500 DFD A4,A0 . GET THE INVERSE OF SQRT(YR) 20510 DFM A0,RMULT . GET R WITH APPROPRIATE SIGN 20520 DS A0,*0,X11 . STORE R IN A 20530 TN CASE . JUMP TO BIGA IF 20540 J BIGA . ABS A .LE. ABS B 20550 DS A4,*2,X11 . STORE C = 1 / SQRT(1 + (B/A)**2) 20560 DFM A4,SMULT . MULTIPLY BY B/A 20570 DS A4,*3,X11 . STORE S 20580 DS A4,*1,X11 . STORE S IN B 20590 J 5,X11 . RETURN 20600 BIGA DS A4,*3,X11 . STORE S = 1 / SQRT(1 + (A/B)**2) 20610 DFM A4,SMULT . MULTIPLY BY A/B 20620 DS A4,*2,X11 . STORE C 20630 DL A0,ONE . STORE 20640 DFD A0,A4 . 1 / C IN 20650 DS A0,*1,X11 . B. 20660 J 5,X11 . RETURN 20670 ZIP DL A4,ONE . LOAD A4,A5 WITH A 1. 20680 JZ A0,BZERO . JUMP IF B=0 (A IS ALSO 0) 20690 DS A0,*0,X11 . STORE B IN A, 20700 DS A4,*1,X11 . 1 IN B.(CASE OF C=0), 20710 DS A4,*3,X11 . 1 IN S, 20720 SZ *2,X11 . 0 IN 20730 SZ *2,X11 . C. 20740 J 5,X11 . RETURN 20750 BZERO SZ *3,X11 . STORE 0 IN 20760 SZ *3,X11 . S AND 20770 DS A4,*2,X11 . 1 IN C. 20780 J 5,X11 . RETURN 20790 $(0). 20800 ONE + 1.0D . 1.D0 20810 CASE + 0 . PLACE TO STORE CASE 20820 ZERO + 0D . 0.0D 20830 RMULT + 0D . PLACE TO STORE A (OR B) 20840 SMULT + 0D . PLACE TO STORE A/B (OR B/A) 20850 YR + 0D . 20860 WB + 'DROTG' . WALKBACK WORD 20870 + 0 . PLACE TO SAVE X11 20880 . 20890 END . 20900 AXR$ 20910 $(1). 20920 . SINGLE PRECISION APPLICATION OF A GIVENS TRANSFORMATION 20930 . 20940 . TO BE USED AS FORTRAN SUBROUTINE SROT(N,X,INCX,Y,INCY,C,S) 20950 . APPLY (C S) TO A 2 BY N MATRIX (XX(1) ... XX(N)) 20960 . (-S C) (YY(1) ... YY(N)) 20970 . WHERE XX(I)=X(1-INCX+I*INCX) IF INCX .GE. 0 20980 . AND XX(I)=X(1-N*INCX+I*INCX) IF INCX .LT. 0 20990 . AND YY(I) IS SIMILARLY DEFINED, WITH X AND INCX REPLACED 21000 . BY Y AND INCY. 21010 . 21020 SROT* SZ A3 . 0 A3 FOR INDIRECT ADDRESSING OPTION 21030 LR R3,*0,X11 . STORE N IN R3 21040 LA A0,*5,X11 . STORE C IN A0 21050 LA A1,*6,X11 . STORE S IN A1 21060 JNZ A1,$+2 . TEST FOR RETURN S=0 21070 TE A0,ONE . AND C=1 21080 JGD R3,NPOS . OR N.LE.0 21090 J 8,X11 . RETURN 21100 NPOS DS A6,A6A7 . SAVE CONTENTS OF A6 AND A7 REGISTERS 21110 LA,U A2,*1,X11 . LOAD ADDRESS OF X 21120 LXI A2,*2,X11 . LOAD INCREMENT ON X 21130 LXI A3,*4,X11 . LOAD INCREMENT ON Y 21140 LXM,U A3,*3,X11 . LOAD ADDRESS OF Y 21150 JP A2,TINCY . TEST IF INCX .GE. 0 21160 LNA A4,A2 . ADD -INCX*(N-1) 21170 SSA A4,18 . TO THE BASE 21180 MSI A4,R3 . ADDRESS 21190 AH A2,A4 . FOR X 21200 TINCY JP A3,LOOP . TEST IF INCY .GE. 0 21210 LNA A4,A3 . ADD -INCY*(N-1) 21220 SSA A4,18 . TO THE BASE 21230 MSI A4,R3 . ADDRESS 21240 AH A3,A4 . FOR Y 21250 LOOP LA A4,0,A2 . LOAD X 21260 LA A6,0,A3 . LOAD Y 21270 FM A4,A0 . FORM C*X 21280 FM A6,A1 . FORM S*Y 21290 FA A6,A4 . FORM C*X + S*Y 21300 LA A4,0,A2 . LOAD X 21310 SA A6,0,*A2 . STORE NEW X 21320 FM A4,A1 . FORM S*X 21330 LA A6,0,A3 . LOAD Y 21340 FM A6,A0 . FORM C*Y 21350 FAN A6,A4 . FORM C*Y - S*X 21360 SA A6,0,*A3 . STORE NEW Y 21370 JGD R3,LOOP . END OF LOOP 21380 DL A6,A6A7 . RESTORE A6 AND A7 REGISTERS 21390 J 8,X11 . RETURN 21400 . 21410 $(0). 21420 ONE + 1.0 . 1.0 21430 A6A7 + 0D . PLACE TO SAVE A6 AND A7 REGISTERS 21440 . 21450 END . 21460 SHAR_EOF fi # end of overwriting check # End of shell archive exit 0