Skip to content

Commit fa7350f

Browse files
weslleyspereiraweslleyspereira
authored
Merge 72e100c into 5d4180c 
2 parents 5d4180c + 72e100c commit fa7350f

File tree

4 files changed

+60
-96
lines changed

4 files changed

+60
-96
lines changed

‎BLAS/SRC/crotg.f90‎

Lines changed: 15 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -122,7 +122,7 @@ subroutine CROTG( a, b, c, s )
122122
complex(wp) :: a, b, s
123123
! ..
124124
! .. Local Scalars ..
125-
real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
125+
real(wp) :: d, f1, f2, g1, g2, h2, w2, u, uu, v, vv, w
126126
complex(wp) :: f, fs, g, gs, r, t
127127
! ..
128128
! .. Intrinsic Functions ..
@@ -149,8 +149,7 @@ subroutine CROTG( a, b, c, s )
149149
!
150150
! Use unscaled algorithm
151151
!
152-
g2 = ABSSQ( g )
153-
d = sqrt( g2 )
152+
d = abs( g )
154153
s = conjg( g ) / d
155154
r = d
156155
else
@@ -160,8 +159,7 @@ subroutine CROTG( a, b, c, s )
160159
u = min( safmax, max( safmin, g1 ) )
161160
uu = one / u
162161
gs = g*uu
163-
g2 = ABSSQ( gs )
164-
d = sqrt( g2 )
162+
d = abs( g2 )
165163
s = conjg( gs ) / d
166164
r = d*u
167165
end if
@@ -176,15 +174,10 @@ subroutine CROTG( a, b, c, s )
176174
f2 = ABSSQ( f )
177175
g2 = ABSSQ( g )
178176
h2 = f2 + g2
179-
if( f2 > rtmin .and. h2 < rtmax ) then
180-
d = sqrt( f2*h2 )
181-
else
182-
d = sqrt( f2 )*sqrt( h2 )
183-
end if
184-
p = 1 / d
185-
c = f2*p
186-
s = conjg( g )*( f*p )
187-
r = f*( h2*p )
177+
d = sqrt( one + ( g2/f2 ) )
178+
r = f*d
179+
c = one / d
180+
s = conjg( g )*( r / h2 )
188181
else
189182
!
190183
! Use scaled algorithm
@@ -201,27 +194,25 @@ subroutine CROTG( a, b, c, s )
201194
v = min( safmax, max( safmin, f1 ) )
202195
vv = one / v
203196
w = v * uu
197+
w2 = w**2
204198
fs = f*vv
205199
f2 = ABSSQ( fs )
206-
h2 = f2*w**2 + g2
200+
h2 = f2*w2 + g2
207201
else
208202
!
209203
! Otherwise use the same scaling for f and g.
210204
!
211205
w = one
206+
w2 = one
212207
fs = f*uu
213208
f2 = ABSSQ( fs )
214209
h2 = f2 + g2
215210
end if
216-
if( f2 > rtmin .and. h2 < rtmax ) then
217-
d = sqrt( f2*h2 )
218-
else
219-
d = sqrt( f2 )*sqrt( h2 )
220-
end if
221-
p = 1 / d
222-
c = ( f2*p )*w
223-
s = conjg( gs )*( fs*p )
224-
r = ( fs*( h2*p ) )*u
211+
d = sqrt( w2 + ( g2/f2 ) )
212+
c = w / d
213+
r = fs*d
214+
s = conjg( gs )*( r / h2 )
215+
r = r*u
225216
end if
226217
end if
227218
a = r

‎BLAS/SRC/zrotg.f90‎

Lines changed: 15 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -122,7 +122,7 @@ subroutine ZROTG( a, b, c, s )
122122
complex(wp) :: a, b, s
123123
! ..
124124
! .. Local Scalars ..
125-
real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
125+
real(wp) :: d, f1, f2, g1, g2, h2, w2, u, uu, v, vv, w
126126
complex(wp) :: f, fs, g, gs, r, t
127127
! ..
128128
! .. Intrinsic Functions ..
@@ -149,8 +149,7 @@ subroutine ZROTG( a, b, c, s )
149149
!
150150
! Use unscaled algorithm
151151
!
152-
g2 = ABSSQ( g )
153-
d = sqrt( g2 )
152+
d = abs( g )
154153
s = conjg( g ) / d
155154
r = d
156155
else
@@ -160,8 +159,7 @@ subroutine ZROTG( a, b, c, s )
160159
u = min( safmax, max( safmin, g1 ) )
161160
uu = one / u
162161
gs = g*uu
163-
g2 = ABSSQ( gs )
164-
d = sqrt( g2 )
162+
d = abs( g2 )
165163
s = conjg( gs ) / d
166164
r = d*u
167165
end if
@@ -176,15 +174,10 @@ subroutine ZROTG( a, b, c, s )
176174
f2 = ABSSQ( f )
177175
g2 = ABSSQ( g )
178176
h2 = f2 + g2
179-
if( f2 > rtmin .and. h2 < rtmax ) then
180-
d = sqrt( f2*h2 )
181-
else
182-
d = sqrt( f2 )*sqrt( h2 )
183-
end if
184-
p = 1 / d
185-
c = f2*p
186-
s = conjg( g )*( f*p )
187-
r = f*( h2*p )
177+
d = sqrt( one + ( g2/f2 ) )
178+
r = f*d
179+
c = one / d
180+
s = conjg( g )*( r / h2 )
188181
else
189182
!
190183
! Use scaled algorithm
@@ -201,27 +194,25 @@ subroutine ZROTG( a, b, c, s )
201194
v = min( safmax, max( safmin, f1 ) )
202195
vv = one / v
203196
w = v * uu
197+
w2 = w**2
204198
fs = f*vv
205199
f2 = ABSSQ( fs )
206-
h2 = f2*w**2 + g2
200+
h2 = f2*w2 + g2
207201
else
208202
!
209203
! Otherwise use the same scaling for f and g.
210204
!
211205
w = one
206+
w2 = one
212207
fs = f*uu
213208
f2 = ABSSQ( fs )
214209
h2 = f2 + g2
215210
end if
216-
if( f2 > rtmin .and. h2 < rtmax ) then
217-
d = sqrt( f2*h2 )
218-
else
219-
d = sqrt( f2 )*sqrt( h2 )
220-
end if
221-
p = 1 / d
222-
c = ( f2*p )*w
223-
s = conjg( gs )*( fs*p )
224-
r = ( fs*( h2*p ) )*u
211+
d = sqrt( w2 + ( g2/f2 ) )
212+
c = w / d
213+
r = fs*d
214+
s = conjg( gs )*( r / h2 )
215+
r = r*u
225216
end if
226217
end if
227218
a = r

‎SRC/clartg.f90‎

Lines changed: 15 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -129,7 +129,7 @@ subroutine CLARTG( f, g, c, s, r )
129129
complex(wp) f, g, r, s
130130
! ..
131131
! .. Local Scalars ..
132-
real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
132+
real(wp) :: d, f1, f2, g1, g2, h2, w2, u, uu, v, vv, w
133133
complex(wp) :: fs, gs, t
134134
! ..
135135
! .. Intrinsic Functions ..
@@ -154,8 +154,7 @@ subroutine CLARTG( f, g, c, s, r )
154154
!
155155
! Use unscaled algorithm
156156
!
157-
g2 = ABSSQ( g )
158-
d = sqrt( g2 )
157+
d = abs( g )
159158
s = conjg( g ) / d
160159
r = d
161160
else
@@ -165,8 +164,7 @@ subroutine CLARTG( f, g, c, s, r )
165164
u = min( safmax, max( safmin, g1 ) )
166165
uu = one / u
167166
gs = g*uu
168-
g2 = ABSSQ( gs )
169-
d = sqrt( g2 )
167+
d = abs( g2 )
170168
s = conjg( gs ) / d
171169
r = d*u
172170
end if
@@ -181,15 +179,10 @@ subroutine CLARTG( f, g, c, s, r )
181179
f2 = ABSSQ( f )
182180
g2 = ABSSQ( g )
183181
h2 = f2 + g2
184-
if( f2 > rtmin .and. h2 < rtmax ) then
185-
d = sqrt( f2*h2 )
186-
else
187-
d = sqrt( f2 )*sqrt( h2 )
188-
end if
189-
p = 1 / d
190-
c = f2*p
191-
s = conjg( g )*( f*p )
192-
r = f*( h2*p )
182+
d = sqrt( one + ( g2/f2 ) )
183+
r = f*d
184+
c = one / d
185+
s = conjg( g )*( r / h2 )
193186
else
194187
!
195188
! Use scaled algorithm
@@ -206,27 +199,25 @@ subroutine CLARTG( f, g, c, s, r )
206199
v = min( safmax, max( safmin, f1 ) )
207200
vv = one / v
208201
w = v * uu
202+
w2 = w**2
209203
fs = f*vv
210204
f2 = ABSSQ( fs )
211-
h2 = f2*w**2 + g2
205+
h2 = f2*w2 + g2
212206
else
213207
!
214208
! Otherwise use the same scaling for f and g.
215209
!
216210
w = one
211+
w2 = one
217212
fs = f*uu
218213
f2 = ABSSQ( fs )
219214
h2 = f2 + g2
220215
end if
221-
if( f2 > rtmin .and. h2 < rtmax ) then
222-
d = sqrt( f2*h2 )
223-
else
224-
d = sqrt( f2 )*sqrt( h2 )
225-
end if
226-
p = 1 / d
227-
c = ( f2*p )*w
228-
s = conjg( gs )*( fs*p )
229-
r = ( fs*( h2*p ) )*u
216+
d = sqrt( w2 + ( g2/f2 ) )
217+
c = w / d
218+
r = fs*d
219+
s = conjg( gs )*( r / h2 )
220+
r = r*u
230221
end if
231222
end if
232223
return

‎SRC/zlartg.f90‎

Lines changed: 15 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -129,7 +129,7 @@ subroutine ZLARTG( f, g, c, s, r )
129129
complex(wp) f, g, r, s
130130
! ..
131131
! .. Local Scalars ..
132-
real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
132+
real(wp) :: d, f1, f2, g1, g2, h2, w2, u, uu, v, vv, w
133133
complex(wp) :: fs, gs, t
134134
! ..
135135
! .. Intrinsic Functions ..
@@ -154,8 +154,7 @@ subroutine ZLARTG( f, g, c, s, r )
154154
!
155155
! Use unscaled algorithm
156156
!
157-
g2 = ABSSQ( g )
158-
d = sqrt( g2 )
157+
d = abs( g )
159158
s = conjg( g ) / d
160159
r = d
161160
else
@@ -165,8 +164,7 @@ subroutine ZLARTG( f, g, c, s, r )
165164
u = min( safmax, max( safmin, g1 ) )
166165
uu = one / u
167166
gs = g*uu
168-
g2 = ABSSQ( gs )
169-
d = sqrt( g2 )
167+
d = abs( g2 )
170168
s = conjg( gs ) / d
171169
r = d*u
172170
end if
@@ -181,15 +179,10 @@ subroutine ZLARTG( f, g, c, s, r )
181179
f2 = ABSSQ( f )
182180
g2 = ABSSQ( g )
183181
h2 = f2 + g2
184-
if( f2 > rtmin .and. h2 < rtmax ) then
185-
d = sqrt( f2*h2 )
186-
else
187-
d = sqrt( f2 )*sqrt( h2 )
188-
end if
189-
p = 1 / d
190-
c = f2*p
191-
s = conjg( g )*( f*p )
192-
r = f*( h2*p )
182+
d = sqrt( one + ( g2/f2 ) )
183+
r = f*d
184+
c = one / d
185+
s = conjg( g )*( r / h2 )
193186
else
194187
!
195188
! Use scaled algorithm
@@ -206,27 +199,25 @@ subroutine ZLARTG( f, g, c, s, r )
206199
v = min( safmax, max( safmin, f1 ) )
207200
vv = one / v
208201
w = v * uu
202+
w2 = w**2
209203
fs = f*vv
210204
f2 = ABSSQ( fs )
211-
h2 = f2*w**2 + g2
205+
h2 = f2*w2 + g2
212206
else
213207
!
214208
! Otherwise use the same scaling for f and g.
215209
!
216210
w = one
211+
w2 = one
217212
fs = f*uu
218213
f2 = ABSSQ( fs )
219214
h2 = f2 + g2
220215
end if
221-
if( f2 > rtmin .and. h2 < rtmax ) then
222-
d = sqrt( f2*h2 )
223-
else
224-
d = sqrt( f2 )*sqrt( h2 )
225-
end if
226-
p = 1 / d
227-
c = ( f2*p )*w
228-
s = conjg( gs )*( fs*p )
229-
r = ( fs*( h2*p ) )*u
216+
d = sqrt( w2 + ( g2/f2 ) )
217+
c = w / d
218+
r = fs*d
219+
s = conjg( gs )*( r / h2 )
220+
r = r*u
230221
end if
231222
end if
232223
return

0 commit comments

Comments
 (0)