|
a/LibDBlas.mod |
|
b/LibDBlas.mod |
|
... |
|
... |
| 33 |
(* 29.10.17, MRi: dgemv,dgemm,zgemm und dger sind nur noch Verweise auf *)
|
33 |
(* 29.10.17, MRi: dgemv,dgemm,zgemm und dger sind nur noch Verweise auf *)
|
| 34 |
(* die entsprechenden Routinen in LibDBlasM2 *)
|
34 |
(* die entsprechenden Routinen in LibDBlasM2 *)
|
| 35 |
(* 20.06.18, MRi: Erstellen der erstern uebersetzbaren Version von *)
|
35 |
(* 20.06.18, MRi: Erstellen der erstern uebersetzbaren Version von *)
|
| 36 |
(* dznrm2,zdotc,zscal,zaxpy,zswap,zdrot *)
|
36 |
(* dznrm2,zdotc,zscal,zaxpy,zswap,zdrot *)
|
| 37 |
(* 21.06.18, MRi: Korrekturen in dznrm2 und zdotc *)
|
37 |
(* 21.06.18, MRi: Korrekturen in dznrm2 und zdotc *)
|
|
|
38 |
(* 11.09.18, MRi: Hinzufuegen von zcopy und zgemv (definition) *)
|
| 38 |
(*------------------------------------------------------------------------*)
|
39 |
(*------------------------------------------------------------------------*)
|
| 39 |
(* Testroutinen *)
|
40 |
(* Testroutinen *)
|
| 40 |
(* *)
|
41 |
(* *)
|
| 41 |
(* - zgemm in TstCmplxMaMul *)
|
42 |
(* - zgemm in TstCmplxMaMul *)
|
| 42 |
(*------------------------------------------------------------------------*)
|
43 |
(*------------------------------------------------------------------------*)
|
|
... |
|
... |
| 47 |
(*------------------------------------------------------------------------*)
|
48 |
(*------------------------------------------------------------------------*)
|
| 48 |
(* Implementation : Michael Riedl *)
|
49 |
(* Implementation : Michael Riedl *)
|
| 49 |
(* Licence : GNU Lesser General Public License (LGPL) *)
|
50 |
(* Licence : GNU Lesser General Public License (LGPL) *)
|
| 50 |
(*------------------------------------------------------------------------*)
|
51 |
(*------------------------------------------------------------------------*)
|
| 51 |
|
52 |
|
| 52 |
(* $Id: LibDBlas.mod,v 1.4 2017/10/29 09:54:58 mriedl Exp mriedl $ *)
|
53 |
(* $Id: LibDBlas.mod,v 1.6 2018/09/12 13:20:49 mriedl Exp mriedl $ *)
|
| 53 |
|
54 |
|
| 54 |
IMPORT SYSTEM;
|
55 |
IMPORT SYSTEM;
|
| 55 |
FROM Deklera IMPORT FLOAT,CFLOAT; (* REAL,COMPLEX type *)
|
56 |
FROM Deklera IMPORT FLOAT,CFLOAT; (* REAL,COMPLEX type *)
|
| 56 |
IMPORT Errors;
|
57 |
IMPORT Errors;
|
| 57 |
FROM LongMath IMPORT sqrt;
|
58 |
FROM LongMath IMPORT sqrt;
|
|
... |
|
... |
| 535 |
FOR i:=0 TO dim-1 DO Sum:=Sum + ABS(XX^[ix]); INC(ix,IncX); END;
|
536 |
FOR i:=0 TO dim-1 DO Sum:=Sum + ABS(XX^[ix]); INC(ix,IncX); END;
|
| 536 |
END;
|
537 |
END;
|
| 537 |
RETURN Sum;
|
538 |
RETURN Sum;
|
| 538 |
END dasum;
|
539 |
END dasum;
|
| 539 |
|
540 |
|
| 540 |
(*============================= complexe prozedures ========================*)
|
541 |
(*============================= complexe procedures ========================*)
|
| 541 |
|
542 |
|
| 542 |
PROCEDURE zswap( N : CARDINAL;
|
543 |
PROCEDURE zswap( N : CARDINAL;
|
| 543 |
VAR X : (* ARRAY OF *) CFLOAT;
|
544 |
VAR X : (* ARRAY OF *) CFLOAT;
|
| 544 |
IncX : INTEGER;
|
545 |
IncX : INTEGER;
|
| 545 |
VAR Y : (* ARRAY OF *) CFLOAT;
|
546 |
VAR Y : (* ARRAY OF *) CFLOAT;
|
|
... |
|
... |
| 581 |
Xi := XX^[ix]; XX^[ix] := YY^[iy]; YY^[iy] := Xi;
|
582 |
Xi := XX^[ix]; XX^[ix] := YY^[iy]; YY^[iy] := Xi;
|
| 582 |
INC(ix,IncX); INC(iy,IncY);
|
583 |
INC(ix,IncX); INC(iy,IncY);
|
| 583 |
END;
|
584 |
END;
|
| 584 |
END;
|
585 |
END;
|
| 585 |
END zswap;
|
586 |
END zswap;
|
|
|
587 |
|
|
|
588 |
PROCEDURE zcopy( N : INTEGER;
|
|
|
589 |
VAR X : (* ARRAY OF *) LONGCOMPLEX;
|
|
|
590 |
IncX : INTEGER;
|
|
|
591 |
VAR Y : (* ARRAY OF *) LONGCOMPLEX;
|
|
|
592 |
IncY : INTEGER);
|
|
|
593 |
|
|
|
594 |
(*----------------------------------------------------------------*)
|
|
|
595 |
(* Adopted to Modula-2, MRi, 04.04.2016, complex version 09.08.18 *)
|
|
|
596 |
(*----------------------------------------------------------------*)
|
|
|
597 |
|
|
|
598 |
CONST MAXINT = MAX(INTEGER);
|
|
|
599 |
TYPE PCVEKTOR0 = POINTER TO ARRAY [0..MAXINT-1] OF LONGCOMPLEX;
|
|
|
600 |
VAR i,ix,iy,m : INTEGER;
|
|
|
601 |
XX,YY : PCVEKTOR0;
|
|
|
602 |
BEGIN
|
|
|
603 |
IF (N <= 0) THEN RETURN; END;
|
|
|
604 |
|
|
|
605 |
XX:=SYSTEM.CAST(PCVEKTOR0,SYSTEM.ADR(X));
|
|
|
606 |
YY:=SYSTEM.CAST(PCVEKTOR0,SYSTEM.ADR(Y));
|
|
|
607 |
|
|
|
608 |
IF (IncX = 1) AND (IncY = 1) THEN
|
|
|
609 |
(* code for both increments equal to 1 *)
|
|
|
610 |
m := (N MOD 8);
|
|
|
611 |
IF (m # 0) THEN (* Clean-up loop *)
|
|
|
612 |
FOR i:=0 TO m-1 DO YY^[i] := XX^[i]; END;
|
|
|
613 |
IF (N < 8) THEN RETURN; END
|
|
|
614 |
END;
|
|
|
615 |
FOR i:=m TO N-1 BY 8 DO
|
|
|
616 |
YY^[i+0] := XX^[i+0]; YY^[i+1] := XX^[i+1];
|
|
|
617 |
YY^[i+2] := XX^[i+2]; YY^[i+3] := XX^[i+3];
|
|
|
618 |
YY^[i+4] := XX^[i+4]; YY^[i+5] := XX^[i+5];
|
|
|
619 |
YY^[i+6] := XX^[i+6]; YY^[i+7] := XX^[i+7];
|
|
|
620 |
END;
|
|
|
621 |
ELSE
|
|
|
622 |
(* code for unequal increments or equal increments not equal to 1 *)
|
|
|
623 |
IF (IncX > 0) THEN ix:=0; ELSE ix:=(1 - VAL(INTEGER,N))*IncX; END;
|
|
|
624 |
IF (IncY > 0) THEN iy:=0; ELSE iy:=(1 - VAL(INTEGER,N))*IncY; END;
|
|
|
625 |
FOR i:=0 TO N-1 DO
|
|
|
626 |
YY^[iy] := XX^[ix];
|
|
|
627 |
INC(ix,IncX); INC(iy,IncY);
|
|
|
628 |
END;
|
|
|
629 |
END;
|
|
|
630 |
END zcopy;
|
| 586 |
|
631 |
|
| 587 |
PROCEDURE zdotc( N : INTEGER;
|
632 |
PROCEDURE zdotc( N : INTEGER;
|
| 588 |
VAR X : (* ARRAY OF *) CFLOAT;
|
633 |
VAR X : (* ARRAY OF *) CFLOAT;
|
| 589 |
IncX : INTEGER;
|
634 |
IncX : INTEGER;
|
| 590 |
VAR Y : (* ARRAY OF *) CFLOAT;
|
635 |
VAR Y : (* ARRAY OF *) CFLOAT;
|