Aufgabe 9

PROGRAM C_08
 IMPLICIT NONE
 INTEGER :: f1(5), f2(4), f3(9)
 INTERFACE
  SUBROUTINE menge (feld1, feld2, feld3)
   IMPLICIT NONE
   INTEGER, DIMENSION(:) :: feld1, feld2, feld3
  END SUBROUTINE
 END INTERFACE
 f1 = (/ 2, 1, 4, 1, 5 /)
 f2 = (/ 4, 2, 3, 4 /)
 CALL menge (f1, f2, f3)
 WRITE (*,*) f1
 WRITE (*,*) f2
 WRITE (*,*) f3
END PROGRAM

SUBROUTINE menge (feld1, feld2, feld3)
 IMPLICIT NONE
 INTEGER, DIMENSION(:) :: feld1, feld2, feld3
 INTEGER :: i, m, n
 INTERFACE
  SUBROUTINE it_bubble (vektor)
   IMPLICIT NONE
   INTEGER :: vektor(:)
  END SUBROUTINE
  RECURSIVE SUBROUTINE rec_bubble (vektor)
   IMPLICIT NONE
   INTEGER :: vektor(:)
  END SUBROUTINE
 END INTERFACE

 CALL it_bubble (feld1)
 CALL single (feld1,n)
 CALL it_bubble (feld2)
 CALL single (feld2,m)
 feld3 = (/ feld1(1:n), feld2(1:m) /)
 CALL rec_bubble (feld3(1:m+n))
 CALL single (feld3(1:m+n),n)
 feld3(m+n+1:) = -1*HUGE(1)
CONTAINS
 SUBROUTINE single (array, lang)
! setzt voraus, dasz array sortiert ist!
  IMPLICIT NONE
  INTEGER :: array(:), i, lang, min
  lang = SIZE(array)
  min = HUGE(i)
  DO i = 1, lang-1
   IF (array(i) == array(i+1)) THEN
    array (i:) = (/ array(i+1:), -1*min /)
    lang = lang - 1
   ENDIF 
  END DO
 END SUBROUTINE
END SUBROUTINE

SUBROUTINE it_bubble (vektor)  ! Sortieren durch Austausch
 IMPLICIT NONE
 INTEGER :: vektor(:), hilf, i, j, n
 LOGICAL :: tausch
 n = SIZE(vektor)
 IF (n <= 1) RETURN
 DO i = n, 2, -1
  tausch = .FALSE.
  DO j = 1, i-1
   IF (vektor(j) > vektor(j+1)) THEN
    hilf = vektor(j+1)
    vektor(j+1) = vektor(j)
    vektor(j) = hilf
    tausch = .TRUE.
   END IF
  ENDDO
  IF (.NOT. tausch) EXIT loop
 ENDDO loop
END SUBROUTINE

! geht auch rekursiv:
RECURSIVE SUBROUTINE rec_bubble (vektor)  ! Sortieren durch Austausch
 IMPLICIT NONE
 INTEGER :: vektor(:), hilf, i, n
 LOGICAL :: tausch
 n = SIZE(vektor)
 IF (n <= 1) RETURN
 tausch = .FALSE.
 DO i = n-1, 1, -1
  IF (vektor(i) > vektor(i+1)) THEN
   hilf = vektor(i+1)
   vektor(i+1) = vektor(i)
   vektor(i) = hilf
   tausch = .TRUE.
  END IF
 ENDDO
 IF (tausch) CALL rec_bubble (vektor(2:n))
END SUBROUTINE