```001:       SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
002:      \$                   SNV, CSQ, SNQ )
003: *
004: *  -- LAPACK auxiliary routine (version 3.2) --
005: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
006: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
007: *     November 2006
008: *
009: *     .. Scalar Arguments ..
010:       LOGICAL            UPPER
011:       REAL               A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
012:      \$                   SNU, SNV
013: *     ..
014: *
015: *  Purpose
016: *  =======
017: *
018: *  SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
019: *  that if ( UPPER ) then
020: *
021: *            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
022: *                        ( 0  A3 )     ( x  x  )
023: *  and
024: *            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
025: *                        ( 0  B3 )     ( x  x  )
026: *
027: *  or if ( .NOT.UPPER ) then
028: *
029: *            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
030: *                        ( A2 A3 )     ( 0  x  )
031: *  and
032: *            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
033: *                        ( B2 B3 )     ( 0  x  )
034: *
035: *  The rows of the transformed A and B are parallel, where
036: *
037: *    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
038: *        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
039: *
040: *  Z' denotes the transpose of Z.
041: *
042: *
043: *  Arguments
044: *  =========
045: *
046: *  UPPER   (input) LOGICAL
047: *          = .TRUE.: the input matrices A and B are upper triangular.
048: *          = .FALSE.: the input matrices A and B are lower triangular.
049: *
050: *  A1      (input) REAL
051: *  A2      (input) REAL
052: *  A3      (input) REAL
053: *          On entry, A1, A2 and A3 are elements of the input 2-by-2
054: *          upper (lower) triangular matrix A.
055: *
056: *  B1      (input) REAL
057: *  B2      (input) REAL
058: *  B3      (input) REAL
059: *          On entry, B1, B2 and B3 are elements of the input 2-by-2
060: *          upper (lower) triangular matrix B.
061: *
062: *  CSU     (output) REAL
063: *  SNU     (output) REAL
064: *          The desired orthogonal matrix U.
065: *
066: *  CSV     (output) REAL
067: *  SNV     (output) REAL
068: *          The desired orthogonal matrix V.
069: *
070: *  CSQ     (output) REAL
071: *  SNQ     (output) REAL
072: *          The desired orthogonal matrix Q.
073: *
074: *  =====================================================================
075: *
076: *     .. Parameters ..
077:       REAL               ZERO
078:       PARAMETER          ( ZERO = 0.0E+0 )
079: *     ..
080: *     .. Local Scalars ..
081:       REAL               A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
082:      \$                   AVB21, AVB22, CSL, CSR, D, S1, S2, SNL,
083:      \$                   SNR, UA11R, UA22R, VB11R, VB22R, B, C, R, UA11,
084:      \$                   UA12, UA21, UA22, VB11, VB12, VB21, VB22
085: *     ..
086: *     .. External Subroutines ..
087:       EXTERNAL           SLARTG, SLASV2
088: *     ..
089: *     .. Intrinsic Functions ..
090:       INTRINSIC          ABS
091: *     ..
092: *     .. Executable Statements ..
093: *
094:       IF( UPPER ) THEN
095: *
096: *        Input matrices A and B are upper triangular matrices
097: *
098: *        Form matrix C = A*adj(B) = ( a b )
099: *                                   ( 0 d )
100: *
101:          A = A1*B3
102:          D = A3*B1
103:          B = A2*B1 - A1*B2
104: *
105: *        The SVD of real 2-by-2 triangular C
106: *
107: *         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
108: *         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
109: *
110:          CALL SLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
111: *
112:          IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
113:      \$        THEN
114: *
115: *           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
116: *           and (1,2) element of |U|'*|A| and |V|'*|B|.
117: *
118:             UA11R = CSL*A1
119:             UA12 = CSL*A2 + SNL*A3
120: *
121:             VB11R = CSR*B1
122:             VB12 = CSR*B2 + SNR*B3
123: *
124:             AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
125:             AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
126: *
127: *           zero (1,2) elements of U'*A and V'*B
128: *
129:             IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
130:                IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
131:      \$             ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
132:                   CALL SLARTG( -UA11R, UA12, CSQ, SNQ, R )
133:                ELSE
134:                   CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
135:                END IF
136:             ELSE
137:                CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
138:             END IF
139: *
140:             CSU = CSL
141:             SNU = -SNL
142:             CSV = CSR
143:             SNV = -SNR
144: *
145:          ELSE
146: *
147: *           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
148: *           and (2,2) element of |U|'*|A| and |V|'*|B|.
149: *
150:             UA21 = -SNL*A1
151:             UA22 = -SNL*A2 + CSL*A3
152: *
153:             VB21 = -SNR*B1
154:             VB22 = -SNR*B2 + CSR*B3
155: *
156:             AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
157:             AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
158: *
159: *           zero (2,2) elements of U'*A and V'*B, and then swap.
160: *
161:             IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
162:                IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
163:      \$             ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
164:                   CALL SLARTG( -UA21, UA22, CSQ, SNQ, R )
165:                ELSE
166:                   CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
167:                END IF
168:             ELSE
169:                CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
170:             END IF
171: *
172:             CSU = SNL
173:             SNU = CSL
174:             CSV = SNR
175:             SNV = CSR
176: *
177:          END IF
178: *
179:       ELSE
180: *
181: *        Input matrices A and B are lower triangular matrices
182: *
183: *        Form matrix C = A*adj(B) = ( a 0 )
184: *                                   ( c d )
185: *
186:          A = A1*B3
187:          D = A3*B1
188:          C = A2*B3 - A3*B2
189: *
190: *        The SVD of real 2-by-2 triangular C
191: *
192: *         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
193: *         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
194: *
195:          CALL SLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
196: *
197:          IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
198:      \$        THEN
199: *
200: *           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
201: *           and (2,1) element of |U|'*|A| and |V|'*|B|.
202: *
203:             UA21 = -SNR*A1 + CSR*A2
204:             UA22R = CSR*A3
205: *
206:             VB21 = -SNL*B1 + CSL*B2
207:             VB22R = CSL*B3
208: *
209:             AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
210:             AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
211: *
212: *           zero (2,1) elements of U'*A and V'*B.
213: *
214:             IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
215:                IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
216:      \$             ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
217:                   CALL SLARTG( UA22R, UA21, CSQ, SNQ, R )
218:                ELSE
219:                   CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
220:                END IF
221:             ELSE
222:                CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
223:             END IF
224: *
225:             CSU = CSR
226:             SNU = -SNR
227:             CSV = CSL
228:             SNV = -SNL
229: *
230:          ELSE
231: *
232: *           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
233: *           and (1,1) element of |U|'*|A| and |V|'*|B|.
234: *
235:             UA11 = CSR*A1 + SNR*A2
236:             UA12 = SNR*A3
237: *
238:             VB11 = CSL*B1 + SNL*B2
239:             VB12 = SNL*B3
240: *
241:             AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
242:             AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
243: *
244: *           zero (1,1) elements of U'*A and V'*B, and then swap.
245: *
246:             IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
247:                IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
248:      \$             ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
249:                   CALL SLARTG( UA12, UA11, CSQ, SNQ, R )
250:                ELSE
251:                   CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
252:                END IF
253:             ELSE
254:                CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
255:             END IF
256: *
257:             CSU = SNR
258:             SNU = CSR
259:             CSV = SNL
260:             SNV = CSL
261: *
262:          END IF
263: *
264:       END IF
265: *
266:       RETURN
267: *
268: *     End of SLAGS2
269: *
270:       END
271: ```