Aufgabe 4

PROGRAM B_01 

IMPLICIT NONE
REAL    :: a0, a1, a2, a3, x1, x2, a,b,c,D, p
INTEGER :: i

schleife: DO
 WRITE (*,'(a)') '                                                  2    3  '
 WRITE (*,'(a)') 'Geben Sie die Koef. des Polynoms p(x) = a +a x+a x +a x ein:'
 WRITE (*,'(a)') '                                         0  1   2    3     '
 DO
  WRITE (*,'(a)',ADVANCE='no') 'a0 = '
  READ (*,*,IOSTAT=i) a0
  IF (i == 0) THEN
   EXIT
  ELSE IF (i > 0) THEN
   CYCLE
  ELSE
   EXIT schleife
  ENDIF
 ENDDO
 DO
  WRITE (*,'(a)',ADVANCE='no') 'a1 = '
  READ (*,*,IOSTAT=i) a1
  IF (i == 0) THEN
   EXIT
  ELSE IF (i > 0) THEN
   CYCLE
  ELSE
   EXIT schleife
  ENDIF
 ENDDO
 DO
  WRITE (*,'(a)',ADVANCE='no') 'a2 = '
  READ (*,*,IOSTAT=i) a2
  IF (i == 0) THEN
   EXIT
  ELSE IF (i > 0) THEN
   CYCLE
  ELSE
   EXIT schleife
  ENDIF
 ENDDO
 DO
  WRITE (*,'(a)',ADVANCE='no') 'a3 = '
  READ (*,*,IOSTAT=i) a3
  IF (i == 0) THEN
   EXIT
  ELSE IF (i > 0) THEN
   CYCLE
  ELSE
   EXIT schleife
  ENDIF
 ENDDO
 
! Extrema an den Stellen, wo 1. Ableitung = 0 und
!                            2. Ableitung /= 0
!                                         (<0 .. Maximum)
!                                         (>0 .. Minimum)

!                                        2     2
! 1. Ableitung p'(x) = a  + 2 a x + 3 a x  = ax  + bx + c
!                       1      2       3
!
! 2. Ableitung p"(x) = 2ax + b
!                                       
! p'(x) = 0  => quadratische Aufloesung:
!                     2
!        -b +/- sqrt(b  - 4ac)
!  x  = -----------------------
! 1 2             2a 

 IF (a3 /= 0.0) THEN
  a = 3.*a3
  b = 2.*a2
  c = a1
  D = b**2 - 4.*a*c
  IF (D < 0.0) THEN
   WRITE (*,*) 'keine reellen Extrema!'
   CYCLE
  ENDIF
  x1 = (-b + SQRT(D)) / (2.*a)
  CALL ausgabe (a2,a3,x1,p(a0,a1,a2,a3,x1))
  IF (D /= 0.0) THEN
   x2 = (-b - sqrt(D)) / (2.*a)
   CALL ausgabe (a2,a3,x2,p(a0,a1,a2,a3,x2))
  ENDIF
 ELSE                  ! Ordnung ist maximal 2 nicht 3
  IF (a2 /= 0.0) THEN  ! Ordnung ist 2 => Parabel: nur 1 Extremum
   x1 = -a1/a2
   WRITE (*,*) 'eine Parabel hat nur 1 Extremum:'
   CALL ausgabe (a2,a3,x1,p(a0,a1,a2,a3,x1))
  ELSE
   WRITE (*,*) 'eine Gerade hat keine Extrema!'
  ENDIF
 ENDIF
ENDDO schleife
WRITE (*,*) 'Programm beendet'
END PROGRAM B_01

SUBROUTINE ausgabe (a2,a3,x,y)
REAL :: a2, a3, x, y, term

term = 2.*a2 + 6.*a3*x
IF (term < 0) THEN
 WRITE (*,*) 'lokales Maximum: ',x,y
ELSE IF (term > 0) THEN
 WRITE (*,*) 'lokales Minimum: ',x,y
ELSE
 WRITE (*,*) 'Wendepunkt: ',x,y
ENDIF
END SUBROUTINE ausgabe

REAL FUNCTION p(a0,a1,a2,a3,x)
REAL :: x
p = a0 + a1*x + a2*x**2. + a3*x**3.
END FUNCTION p