120 parameter( two = 2.0e+0, one = 1.0e+0, zero = 0.0e+0 )
122 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
127 REAL d, di, dr, eps, f2, f2s, g2, g2s, safmin,
128 $ safmn2, safmx2, scale
137 INTRINSIC abs, aimag, cmplx, conjg, int, log, max,
REAL,
144 abs1( ff ) = max( abs(
REAL( FF ) ), abs( aimag( ff ) ) )
145 abssq( ff ) =
REAL( ff )**2 + aimag( ff )**2
151 safmn2 =
slamch(
'B' )**int( log( safmin / eps ) /
152 $ log(
slamch(
'B' ) ) / two )
153 safmx2 = one / safmn2
154 scale = max( abs1( f ), abs1( g ) )
158 IF( scale.GE.safmx2 )
THEN
164 IF( scale.GE.safmx2 )
166 ELSE IF( scale.LE.safmn2 )
THEN
167 IF( g.EQ.czero.OR.
sisnan( abs( g ) ) )
THEN
178 IF( scale.LE.safmn2 )
183 IF( f2.LE.max( g2, one )*safmin )
THEN
187 IF( f.EQ.czero )
THEN
189 r =
slapy2(
REAL( G ), aimag( g ) )
191 d =
slapy2(
REAL( GS ), aimag( gs ) )
192 sn = cmplx(
REAL( GS ) / d, -aimag( gs ) / d )
195 f2s =
slapy2(
REAL( FS ), aimag( fs ) )
209 IF( abs1( f ).GT.one )
THEN
210 d =
slapy2(
REAL( F ), aimag( f ) )
211 ff = cmplx(
REAL( F ) / d, aimag( f ) / d )
213 dr = safmx2*
REAL( f )
214 di = safmx2*aimag( f )
216 ff = cmplx( dr / d, di / d )
218 sn = ff*cmplx(
REAL( GS ) / g2s, -aimag( gs ) / g2s )
226 f2s = sqrt( one+g2 / f2 )
228 r = cmplx( f2s*
REAL( FS ), f2s*aimag( fs ) )
232 sn = cmplx(
REAL( R ) / d, aimag( r ) / d )
234 IF( count.NE.0 )
THEN
235 IF( count.GT.0 )
THEN