program roots
use, intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
use M_attr, only : attr, attr_mode, attr_update
! Calculate and print the roots of a quadratic formula even if they are complex
implicit none
integer,parameter :: dp=kind(0.0d0)
real(kind=dp) :: a, b, c, discriminant
real(kind=dp) :: x1, x2, x ! Real roots of the equation
real(kind=dp) :: x_real ! Real part of complex root of the equation
REAL(kind=dp) :: x_complex ! Imaginary part of complex root of the equation
character(len=256) :: message
integer :: ios
character(len=1) :: paws
character(len=1024) :: buffer
character(len=*),parameter :: numbers='("<B><w><bo> ",*("(",g0.8,",",g0.8,")":,1x))'
character(len=:),allocatable :: TERM
if(system_isatty(stdout))then ! ISATTY() is an extension, but found in Intel, GNU, PGI, ... compiler
call attr_mode('color')
else
call attr_mode('plain')
endif
TERM=system_getenv('TERM','vt102') ! perhaps change or add strings based on terminal type
select case(TERM)
case('xterm')
call attr_update('mono',attr( '<esc>]11;black<bel><esc>]10;white<bel>' )) ! change default bg and fg
case('screen')
end select
INFINITE: do
! clear screen, set attributes and print messages
call text("<reset><clear>")
call text("For the quadratic equation <m>A</m><g>*x**2 +<m>B</m><g>*x + <m>C</m> ")
write(stdout,'(*(a))',advance='no') &
& attr('<B><w><bo>',chars=80), &
& char(13),&
& attr('<B><g><bo>enter coefficients <m>A,B,C</m><g>:<y><gt><ul>',&
& reset=.false.,chars=80)
read(stdin,*,iostat=ios,iomsg=message)a,b,c
write(stdout,'(a)',advance='no')attr('<reset>')
if(ios.ne.0)then
write(stdout,*)
write(stdout,'(*(g0))')ios,' ',trim(message)
rewind(unit=stdin,iostat=ios)
backspace(unit=stdin,iostat=ios)
else
! Given the equation "A*X**2 + B*X + C = 0"
! Use the quadratic formula to determine the root values of the equation.
! prompt for new value
call text()
call text('Given the equation')
call text()
write(buffer,'(*(g0.8))') '<B><w><bo> ',a,'<m>*X**2</m><w> + ',b,'<m>*X</m><w> + ',c,' = 0'
call text(buffer)
call text()
discriminant = b**2 - 4*a*c
if (a.eq.0)then
call text('<ERROR> <m>If <m>a</m><g> is zero this is a linear, not quadratic equation')
elseif ( discriminant>0 ) then
call text('the <m>roots</m><g> (ie. "x intercepts") are <m>real<m><g> so the parabola ')
call text('crosses the x-axis at <m>two points</m><g>:')
call text()
x1 = ( -b + sqrt(discriminant)) / (2 * a)
x2 = ( -b - sqrt(discriminant)) / (2 * a)
write(buffer,numbers)x1,0.0d0
call text(buffer)
write(buffer,numbers)x2,0.0d0
call text(buffer)
call text()
elseif ( discriminant==0 ) then
call text('the <m>roots</m><g> (ie. "x intercepts") are repeated <m>(real and equal)</m><g>')
call text('so the parabola just touches the x-axis at:')
call text()
if(b.ne.0)then
x = (-b) / (2 * a)
else
x = 0.0d0
endif
write(buffer,numbers)x,0.0d0
call text(buffer)
call text()
else
call text('the <m>roots</m><g>(ie. "x intercepts") are <m>complex</m><g>:')
x_real = (-b)/(2 * a)
x_complex = sqrt (abs(discriminant)) / (2 * a)
call text()
WRITE(buffer,'(a,*("(",g0.8,", +i",g0.8,")",:,1x))') '<B><w><bo> ', x_real,x_complex
call text(buffer)
WRITE(buffer,'(a,*("(",g0.8,", -i",g0.8,")",:,1x))') '<B><w><bo> ', x_real,x_complex
call text(buffer)
call text()
endif
call text('with')
call text()
write(buffer,'(g0,*(g0.8,1x))')"<B><w><bo> <m>discriminate</m><w> = ", discriminant
call text(buffer)
call text()
endif
write(stdout,'(*(g0))',advance='no')attr('<B><e>press <g>return</g><e> to continue, "<g>q</g><e>" to quit:',chars=79)
read(stdin,advance='yes',iostat=ios,fmt='(a)',iomsg=message)paws
if(paws.ne.'')exit INFINITE
enddo INFINITE
contains
subroutine text(string)
character(len=*),intent(in),optional :: string
if(present(string))then
write(stdout,'(*(g0))') attr('<B><g><bo>'//trim(string),chars=80)
else
write(stdout,'(*(g0))') attr('<B><g><bo>',chars=80)
endif
end subroutine text
!> call compiler-specific ISATTY() function or return .FALSE.
#undef ISATTY
#ifdef __INTEL_COMPILER
function system_isatty(lun)
use IFPORT
integer,intent(in) :: lun
logical :: system_isatty
system_isatty=isatty(lun)
end function system_isatty
#define ISATTY
#endif
#ifdef __NVCOMPILER_MAJOR__X
! __NVCOMPILER_MAJOR__ __NVCOMPILER_MINOR__ __NVCOMPILER_PATCHLEVEL__
function system_isatty(lun)
use DFPORT
integer,intent(in) :: lun
logical :: system_isatty
system_isatty=isatty(lun)
end function system_isatty
#define ISATTY
#endif
#ifdef __GFORTRAN__
function system_isatty(lun)
integer,intent(in) :: lun
logical :: system_isatty
system_isatty=isatty(lun)
end function system_isatty
#define ISATTY
#endif
#ifndef ISATTY
function system_isatty(lun)
integer,intent(in) :: lun
logical :: system_isatty
system_isatty=.false.
end function system_isatty
#define ISATTY
#endif
function system_getenv(name,default) result(value)
!$@(#) M_system::system_getenv(3f): call get_environment_variable as a function with a default value(3f)
character(len=*),intent(in) :: name
character(len=*),intent(in),optional :: default
integer :: howbig
integer :: stat
character(len=:),allocatable :: value
if(NAME.ne.'')then
call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value
if(howbig.ne.0)then
select case (stat)
case (1) ! print *, NAME, " is not defined in the environment. Strange..."
value=''
case (2) ! print *, "This processor doesn't support environment variables. Boooh!"
value=''
case default ! make string to hold value of sufficient size and get value
if(allocated(value))deallocate(value)
allocate(character(len=max(howbig,1)) :: VALUE)
call get_environment_variable(name,value,status=stat,trim_name=.true.)
if(stat.ne.0)VALUE=''
end select
else
value=''
endif
else
value=''
endif
if(value.eq.''.and.present(default))value=default
end function system_getenv
END PROGRAM roots