Skip to content

Commit d7391de

Browse files
langoulangou
authored
Merge pull request #402 from matcross/master
Incorrect behaviour in real ?LACN2 under Fortran 95 SIGN semantics. Improved some ?COPY testing.
2 parents a1233b3 + 55e6ff5 commit d7391de

File tree

6 files changed

+106
-46
lines changed

6 files changed

+106
-46
lines changed

‎BLAS/TESTING/cblat1.f

Lines changed: 18 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -344,7 +344,8 @@ SUBROUTINE CHECK2(SFAC)
344344
LOGICAL PASS
345345
* .. Local Scalars ..
346346
COMPLEX CA
347-
INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
347+
INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
348+
+ MX, MY
348349
* .. Local Arrays ..
349350
COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
350351
+ CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
@@ -564,15 +565,23 @@ SUBROUTINE CHECK2(SFAC)
564565
* .. CCOPY ..
565566
CALL CCOPY(N,CX,INCX,CY,INCY)
566567
CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0)
567-
CX0(1) = (42.0E0,43.0E0)
568-
CY0(1) = (44.0E0,45.0E0)
569-
IF (N.EQ.0) THEN
570-
CTY0(1) = CY0(1)
571-
ELSE
572-
CTY0(1) = CX0(1)
568+
IF (KI.EQ.1) THEN
569+
CX0(1) = (42.0E0,43.0E0)
570+
CY0(1) = (44.0E0,45.0E0)
571+
IF (N.EQ.0) THEN
572+
CTY0(1) = CY0(1)
573+
ELSE
574+
CTY0(1) = CX0(1)
575+
END IF
576+
LINCX = INCX
577+
INCX = 0
578+
LINCY = INCY
579+
INCY = 0
580+
CALL CCOPY(N,CX0,INCX,CY0,INCY)
581+
CALL CTEST(1,CY0,CTY0,CSIZE3,1.0E0)
582+
INCX = LINCX
583+
INCY = LINCY
573584
END IF
574-
CALL CCOPY(N,CX0,0,CY0,0)
575-
CALL CTEST(1,CY0,CTY0,CSIZE3,1.0E0)
576585
ELSE IF (ICASE.EQ.5) THEN
577586
* .. CSWAP ..
578587
CALL CSWAP(N,CX,INCX,CY,INCY)

‎BLAS/TESTING/dblat1.f

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -362,7 +362,7 @@ SUBROUTINE CHECK2(SFAC)
362362
* .. Local Scalars ..
363363
DOUBLE PRECISION SA
364364
INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY,
365-
$ MX, MY
365+
$ LINCX, LINCY, MX, MY
366366
* .. Local Arrays ..
367367
DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
368368
$ DT8(7,4,4), DX1(7),
@@ -646,15 +646,23 @@ SUBROUTINE CHECK2(SFAC)
646646
60 CONTINUE
647647
CALL DCOPY(N,SX,INCX,SY,INCY)
648648
CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
649-
SX0(1) = 42.0D0
650-
SY0(1) = 43.0D0
651-
IF (N.EQ.0) THEN
652-
STY0(1) = SY0(1)
653-
ELSE
654-
STY0(1) = SX0(1)
649+
IF (KI.EQ.1) THEN
650+
SX0(1) = 42.0D0
651+
SY0(1) = 43.0D0
652+
IF (N.EQ.0) THEN
653+
STY0(1) = SY0(1)
654+
ELSE
655+
STY0(1) = SX0(1)
656+
END IF
657+
LINCX = INCX
658+
INCX = 0
659+
LINCY = INCY
660+
INCY = 0
661+
CALL DCOPY(N,SX0,INCX,SY0,INCY)
662+
CALL STEST(1,SY0,STY0,SSIZE2(1,1),1.0D0)
663+
INCX = LINCX
664+
INCY = LINCY
655665
END IF
656-
CALL DCOPY(N,SX0,0,SY0,0)
657-
CALL STEST(1,SY0,STY0,SSIZE2(1,1),1.0D0)
658666
ELSE IF (ICASE.EQ.6) THEN
659667
* .. DSWAP ..
660668
CALL DSWAP(N,SX,INCX,SY,INCY)

‎BLAS/TESTING/sblat1.f

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -362,7 +362,7 @@ SUBROUTINE CHECK2(SFAC)
362362
* .. Local Scalars ..
363363
REAL SA
364364
INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY,
365-
$ MX, MY
365+
$ LINCX, LINCY, MX, MY
366366
* .. Local Arrays ..
367367
REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
368368
$ DT8(7,4,4), DX1(7),
@@ -648,15 +648,23 @@ SUBROUTINE CHECK2(SFAC)
648648
60 CONTINUE
649649
CALL SCOPY(N,SX,INCX,SY,INCY)
650650
CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0)
651-
SX0(1) = 42.0E0
652-
SY0(1) = 43.0E0
653-
IF (N.EQ.0) THEN
654-
STY0(1) = SY0(1)
655-
ELSE
656-
STY0(1) = SX0(1)
651+
IF (KI.EQ.1) THEN
652+
SX0(1) = 42.0E0
653+
SY0(1) = 43.0E0
654+
IF (N.EQ.0) THEN
655+
STY0(1) = SY0(1)
656+
ELSE
657+
STY0(1) = SX0(1)
658+
END IF
659+
LINCX = INCX
660+
INCX = 0
661+
LINCY = INCY
662+
INCY = 0
663+
CALL SCOPY(N,SX0,INCX,SY0,INCY)
664+
CALL STEST(1,SY0,STY0,SSIZE2(1,1),1.0E0)
665+
INCX = LINCX
666+
INCY = LINCY
657667
END IF
658-
CALL SCOPY(N,SX0,0,SY0,0)
659-
CALL STEST(1,SY0,STY0,SSIZE2(1,1),1.0E0)
660668
ELSE IF (ICASE.EQ.6) THEN
661669
* .. SSWAP ..
662670
CALL SSWAP(N,SX,INCX,SY,INCY)

‎BLAS/TESTING/zblat1.f

Lines changed: 18 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -344,7 +344,8 @@ SUBROUTINE CHECK2(SFAC)
344344
LOGICAL PASS
345345
* .. Local Scalars ..
346346
COMPLEX*16 CA
347-
INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
347+
INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
348+
+ MX, MY
348349
* .. Local Arrays ..
349350
COMPLEX*16 CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
350351
+ CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
@@ -564,15 +565,23 @@ SUBROUTINE CHECK2(SFAC)
564565
* .. ZCOPY ..
565566
CALL ZCOPY(N,CX,INCX,CY,INCY)
566567
CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0)
567-
CX0(1) = (42.0D0,43.0D0)
568-
CY0(1) = (44.0D0,45.0D0)
569-
IF (N.EQ.0) THEN
570-
CTY0(1) = CY0(1)
571-
ELSE
572-
CTY0(1) = CX0(1)
568+
IF (KI.EQ.1) THEN
569+
CX0(1) = (42.0D0,43.0D0)
570+
CY0(1) = (44.0D0,45.0D0)
571+
IF (N.EQ.0) THEN
572+
CTY0(1) = CY0(1)
573+
ELSE
574+
CTY0(1) = CX0(1)
575+
END IF
576+
LINCX = INCX
577+
INCX = 0
578+
LINCY = INCY
579+
INCY = 0
580+
CALL ZCOPY(N,CX0,INCX,CY0,INCY)
581+
CALL CTEST(1,CY0,CTY0,CSIZE3,1.0D0)
582+
INCX = LINCX
583+
INCY = LINCY
573584
END IF
574-
CALL ZCOPY(N,CX0,0,CY0,0)
575-
CALL CTEST(1,CY0,CTY0,CSIZE3,1.0D0)
576585
ELSE IF (ICASE.EQ.5) THEN
577586
* .. ZSWAP ..
578587
CALL ZSWAP(N,CX,INCX,CY,INCY)

‎SRC/dlacn2.f

Lines changed: 18 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -160,7 +160,7 @@ SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
160160
* ..
161161
* .. Local Scalars ..
162162
INTEGER I, JLAST
163-
DOUBLE PRECISION ALTSGN, ESTOLD, TEMP
163+
DOUBLE PRECISION ALTSGN, ESTOLD, TEMP, XS
164164
* ..
165165
* .. External Functions ..
166166
INTEGER IDAMAX
@@ -171,7 +171,7 @@ SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
171171
EXTERNAL DCOPY
172172
* ..
173173
* .. Intrinsic Functions ..
174-
INTRINSIC ABS, DBLE, NINT, SIGN
174+
INTRINSIC ABS, DBLE, NINT
175175
* ..
176176
* .. Executable Statements ..
177177
*
@@ -199,7 +199,11 @@ SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
199199
EST = DASUM( N, X, 1 )
200200
*
201201
DO 30 I = 1, N
202-
X( I ) = SIGN( ONE, X( I ) )
202+
IF( X(I).GE.ZERO ) THEN
203+
X(I) = ONE
204+
ELSE
205+
X(I) = -ONE
206+
END IF
203207
ISGN( I ) = NINT( X( I ) )
204208
30 CONTINUE
205209
KASE = 2
@@ -232,7 +236,12 @@ SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
232236
ESTOLD = EST
233237
EST = DASUM( N, V, 1 )
234238
DO 80 I = 1, N
235-
IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
239+
IF( X(I).GE.ZERO ) THEN
240+
XS = ONE
241+
ELSE
242+
XS = -ONE
243+
END IF
244+
IF( NINT( XS ).NE.ISGN( I ) )
236245
$ GO TO 90
237246
80 CONTINUE
238247
* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
@@ -244,7 +253,11 @@ SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
244253
$ GO TO 120
245254
*
246255
DO 100 I = 1, N
247-
X( I ) = SIGN( ONE, X( I ) )
256+
IF( X(I).GE.ZERO ) THEN
257+
X(I) = ONE
258+
ELSE
259+
X(I) = -ONE
260+
END IF
248261
ISGN( I ) = NINT( X( I ) )
249262
100 CONTINUE
250263
KASE = 2

‎SRC/slacn2.f

Lines changed: 18 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -160,7 +160,7 @@ SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
160160
* ..
161161
* .. Local Scalars ..
162162
INTEGER I, JLAST
163-
REAL ALTSGN, ESTOLD, TEMP
163+
REAL ALTSGN, ESTOLD, TEMP, XS
164164
* ..
165165
* .. External Functions ..
166166
INTEGER ISAMAX
@@ -171,7 +171,7 @@ SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
171171
EXTERNAL SCOPY
172172
* ..
173173
* .. Intrinsic Functions ..
174-
INTRINSIC ABS, NINT, REAL, SIGN
174+
INTRINSIC ABS, NINT, REAL
175175
* ..
176176
* .. Executable Statements ..
177177
*
@@ -199,7 +199,11 @@ SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
199199
EST = SASUM( N, X, 1 )
200200
*
201201
DO 30 I = 1, N
202-
X( I ) = SIGN( ONE, X( I ) )
202+
IF( X(I).GE.ZERO ) THEN
203+
X(I) = ONE
204+
ELSE
205+
X(I) = -ONE
206+
END IF
203207
ISGN( I ) = NINT( X( I ) )
204208
30 CONTINUE
205209
KASE = 2
@@ -232,7 +236,12 @@ SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
232236
ESTOLD = EST
233237
EST = SASUM( N, V, 1 )
234238
DO 80 I = 1, N
235-
IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
239+
IF( X(I).GE.ZERO ) THEN
240+
XS = ONE
241+
ELSE
242+
XS = -ONE
243+
END IF
244+
IF( NINT( XS ).NE.ISGN( I ) )
236245
$ GO TO 90
237246
80 CONTINUE
238247
* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
@@ -244,7 +253,11 @@ SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
244253
$ GO TO 120
245254
*
246255
DO 100 I = 1, N
247-
X( I ) = SIGN( ONE, X( I ) )
256+
IF( X(I).GE.ZERO ) THEN
257+
X(I) = ONE
258+
ELSE
259+
X(I) = -ONE
260+
END IF
248261
ISGN( I ) = NINT( X( I ) )
249262
100 CONTINUE
250263
KASE = 2

0 commit comments

Comments
 (0)