C ALGORITHM 653, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 13, NO. 3, P. 311. PROGRAM BUST C C READ TEXT FROM A FILE WHOSE NAME IS READ FROM STANDARD INPUT. C LOOK FOR SPECIAL SIGNALS 'C$' IN COLUMNS 1 AND 2. UPPER CASE C. C THIS IS FOLLOWED BY THE CHARACTERS 'TEXT1.TEXT2'. C A SIGNAL ';$' HAS THE SAME MEANING. THE SIGNAL '-$' OPENS A C FILE BUT ANY LINES WITH THIS IN COLUMNS 1-2 ARE NOT WRITTEN. C AFTER READING THIS SIGNAL, CLOSE ANY EXISTING OPEN UNIT AND C OPEN A NEW FILE WITH THE NAME 'TEXT1.TEXT2'. C AN EOF WILL ALSO CLOSE ANY OPEN UNIT. C R. J. HANSON, 1986 MAR 18. PARAMETER (NIN=1,NOUT=2,LL=80) C C IF THE LINES ARE TO BE LONGER THAN 80 CHARS., CHANGE THE NEXT C LINE AND LL IN THE PARAMETER STATEMENT TO A VALUE .GE. THE LONGEST C LINE IN THE FILE. CHARACTER *80 L CHARACTER *64 BOOTFL,ANSWER LOGICAL OPEN,QUIET C C ASK FOR FILE NAME. READ FROM STANDARD INPUT. 10 CONTINUE WRITE (*, . '('' ENTER NAME OF FILE THAT CONTAINS INDIVIDUAL FILES...'')') READ (*,'(A)',ERR=10,END=80) BOOTFL C C HAVE THE NAME OF UNPACKED FILE IN THE CHARACTER VARIABLE 'BOOTFL'. 20 WRITE (*, .'('' ENTER Y FOR YES IF OUTPUT IS TO BE ECHOED ON STANDARD OUTPUT. .'',/,'' N FOR NOT. REPLY IN CAPS, PLEASE...'')') READ (*,*,ERR=20,END=80) ANSWER QUIET = ICHAR(ANSWER(1:1)) .EQ. ICHAR('N') IF ( .NOT. QUIET .AND. ICHAR(ANSWER(1:1)).NE.ICHAR('Y')) GO TO 20 C C OPEN THE FILE THAT CONTAINS ALL THE TEXT. START OVER IF ANY C ERRORS OCCURR. OPEN (UNIT=NIN,FILE=BOOTFL,ERR=10,STATUS='OLD') OPEN = .FALSE. C C START MAIN LOOP THAT READS THE MAIN FILE AND WRITES SMALLER C FILES. A NEW FILE IS SIGNALED BY 'C$'. 30 CONTINUE C C THIS IS A 'DO FOREVER' LOOP WITH ONLY AN EOF STOPPING IT. READ (NIN,'(A)',END=70) L C C FIND THE LAST NONBLANK CHARACTER IN THE IMAGE. DO 40 I = LL,1,-1 LLINE = I IF (ICHAR(L(I:I)).NE.ICHAR(' ')) GO TO 50 40 CONTINUE 50 CONTINUE C C ECHO THE OUTPUT IF IT WAS DESIRED. IF ( .NOT. QUIET) WRITE (*,'(1X,A)') L(1:LLINE) C C LOOK FOR A 'C$'. UPPER CASE C IS REQUIRED. C LOOK FOR A ';$'. THIS ALSO HAS THE SAME MEANING AS 'C$'. C LOOK FOR A '-$'. THIS ALSO HAS THE SAME MEANING AS 'C$' C EXCEPT THAT THE LINE IS NOT WRITTEN TO THE OUTPUT FILE. IF (LLINE.GE.2) THEN IF ((ICHAR(L(1:1)).EQ.ICHAR('C').OR.ICHAR(L(1:1)) . .EQ.ICHAR(';') .OR. ICHAR(L(1:1)).EQ.ICHAR('-')) . .AND. ICHAR(L(2:2)).EQ.ICHAR('$')) THEN IF (OPEN) THEN CLOSE (UNIT=NOUT) OPEN = .FALSE. END IF * OPEN (UNIT=NOUT,FILE=L(3:LLINE),STATUS='NEW',ERR=60) OPEN = .TRUE. END IF * END IF C C AFTER FILE IS OPENED WRITE TEXT INTO IT. C SOME FILES SHOULD NOT HAVE THE FILE NAME LINE IN THEM. C THIS IS SIGNALLED BY A '-' (MINUS) SIGN IN COLUMN ONE C AND A '$' IN COLUMN TWO. IF (OPEN) THEN IF((LLINE.GE.2))THEN IF(ICHAR(L(1:1)).EQ.ICHAR('-').AND. . ICHAR(L(2:2)) .EQ. ICHAR('$')) GO TO 30 END IF WRITE (NOUT,'(A)') L(1:LLINE) END IF GO TO 30 * 60 CONTINUE C C AN ERROR OCCURRED IN THE OPEN OF A FILE. PROBABLY A NAME ALREADY C EXISTED. WRITE (*, .'('' ERROR OCCURRED TRYING TO OPEN A FILE.'',/, '' IF TH .E OPTION TO ECHO OUTPUT WAS USED, THE NAME SHOWN'',/, '' ABOVE . (AFTER *$) MAY ALREADY EXIST, *=C, ; OR - ALLOWED HERE.'').') C C CLOSE ANY EXISTING FILE. 70 IF (OPEN) CLOSE (UNIT=NOUT) 80 STOP END C$TBLAS.FOR PROGRAM TBLAS 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 N BY N 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(N BY N) 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 N BY N 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 M BY N 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 C1 ********************************* TBLAS ************************** C TEST DRIVER FOR BASIC LINEAR ALGEBRA SUBPROGRAMS. C C. L. LAWSON,JPL, 1974 DEC 10, 1975 MAY 28 C MODIFIED TO READ FILE NAMES IN PC DOS SYSTEMS BY R. J. HANSON. C REVISED 1985 NOV 27. C TBLAS 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, TBLAS 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 TBLAS. C USED IN TBLAS, 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 TBLAS 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 TBLAS, CHECK1, AND CHECK2. SENT TO BLAS C SUBPROGRAMS AS TEST DATA. PRINTED WHEN ERRORS ARE C NOTED. C INCY SET IN TBLAS, AND CHECK2. SENT TO BLAS SUBPROGRAMS AS C TEST DATA. PRINTED WHEN ERRORS ARE NOTED. C MODE SET IN TBLAS AND CHECK2. DISTINGUISHES TEST CASES. C PRINTED WHEN ERRORS ARE NOTED. C PASS SET IN TBLAS, 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 CHARACTER *064 NAMEIN,NAMEPR DATA SFAC,SDFAC,DFAC,DQFAC/.3125E-1,.50,.625D-1,.125D0/ * NREAD = 1 NPRINT = 2 10 CONTINUE WRITE (*,'('' GIVE NAME OF FILE OF FLAGS FOR TESTING BLAS...'')') READ (*,'(A)',ERR=10,END=190) NAMEIN OPEN (UNIT=NREAD,FILE=NAMEIN,STATUS='OLD',ERR=10) 70 WRITE (*,'('' GIVE NAME OF FILE TO RECEIVE TESTING RESULTS...'')') READ (*,'(A)',ERR=70,END=190) NAMEPR 80 WRITE (*,'('' GIVE STATUS OF FILE, 1=NEW, 2=OLD...'')') READ (*,*,ERR=80,END=190) IGO GO TO (90,100),IGO * GO TO 80 * 90 CONTINUE OPEN (UNIT=NPRINT,FILE=NAMEPR,STATUS='NEW',ERR=70) GO TO 120 * 100 CONTINUE OPEN (UNIT=NPRINT,FILE=NAMEPR,STATUS='OLD',ERR=70) 120 CONTINUE WRITE (NPRINT,9021) READ (NREAD,9001,ERR=180) ITEST WRITE (NPRINT,9031) ITEST ALLZRO = .TRUE. DO 170 IC = 1,38 ICASE = IC IF (ITEST(ICASE).EQ.0) GO TO 170 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 (150,150,150,150,150,150,150,150,150, . 150,150,130,130,150,150,130,130,150, . 150,150,150,150,150,150,150,140,140, . 140,140,140,140,140,140,140,140,140, . 140,140),ICASE C ICASE = 12-13 OR 16-17 130 CALL CHECK0(SFAC,DFAC) GO TO 160 C ICASE = 26-38 140 CALL CHECK1(SFAC,DFAC) GO TO 160 C ICASE = 1-11, 14-15, OR 18-25 150 CALL CHECK2(SFAC,SDFAC,DFAC,DQFAC) 160 CONTINUE C PRINT IF (PASS) WRITE (NPRINT,9011) 170 CONTINUE IF ( .NOT. ALLZRO) GO TO 10 180 CONTINUE WRITE(NPRINT,9041) 190 STOP * 9001 FORMAT (80I1) 9011 FORMAT (1H ,39X,4HPASS) 9021 FORMAT (1X///34H PROGRAM TBLAS IS READY FOR INPUT./ . 42H INPUT ONE CARD IMAGE HAVING ONES OR ZEROS/ . 42H IN COLS 1 - 38. A ONE IN COL K MEANS TO/ . 41H TEST SUBPROGRAM NO. K. ALL ZEROS MEANS/ . 38H TO TERMINATE EXECUTION. INPUT NOW./) 9031 FORMAT (1H0,38I2) 9041 FORMAT (' PROBABLY BAD INPUT FOR FLAGS OF BLAS TO TEST.') 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 20 I = 1,LEN DD = DCOMP(I) - DTRUE(I) IF (DDIFF(DABS(DSIZE(I))+DABS(DFAC*DD),DABS(DSIZE(I))).EQ. . 0.D0) GO TO 20 C C HERE DCOMP(I) IS NOT CLOSE TO DTRUE(I). C IF ( .NOT. PASS) GO TO 10 C PRINT FAIL MESSAGE AND HEADER. PASS = .FALSE. WRITE (NPRINT,9001) WRITE (NPRINT,9011) 10 WRITE (NPRINT,9021) ICASE,N,INCX,INCY,MODE,I,DCOMP(I), . DTRUE(I),DD,DSIZE(I) 20 CONTINUE RETURN * 9001 FORMAT (1H ,39X,4HFAIL) 9011 FORMAT (26H0CASE N INCX INCY MODE I,29X,7HCOMP(I),29X,7HTRUE(I), . 2X,10HDIFFERENCE,5X,7HSIZE(I)/1X) 9021 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 C REAL SCOMP(1),STRUE(1),SSIZE(*) REAL SCOMP(1),STRUE(1),SSIZE 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(*) 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 20 I = 1,LEN SD = SCOMP(I) - STRUE(I) IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ. . 0.) GO TO 20 C C HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). C IF ( .NOT. PASS) GO TO 10 C PRINT FAIL MESSAGE AND HEADER. PASS = .FALSE. WRITE (NPRINT,9001) WRITE (NPRINT,9011) 10 WRITE (NPRINT,9021) ICASE,N,INCX,INCY,MODE,I,SCOMP(I), . STRUE(I),SD,SSIZE(I) 20 CONTINUE RETURN * 9001 FORMAT (1H+,39X,4HFAIL) 9011 FORMAT (26H0CASE N INCX INCY MODE I,29X,7HCOMP(I),29X,7HTRUE(I), . 2X,10HDIFFERENCE,5X,7HSIZE(I)/1X) 9021 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 20 C C HERE ICOMP IS NOT EQUAL TO ITRUE. C IF ( .NOT. PASS) GO TO 10 C PRINT FAIL MESSAGE AND HEADER. PASS = .FALSE. WRITE (NPRINT,9001) WRITE (NPRINT,9011) 10 ID = ICOMP - ITRUE WRITE (NPRINT,9021) ICASE,N,INCX,INCY,MODE,ICOMP,ITRUE,ID 20 CONTINUE RETURN * 9001 FORMAT (1H+,39X,4HFAIL) 9011 FORMAT (26H0CASE N INCX INCY MODE ,29X,7HCOMP ,29X,7HTRUE , . 2X,10HDIFFERENCE/1X) 9021 FORMAT (1X,I4,I3,3I5,2I36,I12) 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 C CHANGED BY R. J. HANSON, 850923 FOR ANSI 77 FORTRAN. CHARACTER*6 L(38) C DATA L(1)/' SDOT'/ DATA L(2)/' DSDOT'/ DATA L(3)/'SDSDOT'/ DATA L(4)/' DDOT'/ DATA L(5)/'DQDOTI'/ DATA L(6)/'DQDOTA'/ DATA L(7)/' CDOTC'/ DATA L(8)/' CDOTU'/ DATA L(9)/' SAXPY'/ DATA L(10)/' DAXPY'/ DATA L(11)/' CAXPY'/ DATA L(12)/' SROTG'/ DATA L(13)/' DROTG'/ DATA L(14)/' SROT'/ DATA L(15)/' DROT'/ DATA L(16)/'SROTMG'/ DATA L(17)/'DROTMG'/ DATA L(18)/' SROTM'/ DATA L(19)/' DROTM'/ DATA L(20)/' SCOPY'/ DATA L(21)/' DCOPY'/ DATA L(22)/' CCOPY'/ DATA L(23)/' SSWAP'/ DATA L(24)/' DSWAP'/ DATA L(25)/' CSWAP'/ DATA L(26)/' SNRM2'/ DATA L(27)/' DNRM2'/ DATA L(28)/'SCNRM2'/ DATA L(29)/' SASUM'/ DATA L(30)/' DASUM'/ DATA L(31)/'SCASUM'/ DATA L(32)/' SSCAL'/ DATA L(33)/' DSCAL'/ DATA L(34)/' CSCAL'/ DATA L(35)/'CSSCAL'/ DATA L(36)/'ISAMAX'/ DATA L(37)/'IDAMAX'/ DATA L(38)/'ICAMAX'/ C C CHANGED BY R. J. HANSON, 850923 FOR ANSI 77 FORTRAN. WRITE (NPRINT,9001) ICASE, L(ICASE) RETURN C C CHANGED BY R. J. HANSON, 850923 FOR ANSI 77 FORTRAN. 9001 FORMAT (23H0TEST OF SUBPROGRAM NO.,I3,2X,A,3H...) 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,.7D0,.2D0,.6D0,4.2D0,0.D0,0.D0,0.D0, . 0.D0,4.D0,-1.D0,2.D0,4.D0,6.D-10,2.D-2,1.D5,10.D0,4.D10, . 2.D-2,1.D-5,10.D0,2.D-10,4.D-2,1.D5,10.D0,2.D10,4.D-2,1.D-5, . 10.D0,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,0.D0, . 0.D0,4.5D0,4.2D0,1.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,-2.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,4.D0,-1.D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,15.D-3,0.D0,10.D0,-1.D0,0.D0,-1.D-4, . 0.D0,1.D0,0.D0,0.D0,6144.D-5,10.D0,-1.D0,4096.D0,-1.D6,0.D0, . 1.D0,0.D0,0.D0,15.D0,10.D0,-1.D0,5.D-5,0.D0,1.D0,0.D0,0.D0, . 0.D0,15.D0,10.D0,-1.D0,5.D5,-4096.D0,1.D0,4096.D-6,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 80 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 (10,20,100,100,30,60),JUMP C 12. SROTG 10 IF (K.GT.8) GO TO 90 SA = REAL(DA1(K)) SB = REAL(DB1(K)) CALL SROTG(SA,SB,SC,SS) CALL STEST1(SA,REAL(DATRUE(K)),REAL(DATRUE(K)),SFAC) CALL STEST1(SB,REAL(DBTRUE(K)),REAL(DBTRUE(K)),SFAC) CALL STEST1(SC,REAL(DC1(K)),REAL(DC1(K)),SFAC) CALL STEST1(SS,REAL(DS1(K)),REAL(DS1(K)),SFAC) GO TO 80 C 13. DROTG 20 IF (K.GT.8) GO TO 90 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 80 C 16. SROTMG 30 CONTINUE DO 40 I = 1,4 STEMP(I) = REAL(DAB(I,K)) STEMP(I+4) = ZERO 40 CONTINUE STEMP(9) = ZERO CALL SROTMG(STEMP(1),STEMP(2),STEMP(3),STEMP(4),STEMP(5)) C DO 50 I = 1,9 STRUE(I) = REAL(DTRUE(I,K)) 50 CONTINUE CALL STEST(9,STEMP,STRUE,STRUE,SFAC) GO TO 80 C 17. DROTMG 60 CONTINUE DO 70 I = 1,4 DTEMP(I) = DAB(I,K) DTEMP(I+4) = DZERO 70 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) 80 CONTINUE 90 RETURN C THE FOLLOWING STOP SHOULD NEVER BE REACHED. 100 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,.3D0,3.D0,3.D0, . 3.D0,3.D0,3.D0,3.D0,3.D0,.3D0,-.4D0,4.D0,4.D0,4.D0,4.D0,4.D0, . 4.D0,.2D0,-.6D0,.3D0,5.D0,5.D0,5.D0,5.D0,5.D0,.1D0,-.3D0, . .5D0,-.1D0,6.D0,6.D0,6.D0,6.D0,.1D0,8.D0,8.D0,8.D0,8.D0,8.D0, . 8.D0,8.D0,.3D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,.3D0,2.D0, . -.4D0,2.D0,2.D0,2.D0,2.D0,2.D0,.2D0,3.D0,-.6D0,5.D0,.3D0, . 2.D0,2.D0,2.D0,.1D0,4.D0,-.3D0,6.D0,-.5D0,7.D0,-.1D0,3.D0/ C COMPLEX TEST VECTORS DATA CV/ (.1,.1), (1.,2.), (1.,2.), (1.,2.), (1.,2.), (1.,2.), . (1.,2.), (1.,2.), (.3,-.4), (3.,4.), (3.,4.), (3.,4.), . (3.,4.), (3.,4.), (3.,4.), (3.,4.), (.1,-.3), (.5,-.1), . (5.,6.), (5.,6.), (5.,6.), (5.,6.), (5.,6.), (5.,6.), . (.1,.1), (-.6,.1), (.1,-.3), (7.,8.), (7.,8.), (7.,8.), . (7.,8.), (7.,8.), (.3,.1), (.1,.4), (.4,.1), (.1,.2), . (2.,3.), (2.,3.), (2.,3.), (2.,3.), (.1,.1), (4.,5.), . (4.,5.), (4.,5.), (4.,5.), (4.,5.), (4.,5.), (4.,5.), . (.3,-.4), (6.,7.), (6.,7.), (6.,7.), (6.,7.), (6.,7.), . (6.,7.), (6.,7.), (.1,-.3), (8.,9.), (.5,-.1), (2.,5.), . (2.,5.), (2.,5.), (2.,5.), (2.,5.), (.1,.1), (3.,6.), . (-.6,.1), (4.,7.), (.1,-.3), (7.,2.), (7.,2.), (7.,2.), . (.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,.09D0,3.D0, . 3.D0,3.D0,3.D0,3.D0,3.D0,3.D0,.09D0,-.12D0,4.D0,4.D0,4.D0, . 4.D0,4.D0,4.D0,.06D0,-.18D0,.09D0,5.D0,5.D0,5.D0,5.D0,5.D0, . .03D0,-.09D0,.15D0,-.03D0,6.D0,6.D0,6.D0,6.D0,.10D0,8.D0, . 8.D0,8.D0,8.D0,8.D0,8.D0,8.D0,.09D0,9.D0,9.D0,9.D0,9.D0,9.D0, . 9.D0,9.D0,.09D0,2.D0,-.12D0,2.D0,2.D0,2.D0,2.D0,2.D0,.06D0, . 3.D0,-.18D0,5.D0,.09D0,2.D0,2.D0,2.D0,.03D0,4.D0,-.09D0,6.D0, . -.15D0,7.D0,-.03D0,3.D0/ C DATA CTRUE5/ (.1,.1), (1.,2.), (1.,2.), (1.,2.), (1.,2.), (1.,2.), . (1.,2.), (1.,2.), (-.16,-.37), (3.,4.), (3.,4.), (3.,4.), . (3.,4.), (3.,4.), (3.,4.), (3.,4.), (-.17,-.19), (.13,-.39), . (5.,6.), (5.,6.), (5.,6.), (5.,6.), (5.,6.), (5.,6.), . (.11,-.03), (-.17,.46), (-.17,-.19), (7.,8.), (7.,8.), . (7.,8.), (7.,8.), (7.,8.), (.19,-.17), (.32,.09), (.23,-.24), . (.18,.01), (2.,3.), (2.,3.), (2.,3.), (2.,3.), (.1,.1), . (4.,5.), (4.,5.), (4.,5.), (4.,5.), (4.,5.), (4.,5.), . (4.,5.), (-.16,-.37), (6.,7.), (6.,7.), (6.,7.), (6.,7.), . (6.,7.), (6.,7.), (6.,7.), (-.17,-.19), (8.,9.), (.13,-.39), . (2.,5.), (2.,5.), (2.,5.), (2.,5.), (2.,5.), (.11,-.03), . (3.,6.), (-.17,.46), (4.,7.), (-.17,-.19), (7.,2.), (7.,2.), . (7.,2.), (.19,-.17), (5.,8.), (.32,.09), (6.,9.), . (.23,-.24), (8.,3.), (.18,.01), (9.,4.)/ C DATA CTRUE6/ (.1,.1), (1.,2.), (1.,2.), (1.,2.), (1.,2.), (1.,2.), . (1.,2.), (1.,2.), (.09,-.12), (3.,4.), (3.,4.), (3.,4.), . (3.,4.), (3.,4.), (3.,4.), (3.,4.), (.03,-.09), (.15,-.03), . (5.,6.), (5.,6.), (5.,6.), (5.,6.), (5.,6.), (5.,6.), . (.03,.03), (-.18,.03), (.03,-.09), (7.,8.), (7.,8.), (7.,8.), . (7.,8.), (7.,8.), (.09,.03), (.03,.12), (.12,.03), . (.03,.06), (2.,3.), (2.,3.), (2.,3.), (2.,3.), (.1,.1), . (4.,5.), (4.,5.), (4.,5.), (4.,5.), (4.,5.), (4.,5.), . (4.,5.), (.09,-.12), (6.,7.), (6.,7.), (6.,7.), (6.,7.), . (6.,7.), (6.,7.), (6.,7.), (.03,-.09), (8.,9.), (.15,-.03), . (2.,5.), (2.,5.), (2.,5.), (2.,5.), (2.,5.), (.03,.03), . (3.,6.), (-.18,.03), (4.,7.), (.03,-.09), (7.,2.), (7.,2.), . (7.,2.), (.09,.03), (5.,8.), (.03,.12), (6.,9.), (.12,.03), . (8.,3.), (.03,.06), (9.,4.)/ C C DATA ITRUE2/0,1,2,2,3/ DATA ITRUE3/0,1,2,2,2/ C JUMP = ICASE - 25 DO 170 INCX = 1,2 DO 160 NP1 = 1,5 N = NP1 - 1 LEN = 2*MAX0(N,1) C SET VECTOR ARGUMENTS. DO 10 I = 1,LEN SX(I) = REAL(DV(I,NP1,INCX)) DX(I) = DV(I,NP1,INCX) CX(I) = CV(I,NP1,INCX) 10 CONTINUE C C BRANCH TO INVOKE SUBPROGRAM TO BE TESTED. C GO TO (20,30,40,50,60,70,80,100, . 110,120,130,140,150),JUMP C 26. SNRM2 20 STEMP = REAL(DTRUE1(NP1)) CALL STEST1(SNRM2(N,SX,INCX),STEMP,STEMP,SFAC) GO TO 160 C 27. DNRM2 30 CALL DTEST1(DNRM2(N,DX,INCX),DTRUE1(NP1),DTRUE1(NP1),DFAC) GO TO 160 C 28. SCNRM2 40 CALL STEST1(SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1),SFAC) GO TO 160 C 29. SASUM 50 STEMP = REAL(DTRUE3(NP1)) CALL STEST1(SASUM(N,SX,INCX),STEMP,STEMP,SFAC) GO TO 160 C 30. DASUM 60 CALL DTEST1(DASUM(N,DX,INCX),DTRUE3(NP1),DTRUE3(NP1),DFAC) GO TO 160 C 31. SCASUM 70 CALL STEST1(SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),SFAC) GO TO 160 C 32. SSCAL 80 CALL SSCAL(N,SA,SX,INCX) DO 90 I = 1,LEN STRUE(I) = REAL(DTRUE5(I,NP1,INCX)) 90 CONTINUE CALL STEST(LEN,SX,STRUE,STRUE,SFAC) GO TO 160 C 33. DSCAL 100 CALL DSCAL(N,DA,DX,INCX) CALL DTEST(LEN,DX,DTRUE5(1,NP1,INCX),DTRUE5(1,NP1,INCX), . DFAC) GO TO 160 C 34. CSCAL 110 CALL CSCAL(N,CA,CX,INCX) CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), . SFAC) GO TO 160 C 35. CSSCAL 120 CALL CSSCAL(N,SA,CX,INCX) CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), . SFAC) GO TO 160 C 36. ISAMAX 130 CALL ITEST1(ISAMAX(N,SX,INCX),ITRUE2(NP1)) GO TO 160 C 37. IDAMAX 140 CALL ITEST1(IDAMAX(N,DX,INCX),ITRUE2(NP1)) GO TO 160 C 38. ICAMAX 150 CALL ITEST1(ICAMAX(N,CX,INCX),ITRUE3(NP1)) C 160 CONTINUE 170 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 C NOTE.. THE PARAMETER SDFAC IS NOT USED HERE. C 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 COMPLEX CDUMMY(1) EQUIVALENCE (SSIZE2,CDUMMY) EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)), . (DT19X(1,1,5),DT19XB(1,1,1)), . (DT19X(1,1,9),DT19XC(1,1,1)), . (DT19X(1,1,13),DT19XD(1,1,1)) EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)), . (DT19Y(1,1,5),DT19YB(1,1,1)), . (DT19Y(1,1,9),DT19YC(1,1,1)), . (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,0.25D0,1.25D0,0.24D0, . 0.2492D0,0.25D0,1.25D0,0.31D0,0.2518D0,0.25D0,1.25D0, . 1.2497D0,0.0007D0,0.D0,2.D0,2.0008D0,-.5004D0,0.D0,2.D0, . -.02D0,-.0016D0,0.D0,2.D0,.12D0,.0036D0,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), (0.,0.), . (-.06,-.90), (-.59,-1.46), (-1.04,-.04), (0.,0.), . (-.06,-.90), (-.83,.59), (.07,-.37), (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), (0.,0.), . (.90,0.06), (1.45,.74), (.20,.90), (0.,0.), (.90,0.06), . (-.55,.23), (.83,-.39), (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,.68D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,.68D0,-.87D0,0.D0,0.D0,0.D0,0.D0,0.D0,.68D0, . -.87D0,.15D0,.94D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,.68D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.35D0,-.9D0, . .48D0,0.D0,0.D0,0.D0,0.D0,.38D0,-.9D0,.57D0,.7D0,-.75D0,.2D0, . .98D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.68D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.35D0,-.72D0,0.D0,0.D0,0.D0,0.D0,0.D0, . .38D0,-.63D0,.15D0,.88D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,.68D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.68D0, . -.9D0,.33D0,0.D0,0.D0,0.D0,0.D0,.68D0,-.9D0,.33D0,.7D0, . -.75D0,.2D0,1.04D0/ C DATA CT8/ (.6,-.6), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (.32,-1.41), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (.32,-1.41), (-1.55,.5), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.32,-1.41), (-1.55,.5), . (.03,-.89), (-.38,-.96), (0.,0.), (0.,0.), (0.,0.), (.6,-.6), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (.32,-1.41), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (-.07,-.89), (-.9,.5), (.42,-1.41), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.78,.06), (-.9,.5), (.06,-.13), . (.1,-.5), (-.77,-.49), (-.5,-.3), (.52,-1.51), (.6,-.6), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (.32,-1.41), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (-.07,-.89), (-1.18,-.31), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.78,.06), (-1.54,.97), . (.03,-.89), (-.18,-1.31), (0.,0.), (0.,0.), (0.,0.), . (.6,-.6), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (.32,-1.41), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (.32,-1.41), (-.9,.5), (.05,-.6), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.32,-1.41), (-.9,.5), (.05,-.6), . (.1,-.5), (-.77,-.49), (-.5,-.3), (.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,.78D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,.78D0,-.46D0,0.D0,0.D0,0.D0,0.D0,0.D0,.78D0, . -.46D0,-.22D0,1.06D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,.78D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.66D0,.1D0, . -.1D0,0.D0,0.D0,0.D0,0.D0,.96D0,.1D0,-.76D0,.8D0,.90D0,-.3D0, . -.02D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.78D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,-.06D0,.1D0,-.1D0,0.D0,0.D0,0.D0,0.D0, . .90D0,.1D0,-.22D0,.8D0,.18D0,-.3D0,-.02D0,.6D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.78D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, . .78D0,.26D0,0.D0,0.D0,0.D0,0.D0,0.D0,.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,.04D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,.04D0,-.78D0,0.D0,0.D0,0.D0,0.D0,0.D0,.04D0, . -.78D0,.54D0,.08D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,.04D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.7D0,-.9D0, . -.12D0,0.D0,0.D0,0.D0,0.D0,.64D0,-.9D0,-.30D0,.7D0,-.18D0, . .2D0,.28D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.04D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,.7D0,-1.08D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,.64D0,-1.26D0,.54D0,.20D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.04D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, . .04D0,-.9D0,.18D0,0.D0,0.D0,0.D0,0.D0,.04D0,-.9D0,.18D0,.7D0, . -.18D0,.2D0,.16D0/ C DATA DT10X/.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,.5D0,-.9D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . -.9D0,.3D0,.7D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.3D0,.1D0,.5D0,0.D0, . 0.D0,0.D0,0.D0,.8D0,.1D0,-.6D0,.8D0,.3D0,-.3D0,.5D0,.6D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,-.9D0,.1D0,.5D0,0.D0,0.D0,0.D0,0.D0,.7D0,.1D0,.3D0,.8D0, . -.9D0,-.3D0,.5D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,.3D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,.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,.6D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,.6D0,.1D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,.1D0, . -.5D0,.8D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, . .6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.5D0,-.9D0,.6D0,0.D0, . 0.D0,0.D0,0.D0,-.4D0,-.9D0,.9D0,.7D0,-.5D0,.2D0,.6D0,.5D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,-.5D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.4D0,.9D0,-.5D0, . .6D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,-.9D0,.1D0,0.D0,0.D0,0.D0, . 0.D0,.6D0,-.9D0,.1D0,.7D0,-.5D0,.2D0,.8D0/ C DATA CT10X/ (.7,-.8), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (.6,-.6), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (.6,-.6), (-.9,.5), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.6,-.6), (-.9,.5), (.7,-.6), . (.1,-.5), (0.,0.), (0.,0.), (0.,0.), (.7,-.8), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (.6,-.6), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (.7,-.6), (-.4,-.7), (.6,-.6), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (.8,-.7), (-.4,-.7), (-.1,-.2), (.2,-.8), (.7,-.6), . (.1,.4), (.6,-.6), (.7,-.8), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.6,-.6), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (-.9,.5), (-.4,-.7), . (.6,-.6), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (.1,-.5), . (-.4,-.7), (.7,-.6), (.2,-.8), (-.9,.5), (.1,.4), (.6,-.6), . (.7,-.8), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (.6,-.6), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (.6,-.6), (.7,-.6), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.6,-.6), (.7,-.6), (-.1,-.2), . (.8,-.7), (0.,0.), (0.,0.), (0.,0.)/ C DATA CT10Y/ (.6,-.6), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (.7,-.8), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (.7,-.8), (-.4,-.7), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.7,-.8), (-.4,-.7), (-.1,-.9), . (.2,-.8), (0.,0.), (0.,0.), (0.,0.), (.6,-.6), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (.7,-.8), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (-.1,-.9), (-.9,.5), (.7,-.8), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (-.6,.6), (-.9,.5), (-.9,-.4), (.1,-.5), (-.1,-.9), . (-.5,-.3), (.7,-.8), (.6,-.6), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.7,-.8), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (-.1,-.9), (.7,-.8), . (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (-.6,.6), . (-.9,-.4), (-.1,-.9), (.7,-.8), (0.,0.), (0.,0.), (0.,0.), . (.6,-.6), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (.7,-.8), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (0.,0.), (.7,-.8), (-.9,.5), (-.4,-.7), (0.,0.), . (0.,0.), (0.,0.), (0.,0.), (.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,.6D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,-.8D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.9D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,3.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . .1D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.8D0,3.8D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,-.9D0,2.8D0,0.D0,0.D0,0.D0,0.D0,0.D0,3.5D0,-.4D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,.1D0,-.5D0,.8D0,0.D0,0.D0,0.D0, . -.8D0,3.8D0,-2.2D0,-1.2D0,0.D0,0.D0,0.D0,-.9D0,2.8D0,-1.4D0, . -1.3D0,0.D0,0.D0,0.D0,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,.6D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,-.8D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.9D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,3.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . .1D0,-.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,.1D0,-3.0D0,0.D0,0.D0, . 0.D0,0.D0,-.3D0,.1D0,-2.0D0,0.D0,0.D0,0.D0,0.D0,3.3D0,.1D0, . -2.0D0,0.D0,0.D0,0.D0,0.D0,.6D0,.1D0,-.5D0,.8D0,.9D0,-.3D0, . -.4D0,-2.0D0,.1D0,1.4D0,.8D0,.6D0,-.3D0,-2.8D0,-1.8D0,.1D0, . 1.3D0,.8D0,0.D0,-.3D0,-1.9D0,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,.6D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,-.8D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.9D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,3.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . .1D0,-.5D0,0.D0,0.D0,0.D0,0.D0,4.8D0,.1D0,-3.0D0,0.D0,0.D0, . 0.D0,0.D0,3.3D0,.1D0,-2.0D0,0.D0,0.D0,0.D0,0.D0,2.1D0,.1D0, . -2.0D0,0.D0,0.D0,0.D0,0.D0,.6D0,.1D0,-.5D0,.8D0,.9D0,-.3D0, . -.4D0,-1.6D0,.1D0,-2.2D0,.8D0,5.4D0,-.3D0,-2.8D0,-1.5D0,.1D0, . -1.4D0,.8D0,3.6D0,-.3D0,-1.9D0,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,.6D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,-.8D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.9D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,3.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.6D0, . .1D0,0.D0,0.D0,0.D0,0.D0,0.D0,-.8D0,-1.0D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,-.9D0,-.8D0,0.D0,0.D0,0.D0,0.D0,0.D0,3.5D0,.8D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,.6D0,.1D0,-.5D0,.8D0,0.D0,0.D0,0.D0, . -.8D0,-1.0D0,1.4D0,-1.6D0,0.D0,0.D0,0.D0,-.9D0,-.8D0,1.3D0, . -1.6D0,0.D0,0.D0,0.D0,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,.5D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,.7D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,1.7D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,-2.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . -.9D0,0.D0,0.D0,0.D0,0.D0,0.D0,.7D0,-4.8D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,1.7D0,-.7D0,0.D0,0.D0,0.D0,0.D0,0.D0,-2.6D0,3.5D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,-.9D0,.3D0,.7D0,0.D0,0.D0,0.D0, . .7D0,-4.8D0,3.0D0,1.1D0,0.D0,0.D0,0.D0,1.7D0,-.7D0,-.7D0, . 2.3D0,0.D0,0.D0,0.D0,-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,.5D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,.7D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,1.7D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,-2.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . -.9D0,.3D0,0.D0,0.D0,0.D0,0.D0,4.0D0,-.9D0,-.3D0,0.D0,0.D0, . 0.D0,0.D0,-.5D0,-.9D0,1.5D0,0.D0,0.D0,0.D0,0.D0,-1.5D0,-.9D0, . -1.8D0,0.D0,0.D0,0.D0,0.D0,.5D0,-.9D0,.3D0,.7D0,-.6D0,.2D0, . .8D0,3.7D0,-.9D0,-1.2D0,.7D0,-1.5D0,.2D0,2.2D0,-.3D0,-.9D0, . 2.1D0,.7D0,-1.6D0,.2D0,2.0D0,-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,.5D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,.7D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,1.7D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,-2.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . -.9D0,0.D0,0.D0,0.D0,0.D0,0.D0,4.0D0,-6.3D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,-.5D0,.3D0,0.D0,0.D0,0.D0,0.D0,0.D0,-1.5D0,3.0D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,-.9D0,.3D0,.7D0,0.D0,0.D0,0.D0, . 3.7D0,-7.2D0,3.0D0,1.7D0,0.D0,0.D0,0.D0,-.3D0,.9D0,-.7D0, . 1.9D0,0.D0,0.D0,0.D0,-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,.5D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0,0.D0,0.D0,0.D0,0.D0,0.D0, . 0.D0,.7D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,1.7D0,0.D0,0.D0,0.D0, . 0.D0,0.D0,0.D0,-2.6D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,.5D0, . -.9D0,.3D0,0.D0,0.D0,0.D0,0.D0,.7D0,-.9D0,1.2D0,0.D0,0.D0, . 0.D0,0.D0,1.7D0,-.9D0,.5D0,0.D0,0.D0,0.D0,0.D0,-2.6D0,-.9D0, . -1.3D0,0.D0,0.D0,0.D0,0.D0,.5D0,-.9D0,.3D0,.7D0,-.6D0,.2D0, . .8D0,.7D0,-.9D0,1.2D0,.7D0,-1.5D0,.2D0,1.6D0,1.7D0,-.9D0, . .5D0,.7D0,-1.6D0,.2D0,2.4D0,-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.,1.17,1.17, . 1.17,1.17,1.17,1.17,1.17,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,1.17D0,1.17D0, . 1.17D0,1.17D0,1.17D0,1.17D0,1.17D0/ C C FOR CAXPY C DATA CSIZE2/ (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), (0.,0.), . (0.,0.), (1.54,1.54), (1.54,1.54), (1.54,1.54), (1.54,1.54), . (1.54,1.54), (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,-1.D0,2.D0,-3.D0,-4.D0,5.D0, . 0.D0,0.D0,2.D0,-3.D0,0.D0,1.D0,5.D0,2.D0,0.D0,-4.D0/ C DO 370 KI = 1,4 INCX = INCXS(KI) INCY = INCYS(KI) MX = IABS(INCX) MY = IABS(INCY) C DO 360 KN = 1,4 N = NS(KN) KSIZE = MIN0(2,KN) LENX = LENS(KN,MX) LENY = LENS(KN,MY) C INITIALIZE ALL ARGUMENT ARRAYS. DO 10 I = 1,7 SX(I) = REAL(DX1(I)) SY(I) = REAL(DY1(I)) DX(I) = DX1(I) DY(I) = DY1(I) CX(I) = CX1(I) CY(I) = CY1(I) 10 CONTINUE C C BRANCH TO SELECT SUBPROGRAM TO BE TESTED. C GO TO (20,30,40,50,60,70,80,90, . 100,120,130,380,380,140,160,380, . 380,180,230,280,300,310,320,340, . 350),ICASE C 1. SDOT 20 CALL STEST1(SDOT(N,SX,INCX,SY,INCY),REAL(DT7(KN,KI)), . SSIZE1(KN),SFAC) GO TO 360 C 2. DSDOT 30 CALL STEST1(REAL(DSDOT(N,SX,INCX,SY,INCY)),REAL(DT7(KN,KI)), . SSIZE1(KN),SFAC) GO TO 360 C 3. SDSDOT 40 CALL STEST1(SDSDOT(N,SB,SX,INCX,SY,INCY),ST7B(KN,KI), . SSIZE3(KN),SFAC) GO TO 360 C 4. DDOT 50 CALL DTEST1(DDOT(N,DX,INCX,DY,INCY),DT7(KN,KI),DSIZE1(KN), . DFAC) GO TO 360 C 5. DQDOTI 60 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 360 C 6. DQDOTA 70 CONTINUE C TO TEST DQDOTA WE ACTUALLY TEST BOTH DQDOTI AND DQDOTA. C THE OUTPUT VALUE OF QC FROM DQDOTI WILL BE USED AS INPUT C TO DQDOTA. QC 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 360 C 7. CDOTC 80 CDOT(1) = CDOTC(N,CX,INCX,CY,INCY) CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) GO TO 360 C 8. CDOTU 90 CDOT(1) = CDOTU(N,CX,INCX,CY,INCY) CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) GO TO 360 C 9. SAXPY 100 CALL SAXPY(N,SA,SX,INCX,SY,INCY) DO 110 J = 1,LENY STY(J) = REAL(DT8(J,KN,KI)) 110 CONTINUE CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) GO TO 360 C 10. DAXPY 120 CALL DAXPY(N,DA,DX,INCX,DY,INCY) CALL DTEST(LENY,DY,DT8(1,KN,KI),DSIZE2(1,KSIZE),DFAC) GO TO 360 C 11. CAXPY 130 CALL CAXPY(N,CA,CX,INCX,CY,INCY) CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) GO TO 360 C 14. SROT 140 CONTINUE DO 150 I = 1,7 SX(I) = REAL(DX1(I)) SY(I) = REAL(DY1(I)) STX(I) = REAL(DT9X(I,KN,KI)) STY(I) = REAL(DT9Y(I,KN,KI)) 150 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 360 C 15. DROT 160 CONTINUE DO 170 I = 1,7 DX(I) = DX1(I) DY(I) = DY1(I) 170 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 360 C 18. SROTM 180 KNI = KN + 4* (KI-1) DO 220 KPAR = 1,4 DO 190 I = 1,7 SX(I) = REAL(DX1(I)) SY(I) = REAL(DY1(I)) STX(I) = REAL(DT19X(I,KPAR,KNI)) STY(I) = REAL(DT19Y(I,KPAR,KNI)) 190 CONTINUE C DO 200 I = 1,5 SPARAM(I) = REAL(DPAR(I,KPAR)) 200 CONTINUE C SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, C IF ANY MODE = INT(SPARAM(1)) C DO 210 I = 1,LENX SSIZE(I) = STX(I) 210 CONTINUE 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)) SSIZE(1) = 2.4E0 IF ((KPAR.EQ.3) .AND. (KNI.EQ.8)) 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) 220 CONTINUE GO TO 360 C 19. DROTM 230 KNI = KN + 4* (KI-1) DO 270 KPAR = 1,4 DO 240 I = 1,7 DX(I) = DX1(I) DY(I) = DY1(I) DTX(I) = DT19X(I,KPAR,KNI) DTY(I) = DT19Y(I,KPAR,KNI) 240 CONTINUE C DO 250 I = 1,5 DPARAM(I) = DPAR(I,KPAR) 250 CONTINUE C SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, C IF ANY MODE = INT(DPARAM(1)) C DO 260 I = 1,LENX DSIZE(I) = DTX(I) 260 CONTINUE C SEE REMARK ABOVE ABOUT DT11X(1,2,7) C AND DT11X(5,3,8). IF ((KPAR.EQ.2) .AND. (KNI.EQ.7)) DSIZE(1) = 2.4D0 IF ((KPAR.EQ.3) .AND. (KNI.EQ.8)) 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) 270 CONTINUE GO TO 360 C 20. SCOPY 280 DO 290 I = 1,7 STY(I) = REAL(DT10Y(I,KN,KI)) 290 CONTINUE CALL SCOPY(N,SX,INCX,SY,INCY) CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.) GO TO 360 C 21. DCOPY 300 CALL DCOPY(N,DX,INCX,DY,INCY) CALL DTEST(LENY,DY,DT10Y(1,KN,KI),DSIZE2(1,1),1.D0) GO TO 360 C 22. CCOPY 310 CALL CCOPY(N,CX,INCX,CY,INCY) C THE ARRAY SSIZE2() IS REALLY COMPATIBLE WITH USAGE C IN CTEST() THAT ASSUMES IT IS TYPE COMPLEX. C CALL CTEST(LENY,CY,CT10Y(1,KN,KI),SSIZE2(1,1),1.) CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CDUMMY(1),1.) GO TO 360 C 23. SSWAP 320 CALL SSWAP(N,SX,INCX,SY,INCY) DO 330 I = 1,7 STX(I) = REAL(DT10X(I,KN,KI)) STY(I) = REAL(DT10Y(I,KN,KI)) 330 CONTINUE CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.) CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.) GO TO 360 C 24. DSWAP 340 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 360 C 25. CSWAP 350 CALL CSWAP(N,CX,INCX,CY,INCY) C THE ARRAY SSIZE2() IS REALLY COMPATIBLE WITH USAGE C IN CTEST() THAT ASSUMES IT IS TYPE COMPLEX. C CALL CTEST(LENX,CX,CT10X(1,KN,KI),SSIZE2(1,1),1.) C CALL CTEST(LENY,CY,CT10Y(1,KN,KI),SSIZE2(1,1),1.) CALL CTEST(LENX,CX,CT10X(1,KN,KI),CDUMMY(1),1.) CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CDUMMY(1),1.) C C C 360 CONTINUE 370 CONTINUE RETURN C THE FOLLOWING STOP SHOULD NEVER BE REACHED. 380 STOP END C$SROTMG.FOR 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/ IF(.NOT. SD1 .LT. 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 SFLAG=-ONE 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 C$DROTMG.FOR 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/ IF(.NOT. DD1 .LT. 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 DFLAG=-ONE 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 -$MAKETSTL.BAT REM This file compiles the Fortran programs for use with Lahey F77 Fortran. F77L TBLAS.FOR F77L SROTMG.FOR F77L DROTMG.FOR REM This batch file assembles the BLAS that are compatible with REM the Lahey F77 Fortran Compiler. COPY LAHEY.ENV BLAS.ENV MASM SDOT; MASM DSDOT; MASM SDSDOT; MASM DDOT; MASM DQDOT; MASM CDOTC; MASM CDOTU; MASM SAXPY; MASM DAXPY; MASM CAXPY; MASM SROTG; MASM DROTG; MASM SROT; MASM DROT; MASM SROTM; MASM DROTM; MASM SCOPY; MASM DCOPY; MASM SSWAP; MASM DSWAP; MASM SNRM2; MASM DNRM2; MASM SCNRM2; MASM SASUM; MASM DASUM; MASM SCASUM; MASM SSCAL; MASM DSCAL; MASM CSCAL; MASM CSSCAL; MASM ISAMAX; MASM IDAMAX; MASM ICAMAX; MASM SBLAAI; MASM DBLAAI; REM This batch file build the library of BLAS compatible with REM the Lahey F77 Fortran Compiler. Library is called BLASL. LIB BLASL+SDOT+DSDOT+SDSDOT+DDOT+DQDOT+CDOTU+CDOTC,CON,BLASL LIB BLASL+SAXPY+DAXPY+CAXPY,CON,BLASL LIB BLASL+SROTG+DROTG+SROT+DROT+SROTM+DROTM,CON,BLASL LIB BLASL+SCOPY+DCOPY+SSWAP+DSWAP,CON,BLASL LIB BLASL+SNRM2+DNRM2+SCNRM2+SASUM+DASUM+SCASUM,CON,BLASL LIB BLASL+SSCAL+DSCAL+CSCAL+CSSCAL,CON,BLASL LIB BLASL+ISAMAX+IDAMAX+ICAMAX+SBLAAI+DBLAAI,CON,BLASL REM Put the Fortran versions of SROTMG, DROTMG into library. LIB BLASL+SROTMG+DROTMG,CON,BLASL LINK TBLAS,TBLASL,, F77L BLASL TBLASL -$MAKETSTP.BAT REM This file compiles the Fortran programs for use with Prof. Fortran. PROFORT TBLAS PROFORT SROTMG PROFORT DROTMG REM This batch file assembles the BLAS that are compatible with REM the IBM Professional Fortran Compiler. COPY IBMPROF.ENV BLAS.ENV MASM SDOT; MASM DSDOT; MASM SDSDOT; MASM DDOT; MASM DQDOT; MASM CDOTC; MASM CDOTU; MASM SAXPY; MASM DAXPY; MASM CAXPY; MASM SROTG; MASM DROTG; MASM SROT; MASM DROT; MASM SROTM; MASM DROTM; MASM SCOPY; MASM DCOPY; MASM SSWAP; MASM DSWAP; MASM SNRM2; MASM DNRM2; MASM SCNRM2; MASM SASUM; MASM DASUM; MASM SCASUM; MASM SSCAL; MASM DSCAL; MASM CSCAL; MASM CSSCAL; MASM ISAMAX; MASM IDAMAX; MASM ICAMAX; MASM SBLAAI; MASM DBLAAI; REM This batch file build the library of BLAS compatible with REM the IBM Professional Fortran Compiler. Library is called BLASP. LIB BLASP+SDOT+DSDOT+SDSDOT+DDOT+DQDOT+CDOTU+CDOTC,CON,BLASP LIB BLASP+SAXPY+DAXPY+CAXPY,CON,BLASP LIB BLASP+SROTG+DROTG+SROT+DROT+SROTM+DROTM,CON,BLASP LIB BLASP+SCOPY+DCOPY+SSWAP+DSWAP,CON,BLASP LIB BLASP+SNRM2+DNRM2+SCNRM2+SASUM+DASUM+SCASUM,CON,BLASP LIB BLASP+SSCAL+DSCAL+CSCAL+CSSCAL,CON,BLASP LIB BLASP+ISAMAX+IDAMAX+ICAMAX+SBLAAI+DBLAAI,CON,BLASP REM Put the Fortran versions of SROTMG, DROTMG into library. LIB BLASP+SROTMG+DROTMG,CON,BLASP LINK TBLAS,TBLASP,, PROFORT BLASP TBLASP -$MAKETSTM.BAT REM This file compiles the Fortran programs for use with Microsoft Fortran. FOR1 TBLAS; PAS2 FOR1 SROTMG; PAS2 FOR1 DROTMG; PAS2 REM This batch file assembles the BLAS that are compatible with REM the Microsoft Fortran Compiler. COPY MSOFT.ENV BLAS.ENV MASM SDOT; MASM DSDOT; MASM SDSDOT; MASM DDOT; MASM DQDOT; MASM CDOTC; MASM CDOTU; MASM SAXPY; MASM DAXPY; MASM CAXPY; MASM SROTG; MASM DROTG; MASM SROT; MASM DROT; MASM SROTM; MASM DROTM; MASM SCOPY; MASM DCOPY; MASM SSWAP; MASM DSWAP; MASM SNRM2; MASM DNRM2; MASM SCNRM2; MASM SASUM; MASM DASUM; MASM SCASUM; MASM SSCAL; MASM DSCAL; MASM CSCAL; MASM CSSCAL; MASM ISAMAX; MASM IDAMAX; MASM ICAMAX; MASM SBLAAI; MASM DBLAAI; REM This batch file build the library of BLAS compatible with REM the Microsoft Fortran Compiler. Library is called BLASM. LIB BLASM+SDOT+DSDOT+SDSDOT+DDOT+DQDOT+CDOTU+CDOTC,CON,BLASM LIB BLASM+SAXPY+DAXPY+CAXPY,CON,BLASM LIB BLASM+SROTG+DROTG+SROT+DROT+SROTM+DROTM,CON,BLASM LIB BLASM+SCOPY+DCOPY+SSWAP+DSWAP,CON,BLASM LIB BLASM+SNRM2+DNRM2+SCNRM2+SASUM+DASUM+SCASUM,CON,BLASM LIB BLASM+SSCAL+DSCAL+CSCAL+CSSCAL,CON,BLASM LIB BLASM+ISAMAX+IDAMAX+ICAMAX+SBLAAI+DBLAAI,CON,BLASM REM Put the Fortran versions of SROTMG, DROTMG into library. LIB BLASM+SROTMG+DROTMG,CON,BLASM LINK TBLAS,TBLASM,, FORTRAN BLASM TBLASM -$DATALINE 11111111111111111111111111111111111111 ;$SDOT.ASM ; Use as: SW = SDOT(N, SX, INCX, SY, INCY) ; Gives SW = inner product of SX and SY. ; INCLUDE BLAS.ENV START SDOT,'S','S',4 FLDZ; Set dot product to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SDOTX; <=0 => return 0 result GET2ARGS 2 MLOOP: FLD DWORD PTR [SI] FMUL DWORD PTR ES:[DI] INCX FADDP ST(1),ST INCY LOOP MLOOP SDOTX: ENDIT END ;$DSDOT.ASM ; Use as: DW = DSDOT(N, SX, INCX, SY, INCY) ; Gives DW = inner product of SX and SY. ; INCLUDE BLAS.ENV START DSDOT,'D','S',4 FLDZ; Set dot product to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DSDOTX; <=0 => return 0 result GET2ARGS 2 MLOOP: FLD DWORD PTR [SI] FMUL DWORD PTR ES:[DI] INCX FADDP ST(1),ST INCY LOOP MLOOP DSDOTX: ENDIT END ;$SDSDOT.ASM ; Use as: SW = SDSDOT(N, SB, SX, INCX, SY, INCY) ; Gives SW = SB + inner product of SX and SY. ; INCLUDE BLAS.ENV START SDSDOT,'S','S',4 GETARG DS,SI,2 FLD DWORD PTR[SI]; Set to SB to begin with GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SDSDOTX; <=0 => return 0 result GET2ARGS 3 MLOOP: FLD DWORD PTR [SI] FMUL DWORD PTR ES:[DI] INCX FADDP ST(1),ST INCY LOOP MLOOP SDSDOTX: ENDIT END ;$DDOT.ASM ; Use as: DW = DDOT(N, DX, INCX, DY, INCY) ; Gives DW = inner product of DX and DY. ; INCLUDE BLAS.ENV START DDOT,'D','D',4 FLDZ; Set dot product to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DDOTX; <=0 => return 0 result GET2ARGS 2 MLOOP: FLD QWORD PTR [SI] FMUL QWORD PTR ES:[DI] INCX FADDP ST(1),ST INCY LOOP MLOOP DDOTX: ENDIT END ;$DQDOT.ASM ;First entry: ; Use as: SW = DQDOTI(N, DB, QC, DX, INCX, DY, INCY) ; Gives SW, QC = DB + inner product of DX and DY. ;IT IS IMPORTANT TO NOTE THAT QC IS TYPE TEMP REAL. ;THIS MEANS THAT IN TERMS OF FORTRAN 77, ANY OF THE ;FOLLOWING TYPE STATEMENTS FOR QC WOULD DO: ; INTEGER QC(3) ;{OR}REAL QC(3) ;{OR}DOUBLE PRECISION QC(2) ; ;Second entry: ; Use as: SW = DQDOTA(N, DB, QC, DX, INCX, DY, INCY) ; Gives SW, QC = DB + inner product of DX and DY + QC. ;IT IS IMPORTANT TO NOTE THAT QC IS TYPE TEMP REAL. ;THIS MEANS THAT IN TERMS OF FORTRAN 77, ANY OF THE ;FOLLOWING TYPE STATEMENTS FOR QC WOULD DO: ; INTEGER QC(3) ;{OR}REAL QC(3) ;{OR}DOUBLE PRECISION QC(2) ; INCLUDE BLAS.ENV START DQDOTA,'Q','D',4 GETARG DS,SI,3 FLD TBYTE PTR[SI]; Get QC. ADDDB: GETARG DS,SI,2 FLD QWORD PTR[SI]; Add in DB. FADDP ST(1),ST JMP GODQDOT ; Secondary entry point for DQDOTI START2 DQDOTI,4 FLDZ; Load 0. instead of QC. JMP ADDDB GODQDOT: GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DQDOTAX; <=0 => return DB as result GET2ARGS 4 MLOOP: FLD QWORD PTR[SI]; [DQDOT DX] FMUL QWORD PTR ES:[DI]; [DQDOT DX*DY] INCX FADDP ST(1),ST; [(UPDATED)_DQDOT] INCY LOOP MLOOP DQDOTAX: ENDIT END ;$CDOTC.ASM ; Use as: CW = CDOTC(N, CX, INCX, CY, INCY) ;COMPUTE THE DOT PRODUCT OF TWO COMPLEX VECTORS CX(*), CY(*) ;DEFINED AS CDOTC = (SR,SI) = SUM OF CONJG(CX)*CY COMPONENTS. ;COMPONENTS OF CX = (A+I*B), CY=(W+I*Z). ; INCLUDE BLAS.ENV START CDOTC,'C','C',4 ;SET INITIAL VALUE OF CDOTC = (0,0). FLDZ FLD ST GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE CDOTCX; <=0 => return 0 result GET2ARGS 2 MLOOP: FLD DWORD PTR[SI]; [SR SI A] FLD DWORD PTR ES:[DI+4]; [SR SI A Z] FLD DWORD PTR[SI+4]; [SR SI A Z B] FLD DWORD PTR ES:[DI]; [SR SI A Z B W] FLD ST; [SR SI A Z B W W] FMUL ST,ST(4); [SR SI A Z B W W*A] FADDP ST(6),ST; [SR+W*A SI A Z B W] FMUL ST,ST(1); [SR SI A Z B W*B] FSUBP ST(4),ST; [SR SI-W*B A Z B] FLD ST(1); [SR SI A Z B Z] FMULP ST(1),ST; [SR SI A Z Z*B] INCX FADDP ST(4),ST; [SR+Z*B SI A Z] FMULP ST(1),ST; [SR SI Z*A] INCY FADDP ST(1),ST; [SR SI+Z*A] LOOP MLOOP CDOTCX: ENDIT END ;$CDOTU.ASM ; Use as: CW = CDOTU(N, CX, INCX, CY, INCY) ;COMPUTE THE DOT PRODUCT OF TWO COMPLEX VECTORS CX(*), CY(*) ;DEFINED AS CW = (SR,SI) = SUM OF CX*CY COMPONENTS. ;COMPONENTS OF CX = (A+I*B), CY=(W+I*Z). ; INCLUDE BLAS.ENV START CDOTU,'C','C',4 ;SET INITIAL VALUE OF CDOTU = (0,0). FLDZ FLD ST GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE CDOTUX; <=0 => return 0 result GET2ARGS 2 MLOOP: FLD DWORD PTR[SI]; [SR SI A] FLD DWORD PTR ES:[DI+4]; [SR SI A Z] FLD DWORD PTR[SI+4]; [SR SI A Z B] FLD DWORD PTR ES:[DI]; [SR SI A Z B W] FLD ST; [SR SI A Z B W W] FMUL ST,ST(4); [SR SI A Z B W W*A] FADDP ST(6),ST; [SR+W*A SI A Z B W] FMUL ST,ST(1); [SR SI A Z B W*B] FADDP ST(4),ST; [SR SI+W*B A Z B] FLD ST(1); [SR SI A Z B Z] FMULP ST(1),ST; [SR SI A Z Z*B] INCX FSUBP ST(4),ST; [SR-Z*B SI A Z] FMULP ST(1),ST; [SR SI Z*A] INCY FADDP ST(1),ST; [SR SI+Z*A] LOOP MLOOP CDOTUX: ENDIT END ;$SAXPY.ASM ; Use as: CALL SAXPY(N, SA, SX, INCX, SY, INCY) ; Gives SY = SA * SX + SY ; INCLUDE BLAS.ENV START SAXPY,'X','S',6 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SAXPYX; <=0 => return immediately GETARG DS,SI,2 FLD DWORD PTR[SI] FTST GET2ARGS 3,'YB' FLAGS FLGS[BP] JZ SAXPYX; = 0 => nothing to do MLOOP: FLD DWORD PTR [SI] FMUL ST,ST(1) INCY FADD DWORD PTR ES:[DI] INCX FSTP DWORD PTR ES:[DI] LOOP MLOOP SAXPYX: ENDIT END ;$DAXPY.ASM ; Use as: CALL DAXPY(N, DA, DX, INCX, DY, INCY) ; Gives DY = DA * DX + DY ; INCLUDE BLAS.ENV START DAXPY,'X','D',6 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DAXPYX; <=0 => return immediately GETARG DS,SI,2 ; [DA] FLD QWORD PTR[SI] FTST GET2ARGS 3,'YB'; FLAGS FLGS[BP] JZ DAXPYX; = 0 => nothing to do MLOOP: FLD QWORD PTR[SI]; [DA DX] FMUL ST,ST(1); [DA DA*DX] INCY FADD QWORD PTR ES:[DI]; [DA DA*DX+DY] INCX FSTP QWORD PTR ES:[DI]; UPDATE DY LOOP MLOOP DAXPYX: ENDIT END ;$CAXPY.ASM ; Use as: CALL CAXPY(N, CA, CX, INCX, CY, INCY) ; Gives CY = CA * CX + CY, CA=E+I*F, CX=A+I*B, CY=W+I*Z. ; INCLUDE BLAS.ENV START CAXPY,'X','C',6 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JG CAXPTST; <=0 => return immediately JMP FAR PTR CAXPYX CAXPTST: GETARG DS,SI,2 ; [E F], CA=E+I*F FLD DWORD PTR[SI] FLD DWORD PTR[SI+4] FTST FLAGS FLGS[BP] JNZ GO FXCH ST(1) FTST FLAGS FLGS[BP] FXCH ST(1) JZ CAXPYX; = 0 => nothing to do GO: GET2ARGS 3,'YB'; MLOOP: FLD DWORD PTR [SI] FLD DWORD PTR [SI+4]; [E F A B] FLD ST; [E F A B B] FMUL ST,ST(3); [E F A B B*F] INCY FLD ST(2); [E F A B B*F A] FMUL ST,ST(5); [E F A B B*F A*E] FSUBRP ST(1),ST; [E F A B A*E-F*B] FADD DWORD PTR ES:[DI]; [E F A B A*E-F*B + W] FSTP DWORD PTR ES:[DI]; [E F A B] FMUL ST,ST(3); [E F A B*E] INCX FXCH ST(1); [E F B*E A] FMUL ST,ST(2); [E F B*E A*F] FADDP ST(1),ST; [E F B*E+A*F] FADD DWORD PTR ES:[DI+4]; [E F B*E+A*F + Z] FSTP DWORD PTR ES:[DI+4]; [E F] LOOP MLOOP CAXPYX: ENDIT END ;$SROTG.ASM ; CONSTRUCT THE GIVENS TRANSFORMATION ; ; ( SC SS ) ; G = ( ) , SC**2 + SS**2 = 1 , ; (-SS SC ) ; ; WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (SA,SB)**T . ; USE AS: CALL SROTG (SA,SB,SC,SS). ; ; THE QUANTITY R = (+/-)SQRT(SA**2 + SB**2) OVERWRITES SA IN ; STORAGE. THE VALUE OF SB IS OVERWRITTEN BY A VALUE Z WHICH ; ALLOWS SC AND SS TO BE RECOVERED BY THE FOLLOWING ALGORITHM: ; IF Z=1 SET SC=0. AND SS=1. ; IF ABS(Z) .LT. 1 SET SC=SQRT(1-Z**2) AND SS=Z ; IF ABS(Z) .GT. 1 SET SC=1/Z AND SS=SQRT(1-SC**2) ; ; NORMALLY, THE SUBPROGRAM SROT(N,SX,INCX,SY,INCY,SC,SS) WILL ; NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. INCLUDE BLAS.ENV START SROTG,'X','S',2 GETARG DS,SI,1; LOAD THE VALUE OF SA. FLD DWORD PTR [SI] FLD ST; DUPLICATE THE VALUE OF SA. FABS; COMPUTE ABS(A). GETARG DS,SI,2; LOAD THE VALUE OF B. FLD DWORD PTR [SI] FLD ST; DUPLICATE THE VALUE OF B. FABS; COMPUTE ABS(B). NOW HAVE STACK = [A |A| B |B|] FCOM ST(2); COMPARE |A| WITH |B|. FLAGS FLGS[BP] JC A_GT_B JMP B_GE_A ; COMPUTE RESULT TO OVERWRITE SA. ; NOW HAVE |A| .GT. |B|. A_GT_B: FDIV ST,ST(2); NOW HAVE STACK = [A |A| B |B|/|A|] FMUL ST,ST; WITH V=(B/A)**2, NOW HAVE STACK = [A |A| B V] FLD1; NOW HAVE STACK = [A |A| B V 1.] FADDP ST(1),ST; NOW HAVE STACK = [A |A| B 1.+V] FSQRT FMUL ST,ST(3); NOW HAVE STACK = [A |A| B A*SQRT(1.+V)] JMP STORE_R B_GE_A:; HERE THE RELATION |A| .LE. |B| HOLDS. ; NOW HAVE STACK = [A |A| B |B|] FTST; IF A=B=0, DO A SPECIAL SETTING OF C AND S. FLAGS FLGS[BP] JZ BOTH_ZERO ; NOW HAVE |A| .LE. |B|, BUT B .NE. 0. FDIVR ST,ST(2); NOW HAVE STACK = [A |A| B |A|/|B|] FMUL ST,ST; WITH V=(A/B)**2, NOW HAVE STACK = [A |A| B V] FLD1; NOW HAVE STACK = [A |A| B V 1.] FADDP ST(1),ST; NOW HAVE STACK = [A |A| B 1.+V] FSQRT FMUL ST,ST(1); NOW HAVE STACK = [A |A| B B*SQRT(1.+V)] STORE_R: GETARG DS,SI,1 ; OVERWRITE SA WITH VALUE R DEFINED ABOVE IN COMMENTS ; THE VALUE R COMPUTED HERE IS .NE. 0. FST DWORD PTR [SI] FDIV ST(3),ST FDIV ST(1),ST; NOW HAVE STACK = [C ? S R] FXCH ST(3); NOW HAVE STACK = [R ? S C] GETARG DS,SI,3 FST DWORD PTR [SI]; STORE SC AND SS. FXCH ST(1) GETARG DS,SI,4 FST DWORD PTR [SI] FLD ST; NOW HAVE STACK = [R ? C S S] FABS; NOW HAVE STACK = [R ? C S |S|] FCOM ST(2) FLAGS FLGS[BP]; IF JUMP OCCURS, C .GT. ABS(S). JC STORE_S FXCH ST(2); NOW HAVE STACK = [R ? |S| S C] FTST FLAGS FLGS[BP]; IF JUMP OCCURS, C=0. JZ STORE_S FLD1; NOW HAVE STACK = [R ? |S| S C 1.] FDIVRP ST(1),ST; NOW HAVE STACK = [R ? |S| S 1./C] GETARG DS,SI,2 FST DWORD PTR [SI] JMP DONE STORE_S: FXCH ST(1); NOW HAVE STACK = [R ? ? ? S] GETARG DS,SI,2 FST DWORD PTR [SI] JMP DONE BOTH_ZERO: FLD1 GETARG DS,SI,3 FSTP DWORD PTR [SI] FLDZ GETARG DS,SI,4 FSTP DWORD PTR [SI] DONE: ENDIT END ;$DROTG.ASM ; CONSTRUCT THE GIVENS TRANSFORMATION ; ; ( DC DS ) ; G = ( ) , DC**2 + DS**2 = 1 , ; (-DS DC ) ; ; WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . ; USE AS: CALL DROTG (DA,DB,DC,DS). ; ; THE QUANTITY R = (+/-)SQRT(DA**2 + DB**2) OVERWRITES DA IN ; STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH ; ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM: ; IF Z=1 SET DC=0. AND DS=1. ; IF ABS(Z) .LT. 1 SET DC=SQRT(1-Z**2) AND DS=Z ; IF ABS(Z) .GT. 1 SET DC=1/Z AND DS=SQRT(1-DC**2) ; ; NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL ; NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. INCLUDE BLAS.ENV START DROTG,'X','D',2 GETARG DS,SI,1; LOAD THE VALUE OF DA. FLD QWORD PTR [SI] FLD ST; DUPLICATE THE VALUE OF DA. FABS; COMPUTE ABS(A). GETARG DS,SI,2; LOAD THE VALUE OF B. FLD QWORD PTR [SI] FLD ST; DUPLICATE THE VALUE OF B. FABS; COMPUTE ABS(B). NOW HAVE STACK = [A |A| B |B|] FCOM ST(2); COMPARE |A| WITH |B|. FLAGS FLGS[BP] JC A_GT_B JMP B_GE_A ; COMPUTE RESULT TO OVERWRITE DA. ; NOW HAVE |A| .GT. |B|. A_GT_B: FDIV ST,ST(2); NOW HAVE STACK = [A |A| B |B|/|A|] FMUL ST,ST; WITH V=(B/A)**2, NOW HAVE STACK = [A |A| B V] FLD1; NOW HAVE STACK = [A |A| B V 1.] FADDP ST(1),ST; NOW HAVE STACK = [A |A| B 1.+V] FSQRT FMUL ST,ST(3); NOW HAVE STACK = [A |A| B A*SQRT(1.+V)] JMP STORE_R B_GE_A:; HERE THE RELATION |A| .LE. |B| HOLDS. FTST; NOW HAVE STACK = [A |A| B |B|] FLAGS FLGS[BP]; IF A=B=0, DO A SPECIAL SETTING OF C AND S. JZ BOTH_ZERO ; NOW HAVE |A| .LE. |B|, BUT B .NE. 0. FDIVR ST,ST(2); NOW HAVE STACK = [A |A| B |A|/|B|] FMUL ST,ST; WITH V=(A/B)**2, NOW HAVE STACK = [A |A| B V] FLD1; NOW HAVE STACK = [A |A| B V 1.] FADDP ST(1),ST; NOW HAVE STACK = [A |A| B 1.+V] FSQRT FMUL ST,ST(1);NOW HAVE STACK = [A |A| B B*SQRT(1.+V)] STORE_R: GETARG DS,SI,1; OVERWRITE DA WITH VALUE R DEFINED ABOVE IN COMMENTS FST QWORD PTR [SI]; THE VALUE R COMPUTED HERE IS .NE. 0. FDIV ST(3),ST FDIV ST(1),ST; NOW HAVE STACK = [C ? S R] FXCH ST(3); NOW HAVE STACK = [R ? S C] GETARG DS,SI,3 FST QWORD PTR [SI]; STORE DC AND DS. FXCH ST(1) GETARG DS,SI,4 FST QWORD PTR [SI] FLD ST; NOW HAVE STACK = [R ? C S S] FABS; NOW HAVE STACK = [R ? C S |S|] FCOM ST(2) FLAGS FLGS[BP] JC STORE_S; IF JUMP OCCURS, C .GT. ABS(S). FXCH ST(2); NOW HAVE STACK = [R ? |S| S C] FTST FLAGS FLGS[BP] JZ STORE_S; IF JUMP OCCURS, C=0. FLD1; NOW HAVE STACK = [R ? |S| S C 1.] FDIVRP ST(1),ST; NOW HAVE STACK = [R ? |S| S 1./C] GETARG DS,SI,2 FST QWORD PTR [SI] JMP DONE STORE_S: FXCH ST(1); NOW HAVE STACK = [R ? ? ? S] GETARG DS,SI,2 FST QWORD PTR [SI] JMP DONE BOTH_ZERO: FLD1 GETARG DS,SI,3 FSTP QWORD PTR [SI] FLDZ GETARG DS,SI,4 FSTP QWORD PTR [SI] DONE: ENDIT END ;$SROT.ASM ;COMPUTE THE ELEMENTARY VECTOR OPERATION SX :=( SC SS) SX ; SY (-SS SC) SY ;USE AS: CALL SROT(N, SX, INCX, SY, INCY, SC, SS) INCLUDE BLAS.ENV START SROT,'X','S',6 ;IF N .LE. 0, RETURN IMMEDIATELY. GETARG DS,SI,1 MOV CX,[SI] OR CX,CX JG TEST_SC_SS JMP DONESROT TEST_SC_SS: GETARG DS,SI,6 FLD DWORD PTR [SI] FLD1 FCOMP ST(1) FLAGS FLGS[BP] GETARG DS,SI,7 FLD DWORD PTR [SI] JNE GO_SROT FTST FLAGS FLGS[BP] JNZ GO_SROT JMP DONESROT ;IF BRANCH TO LABEL DONESROT, SC=1. AND SS=0. GO_SROT: GET2ARGS 2 MLOOP: FLD DWORD PTR [SI] FLD DWORD PTR ES:[DI]; [C S X Y] FLD ST; [C S X Y Y] FMUL ST,ST(3); [C S X Y Y*S] FLD ST(2); [C S X Y Y*S X] FMUL ST,ST(5); [C S X Y Y*S X*C] FADDP ST(1),ST; [C S X Y Y*S+X*C] FSTP DWORD PTR [SI]; [C S X Y] FMUL ST,ST(3); [C S X Y*C] FXCH ST(1); [C S Y*C X] FMUL ST,ST(2); [C S Y*C X*S] INCX FSUBP ST(1),ST; [C S Y*C-X*S] FSTP DWORD PTR ES:[DI]; [C S] INCY LOOP MLOOP DONESROT: ENDIT END ;$DROT.ASM ;COMPUTE THE ELEMENTARY VECTOR OPERATION DX :=( DC DS) DX ; DY (-DS DC) DY ;USE AS: CALL DROT(N, DX, INCX, DY, INCY, DC, DS) INCLUDE BLAS.ENV START DROT,'X','D',6 ;IF N .LE. 0, RETURN IMMEDIATELY. GETARG DS,SI,1 MOV CX,[SI] OR CX,CX JG TEST_DC_DS JMP DONEDROT TEST_DC_DS: GETARG DS,SI,6 FLD QWORD PTR [SI] FLD1 FCOMP ST(1) FLAGS FLGS[BP] GETARG DS,SI,7 FLD QWORD PTR [SI] JNE GO_DROT FTST FLAGS FLGS[BP] JNZ GO_DROT JMP DONEDROT ;IF BRANCH TO LABEL DONEDROT, DC=1. AND DS=0. GO_DROT: GET2ARGS 2 MLOOP: FLD QWORD PTR [SI] FLD QWORD PTR ES:[DI]; [C S X Y] FLD ST; [C S X Y Y] FMUL ST,ST(3); [C S X Y Y*S] FLD ST(2); [C S X Y Y*S X] FMUL ST,ST(5); [C S X Y Y*S X*C] FADDP ST(1),ST; [C S X Y Y*S+X*C] FSTP QWORD PTR [SI]; [C S X Y] FMUL ST,ST(3); [C S X Y*C] FXCH ST(1); [C S Y*C X] FMUL ST,ST(2); [C S Y*C X*S] INCX FSUBP ST(1),ST; [C S Y*C-X*S] FSTP QWORD PTR ES:[DI]; [C S] INCY LOOP MLOOP DONEDROT: ENDIT END ;$SROTM.ASM ;COMPUTE THE MODIFIED GIVENS TRANSFORMATION SX :=(H11 H12) SX ; SY (H21 H22) SY ;USE AS: CALL SROTM(N, SX, INCX, SY, INCY, SPARAM) INCLUDE BLAS.ENV START SROTM,'X','S',6 GETARG DS,SI,1; IF N .LE. 0, RETURN IMMEDIATELY. MOV CX,[SI] OR CX,CX JG TEST_SROTM JMP FAR PTR STOP_SROTM TEST_SROTM: GETARG DS,SI,6 FLD DWORD PTR [SI] FLD1 FADD ST,ST(1) FTST FLAGS FLGS[BP] FSTP ST FSTP ST JNC LOAD_MATRIX JMP FAR PTR STOP_SROTM; THIS JUMP CORRESPONDS TO PARAM(1)=-2. LOAD_MATRIX: FLD DWORD PTR [SI+4] FLD DWORD PTR [SI+8] FLD DWORD PTR [SI+12] FLD DWORD PTR [SI+16] FLD DWORD PTR [SI] GET2ARGS 2 FTST; EXAMINE PARAM(1). TEST ITS SIGN. FLAGS FLGS[BP] FSTP ST JNZ L01 JMP FAR PTR PARAM_1_EQ_0 L01: JC L02 JMP FAR PTR PARAM_1_EQ_1 L02: ; HERE WE PARAM(1)=-1. THIS IS THE CASE OF RESCALING. ; HAVE 2 BY 2 MATRIX WAITING IN STACK. LOOP_RESCALE:; [H11 H21 H12 H22] FLD DWORD PTR [SI] FLD DWORD PTR ES:[DI]; [H11 H21 H12 H22 X Y] FLD ST(1); [H11 H21 H12 H22 X Y X] FMUL ST,ST(6); [H11 H21 H12 H22 X Y X*H11] FLD ST(1); [H11 H21 H12 H22 X Y X*H11 Y] FMUL ST,ST(5); [H11 H21 H12 H22 X Y X*H11 Y*H12] FADDP ST(1),ST; [H11 H21 H12 H22 X Y X*H11+Y*H12] FSTP DWORD PTR [SI]; [H11 H21 H12 H22 X Y] FMUL ST,ST(2); [H11 H21 H12 H22 X H22*Y] FXCH ST(1); [H11 H21 H12 H22 H22*Y X] FMUL ST,ST(4); [H11 H21 H12 H22 H22*Y H21*X] INCX FADDP ST(1),ST; [H11 H21 H12 H22 H22*Y+H21*X] FSTP DWORD PTR ES:[DI]; [H11 H21 H12 H22] INCY LOOP LOOP_RESCALE JMP FAR PTR STOP_SROTM PARAM_1_EQ_0: LOOP_ZERO:; [H11 H21 H12 H22] FLD DWORD PTR ES:[DI] FLD DWORD PTR [SI]; [H11 H21 H12 H22 Y X] FLD ST(1); [H11 H21 H12 H22 Y X Y] FMUL ST,ST(4); [H11 H21 H12 H22 Y X Y*H12] FADD ST,ST(1); [H11 H21 H12 H22 Y X Y*H12+X] FSTP DWORD PTR [SI]; [H11 H21 H12 H22 Y X] FMUL ST,ST(4); [H11 H21 H12 H22 Y X*H21] INCX FADDP ST(1),ST; [H11 H21 H12 H22 Y+X*H21] FSTP DWORD PTR ES:[DI]; [H11 H21 H12 H22] INCY LOOP LOOP_ZERO JMP FAR PTR STOP_SROTM PARAM_1_EQ_1: LOOP_ONE:; [H11 H21 H12 H22] FLD DWORD PTR [SI] FLD DWORD PTR ES:[DI]; [H11 H21 H12 H22 X Y] FLD ST(1); [H11 H21 H12 H22 X Y X] FMUL ST,ST(6); [H11 H21 H12 H22 X Y X*H11] FADD ST,ST(1); [H11 H21 H12 H22 X Y X*H11+Y] FSTP DWORD PTR [SI]; [H11 H21 H12 H22 X Y] FMUL ST,ST(2); [H11 H21 H12 H22 X Y*H22] INCX FSUBRP ST(1),ST; [H11 H21 H12 H22 Y*H22-X] FSTP DWORD PTR ES:[DI]; [H11 H21 H12 H22] INCY LOOP LOOP_ONE STOP_SROTM LABEL FAR ENDIT END ;$DROTM.ASM ;COMPUTE THE MODIFIED GIVENS TRANSFORMATION DX :=(H11 H12) DX ; DY (H21 H22) DY ;USE AS: CALL DROTM(N, DX, INCX, DY, INCY, DPARAM) INCLUDE BLAS.ENV START DROTM,'X','D',6 GETARG DS,SI,1; IF N .LE. 0, RETURN IMMEDIATELY. MOV CX,[SI] OR CX,CX JG TEST_DROTM JMP FAR PTR STOP_DROTM TEST_DROTM: GETARG DS,SI,6 FLD QWORD PTR [SI] FLD1 FADD ST,ST(1) FTST FLAGS FLGS[BP] FSTP ST FSTP ST JNC LOAD_MATRIX JMP FAR PTR STOP_DROTM; THIS JUMP CORRESPONDS TO PARAM(1)=-2. LOAD_MATRIX: FLD QWORD PTR [SI+8] FLD QWORD PTR [SI+16] FLD QWORD PTR [SI+24] FLD QWORD PTR [SI+32] FLD QWORD PTR [SI] GET2ARGS 2 FTST; EXAMINE PARAM(1). TEST ITS SIGN. FLAGS FLGS[BP] FSTP ST JNZ L01 JMP FAR PTR PARAM_1_EQ_0 L01: JC L02 JMP FAR PTR PARAM_1_EQ_1 L02: ; HERE WE PARAM(1)=-1. THIS IS THE CASE OF RESCALING. ; HAVE 2 BY 2 MATRIX WAITING IN STACK. LOOP_RESCALE:; [H11 H21 H12 H22] FLD QWORD PTR [SI] FLD QWORD PTR ES:[DI]; [H11 H21 H12 H22 X Y] FLD ST(1); [H11 H21 H12 H22 X Y X] FMUL ST,ST(6); [H11 H21 H12 H22 X Y X*H11] FLD ST(1); [H11 H21 H12 H22 X Y X*H11 Y] FMUL ST,ST(5); [H11 H21 H12 H22 X Y X*H11 Y*H12] FADDP ST(1),ST; [H11 H21 H12 H22 X Y X*H11+Y*H12] FSTP QWORD PTR [SI]; [H11 H21 H12 H22 X Y] FMUL ST,ST(2); [H11 H21 H12 H22 X H22*Y] FXCH ST(1); [H11 H21 H12 H22 H22*Y X] FMUL ST,ST(4); [H11 H21 H12 H22 H22*Y H21*X] INCX FADDP ST(1),ST; [H11 H21 H12 H22 H22*Y+H21*X] FSTP QWORD PTR ES:[DI]; [H11 H21 H12 H22] INCY LOOP LOOP_RESCALE JMP FAR PTR STOP_DROTM PARAM_1_EQ_0: LOOP_ZERO:; [H11 H21 H12 H22] FLD QWORD PTR ES:[DI] FLD QWORD PTR [SI]; [H11 H21 H12 H22 Y X] FLD ST(1); [H11 H21 H12 H22 Y X Y] FMUL ST,ST(4); [H11 H21 H12 H22 Y X Y*H12] FADD ST,ST(1); [H11 H21 H12 H22 Y X Y*H12+X] FSTP QWORD PTR [SI]; [H11 H21 H12 H22 Y X] FMUL ST,ST(4); [H11 H21 H12 H22 Y X*H21] INCX FADDP ST(1),ST; [H11 H21 H12 H22 Y+X*H21] FSTP QWORD PTR ES:[DI]; [H11 H21 H12 H22] INCY LOOP LOOP_ZERO JMP FAR PTR STOP_DROTM PARAM_1_EQ_1: LOOP_ONE:; [H11 H21 H12 H22] FLD QWORD PTR [SI] FLD QWORD PTR ES:[DI]; [H11 H21 H12 H22 X Y] FLD ST(1); [H11 H21 H12 H22 X Y X] FMUL ST,ST(6); [H11 H21 H12 H22 X Y X*H11] FADD ST,ST(1); [H11 H21 H12 H22 X Y X*H11+Y] FSTP QWORD PTR [SI]; [H11 H21 H12 H22 X Y] FMUL ST,ST(2); [H11 H21 H12 H22 X Y*H22] INCX FSUBRP ST(1),ST; [H11 H21 H12 H22 Y*H22-X] FSTP QWORD PTR ES:[DI]; [H11 H21 H12 H22] INCY LOOP LOOP_ONE STOP_DROTM LABEL FAR ENDIT END ;$SCOPY.ASM ; Use as: call SCOPY(N, SX, INCX, SY, INCY) ; Copies contents of SX to SY ; INCLUDE BLAS.ENV START SCOPY,'X','S',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SCOPYX; <=0 => nothing to do GET2ARGS 2 SUB WORD PTR INCYL[BP],4*SIZE JNC SCOP1 ADD WORD PTR INCYL[BP],16 DEC WORD PTR INCYH[BP] SCOP1: MOV AX,BX OR AX,DX JZ SCOPC; =0 => INCX = 0 SCOPA: SUB BX,4*SIZE JNC SCOPA1 ADD BX,16 DEC DX SCOPA1: MOV AX,BX OR AX,DX JNZ SCOPB; /=0 => noncontiguous access SCOPA2: MOV AX,INCYL[BP] OR AX,INCYH[BP] JNZ SCOPB; /=0 => noncontiguous access ; Can do fast block copy, both increments = 1 SHL CX,1 CALL SCOPYR JMP SHORT SCOPYX SCOPB: MOVSW MOVSW IF SIZE-1 MOVSW MOVSW ENDIF INCX INCY LOOP SCOPB SCOPYX: EXITSUB SCOPC: MOV AX,DI; copy SX(1) to SY(1) then MOVSW; do the rest of the copies MOVSW; from SY(I) to SY(I+1). IF SIZE-1; Gives saving if INCY = 1 MOVSW MOVSW ENDIF DEC CX JZ SCOPYX MOV SI,AX MOV AX,ES MOV DS,AX MOV BX,INCYL[BP] MOV DX,INCYH[BP] INCY JMP SHORT SCOPA2 SCOPY ENDP SCOPYR PROC NEAR MOV AX,SI NOT AX SHR AX,1 INC AX CMP AX,CX JNC SCOPYR1; no carry => no problem with pointer overflow XCHG AX,CX SUB AX,CX PUSH AX; save count for the continuation CALL SCOPYR1 MOV AX,DS ADD AX,1000H MOV DS,AX POP CX OR DI,DI JNZ SCOPYR; /=0 => DI and SI don't overflow at same time MOV AX,ES ADD AX,1000H MOV ES,AX JMP SHORT SCOPYR SCOPYR1: MOV AX,DI NOT AX SHR AX,1 INC AX CMP AX,CX JNC SCOPYR2; same logic as above XCHG AX,CX SUB AX,CX REP MOVSW; do as much contiguous copy as possible MOV CX,AX MOV AX,ES ADD AX,1000H MOV ES,AX SCOPYR2: REP MOVSW; do as much contiguous copy as possible RET SCOPYR ENDP BLAS ENDS END ;$DCOPY.ASM ; Use as: call DCOPY(N, DX, INCX, DY, INCY) ; Copies contents of DX to DY ; Use as: call CCOPY(N, CX, INCX, CY, INCY) ; Copies contents of CX to CY ; INCLUDE BLAS.ENV START DCOPY,'X','D',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DCOPYX; <=0 => nothing to do GET2ARGS 2 SUB WORD PTR INCYL[BP],4*SIZE JNC DCOP1 ADD WORD PTR INCYL[BP],16 DEC WORD PTR INCYH[BP] DCOP1: MOV AX,BX OR AX,DX JZ DCOPC; =0 => INCX = 0 DCOPA: SUB BX,4*SIZE JNC DCOPA1 ADD BX,16 DEC DX DCOPA1: MOV AX,BX OR AX,DX JNZ DCOPB; /=0 => noncontiguous access DCOPA2: MOV AX,INCYL[BP] OR AX,INCYH[BP] JNZ DCOPB; /=0 => noncontiguous access ; Can do fast block copy, both increments = 1 SHL CX,1 CALL DCOPYR JMP SHORT DCOPYX DCOPB: MOVSW MOVSW IF SIZE-1 MOVSW MOVSW ENDIF INCX INCY LOOP DCOPB DCOPYX: EXITSUB DCOPC: MOV AX,DI; copy DX(1) to DY(1) then MOVSW; do the rest of the copies MOVSW; from SY(I) to SY(I+1). IF SIZE-1; Gives saving if INCY = 1 MOVSW MOVSW ENDIF DEC CX JZ DCOPYX MOV SI,AX MOV AX,ES MOV DS,AX MOV BX,INCYL[BP] MOV DX,INCYH[BP] INCY JMP SHORT DCOPA2 DCOPY ENDP DCOPYR PROC NEAR JNS DCOPR1; No sign => can do in 1 call PUSH CX CALL DCOPR2; Just do half to begin with POP CX; Now do the second half SHR CX,1 DCOPR1: RCL CX,1 DCOPR2: MOV AX,SI NOT AX SHR AX,1 INC AX CMP AX,CX JNC DCOPYR1; no carry => no problem with pointer overflow XCHG AX,CX SUB AX,CX PUSH AX; save count for the continuation CALL DCOPYR1 MOV AX,DS ADD AX,1000H MOV DS,AX POP CX OR DI,DI JNZ DCOPR2; /=0 => DI and SI don't overflow at same time MOV AX,ES ADD AX,1000H MOV ES,AX JMP SHORT DCOPR2 DCOPYR1: MOV AX,DI NOT AX SHR AX,1 INC AX CMP AX,CX JNC DCOPYR2; same logic as above XCHG AX,CX SUB AX,CX REP MOVSW; do as much contiguous copy as possible MOV CX,AX MOV AX,ES ADD AX,1000H MOV ES,AX DCOPYR2: REP MOVSW; do as much contiguous copy as possible RET DCOPYR ENDP BLAS ENDS END ;$SSWAP.ASM ; Use as: CALL SSWAP(N, SX, INCX, SY, INCY) ; Gives SY := SX ; INCLUDE BLAS.ENV START SSWAP,'X','S',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SSWAPX GET2ARGS 2 MLOOP: ; NOTE THAT DATA IS MOVED WITHOUT GOING THROUGH THE NDP. MOV AX,[SI] XCHG AX,ES:[DI] MOV [SI],AX MOV AX,[SI+2] XCHG AX,ES:[DI+2] MOV [SI+2],AX INCX INCY LOOP MLOOP SSWAPX: ENDIT END ;$DSWAP.ASM ; Use as: CALL DSWAP(N, DX, INCX, DY, INCY) ; Gives DY :=: DX ; Use as: CALL CSWAP(N, CX, INCX, CY, INCY) ; Gives CY :=: CX ; INCLUDE BLAS.ENV START DSWAP,'X','D',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DSWAPX GET2ARGS 2 MLOOP: ; NOTE THAT DATA IS MOVED WITHOUT GOING THROUGH THE NDP. MOV AX,[SI] XCHG AX,ES:[DI] MOV [SI],AX MOV AX,[SI+2] XCHG AX,ES:[DI+2] MOV [SI+2],AX MOV AX,[SI+4] XCHG AX,ES:[DI+4] MOV [SI+4 ],AX MOV AX,[SI+6] XCHG AX,ES:[DI+6] MOV [SI+6],AX INCX INCY LOOP MLOOP DSWAPX: ENDIT END ;$SNRM2.ASM ; Use as SW = SNRM2 (N, SX, INCX) ; Gives SW = Euclidean length of SX. ; INCLUDE BLAS.ENV START SNRM2,'S','S',0 FLDZ; Set length to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SNRM2X; <=0 => return 0 result GETPTI 2 MOV DS,DI MLOOP: FLD DWORD PTR [SI]; [SUM X] FMUL ST,ST; [SUM X*X] INCX FADDP ST(1),ST; [SUM] LOOP MLOOP FSQRT SNRM2X: ENDIT END ;$DNRM2.ASM ; Use as DW = DNRM2 (N, DX, INCX) ; Gives DW = Euclidean length of DX. ; INCLUDE BLAS.ENV START DNRM2,'D','D',0 FLDZ; Set length to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DNRM2X; <=0 => return 0 result GETPTI 2 MOV DS,DI MLOOP: FLD QWORD PTR [SI]; [SUM X] FMUL ST,ST; [SUM X*X] INCX FADDP ST(1),ST; [SUM] LOOP MLOOP FSQRT DNRM2X: ENDIT END ;$SCNRM2.ASM ; Use as SW = SCNRM2 (N, CX, INCX) ; Gives SW = Euclidean length of CX. ; INCLUDE BLAS.ENV START SCNRM2,'S','C',0 FLDZ; Set length to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SCNRM2X; <=0 => return 0 result GETPTI 2 MOV DS,DI MLOOP: FLD DWORD PTR [SI] FLD DWORD PTR [SI+4]; [SUM X Y] FMUL ST,ST; [SUM X Y*Y] FADDP ST(2),ST FMUL ST,ST; [SUM X*X] INCX FADDP ST(1),ST; [SUM] LOOP MLOOP FSQRT SCNRM2X: ENDIT END ;$SASUM.ASM ; Use as SW = SASUM (N, SX, INCX) ; Gives SW = Euclidean length of SX. ; INCLUDE BLAS.ENV START SASUM,'S','S',0 FLDZ; Set length to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SASUMX; <=0 => return 0 result GETPTI 2 MOV DS,DI MLOOP: FLD DWORD PTR [SI]; [SUM X] FABS; [SUM |X|] FADDP ST(1),ST; [SUM] INCX LOOP MLOOP SASUMX: ENDIT END ;$DASUM.ASM ; Use as DW = DASUM (N, DX, INCX) ; Gives DW = Euclidean length of DX. ; INCLUDE BLAS.ENV START DASUM,'D','D',0 FLDZ; Set length to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DASUMX; <=0 => return 0 result GETPTI 2 MOV DS,DI MLOOP: FLD QWORD PTR [SI]; [SUM X] FABS; [SUM |X|] FADDP ST(1),ST; [SUM] INCX LOOP MLOOP DASUMX: ENDIT END ;$SCASUM.ASM ; Use as SW = SCASUM (N, CX, INCX) ; Gives SW = Euclidean length of CX. ; INCLUDE BLAS.ENV START SCASUM,'S','C',0 FLDZ; Set length to 0 initially. GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SCASUMX; <=0 => return 0 result GETPTI 2 MOV DS,DI MLOOP: FLD DWORD PTR [SI] FLD DWORD PTR [SI+4]; [SUM X Y] FABS; [SUM X |Y|] FADDP ST(2),ST FABS; [SUM |X|] FADDP ST(1),ST; [SUM] INCX LOOP MLOOP SCASUMX: ENDIT END ;$SSCAL.ASM ; Use as: CALL SSCAL(N, SA, SX, INCX) ; Gives SX = SA * SX ; INCLUDE BLAS.ENV START SSCAL,'X','S',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE SSCALX; <=0 => return immediately GETARG DS,SI,2 FLD DWORD PTR[SI] FLD1 FCOMP ST(1) FLAGS FLGS[BP] JE SSCALX; = 1.0 => nothing to do GETPTI 3 MOV DS,DI MLOOP: FLD DWORD PTR [SI] FMUL ST,ST(1) FSTP DWORD PTR [SI] INCX LOOP MLOOP SSCALX: ENDIT END ;$DSCAL.ASM ; Use as: CALL DSCAL(N, DA, DX, INCX) ; Gives DX = DA * DX ; INCLUDE BLAS.ENV START DSCAL,'X','D',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE DSCALX; <=0 => return immediately GETARG DS,SI,2 FLD QWORD PTR[SI] FLD1 FCOMP ST(1) FLAGS FLGS[BP] JE DSCALX; = 1.0 => nothing to do GETPTI 3 MOV DS,DI MLOOP: FLD QWORD PTR [SI] FMUL ST,ST(1) FSTP QWORD PTR [SI] INCX LOOP MLOOP DSCALX: ENDIT END ;$CSCAL.ASM ; Use as: CALL CSCAL(N, CA, CX, INCX) ; Gives CX = CA * CX, CA=(A+i*B), CX=(W+iZ) ; INCLUDE BLAS.ENV START CSCAL,'X','C',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE CSCALX; <=0 => return immediately GETARG DS,SI,2 FLD DWORD PTR[SI] FLD DWORD PTR[SI+4] FLD1 FCOMP ST(2) FLAGS FLGS[BP] JNE CSCALGO FXCH ST(1) FTST FXCH ST(1) FLAGS FLGS[BP] JZ CSCALX; =1.0 => Nothing to do. CSCALGO: GETPTI 3 MOV DS,DI MLOOP: FLD DWORD PTR [SI+4] FLD DWORD PTR [SI]; | A B Z W| FLD ST; | A B Z W W| FMUL ST,ST(4) FLD ST(2); | A B Z W A*W Z| FMUL ST,ST(4); | A B Z W A*W B*Z| FSUBP ST(1),ST; | A B Z W A*W - B*Z| FSTP DWORD PTR[SI]; | A B Z W| FMUL ST,ST(2); | A B Z B*W| FXCH ST(1) FMUL ST,ST(3); | A B B*W A*Z| FADDP ST(1),ST; | A B B*W + A*Z| FSTP DWORD PTR [SI+4] INCX LOOP MLOOP CSCALX: ENDIT END ;$CSSCAL.ASM ; Use as: CALL CSSCAL(N, SA, CX, INCX) ; Gives CX = SA * CX ; INCLUDE BLAS.ENV START CSSCAL,'X','C',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] OR CX,CX JLE CSSCALX; <=0 => return immediately GETARG DS,SI,2 FLD DWORD PTR[SI] FLD1 FCOMP ST(1) FLAGS FLGS[BP] JE CSSCALX; = 1.0 => nothing to do GETPTI 3 MOV DS,DI MLOOP: FLD DWORD PTR [SI] FLD DWORD PTR [SI+4] FMUL ST,ST(2) FSTP DWORD PTR [SI+4] FMUL ST,ST(1) FSTP DWORD PTR [SI] INCX LOOP MLOOP CSSCALX: ENDIT END ;$ISAMAX.ASM ; Use as IW = ISAMAX (N, SX, INCX) ; Gives IW = smallest index of SX of max. magnitude ; INCLUDE BLAS.ENV START ISAMAX,'I','S',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] PUSH CX MOV DI,CX CMP CX,1 JG GO_ISAMAX; Normal case, N > 1 JL ISAMAXX; N<=0 => result = 0 JMP DECREM; 1 component => nothing to do, result = 1 GO_ISAMAX: GETPTI 2 MOV DS,DI MOV DI,CX FLD DWORD PTR [SI] FABS INCX DEC CX MLOOP: FLD DWORD PTR [SI]; [BIG X] FABS; [BIG |X|] FCOM ST(1) INCX FLAGS FLGS[BP] JBE POPST FXCH ST(1); GOT A BIGGER VALUE. UPDATE GAUGE AND POINTER TO IT. MOV DI,CX POPST: FSTP ST; [BIG] LOOP MLOOP DECREM: DEC DI ISAMAXX: ENDIT END ;$IDAMAX.ASM ; Use as IW = IDAMAX (N, DX, INCX) ; Gives IW = smallest index of DX of max. magnitude ; INCLUDE BLAS.ENV START IDAMAX,'I','D',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] PUSH CX MOV DI,CX CMP CX,1 JG GO_IDAMAX; Normal case, N > 1 JL IDAMAXX; N<=0 => result = 0 JMP DECREM; 1 component => nothing to do, result = 1 GO_IDAMAX: GETPTI 2 MOV DS,DI MOV DI,CX FLD QWORD PTR [SI] FABS INCX DEC CX MLOOP: FLD QWORD PTR [SI]; [BIG X] FABS; [BIG |X|] FCOM ST(1) INCX FLAGS FLGS[BP] JBE POPST FXCH ST(1); GOT A BIGGER VALUE. UPDATE GAUGE AND POINTER TO IT. MOV DI,CX POPST: FSTP ST; [BIG] LOOP MLOOP DECREM: DEC DI IDAMAXX: ENDIT END ;$ICAMAX.ASM ; Use as IW = ICAMAX (N, CX, INCX) ; Gives IW = smallest index of CX of max. sum of magnitudes ; INCLUDE BLAS.ENV START ICAMAX,'I','C',4 GETARG DS,SI,1; Get N into CX MOV CX,[SI] PUSH CX MOV DI,CX CMP CX,1 JG GO_ICAMAX; Normal case, N > 1 JL ICAMAXX; N<=0 => result = 0 JMP DECREM; 1 component => nothing to do, result = 1 GO_ICAMAX: GETPTI 2 MOV DS,DI MOV DI,CX FLDZ MLOOP: FLD DWORD PTR [SI]; [BIG X] FABS; [BIG |X|] FLD DWORD PTR [SI+4] FABS FADDP ST(1),ST; [BIG |X| + |Y|] FCOM ST(1) INCX FLAGS FLGS[BP] JBE POPST FXCH ST(1); GOT A BIGGER VALUE. UPDATE GAUGE AND POINTER TO IT. MOV DI,CX POPST: FSTP ST; [BIG] LOOP MLOOP DECREM: DEC DI ICAMAXX: ENDIT END ;$SBLAAI.ASM TITLE SBLAAI PUBLIC SBLAAI ; ; On entry: CX = N, DI = offset to argument loc. ; On exit: CX = N, DI:SI => base address, DX:BX = increment data ; DS is used, ES is not. ; INCLUDE BLAS.ENV BLAS SEGMENT 'CODE' ASSUME CS:BLAS,DS:NOTHING,SS:NOTHING,ES:NOTHING SBLAAI PROC NEAR PUSH CX GETINC DS,SI MOV AX,[SI] GETBASE DS,SI MOV DI,DS OR AX,AX JGE SBLA1; >= => no adjust of the base address MOV BX,AX DEC CX NEG CX IMUL CX; DX:AX = -(N-1) * INC ( Note is > 0.) SHR DX,1 RCR AX,1 RCR DX,1; After this instruction, DX better = 0 RCR AX,1; AX = -(N-1)*INC*4 / 16 MOV CL,4 RCL DX,CL; DX = mod(-(N-1)*INC*4, 16) ADD DI,AX ADD SI,DX MOV AX,BX JNC SBLA1 ADD DI,1000H; Adjust segment address for carry on base address SBLA1: OR SI,SI JNS SBLA2; No sign => offset is small enough to be safe SUB SI,8000H ADD DI,800H SBLA2: XOR BX,BX SAR AX,1 RCR BX,1 SAR AX,1; AX = 4 * INC / 16 = segment part of increment MOV CL,4 RCL BX,CL; BX = mod(4*INC, 16) = offset part of increment MOV DX,AX POP CX RET SBLAAI ENDP BLAS ENDS END ;$DBLAAI.ASM TITLE DBLAAI PUBLIC DBLAAI ; ; On entry: CX = N, DI = offset to argument loc. ; On exit: CX = N, DI:SI => base address, DX:BX = increment data ; DS is used, ES is not. ; INCLUDE BLAS.ENV BLAS SEGMENT 'CODE' ASSUME CS:BLAS,DS:NOTHING,SS:NOTHING,ES:NOTHING DBLAAI PROC NEAR PUSH CX GETINC DS,SI MOV AX,[SI] GETBASE DS,SI MOV DI,DS OR AX,AX JGE DBLA1; >= => no adjust of the base address MOV BX,AX DEC CX NEG CX IMUL CX; DX:AX = -(N-1) * INC ( Note is > 0.) RCR DX,1; after this instruction, DX better = 0 RCR AX,1; AX = -(N-1)*INC*8 / 16 MOV CL,4 RCL DX,CL; DX = mod(-(N-1)*INC*8, 16) ADD DI,AX ADD SI,DX MOV AX,BX JNC DBLA1 ADD DI,1000H; Adjust segment address for carry on base address DBLA1: OR SI,SI JNS DBLA2; No sign => offset is small enough to be safe SUB SI,8000H ADD DI,800H DBLA2: XOR BX,BX SAR AX,1; AX = 8 * INC / 16 = segment part of increment MOV CL,4 RCL BX,CL; BX = mod(8*INC, 16) = offset part of increment MOV DX,AX POP CX RET DBLAAI ENDP BLAS ENDS END ;$LAHEY.ENV ;LAHEY.ENV => BLAS.ENV FOR LAHEY COMPILER CLIST MACRO .XLIST; To expand the macros, change this .XLIST to .LIST. ENDM .XLIST LIST MACRO .LIST ENDM PAGE 78,132 ; Macros for BLAS on 8088/8086/80186/80286 accessed with Lahey Fortran 77 .287 GETARG MACRO X,REG,IARG; X = DS or ES, REG is a 16 bit register, IARG is the ; argument index -- X:REG gets pointer to argument. CLIST L&X REG,DWORD PTR[BP+4*IARG+IOFF] LIST ENDM GETINC MACRO X,REG CLIST L&X REG,DWORD PTR[DI+BP+4] LIST ENDM GETBASE MACRO X,REG CLIST L&X REG,DWORD PTR[DI+BP] LIST ENDM START2 MACRO NAME2,STKSPA CLIST PUBLIC NAME2 NAME2 LABEL FAR PUSH BP MOV BP,SP IF STKSPA SUB SP,STKSPA; Reserve STKSPA bytes on the stack ENDIF LIST ENDM START MACRO NAME,FSUB,TYPE,STKSPA CLIST TITLE NAME BLAS SEGMENT WORD PUBLIC 'CODE' ASSUME CS:BLAS,DS:NOTHING,SS:NOTHING,ES:NOTHING PUBLIC NAME NAME PROC FAR IFIDN , PUBLIC CCOPY CCOPY LABEL FAR ENDIF IFIDN , PUBLIC CSWAP CSWAP LABEL FAR ENDIF IFDIF ,<'X'> C IOFF = 6; FSUB = 'X' for subroutines ELSE IOFF = 2; = I,S,D,C,Q for various function types ENDIF IFIDN ,<'S'>; TYPE = 'S', 'D', 'C', for Single, Double, & Complex SIZE = 1 EXTRN SBLAAI:NEAR ELSE SIZE = 2 EXTRN DBLAAI:NEAR ENDIF PUSH BP MOV BP,SP IF STKSPA SUB SP,STKSPA; Reserve STKSPA bytes on the stack INCYH EQU WORD PTR -2; Offsets for saving "Y" increments. INCYL EQU WORD PTR -4 FLGS EQU WORD PTR -STKSPA; Place to save flags if needed. ENDIF EXITSUB MACRO CLIST MOV SP,BP POP BP RET LIST ENDM ENDIT MACRO CLIST IFIDN ,<'X'> FINIT ELSE GETARG DS,SI,0 CLIST IFIDN ,<'I'> FINIT POP AX; AX = input value of N. SUB AX,DI; DI = value of CX-1 when got last max. MOV WORD PTR [SI],AX MOV WORD PTR 2[SI],0 ENDIF IFIDN ,<'S'> FSTP DWORD PTR [SI] FWAIT ENDIF IFIDN ,<'D'> FSTP QWORD PTR [SI] FWAIT ENDIF IFIDN ,<'C'> FSTP DWORD PTR 4[SI] FSTP DWORD PTR [SI] FWAIT ENDIF IFIDN ,<'Q'>; FST QWORD PTR [SI] GETARG DS,SI,3 CLIST FSTP TBYTE PTR [SI] FWAIT ENDIF ENDIF EXITSUB NAME ENDP BLAS ENDS LIST ENDM GETPTI MACRO IARG CLIST MOV DI,4*IARG+IOFF; IARG is the argument index for X or Y. On return, IFE SIZE-1 CALL SBLAAI; DI:SI => to arg., DX:BX has increment info. ELSE CALL DBLAAI; DI:SI => to arg., DX:BX has increment info. ENDIF LIST ENDM GET2ARGS MACRO IARG,BACK LOCAL L CLIST GETPTI (IARG+2) CLIST MOV INCYH[BP],DX; Get base addresses and increment info. for two MOV INCYL[BP],BX; vector arguments. IARG is index of the first. IFIDN ,<'YB'> SUB DI,DX; Decrement Y pointer 1 position initially SUB SI,BX JNC L ADD SI,16 DEC DI ENDIF L: MOV ES,DI; PUSH SI; GETPTI IARG CLIST MOV DS,DI; When done ES:DI points to the second argument (-1 POP DI; position if 'YB'); DS:SI points to the first ; argument; INCYH[BP] & INCYL[BP] contain data for ; incrementing the second pointer; and DX & BX ; contain data for incrementing the first pointer. LIST ENDM INCX MACRO LOCAL L1 CLIST MOV AX,DS; Increment pointer for X ADD AX,DX ADD SI,BX JNS L1 SUB SI,8000H ADD AH,8H L1: MOV DS,AX LIST ENDM INCY MACRO LOCAL L2 CLIST MOV AX,ES; Increment pointer for Y ADD AX,INCYH[BP] ADD DI,INCYL[BP] JNS L2 SUB DI,8000H ADD AH,8H L2: MOV ES,AX LIST ENDM FLAGS MACRO SPACE; CLIST FSTSW WORD PTR SPACE; Get zero and carry flags from numeric FWAIT; data processor into CPU. AX and SPACE MOV AX,WORD PTR SPACE; are clobbered. SAHF LIST ENDM LIST ENDM LIST ;$IBMPROF.ENV ;IBMPROF.ENV => BLAS.ENV FOR IBM PROF. COMPILER CLIST MACRO .XLIST; To expand the macros, change this .XLIST to .LIST. ENDM .XLIST LIST MACRO .LIST ENDM PAGE 78,132 ; Macros for BLAS on 8088/8086/80186/80286 accessed with IBM Prof. Fortran 77 .287 GETARG MACRO X,REG,IARG; X = DS or ES, REG is a 16 bit register, IARG is the ; argument index -- X:REG gets pointer to argument. CLIST L&X REG,DWORD PTR ES:[BX+4*IARG-4] LIST ENDM GETINC MACRO X,REG CLIST L&X REG,DWORD PTR ES:[DI+BX+4] LIST ENDM GETBASE MACRO X,REG CLIST L&X REG,DWORD PTR ES:[DI+BX] LIST ENDM START2 MACRO NAME2,STKSPA CLIST PUBLIC NAME2 NAME2 LABEL FAR IF STKSPA MOV BP,SP SUB SP,STKSPA; Reserve STKSPA bytes on the stack ENDIF PUSH ES PUSH BX LIST ENDM START MACRO NAME,FSUB,TYPE,STKSPA CLIST TITLE NAME XSTACK EQU 16 STACK SEGMENT WORD STACK 'STACK' DB XSTACK DUP (?) STACK ENDS BLAS SEGMENT WORD PUBLIC 'CODE' ASSUME CS:BLAS,DS:NOTHING,SS:STACK,ES:NOTHING NAME PROC FAR PUBLIC NAME IFIDN , PUBLIC CCOPY CCOPY LABEL FAR ENDIF IFIDN , PUBLIC CSWAP CSWAP LABEL FAR ENDIF IFIDN ,<'S'>; TYPE = 'S', 'D', 'C', for Single, Double, & Complex SIZE = 1 EXTRN SBLAAI:NEAR ELSE SIZE = 2 EXTRN DBLAAI:NEAR ENDIF IF STKSPA MOV BP,SP SUB SP,STKSPA; Reserve STKSPA bytes on the stack INCYH EQU WORD PTR -2; Offsets for saving "Y" increments. INCYL EQU WORD PTR -4 FLGS EQU WORD PTR -STKSPA; Place to save flags if needed. ENDIF IFIDN ,<'Q'> PUSH ES PUSH BX ENDIF EXITSUB MACRO CLIST IF STKSPA MOV SP,BP ENDIF RET LIST ENDM ENDIT MACRO CLIST IFIDN ,<'X'> FINIT ELSE IFIDN ,<'I'> FINIT POP AX; AX = input value of N. SUB AX,DI; DI = value of CX-1 when got last max. MOV WORD PTR FLGS[BP],AX FILD WORD PTR FLGS[BP] ENDIF IFIDN ,<'C'> FXCH ST(1) ENDIF IFIDN ,<'Q'>; FLD ST POP BX POP ES GETARG DS,SI,3 FSTP TBYTE PTR [SI] ENDIF ENDIF EXITSUB NAME ENDP BLAS ENDS LIST ENDM GETPTI MACRO IARG CLIST MOV DI,4*IARG-4; IARG is the argument index for X or Y. On return, IFE SIZE-1 CALL SBLAAI; DI:SI => to arg., DX:BX has increment info. ELSE CALL DBLAAI; DI:SI => to arg., DX:BX has increment info. ENDIF LIST ENDM GET2ARGS MACRO IARG,BACK LOCAL L CLIST PUSH BX GETPTI (IARG+2) CLIST MOV INCYH[BP],DX; Get base addresses and increment info. for two MOV INCYL[BP],BX; vector arguments. IARG is index of the first. IFIDN ,<'YB'> SUB DI,DX; Decrement Y pointer 1 position initially SUB SI,BX JNC L ADD SI,16 DEC DI ENDIF L: POP BX PUSH DI; PUSH SI GETPTI IARG CLIST MOV DS,DI; When done ES:DI points to the second argument (-1 POP DI; position if 'YB'); DS:SI points to the first POP ES ; argument; INCYH[BP] & INCYL[BP] contain data for ; incrementing the second pointer; and DX & BX ; contain data for incrementing the first pointer. LIST ENDM INCX MACRO LOCAL L1 CLIST MOV AX,DS; Increment pointer for X ADD AX,DX ADD SI,BX JNS L1 SUB SI,8000H ADD AH,8H L1: MOV DS,AX LIST ENDM INCY MACRO LOCAL L2 CLIST MOV AX,ES; Increment pointer for Y ADD AX,INCYH[BP] ADD DI,INCYL[BP] JNS L2 SUB DI,8000H ADD AH,8H L2: MOV ES,AX LIST ENDM FLAGS MACRO SPACE; CLIST FSTSW WORD PTR SPACE; Get zero and carry flags from numeric FWAIT; data processor into CPU. AX and SPACE MOV AX,WORD PTR SPACE; are clobbered. SAHF LIST ENDM LIST ENDM LIST ;$MSOFT.ENV ;MSOFT.ENV => BLAS.ENV FOR MICROSOFT COMPILER CLIST MACRO .XLIST; To expand the macros, change this .XLIST to .LIST. ENDM .XLIST LIST MACRO .LIST ENDM PAGE 78,132 ; Macros for BLAS on 8088/8086/80186/80286 accessed with Microsoft Subset ; Fortran 77 .287 GETARG MACRO X,REG,IARG; X = DS or ES, REG is a 16 bit register, IARG is the ; argument index -- X:REG gets pointer to argument. CLIST IF IARG L&X REG,DWORD PTR[BP+4*(NARGS-IARG)+IOFF] ELSE MOV AX,WORD PTR DATAS[BP] MOV X,AX MOV REG,WORD PTR [BP+6] ENDIF LIST ENDM GETINC MACRO X,REG CLIST L&X REG,DWORD PTR[DI+BP-4] LIST ENDM GETBASE MACRO X,REG CLIST L&X REG,DWORD PTR[DI+BP] LIST ENDM START2 MACRO NAME2,STKSPA CLIST PUBLIC NAME2 NAME2 LABEL FAR PUSH BP MOV BP,SP SUB SP,8; Reserve 8 bytes on the stack; STKSPA not used. MOV AX,DS MOV WORD PTR DATAS[BP],AX; Save DS on the stack. LIST ENDM START MACRO NAME,FSUB,TYPE,STKSPA CLIST TITLE NAME BLAS SEGMENT WORD PUBLIC 'CODE' ASSUME CS:BLAS,DS:NOTHING,SS:NOTHING,ES:NOTHING PUBLIC NAME NAME PROC FAR IFIDN , PUBLIC CCOPY CCOPY LABEL FAR ENDIF IFIDN , PUBLIC CSWAP CSWAP LABEL FAR ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=6 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=7 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=6 ENDIF IFIDN , NARGS=6 ENDIF IFIDN , NARGS=6 ENDIF IFIDN , NARGS=4 ENDIF IFIDN , NARGS=4 ENDIF IFIDN , NARGS=7 ENDIF IFIDN , NARGS=7 ENDIF IFIDN , NARGS=6 ENDIF IFIDN , NARGS=6 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=5 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=4 ENDIF IFIDN , NARGS=4 ENDIF IFIDN , NARGS=4 ENDIF IFIDN , NARGS=4 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=3 ENDIF IFIDN , NARGS=3 ENDIF IOFF = 8; = I,S,D,C,Q for various function types IFIDN ,<'I'> IOFF = 6 ENDIF IFIDN ,<'X'> IOFF = 6; FSUB = 'X' for subroutines ENDIF IFIDN ,<'S'>; TYPE = 'S', 'D', 'C', for Single, Double, & Complex SIZE = 1 EXTRN SBLAAI:NEAR ELSE SIZE = 2 EXTRN DBLAAI:NEAR ENDIF INCYH EQU WORD PTR -2; Offsets for saving "Y" increments. INCYL EQU WORD PTR -4 DATAS EQU WORD PTR -6; Place to save DS. FLGS EQU WORD PTR -8; Place to save flags if needed. PUSH BP MOV BP,SP SUB SP,8; Reserve 8 bytes on the stack MOV AX,DS MOV WORD PTR DATAS[BP],AX; Save DS on the stack. EXITSUB MACRO CLIST IFIDN ,<'X'> MOV AX,WORD PTR DATAS[BP] MOV DS,AX ELSE IFIDN ,<'I'> ELSE MOV AX,SI ENDIF ENDIF MOV SP,BP POP BP RET 4*NARGS+IOFF-6 LIST ENDM ENDIT MACRO CLIST IFIDN ,<'X'> FINIT ELSE IFIDN ,<'Q'> ELSE GETARG DS,SI,0 CLIST ENDIF IFIDN ,<'I'> FINIT MOV AX,WORD PTR DATAS[BP] MOV DS,AX; Restore DS. POP AX; AX = input value of N. SUB AX,DI; DI = value of CX-1 when got last max. SUB DX,DX; Set DX = 0 for proper INTEGER*4 result. ENDIF IFIDN ,<'S'> FSTP DWORD PTR [SI] FWAIT ENDIF IFIDN ,<'D'> FSTP QWORD PTR [SI] FWAIT ENDIF IFIDN ,<'C'> FSTP DWORD PTR [SI+4] FSTP DWORD PTR [SI] FWAIT ENDIF IFIDN ,<'Q'>; FLD ST GETARG DS,SI,3 CLIST FSTP TBYTE PTR [SI] GETARG DS,SI,0 CLIST FSTP QWORD PTR [SI] FWAIT ENDIF ENDIF EXITSUB NAME ENDP BLAS ENDS LIST ENDM GETPTI MACRO IARG CLIST MOV DI,4*(NARGS-IARG)+IOFF; IARG is the argument index for X or Y. On re IFE SIZE-1 CALL SBLAAI; DI:SI => to arg., DX:BX has increment info. ELSE CALL DBLAAI; DI:SI => to arg., DX:BX has increment info. ENDIF LIST ENDM GET2ARGS MACRO IARG,BACK LOCAL L CLIST GETPTI (IARG+2) CLIST MOV INCYH[BP],DX; Get base addresses and increment info. for two MOV INCYL[BP],BX; vector arguments. IARG is index of the first. IFIDN ,<'YB'> SUB DI,DX; Decrement Y pointer 1 position initially SUB SI,BX JNC L ADD SI,16 DEC DI ENDIF L: MOV ES,DI; PUSH SI; GETPTI IARG CLIST MOV DS,DI; When done ES:DI points to the second argument (-1 POP DI; position if 'YB'); DS:SI points to the first ; argument; INCYH[BP] & INCYL[BP] contain data for ; incrementing the second pointer; and DX & BX ; contain data for incrementing the first pointer. LIST ENDM INCX MACRO LOCAL L1 CLIST MOV AX,DS; Increment pointer for X ADD AX,DX ADD SI,BX JNS L1 SUB SI,8000H ADD AH,8H L1: MOV DS,AX LIST ENDM INCY MACRO LOCAL L2 CLIST MOV AX,ES; Increment pointer for Y ADD AX,INCYH[BP] ADD DI,INCYL[BP] JNS L2 SUB DI,8000H ADD AH,8H L2: MOV ES,AX LIST ENDM FLAGS MACRO SPACE; CLIST FSTSW WORD PTR SPACE; Get zero and carry flags from numeric FWAIT; data processor into CPU. AX and SPACE MOV AX,WORD PTR SPACE; are clobbered. SAHF LIST ENDM LIST ENDM LIST