      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  &REGNUM                                                       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
&REGNUM  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  &REGNUM                                                      1090
         AIF   (&CALLQ).L10                                                 1100
         AIF   (T'&RESULT EQ 'O').L5                                        1110
&LBL     LM    14,15,12(13) .  RESULT IN R0.                                1120
         LM    1,&REGNUM,24(13)                                             1130
         AGO   .L50                                                         1140
.L5      ANOP                                                               1150
&LBL     LM    14,&REGNUM,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,&REGNUM+1,24(13)                                           1210
         AGO   .L50                                                         1220
.L15     ANOP                                                               1230
&LBL     L     13,HSA(13) .    RESTORE CALLERS'S SAVEAREA.                  1240
         LM    14,&REGNUM+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
*                        <CONSTANT>, THE ADDRESS OF THE LITERAL VALUE   BLA00061
*                        <CONSTANT> 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
