stdlib_zrotg Subroutine

     pure subroutine stdlib_zrotg( a, b, c, s )
     !! The computation uses the formulas
     !! |x| = sqrt( Re(x)**2 + Im(x)**2 )
     !! sgn(x) = x / |x|  if x /= 0
     !! = 1        if x  = 0
     !! c = |a| / sqrt(|a|**2 + |b|**2)
     !! s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2)
     !! When a and b are real and r /= 0, the formulas simplify to
     !! r = sgn(a)*sqrt(|a|**2 + |b|**2)
     !! c = a / r
     !! s = b / r
     !! the same as in DROTG when |a| > |b|.  When |b| >= |a|, the
     !! sign of c and s will be different from those computed by DROTG
     !! if the signs of a and b are not the same.
        ! -- reference blas level1 routine --
        ! -- reference blas is a software package provided by univ. of tennessee,    --
        ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
        ! Constants 
        integer, parameter :: wp = kind(1._dp)
        ! Scaling Constants 
        ! Scalar Arguments 
        real(dp), intent(out) :: c
        complex(dp), intent(inout) :: a
        complex(dp), intent(in) :: b
        complex(dp), intent(out) :: s
        ! Local Scalars 
        real(dp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
        complex(dp) :: f, fs, g, gs, r, t
        ! Intrinsic Functions 
        intrinsic :: abs,aimag,conjg,max,min,real,sqrt
        ! Statement Functions 
        real(dp) :: abssq
        ! Statement Function Definitions 
        abssq( t ) = real( t,KIND=dp)**2 + aimag( t )**2
        ! Executable Statements 
        f = a
        g = b
        if( g == czero ) then
           c = one
           s = czero
           r = f
        else if( f == czero ) then
           c = zero
           g1 = max( abs(real(g,KIND=dp)), abs(aimag(g)) )
           if( g1 > rtmin .and. g1 < rtmax ) then
              ! use unscaled algorithm
              g2 = abssq( g )
              d = sqrt( g2 )
              s = conjg( g ) / d
              r = d
           else
              ! use scaled algorithm
              u = min( safmax, max( safmin, g1 ) )
              uu = one / u
              gs = g*uu
              g2 = abssq( gs )
              d = sqrt( g2 )
              s = conjg( gs ) / d
              r = d*u
           end if
        else
           f1 = max( abs(real(f,KIND=dp)), abs(aimag(f)) )
           g1 = max( abs(real(g,KIND=dp)), abs(aimag(g)) )
     if( f1 > rtmin .and. f1 < rtmax .and.          g1 > rtmin .and. g1 < rtmax ) then
              ! use unscaled algorithm
              f2 = abssq( f )
              g2 = abssq( g )
              h2 = f2 + g2
              if( f2 > rtmin .and. h2 < rtmax ) then
                 d = sqrt( f2*h2 )
              else
                 d = sqrt( f2 )*sqrt( h2 )
              end if
              p = 1 / d
              c = f2*p
              s = conjg( g )*( f*p )
              r = f*( h2*p )
           else
              ! use scaled algorithm
              u = min( safmax, max( safmin, f1, g1 ) )
              uu = one / u
              gs = g*uu
              g2 = abssq( gs )
              if( f1*uu < rtmin ) then
                 ! f is not well-scaled when scaled by g1.
                 ! use a different scaling for f.
                 v = min( safmax, max( safmin, f1 ) )
                 vv = one / v
                 w = v * uu
                 fs = f*vv
                 f2 = abssq( fs )
                 h2 = f2*w**2 + g2
              else
                 ! otherwise use the same scaling for f and g.
                 w = one
                 fs = f*uu
                 f2 = abssq( fs )
                 h2 = f2 + g2
              end if
              if( f2 > rtmin .and. h2 < rtmax ) then
                 d = sqrt( f2*h2 )
              else
                 d = sqrt( f2 )*sqrt( h2 )
              end if
              p = 1 / d
              c = ( f2*p )*w
              s = conjg( gs )*( fs*p )
              r = ( fs*( h2*p ) )*u
           end if
        end if
        a = r
        return
     end subroutine stdlib_zrotg