C***********************************************************************
C                                                                      *
C  GAUSS ELIMINATION MIT RCKWRTSSUBSTITUTION                         *
C                                                                      *
C***********************************************************************
C
C     ZUR LSUNG DES LINEAREN GLEICHUNGSSYSTEMS MIT N UNBEKANNTEN
C
C     A(1,1) X(1) + A(1,2) X(2) + ... + A(1,N) X(N) = A(1,N+1)
C     A(2,1) X(1) + A(2,2) X(2) + ... + A(2,N) X(N) = A(2,N+1)
C     .
C     .
C     A(N,1) X(1) + A(N,2) X(2) + ... + A(N,N) X(N) = A(N,N+1)
C
C     EINGABE: ANZAHL DER UNBEKANNTEN UND GLEICHUNGEN N IN DER FORM:
C              A = (A(I,J)) WOBEI 1<=I<=N AND 1<=J<=N+1.
C
C     AUSGABE: LSUNGSVEKTOR X(1),X(2),...,X(N) ODER FEHLERMELDUNG.
C
C     INITIALISIERUNG
      DIMENSION A(10,11), X(10)
      CHARACTER NAME*14,NAME1*14,AA*1
      INTEGER INP,OUP,FLAG
      LOGICAL OK
      OPEN(UNIT=5,FILE='CON',ACCESS='SEQUENTIAL')
      OPEN(UNIT=6,FILE='CON',ACCESS='SEQUENTIAL')
      WRITE(6,*) 'Gauss Eliminationsmethode.'
      WRITE(6,*) 'Die Matrix wird von einem Textfile eingelesen, in der'
      WRITE(6,*) 'Reihenfolge A(1,1), A(1,2), ..., A(1,N+1), A(2,1),'
      WRITE(6,*) ' A(2,2), ..., A(2,N+1)..., A(N,1), A(N,2),'
      WRITE(6,*) ' ..., A(N,N+1) '
      WRITE(6,*) 'Eingabe der Matrixelemente durch Leertaste getrennt,'
      OK = .FALSE.
      WRITE(6,*) 'Name des Eingabefiles, z.B. a:\INPUT.TXT'
      WRITE(6,*) ' '
      READ(5,*)  NAME
      INP = 4
      OPEN(UNIT=INP,FILE=NAME,ACCESS='SEQUENTIAL')
      OK = .FALSE.
9     IF (OK) GOTO 11
      WRITE(6,*) 'Anzahl der Unbekannten (Integer)'
      WRITE(6,*) ' '
      READ(5,*) N
      IF (N .GT. 0) THEN
         M = N+1
         READ(INP,*) ((A(I,J), J=1,M),I=1,N)
         OK = .TRUE.
         CLOSE(UNIT=INP)
      ELSE
         WRITE(6,*) 'Die Zahl muss positiv sein'
         ENDIF
         GOTO 9
      ENDIF
11    IF( .NOT. OK) GOTO 400
      WRITE(6,*) 'Ausgabe: '
      WRITE(6,*) '1...Bildschirm '
      WRITE(6,*) '2...in Datenfile '
      WRITE(6,*) 'Geben Sie 1 oder 2 ein'
      WRITE(6,*) ' '
      READ(5,*) FLAG
      IF ( FLAG .EQ. 2 ) THEN
         WRITE(6,*) 'Name des Ausgabefiles'
         WRITE(6,*) ' '
         READ(5,*) NAME1
         OUP = 3
         OPEN(UNIT=OUP,FILE=NAME1,STATUS='NEW')
      ELSE
         OUP = 6
      ENDIF
      WRITE(OUP,*) 'GAUSS ELIMINATION'
C     ICHG Zhler fr die Anzahl der Zeilenvertauschungen
      ICHG = 0
      WRITE(OUP,3)
      WRITE(OUP,4) ((A(I,J),J=1,M),I=1,N)
C     STEP 1
C     ELIMINATIONSVERFAHREN
      NN = N-1
      DO 10 I=1,NN
C          STEP 2
           IP = I
100        IF (ABS(A(IP,I)).GE.1.0E-20 .OR. IP.GT.N) GOTO 200
                IP = IP+1
           GOTO 100
200        IF(IP.EQ.N+1)THEN
C               GLEICHUNGSSYSTEM HAT SINGULRE LSUNG
                WRITE(OUP,5) ((A(I,J),J=1,M),II=1,N)
                GOTO 400
           END IF
C          STEP 3
           IF(IP.NE.I) THEN
                DO 20 JJ=1,M
                     C = A(I,JJ)
                     A(I,JJ) = A(IP,JJ)
20              A(IP,JJ) = C
                ICHG = ICHG+1
           END IF
C          STEP 4
           JJ = I+1
           DO 30 J=JJ,N
C               STEP 5
                XM = A(J,I)/A(I,I)
C               STEP 6
                DO 40 K=JJ,M
40              A(J,K) = A(J,K)-XM*A(I,K)
30         A(J,I) = 0
10    CONTINUE
C     STEP 7
      IF(ABS(A(N,N)).LT.1.0E-20) THEN
C          GLEICHUNGSSYSTEM HAT SINGULRE LSUNG
           WRITE(OUP,5)((A(I,J),J=1,M),I=1,N)
           GOTO 400
      END IF
C     STEP 8
C     BEGINN DER RCKWRTSSUBSTITUTION
      X(N) = A(N,N+1)/A(N,N)
C     STEP 9
      L = N-1
      DO 15 K=1,L
           I = L-K+1
           JJ = I+1
           SUM = A(I,N+1)
           DO 16 KK=JJ,N
16         SUM = SUM-A(I,KK)*X(KK)
15    X(I) = SUM/A(I,I)
      WRITE(OUP,6)((A(I,J),J=1,M),I=1,N)
C     STEP 10
C     ALGORITHMUS VOLLSTNDIG BEENDET
      WRITE(OUP,7)(X(I),I=1,N)
      WRITE(OUP,8) ICHG
400   CLOSE(UNIT=5)
      CLOSE(UNIT=OUP)
      IF(OUP.NE.6) CLOSE(UNIT=6)
      STOP
5     FORMAT(1X,'DAS GLEICHUNGSSYSTEM IST SINGULR')
4     FORMAT(1X,5(3X,E15.8))
6     FORMAT(1X,'DAS GLEICHUNGSSYSTEM:',/,(5(3X,E15.8)))
7     FORMAT(1X,'HAT DEN LSUNGSVEKTOR',4(3X,E15.8))
8     FORMAT(1X,'ANZAHL VON ZEILENVERTAUSCHUNGEN = ',3X,I2)
3     FORMAT(1X,'EINGABEDATEN:',/)
      END
