Aufgabe 10

PROGRAM D_01

!-------------------------------------------------------------------------------
! liest eine Basis ein, 
! liest dann Zahlenpaare in dieser Basis ein
! und gibt die Summe aus
!-------------------------------------------------------------------------------

 CHARACTER*10 :: zahl1, zahl2
 CHARACTER*11 :: summe
 INTEGER      :: basis, error, iostat
 INTERFACE
  SUBROUTINE addiere (basis, string1, string2, string3, index, file)
   IMPLICIT NONE
    CHARACTER(LEN=*)           :: string1, string2, string3
    INTEGER                    :: index, basis
    CHARACTER(LEN=*), OPTIONAL :: file
  END SUBROUTINE
 END INTERFACE

 DO
  DO
   WRITE (*,'(a)',ADVANCE = 'no') 'Basis = '
   READ (*,*,IOSTAT=iostat) basis
   IF (iostat < 0) THEN
    STOP
   ELSE IF (iostat > 0) THEN
    CYCLE
   END IF
   IF ((basis > 1) .AND. (basis < 37)) EXIT
   WRITE (*,*) 'unzulaessige Basis'
  ENDDO
  berechne: DO
   zahl1 = ' '; zahl2 = ' '
   DO
    WRITE (*,'(A)',ADVANCE = 'no') 'Zahl 1: '
    READ (*,'(A10)',IOSTAT=iostat) zahl1
    IF (iostat == 0) THEN
     EXIT
    ELSE IF (iostat < 0) THEN
     STOP
    END IF
   END DO
   zahl1 = ADJUSTR(zahl1)
   DO
    WRITE (*,'(A)',ADVANCE = 'no') 'Zahl 2: '
    READ (*,'(A10)',IOSTAT=iostat) zahl2
    IF (iostat == 0) EXIT
   END DO
   zahl2 = ADJUSTR(zahl2)

   summe = "	! auf WS automatisch, am PC nicht!
   CALL addiere(basis,zahl1,zahl2,summe,error)
   WRITE (*,'(A)') 'Die Summe lautet '//summe
  ENDDO berechne
 ENDDO

END PROGRAM D_01

SUBROUTINE addiere (basis, string1, string2, string3, index, file)

!-------------------------------------------------------------------------------
!
!  addiert zwei Zahleneiner beliebigen Basis (1 < basis < 37), ohne die
!  Zahlen zuvor ins Dezimalsystem zu uebertragen
!
!-------------------------------------------------------------------------------

 IMPLICIT NONE
 CHARACTER(LEN=*)           :: string1, string2, string3
 INTEGER                    :: index, basis
 CHARACTER(LEN=*), OPTIONAL :: file

 INTEGER                    :: L, l1, l2, m, n, A, ueber, num1, num2, num_neu
 INTEGER                    :: null, neun
 CHARACTER*1                :: c1, c2

 l1 = LEN(string1)
 l2 = LEN(string2)
 L = max(l1,l2)
 null = ichar('0')
 neun = ichar('9')
 A = ichar('A')
 ueber = 0
 index = 0
 DO n = L, 1, -1
  m = n+1
  c1 = string1(n:n)
  c2 = string2(n:n)
  IF ((c1 .ne. ' ') .and. (c2 .ne.  ' ')) THEN
   num1 = ichar(c1)-null
   num2 = ichar(c2)-null
  ELSE IF (c1 .ne. ' ') THEN
   num1 = ichar(c1)-null
   num2 = 0
  ELSE IF (c2 .ne. ' ') THEN
   num1 = 0
   num2 = ichar(c2)-null
  ELSE
   EXIT
  ENDIF
  IF (basis .le. 10) THEN
   IF (num1 >= basis) index = 10
   IF (num2 >= basis) index = index+1
  ELSE
   IF (num1 > (A-null)+(basis-10)-1) index = 10
   IF (num2 > (A-null)+(basis-10)-1) index = index+1
  ENDIF
  IF (num1 > 10) num1 = num1 - (A-neun) + 1
  IF (num2 > 10) num2 = num2 - (A-neun) + 1
  num_neu = num1 + num2 + ueber
  ueber = 0
  IF (num_neu >= basis) THEN
   ueber = 1
   num_neu = num_neu-basis
  ENDIF
  IF (num_neu < 10) THEN
   string3(m:m) = char(num_neu+null)
  ELSE
   string3(m:m) = char(num_neu-10+A)
  ENDIF
 ENDDO
 IF (ueber == 1) THEN
  string3(m:m) = '1'
 ELSE
  string3(m:m) = ' '
 ENDIF

 IF (PRESENT(file)) THEN
  file = TRIM(ADJUSTL(file))
  OPEN (10,FILE=TRIM(ADJUSTL(file)),POSITION='APPEND')
  WRITE (10,*) string1, string2, string3 
  CLOSE (10)
 END IF
END SUBROUTINE addiere