From 968119f2bb9c30bca144353185cf079669ff4afa Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 21 Apr 2026 10:53:22 +0200 Subject: [PATCH] Optimize looping over the lower triangular in fat matrix cases --- SRC/clacpy.f | 2 +- SRC/clantr.f | 14 +++++++------- SRC/clascl.f | 2 +- SRC/dlacpy.f | 2 +- SRC/dlantr.f | 14 +++++++------- SRC/dlascl.f | 2 +- SRC/slacpy.f | 2 +- SRC/slantr.f | 14 +++++++------- SRC/slascl.f | 2 +- SRC/zlacpy.f | 2 +- SRC/zlantr.f | 14 +++++++------- SRC/zlascl.f | 2 +- 12 files changed, 36 insertions(+), 36 deletions(-) diff --git a/SRC/clacpy.f b/SRC/clacpy.f index f224562f6..0e1a88e70 100644 --- a/SRC/clacpy.f +++ b/SRC/clacpy.f @@ -134,7 +134,7 @@ SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB ) 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE diff --git a/SRC/clantr.f b/SRC/clantr.f index c91bec250..a671f60a2 100644 --- a/SRC/clantr.f +++ b/SRC/clantr.f @@ -193,7 +193,7 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, 10 CONTINUE 20 CONTINUE ELSE - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -212,7 +212,7 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, 50 CONTINUE 60 CONTINUE ELSE - DO 80 J = 1, N + DO 80 J = 1, MIN( M, N ) DO 70 I = J, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -243,7 +243,7 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE - DO 140 J = 1, N + DO 140 J = 1, MIN( M, N ) IF( UDIAG ) THEN SUM = ONE DO 120 I = J + 1, M @@ -290,7 +290,7 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, DO 220 I = N + 1, M WORK( I ) = ZERO 220 CONTINUE - DO 240 J = 1, N + DO 240 J = 1, MIN( M, N ) DO 230 I = J + 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 230 CONTINUE @@ -299,7 +299,7 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, DO 250 I = 1, M WORK( I ) = ZERO 250 CONTINUE - DO 270 J = 1, N + DO 270 J = 1, MIN( M, N ) DO 260 I = J, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 260 CONTINUE @@ -336,14 +336,14 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = REAL( MIN( M, N ) ) - DO 310 J = 1, N + DO 310 J = 1, MIN( M, N ) CALL CLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, $ SUM ) 310 CONTINUE ELSE SCALE = ZERO SUM = ONE - DO 320 J = 1, N + DO 320 J = 1, MIN( M, N ) CALL CLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF diff --git a/SRC/clascl.f b/SRC/clascl.f index 65cfe7e3d..33716bf75 100644 --- a/SRC/clascl.f +++ b/SRC/clascl.f @@ -291,7 +291,7 @@ SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, * * Lower triangular matrix * - DO 50 J = 1, N + DO 50 J = 1, MIN( M, N ) DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE diff --git a/SRC/dlacpy.f b/SRC/dlacpy.f index 6a1933d80..ae8cc7aa6 100644 --- a/SRC/dlacpy.f +++ b/SRC/dlacpy.f @@ -133,7 +133,7 @@ SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE diff --git a/SRC/dlantr.f b/SRC/dlantr.f index 8c80a2f54..69804b52b 100644 --- a/SRC/dlantr.f +++ b/SRC/dlantr.f @@ -191,7 +191,7 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, 10 CONTINUE 20 CONTINUE ELSE - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -210,7 +210,7 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, 50 CONTINUE 60 CONTINUE ELSE - DO 80 J = 1, N + DO 80 J = 1, MIN( M, N ) DO 70 I = J, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -241,7 +241,7 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE - DO 140 J = 1, N + DO 140 J = 1, MIN( M, N ) IF( UDIAG ) THEN SUM = ONE DO 120 I = J + 1, M @@ -288,7 +288,7 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, DO 220 I = N + 1, M WORK( I ) = ZERO 220 CONTINUE - DO 240 J = 1, N + DO 240 J = 1, MIN (M, N ) DO 230 I = J + 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 230 CONTINUE @@ -297,7 +297,7 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, DO 250 I = 1, M WORK( I ) = ZERO 250 CONTINUE - DO 270 J = 1, N + DO 270 J = 1, MIN( M, N ) DO 260 I = J, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 260 CONTINUE @@ -334,14 +334,14 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = MIN( M, N ) - DO 310 J = 1, N + DO 310 J = 1, MIN( M, N ) CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, $ SUM ) 310 CONTINUE ELSE SCALE = ZERO SUM = ONE - DO 320 J = 1, N + DO 320 J = 1, MIN( M, N ) CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF diff --git a/SRC/dlascl.f b/SRC/dlascl.f index 79ff0d2c8..5db6fc40b 100644 --- a/SRC/dlascl.f +++ b/SRC/dlascl.f @@ -291,7 +291,7 @@ SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, * * Lower triangular matrix * - DO 50 J = 1, N + DO 50 J = 1, MIN( M, N ) DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE diff --git a/SRC/slacpy.f b/SRC/slacpy.f index b7a028e44..8214332dc 100644 --- a/SRC/slacpy.f +++ b/SRC/slacpy.f @@ -133,7 +133,7 @@ SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE diff --git a/SRC/slantr.f b/SRC/slantr.f index c4bcedc26..b27b3b671 100644 --- a/SRC/slantr.f +++ b/SRC/slantr.f @@ -191,7 +191,7 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, 10 CONTINUE 20 CONTINUE ELSE - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -210,7 +210,7 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, 50 CONTINUE 60 CONTINUE ELSE - DO 80 J = 1, N + DO 80 J = 1, MIN( M, N ) DO 70 I = J, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -241,7 +241,7 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE - DO 140 J = 1, N + DO 140 J = 1, MIN( M, N ) IF( UDIAG ) THEN SUM = ONE DO 120 I = J + 1, M @@ -288,7 +288,7 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, DO 220 I = N + 1, M WORK( I ) = ZERO 220 CONTINUE - DO 240 J = 1, N + DO 240 J = 1, MIN( M, N ) DO 230 I = J + 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 230 CONTINUE @@ -297,7 +297,7 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, DO 250 I = 1, M WORK( I ) = ZERO 250 CONTINUE - DO 270 J = 1, N + DO 270 J = 1, MIN( M, N ) DO 260 I = J, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 260 CONTINUE @@ -334,14 +334,14 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = REAL( MIN( M, N ) ) - DO 310 J = 1, N + DO 310 J = 1, MIN ( M, N ) CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, $ SUM ) 310 CONTINUE ELSE SCALE = ZERO SUM = ONE - DO 320 J = 1, N + DO 320 J = 1, MIN( M, N ) CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF diff --git a/SRC/slascl.f b/SRC/slascl.f index c9b8d3e7b..84b601022 100644 --- a/SRC/slascl.f +++ b/SRC/slascl.f @@ -291,7 +291,7 @@ SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, * * Lower triangular matrix * - DO 50 J = 1, N + DO 50 J = 1, MIN( M, N ) DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE diff --git a/SRC/zlacpy.f b/SRC/zlacpy.f index e5d067ed8..334553046 100644 --- a/SRC/zlacpy.f +++ b/SRC/zlacpy.f @@ -134,7 +134,7 @@ SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE diff --git a/SRC/zlantr.f b/SRC/zlantr.f index 5216747c8..73a7bc621 100644 --- a/SRC/zlantr.f +++ b/SRC/zlantr.f @@ -193,7 +193,7 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, 10 CONTINUE 20 CONTINUE ELSE - DO 40 J = 1, N + DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -212,7 +212,7 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, 50 CONTINUE 60 CONTINUE ELSE - DO 80 J = 1, N + DO 80 J = 1, MIN( M, N ) DO 70 I = J, M SUM = ABS( A( I, J ) ) IF( VALUE .LT. SUM .OR. @@ -243,7 +243,7 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 110 CONTINUE ELSE - DO 140 J = 1, N + DO 140 J = 1, MIN( M, N ) IF( UDIAG ) THEN SUM = ONE DO 120 I = J + 1, M @@ -290,7 +290,7 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, DO 220 I = N + 1, M WORK( I ) = ZERO 220 CONTINUE - DO 240 J = 1, N + DO 240 J = 1, MIN( M, N ) DO 230 I = J + 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 230 CONTINUE @@ -299,7 +299,7 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, DO 250 I = 1, M WORK( I ) = ZERO 250 CONTINUE - DO 270 J = 1, N + DO 270 J = 1, MIN( M, N ) DO 260 I = J, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 260 CONTINUE @@ -336,14 +336,14 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, IF( LSAME( DIAG, 'U' ) ) THEN SCALE = ONE SUM = MIN( M, N ) - DO 310 J = 1, N + DO 310 J = 1, MIN( M, N ) CALL ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, $ SUM ) 310 CONTINUE ELSE SCALE = ZERO SUM = ONE - DO 320 J = 1, N + DO 320 J = 1, MIN( M, N ) CALL ZLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) 320 CONTINUE END IF diff --git a/SRC/zlascl.f b/SRC/zlascl.f index b44b40f90..a1262f1ad 100644 --- a/SRC/zlascl.f +++ b/SRC/zlascl.f @@ -291,7 +291,7 @@ SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, * * Lower triangular matrix * - DO 50 J = 1, N + DO 50 J = 1, MIN( M, N ) DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE