CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C  PROGRAMM ZUR AUTOMATISCHEN ERKENNUNG PROSODISCHER MERKMALE
C
C      ZUR SCHLUESSELWORTDETEKTION IN FLIESSENDER SPRACHE.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C PROGRAMM :    BETONUNG VERSION 19
C
C DATUM    :    23.12.83
C
C ES MACHT :    ELIMINIERT FREQUENZWERTE UNTERHALB EINES
C               ENERGIESCHWELLWERTES.
C
C               ELIMINIERT FREQUENZFLANKEN OBERHALB EINES
C               GRENZWERTES.
C
C               INTERPOLIERT LINEAR IN FREQUENZLUECKEN.
C
C               GLAETTET DIE FREQUENZ NACH DEM ABLEITUNGSPRINZIP.
C
C               SUCHT FREQUENZHUPPEL.
C
C               ERKENNT FREQUENZEINBRUECHE.
C
C               BERECHNET FREQUENZHUEBE.
C
C               ZIEHT POLYGONZUG VON MINIMUM ZU MINIMUM.
C
C               BERECHNET DIE FLAECHEN DAZWISCHEN.
C
C               BERECHNET DEN SONDERFALL DER ENDFLAECHE.
C
C               ELIMINIERT FLAECHEN UNTERHALB EINES
C               SCHWELLWERTES.
C
C               SUCHT MAXIMALEN FREQUENZHUB.
C
C               SORTIERT DIE HUPPEL NACH IHREN FLAECHEN.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C PROGRAMMSTRUKTUR
C==================
C
C BETON<<<<<<<
C            ^< LESEN
C            ^< SUCHE<<<<<<<<<
C            ^< AUSGA        ^
C                            ^< BUEGE
C                            ^< SILBE
C                            ^< FREQU
C                            ^< SORTI
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C VARIABLENDEKLARATION
C======================
C
C ANFA      = ANFANG
C DATE(X)   = FELD ZUM LESEN UND SCHREIBEN VON DATEN
C DDFR(X)   = ZWEITE ABLEITUNG DER SPRACHGRUNDFREQUENZ
C DFRE(X)   = ERSTE ABLEITUNG DER SPRACHGRUNDFREQUENZ
C DIFF      = FREQUENZDIFFERENZ
C ENDE      = ENDE
C ENER(X)   = ENERGIE
C FREM(X)   = GEGLAETTETE SPRACHGRUNDFREQUENZ
C FREQ(X)   = SPRACHGRUNDFREQUENZ
C FREZ(X)   = NORMIERTE SPRACHGRUNDFREQUENZ
C GLAT(X)   = HILFSFELD FUER DIE GLAETTUNGSROUTINE
C HACK(X)   = FELD ZUR BETONUNGSKENNUNG
C INDEX     = INDEX
C KONT      = KONTROLLFLAG
C LIST(1,X) = WORTANFANG
C LIST(2,X) = MAXIMUM DER SPRACHGRUNDFREQUENZ
C LIST(3,X) = WORTENDE
C LIST(4,X) = FREQUENZFLAECHE
C LIST(5,X) = FREQUENZHUB
C MAXE      = VARIABLE FUER MAXIMALWERT-BERECHNUNGEN
C STEI      = VARIABLE FUER FLANKENSTEILHEIT-BERECHNUNGEN
C WORT      = ANZAHL DER ERKANNTEN LAUTVERBINDUNGEN
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                       HAUPTPROGRAMM                           C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
        PROGRAM BETON
        INTEGER ANFA,ENDE,ENER(300),FREM(300),FREQ(300),
     1  FREZ(300),HACK(300)
        CALL LESEN(ENER,FREQ)
        CALL SUCHE(ANFA,ENDE,ENER,FREM,FREQ,FREZ,HACK)
        CALL AUSGA(ANFA,ENDE,FREM,FREZ,HACK)
        STOP'TSCHUESS, ICH BIN FERTIG!'
        END
CCCCCCCCCCCCCCCCC
C UNTERPROGRAMM C
CCCCCCCCCCCCCCCCC
        SUBROUTINE LESEN(ENER,FREQ)
        INTEGER ENER(300),FREQ(300)
        INTEGER*2 DATE(256)
C
C LIEST DATEN DES ANALYSEFILES "WD200.;1".
C
        OPEN(10,NAME='WD200.;1',TYPE='OLD',
     1  FORM='UNFORMATTED',RECL=128,ACCESS='DIRECT')
        DO I=1,141
                READ(10'I)DATE
                FREQ(2*I+7)=DATE(55)
                ENER(2*I+7)=DATE(59)
                FREQ(2*I+8)=DATE(183)
                ENER(2*I+8)=DATE(187)
        END DO
        CLOSE(UNIT=10)
C
C ERZEUGT DEFINIERTE RANDBEDINGUNGEN.
C
        DO I=1,9
                ENER(I)=0
                FREQ(I)=0
        END DO
        DO I=1,11
                ENER(I+289)=0
                FREQ(I+289)=0
        END DO
        RETURN
        END
CCCCCCCCCCCCCCCCC
C UNTERPROGRAMM C
CCCCCCCCCCCCCCCCC
        SUBROUTINE SUCHE(ANFA,ENDE,ENER,FREM,FREQ,FREZ,HACK)
        INTEGER ANFA,ENDE,ENER(300),FREM(300),FREQ(300),
     1  FREZ(300),HACK(300),LIST(5,30),WORT
C
C SUCHT UND SORTIERT FREQUENZHUPPEL.
C
        CALL BUEGE(ENER,FREM,FREQ)
        CALL SILBE(FREM,LIST,WORT)
        CALL FREQU(FREM,FREZ,LIST,WORT)
        CALL SORTI(ANFA,ENDE,FREM,HACK,LIST,WORT)
        RETURN
        END
CCCCCCCCCCCCCCCCC
C UNTERPROGRAMM C
CCCCCCCCCCCCCCCCC
        SUBROUTINE AUSGA(ANFA,ENDE,FREM,FREZ,HACK)
        INTEGER ANFA,ENDE,FREM(300),FREZ(300),HACK(300),INDEX
        INTEGER*2 DATE(256)
C
C ISOLIERT IM AUFNAHMEFILE "WD100.;1" DIE BETONTE SILBE.
C
        OPEN(10,NAME='WD100.;1',TYPE='OLD',
     1  FORM='UNFORMATTED',RECL=128,ACCESS='DIRECT')
        ANFA=ANFA-10
        ENDE=ENDE-10
        DO I=1,94
                READ(10'I)DATE
                DO J=1,256
                        INDEX=(256*I+J-241)/80
                        IF(.NOT.(INDEX.LT.1.OR.INDEX.GT.ANFA
     1                  .AND.INDEX.LT.ENDE))DATE(J)=0
                END DO
                WRITE(10'I)DATE
        END DO
        CLOSE(UNIT=10)
C
C SCHREIBT DATEN IN DAS ANALYSEFILE "WD200.;1" ZURUECK.
C MANIPULIERTE SPRACHGRUNDFREQUENZ STEHT AN STELLE 111,
C NORMIERTE SPRACHGRUNDFREQUENZ AN STELLE 112,
C BETONUNGSKENNUNG AN STELLE 113.
C
        OPEN(10,NAME='WD200.;1',TYPE='OLD',
     1  FORM='UNFORMATTED',RECL=128,ACCESS='DIRECT')
        DO I=1,141
                READ(10'I)DATE
                IF(I.NE.1)THEN
                        DATE(47)=FREM(2*I+7)/1000
                        DATE(48)=FREZ(2*I+7)/1000
                        DATE(49)=HACK(2*I+7)/1000
                END IF
                IF(I.NE.141)THEN
                        DATE(175)=FREM(2*I+8)/1000
                        DATE(176)=FREZ(2*I+8)/1000
                        DATE(177)=HACK(2*I+8)/1000
                END IF
                WRITE(10'I)DATE
        END DO
        CLOSE(UNIT=10)
        RETURN
        END
CCCCCCCCCCCCCCCCC
C UNTERPROGRAMM C
CCCCCCCCCCCCCCCCC
        SUBROUTINE BUEGE(ENER,FREM,FREQ)
        INTEGER ANFA,DDFR(300),DFRE(300),ENDE,ENER(300),
     1  FREM(300),FREQ(300),GLAT(300),MAXE
        LOGICAL KONT
C
C ELIMINIERT MESSWERTE UNTERHALB 20% DER MAXIMALENERGIE.
C
        MAXE=0
        DO I=1,300
                IF(ENER(I).GT.MAXE)MAXE=ENER(I)
        END DO
        MAXE=MAX(MAXE,4000)
        MAXE=MAXE/5
        DO I=1,300
                IF(ENER(I).LT.MAXE)FREQ(I)=0
        END DO
C
C ELIMINIERT FREQUENZFLANKEN UEBER 30 HZ/FRAME.
C
100     KONT=.FALSE.
        DO I=1,300
                IF(FREQ(I).NE.0)THEN
                        J=I
200                     J=J+1
                        IF(J.GT.300)GOTO 300
                        IF(FREQ(J).EQ.0)GOTO 200
                        IF(ABS((FREQ(J)-FREQ(I))/(J-I)).GT.30)
     1                  THEN
                                KONT=.TRUE.
                                FREQ(I)=0
                                FREQ(J)=0
                        END IF
                END IF
                IF(KONT)GOTO 100
        END DO
C
C SCHREIBT SPRACHGRUNDFREQUENZ MIT HOEHERER AUFLOESUNG IN FREM.
C
300     DO I=1,300
                FREM(I)=FREQ(I)*1000
        END DO
C
C STOPFT LUECKEN IN SPRACHGRUNDFREQUENZ.
C
        KONT=.FALSE.
        DO I=1,300
                IF(FREM(I).EQ.0)THEN
C
C ORTET FREQUENZLUECKEN.
C
                        IF(.NOT.KONT)THEN
                                KONT=.TRUE.
                                ANFA=I
                                ENDE=I
400                             ENDE=ENDE+1
                                IF(FREM(ENDE).EQ.0.
     1                          AND.ENDE.LT.300)GOTO 400
                        END IF
C
C INTERPOLIERT LINEAR.
C
                        IF(ANFA.NE.1.AND.ENDE.NE.300)THEN
                                FREM(I)=FREM(ANFA-1)+
     1                          (FREM(ENDE)-FREM(ANFA-1))
     2                          *(I-ANFA+1)/(ENDE-ANFA+1)
                        END IF
C
C ERZEUGT DEFINIERTE RANDWERTE.
C
                        IF(ANFA.EQ.1)FREM(I)=FREM(ENDE)
                        IF(ENDE.EQ.300)FREM(I)=FREM(ANFA-1)
                ELSE
                        KONT=.FALSE.
                END IF
        END DO
C
C GLAETTET SPRACHGRUNDFREQUENZ.
C
        DO I=3,298
                GLAT(I)=FREM(I-2)+FREM(I+2)+
     1          4*(FREM(I-1)+FREM(I+1))+6*FREM(I)
        END DO
        DO I=3,298
                FREM(I)=GLAT(I)/16
        END DO
C
C BILDET ERSTE ABLEITUNG.
C
        DO I=1,299
                DFRE(I+1)=FREM(I+1)-FREM(I)
        END DO
        DFRE(1)=0
C
C GLAETTET ERSTE ABLEITUNG.
C
        DO I=3,298
                GLAT(I)=DFRE(I-2)+DFRE(I+2)+
     1          4*(DFRE(I-1)+DFRE(I+1))+6*DFRE(I)
        END DO
        DO I=3,298
                DFRE(I)=GLAT(I)/16
        END DO
C
C BILDET ZWEITE ABLEITUNG.
C
        DO I=1,299
                DDFR(I+1)=DFRE(I+1)-DFRE(I)
        END DO
        DDFR(1)=0
C
C GLAETTET ZWEITE ABLEITUNG.
C
        DO I=3,298
                GLAT(I)=DDFR(I-2)+DDFR(I+2)+
     1          4*(DDFR(I-1)+DDFR(I+1))+6*DDFR(I)
        END DO
        DO I=3,298
                DDFR(I)=GLAT(I)/16
        END DO
C
C BILDET ERSTE ABLEITUNG AUS DER ZWEITEN.
C
        DO I=2,300
                DFRE(I)=DFRE(I-1)+DDFR(I)
        END DO
C
C BILDET SPRACHGRUNDFREQUENZ AUS DER ERSTEN ABLEITUNG.
C
        DO I=2,300
                FREM(I)=FREM(I-1)+DFRE(I)/256
        END DO
        RETURN
        END
CCCCCCCCCCCCCCCCC
C UNTERPROGRAMM C
CCCCCCCCCCCCCCCCC
        SUBROUTINE SILBE(FREM,LIST,WORT)
        INTEGER DIFF,FREM(300),LIST(5,30),WORT
        LOGICAL KONT
C
C TRAEGT HUPPELANFANG IN DIE LISTE EIN UND ZAEHLT DIE HUPPEL.
C
        WORT=0
        KONT=.TRUE.
        DO I=1,299
                IF(FREM(I)/100.LT.FREM(I+1)/100.AND.KONT)THEN
                        KONT=.FALSE.
                        WORT=WORT+1
                        LIST(1,WORT)=I
                END IF
                IF(FREM(I)/100.GT.FREM(I+1)/100.)KONT=.TRUE.
        END DO
C
C SUCHT MAXIMA.
C
        DO I=1,WORT
                J=LIST(1,I)
100             J=J+1
                IF(FREM(J).LT.FREM(J+1).AND.J.LT.300)GOTO 100
                LIST(2,I)=J
        END DO
C
C TRAEGT HUPPELENDEN IN DIE LISTE EIN.
C
        DO I=1,WORT-1
                LIST(3,I)=LIST(1,I+1)
        END DO
C
C SUCHT MINIMUM FUER DEN LETZTEN HUPPEL.
C
        I=LIST(2,WORT)
200     I=I+1
        IF(FREM(I).GT.FREM(I+1).AND.I.LT.300)GOTO 200
        LIST(3,WORT)=I
C
C BEULT EINGEDELLERTE HUPPEL AUS. ( DIFF > 21000 ).
C
300     DO I=1,WORT-1
                DIFF=FREM(LIST(1,I))+
     1          (FREM(LIST(3,I+1))-FREM(LIST(1,I)))
     2          *(LIST(3,I)-LIST(1,I))/(LIST(3,I+1)-LIST(1,I))
                DIFF=FREM(LIST(3,I))-DIFF
                IF(DIFF.GT.21000)GOTO 400
        END DO
        RETURN
400     LIST(3,I)=LIST(3,I+1)
        DO I=I+1,WORT
                DO J=1,3
                        LIST(J,I)=LIST(J,I+1)
                END DO
        END DO
        WORT=WORT-1
        GOTO 300
        END
CCCCCCCCCCCCCCCCC
C UNTERPROGRAMM C
CCCCCCCCCCCCCCCCC
        SUBROUTINE FREQU(FREM,FREZ,LIST,WORT)
        INTEGER ANFA,ENDE,FREM(300),FREZ(300),LIST(5,30),WORT
C
C BERECHNET FREQUENZHUEBE.
C
        DO I=1,WORT
                LIST(4,I)=0
                LIST(5,I)=FREM(LIST(2,I))-FREM(LIST(1,I))
        END DO
        DO I=1,300
                FREZ(I)=0
        END DO
C
C ZIEHT POLIGONZUG VON MINIMUM ZU MINIMUM UND BERECHNET DIE
C FREQUENZFLAECHE DER HUPPEL.
C
        DO I=1,WORT
                ANFA=LIST(1,I)
                ENDE=LIST(3,I)
                DO J=ANFA,ENDE
                        FREZ(J)=FREM(J)-FREM(ANFA-1)-
     1                  (FREM(ENDE)-FREM(ANFA-1))
     2                  *(J-ANFA+1)/(ENDE-ANFA+1)
                        LIST(4,I)=LIST(4,I)+FREZ(J)
                END DO
        END DO
C
C BERECHNET DIE LETZTE HUPPELFLAECHE.
C
        IF(FREM(LIST(2,WORT))/1000.EQ.FREM(LIST(3,WORT))/1000)
     1  THEN
                ANFA=LIST(1,WORT)
                ENDE=LIST(3,WORT)
                LIST(4,WORT)=0
                DO J=ANFA,ENDE
                        FREZ(J)=FREM(J)-FREM(ANFA-1)
                        LIST(4,WORT)=LIST(4,WORT)+FREZ(J)
                END DO
        END IF
        DO I=1,WORT
        END DO
C
C ELIMINIERT FLAECHEN UNTER 300000.
C
        DO I=1,WORT
                IF(LIST(4,I).LT.300000)LIST(4,I)=0
        END DO
        RETURN
        END
CCCCCCCCCCCCCCCCC
C UNTERPROGRAMM C
CCCCCCCCCCCCCCCCC
        SUBROUTINE SORTI(ANFA,ENDE,FREM,HACK,LIST,WORT)
        INTEGER ANFA,ENDE,FREM(300),HACK(300),LIST(5,30),STEI,
     1  WORT
C
C SUCHT MAXIMALEN FREQUENZHUB.
C
        STEI=1
        DO I=2,WORT
                IF(LIST(5,I).GT.LIST(5,STEI))STEI=I
        END DO
        DO I=1,WORT
                IF(I.NE.STEI)LIST(5,I)=0
        END DO
C
C SORTIERT DIE HUPPEL NACH IHREN FLAECHEN.
C
        DO I=1,WORT-1
                DO J=1,WORT-I
                        IF(LIST(4,J).LT.LIST(4,J+1))THEN
                                DO K=1,5
                                        L=LIST(K,J)
                                        LIST(K,J)=LIST(K,J+1)
                                        LIST(K,J+1)=L
                                END DO
                        END IF
                END DO
        END DO
C
C LEGT WIEDERGABEBEREICH FEST.
C
        IF(LIST(4,1).NE.0)THEN
                ANFA=LIST(1,1)
                ENDE=LIST(3,1)
        ELSE
                ANFA=0
                ENDE=0
        END IF
C
C SETZT FELD ZUM ZEICHNEN.
C
        DO I=1,300
                HACK(I)=0
        END DO
        DO I=1,WORT
                IF(LIST(4,I).NE.0)THEN
                        DO J=LIST(1,I),LIST(3,I),I
                                HACK(J)=FREM(J)
                        END DO
                END IF
        END DO
        IF(LIST(4,1).NE.0.AND.LIST(5,1).NE.0)THEN
                DO I=ANFA,LIST(2,1)
                        HACK(I)=275000
                END DO
        ELSE
                DO I=1,WORT
                        IF(LIST(5,I).GT.40000)THEN
                                HACK(LIST(1,I))=275000
                                HACK(LIST(2,I))=275000
                        END IF
                END DO
        END IF
        RETURN
        END