//SGP36Z   JOB (TEST,H02),PPS,PASSWORD=(.....)
/*JOBPARM T=60,L=80
// EXEC SERVICE
//SYSIN DD *
 SCRATCH ZGRID9
 ALLOCATE ZGRID9 RECORDS(15000) ATTRIBUTES(FIXED,RECSIZE(80), -
 BLKSIZE(3120))
// EXEC FORTVCE,PLOT=D,CPRINT=D,OPT=3
C     FILES: 6: MESFIL, OUTPUT, MESSAGES
C           12: COLFIL, OUTPUT, FARBEN
C            9  PICFIL, OUTPUT, PIXEL
C            5  DATFIL, INPUT, DATEN
C
C&TRACE OFF
CFI 5 DISK PIUFOR TEMP A
CFI 6 DISK ZGRID MESSAGE A
CFI 9 DISK ZWERT25 GRID A
CFI 12 DISK ZGRID COLORS A
CEXEC FORTE ZGRID
C
C     STAND: 21.12.1990 17.01
      REAL ZREC(800),LATCOR,LONCOR
      INTEGER IZREC(800)
      REAL XV(900),YV(900),ZV(900),HELP(900),XSTOR(1),YSTOR(1),
     *     DSTOR,XVALS(6900),ZVALS(6900),XERG(6900),ZERG(6900),
     *     XPOL(720),ZPOL(720),EQUIL
      INTEGER TEXT(20),REGEO(20,900)
      INTEGER PEGEL(900),IHELP(900)
      INTEGER NGES,NSTOR,IANZ,NZEIL,NSPA,IZEIL,ISPA,ZELLE,
     *        DATFIL,PICFIL,COLFIL,MESFIL,TURBO,DATFIO
      LOGICAL OUTLAW(900),VERBOT(900),NIERO,DRENEW,ERW,CALC,NOSPI,
     *        TRAN,GEIST,STODT,TRACE,HABWRT
C     ARRAYS FUER DIE NACHBARN
      REAL XNAC(500),YNAC(500),A(500),B(500),C(500)
      INTEGER NUMMER(500,9),UNDEF,NCALC(2)
      DATA NGES/900/,NSTOR/1/,IANZ/10/,NST/1/,GENAU/0.5E-06/,
     *     NZEIL/360/,NSPA/720/,IZEIL/360/,ISPA/720/,ISPAM/6900/,
     *     DATFIL/5/,PICFIL/9/,COLFIL/12/,MESFIL/6/,NACFIL/8/,DATFIO/4/
C     INITIALISIERUNGEN FUER ISO/9 (TRIAN)
      DATA DSTOR/0.01/,NIERO/.FALSE./,SW/0./,NRMAX/500/,UNDEF/'UV-0'/,
     *     DRENEW/.TRUE./,TURBO/0/,ERW/.FALSE./,IRANDS/0/,CALC/.FALSE./,
     *     NOSPI/.FALSE./,TRAN/.FALSE./,GEIST/.FALSE./,STODT/.FALSE./
      COMMON /GLEICH/ EQUIL
      RAD(ALPHA)=ALPHA*3.1415/180.
      EQUIL=0.001
C
C     FILES: 6: MESFIL, OUTPUT, MESSAGES
C           12: COLFIL, OUTPUT, FARBEN
C            9  PICFIL, OUTPUT, PIXEL
C            5  DATFIL, INPUT, DATEN
C
C     IWAS=1: TRIANGULIEREN
      IWAS=1
C     IWAS=2: DREIECKE EINLESEN UND VERWENDEN
C     IWAS=2
C     ZLIMIT, DAS WERTE ANNEHMEN WENN SIE GROESSER SIND
      ZLIM=30.
      NACFIO=8
      TRACE=.FALSE.
      ABSAUS=0.5
      DPHI=0.
      DLAM=RAD(-210.)
C     DELTA Z FUER TEMPERATUREN
      ZMIN=0.
      ZMAX=30.
C     IWISH=1 SOMMERTEMP
      IWISH=9
      NRMAX=500
      NGES=900
C     DELTA Z FUER SALINITAETEN
C     ZMIN=32.0
C     ZMAX=39.5
500   CONTINUE
CC    READ (0,*) IWISH,ZMAX
CC    IF(IWISH.LT.1.OR.IWISH.GT.8) GOTO 500
CC    WRITE (0,*) 'IWISH=',IWISH,' ZMAX='
      DXCHEK=0.1
      DYCHEK=0.1
      XMAX=180.
      YMAX=90.
      YMIN=-90.
      XMIN=-180.
      YSTART=-80.
      YEND=80.
      XSTART=-180.
      XEND=180.
      ABSTIN=0.5
      ABST=0.5
      INCR=1
      NACFII=1
      IF(IWAS.EQ.1) CALL PLOTS
      IF(IWAS.EQ.1) CALL PLOT (5.,5.,-3)
      IF(IWAS.EQ.1) WRITE (DATFIO,109)
109   FORMAT ('//FT01F001 DD *')
      IF(IWAS.EQ.1) READ (5,111) TEXT
      IF(IWAS.EQ.2) READ (NACFII,111) TEXT
111   FORMAT (20A4)
      WRITE (9,111) TEXT
      IF(IWAS.EQ.1) WRITE (DATFIO,111) TEXT
      WRITE (6,112) TEXT
112   FORMAT (1X,20A4)
      IF(IWAS.EQ.1) READ (5,111) TEXT
      IF(IWAS.EQ.2) READ (NACFII,111) TEXT
      WRITE (9,111) TEXT
      IF(IWAS.EQ.1) WRITE (DATFIO,111) TEXT
      WRITE (6,112) TEXT
      NST=NSTOR
      IF(IWAS.EQ.1) CALL ISORD (REGEO,NGES,ZV,IREGEO,DATFIL,MESFIL,
     *                         IWISH)
C     MODIFIZEIRTE DATEN LESEN
      IF(IWAS.EQ.2) CALL DATRED (REGEO,NGES,ZV,IREGEO,NACFII)
      IF(IREGEO.LT.1) STOP
      CALL REGKON (REGEO,IREGEO,XV,YV,MESFIL)
      WRITE (6,*) 'IREGEO VOR XYCHECK=',IREGEO
C
      CALL XYCECK (XV,YV,ZV,IREGEO,IREG,DXCHEK,DYCHEK,REGEO)
      IREGEO=IREG
      WRITE (6,*) 'IREGEO NACH XYCHECK=',IREGEO
C     MODIFIZIERTE DATEN AUSSCHREIBEN
      IF(IWAS.EQ.1) CALL DATWRT (REGEO,NGES,ZV,IREGEO,DATFIO)
C
C     LAMBDAMAESSIG VERSCHIEBEN, SO DASS SCHNITT IN AFRIKA IST
      DO 1 I=1,IREGEO
         XV(I)=XV(I)+DLAM
         YV(I)=YV(I)+DPHI
         XV(I)=LONCOR(XV(I))
         YV(I)=LATCOR(YV(I))
CC        XV(I)=(XV(I)+3.)*10.
CC        YV(I)=(YV(I)+1.)*10.
         WRITE (6,1177) I,XV(I),YV(I),ZV(I)
 1177    FORMAT (1X,'I=',I4,' XV=',F9.3,' YV=',F9.3,' ZV=',F9.3)
1        CONTINUE
         NDAT=IREGEO
         NPRIM=IREGEO
         NSTO=IREGEO
         DO 11 I=1,NRMAX
            DO 11 J=1,9
               NUMMER(I,J)=UNDEF
11             CONTINUE
         DO 12 I=1,NGES
            OUTLAW(I)=.FALSE.
12          CONTINUE
         NSTOR=1
         NST=1
         NUMANZ=0
         IF(IWAS.EQ.1) GOTO 13
C           ANSONSTEN DIE NACHBARN EINLESEN
            NUMANZ=0
14          NUMANZ=NUMANZ+1
            IF(NUMANZ.GT.NRMAX) GOTO 1010
            READ (NACFIL,992,END=16) (NUMMER(NUMANZ,J),J=1,9)
C    *                              XNAC(NUMANZ),YNAC(NUMANZ)
992         FORMAT (6I10,/,3I10,2E14.7)
            GOTO 14
16          CONTINUE
            NUMANZ=NUMANZ-1
            WRITE (6,17) NUMANZ
17          FORMAT (1X,'SIE HABEN => ',I5,' NUMMERNZEILEN.')
            IF(NUMANZ.LT.1) GOTO 1000
            GOTO 20
13       CONTINUE
C        CALL PLOTS
C        CALL PLOT (10.,10.,-3)
C
         CALL TRIANG (XV,YV,ZV,NGES,NDAT,NPRIM,NSTO,HELP,IHELP,OUTLAW,
     *                VERBOT,XSTOR,YSTOR,NSTOR,NST,GENAU,
     *                NUMMER,NRMAX,NUMANZ,DSTOR,NIERO,DRENEW,
     *                TURBO,ERW,SW,IRANDS,CALC,
     *                NOSPI,TRAN,TRACE,GEIST,IRC,STODT,MESFIL)
         NFIL=4
         WRITE (DATFIO,1811)
1811     FORMAT ('//FT08F001 DD *')
         DO 18 N=1,NUMANZ
            ILINE=N
            CALL NACWRT (NUMMER,NRMAX,NUMANZ,ILINE,DATFIO,XV,YV,ZV,
     *                   NDAT,NPRIM)
18       CONTINUE
         WRITE (6,*) 'FERTIG MIT TRIANG'
         IF(IWAS.EQ.1) CALL PLOTE
         STOP
20       CONTINUE
C        NACCLC WIRD NACH DEM STAND DER DINGE NICHT MEHR BENOETIGT
C        AUS SICHERHEITSGRUENDEN DRINGELASSEN
         IF(IWAS.EQ.1)
     *   CALL NACCLC (XV,YV,ZV,NDAT,XNAC,YNAC,A,B,C,NUMMER,NUMANZ,
     *                NRMAX)
      NCALC(1)=0
      NCALC(2)=0
      INAC=NUMANZ
C
C
      FAKX=IZEIL/(XMAX-XMIN)
      FAKY=ISPA/(YMAX-YMIN)
C     Z-WERT-RASTER BERECHNEN
C     ZUNAECHST X UND Y IN RADIANS WANDELN
C     GRADC=180./3.1415
      GRADC=3.1415/180.
      IOUT=9
C      DO 2 N=1,NDAT
C         XV(N)=XV(N)*GRADC
C         YV(N)=YV(N)*GRADC
C2        CONTINUE
C
C
      WRITE (9,901) ZMIN,ZMAX
901   FORMAT (1X,T10,'ZMIN=',T20,F8.4,T30,'ZMAX=',T40,F8.4)
      XMIN=XMIN*GRADC
      XMAX=XMAX*GRADC
      YMIN=YMIN*GRADC
      YMAX=YMAX*GRADC
      YSTART=YSTART*GRADC
      YEND=YEND*GRADC
      ABST=ABST*GRADC
      XSTA=XSTART
      XEN=XEND
      XSTART=XSTART*GRADC
      XEND=XEND*GRADC
C     DAS X Y RASTER VORBEREITEN
      DX=(XEND-XSTART)/ISPA
      DY=(YEND-YSTART)/IZEIL
C     DAMIT NICHT FUER 10 BREITENGRADE 10000 RECS GESCHRIEBEN WERDEN
C     IF(DY.LT.0.5*DX) DY=DX
C     DY=DX
C     DY=0.0078
      Y=YSTART-DY
C     WRITE (9,900) XMIN,XMAX,YMIN,YMAX,ISPA,IZEIL,DX,DY,YSTART,YEND,
C    *              XSTART,XEND
C900  FORMAT (1X,T10,'XMIN=',T20,F8.4,T30,'XMAX=',T40,F8.4,
C    *      /,1X,T10,'YMIN=',T20,F8.4,T30,'YMAX=',T40,F8.4,
C    *      /,1X,T10,'IZEI=',T20,I8  ,T30,'JSPA=',T40,I8,
C    *      /,1X,T10,'DX  =',T20,F8.4,T30,'DY  =',T40,F8.4,
C    *      /,1X,T10,'YSTA=',T20,F8.4,T30,'YEND=',T40,F8.4,
C    *      /,1X,T10,'XSTA=',T20,F8.4,T30,'XEND=',T40,F8.4)
      LCNT=0
      X=XSTART
C     DIE X-WERTE BLEIBEN KONSTANT
      DO 3 IX=1,ISPA
         XVALS(IX)=X
         X=X+DX
3        CONTINUE
C
C     NUN DIE SCAN SCHLEIFE VON OBEN NACH UNTEN
      HABWRT=.FALSE.
      NVEM=0
5     CONTINUE
      LCNT=LCNT+1
      Y=Y+DY
      IF(Y.GT.YEND) GOTO 1000
         NCALC(1)=0
         NCALC(2)=0
         YWRT=Y*180./3.1415
         CALL SCAN (XV,YV,ZV,NDAT,NUMMER,NRMAX,NUMANZ,
     *              XVALS,ZVALS,XERG,ZERG,ISPAM,ISPA,XPOL,ZPOL,Y,
     *              HELP,IHELP,XSTART,XEND,IPOL,ABST,ABSAUS,XSTA,XEN,
     *              ABSTIN,IWERT,TRACE,NVEND)
         IF(NVEND.GT.NVEM) NVEM=NVEND
         IF(IPOL.LT.1) GOTO 5
         YOK=Y
         IF(HABWRT) GOTO 6
            WRITE (9,900) XMIN,XMAX,YMIN,YMAX,IZEIL,ISPA,DX,DY,
     *                    Y,YEND,XSTART,XEND
            WRITE (6,900) XMIN,XMAX,YMIN,YMAX,IZEIL,ISPA,DX,DY,
     *                    Y,YEND,XSTART,XEND
900         FORMAT (1X,T10,'XMIN=',T20,F8.4,T30,'XMAX=',T40,F8.4,
     *            /,1X,T10,'YMIN=',T20,F8.4,T30,'YMAX=',T40,F8.4,
     *            /,1X,T10,'IZEI=',T20,I8  ,T30,'JSPA=',T40,I8,
     *            /,1X,T10,'DX  =',T20,F8.4,T30,'DY  =',T40,F8.4,
     *            /,1X,T10,'YSTA=',T20,F8.4,T30,'YEND=',T40,F8.4,
     *            /,1X,T10,'XSTA=',T20,F8.4,T30,'XEND=',T40,F8.4)
           HABWRT=.TRUE.
6        CONTINUE
         DO 4 IX=1,ISPA
            IF(ZERG(IX).GT.ZLIM) ZERG(IX)=ZLIM
            IZREC(IX)=10.*ZERG(IX)
C           IZREC(IX)=10.*ZVALS(IX)
4           CONTINUE
CC       CALL ZPLOT (ZVALS,ISPA,0.,36.)
C        DEN ZREC AUSSCHREIBEN
C
C        FALLS AUF MVS PLATTE GESCHRIEBEN WIRD, ENTFAELLT OUTUNI
CMVS     CALL OUTUNI (LCNT,IOUT)
C
         WRITE (IOUT,250) (IZREC(J),J=1,ISPA)
250      FORMAT (20I4)
         YWRT=Y*180./3.1415
         WRITE (6,904) Y,YWRT,NVEND,ISPAM
904      FORMAT (1X,'GESCHRIEBEN Y=',F7.3,' (RADIANS) =',F6.1,
     *              ' GRAD NV=',I8,' (MAX:',I8,').')
      GOTO 5
1000  CONTINUE
      WRITE (6,1011) YOK,NVEM,ISPAM
1011  FORMAT (1X,'LETZTER GUELTIGER Y-WERT =>',F8.4,' ==>',I6,
     *           ' DATEN VON ==> ',I6,' ZULAESSIGEN.')
      IF(IWAS.EQ.1) CALL PLOTE
      STOP
1010  CONTINUE
      WRITE (6,*) 'NRMAX ZU KLEIN'
      GOTO 1000
      END
      SUBROUTINE NUMBER (XSYM,YSYM,HSYM,WERT,PHI,NKOMMA)
C     BEI FORTVCE STILLEGEN
      RETURN
      END
      SUBROUTINE ZPLOT (ZVALS,IX,XSTART,XEND)
      REAL ZVALS(IX)
      HSYM=0.3
      CONST=6.*HSYM/7.
      XVAL=-180.
      ICNT=0
      DX=(XEND-XSTART)/IX
      X=XSTART
      DXV=360./IX
      Y=0.
      CALL PLOT (X,Y,3)
1     CONTINUE
      X=X+DX
      ICNT=ICNT+1
      XVAL=XVAL+DXV
      CALL PLOT (X,Y,2)
      IXTEST=XVAL
      IF(MOD(ICNT,60).NE.0) GOTO 10
         CALL PLOT (X,Y-0.2,2)
CSYM     CALL NUMBER (X-CONST,Y-0.2-1.5*HSYM,HSYM,XVAL,0.,-1)
         CALL PLOT (X,Y-0.2,3)
         CALL PLOT (X,Y,2)
10    CONTINUE
C
      IF(X.LT.XEND) GOTO 1
      X=XSTART-DX
      CALL PLOT (XSTART,15.,3)
      CALL PLOT (XEND,15.,2)
      CALL PLOT (XSTART,10.,3)
      CALL PLOT (XEND,10.,2)
      CALL PLOT (XSTART,5.,3)
      CALL PLOT (XEND,5.,2)
      CALL PLOT (X,ZVALS(1),3)
      XWRT=-180.-DXV
      DO 2 I=1,IX
         XWRT=XWRT+DXV
         X=X+DX
         CALL PLOT (X,ZVALS(I)*0.5,2)
         WRITE (6,4711) I,XWRT,ZVALS(I)
4711     FORMAT (1X,' I=',I5,' L=',F9.3,' Z=',F7.3)
2        CONTINUE
      RETURN
      END
      SUBROUTINE DATWRT (REGEO,NGES,ZV,IREGEO,DATFIO)
      REAL ZV(NGES)
      INTEGER REGEO(20,NGES),DATFIO
      DO 1 N=1,IREGEO
         WRITE (DATFIO,10) (REGEO(J,N),J=5,20),ZV(N)
10       FORMAT ('BCN3',16A1,T36,F10.3)
1        CONTINUE
      RETURN
      END
      SUBROUTINE DATRED (REGEO,NGES,ZV,IREGEO,DATFIO)
      REAL ZV(NGES)
      INTEGER REGEO(20,NGES),DATFIO
      IREGEO=0
1     CONTINUE
      IREGEO=IREGEO+1
      IF(IREGEO.GT.NGES) GOTO 1000
      READ (DATFIO,10,END=100) (REGEO(J,IREGEO),J=1,20),ZV(IREGEO)
10    FORMAT (20A1,T36,F10.3)
      GOTO 1
100   CONTINUE
      IREGEO=IREGEO-1
      RETURN
1000  CONTINUE
      WRITE (6,1001) NGES
1001  FORMAT (1X,'SIE HABEN MEHR ALS =>',I8,' DATEN.')
      IREGEO=NGES
      RETURN
      END
      SUBROUTINE ISORD (REGEO,NNREGE,ZVEK,IREGEO,DATFIL,MESFIL,IWISH)
      REAL ZVEK(NNREGE),QUALI(1000),FAKTOR(20),PACH(14),TEMPS(14)
      INTEGER REGEO(20,NNREGE),DATFIL,MESFIL,DOL,HLP
      LOGICAL DOP
      DATA DOL/'$'/
      ZMAX=-1.E70
      QULIT=100.
      WRITE (MESFIL,4713) DATFIL
4713  FORMAT (1X,'AUF KANAL ',I3,' SOLLEN IHRE DATEN GELESEN WERDEN.')
      IREGEO=1
 999  IREGEO=IREGEO-1
1000  IREGEO=IREGEO+1
      IF(IREGEO.GT.NNREGE) GOTO 1010
C     EINLESEN FUER WDSFRIML-OUTPUT
C     READ (DATFIL,1007,END=1020) (REGEO(J,IREGEO),J=5,20),
C    *      QULIT,FAK1,FAK2,FAK3,FAK4,FAK5,WIN1,SOM1,SAL1,
C    *      WIN5,SOM5,SAL5,WIN8,SOM8,SAL8
C     EINLESEN FUER BDLOG4-OUTPUT
C     READ (DATFIL,1008,END=1020) (REGEO(J,IREGEO),J=5,20),
C    *      QULIT,(FAKTOR(J),J=1,20)
C1008  FORMAT (T5,16A1,T46,7(F4.1,1X),/,T46,7(F4.1,1X),/,T46,7(F4.1,1X))
C1007  FORMAT (T5,16A1,T44,6(F5.2,1X),/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/
C     *        T44,F5.2,T50,F5.2,T56,F5.2)
C1006  FORMAT (T1,A1,T7,16A1,T44,6(F5.2,1X),/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2)
C     EINLESEN FUER P6C OUTPUT
      IF(IWISH.LT.8)
     *   READ (DATFIL,1004,END=1020) HLP,(REGEO(J,IREGEO),J=5,20),
     *         QULIT,FAK1,FAK2,FAK3,FAK4,FAK5,WINA,WINS,SOMS
1004  FORMAT (T1,A1,T5,16A1,T44,F5.1,T50,F5.1,T56,F5.1,T62,F5.1,
     *        T68,F5.1,T74,F5.1,//,
     *        T44,F5.2,T50,F5.2,T62,F5.2)
      IF(IWISH.EQ.8)
     *   READ (DATFIL,1004,END=1020) HLP,(REGEO(J,IREGEO),J=5,20),
     *         FAUMIX
C1003     FORMAT (T1,A1,T5,16A1,T46,F4.1)
C     --BEGINPAHCREAD
      IF (IWISH.NE.9) GOTO 2
C     EINLESEN FUER ZEITSCHEIBEN 1 M.A. IWISH=9
      READ (DATFIL,1009,END=1020) (REGEO(J,IREGEO),J=5,20),ISITE,
     *                            (PACH(J),J=1,7),(TEMPS(J),J=1,7),
     *                            (PACH(J),J=8,14),(TEMPS(J),J=8,14)
1009  FORMAT (T5,16A1,I3,T30,7F7.2,/,T30,7F7.2,/,
     *                   T30,7F7.2,/,T30,7F7.2)
      WRITE (6,1009) (REGEO(J,IREGEO),J=5,20),ISITE,
     *                            (PACH(J),J=1,7),(TEMPS(J),J=1,7),
     *                            (PACH(J),J=8,14),(TEMPS(J),J=8,14)
C     DURCHSCANNEN, WO DIE ERSTE POSITIVE PROBE IST
      IPOS=15
      DO 1 I=1,14
         IF(PACH(I).GE.0.) GOTO 3
1        CONTINUE
3     CONTINUE
      IPOS=I
      IPACH=10
      ZVEK(IREGEO)=PACH(IPACH)
C     ZVEK(IREGEO)=TEMPS(IPACH)
C     QULIT=FLOAT(ISITE)
C     2= OK. 999= MURKS
C     IF(ZVEK(IREGEO).NE.-9.9.AND.ZVEK(IREGEO).NE.-9.) GOTO 2
      IF(ZVEK(IREGEO).GT.-0.1) GOTO 2
         GOTO 999
C        IST DER WERT SOWIESO NICHT ZU GEBRAUCHEN
C        IF(ZVEK(IREGEO).NE.-9.9) GOTO 999
C        IF(IPACH.LT.IPOS) GOTO 999
C        ZVEK(IREGEO)=-0.009
2     CONTINUE
C     --ENDE PAHCREAD
      IF(IWISH.EQ.8) QULIT=90.
C     IF(QULIT.LT.02.) GOTO 999
C     ZVEK(IREGEO)=ABS(SOM6-WIN6)
C     ZVEK(IREGEO)=SOM8
C     ZVEK(IREGEO)=ABS(SOM8-WIN8)
C     ZVEK(IREGEO)=ABS((WIN8+SOM8)/2)
      IF(IWISH.EQ.1) ZVEK(IREGEO)=SOMS
      IF(IWISH.EQ.2) ZVEK(IREGEO)=WINA
      IF(IWISH.EQ.3) ZVEK(IREGEO)=ABS(FAK1)
      IF(IWISH.EQ.4) ZVEK(IREGEO)=ABS(FAK2)
      IF(IWISH.EQ.5) ZVEK(IREGEO)=ABS(FAK3)
      IF(IWISH.EQ.6) ZVEK(IREGEO)=ABS(FAK4)
      IF(IWISH.EQ.7) ZVEK(IREGEO)=ABS(FAK5)
      IF(IWISH.EQ.8) ZVEK(IREGEO)=ABS(FAUMIX)
      IF(ZVEK(IREGEO).GT.ZMAX) ZMAX=ZVEK(IREGEO)
C     QUALI(IREGEO)=QULIT
C     CALL DOPFEI (REGEO,NNREGE,ZVEK,QULIT,IREGEO,QUALI,DOP)
C     IF(DOP) WRITE (6,8787) IREGEO
8787  FORMAT (1X,'DOPPELT IST',I5)
C     IF(DOP) GOTO 999
C
CFAK  BEI DEN FAKTOREN ALLE WERTE MIT 100. MALNEHMEN
CFAK  ZVEK(IREGEO)=ZVEK(IREGEO)*ZVEK(IREGEO)*100.
C
C     BEI DEN FAKTOREN DIE BLANKS NEHMEN, BEI DER DISKORDANZ DIE DOLLARS
C     IF(HLP.NE.DOL) GOTO 999
      WRITE (MESFIL,4711) (REGEO(J,IREGEO),J=5,20),ZVEK(IREGEO),IREGEO
4711  FORMAT (1X,'REG= ',16A1,' ZV=',F8.1,' IREG=',I4)
C     FORMAT FUER DIE DISKORDANZ
C005  FORMAT (T1,A1,T9,16A1,T33,F7.2)
      GOTO 1000
1010  WRITE (MESFIL,1011) NNREGE
1011  FORMAT (1X,'NNREGE IST ZU NIEDRIG, EINLESEFEHLER. NNREGE= ',I5)
      STOP
1020  IREGEO=IREGEO-1
      WRITE (6,1021) ZMAX
1021  FORMAT (1X,'ZMAX DER EINGABEDATEN IST =: ',F10.3)
      RETURN
      END
//E.SYSLIN DD
//         DD DSN=SYSTEM.SGPOBJ(SGP36Z9C),DISP=SHR
//* ZGRID OUTPUTFILE
//FT09F001 DD DSN=SGP36.ZGRID9,DISP=SHR
//*T10F001 DD SYSOUT=R
//* DATEN UM DOPPELTE BEREINIGT
//FT04F001 DD SYSOUT=T
//*T04F001 DD *
//* NACHBARNM FILES
//*T08F001 DD SYSOUT=R
//*T08F001 DD *
//* INPUT FUER IWAS=1
//SYSIN DD *
//SGP36Z   JOB (TEST,H02),PPS,PASSWORD=(ASKJA)
/*JOBPARM T=60,L=80
// EXEC SERVICE
//SYSIN DD *
 SCRATCH ZGRID9
 ALLOCATE ZGRID9 RECORDS(15000) ATTRIBUTES(FIXED,RECSIZE(80), -
 BLKSIZE(3120))
// EXEC FORTVCE,PLOT=D,CPRINT=D
C/ EXEC WATFIV
C/SYSIN DD DATA
C/WATFIV TIME=6000,LINES=20000,PAGES=1000
C     FILES: 6: MESFIL, OUTPUT, MESSAGES
C           12: COLFIL, OUTPUT, FARBEN
C            9  PICFIL, OUTPUT, PIXEL
C            5  DATFIL, INPUT, DATEN
C
C&TRACE OFF
CFI 5 DISK PIUFOR TEMP A
CFI 6 DISK ZGRID MESSAGE A
CFI 9 DISK ZWERT25 GRID A
CFI 12 DISK ZGRID COLORS A
CEXEC FORTE ZGRID
C
C     STAND: 21.12.1990 17.01
      REAL ZREC(800),LATCOR,LONCOR
      INTEGER IZREC(800)
      REAL XV(900),YV(900),ZV(900),HELP(900),XSTOR(1),YSTOR(1),
     *     DSTOR,XVALS(6900),ZVALS(6900),XERG(6900),ZERG(6900),
     *     XPOL(720),ZPOL(720),EQUIL
      INTEGER TEXT(20),REGEO(20,900)
      INTEGER PEGEL(900),IHELP(900)
      INTEGER NGES,NSTOR,IANZ,NZEIL,NSPA,IZEIL,ISPA,ZELLE,
     *        DATFIL,PICFIL,COLFIL,MESFIL,TURBO,DATFIO
      LOGICAL OUTLAW(900),VERBOT(900),NIERO,DRENEW,ERW,CALC,NOSPI,
     *        TRAN,GEIST,STODT,TRACE,HABWRT
C     ARRAYS FUER DIE NACHBARN
      REAL XNAC(500),YNAC(500),A(500),B(500),C(500)
      INTEGER NUMMER(500,9),UNDEF,NCALC(2)
      DATA NGES/900/,NSTOR/1/,IANZ/10/,NST/1/,GENAU/0.5E-06/,
     *     NZEIL/360/,NSPA/720/,IZEIL/360/,ISPA/720/,ISPAM/6900/,
     *     DATFIL/5/,PICFIL/9/,COLFIL/12/,MESFIL/6/,NACFIL/8/,DATFIO/4/
C     INITIALISIERUNGEN FUER ISO/9 (TRIAN)
      DATA DSTOR/0.01/,NIERO/.FALSE./,SW/0./,NRMAX/500/,UNDEF/'UV-0'/,
     *     DRENEW/.TRUE./,TURBO/0/,ERW/.FALSE./,IRANDS/0/,CALC/.FALSE./,
     *     NOSPI/.FALSE./,TRAN/.FALSE./,GEIST/.FALSE./,STODT/.FALSE./
      COMMON /GLEICH/ EQUIL
      RAD(ALPHA)=ALPHA*3.1415/180.
      EQUIL=0.001
C
C     FILES: 6: MESFIL, OUTPUT, MESSAGES
C           12: COLFIL, OUTPUT, FARBEN
C            9  PICFIL, OUTPUT, PIXEL
C            5  DATFIL, INPUT, DATEN
C
C     IWAS=1: TRIANGULIEREN
      IWAS=1
C     IWAS=2: DREIECKE EINLESEN UND VERWENDEN
      IWAS=2
      NACFIO=8
      TRACE=.FALSE.
      ABSAUS=0.5
      DPHI=0.
      DLAM=RAD(-210.)
C     DELTA Z FUER TEMPERATUREN
      ZMIN=0.
      ZMAX=30.
C     IWISH=1 SOMMERTEMP
      IWISH=9
      NRMAX=500
      NGES=900
C     DELTA Z FUER SALINITAETEN
C     ZMIN=32.0
C     ZMAX=39.5
500   CONTINUE
CC    READ (0,*) IWISH,ZMAX
CC    IF(IWISH.LT.1.OR.IWISH.GT.8) GOTO 500
CC    WRITE (0,*) 'IWISH=',IWISH,' ZMAX='
      DXCHEK=0.1
      DYCHEK=0.1
      XMAX=180.
      YMAX=90.
      YMIN=-90.
      XMIN=-180.
      YSTART=-80.
      YEND=80.
      XSTART=-180.
      XEND=180.
      ABSTIN=0.5
      ABST=0.5
      INCR=1
      NACFII=1
      IF(IWAS.EQ.1) CALL PLOTS
      IF(IWAS.EQ.1) CALL PLOT (5.,5.,-3)
      IF(IWAS.EQ.1) WRITE (DATFIO,109)
109   FORMAT ('//FT01F001 DD *')
      IF(IWAS.EQ.1) READ (5,111) TEXT
      IF(IWAS.EQ.2) READ (NACFII,111) TEXT
111   FORMAT (20A4)
      WRITE (9,111) TEXT
      IF(IWAS.EQ.1) WRITE (DATFIO,111) TEXT
      WRITE (6,112) TEXT
112   FORMAT (1X,20A4)
      IF(IWAS.EQ.1) READ (5,111) TEXT
      IF(IWAS.EQ.2) READ (NACFII,111) TEXT
      WRITE (9,111) TEXT
      IF(IWAS.EQ.1) WRITE (DATFIO,111) TEXT
      WRITE (6,112) TEXT
      NST=NSTOR
      IF(IWAS.EQ.1) CALL ISORD (REGEO,NGES,ZV,IREGEO,DATFIL,MESFIL,
     *                         IWISH)
C     MODIFIZEIRTE DATEN LESEN
      IF(IWAS.EQ.2) CALL DATRED (REGEO,NGES,ZV,IREGEO,NACFII)
      IF(IREGEO.LT.1) STOP
      CALL REGKON (REGEO,IREGEO,XV,YV,MESFIL)
      WRITE (6,*) 'IREGEO VOR XYCHECK=',IREGEO
C
      CALL XYCECK (XV,YV,ZV,IREGEO,IREG,DXCHEK,DYCHEK,REGEO)
      IREGEO=IREG
      WRITE (6,*) 'IREGEO NACH XYCHECK=',IREGEO
C     MODIFIZIERTE DATEN AUSSCHREIBEN
      IF(IWAS.EQ.1) CALL DATWRT (REGEO,NGES,ZV,IREGEO,DATFIO)
C
C     LAMBDAMAESSIG VERSCHIEBEN, SO DASS SCHNITT IN AFRIKA IST
      DO 1 I=1,IREGEO
         XV(I)=XV(I)+DLAM
         YV(I)=YV(I)+DPHI
         XV(I)=LONCOR(XV(I))
         YV(I)=LATCOR(YV(I))
CC        XV(I)=(XV(I)+3.)*10.
CC        YV(I)=(YV(I)+1.)*10.
         WRITE (6,1177) I,XV(I),YV(I),ZV(I)
 1177    FORMAT (1X,'I=',I4,' XV=',F9.3,' YV=',F9.3,' ZV=',F9.3)
1        CONTINUE
         NDAT=IREGEO
         NPRIM=IREGEO
         NSTO=IREGEO
         DO 11 I=1,NRMAX
            DO 11 J=1,9
               NUMMER(I,J)=UNDEF
11             CONTINUE
         DO 12 I=1,NGES
            OUTLAW(I)=.FALSE.
12          CONTINUE
         NSTOR=1
         NST=1
         NUMANZ=0
         IF(IWAS.EQ.1) GOTO 13
C           ANSONSTEN DIE NACHBARN EINLESEN
            NUMANZ=0
14          NUMANZ=NUMANZ+1
            IF(NUMANZ.GT.NRMAX) GOTO 1010
            READ (NACFIL,992,END=16) (NUMMER(NUMANZ,J),J=1,9)
C    *                              XNAC(NUMANZ),YNAC(NUMANZ)
992         FORMAT (6I10,/,3I10,2E14.7)
            GOTO 14
16          CONTINUE
            NUMANZ=NUMANZ-1
            WRITE (6,17) NUMANZ
17          FORMAT (1X,'SIE HABEN => ',I5,' NUMMERNZEILEN.')
            IF(NUMANZ.LT.1) GOTO 1000
            GOTO 20
13       CONTINUE
C        CALL PLOTS
C        CALL PLOT (10.,10.,-3)
C
         CALL TRIANG (XV,YV,ZV,NGES,NDAT,NPRIM,NSTO,HELP,IHELP,OUTLAW,
     *                VERBOT,XSTOR,YSTOR,NSTOR,NST,GENAU,
     *                NUMMER,NRMAX,NUMANZ,DSTOR,NIERO,DRENEW,
     *                TURBO,ERW,SW,IRANDS,CALC,
     *                NOSPI,TRAN,TRACE,GEIST,IRC,STODT,MESFIL)
         DO 18 N=1,NUMANZ
            ILINE=N
            CALL NACWRT (NUMMER,NRMAX,NUMANZ,ILINE,NACFIL,XV,YV,ZV,
     *                   NDAT,NPRIM)
18       CONTINUE
         WRITE (6,*) 'FERTIG MIT TRIANG'
         IF(IWAS.EQ.1) CALL PLOTE
         STOP
20       CONTINUE
C        NACCLC WIRD NACH DEM STAND DER DINGE NICHT MEHR BENOETIGT
C        AUS SICHERHEITSGRUENDEN DRINGELASSEN
         IF(IWAS.EQ.1)
     *   CALL NACCLC (XV,YV,ZV,NDAT,XNAC,YNAC,A,B,C,NUMMER,NUMANZ,
     *                NRMAX)
      NCALC(1)=0
      NCALC(2)=0
      INAC=NUMANZ
C
C
      FAKX=IZEIL/(XMAX-XMIN)
      FAKY=ISPA/(YMAX-YMIN)
C     Z-WERT-RASTER BERECHNEN
C     ZUNAECHST X UND Y IN RADIANS WANDELN
C     GRADC=180./3.1415
      GRADC=3.1415/180.
      IOUT=9
C      DO 2 N=1,NDAT
C         XV(N)=XV(N)*GRADC
C         YV(N)=YV(N)*GRADC
C2        CONTINUE
C
C
      WRITE (9,901) ZMIN,ZMAX
901   FORMAT (1X,T10,'ZMIN=',T20,F8.4,T30,'ZMAX=',T40,F8.4)
      XMIN=XMIN*GRADC
      XMAX=XMAX*GRADC
      YMIN=YMIN*GRADC
      YMAX=YMAX*GRADC
      YSTART=YSTART*GRADC
      YEND=YEND*GRADC
      ABST=ABST*GRADC
      XSTA=XSTART
      XEN=XEND
      XSTART=XSTART*GRADC
      XEND=XEND*GRADC
C     DAS X Y RASTER VORBEREITEN
      DX=(XEND-XSTART)/ISPA
      DY=(YEND-YSTART)/IZEIL
C     DAMIT NICHT FUER 10 BREITENGRADE 10000 RECS GESCHRIEBEN WERDEN
C     IF(DY.LT.0.5*DX) DY=DX
C     DY=DX
C     DY=0.0078
      Y=YSTART-DY
C     WRITE (9,900) XMIN,XMAX,YMIN,YMAX,ISPA,IZEIL,DX,DY,YSTART,YEND,
C    *              XSTART,XEND
C900  FORMAT (1X,T10,'XMIN=',T20,F8.4,T30,'XMAX=',T40,F8.4,
C    *      /,1X,T10,'YMIN=',T20,F8.4,T30,'YMAX=',T40,F8.4,
C    *      /,1X,T10,'IZEI=',T20,I8  ,T30,'JSPA=',T40,I8,
C    *      /,1X,T10,'DX  =',T20,F8.4,T30,'DY  =',T40,F8.4,
C    *      /,1X,T10,'YSTA=',T20,F8.4,T30,'YEND=',T40,F8.4,
C    *      /,1X,T10,'XSTA=',T20,F8.4,T30,'XEND=',T40,F8.4)
      LCNT=0
      X=XSTART
C     DIE X-WERTE BLEIBEN KONSTANT
      DO 3 IX=1,ISPA
         XVALS(IX)=X
         X=X+DX
3        CONTINUE
C
C     NUN DIE SCAN SCHLEIFE VON OBEN NACH UNTEN
      HABWRT=.FALSE.
      NVEM=0
5     CONTINUE
      LCNT=LCNT+1
      Y=Y+DY
      IF(Y.GT.YEND) GOTO 1000
         NCALC(1)=0
         NCALC(2)=0
         YWRT=Y*180./3.1415
         TRACE=.FALSE.
         IF(YWRT.GT.20.AND.YWRT.LT.40.) TRACE=.TRUE.
         CALL SCAN (XV,YV,ZV,NDAT,NUMMER,NRMAX,NUMANZ,
     *              XVALS,ZVALS,XERG,ZERG,ISPAM,ISPA,XPOL,ZPOL,Y,
     *              HELP,IHELP,XSTART,XEND,IPOL,ABST,ABSAUS,XSTA,XEN,
     *              ABSTIN,IWERT,TRACE,NVEND)
         IF(NVEND.GT.NVEM) NVEM=NVEND
         IF(IPOL.LT.1) GOTO 5
         YOK=Y
         IF(HABWRT) GOTO 6
            WRITE (9,900) XMIN,XMAX,YMIN,YMAX,IZEIL,ISPA,DX,DY,
     *                    Y,YEND,XSTART,XEND
            WRITE (6,900) XMIN,XMAX,YMIN,YMAX,IZEIL,ISPA,DX,DY,
     *                    Y,YEND,XSTART,XEND
900         FORMAT (1X,T10,'XMIN=',T20,F8.4,T30,'XMAX=',T40,F8.4,
     *            /,1X,T10,'YMIN=',T20,F8.4,T30,'YMAX=',T40,F8.4,
     *            /,1X,T10,'IZEI=',T20,I8  ,T30,'JSPA=',T40,I8,
     *            /,1X,T10,'DX  =',T20,F8.4,T30,'DY  =',T40,F8.4,
     *            /,1X,T10,'YSTA=',T20,F8.4,T30,'YEND=',T40,F8.4,
     *            /,1X,T10,'XSTA=',T20,F8.4,T30,'XEND=',T40,F8.4)
           HABWRT=.TRUE.
6        CONTINUE
         DO 4 IX=1,ISPA
            IZREC(IX)=10.*ZERG(IX)
C           IZREC(IX)=10.*ZVALS(IX)
4           CONTINUE
CC       CALL ZPLOT (ZVALS,ISPA,0.,36.)
C        DEN ZREC AUSSCHREIBEN
C
C        FALLS AUF MVS PLATTE GESCHRIEBEN WIRD, ENTFAELLT OUTUNI
CMVS     CALL OUTUNI (LCNT,IOUT)
C
         WRITE (IOUT,250) (IZREC(J),J=1,ISPA)
250      FORMAT (20I4)
         YWRT=Y*180./3.1415
         WRITE (6,904) Y,YWRT,NVEND,ISPAM
904      FORMAT (1X,'GESCHRIEBEN Y=',F7.3,' (RADIANS) =',F6.1,
     *              ' GRAD NV=',I8,' (MAX:',I8,').')
      GOTO 5
1000  CONTINUE
      WRITE (6,1011) YOK,NVEM,ISPAM
1011  FORMAT (1X,'LETZTER GUELTIGER Y-WERT =>',F8.4,' ==>',I6,
     *           ' DATEN VON ==> ',I6,' ZULAESSIGEN.')
      IF(IWAS.EQ.1) CALL PLOTE
      STOP
1010  CONTINUE
      WRITE (6,*) 'NRMAX ZU KLEIN'
      GOTO 1000
      END
      SUBROUTINE NUMBER (XSYM,YSYM,HSYM,WERT,PHI,NKOMMA)
C     BEI FORTVCE STILLEGEN
      RETURN
      END
      SUBROUTINE ZPLOT (ZVALS,IX,XSTART,XEND)
      REAL ZVALS(IX)
      HSYM=0.3
      CONST=6.*HSYM/7.
      XVAL=-180.
      ICNT=0
      DX=(XEND-XSTART)/IX
      X=XSTART
      DXV=360./IX
      Y=0.
      CALL PLOT (X,Y,3)
1     CONTINUE
      X=X+DX
      ICNT=ICNT+1
      XVAL=XVAL+DXV
      CALL PLOT (X,Y,2)
      IXTEST=XVAL
      IF(MOD(ICNT,60).NE.0) GOTO 10
         CALL PLOT (X,Y-0.2,2)
CSYM     CALL NUMBER (X-CONST,Y-0.2-1.5*HSYM,HSYM,XVAL,0.,-1)
         CALL PLOT (X,Y-0.2,3)
         CALL PLOT (X,Y,2)
10    CONTINUE
C
      IF(X.LT.XEND) GOTO 1
      X=XSTART-DX
      CALL PLOT (XSTART,15.,3)
      CALL PLOT (XEND,15.,2)
      CALL PLOT (XSTART,10.,3)
      CALL PLOT (XEND,10.,2)
      CALL PLOT (XSTART,5.,3)
      CALL PLOT (XEND,5.,2)
      CALL PLOT (X,ZVALS(1),3)
      XWRT=-180.-DXV
      DO 2 I=1,IX
         XWRT=XWRT+DXV
         X=X+DX
         CALL PLOT (X,ZVALS(I)*0.5,2)
         WRITE (6,4711) I,XWRT,ZVALS(I)
4711     FORMAT (1X,' I=',I5,' L=',F9.3,' Z=',F7.3)
2        CONTINUE
      RETURN
      END
      SUBROUTINE DATWRT (REGEO,NGES,ZV,IREGEO,DATFIO)
      REAL ZV(NGES)
      INTEGER REGEO(20,NGES),DATFIO
      DO 1 N=1,IREGEO
         WRITE (DATFIO,10) (REGEO(J,N),J=5,20),ZV(N)
10       FORMAT ('BCN3',16A1,T36,F10.3)
1        CONTINUE
      RETURN
      END
      SUBROUTINE DATRED (REGEO,NGES,ZV,IREGEO,DATFIO)
      REAL ZV(NGES)
      INTEGER REGEO(20,NGES),DATFIO
      IREGEO=0
1     CONTINUE
      IREGEO=IREGEO+1
      IF(IREGEO.GT.NGES) GOTO 1000
      READ (DATFIO,10,END=100) (REGEO(J,IREGEO),J=1,20),ZV(IREGEO)
10    FORMAT (20A1,T36,F10.3)
      GOTO 1
100   CONTINUE
      IREGEO=IREGEO-1
      RETURN
1000  CONTINUE
      WRITE (6,1001) NGES
1001  FORMAT (1X,'SIE HABEN MEHR ALS =>',I8,' DATEN.')
      IREGEO=NGES
      RETURN
      END
      SUBROUTINE ISORD (REGEO,NNREGE,ZVEK,IREGEO,DATFIL,MESFIL,IWISH)
      REAL ZVEK(NNREGE),QUALI(1000),FAKTOR(20),PACH(14),TEMPS(14)
      INTEGER REGEO(20,NNREGE),DATFIL,MESFIL,DOL,HLP
      LOGICAL DOP
      DATA DOL/'$'/
      ZMAX=-1.E70
      QULIT=100.
      WRITE (MESFIL,4713) DATFIL
4713  FORMAT (1X,'AUF KANAL ',I3,' SOLLEN IHRE DATEN GELESEN WERDEN.')
      IREGEO=1
 999  IREGEO=IREGEO-1
1000  IREGEO=IREGEO+1
      IF(IREGEO.GT.NNREGE) GOTO 1010
C     EINLESEN FUER WDSFRIML-OUTPUT
C     READ (DATFIL,1007,END=1020) (REGEO(J,IREGEO),J=5,20),
C    *      QULIT,FAK1,FAK2,FAK3,FAK4,FAK5,WIN1,SOM1,SAL1,
C    *      WIN5,SOM5,SAL5,WIN8,SOM8,SAL8
C     EINLESEN FUER BDLOG4-OUTPUT
C     READ (DATFIL,1008,END=1020) (REGEO(J,IREGEO),J=5,20),
C    *      QULIT,(FAKTOR(J),J=1,20)
C1008  FORMAT (T5,16A1,T46,7(F4.1,1X),/,T46,7(F4.1,1X),/,T46,7(F4.1,1X))
C1007  FORMAT (T5,16A1,T44,6(F5.2,1X),/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/
C     *        T44,F5.2,T50,F5.2,T56,F5.2)
C1006  FORMAT (T1,A1,T7,16A1,T44,6(F5.2,1X),/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2,/,
C     *        T44,F5.2,T50,F5.2,T56,F5.2)
C     EINLESEN FUER P6C OUTPUT
      IF(IWISH.LT.8)
     *   READ (DATFIL,1004,END=1020) HLP,(REGEO(J,IREGEO),J=5,20),
     *         QULIT,FAK1,FAK2,FAK3,FAK4,FAK5,WINA,WINS,SOMS
1004  FORMAT (T1,A1,T5,16A1,T44,F5.1,T50,F5.1,T56,F5.1,T62,F5.1,
     *        T68,F5.1,T74,F5.1,//,
     *        T44,F5.2,T50,F5.2,T62,F5.2)
      IF(IWISH.EQ.8)
     *   READ (DATFIL,1004,END=1020) HLP,(REGEO(J,IREGEO),J=5,20),
     *         FAUMIX
C1003     FORMAT (T1,A1,T5,16A1,T46,F4.1)
C     --BEGINPAHCREAD
      IF (IWISH.NE.9) GOTO 2
C     EINLESEN FUER ZEITSCHEIBEN 1 M.A. IWISH=9
      READ (DATFIL,1009,END=1020) (REGEO(J,IREGEO),J=5,20),ISITE,
     *                            (PACH(J),J=1,7),(TEMPS(J),J=1,7),
     *                            (PACH(J),J=8,14),(TEMPS(J),J=8,14)
1009  FORMAT (T5,16A1,I3,T30,7F7.2,/,T30,7F7.2,/,
     *                   T30,7F7.2,/,T30,7F7.2)
      WRITE (6,1009) (REGEO(J,IREGEO),J=5,20),ISITE,
     *                            (PACH(J),J=1,7),(TEMPS(J),J=1,7),
     *                            (PACH(J),J=8,14),(TEMPS(J),J=8,14)
C     DURCHSCANNEN, WO DIE ERSTE POSITIVE PROBE IST
      IPOS=15
      DO 1 I=1,14
         IF(PACH(I).GE.0.) GOTO 3
1        CONTINUE
3     CONTINUE
      IPOS=I
      IPACH=2
      ZVEK(IREGEO)=PACH(IPACH)
C     ZVEK(IREGEO)=TEMPS(IPACH)
C     QULIT=FLOAT(ISITE)
C     2= OK. 999= MURKS
C     IF(ZVEK(IREGEO).NE.-9.9.AND.ZVEK(IREGEO).NE.-9.) GOTO 2
      IF(ZVEK(IREGEO).GT.-0.1) GOTO 2
         GOTO 999
C        IST DER WERT SOWIESO NICHT ZU GEBRAUCHEN
C        IF(ZVEK(IREGEO).NE.-9.9) GOTO 999
C        IF(IPACH.LT.IPOS) GOTO 999
C        ZVEK(IREGEO)=-0.009
2     CONTINUE
C     --ENDE PAHCREAD
      IF(IWISH.EQ.8) QULIT=90.
C     IF(QULIT.LT.02.) GOTO 999
C     ZVEK(IREGEO)=ABS(SOM6-WIN6)
C     ZVEK(IREGEO)=SOM8
C     ZVEK(IREGEO)=ABS(SOM8-WIN8)
C     ZVEK(IREGEO)=ABS((WIN8+SOM8)/2)
      IF(IWISH.EQ.1) ZVEK(IREGEO)=SOMS
      IF(IWISH.EQ.2) ZVEK(IREGEO)=WINA
      IF(IWISH.EQ.3) ZVEK(IREGEO)=ABS(FAK1)
      IF(IWISH.EQ.4) ZVEK(IREGEO)=ABS(FAK2)
      IF(IWISH.EQ.5) ZVEK(IREGEO)=ABS(FAK3)
      IF(IWISH.EQ.6) ZVEK(IREGEO)=ABS(FAK4)
      IF(IWISH.EQ.7) ZVEK(IREGEO)=ABS(FAK5)
      IF(IWISH.EQ.8) ZVEK(IREGEO)=ABS(FAUMIX)
      IF(ZVEK(IREGEO).GT.ZMAX) ZMAX=ZVEK(IREGEO)
C     QUALI(IREGEO)=QULIT
C     CALL DOPFEI (REGEO,NNREGE,ZVEK,QULIT,IREGEO,QUALI,DOP)
C     IF(DOP) WRITE (6,8787) IREGEO
8787  FORMAT (1X,'DOPPELT IST',I5)
C     IF(DOP) GOTO 999
C
CFAK  BEI DEN FAKTOREN ALLE WERTE MIT 100. MALNEHMEN
CFAK  ZVEK(IREGEO)=ZVEK(IREGEO)*ZVEK(IREGEO)*100.
C
C     BEI DEN FAKTOREN DIE BLANKS NEHMEN, BEI DER DISKORDANZ DIE DOLLARS
C     IF(HLP.NE.DOL) GOTO 999
      WRITE (MESFIL,4711) (REGEO(J,IREGEO),J=5,20),ZVEK(IREGEO),IREGEO
4711  FORMAT (1X,'REG= ',16A1,' ZV=',F8.1,' IREG=',I4)
C     FORMAT FUER DIE DISKORDANZ
C005  FORMAT (T1,A1,T9,16A1,T33,F7.2)
      GOTO 1000
1010  WRITE (MESFIL,1011) NNREGE
1011  FORMAT (1X,'NNREGE IST ZU NIEDRIG, EINLESEFEHLER. NNREGE= ',I5)
      STOP
1020  IREGEO=IREGEO-1
      WRITE (6,1021) ZMAX
1021  FORMAT (1X,'ZMAX DER EINGABEDATEN IST =: ',F10.3)
      RETURN
      END
      SUBROUTINE XYCECK (XV,YV,ZV,IREGEO,IREG,DXCHEK,DYCHEK,REGEO)
      REAL XV(IREGEO),YV(IREGEO),ZV(IREGEO),DXCHEK,DYCHEK
      INTEGER REGEO(20,IREGEO)
      DX=DXCHEK*3.1415/180.
      DY=DYCHEK*3.1415/180.
      WRITE (6,7713) DX,DY
7713  FORMAT (1X,'DX=',F10.5,' DY=',F10.5)
C     BOHRUNGEN DIE DICHTER ALS 1 GRAD LIEGEN ENTWEDER MITTEL ODER
C     RAUSSCHMEISSEN
      IREG=IREGEO
      I=0
1     CONTINUE
      I=I+1
      IF(I.LT.1) I=1
      IF(I.GT.IREG) GOTO 100
         X=XV(I)
         Y=YV(I)
         Z=ZV(I)
         JEND=IREG
         DO 10 J=1,JEND
            IF(I.EQ.J) GOTO 10
               IF(ABS(XV(J)-X).GT.DX.OR.ABS(YV(J)-Y).GT.DY) GOTO 10
                  GOTO 12
10          CONTINUE
C           NAECHSTEN PUNKT
            GOTO 1
12          CONTINUE
C           2 PUNKTE SIND ZU DICHT
C                 MITTELN
C        WRITE (6,7711) I,X,Y,J,XV(J),YV(J),Z,ZV(J)
7711     FORMAT (1X,'I=',I3,'X=',F8.4,' Y=',F8.4,' J=',I3,' XJ=',
     *           F8.4,' YJ=',F8.4,' Z=',F6.2,' ZJ=',F6.2)
                  XV(I)=0.5*(XV(J)+X)
                  YV(I)=0.5*(YV(J)+Y)
                  ZV(I)=0.5*(ZV(J)+Z)
C        WRITE (6,7712) XV(I),YV(I),ZV(I)
7712     FORMAT (1X,' XMIT=',F8.4,' YMIT=',F8.4,' ZMIT=',F8.4)
C                 WERT(J) DELETEN
C                 DER PUNKT J WIRD DELETET
                  CALL DEL (XV,IREGEO,J)
                  CALL DEL (YV,IREGEO,J)
                  CALL DEL (ZV,IREGEO,J)
C                 DEN REGEOCODE AUCH DELETEN
                  ISTART=J
                  IF(ISTART.EQ.IREG) GOTO 13
                     IEND=IREG-1
                     DO 14 K=ISTART,IEND
                        DO 15 L=5,20
                           REGEO(L,K)=REGEO(L,K+1)
15                         CONTINUE
14                      CONTINUE
13                CONTINUE
                  IREG=IREG-1
                  I=I-4
         GOTO 1
100   CONTINUE
      RETURN
      END
      SUBROUTINE SCAN (XV,YV,ZV,NDAT,NUMMER,NRMAX,NUMANZ,
     *                 XVALS,ZVALS,XERG,ZERG,ISPAM,ISPA,XPOL,ZPOL,Y,
     *                 RHELP,IHELP,XSTART,XEND,IPOL,ABST,ABSAUS,
     *                 XSTA,XEN,ABSTIN,IWERT,TRACE,NVEND)
      REAL XV(NDAT),YV(NDAT),ZV(NDAT),XVALS(ISPAM),XERG(ISPAM),
     *     ZERG(ISPAM),ZVALS(ISPAM),XPOL(ISPA),ZPOL(ISPA),RHELP(NDAT),
     *     XCUT(2),YCUT(2),ZCUT(2)
      INTEGER NUMMER(NRMAX,9),I3(3),RC,IHELP(NDAT)
      REAL L,M1,M2,HSYM,RELAUS,ABSAUS,LSTRIN,ABST
      INTEGER ILOCH,ZIFF,NKOMMA
      LOGICAL ENDE,OPEN,LOCH,ZAHL,DRIN,TRACE
      DATA OPEN/.TRUE./,ILOCH/-1/,HSYM/0.2/,SW/0.0/,ZIFF/1/,
     *     NKOMMA/-1/,ZAHL/.FALSE./,RELAUS/0.4/,DRIN/.FALSE./,
     *     LSTRIN/1.0/
C     AUFGABE: ALLE Z-WERTE AUF DIESEM Y-SCAN BESTIMMEN.
C     WEG: SCHNITT MIT DEN DREIECKSKANTEN, AUF DIESEM SCAN. DEN
C          Z-WERT BEI DEM SCHNITT BESTIMMEN.
C          DANN FUER DEN ERSTEN UND LETZTEN PUNKT KONVENTIONELL
C          AUS DEN NAECHSTEN DREI-SECHS PUNKTEN DEN WERT BESTIMMEN
C          DANN AUF DAS POLYGON RUND AUS ISO/9 ANSETZEN UND DAS
C          ERGEBNIS IN ZVALS ZURUECKGEBEN
C
C     FUER ALLE DREIECKE
      NVEND=0
      YWRT=Y*180./3.1415
      IPOL=0
      DO 1 N=1,NUMANZ
C        EIN DREIECK RAUSFISCHEN
         DO 11 J=1,3
            I3(J)=NUMMER(N,J)
11          CONTINUE
C        KANN ES SCHNEIDEN?
         IF(YV(I3(1)).GT.Y.AND.YV(I3(2)).GT.Y.AND.YV(I3(3)).GT.Y  .OR.
     *      YV(I3(1)).LT.Y.AND.YV(I3(2)).LT.Y.AND.YV(I3(3)).LT.Y) GOTO 1
            IPALT=IPOL
            IF(IPALT.LT.1) IPALT=1
C           JA, ES SCHNEIDET.
C           DIE SCHNITTPUNKTE BERECHNEN UND IN XPOL, ZPOL ABSPEICHERN
            CALL TRICUT (XV,YV,ZV,NDAT,I3(1),I3(2),X,Y,XCUT,YCUT,ZCUT,
     *                   ICUT,RC)
C           WRITE (6,5514) I3(1),I3(2),X,Y,XCUT(1),YCUT(1),ZCUT(1),RC
5514        FORMAT (1X,' NR=',2I3,' X,Y=',2F6.2,' XCUT=',F6.2,' YCUT=',
     *                 F6.2,' ZCUT=',F6.2,' RC=',I5)
            IF(RC.EQ.0) CALL STORE (XPOL,ZPOL,IPOL,ISPA,XCUT,ZCUT,ICUT,
     *                              RC)
            CALL TRICUT (XV,YV,ZV,NDAT,I3(2),I3(3),X,Y,XCUT,YCUT,ZCUT,
     *                   ICUT,RC)
C           WRITE (6,5514) I3(2),I3(3),X,Y,XCUT(1),YCUT(1),ZCUT(1),RC
            IF(RC.EQ.0) CALL STORE (XPOL,ZPOL,IPOL,ISPA,XCUT,ZCUT,ICUT,
     *                              RC)
            CALL TRICUT (XV,YV,ZV,NDAT,I3(3),I3(1),X,Y,XCUT,YCUT,ZCUT,
     *                   ICUT,RC)
C           WRITE (6,5514) I3(3),I3(1),X,Y,XCUT(1),YCUT(1),ZCUT(1),RC
            IF(RC.EQ.0) CALL STORE (XPOL,ZPOL,IPOL,ISPA,XCUT,ZCUT,ICUT,
     *                              RC)
C      WRITE (6,*) 'I3=',I3,' IPALT=',IPALT,' IPOL=',IPOL
C      WRITE (6,5511) (XV(I3(J)),YV(I3(J)),ZV(I3(J)),J=1,3)
5511   FORMAT (1X,'XV=',F6.2,' YV=',F6.2,' ZV=',F6.2)
C      WRITE (6,5512) (XPOL(J),ZPOL(J),J=IPALT,IPOL)
5512   FORMAT (1X,'XPOL=',F6.2,' ZPOL=',F6.2)
C
1        CONTINUE
      IF(IPOL.EQ.0) RETURN
            DO 54 IW=1,IPOL
               XWRT=XPOL(IW)*180./3.1415
C              WRITE (6,5515) IW,XWRT,ZPOL(IW)
54             CONTINUE
      CALL SORT (XPOL,ZPOL,IPOL,ISPA)
C     GGF. ECK UND MITTELWERTE ERGAENZEN
      CALL ERG (XPOL,ZPOL,IPOL,ISPA,XV,YV,ZV,NDAT,RHELP,IHELP,XSTART,
     *          XEND,Y)
C     DOPPELTE DELETEN
      I=1
2     I=I+1
      IF(I.GT.IPOL) GOTO 3
         IF(I.EQ.1) GOTO 2
            IF(ABS(XPOL(I)-XPOL(I-1)).GT.ABST) GOTO 2
C              DER PUNKT I WIRD DELETET
4              CONTINUE
               ZPOL(I-1)=0.5*(ZPOL(I)+ZPOL(I-1))
               CALL DEL (XPOL,IPOL,I)
               CALL DEL (ZPOL,IPOL,I)
               IPOL=IPOL-1
               I=I-2
               GOTO 2
3     CONTINUE
C
      YWRT=Y*180./3.1415
       DO 500 I=1,IPOL
          XPOL(I)=XPOL(I)*180./3.1415
          IF(TRACE) WRITE (6,501) I,XPOL(I),ZPOL(I)
          ZVALS(I)=ZPOL(I)
 501      FORMAT (1X,'501 I=',I5,' X=',F9.3,' Z=',F9.3)
 500      CONTINUE
C
C     ZURUNDEN
      NV=0
      CALL RUNDO (XPOL,ZPOL,IPOL,OPEN,ILOCH,HSYM,SW,ZIFF,NKOMMA,ZAHL,
     *            RELAUS,ABSAUS,DRIN,LSTRIN,ABSTIN,XVALS,ZVALS,
     *            ISPAM,NV)
C     JETZT IM ABSTAND VON DX DIE WERTE RAUSFISCHEN, GGF. INTERPOLIEREN
      NVEND=NV
      IF(NV.GT.ISPAM) NV=ISPAM
      CALL ZFISCH (XVALS,ZVALS,ISPAM,ISPA,XERG,ZERG,ABSTIN,XSTA,XEN,
     *             NV,RC,IWERT)
      WRITE (6,*) 'ISPA=',ISPA,' NV=',NV,' IWERT=',IWERT
      RETURN
1000  CONTINUE
      RETURN
      END
      SUBROUTINE ZFISCH (XVALS,ZVALS,ISPAM,ISPA,XERG,ZERG,
     *                   ABST,XSTART,XEND,NV,RC,IWERT)
      REAL XVALS(ISPAM),ZVALS(ISPAM),XERG(ISPAM),ZERG(ISPAM)
      REAL ABST,XSTART,XEND
      REAL GENAU,M,B,XOUT(20),ZOUT(20)
      INTEGER RC
      GENAU=0.001
C     AUFGABE: IM ABSTAND ABST ZWISCHEN XSTART UND XEND AUS DEN ARRAYS
C              XVALS, ZVALS DIE ZWERTE ENTNEHMEN UND IN XERG UND ZERG
C              SPEICHERN
      RC=0
      IWERT=0
      DO 1 I=1,NV
         IF(I.GT.ISPA) GOTO 1
            XERG(I)=XVALS(I)
            ZERG(I)=ZVALS(I)
1           CONTINUE
      IF(NV.LT.2) RETURN
C
C     JETZT ERNSTHAFT VORGEHEN
      DX=ABST
      X=XSTART-DX
      ILOOK=1
2     CONTINUE
        X=X+DX
        IF(X.GT.XEND) GOTO 2000
C       DAS PAAR FINDEN, WO X ZWISCHEN LIEGT
20      CONTINUE
           ILOOK=ILOOK+1
           IF(ILOOK.LT.2) ILOOK=2
           IF(ILOOK.GT.NV) GOTO 1000
              IF(.NOT.(X.GE.XVALS(ILOOK-1)-GENAU.AND.X.LT.XVALS(ILOOK)))
     *                 GOTO 20
                 M=(ZVALS(ILOOK)-ZVALS(ILOOK-1))/
     *             (XVALS(ILOOK)-XVALS(ILOOK-1))
C                M=(ZV(ILOOK)-ZV(ILOOK-1))/(XV(ILOOK)-XV(ILOOK-1)
C                Y=MX + B
                 B=ZVALS(ILOOK-1)-M*XVALS(ILOOK-1)
C                EINSETZEN
                 ZSUM=M*X+B
C     WRITE (6,2111) ILOOK,XVALS(ILOOK-1),XVALS(ILOOK),X,
C    *               ZVALS(ILOOK-1),ZVALS(ILOOK),ZSUM
2111  FORMAT (1X,'ILOOK=',I4,' X-1=',F8.3,' X1=',F8.3,' X=',F8.3,
     *        1X,'            Z-1=',F8.3,' Z1=',F8.3,' Z=',F8.3)
C                ES WURDE EIN PAAR GEFUNDEN
C                ABSTAND NACH VORN UND HINTEN BESTIMMEN
C                XBACK=X-XVALS(ILOOK-1)
C                XADV=XVALS(ILOOK)-X
C                IF(XBACK.LT.1.E-06) XBACK=1.E-06
C                IF(XADV.LT.1.E-06) XADV=1.E-06
C                XBACK=1./(XBACK*XBACK)
C                XADV=1./(XADV*XADV)
C                WSUM=XBACK+XADV
C                ZSUM=ZVALS(ILOOK-1)*XBACK+ZVALS(ILOOK)*XADV
C                ZSUM=ZSUM/WSUM
                 IWERT=IWERT+1
                 IF(IWERT.GT.ISPAM) GOTO 1010
                    XERG(IWERT)=X
                    ZERG(IWERT)=ZSUM
                    ILOOK=ILOOK-1
C                   NAECHSTEN X-WERT
                    GOTO 2
2000  CONTINUE
      IREIN=0
C     DO 2020 I=626,640
C        IREIN=IREIN+1
C        XOUT(IREIN)=XERG(I)
C        ZOUT(IREIN)=ZERG(I)
C2020    CONTINUE
C     WRITE (6,2021) (XOUT(I),ZOUT(I),I=1,14)
2021  FORMAT (1X,'626FF',7(F7.3,1X,F4.1))
C      DO 2010 I=1,IWERT
C         WRITE (6,2011) I,XERG(I),ZERG(I)
C2011     FORMAT (1X,'IWERT=',I5,' XERG=',F10.3,' ZERG=',F7.3)
C2010     CONTINUE
      RETURN
1000  CONTINUE
      WRITE (6,1001) X,XSTART,XEND,XVALS(1),XVALS(NV)
1001  FORMAT (1X,'IHR X-WERT IST IM ORIGINAL ARRAY NICHT VORHANDEN:',
     *           ' X=',F7.2,/,1X,' XSTART=',F7.2,' XEND=',F7.2,
     *           ' ERSTES X=',F7.2,' LETZTES X=',F7.2)
      RC=2
      IF(IWERT.EQ.0) RC=1
      IF(RC.EQ.1) RETURN
C     AUFFUELLEN
      ISTART=IWERT+1
      IF(ISTART.GT.ISPAM) RETURN
         DO 1002 I=ISTART,ISPAM
            X=X+DX
            XERG(I)=X
            ZERG(I)=ZVALS(NV)
1002        CONTINUE
         RETURN
1010  CONTINUE
      WRITE (6,1011) ISPAM
1011  FORMAT (1X,'IHR AUFNAHMEARRY IST MIT => ',I8,' ELEMENTEN ZU ',
     *           'KLEIN.')
      IWERT=ISPAM
      RETURN
      END
      SUBROUTINE ERG (XPOL,ZPOL,IPOL,ISPA,XV,YV,ZV,NDAT,RHELP,IHELP,
     *                XSTART,XEND,Y)
      REAL XPOL(ISPA),ZPOL(ISPA),XV(NDAT),YV(NDAT),ZV(NDAT),
     *     RHELP(NDAT)
      INTEGER IHELP(NDAT)
C     FUER DEN FALL DAS KEINE WERTE GEFUNDEN WURDEN (IPOL=0)
C     WELCHE KONVENTIONELL ERZEUGEN
C     FUER DEN FALL, DASS DIE WERTE NICHT BIS ZUM RAND GEHEN, JE EINEN
C     START UND ENDWERT ERZEUGEN
C     ERZEUGEN DES STARTWERTES
      ZSTART=Z3(XV,YV,ZV,RHELP,IHELP,NDAT,XSTART,Y)
C     DES ENDWERTES
      ZEND=Z3(XV,YV,ZV,RHELP,IHELP,NDAT,XEND,Y)
C     DES MITTENWERTES
      XMIT=0.5*(XSTART+XEND)
      ZMIT=Z3(XV,YV,ZV,RHELP,IHELP,NDAT,XMIT,Y)
C     GGF. UEBERSTEHENDE WERTE DELETEN, FALLS DATEN GROESSERE
C     AUSDEHNUNG HABEN ALS DURCH XSTART,XEND GEGEBEN
      IF(IPOL.LT.1) GOTO 10
         I=0
11       CONTINUE
         I=I+1
         IF(I.GT.IPOL) GOTO 10
            IF(XPOL(I).GE.XSTART) GOTO 10
C              DER PUNKT I WIRD DELETET
               CALL DEL (XPOL,IPOL,I)
               CALL DEL (ZPOL,IPOL,I)
               IPOL=IPOL-1
               I=I-2
               GOTO 11
10    CONTINUE
      IF(IPOL.GT.0) GOTO 15
C        FALLS ES KEINE NORMALEN WERTE GIBT DIE EXTREMA DIREKT VERWENDEN
         XPOL(1)=XSTART
         ZPOL(1)=ZSTART
         XPOL(2)=XMIT
         ZPOL(2)=ZMIT
         XPOL(3)=XEND
         ZPOL(3)=ZEND
         IPOL=3
         RC=0
         RETURN
15    CONTINUE
      IPOLRE=IPOL
C     DEN STARTWERT INSERTEN
      CALL INS (XPOL,ISPA,IPOL,0,XSTART)
      ZSTART=ZPOL(1)
      CALL INS (ZPOL,ISPA,IPOL,0,ZSTART)
      IPOL=IPOL+1
C
      IF(IPOLRE.GT.3) GOTO 20
         CALL INS (XPOL,ISPA,IPOL,1,XMIT)
         CALL INS (ZPOL,ISPA,IPOL,1,ZMIT)
         IPOL=IPOL+1
20    CONTINUE
C     DEN ENDWERT DRANHAENGEN
      IF(IPOL.GE.ISPA) GOTO 100
         IPOL=IPOL+1
         XPOL(IPOL)=XEND
         ZPOL(IPOL)=ZEND
         ZPOL(IPOL)=ZPOL(IPOL-1)
         RETURN
100   CONTINUE
      WRITE (6,4711) ISPA
4711  FORMAT (1X,'SIE HABEN MEHR DREIECKE ALS POTENTIELLE',
     *           ' BILDPUNKTE (',I8,'  )')
      RC=1
      RETURN
      END
      REAL FUNCTION Z3(XV,YV,ZV,RHELP,IHELP,NDAT,XP,YP)
      REAL XV(NDAT),YV(NDAT),ZV(NDAT),RHELP(NDAT)
      INTEGER IHELP(NDAT),I3(3)
C     AUFGABE: BESTIMMT DENM Z-WERT AUS DEN NAECHSTEN 3 PUNKTEN
      ZSUM=0.
      WSUM=0.
      DO 1 I=1,NDAT
         XD=XP-XV(I)
         YD=YP-YV(I)
CALT     RHELP(I)=XD*XD+YD*YD
         DIV=YD*YD
         IF(DIV.LT.0.01) DIV=0.01
         RHELP(I)=1./DIV
         IHELP(I)=I
         WSUM=WSUM+RHELP(I)
         ZSUM=ZSUM+ZV(I)*RHELP(I)
1        CONTINUE
         ZSUM=ZSUM/WSUM
         IF(ZSUM.GT.-1000.) GOTO 500
C     DIE NAECHSTEN 3 BREITENMAESSIG) FINDEN
      NSTART=1
10    CONTINUE
      NMIN=NSTART
      DO 2 I=1,NDAT
         IF(RHELP(I).LT.RHELP(NMIN)) NMIN=I
2        CONTINUE
C     VERTAUSCHEN
      HELP=RHELP(NSTART)
      RHELP(NSTART)=RHELP(NMIN)
      RHELP(NMIN)=HELP
      KHELP=IHELP(NSTART)
      IHELP(NSTART)=IHELP(NMIN)
      IHELP(NMIN)=KHELP
      NSTART=NSTART+1
      IF(NSTART.LT.NDAT) GOTO 10
C     AM BEGINN VON IHELP STEHEN JETZT DIE NUMMERN DER DREI NAECHSTEN
C     PUNKTE
      WRITE (6,*) 'YP=',YP
      DO 55 I=1,NDAT
         IW=IHELP(I)
         WRITE (6,5511) IW,RHELP(I),YV(IW),ZV(IW)
5511     FORMAT (1X,'IP=',I4,' R=',F9.3,' Y=',F9.3,' Z=',F7.2)
55       CONTINUE
C
      DO 4 I=1,3
         I3(I)=IHELP(I)
4        CONTINUE
      WSUM=0.
      ZSUM=0.
      DO 5 I=1,2
         IF(I.GT.1) GOTO 5
         WT=RHELP(I)*RHELP(I)
         IF(WT.LT.1.E-06) WT=1.E-06
         ZSUM=ZSUM+ZV(I3(I))*WT
         WSUM=WSUM+WT
5        CONTINUE
      ZSUM=ZSUM/WSUM
C     WRITE (6,7711) ZSUM,XP,YP,(XV(I3(J)),YV(I3(J)),ZV(I3(J)),J=1,3),I3
C711  FORMAT (1X,'NEUES Z=',F9.3,' FUER X=',F9.3,' Y=',F9.3,/,1X,
C    *        1X,'AUS X,Y,Z=',3F10.3,/
C    *        1X,'AUS X,Y,Z=',3F10.3,/
C    *        1X,'AUS X,Y,Z=',3F10.3,/
C    *           ' MIT I=',3I6)
500   CONTINUE
      Z3=ZSUM
      RETURN
      END
      SUBROUTINE DEL (X,N,IDEL)
      REAL X(N)
C
C     DER PUNKT X(IDEL) Y(IDEL) WIRD DELETED, DIE LAENGE DES VEKTORS
C     IM AUFRUFENDEN PROGRAMM UM 1 VERKUERZT
      IF(IDEL.EQ.N) GOTO 2
         IEND=N-1
         DO 1 I=IDEL,IEND
            X(I)=X(I+1)
1           CONTINUE
2     CONTINUE
      RETURN
      END
      SUBROUTINE INS (XV,NGES,NDAT,N,XSMIT)
      REAL XV(NGES),XSMIT
C     AUFGABE: HINTER N DEN PUNKT XSMIT INSERTEN
      NEND=N+1
      NFROM=NDAT
1     CONTINUE
      XV(NFROM+1)=XV(NFROM)
      NFROM=NFROM-1
      IF(NFROM.GT.N) GOTO 1
         XV(N+1)=XSMIT
         RETURN
      END
      SUBROUTINE SORT (XPOL,ZPOL,IPOL,ISPA)
      REAL XPOL(ISPA),ZPOL(ISPA)
      IF(IPOL.LT.2) RETURN
C        WERTE NACH X SORTIEREN
         NSTART=1
1        CONTINUE
         NMIN=NSTART
         DO 2 N=NSTART,IPOL
            IF(XPOL(N).LT.XPOL(NMIN)) NMIN=N
2           CONTINUE
C           VERTAUSCHEN
            HELP=XPOL(NSTART)
            XPOL(NSTART)=XPOL(NMIN)
            XPOL(NMIN)=HELP
            HELP=ZPOL(NSTART)
            ZPOL(NSTART)=ZPOL(NMIN)
            ZPOL(NMIN)=HELP
            NSTART=NSTART+1
            IF(NSTART.GE.IPOL) RETURN
               GOTO 1
      END
      SUBROUTINE STORE (XPOL,ZPOL,IPOL,ISPA,XCUT,ZCUT,ICUT,RC)
      REAL XPOL(ISPA),ZPOL(ISPA),XCUT(ICUT),ZCUT(ICUT)
      INTEGER RC
C     AUFGABE: DIE SCHNITTWERTE IN XCUT,ZCUT ABLEGEN
      DO 1 I=1,ICUT
         RC=1
         IPOL=IPOL+1
         IF(IPOL.GT.ISPA) GOTO 2
            RC=0
            XPOL(IPOL)=XCUT(I)
            ZPOL(IPOL)=ZCUT(I)
1        CONTINUE
      RETURN
2     CONTINUE
      WRITE (6,4711) ISPA
4711  FORMAT (1X,'SIE HABEN MEHR DREIECKE ALS POTENTIELLE',
     *           ' BILDPUNKTE (',I8,'  )')
      RC=1
      RETURN
      END
      SUBROUTINE TRICUT (XV,YV,ZV,NDAT,I1,I2,X,Y,XCUT,YCUT,ZCUT,ICUT,
     *                   RC)
      REAL XV(NDAT),YV(NDAT),ZV(NDAT),XCUT(2),YCUT(2),ZCUT(2),M,B
      INTEGER RC
      RC=1
      IF(Y.GT.YV(I1).AND.Y.GT.YV(I2).OR.
     *   Y.LT.YV(I1).AND.Y.LT.YV(I2)) RETURN
C     AUFGABE: SCHNEIDET DIE STRECKE XV(I1),YV(I1) - XV(I2),YV(I2)
C              MIT DER HORIZINTALEN Y UND LIEFERT GGF. (FALLS DER
C              SCHNITTPUNKT AUF DER STRECKE LIEGT) DEN WERT ZURUECK
C     STRECKE WAAGERECHT?
      IF(ABS(YV(I1)-YV(I2)).GT.1.E-06) GOTO 1
         IF(XV(I1).LT.XV(I2).AND.(X.LT.XV(I1).OR.X.GT.XV(I2)).OR.
     *      XV(I1).GT.XV(I2).AND.(X.GT.XV(I1).OR.X.LT.XV(I2))) GOTO 10
            YCUT(1)=Y
            XCUT(1)=XV(I1)
            ZCUT(1)=ZV(I1)
            YCUT(2)=Y
            XCUT(2)=XV(I2)
            ZCUT(2)=ZV(I2)
C      WRITE (6,*) 'WAAGERECHT:'
C      WRITE (6,4711) XCUT(1),YCUT(1),ZCUT(1),XCUT(2),YCUT(2),ZCUT(2)
C4711  FORMAT (1X,'X1=',F9.3,' Y1=',F9.3,' Z1=',F9.3,/,
C     *        1X,'X2=',F9.3,' Y2=',F9.3,' Z2=',F9.3,/)
            ICUT=2
            RC=0
            RETURN
1     CONTINUE
C     STRECKE SENKRECHT?
      IF(ABS(XV(I1)-XV(I2)).GT.1.E-06) GOTO 2
         IF(YV(I1).LT.YV(I2).AND.(Y.LT.YV(I1).OR.Y.GT.YV(I2)).OR.
     *      YV(I1).GT.YV(I2).AND.(Y.GT.YV(I1).OR.Y.LT.YV(I2))) GOTO 10
            XCUT(1)=XV(I1)
            YCUT(1)=Y
            ZCUT(1)=ZNEU(ZV(I1),ZV(I2),YV(I1),YV(I2),Y)
            ICUT=1
C     WRITE (6,*) 'SENKRECHT'
C     WRITE (6,4712) XCUT(1),YCUT(1),ZCUT(1)
C712  FORMAT (1X,'X1=',F9.3,' Y1=',F9.3,' Z1=',F9.3,/)
            RC=0
            RETURN
2     CONTINUE
C     STRECKE IST SCHRAEG
C     GERADENGLEICHUNG, M UND B BERECHNEN
      M=(YV(I2)-YV(I1))/(XV(I2)-XV(I1))
      B=YV(I1)-M*XV(I1)
C     Y EINSETZEN X BESTIMMEN
      XC=(Y-B)/M
      YC=Y
C     LIEGT DER PUNKT (XCUT(1),YCUT(1)) AUF DER STRECKE?
C     IF(XV(I1).LT.XV(I2).AND.(XC.LT.XV(I1).OR.XC.GT.XV(I2)).OR.
C    *   XV(I1).GT.XV(I2).AND.(XC.GT.XV(I1).OR.XC.LT.XV(I2))) GOTO 10
C     IF(YV(I1).LT.YV(I2).AND.(YC.LT.YV(I1).OR.YC.GT.YV(I2)).OR.
C    *   YV(I1).GT.YV(I2).AND.(YC.GT.YV(I1).OR.YC.LT.YV(I2))) GOTO 10
         XCUT(1)=XC
         YCUT(1)=Y
         ZCUT(1)=ZNEU(ZV(I1),ZV(I2),YV(I1),YV(I2),Y)
C     WRITE (6,*) 'SCHRAEG: '
C     WRITE (6,4713) XCUT(1),YCUT(1),ZCUT(1)
4713  FORMAT (1X,'X1=',F9.3,' Y1=',F9.3,' Z1=',F9.3,/)
         RC=0
         ICUT=1
         RETURN
10    CONTINUE
      RC=1
      RETURN
      END
      REAL FUNCTION ZNEU (Z1,Z2,Y1,Y2,Y)
      REAL M,B
C     BESTIMMT DEN NEUEN Z-WERT FUER Y AUS Y1,Z1 UND Y2,Z2
      ZNEU=Z1
      IF(Z1.EQ.Z2) RETURN
      ZNEU=(Z1+Z2)/0.5
      IF(ABS(Y1-Y2).LT.1.E-06) RETURN
      M=(Z2-Z1)/(Y2-Y1)
      B=Z1-M*Y1
      ZNEU=M*Y+B
      ZWRT=ZNEU
C     WRITE (6,4711) Y1,Y2,Z1,Z2,ZWRT
C711  FORMAT (1X,'IN ZNEU Y1=',F9.3,' Y2=',F9.3,' Z1=',F9.3,' Z2=',F9.3,
C    *           'ZNEU=',F9.3)
      RETURN
      END
      SUBROUTINE NACCLC (XV,YV,ZV,NDAT,XNAC,YNAC,A,B,C,NUMMER,ILINE,
     *                   NRMAX)
      REAL XV(NDAT),YV(NDAT),ZV(NDAT),XNAC(ILINE),YNAC(ILINE),
     *     A(ILINE),B(ILINE),C(ILINE)
      INTEGER NUMMER(NRMAX,9),I3(3)
C     AUFGABE: FUER JEDES DREIECK DIE EBENENGLEICHUNG BERECHNEN
      DO 1 I=1,ILINE
         DO 10 J=1,3
            I3(J)=NUMMER(I,J)
10          CONTINUE
         XP=XNAC(I)
         YP=YNAC(I)
C        A(I)=(XP-XV(I3(1)))*((YV(I3(2))-YV(I3(1)))*
C    *            (ZV(I3(3))-ZV(I3(1)))-
C    *            (ZV(I3(2))-ZV(I3(1)))*(YV(I3(3))-YV(I3(1))))
C        B(I)=(YP-YV(I3(1)))*((XV(I3(2))-XV(I3(1)))*
C    *            (ZV(I3(3))-ZV(I3(1)))-
C    *            (ZV(I3(2))-ZV(I3(1)))*(XV(I3(3))-XV(I3(1))))
C        C(I)=(XV(I3(2))-XV(I3(1)))*(YV(I3(3))-YV(I3(1)))-
C    *            (YV(I3(2))-YV(I3(1)))*(XV(I3(3))-XV(I3(1)))
         XNAC(I)=(XV(I3(1))+XV(I3(2))+XV(I3(3)))/3.
         YNAC(I)=(YV(I3(1))+YV(I3(2))+YV(I3(3)))/3.
1        CONTINUE
      RETURN
C     VORLAGE AUS ISO/9
C     A=(XP-XV(1))*((YV(2)-YV(1))*
C    *             (ZV(3)-ZV(1))-(ZV(2)-ZV(1))*(YV(3)-YV(1)))
C     B=(YP-YV(1))*((XV(2)-XV(1))*
C    *             (ZV(3)-ZV(1))-(ZV(2)-ZV(1))*(XV(3)-XV(1)))
C     C=(XV(2)-XV(1))*(YV(3)-YV(1))-(YV(2)-YV(1))*(XV(3)-XV(1))
C     ?IST DIE GLEICHUNG TECHNISCH MOEGLICH
C     WRITE (6,4712) ZV,A,B,C
C     IF(ABS(C).LT.1.E-06) RETURN
C        ZWERT1=(B-A+ZV(1)*C)/C
      END
      REAL FUNCTION ZCALC (XV,YV,ZV,NDAT,XNAC,YNAC,INAC,A,B,C,X,Y,
     *                     NUMMER,NUMANZ,NRMAX,NCALC,ZMIN,ZMAX)
      REAL XV(NDAT),YV(NDAT),ZV(NDAT),XNAC(INAC),YNAC(INAC),
     *     A(INAC),B(INAC),C(INAC)
      INTEGER NUMMER(NRMAX,9),I3(3),NCALC(2)
      DATA CC/57.2974/
      ZMIN= 4711.E20
      ZMAX=-4711.E20
C     AUFGABE: FUER X UND Y DEN ZWERT BERECHNEN
C     FUER JEDES DREIECK
      IZ=0
      ZSUM=0.
      WSUM=0.
      DO 1 I=1,INAC
         DO 10 J=1,3
            I3(J)=NUMMER(I,J)
10          CONTINUE
         A(I)=(X-XV(I3(1)))*((YV(I3(2))-YV(I3(1)))*
     *            (ZV(I3(3))-ZV(I3(1)))-
     *            (ZV(I3(2))-ZV(I3(1)))*(YV(I3(3))-YV(I3(1))))
         B(I)=(Y-YV(I3(1)))*((XV(I3(2))-XV(I3(1)))*
     *            (ZV(I3(3))-ZV(I3(1)))-
     *            (ZV(I3(2))-ZV(I3(1)))*(XV(I3(3))-XV(I3(1))))
         C(I)=(XV(I3(2))-XV(I3(1)))*(YV(I3(3))-YV(I3(1)))-
     *            (YV(I3(2))-YV(I3(1)))*(XV(I3(3))-XV(I3(1)))
         IF(ABS(C(I)).LT.1.E-60) GOTO 1
C           DIESER KANN VERARBEITET WERDEN
            IZ=IZ+1
            ZWERT=(B(I)-A(I)+ZV(I3(1))*C(I))/C(I)
            IF(ZWERT.LT.-4..OR.ZWERT.GT.30.) GOTO 1
            IF(ZWERT.LT.ZMIN) ZMIN=ZWERT
            IF(ZWERT.GT.ZMAX) ZMAX=ZWERT
            XL=CC*(X-XNAC(I))
            YL=CC*(Y-YNAC(I))
            WT1=XL*XL+YL*YL
C     WRITE (6,*) 'WT1=',WT1
C           WT=1./(WT*WT*WT)
C           WT=ABS(X-XNAC(I))+ABS(Y-YNAC(I))
            IF(WT1.GT.1.) WT=1./(WT1**5)
            IF(WT1.LT.1.) WT=1.-WT1
C     WRITE (6,7715) I,(ZV(I3(J)),J=1,3),X,Y,ZWERT,WT
7715  FORMAT (1X,'I=',I4,' ZV=',3F15.1,' X=',F7.2,' Y=',F7.2,' Z=',
     *        F15.1,' WT=',E14.7)
            ZSUM=ZSUM+ZWERT*WT
            WSUM=WSUM+WT
1        CONTINUE
      IF(IZ.LT.0.5*ILINE) GOTO 50
         NCALC(1)=NCALC(1)+1
         ZCALC=ZSUM/WSUM
         RETURN
50    CONTINUE
C     IN WENIGER ALS DER HAELFTE HAT ES GEKLAPPT => DER KLASS. ANSATZ
      ZSUM=0.
      WSUM=0.
      DO 52 I=1,NDAT
         XL=(X-XV(I))*0.5
         YL=Y-YV(I)
         RL=1./(XL*XL+YL*YL+1.E-05)
         ZSUM=ZSUM+ZV(I)*RL
         WSUM=WSUM+RL
52       CONTINUE
         NCALC(2)=NCALC(2)+1
      ZCALC=ZSUM/WSUM
      RETURN
      END
      SUBROUTINE OUTUNI (LCNT,IOUT)
      IF(LCNT.LT.250) RETURN
C        IOUT=IOUT+1
         LCNT=0
         RETURN
      END
      REAL FUNCTION ZCALC3 (XV,YV,ZV,N,XWERT,YWERT)
      REAL XV(N),YV(N),ZV(N),XWERT,YWERT
      ZSUM=0.
      WSUM=0.
      DO 1 I=1,N
         XL=0.5*(XWERT-XV(I))
         YL=YWERT-YV(I)
         RL=1./(XL*XL+YL*YL+1.E-05)
         ZSUM=ZV(I)*RL+ZSUM
         WSUM=WSUM+RL
1        CONTINUE
      ZCALC3=ZSUM/WSUM
      RETURN
      END
      SUBROUTINE DOPFEI (REGEO,NNREGE,ZV,QULIT,IREGEO,QUALIT,DOP)
      INTEGER REGEO(20,NNREGE),REGO(20)
      REAL ZV(NNREGE),QULIT,QUALIT(1000)
      LOGICAL DOP
C     LETZTEN REGEOCODE RAUSHOLEN
      DOP=.FALSE.
      DO 1 I=5,20
         REGO(I)=REGEO(I,IREGEO)
1        CONTINUE
C     KOMMT DIESER CODE SCHON IRGENDWO VOR?
      IEND=IREGEO-1
      IF(IEND.LT.1) RETURN
      DO 2 I=1,IEND
C        DO 20 J=5,12
         IF(REGO(20).NE.REGEO(20,I)) GOTO 2
C        0010188776655431
         DO 20 J=10,13
            IF(REGO(J).NE.REGEO(J,I)) GOTO 2
20          CONTINUE
C           DAS DING IST DOPPELT
            IF(QUALIT(I).GE.QULIT) GOTO 30
               ZV(I)=(ZV(IREGEO)+ZV(I))*0.5
               QUALIT(I)=(QULIT+QUALIT(I))*0.5
30          DOP=.TRUE.
            RETURN
2        CONTINUE
      RETURN
      END
      SUBROUTINE REGKON (REGEO,IREGEO,LAMBDA,PHI,MESFIL)
      INTEGER REGEO(20,IREGEO),NUMS(4),RECORD(20),MESFIL
      REAL LAMBDA(IREGEO),PHI(IREGEO)
      DATA NUMS/'1','2','3','4'/
      RAD(ALPHA)=ALPHA*3.1415/180.
      DO 1 I=1,IREGEO
         DO 10 J=5,20
            RECORD(J)=REGEO(J,I)
10          CONTINUE
         LAMBDA(I)=FLOAT(NUM(RECORD,20,5,7,-1,MESFIL))+
     *             FLOAT(NUM(RECORD,20,10,11,-1,MESFIL))/60.+
     *             (FLOAT(NUM(RECORD,20,14,15,-1,MESFIL))+
     *              FLOAT(NUM(RECORD,20,18,18,-1,MESFIL))*0.1)/3600.
         LAMBDA(I)=RAD(LAMBDA(I))
         PHI(I)=FLOAT(NUM(RECORD,20,8,9,-1,MESFIL))+
     *          FLOAT(NUM(RECORD,20,12,13,-1,MESFIL))/60.+
     *          (FLOAT(NUM(RECORD,20,16,17,-1,MESFIL))+
     *           FLOAT(NUM(RECORD,20,19,19,-1,MESFIL))*0.1)/3600.
         PHI(I)=RAD(PHI(I))
         IF(RECORD(20).EQ.NUMS(2).OR.RECORD(20).EQ.NUMS(3))
     *      LAMBDA(I)=-LAMBDA(I)
         IF(RECORD(20).EQ.NUMS(3).OR.RECORD(20).EQ.NUMS(4))
     *      PHI(I)=-PHI(I)
1        CONTINUE
      RETURN
      END
      INTEGER FUNCTION NUM (RECORD,NR,COL1,COL2,ISIGN,MESFIL)
      INTEGER RECORD(NR),COL1,COL2,ISIGN,MINUS,BLANK,MESFIL
      INTEGER NUMS(10),MM,DD,FF,II,CC
      DATA NUMS/'0','1','2','3','4','5','6','7','8','9'/
      DATA MM/'M'/,DD/'D'/,CC/'C'/,FF/'F'/,II/'I'/
      DATA BLANK/' '/
      IPOT=0
      NUM=0
      INDEX=0
      DO 10 I=COL1,COL2
            INDEX=COL2-IPOT
            IF(RECORD(INDEX).EQ.BLANK) GOTO 40
              DO 20 J=1,10
                    IF(RECORD(INDEX).EQ.NUMS(J)) GOTO 30
20                  CONTINUE
              WRITE (MESFIL,4711) COL1,COL2,RECORD
4711          FORMAT (1X,'IN SPALTE:',I10,' BIS SPALTE: ',I10,
     *                   ' SOLLEN NUR ZAHLEN SEINe ',/,80A1)
              STOP
30            NUM=NUM+(J-1)*10**IPOT
              IPOT=IPOT+1
10            CONTINUE
C
40    IF(ISIGN.LE.0) RETURN
         IF(RECORD(ISIGN).EQ.MINUS) NUM=-NUM
         RETURN
      END
      REAL FUNCTION LATCOR (WERT)
      LATCOR=WERT
C     IF(WERT.LT.-1.5707) LATCOR=-1.5707+(-1.5707-WERT)
C     IF(WERT.GT.1.5707) LATCOR=1.5707-(WERT-1.5707)
      IF(WERT.LT.-1.5707) LATCOR=-3.1415-WERT
      IF(WERT.GT.1.5707) LATCOR=3.1415-WERT
      RETURN
      END
      REAL FUNCTION LONCOR (WERT)
      REAL PI/3.1415/
      LONCOR=WERT
C     IF(WERT.GT.PI) LONCOR=-PI+(WERT-PI)
C     IF(WERT.LT.-PI) LONCOR=PI-(-PI-WERT)
      IF(WERT.GT.PI) LONCOR=-PI+(WERT-PI)
      IF(WERT.LT.-PI) LONCOR=PI-(-PI-WERT)
      RETURN
      END
      SUBROUTINE TRIANG (XV,YV,ZV,NGES,NDAT,NPRIM,NSTO,HELP,IHELP,
     *                   OUTLAW,VERBOT,XSTOR,YSTOR,NSTOR,NST,GENAU,
     *                   NUMMER,NRMAX,NUMANZ,DSTOR,NIER2,DRENEW,
     *                   TURBO,ERWREM,SW,IRANDS,CALC,
     *                   NOSPI,TRAN,TRACE,GEIST,IRC,STODAT,MESFIL)
      REAL XV(NGES),YV(NGES),ZV(NGES),HELP(NGES),XSTOR(NSTOR),
     *     YSTOR(NSTOR),DSTOR,ALLPAR(100)
      INTEGER IHELP(NGES),NUMMER(NRMAX,9),I3(3),TURBO,UNDEF,IACK(2)
      LOGICAL OUTLAW(NGES),VERBOT(NGES),DRENEW,IGNORE,ERW,MATSCH(3),
     *        CALC,NIER2,NOSPI,TRAN,TRACE,GEIST,ERWREM,INSTOR,HABTRI,
     *        CHANGE,STODAT
      DATA UNDEF/'UV-0'/
C
C     AUFGABE: AUS RECHENZEITGRUENDEN EINE VORABTRIANGULATION ERSTELLEN,
C              DIE DANN BEIM EIGENTLICHEN RECHNEN MODIFIZIERT WIRD.
C              AUFRUF AUS STEUER (VORPROGRAMM)
      COMMON /WISHES/ ALLPAR
      SEGMIN=1.0
      IPASS=0
      CHANGE=.FALSE.
      ERW=.FALSE.
      NRING=NDAT
      DO 1 I=1,NPRIM
C        EIN STARTDREIECK SUCHEN
C        NEUE DREIECK-ROUTINE (SCHNELLER)
C        GIBT ES SCHON EIN DREIECK MIT I IN NUMMER
         GOTO 12
         IF(NUMANZ.LT.1) GOTO 12
            DO 11 IN=1,NUMANZ
               N1=NUMMER(IN,1)
               N2=NUMMER(IN,2)
               N3=NUMMER(IN,3)
               I3(1)=N1
               I3(2)=N2
               I3(3)=N3
               IF(N1.EQ.I.OR.N2.EQ.I.OR.N3.EQ.I) GOTO 1
   11          CONTINUE
12       CONTINUE
         IF(IPASS.GT.1) GOTO 2
C        ES  IST NOCH GAR NICHT VORHANDEN
         TRACE=.FALSE.
         IF(DRENEW) CALL DRECK (I,XV,YV,ZV,NGES,NDAT,NRING,NPRIM,
     *                          HELP,IHELP,I3,VERBOT,XSTOR,YSTOR,NST,
     *                          IGNORE,OUTLAW,GENAU,TURBO,ERW,SW,IRANDS,
     *                          CALC,NIER2,NOSPI,TRAN,NUMMER,NRMAX,
     *                          NUMANZ,TRACE,DSTOR,GEIST)
C        ALTE DREIECK-ROUTINE (LANGSAMER)
         IF(.NOT.DRENEW) CALL DRECKT(I,XV,YV,NDAT,NRING,HELP,IHELP,
     *                        I3,XSTOR,YSTOR,NST,IGNORE,OUTLAW,GENAU,
     *                        NOSPI)
         TRACE=.TRUE.
         IF(.NOT.IGNORE) GOTO 2
1        CONTINUE
      GOTO 1002
2     CONTINUE
      ILINE=0
      ITEST=1
      NUMREM=NUMANZ
C     DREIECK (STEHT IN I3) ABLEGEN UND DIE NAECHSTEN NACHBARN ERUIEREN
      CALL ABLEG (NUMMER,NRMAX,NUMANZ,I3,IACK,INAH,NCUT,XV,YV,
     *            NGES,NDAT,NPRIM,NSTO,XSTOR,YSTOR,NSTOR,NST,
     *            OUTLAW,GENAU,INSTOR,NP,IMATCH,INDEX,HELP,IHELP,NIER2,
     *            TURBO,NOSPI,IRC,CHANGE,CALC,STODAT,TRACE)
      IF(IRC.LT.0) GOTO 1002
      ILINE=NUMANZ
      IF(NUMREM.LT.NUMANZ)
     *   CALL NACWRT (NUMMER,NRMAX,NUMANZ,ILINE,MESFIL,XV,YV,ZV,
     *                NDAT,NPRIM)
3     CONTINUE
C
C
C     JETZT DIE TRIANGULATIONSSCHLEIFE BEGINNEN
C     AUS JEDER SEITE UND DEM NACHBARN EIN NEUES DREIECK BILDEN
C     DIESES GGF. ABLEGEN UND WIEDER DIE NACHBARN BESTIMMEN
C     AUFHOEHEREN WENN KEINE NEUEN DREIECKE MEHR HINZUGEKOMMEN SIND
C     U N D ALLE NACHBARN DEFINIERT SIND (GROESSER 0 ODER 0)
C
C     ERSTE SEITE
      I3(1)=NUMMER(ILINE,1)
      I3(2)=NUMMER(ILINE,2)
      I3(3)=NUMMER(ILINE,4)
      IF(I3(1).EQ.UNDEF.OR.I3(2).EQ.UNDEF.OR.I3(3).EQ.UNDEF) GOTO 32
      IF(I3(1).LE.0.OR.I3(2).LE.0.OR.I3(3).LE.0) GOTO 32
C     IF(I3(1).GT.NSTO.OR.I3(2).GT.NSTO.OR.I3(3).GT.NSTO) GOTO 32
C
         NUMREM=NUMANZ
C        DIE NACHBARN SIND ALLE DEFINIERT UND GROESSER 0
         CALL ABLEG (NUMMER,NRMAX,NUMANZ,I3,IACK,INAH,NCUT,XV,YV,
     *               NGES,NDAT,NPRIM,NSTO,XSTOR,YSTOR,NSTOR,NST,OUTLAW,
     *               GENAU,INSTOR,NP,IMATCH,INDEX,HELP,IHELP,NIER2,
     *               TURBO,NOSPI,IRC,CHANGE,CALC,STODAT,TRACE)
C
      IF(IRC.LT.0) GOTO 200
      IF(NUMREM.LT.NUMANZ)
     *   CALL NACWRT (NUMMER,NRMAX,NUMANZ,ILINE,MESFIL,XV,YV,ZV,
     *                NDAT,NPRIM)
C
C     ZWEITE SEITE
32    CONTINUE
      I3(1)=NUMMER(ILINE,2)
      I3(2)=NUMMER(ILINE,3)
      I3(3)=NUMMER(ILINE,5)
      IF(I3(1).EQ.UNDEF.OR.I3(2).EQ.UNDEF.OR.I3(3).EQ.UNDEF) GOTO 33
      IF(I3(1).LE.0.OR.I3(2).LE.0.OR.I3(3).LE.0) GOTO 33
C     IF(I3(1).GT.NSTO.OR.I3(2).GT.NSTO.OR.I3(3).GT.NSTO) GOTO 33
         NUMREM=NUMANZ
         CALL ABLEG (NUMMER,NRMAX,NUMANZ,I3,IACK,INAH,NCUT,XV,YV,
     *               NGES,NDAT,NPRIM,NSTO,XSTOR,YSTOR,NSTOR,NST,OUTLAW,
     *               GENAU,INSTOR,NP,IMATCH,INDEX,HELP,IHELP,NIER2,
     *               TURBO,NOSPI,IRC,CHANGE,CALC,STODAT,TRACE)
      IF(IRC.LT.0) GOTO 200
      IF(NUMREM.LT.NUMANZ)
     *   CALL NACWRT (NUMMER,NRMAX,NUMANZ,ILINE,MESFIL,XV,YV,ZV,
     *                NDAT,NPRIM)
C
C     DRITTE SEITE
33    CONTINUE
      I3(1)=NUMMER(ILINE,3)
      I3(2)=NUMMER(ILINE,1)
      I3(3)=NUMMER(ILINE,6)
      IF(I3(1).EQ.UNDEF.OR.I3(2).EQ.UNDEF.OR.I3(3).EQ.UNDEF .OR.
     *   I3(1).LE.0.OR.I3(2).LE.0.OR.I3(3).LE.0) GOTO 34
C     IF(I3(1).GT.NSTO.OR.I3(2).GT.NSTO.OR.I3(3).GT.NSTO) GOTO 34
      NUMREM=NUMANZ
      CALL ABLEG (NUMMER,NRMAX,NUMANZ,I3,IACK,INAH,NCUT,XV,YV,
     *            NGES,NDAT,NPRIM,NSTO,XSTOR,YSTOR,NSTOR,NST,OUTLAW,
     *            GENAU,INSTOR,NP,IMATCH,INDEX,HELP,IHELP,NIER2,TURBO,
     *            NOSPI,IRC,CHANGE,CALC,STODAT,TRACE)
      IF(IRC.LT.0) GOTO 200
      IF(NUMREM.LT.NUMANZ)
     *   CALL NACWRT (NUMMER,NRMAX,NUMANZ,ILINE,MESFIL,XV,YV,ZV,
     *                NDAT,NPRIM)
C     JETZT UNTER DEN NEU GESCHAFFENEN DREIECKEN WEITER NACH UNTEN
C     RUTSCHEN UND EBENSO VERFAHREN
34    CONTINUE
      ILINE=ILINE+1
      IF(ILINE.LE.NUMANZ) GOTO 3
C
C     ES IST KEIN NEUES DREIECK DAZUGEKOMMEN
C     UNDEFINIERTE NACHBARN SIND ERLAUBT, UNDEFINIERTE 3ECKE NICHT
C     NACHBARN VORKOMMEN
      DO 6 IT=ITEST,NUMANZ
         DO 61 J=1,3
            IF(NUMMER(IT,J).EQ.UNDEF) GOTO 7
61          CONTINUE
6        CONTINUE
      GOTO 200
7     CONTINUE
      ITEST=IT
      ILINE=IT
      GOTO 3
200   CONTINUE
      WRITE (6,4712) IPASS
4712  FORMAT (1X,'VORPROCESSING BEENDET. DURCHLAUF NR => ',I6)
      RETURN
C
      I=0
50    CONTINUE
      I=I+1
      IF(I.EQ.0) I=1
      IF(I.GT.NUMANZ) GOTO 60
         DO 52 J=1,6
            IF(NUMMER(I,J).GT.NPRIM) GOTO 54
52          CONTINUE
         GOTO 50
54       CONTINUE
C        DIESE ZEILE DELETEN
         NUMANZ=NUMANZ-1
         DO 56 ITO=I,NUMANZ
            IFROM=ITO+1
            DO 57 J=1,9
               NUMMER(ITO,J)=NUMMER(IFROM,J)
57             CONTINUE
56          CONTINUE
         I=I-2
         GOTO 50
60    CONTINUE
      RETURN
C
C     ANSONSTEN DIE STOERUNGSDATEN MODIFIZIEREN (ERGAENZEN)
1000  CONTINUE
      WRITE (6,1001) NDAT
1001  FORMAT (1X,'SIE BRAUCHEN PLATZ FUER MEHR ALS => ',I6,' DATEN.')
      IRC=-2
      NDAT=NGES
      RETURN
1002  CONTINUE
      WRITE (6,4711)
4711  FORMAT (1X,'VORPROCESSING NICHT MOEGLICH.')
      IRC=-1
1004  CONTINUE
      WRITE (6,1001) NSTOR
1005  FORMAT (1X,'SIE BRAUCHEN PLATZ FUER MEHR ALS => ',I6,
     *           'STOERUNGSPUNKTE.')
      IRC=-1
      RETURN
      END
      SUBROUTINE NACWRT (NUMMER,NRMAX,NUMANZ,LINE,WRTFIL,XV,YV,ZV,
     *                   NDAT,NPRIM)
      REAL XV(NDAT),YV(NDAT),ZV(NDAT)
      INTEGER NUMMER(NRMAX,9),NUMANZ,LINE,WRTFIL,UNDEF
      DATA UNDEF/'UV-0'/
C     AUFGABE: SCHREIBT DIE NACHBARNKONFIGURATION AUS. SOWOHL INS MESFIL
C              (FORTLAUFEND) ALS AUCH INS NRFILO
      XSUM=0.
      YSUM=0.
      DO 991 J=1,6
         IF(NUMMER(LINE,J).GT.NPRIM) GOTO 995
            IF(LINE.GT.NDAT.OR.J.GT.3) GOTO 991
               IF(NUMMER(LINE,J).EQ.UNDEF) GOTO 995
                  XSUM=XSUM+XV(NUMMER(LINE,J))
                  YSUM=YSUM+YV(NUMMER(LINE,J))
991      CONTINUE
      XSUM=XSUM/3.
      YSUM=YSUM/3.
C
      IF(WRTFIL.NE.6) WRITE (WRTFIL,992)
     *                      (NUMMER(LINE,J),J=1,9),XSUM,YSUM
992   FORMAT (6I10,/,3I10,2E14.7)
      IF(WRTFIL.EQ.6) WRITE (WRTFIL,993)
     *                      (NUMMER(LINE,J),J=1,9),XSUM,YSUM
993   FORMAT (1X,6I10,/,3I10,2E14.7)
      IF(WRTFIL.EQ.6) GOTO 995
         XSYM1=XV(NUMMER(LINE,1))
         YSYM1=YV(NUMMER(LINE,1))
         RSYM1=ZV(NUMMER(LINE,1))
C
         XSYM2=XV(NUMMER(LINE,2))
         YSYM2=YV(NUMMER(LINE,2))
         RSYM2=ZV(NUMMER(LINE,2))
C
         XSYM3=XV(NUMMER(LINE,3))
         YSYM3=YV(NUMMER(LINE,3))
         RSYM3=ZV(NUMMER(LINE,3))
         CALL NUMBER (XSYM1,YSYM1,0.05,RSYM1,0.,1)
         CALL NUMBER (XSYM2,YSYM2,0.05,RSYM2,0.,1)
         CALL NUMBER (XSYM3,YSYM3,0.05,RSYM3,0.,1)
C
C
         CALL PLOT (XSYM1,YSYM1,3)
         CALL PLOT (XSYM2,YSYM2,2)
         CALL PLOT (XSYM3,YSYM3,2)
         CALL PLOT (XSYM1,YSYM1,2)
995   CONTINUE
      RETURN
      END
      SUBROUTINE PLTTRI (NUMMER,NRMAX,NUMANZ,XV,YV,ZV,NDAT)
      INTEGER NUMMER(NRMAX,9),I3(3)
      REAL XV(NDAT),YV(NDAT),ZV(NDAT)
      IF(NUMANZ.LT.1) RETURN
      DO 1 N=1,NUMANZ
         DO 11 J=1,3
            I3(J)=NUMMER(N,J)
11          CONTINUE
         CALL PLOT (XV(I3(1)),YV(I3(1)),3)
         CALL PLOT (XV(I3(2)),YV(I3(2)),2)
         CALL PLOT (XV(I3(3)),YV(I3(3)),2)
         CALL PLOT (XV(I3(1)),YV(I3(1)),2)
1     CONTINUE
      RETURN
      END
      SUBROUTINE ABLEG (NUMMER,NRMAX,NUMANZ,I3,IACK,INAH,NCUT,XV,YV,
     *                  NANZ,NDAT,NPRIM,NSTO,XSTOR,YSTOR,NSTOR,NST,
     *                  OUTLAW,GENAU,INSTOR,NP,IMATCH,INDEX,HELP,IHELP,
     *                  NIER2,TURBO,NOSPI,IRC,CHANGE,CALC,STODAT,TRACE)
      INTEGER NUMMER(NRMAX,9),I3(3),IACK(2),INAH,NCUT,NP,IMATCH,INDEX,
     *        IHELP(NANZ),TURBO,UNDEF
      REAL XV(NANZ),YV(NANZ),XSTOR(NSTOR),YSTOR(NSTOR),GENAU,
     *     HELP(NANZ),XSMIT(4),YSMIT(4)
      LOGICAL OUTLAW(NANZ),INSTOR,NIER2,NOSPI,MATSCH(3),WRITEN,SCHNIT,
     *        CHANGE,CALC,STODAT,STENDE,TRACE,HABSIE
      DATA UNDEF/'UV-0'/
C
C     AUFGABE: EIN DREIECK GGF. IN NUMMER ABLEGEN UND DIE NACHBARN
C              DAZU BESTIMMEN. ABLEG VERWENDET WEITE TEILE VON NUMNAH
C     AUFRUF AUS TRIANG ( STEUER)  (VORPROZESS)
      IRC=0
      ISEIT=0
      IF(NUMANZ.EQ.0) GOTO 5
C
         NCUT=UNDEF
C     FINDEN EINES MATCHES
      NCUT=UNDEF
      DO 1 I=1,NUMANZ
         N1=NUMMER(I,1)
         N2=NUMMER(I,2)
         N3=NUMMER(I,3)
         DO 10 J=1,3
            MATSCH(J)=.FALSE.
            IF(I3(J).EQ.N1.OR.I3(J).EQ.N2.OR.I3(J).EQ.N3)
     *         MATSCH(J)=.TRUE.
10          CONTINUE
         IMATCH=I
         IF(MATSCH(1).AND.MATSCH(2).AND.MATSCH(3)) RETURN
CC       IF(MATSCH(1).AND.MATSCH(2).AND.MATSCH(3)) GOTO 3
1        CONTINUE
C
C     DAS AKTUELLE DREIECK WAR NICHT IN DER TABELLE, DAHER WIRD ES
C     HIER AUFGENOMMEN (FALLS PLATZ IST)
5     N1=I3(1)
      N2=I3(2)
      N3=I3(3)
      NUMANZ=NUMANZ+1
      IF(NUMANZ.GT.NRMAX) GOTO 4
         WRITE (6,*) 'ABGELEGT WIRD => ',I3
         DO 2 J=1,3
2           NUMMER(NUMANZ,J)=I3(J)
         I=NUMANZ
C
C
C
         GOTO 3
4     IF(.NOT.WRITEN) WRITE (6,4711)
4711  FORMAT (1X,'IN NUMMER BITTE DEN PLATZ ERHOEHEN (NRMAX).')
      IRC=-1
      WRITEN=.TRUE.
C
C
C     JETZT ZUR DURCH IACK SP. SEITE DIE PASSENDE NUMMER RAUSSUCHEN
CC    WRITE (6,*) ' '
CC    WRITE (6,*) 'NACHBARN ZU DEN SEITEN'
3     CONTINUE
      ISEIT=ISEIT+1
      IF(ISEIT.GT.3) RETURN
      IF(ISEIT.GT.1) GOTO 32
         INAH=0
         IACK(1)=I3(1)
         IACK(2)=I3(2)
         CALL TRICHK (NUMMER,NRMAX,NUMANZ,IACK,HABSIE)
         IF(HABSIE) GOTO 3
         INDEX=4
         GOTO 7
32    CONTINUE
      IF(ISEIT.GT.2) GOTO 33
         INAH=0
         IACK(1)=I3(2)
         IACK(2)=I3(3)
         CALL TRICHK (NUMMER,NRMAX,NUMANZ,IACK,HABSIE)
         IF(HABSIE) GOTO 3
         INDEX=5
         GOTO 7
33    CONTINUE
         INAH=0
         IACK(1)=I3(3)
         IACK(2)=I3(1)
         CALL TRICHK (NUMMER,NRMAX,NUMANZ,IACK,HABSIE)
         IF(HABSIE) GOTO 3
         INDEX=6
7     CONTINUE
      IF(I.GT.NRMAX) GOTO 14
      INAH=NUMMER(I,INDEX)
      IF(INAH.NE.UNDEF) GOTO 1000
C        ZUR AKTUELLEN SEITE EINEN NACHBARN ERUIEREN
C        DEN MITTELPUNKT EINER DREIECKSSEITE
14       XMIT=0.5*(XV(IACK(1))+XV(IACK(2)))
         YMIT=0.5*(YV(IACK(1))+YV(IACK(2)))
         INAH=0
C        DAZU DEN NAECHSTN NACHBARN
         IF(.NOT.NIER2) INAH=NEAR(XV,YV,NDAT,XMIT,YMIT,I3,IACK,
     *                            XSTOR,YSTOR,NST,OUTLAW,GENAU,IHELP,
     *                            HELP,TURBO,NOSPI)
         XMIT=-XMIT
         IF(NIER2) INAH=NEAR2(XV,YV,NDAT,XMIT,YMIT,I3,IACK,
     *                        XSTOR,YSTOR,NST,OUTLAW,GENAU,NOSPI)
C        IF(IACK(1).EQ.50.AND.IACK(2).EQ.51.OR.
C    *      IACK(1).EQ.51.AND.IACK(2).EQ.50) WRITE (6,*) 'INAH=',INAH
         XMIT=ABS(XMIT)
         SCHNIT=.FALSE.
C        NSTO IST >= NPRIM
         IF(.NOT.CALC.AND.INAH.GT.NSTO) INAH=0
C
16       CONTINUE
         IF(I.GT.NRMAX) RETURN
         NUMMER(I,INDEX)=INAH
         IF(SCHNIT) NUMMER(I,INDEX+3)=NCUT
1000  INAH=NUMMER(I,INDEX)
      NCUT=NUMMER(I,INDEX+3)
      IMATCH=I
      GOTO 3
      RETURN
      END
      SUBROUTINE TRICHK (NUMMER,NRMAX,NUMANZ,IACK,HABSIE)
      INTEGER NUMMER(NRMAX,9),NUMANZ,IACK(2),ZEILE(6)
      LOGICAL HABSIE
C     PRUEFT OB ES ZUR MIT IACK(1)-IACK(2) SPEZIFIZIERTEN SEITE
C     EINEN NACHBARN GIBT
      HABSIE=.FALSE.
      IF(NUMANZ.LT.1) RETURN
      DO 1 N=1,NUMANZ
         DO 2 J=1,6
            ZEILE(J)=NUMMER(N,J)
2           CONTINUE
C
C        SEITE 1
         IF(ZEILE(4).GT.0.AND.
     *      (IACK(1).EQ.ZEILE(1).AND.IACK(2).EQ.ZEILE(2).OR.
     *       IACK(2).EQ.ZEILE(1).AND.IACK(1).EQ.ZEILE(2))) GOTO 10
C        SEITE 2
         IF(ZEILE(5).GT.0.AND.
     *      (IACK(1).EQ.ZEILE(2).AND.IACK(2).EQ.ZEILE(3).OR.
     *       IACK(2).EQ.ZEILE(2).AND.IACK(1).EQ.ZEILE(3))) GOTO 10
C        SEITE 3
         IF(ZEILE(6).GT.0.AND.
     *      (IACK(1).EQ.ZEILE(3).AND.IACK(2).EQ.ZEILE(1).OR.
     *       IACK(2).EQ.ZEILE(3).AND.IACK(1).EQ.ZEILE(1))) GOTO 10
1        CONTINUE
      RETURN
10    CONTINUE
      HABSIE=.TRUE.
      RETURN
      END
      SUBROUTINE KREUZ (X,Y)
      CALL PLOT (X-0.1,Y,3)
      CALL PLOT (X+0.1,Y,2)
      CALL PLOT (X,Y-0.1,3)
      CALL PLOT (X,Y+0.1,2)
      RETURN
      END
      SUBROUTINE DRECK (I,XV,YV,ZV,NGES,NANZ,NRING,NPRIM,HELP,IHELP,I3,
     *                  VERBOT,XSTOR,YSTOR,NSTOR,IGNORE,OUTLAW,GENAU,
     *                  TURBO,ERW,SW,IRANDS,CALC,NIER2,NOSPI,TRAN,
     *                  NUMMER,NRMAX,NUMANZ,TRACE,DSTOR,GEIST)
C     AUFGABE: FESTSTELLEN EINES GUELTIGEN DRECKS, DAS ALS EINEN
C              ECKPUNKT XV(I),YV(I) ENTHAELT.
      REAL XV(NGES),YV(NGES),ZV(NGES),HELP(NGES),DMIN,HILF,XSTOR(NSTOR),
     *     YSTOR(NSTOR),SW,DSTOR
      INTEGER I3(3),IHELP(NGES),IHILF,IACK(2),WOHER,DREK,WOHIN,
     *        IDUMMY(1),NDUM,TURBO,IRANDS,ITEST(3),UNDEF,
     *        NUMMER(NRMAX,9)
      LOGICAL VERBOT(NGES),ERW,CALC,NIER2,TRIAD,KLZ,GRZ,NOSPI,TRAN,
     *        WASDA,SCHLUS,TRACE,GEIST
C     IDUMMY NDUM: DUMMIES FUER IREAL UND NREAL
      LOGICAL ENTART,RDRIN,SCHNIT,IGNORE,OUTLAW(NGES),WRITEN
      DATA UNDEF/'UV-0'/
      DATA DREK/'DREK'/,NDUM/1/
      WOHIN=0
      WOHER=DREK
      IGNORE=.FALSE.
      WRITEN=.FALSE.
      I3(1)=I
C     ZUM PUNKT XV(I),YV(I) DIE ENTFERNUNGEN ZU DEN ANDEREN ERUIEREN
C     UND SORTIEREN
C
      ITO=0
      I3(1)=I
      IF(OUTLAW(I)) GOTO 44
      DO 1 J=1,NANZ
           IF(J.EQ.I) GOTO 1
              ITO=ITO+1
              XWURZ=XV(I)-XV(J)
              YWURZ=YV(I)-YV(J)
              HELP(ITO)=XWURZ*XWURZ+YWURZ*YWURZ
              IHELP(ITO)=J
1          CONTINUE
C
      JSTART=1
10    JMIN=JSTART
      DO 2 J=JSTART,ITO
           IF(HELP(J).LT.HELP(JMIN)) JMIN=J
2          CONTINUE
      HILF=HELP(JSTART)
      HELP(JSTART)=HELP(JMIN)
      HELP(JMIN)=HILF
      IHILF=IHELP(JSTART)
      IHELP(JSTART)=IHELP(JMIN)
      IHELP(JMIN)=IHILF
      JSTART=JSTART+1
      IF(JSTART.LE.ITO) GOTO 10
C
C
      II=0
100   II=II+1
      IF(II.GT.ITO) GOTO 101
C     DO 100 II=1,ITO
             IF(II.EQ.I) GOTO 100
                INDEX2=IHELP(II)
                IF(INDEX2.EQ.I) GOTO 100
                IF(NSTOR.EQ.1) GOTO 110
                  IF(OUTLAW(INDEX2)) GOTO 100
105                CALL JOINTC (SCHNIT,XV(I),YV(I),XV(INDEX2),
     *                  YV(INDEX2),XSTOR,YSTOR,NSTOR,NCUT,GENAU)
                   IF(SCHNIT) GOTO 100
110             I3(2)=INDEX2
C
C            JETZT DEN DRITTEN INDEX
             J=II-1
200          J=J+1
             IF(J.GT.ITO) GOTO 201
C            DO 200 J=II,ITO
                    INDEX3=IHELP(J)
                    IF(INDEX3.EQ.I.OR.INDEX3.EQ.INDEX2) GOTO 200
                       IF(OUTLAW(INDEX3)) GOTO 200
115                 I3(3)=INDEX3
C
C                   JETZT DIE PRUEFUNG AUF ENTARTUNG
CENT                IF(ENTART(XV(I3(1)),YV(I3(1)),XV(I3(2)),YV(I3(2)),
CENT *                        XV(I3(3)),YV(I3(3)))) GOTO 200
C
C                   JETZT DIE UMKREISPRUEFUNG
C                   EVTL. EINE EIGENE RDRIN-ROUTINE OHNE IACK SCHREIBEN
                    IACK(1)=I3(1)
                    IACK(2)=I3(2)
                    IF(RDRIN(XV,YV,NANZ,I3,XSTOR,YSTOR,NSTOR,WOHER,
     *                       OUTLAW,GENAU,I3,WOHIN,IACK,IDUMMY,NDUM,
     *                       NOSPI)) GOTO 200
C                   WENN EINER DRINLIEGT WEITERSUCHEN
                    IF(NSTOR.GT.1) GOTO 210
C                      GGF. DAS ERWEITERTE SUCHEN ANWENDEN (300)
                       IF(ERW) GOTO 300
                          R E T U R N
C
210                    GENIN=GENAU
                       IF(GEIST) GENIN=-GENAU
                       CALL JOINTC (SCHNIT,XV(I),YV(I),XV(INDEX3),
     *                      YV(INDEX3),XSTOR,YSTOR,NSTOR,NCUT,GENAU)
                       IF(.NOT.SCHNIT) GOTO 215
                          IF(GEIST) GOTO 55
                             GOTO 200
215                    GENIN=GENAU
                       IF(GEIST) GENIN=-GENAU
                       CALL JOINTC (SCHNIT,XV(INDEX2),YV(INDEX2),
     *                      XV(INDEX3),YV(INDEX3),XSTOR,YSTOR,NSTOR,
     *                      NCUT,GENAU)
                       IF(.NOT.SCHNIT) GOTO 300
                          IF(GEIST) GOTO 55
                             GOTO 200
C
C             SCHON BEIM START GEISTER PRODUZIEREN.
55            IF(.NOT.TRAN.OR..NOT.GEIST) GOTO 44
              IACK(1)=I3(1)
              IACK(2)=I3(2)
              XMIT=(XV(IACK(1))+XV(IACK(2)))*0.5
              YMIT=(YV(IACK(1))+YV(IACK(2)))*0.5
              IF(TRACE) WRITE (6,4715) DSTOR,NCUT
4715          FORMAT (1X,'GUELTIGES DSTOR:',F8.5,' NCUT=',I5)
              WASDA=.FALSE.
C             CALL ADDPT (XV,YV,ZV,NANZ,NPRIM,INDEX3,XSTOR,YSTOR,NSTOR,
C    *                    NCUT,XMIT,YMIT,XNV,YNV,ZNV,GENAU,SCHLUS,
C    *                    OUTLAW,HELP,IHELP,DSTOR,XCUT,YCUT,XDUM,
C    *                    YDUM,WASDA,ISCHON,NUMMER,NRMAX,NUMANZ,I3,
C    *                    IACK)
              IF(.NOT.WASDA) GOTO 94
                 I3(3)=ISCHON
                 GOTO 300
94            IF(SCHLUS) GOTO 44
C
              NANZ=NANZ+1
              IF(NANZ.GT.NGES) GOTO 2020
                 XV(NANZ)=XNV
                 YV(NANZ)=YNV
                 ZV(NANZ)=ZNV
                 IF(TRACE) WRITE (6,4726) XNV,YNV,ZNV
4726             FORMAT (1X,'NEUER PUNKT (X,Y,Z): ',3(F8.2,1X))
                 I3(3)=NANZ
                 RETURN
C
C                GEHEN NACH ERWEITERUNG DENKBAR, DOCH GEFAHR VON
C                ENDLOSSCHLEIFEN
2020          WRITE (6,4716) NGES
4716          FORMAT (1X,'BITTE ERHOEHEN SIE DIE LAENGE VON XV, YV ETC.'
     *             ,/,1X,'EINE LAENGE VON ==> ',I5,' REICHT NICHT.')
                    GOTO 44
C                      WENN ER NICHT SCHNEIDET IST'S OK.
C200                  CONTINUE
C100      CONTINUE
201                   CONTINUE
101       CONTINUE
      IF(I.LE.NPRIM) WRITE(6,4711) XV(I),YV(I),I
4711  FORMAT (1X,'MIT PUNKT (',F10.3,',',F10.3,') NR:',I8,
     *        1X,'KANN KEINE ISOLINIE BEGINNEN.',/,
     *        1X,'ER WIRD DAHER IGNORIERT.'/,
     *        1X,'SO SIE KEINE STOERUNG HABEN, ERHOEHEN SIE BITTE EQUIL'
     *       ,' Z.B. UM EINE ZEHNERPOTENZ.')
44    IGNORE=.TRUE.
      DO 45 J=1,3
45          I3(J)=0
      RETURN
C
C     DAS ERWEITERTE SUCHEN, SCHAUEN OB'S DER DRECK BRINGT (VIA SW)
C     ANSONSTEN GGF. IN ALLE 3 RICHTUNGEN SCHAUEN.
300   IF(.NOT.ERW) RETURN
      IF(TRACE) WRITE (6,4714) I3,IRANDS,GEIST,(ZV(I3(IWRT)),IWRT=1,3)
4714  FORMAT (1X,'IM ERWEITERTEN SUCHBLOCK I3=',3(I5,1X),' IRANDS=',I5,
     *           ' GEIST=',L1,/,1X,' ZV= ',3(F10.4,1X))
      IF(TRIAD(ZV,VERBOT,NANZ,NPRIM,NRING,I3,SW,GENAU,CALC,NSTOR,IRANDS,
     *   GEIST,TRACE)) RETURN
C
      ICNT=0
      DO 302 II=1,3
302          ITEST(II)=I3(II)
310   IACK(1)=ITEST(1)
      IACK(2)=ITEST(2)
      XMIT=0.5*(XV(IACK(1))+XV(IACK(2)))
      YMIT=0.5*(YV(IACK(1))+YV(IACK(2)))
C     HELP UND IHELP WERDEN AB HIER JA NICHT MEHR GEBRAUCHT, SIE
C     KOENNEN DAHER RUHIG UEBERSPEICHERT WERDEN
      IF(NIER2) INAH=NEAR2 (XV,YV,NANZ,XMIT,YMIT,ITEST,IACK,
     *                      XSTOR,YSTOR,NSTOR,OUTLAW,GENAU,NOSPI)
      IF(.NOT.NIER2) INAH=NEAR (XV,YV,NANZ,XMIT,YMIT,ITEST,IACK,
     *                          XSTOR,YSTOR,NSTOR,OUTLAW,GENAU,
     *                          IHELP,HELP,TURBO,NOSPI)
C ATH: KEINE ODER VERKNUEPFUNG MACHEN, DA DURCH DEN COMPILER
C      MASCHINENINTERN DIE REIHENFOLGE VERTAUSCHT SEIN KANN
      ICNT=ICNT+1
      IF(TRACE) WRITE (6,4712) ITEST,IACK,INAH
4712  FORMAT (1X,'I3-TEST=',3(I5,1X),' IACK=',2(I5,1X),' INAH=',I5)
      IF(INAH.EQ.0) GOTO 315
      IF(OUTLAW(INAH)) GOTO 315
         IF(NSTOR.EQ.1) GOTO 350
            GENIN=GENAU
            IF(GEIST) GENIN=-GENAU
            CALL JOINTC (SCHNIT,XMIT,YMIT,XV(INAH),YV(INAH),
     *                   XSTOR,YSTOR,NSTOR,NCUT,GENIN)
         IF(.NOT.SCHNIT) GOTO 350
         IF(TRACE) WRITE (6,4730)
         IF(GEIST.AND.TRAN) GOTO 55
4730     FORMAT (1X,'LIEGT JENSEITS EINER STOERUNG')
C        ANDERE SEITE VERSUCHEN, FALLS NOCH MOEGLICH
C        E.G. EINEN GEIST PRODUZIEREN UND ANFANGEN
315      IF(ICNT.EQ.3) GOTO 44
            GOTO (320,330),ICNT
320         CONTINUE
            ITEST(1)=I3(1)
            ITEST(2)=I3(3)
            ITEST(3)=I3(2)
            GOTO 310
330         CONTINUE
            ITEST(1)=I3(2)
            ITEST(2)=I3(3)
            ITEST(3)=I3(1)
            GOTO 310
350   ITEST(3)=INAH
      IF(TRACE) WRITE (6,4713) ITEST,(ZV(ITEST(IWRT)),IWRT=1,3)
4713  FORMAT (1X,'IM ERW-BLOCK VOR TRIAD-2 ITEST=',3(I5,1X),
     *      /,1X,'                         ZV= ',3(F10.4,1X))
      IF(TRIAD(ZV,VERBOT,NANZ,NPRIM,NRING,ITEST,SW,GENAU,CALC,NSTOR,
     *   IRANDS,GEIST,TRACE)) GOTO 360
      IF(ICNT.EQ.3) GOTO 44
         GOTO(320,330),ICNT
360   DO 365 II=1,3
365          I3(II)=ITEST(II)
      RETURN
      END
      SUBROUTINE MINMAX (VEK,NR,MIN,MAX,IEXTR)
      REAL VEK(NR),MIN,MAX
      INTEGER IEXTR(2)
      MIN=VEK(1)
      MAX=MIN
      DO 1 I=1,NR
           IF(VEK(I).GT.MIN) GOTO 11
              MIN=VEK(I)
              IEXTR(1)=I
11         IF(VEK(I).LT.MAX) GOTO 1
              MAX=VEK(I)
              IEXTR(2)=I
1          CONTINUE
      RETURN
      END
      REAL FUNCTION PHI (X1,Y1,X2,Y2)
      REAL L,X1,Y1,X2,Y2,NINETY
      DATA NINETY/1.5707/
      L=SQRT((Y2-Y1)*(Y2-Y1)+(X2-X1)*(X2-X1))
      IF(Y2.GE.Y1.AND.X2.GE.X1) PHI=ASIN((Y2-Y1)/L)
      IF(Y2.GE.Y1.AND.X2.LT.X1) PHI=ACOS((Y2-Y1)/L)+NINETY
      IF(Y2.LT.Y1.AND.X2.LT.X1) PHI=ASIN((Y1-Y2)/L)+3.1415
      IF(Y2.LT.Y1.AND.X2.GE.X1) PHI=6.28-ASIN((Y1-Y2)/L)
      RETURN
      END
      REAL FUNCTION ASIN (X)
      ASIN=ARSIN(X)
      RETURN
      END
      REAL FUNCTION ACOS (X)
      ACOS=ARCOS(X)
      RETURN
      END
      REAL FUNCTION PHINEW(PHI1,PHI2)
      REAL PI,PI270
      DATA PI/3.14159/,PI270/4.71238/
      PHINEW=(PHI1+PHI2)*0.5
      IF((PHI1.LT.PHI2.AND.PHI1+PI.LT.PHI2)  .OR.
     *   (PHI2.LT.PHI1.AND.PHI2+PI.LT.PHI1))
     *    PHINEW=(PHI1+PI+PHI2)*0.5-PI270
      IF(PHINEW.LT.0.) PHINEW=PHINEW+6.28318530
      RETURN
      END
      LOGICAL FUNCTION TRIAD (ZV,VERBOT,NANZ,NPRIM,NRING,I3,SW,GENAU,
     *                        CALC,NSTOR,IRANDS,GEIST,TRACE)
C     AUFGABE: PRUEFEN OB EIN DURCH I3 SPEZIFIZIERTES DRECK ENTWEDER
C              LOKAL VERBOTEN IST ODER SW NICHT ENTHAELT
C              EIN DREIECK UNTER VERWENDUNG VON RANDDATEN GEHT NICHT.
C     AUFRUF: AUS ISOS
      REAL ZV(NANZ),SW
      INTEGER I3(3),VCNT,IRANDS
      LOGICAL VERBOT(NANZ),INTER2,CUT(3),GROSS(3),CALC,GEIST,GEI(3)
      LOGICAL TRACE
      TRIAD=.FALSE.
      IVERB=0
      IGR=0
      DO 2 J=1,3
           IF(VERBOT(I3(J))) IVERB=IVERB+1
           CUT(J)=.FALSE.
           GROSS(J)=.FALSE.
           GEI(J)=.FALSE.
           IF(I3(J).LE.NPRIM) GOTO 2
              IF(I3(J).LE.NRING) GOTO 22
                 GEI(J)=.TRUE.
22            GROSS(J)=.TRUE.
              IGR=IGR+1
2          CONTINUE
C     ?ALLE DREI VERBOTEN
      IF(TRACE) WRITE (6,4711)
4711  FORMAT (1X,'ALLE 3 VERBOTEN?')
      IF(IVERB.GT.2) RETURN
C     ?MEHR ALS IRANDS RANDDATEN BETEILIGT
      IF(TRACE) WRITE (6,4712) IRANDS
4712  FORMAT (1X,'NEIN. MEHR ALS ',I4,' RANDDATEN BETEILIGT?')
      IF(IGR.GT.IRANDS) RETURN
C     ?BEGINN MIT GEISTERN VERBOTEN
      IF(TRACE) WRITE (6,4713)
4713  FORMAT (1X,'NEIN. VERBOTENE GEISTER BETEILIGT?')
      IF(.NOT.GEIST.AND.(GEI(1).OR.GEI(2).OR.GEI(3))) RETURN
      VCNT=0
C     KEINER EIN PRIMAERWERT - DAS GEHT NICHT
C     ?AN WELCHEN SEITEN SCHNEIDET ER
      IF(INTER2(ZV(I3(1)),ZV(I3(2)),SW)) CUT(1)=.TRUE.
      IF(INTER2(ZV(I3(2)),ZV(I3(3)),SW)) CUT(2)=.TRUE.
      IF(INTER2(ZV(I3(3)),ZV(I3(1)),SW)) CUT(3)=.TRUE.
C     WENN KEINER SCHNEIDET RETURN
      IF(TRACE) WRITE (6,4714)
4714  FORMAT (1X,'NEIN. SCHNEIDET KEINER?')
      IF(.NOT.CUT(1).AND..NOT.CUT(2).AND..NOT.CUT(3)) RETURN
      IF(TRACE) WRITE (6,4715)
4715  FORMAT (1X,'NEIN. IST ER DA, WO ER SCHNEIDET VERBOTEN?')
C     WENN ER DA WO ER SCHNEIDET SCHON VERBOTEN IST => RETURN
      IF(CUT(1).AND.VERBOT(I3(1)).AND.VERBOT(I3(2))  .OR.
     *   CUT(2).AND.VERBOT(I3(2)).AND.VERBOT(I3(3))  .OR.
     *   CUT(3).AND.VERBOT(I3(3)).AND.VERBOT(I3(1))) RETURN
      IF(TRACE) WRITE (6,4716)
4716  FORMAT (1X,'NEIN. ER IST UEBERALL ERFOLGREICH.')
      TRIAD=.TRUE.
      RETURN
C     ES FOLGT ISO9C  **********
      END
      SUBROUTINE DRECKT (I,XV,YV,NPRIM,N,HELP,IHELP,I3,XSTOR,YSTOR,
     *                   NSTOR,IGNORE,OUTLAW,GENAU,NOSPI)
C     AUFGABE: FESTSTELLEN EINES GUELTIGEN DRECKS, DAS ALS EINEN
C              ECKPUNKT XV(I),YV(I) ENTHAELT.
      REAL XV(N),YV(N),HELP(N),DMIN,HILF,XSTOR(NSTOR),YSTOR(NSTOR)
      INTEGER I3(3),IHELP(N),IHILF,IACK(2),WOHER,DREK,WOHIN,
     *        IDUMMY(1),NDUM
C     IDUMMY NDUM: DUMMIES FUER IREAL UND NREAL
      LOGICAL ENTART,RDRIN,SCHNIT,IGNORE,OUTLAW(N),WRITEN,NOSPI
      DATA DREK/'DREK'/
      NDUM=1
      WOHIN=0
      WOHER=DREK
      IGNORE=.FALSE.
      WRITEN=.FALSE.
      I3(1)=I
C     DIE BEIDEN NAECHSTEN NACHBARN ZUM PUNKT XV(I),YV(I) SUCHEN.
C     ZU DEN ERSTEN BEIDEN DENJENIGEN DRITTEN NACHBARN SUCHEN BEI
C     DEM DAS ZUKUENFTIGE DRECK NICHT VERBOTEN IST, NICHT ENTARTET
C     IST UND SW ENTHAELT.
      IF(OUTLAW(I)) GOTO 44
      CALL NAH (XV,YV,N,XV(I),YV(I),HELP,IHELP,I3,XSTOR,YSTOR,NSTOR,
     *          WOHER,OUTLAW,GENAU)
C
C     JETZT UNTER IHELP DENJENIGEN DRITTEN FINDEN, BEI DEM KEINE
C     WEITEREN PUNKTE IM UMKREIS LIEGEN, UND BEI DEM DIE VERBINDUNGS-
C     LINIE ERSTER-DRITTE UND ZWEITER DRITTER KEIN STOERUNGSSEGMENT
C     SCHNEIDET, UND DER KEIN OUTLAW IST UND WOBEI KEIN ENTARTETER
C     DRECK ENTSTEHT.
      IACK(1)=I3(1)
      IACK(2)=I3(2)
      DO 3 J=1,N
           IF(IHELP(J).EQ.I3(1).OR.IHELP(J).EQ.I3(2)) GOTO 3
              I3(3)=IHELP(J)
C          UMKREISPRUEFUNG GILT NICHT FUER ENTARTETEN DRECK
CENT       IF(ENTART(XV(I3(1)),YV(I3(1)),XV(I3(2)),YV(I3(2)),
CENT *               XV(I3(3)),YV(I3(3)))) GOTO 3
           IF(RDRIN(XV,YV,N,I3,XSTOR,YSTOR,NSTOR,WOHER,OUTLAW,
     *              GENAU,I3,WOHIN,IACK,IDUMMY,NDUM,NOSPI)) GOTO 3
           IF(NSTOR.EQ.1) RETURN
              IF(.NOT.OUTLAW(I3(3))) GOTO 55
CTRAN            IF(NOSPI) GOTO 44
                    GOTO 3
55               X1=XV(I3(1))
                 Y1=YV(I3(1))
                 X2=XV(I3(3))
                 Y2=YV(I3(3))
                 CALL JOINTC (SCHNIT,X1,Y1,X2,Y2,XSTOR,YSTOR,NSTOR,NCUT,
     *                        GENAU)
                 IF(.NOT.SCHNIT) GOTO 66
CTRAN               IF(NOSPI) GOTO 44
                       GOTO 3
66               X1=XV(I3(2))
                 Y1=YV(I3(2))
                 CALL JOINTC (SCHNIT,X1,Y1,X2,Y2,XSTOR,YSTOR,NSTOR,NCUT,
     *                        GENAU)
                 IF(.NOT.SCHNIT) RETURN
CTRAN               IF(NOSPI) GOTO 44
                       GOTO 3
3          CONTINUE
      IF(I.LE.NPRIM) WRITE(6,4711) XV(I),YV(I),I
4711  FORMAT (1X,'MIT PUNKT (',F10.3,',',F10.3,') NR:',I8,
     *        1X,'KANN KEINE ISOLINIE BEGINNEN.',/,
     *        1X,'ER WIRD IGNORIERT.'/,
     *        1X,'SO SIE KEINE STOERUNG HABEN, ERHOEHEN SIE BITTE EQUIL'
     *       ,' Z.B. UM EINE ZEHNERPOTENZ.')
44    IGNORE=.TRUE.
      DO 45 J=2,3
45          I3(J)=0
      RETURN
      END
      SUBROUTINE NAH (XV,YV,N,XP,YP,HELP,IHELP,I3,XSTOR,YSTOR,NSTOR,
     *                WOHER,OUTLAW,GENAU)
C     AUFGABE: ZU EINEM PUNKT (XP,YP) ZWEI WEITERE FINDEN,
C              SO DASS EIN NAHES DRECK ENTSTEHT
C     AUFRUF: AUS VURING UND AUS DRECK
C
      REAL XV(N),YV(N),XP,YP,HELP(N),XSTOR(NSTOR),YSTOR(NSTOR)
      INTEGER I3(3),IHELP(N),WOHER,DREK,RING
      LOGICAL SCHNIT,OUTLAW(N),WRITEN
      DATA DREK/'DREK'/,RING/'RING'/
      DO 1111 J=1,3
1111       I3(J)=0
C     DIE ABSTAENDE ZWISCHEN (XP,YP) UND ALLEN ANDEREN PUNKTEN
C     BESTIMMEN, IN HELP SPEICHERN, SORTIEREN UND DIE INDIZES DABEI
C     MIT SORTIEREN, SO DASS IN IHELP DIE INDZES ZU DEN EINZELNEN
C     PUNKTEN IN DER REIHENFOLGE DES ABSTANDES STEHEN.
      WRITEN=.FALSE.
      DO 1 J=1,N
           XWURZ=XP-XV(J)
           YWURZ=YP-YV(J)
           HELP(J)=XWURZ*XWURZ+YWURZ*YWURZ
           IHELP(J)=J
1          CONTINUE
      JSTART=1
10    CONTINUE
      DO 2 J=JSTART,N
           IF(HELP(J).GE.HELP(JSTART)) GOTO 2
             HILF=HELP(JSTART)
             HELP(JSTART)=HELP(J)
             HELP(J)=HILF
             IHILF=IHELP(JSTART)
             IHELP(JSTART)=IHELP(J)
             IHELP(J)=IHILF
2          CONTINUE
      JSTART=JSTART+1
      IF(JSTART.LE.N) GOTO 10
C     JETZT STEHEN AUF IHELP DIE INDIZES NACH DER ENTFERNUNG SORTIERT
C
      I F ( N S T O R . G T . 1 )  G O T O   5 0 0
C
         DO 3 K=1,3
3             I3(K)=IHELP(K)
         R E T U R N
C
C     *********************************************
C
500   IF(WOHER.EQ.RING) GOTO 503
         X1=XV(IHELP(1))
         Y1=YV(IHELP(1))
         I3(1)=IHELP(1)
         GOTO 502
C     WENN NAH AUS DRECK AUFGERUFEN WIRD IST DER ERSTE = (XP,YP)
C     UND SOMIT A PRIORI KEIN OUTLAW
C
C
C
503   DO 501 L=1,N
             IF(OUTLAW(IHELP(L))) GOTO 501
             X1=XV(IHELP(L))
             Y1=YV(IHELP(L))
             I3(1)=IHELP(L)
C            AUF STOERUNGSSCHNITT PRUEFEN
C            DER ERSTE NICHT SCHNEIDENDE WIRD GENOMMEN.
             CALL JOINTC (SCHNIT,XP,YP,X1,Y1,XSTOR,YSTOR,NSTOR,NCUT,
     *                    GENAU)
             IF(.NOT.SCHNIT) GOTO 502
C
501          CONTINUE
      IF(WOHER.EQ.RING) GOTO 7
         WRITE (6,5201) IHELP(1)
5201     FORMAT (1X,'DER PUNKT: ',I8,' BEFINDET SICH IM SCHATTEN EINER',
     *         /,1X,' STOERUNG (KEIN NACHBAR). SR-NAH / DRECK.')
         STOP
C
C     DEN NAECHSTEN NACHBARN ZU X1 Y1 FINDEN, WOBEI DIE VERBINDUNGS-
C     LINIE ZU IHM KEINE STOERUNG SCHHNEIDEN DARF, ER SELBER DARF AUCH
C     NICHT IM STOERUNGSSCHATTEN STEHEN. NAH WIRD AUS DRECK AUFGERUFEN,
C     WOBEI DRECK NUR DANN AUFGERUFEN WIRD, WENN DER AUSGANGSWERT
C     KEIN SCHATTENWERT IST.
C
C
502   DO 4 L=1,N
C          EIN EINZUBEZIEHENDER DARF NATUERLICH KEIN OUTLAW SEIN
C          DER NEUE DARF NATUERLICH NICHT GLEICH DEM ERSTEN SEIN
C          BEIM AUFRUF AUS DRECK IST X1 NATUERLICH GLEICH XP DITO Y.
C          SO DIE UEBERPRUEFUNG VON X1 O.K. IST KANN ER ABHAUN.
C
           IF(OUTLAW(IHELP(L)).OR.IHELP(L).EQ.I3(1)) GOTO 4
           X2=XV(IHELP(L))
           Y2=YV(IHELP(L))
           CALL JOINTC (SCHNIT,XP,YP,X2,Y2,XSTOR,YSTOR,NSTOR,NCUT,GENAU)
           IF(SCHNIT) GOTO 4
             IF(WOHER.NE.RING) GOTO 600
           CALL JOINTC (SCHNIT,X1,Y1,X2,Y2,XSTOR,YSTOR,NSTOR,NCUT,GENAU)
           IF(SCHNIT) GOTO 4
600           I3(2)=IHELP(L)
              GOTO 6
4          CONTINUE
C
      IF(WOHER.EQ.RING) GOTO 7
C
      WRITE(6,4711) X1,Y1,I3(1)
4711  FORMAT (1X,'IN EINEM VON STOERUNGEN UMGRENZTEN TEILBEREICH ',
     *           'FINDET SICH NUR EIN PUNKT - ',/,
     *        1X,'DAS SIND ZWEI ZU WENIG. ISO/9 BRICHT DAHER AB.'/,
     *        1X,'DER EINE PUNKT IST (X,Y): (',F10.3,',',F10.3,').',/,
     *        1X,'SO WIE ES AUSSIEHT, TRAEGT ER DIE NUMMER ',I10)
      STOP
C
C     JETZT DEN DRITTEN FINDEN. WEDER DARF DIE LINIE VOM ERSTEN ZUM
C     DRITTEN NOCH DIE VOM ZWEITEN ZUM DRITTEN EINE STOERUNG SCHNEIDEN.
C     EIN DRITTER MUSS NUR BEIM AUFRUF AUS VURING GEFUNDEN WERDEN,
C     NICHT BEIM AUFRUF AUS DRECK. STEUERUNG UEBER WOHER.
C
6     IF(WOHER.NE.RING) RETURN
C     HIER KOMMT ER NUR AUS VURING HIN
      LSTART=L
      IF(LSTART.GT.N) GOTO 7
      DO 5 L=LSTART,N
           IF(OUTLAW(IHELP(L)).OR.IHELP(L).EQ.I3(1).OR.IHELP(L)
     *        .EQ.I3(2)) GOTO 5
           X3=XV(IHELP(L))
           Y3=YV(IHELP(L))
           CALL JOINTC (SCHNIT,X1,Y1,X3,Y3,XSTOR,YSTOR,NSTOR,NCUT,GENAU)
           IF(SCHNIT) GOTO 5
           CALL JOINTC (SCHNIT,X2,Y2,X3,Y3,XSTOR,YSTOR,NSTOR,NCUT,GENAU)
           IF(SCHNIT) GOTO 5
           CALL JOINTC (SCHNIT,XP,YP,X3,Y3,XSTOR,YSTOR,NSTOR,NCUT,GENAU)
           IF(SCHNIT) GOTO 5
              I3(3)=IHELP(L)
              RETURN
5          CONTINUE
C
C
C     WENN VIRTUELLE RANDDATEN ERZEUGT WERDEN SOLLEN, KANN DER JEW.
C     PUNKT JA AUCH RANDWAERTS VON RANDSTOERUNGEN LIEGEN. IN SO EINEM
C     FALL IST DAS "NICHT-FINDEN" VON NACHBARN DIE REGEL.
7     DO 8 J=1,3
8          I3(J)=(-1)
      RETURN
      END
      LOGICAL FUNCTION RDRIN2 (XV,YV,N,ITEST,XSTOR,YSTOR,NSTOR,VONWO,
     *                         OUTLAW,GENAU,I3,WOHIN,IACK,NOSPI)
      REAL XV(N),YV(N),XSTOR(NSTOR),YSTOR(NSTOR)
      INTEGER ITEST(3),NEAR,VONWO,I3(3),WOHIN,IACK(2),
     *        DRECK
      LOGICAL SCHNIT,OUTLAW(N),STOR,SCHNIP,ENTART,NOSPI,SCHREI,ONCHK
C     ONCHK=.TRUE. : ES WIRD NUR AUF ENTARTUNG GEPRUEFT.
      DATA NEAR/'NEAR'/,DRECK/'DREK'/
      RDRIN2=.FALSE.
      SCHREI=.FALSE.
      STOR=.FALSE.
      IF(NSTOR.GT.1) STOR=.TRUE.
C     WENN IN DEM UMKREIS MINDESTENS EIN WEITERER PUNKT LIEGT,
C     BEI DEM DIE VERBINDUNGSLINIE VON IHM ZUM MITTELPUNKT
C     KEINE STOERUNG SCHNEIDET: DANN RDRIN = .TRUE.
C     AUSSER: ER IST EIN OUTLAW
C
      ENTART=.FALSE.
      ONCHK=.FALSE.
      CALL UMKREI (XV(ITEST(1)),YV(ITEST(1)),XV(ITEST(2)),
     *             YV(ITEST(2)),XV(ITEST(3)),YV(ITEST(3)),XMIT,
     *             YMIT,R,GENAU,ENTART,ONCHK)
      IF(ENTART) GOTO 5
C     R IST HIER IN WIRKLICHKEIT R-QUADRAT
      DO 1 I=1,N
C          OUTLAWS DUERFEN IM UMKREIS LIEGEN EBENSO WIE PUNKTE JENSEITS
C          VON STOERUNGEN.
           IF(VONWO.NE.NEAR.AND.VONWO.NE.DRECK.AND.OUTLAW(I).OR.
     *        I.EQ.ITEST(1).OR.I.EQ.ITEST(2).OR.I.EQ.ITEST(3).OR.
     *        I.EQ.I3(1).OR.I.EQ.I3(2).OR.I.EQ.I3(3)) GOTO 1
              XWURZ=XMIT-XV(I)
              YWURZ=YMIT-YV(I)
              TEST=XWURZ*XWURZ+YWURZ*YWURZ
              IF(TEST.GE.R) GOTO 1
C                UEBERTSPITZE DREIECKE SIND NICHT GESTATTET,FALLS NOSPI
C                = .TRUE.
C
C             JETZT FAELLE PRUEFEN, OB IM UMKREIS EINER LIEGEN DARF.
              IF(VONWO.NE.NEAR) GOTO 2
C                DIESER BLOCK IST NUR FUER FAELLE, WO ER SCHON EIN
C                AKTUELLES DREIECK MIT EINER AKTUELLEN SEITE HAT, ALSO
C                NICHT FUER FAELLE, WO WOHIN = 0 IST (Z.B. AUS DRECK).
C                LIEGT EINER DRIN, DER HINTER DEM DREIECK LIEGT, SO
C                MACHYS NICHTS
C
                 XCENT=(XV(IACK(1))+XV(IACK(2)))*0.5
                 YCENT=(YV(IACK(1))+YV(IACK(2)))*0.5
                 GOTO(20,30,40),WOHIN
C
20               IF(SCHNIP(XCENT,YCENT,XV(I),YV(I),XV(I3(2)),YV(I3(2)),
     *                     XV(I3(3)),YV(I3(3)),GENAU) .OR.
     *              SCHNIP(XCENT,YCENT,XV(I),YV(I),XV(I3(3)),YV(I3(3)),
     *                     XV(I3(1)),YV(I3(1)),GENAU)) GOTO 1
                 GOTO 3
30               IF(SCHNIP(XCENT,YCENT,XV(I),YV(I),XV(I3(1)),YV(I3(1)),
     *                     XV(I3(3)),YV(I3(3)),GENAU)     .OR.
     *              SCHNIP(XCENT,YCENT,XV(I),YV(I),XV(I3(1)),YV(I3(1)),
     *                     XV(I3(2)),YV(I3(2)),GENAU)) GOTO 1
                 GOTO 3
40               IF(SCHNIP(XCENT,YCENT,XV(I),YV(I),XV(I3(1)),YV(I3(1)),
     *                     XV(I3(2)),YV(I3(2)),GENAU)     .OR.
     *              SCHNIP(XCENT,YCENT,XV(I),YV(I),XV(I3(2)),YV(I3(2)),
     *                     XV(I3(3)),YV(I3(3)),GENAU)) GOTO 1
                 GOTO 3
C
C
2             IF(NSTOR.EQ.1.OR.NOSPI) GOTO 3
              IF(VONWO.EQ.NEAR) GOTO 4
                 IF(OUTLAW(I)) GOTO 3
C                ES WIRD JA ZU SCON 2 VORHANDENEN DER DRITTE GESUCHET.
                 XCENT=(XV(ITEST(1))+XV(ITEST(2)))*0.5
                 YCENT=(YV(ITEST(1))+YV(ITEST(2)))*0.5
4             SCHNIT=.FALSE.
              IF(STOR) CALL JOINTC (SCHNIT,XCENT,YCENT,XV(I),YV(I),
     *                              XSTOR,YSTOR,NSTOR,NCUT,GENAU)
                 IF(.NOT.SCHNIT) GOTO 3
                 GOTO 1
3          CONTINUE
C          WENN DER DER IM UMKREIS LIEGT MIT DEN BEIDEN AKTUELLEN EINEN
C          ENTARTETEN DRECK BILDEN WUERDE, DANN DIESEN NICHT BEACHTEN
      ENTART=.FALSE.
      ONCHK=.TRUE.
      CALL UMKREI (XV(IACK(1)),YV(IACK(1)),XV(IACK(2)),
     *             YV(IACK(2)),XV(I),YV(I),XMITD,YMITD,
     *             RD,GENAU,ENTART,ONCHK)
       IF(ENTART) GOTO 1
CENT       IF(ENTART(XV(IACK(1)),YV(IACK(1)),XV(IACK(2)),YV(IACK(2)),
CENT *               XV(I),YV(I))) GOTO 1
             RDRIN2=.TRUE.
             RETURN
1          C O N T I N U E
      RETURN
5     RDRIN2=.TRUE.
      R E T U R N
      END
      INTEGER FUNCTION NEAR (XV,YV,N,XMIT,YMIT,I3,IACK,XSTOR,YSTOR,
     *                       NSTOR,OUTLAW,GENAU,IREAL,HELP,TURBO,NOSPI)
      REAL XV(N),YV(N),XMIT,YMIT,XSTOR(NSTOR),YSTOR(NSTOR),HELP(N)
      INTEGER I3(3),IACK(2),ITEST(3),VONWO,NIER,J,WOHIN,
     *        WOHER,DRECK,IREAL(N),TURBO
      LOGICAL SCHNIP,ENTART,HABMIN,RDRIN,OUTLAW(N),SCHREI,NOSPI
      DATA NIER/'NEAR'/,DRECK/'DREK'/
C     ZU (XMIT,YMIT) DEN NAECHSTEN NACHBARN, ABER AUSSERHALB DES
C     AKTUELLEN, MIT DEN INDIZES IN I3 GESPEICHERTEN DRECKS. DAS
C     POTENTIELLE NEUE DRECK MUSS SO SEIN, DASS KEINE SEINER POTEN-
C     TIELLEN SEITEN (= VERBINDUNGSLINIEN (XMIT,YMIT)_(XV(NEAR),YV(NEAR)
C     DAS AKTUELLE DRECK SCHNEIDET. AUCH DARF DAS POTENTIELLE NEUE DRECK
C     KEIN ENTARTETER DRECK SEIN.
C     DER SCHNITT DARF NUR FUER DIEJENIGEN SEITEN GEPRUEFT WERDEN, DIE
C     N I C H T (XMIT,YMIT) (UEBER IACK ZU ERKENNEN) ENTHALTEN.
C
      SCHREI=.FALSE.
C     IF(I3(1).EQ.4.AND.I3(2).EQ.8.AND.I3(3).EQ.154) SCHREI=.TRUE.
      VONWO=NIER
      NEAR=0
      HABMIN=.FALSE.
      CALL RELEVA (XV,YV,N,XMIT,YMIT,I3,IACK,GENAU,IREAL,NREAL,HELP,
     *             TURBO)
C     IN IREAL STEHEN DIE NUMMERN DERJENIGEN, DIE BEIM BLICK NACH
C     VORNE IN FRAGE KOMMEN.
      IF(NREAL.EQ.0) RETURN
3     DO 1 JIND=1,NREAL
           J=IREAL(JIND)
C
C          WENN DER POTENTIELLE DRECK TLW. ODER GANZ ENTARTET IST
CENT       IF(ENTART(XV(IACK(1)),YV(IACK(1)),XV(IACK(2)),YV(IACK(2)),
CENT *               XV(J),YV(J))) GOTO 1
           ITEST(1)=IACK(1)
           ITEST(2)=IACK(2)
           ITEST(3)=J
C          PRUEFEN, OB IN DEM UMKREIS DES MIT DER AKTUELLEN SEITE
C          UND (XV(J),YV(J)) WEITERE PUNKTE LIEGEN, WENN JA:
C          WEITERSUCHEN
           IF(RDRIN(XV,YV,N,ITEST,XSTOR,YSTOR,NSTOR,VONWO,
     *              OUTLAW,GENAU,I3,WOHIN,IACK,IREAL,NREAL,NOSPI))
     *              GOTO 1
C
              IF(HABMIN) GOTO 2
                 XWURZ=XMIT-XV(J)
                 YWURZ=YMIT-YV(J)
                 DMIN=XWURZ*XWURZ+YWURZ*YWURZ
                 HABMIN=.TRUE.
                 NEAR=J
                 GOTO 1
2             XWURZ=XMIT-XV(J)
              YWURZ=YMIT-YV(J)
              TEST=XWURZ*XWURZ+YWURZ*YWURZ
              IF(TEST.GT.DMIN) GOTO 1
                 DMIN=TEST
                 NEAR=J
1          CONTINUE
      RETURN
      END
      SUBROUTINE RELEVA (XV,YV,N,XMIT,YMIT,I3,IACK,GENAU,IREAL,NREAL,
     *                   HELP,TURBO)
      REAL XV(N),YV(N),XMIT,YMIT,HELP(N)
      INTEGER I3(3),IACK(2),ITEST(3),VONWO,NIER,J,WOHIN,
     *        WOHER,DRECK,IREAL(N),TURBO
      LOGICAL SCHNIP,ENTART,HABMIN,RDRIN,SCHREI
      DATA NIER/'NEAR'/,DRECK/'DREK'/
C     ZU (XMIT,YMIT) DIE POTENTIELLEN NAECHSTEN NACHBARN AUSSER-
C     HALB DES AKTUELLEN DREIECKS NACH VORNE GESHEN ERUIEREN.
      SCHREI=.FALSE.
      VONWO=NIER
      NEAR=0
      HABMIN=.FALSE.
C     DEN KLEINSTEN ABSTAND VON (XMIT,YMIT) ZU DEN ANDEREN PUNKTEN,
C     WOBEI KEINER ZU DEM DURCH I3 SPECIFICIERTEN DRECK GEHOIEHEREN DARF
      WOHIN=0
           IF(IACK(1).EQ.I3(1).AND.IACK(2).EQ.I3(2).OR.
     *        IACK(2).EQ.I3(1).AND.IACK(1).EQ.I3(2)) WOHIN=1
           IF(IACK(1).EQ.I3(2).AND.IACK(2).EQ.I3(3).OR.
     *        IACK(2).EQ.I3(2).AND.IACK(1).EQ.I3(3)) WOHIN=2
           IF(IACK(1).EQ.I3(3).AND.IACK(2).EQ.I3(1).OR.
     *        IACK(2).EQ.I3(3).AND.IACK(1).EQ.I3(1)) WOHIN=3
      IF(WOHIN.NE.0) GOTO 3
C
           WRITE (6,4711)
4711       FORMAT (1X,'PROGRAMMFEHLER IN RELEVAL')
           NREAL=0
           RETURN
3     NREAL=0
      DO 1 J=1,N
           IF(J.EQ.I3(1).OR.J.EQ.I3(2).OR.J.EQ.I3(3)) GOTO 1
              GOTO(20,30,40),WOHIN
C
20         IF(SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(2)),YV(I3(2)),
     *               XV(I3(3)),YV(I3(3)),GENAU) .OR.
     *        SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(3)),YV(I3(3)),
     *               XV(I3(1)),YV(I3(1)),GENAU)) GOTO 1
           GOTO 100
C
C
30         IF(SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(1)),YV(I3(1)),
     *               XV(I3(3)),YV(I3(3)),GENAU)  .OR.
     *        SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(1)),YV(I3(1)),
     *               XV(I3(2)),YV(I3(2)),GENAU)) GOTO 1
           GOTO 100
C
C
40         IF(SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(1)),YV(I3(1)),
     *               XV(I3(2)),YV(I3(2)),GENAU)     .OR.
     *        SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(2)),YV(I3(2)),
     *               XV(I3(3)),YV(I3(3)),GENAU)) GOTO 1
100        NREAL=NREAL+1
           IREAL(NREAL)=J
           IF(TURBO.EQ.0) GOTO 1
              XWURZ=XMIT-XV(J)
              YWURZ=YMIT-YV(J)
              HELP(NREAL)=XWURZ*XWURZ+YWURZ*YWURZ
1          CONTINUE
      IF(TURBO.EQ.0.OR.TURBO.GE.NREAL) RETURN
C       DIE ERSTEN TURBO WERTE SORTIEREN
        ISTART=1
2       IMIN=ISTART
        DO 5 J=ISTART,NREAL
             IF(HELP(J).GT.HELP(IMIN)) GOTO 5
                IMIN=J
5            CONTINUE
        HAHA=HELP(ISTART)
        HELP(ISTART)=HELP(IMIN)
        HELP(IMIN)=HAHA
C       DAS WICHTIGSTE - DIE NUMMERN - NICHT VERGESSEN
        IHAHA=IREAL(ISTART)
        IREAL(ISTART)=IREAL(IMIN)
        IREAL(IMIN)=IHAHA
        ISTART=ISTART+1
        IF(ISTART.GT.NREAL) RETURN
        IF(ISTART.LT.TURBO) GOTO 2
           NREAL=TURBO
           RETURN
      END
      LOGICAL FUNCTION ENTART (X1,Y1,X2,Y2,X3,Y3)
      REAL X1,Y1,X2,Y2,X3,Y3,ALPHA,BETA,PI
      DATA PI/3.1415/
C     PRUEFT OB (X1,Y1), (X2,Y2) UND (X3,Y3) AUF EINER LINIE LIEGEN
      ENTART=.FALSE.
      IF(X1.EQ.X2.AND.X2.EQ.X3.OR.Y1.EQ.Y2.AND.Y2.EQ.Y3) GOTO 1
C  EIN 3 ECK IST DANN ENTARTED WENN EIN ECKWINKEL CA. 3.14 IST
C              1
C
C         2         3
C
C
C    PHI1: WINKEL ZW. 1_2 UND 1_3
      PHI1=ABS(PHI(X1,Y1,X2,Y2)-PHI(X1,Y1,X3,Y3))
      PHI2=ABS(PHI(X2,Y2,X1,Y1)-PHI(X2,Y2,X3,Y3))
      PHI3=ABS(PHI(X3,Y3,X2,Y2)-PHI(X3,Y3,X1,Y1))
      IF(ABS(PI-PHI1).LT.0.05.OR.ABS(PI-PHI2).LT.0.05.OR.
     *   ABS(PI-PHI3).LT.0.05) GOTO 1
      RETURN
1     ENTART=.TRUE.
      RETURN
      END
      LOGICAL FUNCTION RDRIN (XV,YV,N,ITEST,XSTOR,YSTOR,NSTOR,VONWO,
     *                        OUTLAW,GENAU,I3,WOHIN,IACK,IREAL,NREAL,
     *                        NOSPI)
      REAL XV(N),YV(N),XSTOR(NSTOR),YSTOR(NSTOR)
      INTEGER ITEST(3),NEAR,VONWO,I3(3),WOHIN,IACK(2),
     *        DRECK,IREAL(NREAL)
      LOGICAL SCHNIT,OUTLAW(N),STOR,SCHNIP,ENTART,SCHREI,NOSPI,ONCHK
C     ONCHK=.TRUE. : ES WIRD NUR AUF ENTARTUNG GEPRUEFT
      DATA DRECK/'DREK'/,NEAR/'NEAR'/
      SCHREI=.FALSE.
      RDRIN=.FALSE.
      STOR=.FALSE.
      IF(NSTOR.GT.1) STOR=.TRUE.
C     WENN IN DEM UMKREIS MINDESTENS EIN WEITERER PUNKT LIEGT,
C     BEI DEM DIE VERBINDUNGSLINIE VON IHM ZUM MITTELPUNKT
C     KEINE STOERUNG SCHNEIDET: DANN RDRIN = .TRUE.
C     AUSSER: ER IST EIN OUTLAW
C
      ENTART=.FALSE.
      ONCHK=.FALSE.
      CALL UMKREI (XV(ITEST(1)),YV(ITEST(1)),XV(ITEST(2)),
     *             YV(ITEST(2)),XV(ITEST(3)),YV(ITEST(3)),XMIT,
     *             YMIT,R,GENAU,ENTART,ONCHK)
C     R IST HIER R-QUADRAT
      IF(ENTART) GOTO 5
      NEND=N
      IF(VONWO.EQ.NEAR) NEND=NREAL
      DO 1 K=1,NEND
           I=K
           IF(VONWO.EQ.NEAR) I=IREAL(K)
C          OUTLAWS DUERFEN IM UMKREIS LIEGEN EBENSO WIE PUNKTE JENSEITS
C          VON STOERUNGEN.
           IF(VONWO.NE.NEAR.AND.VONWO.NE.DRECK.OR.OUTLAW(I).OR.
     *        I.EQ.ITEST(1).OR.I.EQ.ITEST(2).OR.I.EQ.ITEST(3).OR.
     *        I.EQ.I3(1).OR.I.EQ.I3(2).OR.I.EQ.I3(3)) GOTO 1
              XWURZ=XMIT-XV(I)
              YWURZ=YMIT-YV(I)
              TEST=XWURZ*XWURZ+YWURZ*YWURZ
              IF(TEST.GE.R) GOTO 1
C                FALLS UEBERSPITZE DREIECKE VERBOTEN SIND.
                 IF(NOSPI) GOTO 3
              IF(VONWO.NE.NEAR.AND.OUTLAW(I)) GOTO 3
C
C             JETZT FAELLE PRUEFEN, OB IM UMKREIS EINER LIEGEN DARF.
2             IF(NSTOR.EQ.1) GOTO 3
                 XCENT=0.5*(XV(IACK(1))+XV(IACK(2)))
                 YCENT=0.5*(YV(IACK(1))+YV(IACK(2)))
                 IF(VONWO.EQ.NEAR) GOTO 4
C                   ES WIRD JA ZU SCON 2 VORHANDENEN DER DRITTE GESUCHET
                    XCENT=XMIT
                    YCENT=YMIT
4                SCHNIT=.FALSE.
                 IF(STOR) CALL JOINTC (SCHNIT,XCENT,YCENT,XV(I),YV(I),
     *                                 XSTOR,YSTOR,NSTOR,NCUT,GENAU)
                 IF(.NOT.SCHNIT) GOTO 3
                 GOTO 1
3          CONTINUE
C          WENN DER DER IM UMKREIS LIEGT MIT DEN BEIDEN AKTUELLEN EINEN
C          ENTARTETEN DRECK BILDEN WUERDE, DANN DIESEN NICHT BEACHTEN
C
C          HIER UMKREI WIEDER AUFRUFEN, UM ENTART ZU ERSETZEN
      ENTART=.FALSE.
      ONCHK=.TRUE.
      CALL UMKREI (XV(IACK(1)),YV(IACK(1)),XV(IACK(2)),
     *             YV(IACK(2)),XV(I),YV(I),XMITD,
     *             YMITD,RD,GENAU,ENTART,ONCHK)
      IF(ENTART) GOTO 1
C          IF(ENTART(XV(IACK(1)),YV(IACK(1)),XV(IACK(2)),YV(IACK(2)),
C    *               XV(I),YV(I))) GOTO 1
             RDRIN=.TRUE.
             RETURN
1          C O N T I N U E
      RETURN
5     RDRIN=.TRUE.
      R E T U R N
      END
      SUBROUTINE UMKREI (X1,Y1,X2,Y2,X3,Y3,XMIT,YMIT,R,GENAU,ENTART,
     *                   ONCHK)
      REAL M(2),B(2),EQUIL
      INTEGER GENUG
      LOGICAL WRITEN,ENTART,ONCHK
      COMMON /GLEICH/ EQUIL
      EQUILT=EQUIL
      ENTART=.FALSE.
C     BERECHNET DEN MITTELPUNKT DES UMKREISES ZU EINEM DREIECK
C     UND DESSEN RADIUS. GEHT NUR FUER NICHT ENTARTETEN DRECK.
      WRITEN=.FALSE.
      IF(Y1.LT.0.) WRITEN=.TRUE.
      LCNT=0
      GENUG=0
      IF(ABS(Y1-Y2).LE.EQUILT) GOTO 1
         GENUG=GENUG+1
         M(GENUG)=-(X2-X1)/(Y2-Y1)
         B(GENUG)=0.5*(Y2+Y1)-M(GENUG)*0.5*(X1+X2)
1     IF(ABS(Y2-Y3).LE.EQUILT) GOTO 2
         GENUG=GENUG+1
         M(GENUG)=-(X3-X2)/(Y3-Y2)
         B(GENUG)=0.5*(Y3+Y2)-M(GENUG)*0.5*(X2+X3)
C
2     IF(GENUG.EQ.2) GOTO 5
      IF(ABS(Y3-Y1).LE.EQUILT) GOTO 4
         GENUG=GENUG+1
         M(GENUG)=-(X3-X1)/(Y3-Y1)
         B(GENUG)=0.5*(Y3+Y1)-M(GENUG)*0.5*(X3+X1)
C
5     CONTINUE
      IF(ABS(M(1)-M(2)).GT.EQUILT) GOTO 6
4        ENTART=.TRUE.
         RETURN
6     IF(ONCHK) RETURN
C     E.G. FALLS NUR AUF ENTARTUNG GEPRUEFT WERDEN SOLLTE
      XMIT=(B(2)-B(1))/(M(1)-M(2))
      YMIT=M(1)*XMIT+B(1)
      XWURZ=XMIT-X1
      YWURZ=YMIT-Y1
      R=XWURZ*XWURZ+YWURZ*YWURZ
      RETURN
      END
      SUBROUTINE JOINTC (SCHNIT,X1,Y1,X2,Y2,XSTOR,YSTOR,NSTOR,NCUT,
     *                   GENAU)
      REAL X1,Y1,X2,Y2,XSTOR(NSTOR),YSTOR(NSTOR)
      LOGICAL SCHNIT,SCHNIP,SCHLUS,PRACIS
C     XSTOR(1): NUMMER DES LETZTEN GUELTIGEN ELEMENTS DER ERSTEN
C               STOERUNG. HINTER DEM PLATZ MIT DIESER NUMMER:
C               NUMMER DES LETZTEN GUELTIGEN PLATZES DER NAECHSTEN
C               STOERUNG USW. BIS DIE NUMMER = NSTOR IST.
C     YSTOR(1): DITO
C     ALS NAECHSTE STOERUNG WIRD DIEJENIGE ANGESEHEN, DIE AM NAECHSTEN
C     ZU DER MITTE AUS (X1,Y1) UND (XCUT,YCUT) IST (IM SCHNITTFALL).
C     DIES BEDEUTET, DASS BEIM AUFRUF VON JOINTC (X1,Y1) IMMER
C     "DIESSEITS" DER STOERUNG SEIN MUSS. SONST GEHTS NICHT
C
C
      PRACIS=.FALSE.
      IF(GENAU.GT.0.) GOTO 1000
        PRACIS=.TRUE.
        GENAU=-GENAU
C       NUR WENN JOINTC AUS NEAR ODER ISOS AUFGERUFEN WIRD, IST
C       DIE PRAEZISE POSITION DES SCHNITTS GEFRAGT, STEUERUNG UEBER
C       DAS VORZEICHEN VON GENAU.
1000  SCHNIT=.FALSE.
      IF(NSTOR.EQ.1) RETURN
      NEND=IFIX(XSTOR(1))
      NSTART=3
      ICUTN=0
2     DO 1 N=NSTART,NEND
             IF(.NOT.SCHNIP(X1,Y1,X2,Y2,XSTOR(N-1),YSTOR(N-1),XSTOR(N),
     *          YSTOR(N),GENAU)) GOTO 1
                ICUTN=ICUTN+1
                NCUT=N-1
                IF(.NOT.PRACIS) GOTO 3
C                  MARKIEREN DER SCHNITTPUNKTE
                   XSTOR(NCUT)=-XSTOR(NCUT)
                   YSTOR(NCUT)=-YSTOR(NCUT)
1            CONTINUE
      IF(NEND.LT.NSTOR) GOTO 30
         IF(ICUTN.GT.0) GOTO 3
            RETURN
30       NNUM=NEND+1
         NEND=IFIX(XSTOR(NNUM))
         NSTART=NNUM+2
         GOTO 2
3     SCHNIT=.TRUE.
      IF(.NOT.PRACIS) RETURN
C     WIRD MEHR ALS EINE STOERUNG GESCHNITTEN (AUESSERST SELTEN) DAS
C     GANZE NOCHMAL, ABER GENAUER
      IF(ICUTN.EQ.1) GOTO 40
         IF(PRACIS) CALL JOIASS (SCHNIT,X1,Y1,X2,Y2,XSTOR,YSTOR,NSTOR,
     *                           NCUT,GENAU)
         RETURN
C     DEMARKIEREN
40    XSTOR(NCUT)=ABS(XSTOR(NCUT))
      YSTOR(NCUT)=ABS(YSTOR(NCUT))
C     NCUT=N-1
      RETURN
      END
      SUBROUTINE JOIASS (SCHNIT,X1,Y1,X2,Y2,XSTOR,YSTOR,NSTOR,NCUT,
     *                   GENAU)
      REAL X1,Y1,X2,Y2,XSTOR(NSTOR),YSTOR(NSTOR)
      LOGICAL SCHNIT,SCHNIP,SCHLUS,INTER,HABTES
      HABTES=.FALSE.
C     XSTOR(1): NUMMER DES LETZTEN GUELTIGEN ELEMENTS DER ERSTEN
C               STOERUNG. HINTER DEM PLATZ MIT DIESER NUMMER:
C               NUMMER DES LETZTEN GUELTIGEN PLATZES DER NAECHSTEN
C               STOERUNG USW. BIS DIE NUMMER = NSTOR IST.
C     YSTOR(1): DITO
C     ALS NAECHSTE STOERUNG WIRD DIEJENIGE ANGESEHEN, DIE AM NAECHSTEN
C     ZU DER MITTE AUS (X1,Y1) UND (XCUT,YCUT) IST (IM SCHNITTFALL).
C     DIES BEDEUTET, DASS BEIM AUFRUF VON JOINTC (X1,Y1) IMMER
C     "DIESSEITS" DER STOERUNG SEIN MUSS. SONST GEHTS NICHT
C
C     ATH: INPUT MIT MARKIERTEN WERTEN
      SCHNIT=.FALSE.
      IF(NSTOR.EQ.1) RETURN
      NEND=IFIX(XSTOR(1))
      NSTART=3
      ICUTN=0
2     DO 1 N=NSTART,NEND
C            WENN BEIDE, X UND Y PRIMAER 0 SIND, LAEUFTS NICHT. MANUAL.
             IF(XSTOR(N-1).GE.0..AND.YSTOR(N-1).GE.0.) GOTO 1
C               ANSNSONSTEN IST ER MARKIERT, ZUNAECHST DEMARKIEREN.
                XSTOR(N-1)=-XSTOR(N-1)
                YSTOR(N-1)=-YSTOR(N-1)
                ICUTN=ICUTN+1
                CALL MESSER (X1,Y1,X2,Y2,XSTOR(N-1),YSTOR(N-1),XSTOR(N),
     *                       YSTOR(N),GENAU,XCUT,YCUT,SCHLUS)
                IF(.NOT.SCHLUS) GOTO 20
C                  WRITE (6,4714)
C4714              FORMAT (1X,'TROTZ JOINTC KEIN ERFOLG MIT DEM MESSER')
                   NCUT=N-1
                   GOTO 1
20              XCENT=0.5*(X1+XCUT)
                YCENT=0.5*(Y1+YCUT)
                TEST1=SQRT((XCENT-XCUT)*(XCENT-XCUT)+
     *                     (YCENT-YCUT)*(YCENT-YCUT))
C NEU 25.11.88  FALLS NOCH KEINE TESTENTFERNUNG VORHANDEN, DIE
C               ENTFERNUNG AUF TESREM MERKEN
                IF(.NOT.HABTES) TESREM=TEST1
                HABTES=.TRUE.
                IF(ICUTN.GT.1) GOTO 10
                   TESREM=TEST1
                   NCUT=N-1
                   GOTO 1
10              IF(TEST1.GT.TESREM) GOTO 1
                   TESREM=TEST1
                   NCUT=N-1
1            CONTINUE
      IF(NEND.LT.NSTOR) GOTO 30
         IF(ICUTN.GT.0) GOTO 3
            RETURN
30       NNUM=NEND+1
         NEND=IFIX(XSTOR(NNUM))
         NSTART=NNUM+2
         GOTO 2
3     SCHNIT=.TRUE.
      RETURN
C     ES FOLGT ISO9E  **********
      END
      SUBROUTINE MESSER(X1,Y1,X2,Y2,WX1,WY1,WX2,WY2,GENAU,XCUT,YCUT,
     *                  SCHLUS)
      REAL X(2),Y(2),WX(2),WY(2),XMIN,XMAX,YMIN,YMAX,WXMIN,WXMAX,
     *     WYMIN,WYMAX,M1,M2,B1,B2
      INTEGER IDUMMY(2)
      LOGICAL INTER,X1EQX2,Y1EQY2,WXEQWX,WYEQWY,SCHLUS
      COMMON /GLEICH/ EQUIL
      SCHLUS=.TRUE.
      X(1)=X1
      X(2)=X2
      Y(1)=Y1
      Y(2)=Y2
      WX(1)=WX1
      WX(2)=WX2
      WY(1)=WY1
      WY(2)=WY2
      CALL MINMAX (X,2,XMIN,XMAX,IDUMMY)
      CALL MINMAX (Y,2,YMIN,YMAX,IDUMMY)
      CALL MINMAX (WY,2,WYMIN,WYMAX,IDUMMY)
      CALL MINMAX (WX,2,WXMIN,WXMAX,IDUMMY)
C     2 STRECKEN KOENNEN SICH NICHT SCHNEIDEN WENN DIE EINE ENTWEDER
C     UEBER ODER UNTER ODER LINKS ODER RECHTS VON DER ANDEREN LIEGT
C     ODER UMGEKEHRT
      IF (WX(1).LT.XMIN.AND.WX(2).LT.XMIN.OR.
     *    WX(1).GT.XMAX.AND.WX(2).GT.XMAX.OR.
     *    WY(1).LT.YMIN.AND.WY(2).LT.YMIN.OR.
     *    WY(1).GT.YMAX.AND.WY(2).GT.YMAX)    R E T U R N
      IF (X(1).LT.WXMIN.AND.X(2).LT.WXMIN.OR.
     *    X(1).GT.WXMAX.AND.X(2).GT.WXMAX.OR.
     *    Y(1).LT.WYMIN.AND.Y(2).LT.WYMIN.OR.
     *    Y(1).GT.WYMAX.AND.Y(2).GT.WYMAX)    R E T U R N
      SCHLUS=.FALSE.
C
C     EIN SCHNEIDEN IST SOMIT PRINZIPIELL MOEGLICH
      X1EQX2=.FALSE.
      Y1EQY2=.FALSE.
      WXEQWX=.FALSE.
      WYEQWY=.FALSE.
      IF(ABS(X(1)-X(2)).LE.EQUIL) X1EQX2=.TRUE.
      IF(ABS(Y(1)-Y(2)).LE.EQUIL) Y1EQY2=.TRUE.
      IF(ABS(WY(1)-WY(2)).LE.EQUIL) WYEQWY=.TRUE.
      IF(ABS(WX(1)-WX(2)).LE.EQUIL) WXEQWX=.TRUE.
      IF(.NOT.X1EQX2.AND..NOT.Y1EQY2.AND..NOT.WXEQWX.AND..NOT.WYEQWY)
     *   GOTO 100
C
C     HIER ABKLAEREN DER SONDERFAELLE
      IF(X1EQX2.AND..NOT.WXEQWX) GOTO 10
      IF(.NOT.X1EQX2.AND.WXEQWX) GOTO 20
      IF(X1EQX2.AND.WXEQWX) GOTO 30
      IF(Y1EQY2.AND..NOT.WYEQWY) GOTO 40
      IF(.NOT.Y1EQY2.AND.WYEQWY) GOTO 50
      IF(Y1EQY2.AND.WYEQWY) GOTO 60
C     X1 SENKRECHT W ANDERS
10    CALL MB (WX,WY,M2,B2)
      YCUT=M2*X(1)+B2
      XCUT=X1
      RETURN
C     W SENKRECHT X NICHT
20    CALL MB (X,Y,M1,B1)
      YCUT=M1*WX(1)+B1
      XCUT=WX1
      RETURN
C     BEIDE SENKRECHT
30    SCHLUS=.TRUE.
      RETURN
C     Y WAAGERECHT W NICHT
40    CALL MB (WX,WY,M2,B2)
      XCUT=(Y(1)-B2)/M2
      YCUT=Y1
      RETURN
C     WY WAAGERECHT Y NICHT
50    CALL MB (X,Y,M1,B1)
      XCUT=(WY(1)-B1)/M1
      YCUT=Y1
      RETURN
C     BEIDE WAAGERECHT
60    SCHLUS=.TRUE.
      RETURN
C
C     JETZT DER NORMALFALL: BEIDE SCHRAEG
100   CALL MB (X,Y,M1,B1)
      CALL MB (WX,WY,M2,B2)
      IF(M1.EQ.M2) GOTO 200
C       HIER FUER NICHTPARALLELE STRECKEN
        XCUT=(B2-B1)/(M1-M2)
        YCUT=M1*XCUT+B1
        RETURN
200   WRITE (6,4711)
4711  FORMAT (1X,'MESSER PRUEFEN')
      SCHLUS=.TRUE.
      RETURN
      END
      LOGICAL FUNCTION INTER (W1,W2,TEST,GENAU)
C     PRUEFT OB TEST ZWISCHEN W1 UND W2 LIEGT
      INTER=.FALSE.
      IF(TEST.GE.W1.AND.TEST.LE.W2        .OR.
     *   TEST.GE.W2.AND.TEST.LE.W1        .OR.
     *   ABS(TEST-W1).LT.GENAU.OR.ABS(TEST-W2).LT.GENAU) INTER=.TRUE.
      RETURN
      END
      LOGICAL FUNCTION INTER2 (W1,W2,TEST)
C     PRUEFT OB TEST ZWISCHEN W1 UND W2 LIEGT
      INTER2=.FALSE.
      IF(TEST.GT.W1.AND.TEST.LT.W2        .OR.
     *   TEST.GT.W2.AND.TEST.LT.W1) INTER2=.TRUE.
      RETURN
      END
      LOGICAL FUNCTION SCHNIP (X1,Y1,X2,Y2,WX1,WY1,WX2,WY2,GENAU)
      REAL X(2),Y(2),WX(2),WY(2),XMIN,XMAX,YMIN,YMAX,WXMIN,WXMAX,
     *     WYMIN,WYMAX,M1,M2,B1,B2
      INTEGER IDUMMY(2)
      LOGICAL INTER,X1EQX2,Y1EQY2,WXEQWX,WYEQWY,SCHREI
      COMMON /GLEICH/ EQUIL
      SCHNIP=.FALSE.
      SCHREI=.FALSE.
      X(1)=X1
      X(2)=X2
      Y(1)=Y1
      Y(2)=Y2
      WX(1)=WX1
      WX(2)=WX2
      WY(1)=WY1
      WY(2)=WY2
      CALL MINMAX (X,2,XMIN,XMAX,IDUMMY)
      CALL MINMAX (Y,2,YMIN,YMAX,IDUMMY)
      CALL MINMAX (WY,2,WYMIN,WYMAX,IDUMMY)
      CALL MINMAX (WX,2,WXMIN,WXMAX,IDUMMY)
C     2 STRECKEN KOENNEN SICH NICHT SCHNEIDEN WENN DIE EINE ENTWEDER
C     UEBER ODER UNTER ODER LINKS ODER RECHTS VON DER ANDEREN LIEGT
C     ODER UMGEKEHRT
      IF(SCHREI) WRITE (6,815) X,Y,WX,WY
815   FORMAT (1X,'X=',2(F16.2),' Y=',2(F16.2),/,1X,
     *           'WX=',2(F16.2),' WY=',2(F16.2))
      IF (WX(1).LT.XMIN.AND.WX(2).LT.XMIN.OR.
     *    WX(1).GT.XMAX.AND.WX(2).GT.XMAX.OR.
     *    WY(1).LT.YMIN.AND.WY(2).LT.YMIN.OR.
     *    WY(1).GT.YMAX.AND.WY(2).GT.YMAX)    R E T U R N
      IF (X(1).LT.WXMIN.AND.X(2).LT.WXMIN.OR.
     *    X(1).GT.WXMAX.AND.X(2).GT.WXMAX.OR.
     *    Y(1).LT.WYMIN.AND.Y(2).LT.WYMIN.OR.
     *    Y(1).GT.WYMAX.AND.Y(2).GT.WYMAX)    R E T U R N
      IF(SCHREI) WRITE (6,816)
816   FORMAT (1X,'HINTER DEM ERSTERN HAUPTRETURN.')
C
C     EIN SCHNEIDEN IST SOMIT PRINZIPIELL MOEGLICH
      X1EQX2=.FALSE.
      Y1EQY2=.FALSE.
      WXEQWX=.FALSE.
      WYEQWY=.FALSE.
      IF(ABS(X(1)-X(2)).LE.EQUIL) X1EQX2=.TRUE.
      IF(ABS(Y(1)-Y(2)).LE.EQUIL) Y1EQY2=.TRUE.
      IF(ABS(WY(1)-WY(2)).LE.EQUIL) WYEQWY=.TRUE.
      IF(ABS(WX(1)-WX(2)).LE.EQUIL) WXEQWX=.TRUE.
      IF(.NOT.X1EQX2.AND..NOT.Y1EQY2.AND..NOT.WXEQWX.AND..NOT.WYEQWY)
     *   GOTO 100
      IF(SCHREI) WRITE (6,817)
817   FORMAT (1X,'MIND. EINER IST EIN SONDERFALL')
C
C     HIER ABKLAEREN DER SONDERFAELLE
      IF(X1EQX2.AND.WYEQWY) GOTO 70
      IF(WXEQWX.AND.Y1EQY2) GOTO 72
C
      IF(X1EQX2.AND..NOT.WXEQWX) GOTO 10
      IF(.NOT.X1EQX2.AND.WXEQWX) GOTO 20
      IF(X1EQX2.AND.WXEQWX) GOTO 30
      IF(Y1EQY2.AND..NOT.WYEQWY) GOTO 40
      IF(.NOT.Y1EQY2.AND.WYEQWY) GOTO 50
      IF(Y1EQY2.AND.WYEQWY) GOTO 60
C     X1 SENKRECHT W ANDERS
10    CALL MB (WX,WY,M2,B2)
      YY=M2*X(1)+B2
      IF(INTER(Y(1),Y(2),YY,GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,818)
818   FORMAT (1X,'X SENKRECHT W SCHRAEG')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,818)
819   FORMAT (1X,'SCHNEIDET NICHT.')
      RETURN
C     W SENKRECHT X NICHT
20    CALL MB (X,Y,M1,B1)
      YY=M1*WX(1)+B1
      IF(INTER(WY(1),WY(2),YY,GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,820)
820   FORMAT (1X,'W SENKRECHT X SCHRAEG')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,819)
      RETURN
C     BEIDE SENKRECHT
30    IF(INTER(WY(1),WY(2),Y(1),GENAU).OR.INTER(WY(1),WY(2),Y(2),GENAU)
     *   .OR.INTER(Y(1),Y(2),WY(1),GENAU).OR.INTER(Y(1),Y(2),WY(2),
     *        GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,821)
821   FORMAT (1X,'BEIDE SENKRECHT.')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,819)
      RETURN
C     Y WAAGERECHT W NICHT
40    CALL MB (WX,WY,M2,B2)
      XX=(Y(1)-B2)/M2
      IF(INTER(X(1),X(2),XX,GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,822)
822   FORMAT (1X,'Y WAAGERECHT W NICHT.')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,819)
      RETURN
C     WY WAAGERECHT Y NICHT
50    CALL MB (X,Y,M1,B1)
      XX=(WY(1)-B1)/M1
      IF(INTER(WX(1),WX(2),XX,GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,823)
823   FORMAT (1X,'WY WAAGERECHT Y NICHT.')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,819)
      RETURN
C     BEIDE WAAGERECHT
60    IF(INTER(X(1),X(2),WX(1),GENAU).OR.INTER(X(1),X(2),WX(2),GENAU)
     *   .OR.INTER(WX(1),WX(2),X(1),GENAU).OR.
     *    INTER(WX(1),WX(2),X(2),GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,824)
824   FORMAT (1X,'BEIDE WAAGERECHT')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,819)
      RETURN
C     1 SENKRECHT 2 (W) WAAGERECHT
70    IF(INTER(Y(1),Y(2),WY(1),GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,825)
825   FORMAT (1X,'1 SENKRECHT, W WAAGERECHT.')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,819)
      RETURN
C     2 (W) SENKRECHT 1 WAAGERECHT
72    IF(INTER(WY(1),WY(2),Y(1),GENAU)) SCHNIP=.TRUE.
      IF(SCHREI) WRITE (6,826)
826   FORMAT (1X,'W SENKRECHT, 1 WAAGERECHT.')
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,819)
      RETURN
C
C     JETZT DER NORMALFALL: BEIDE SCHRAEG
100   CALL MB (X,Y,M1,B1)
      CALL MB (WX,WY,M2,B2)
      IF(SCHREI) WRITE (6,827)
827   FORMAT (1X,'BEIDE SCHRAEG')
      IF(M1.EQ.M2) GOTO 200
C       HIER FUER NICHTPARALLELE STRECKEN
        XX=(B2-B1)/(M1-M2)
        YY=M1*XX+B1
C       PRUEFEN OB (XX,YY) IN B E I D E N DURCH DIE STRECKEN AUFGESPANNT
C       RECHTECKEN LIEGT
        IF(INTER(X(1),X(2),XX,GENAU).AND.INTER(Y(1),Y(2),YY,GENAU).AND.
     *     INTER(WX(1),WX(2),XX,GENAU).AND.INTER(WY(1),WY(2),YY,GENAU))
     *     SCHNIP=.TRUE.
      IF(SCHREI.AND..NOT.SCHNIP) WRITE (6,828)
828   FORMAT (1X,'BEIDE SCHRAEG, SCHNEOIDET NICHT.')
        RETURN
C     SCHRAEGE, PARRALLELE STRECKEN, PRUEFEN WO SIE UEBERLAPPEN
200   CONTINUE
      IF(SCHREI) WRITE (6,829)
829   FORMAT (1X,'ES SIND SCHRAEGE PARALLEL STRECKEN.')
      IF(INTER(WX(1),WX(2),X(1),GENAU)) GOTO 210
      IF(INTER(WX(1),WX(2),X(2),GENAU)) GOTO 220
      IF(INTER(X(1),X(2),WX(1),GENAU)) GOTO 230
      IF(INTER(X(1),X(2),WX(2),GENAU)) GOTO 240
      RETURN
210   YY=M2*X(1)+B2
      IF(ABS(YY-Y(1)).LT.GENAU) SCHNIP=.TRUE.
      RETURN
220   YY=M2*X(2)+B2
      IF(ABS(YY-Y(2)).LT.GENAU) SCHNIP=.TRUE.
      RETURN
230   YY=M1*WX(1)+B1
      IF(ABS(YY-WY(1)).LT.GENAU) SCHNIP=.TRUE.
      RETURN
240   YY=M1*WX(2)+B1
      IF(ABS(YY-WY(2)).LT.GENAU) SCHNIP=.TRUE.
      RETURN
      END
      SUBROUTINE MB (X,Y,M,B)
      REAL X(2),Y(2),M,B
      M=(Y(2)-Y(1))/(X(2)-X(1))
      B=Y(2)-M*X(2)
      RETURN
      END
      INTEGER FUNCTION NEAR2 (XV,YV,N,XMIT,YMIT,I3,IACK,XSTOR,YSTOR,
     *                        NSTOR,OUTLAW,GENAU,NOSPI)
      REAL XV(N),YV(N),XMIT,YMIT,XSTOR(NSTOR),YSTOR(NSTOR)
      INTEGER I3(3),IACK(2),ITEST(3),VONWO,NIER,J,WOHIN,
     *        WOHER,DRECK
      LOGICAL SCHNIP,ENTART,HABMIN,RDRIN2,OUTLAW(N),SCHREI,NOSPI
      DATA NIER/'NEAR'/,DRECK/'DREK'/
C     ZU (XMIT,YMIT) DEN NAECHSTEN NACHBARN, ABER AUSSERHALB DES
C     AKTUELLEN, MIT DEN INDIZES IN I3 GESPEICHERTEN DRECKS. DAS
C     POTENTIELLE NEUE DRECK MUSS SO SEIN, DASS KEINE SEINER POTEN-
C     TIELLEN SEITEN (= VERBINDUNGSLINIEN (XMIT,YMIT)_(XV(NEAR),YV(NEAR)
C     DAS AKTUELLE DRECK SCHNEIDET. AUCH DARF DAS POTENTIELLE NEUE DRECK
C     KEIN ENTARTETER DRECK SEIN.
C     DER SCHNITT DARF NUR FUER DIEJENIGEN SEITEN GEPRUEFT WERDEN, DIE
C     N I C H T (XMIT,YMIT) (UEBER IACK ZU ERKENNEN) ENTHALTEN.
C
      SCHREI=.FALSE.
      IF(XMIT.LT.0) SCHREI=.TRUE.
      XMIT=ABS(XMIT)
      VONWO=NIER
      NEAR2=0
      HABMIN=.FALSE.
C     DEN KLEINSTEN ABSTAND VON (XMIT,YMIT) ZU DEN ANDEREN PUNKTEN,
C     WOBEI KEINER ZU DEM DURCH I3 SPECIFICIERTEN DRECK GEHOIEHEREN DARF
      WOHIN=0
           IF(IACK(1).EQ.I3(1).AND.IACK(2).EQ.I3(2).OR.
     *        IACK(2).EQ.I3(1).AND.IACK(1).EQ.I3(2)) WOHIN=1
           IF(IACK(1).EQ.I3(2).AND.IACK(2).EQ.I3(3).OR.
     *        IACK(2).EQ.I3(2).AND.IACK(1).EQ.I3(3)) WOHIN=2
           IF(IACK(1).EQ.I3(3).AND.IACK(2).EQ.I3(1).OR.
     *        IACK(2).EQ.I3(3).AND.IACK(1).EQ.I3(1)) WOHIN=3
      IF(WOHIN.NE.0) GOTO 3
C
           WRITE (6,4711)
4711       FORMAT (1X,'PROGRAMMFEHLER IN NEAR2')
           NEAR2=0
           RETURN
3     DO 1 J=1,N
           IF(J.EQ.I3(1).OR.J.EQ.I3(2).OR.J.EQ.I3(3)) GOTO 1
              GOTO(20,30,40),WOHIN
C
20         IF(SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(2)),YV(I3(2)),
     *               XV(I3(3)),YV(I3(3)),GENAU) .OR.
     *        SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(3)),YV(I3(3)),
     *               XV(I3(1)),YV(I3(1)),GENAU)) GOTO 1
           GOTO 100
C
C
30         CONTINUE
C
           IF(SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(1)),YV(I3(1)),
     *               XV(I3(3)),YV(I3(3)),GENAU)     .OR.
     *        SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(1)),YV(I3(1)),
     *               XV(I3(2)),YV(I3(2)),GENAU)) GOTO 1
           GOTO 100
C
C
40         IF(SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(1)),YV(I3(1)),
     *               XV(I3(2)),YV(I3(2)),GENAU)     .OR.
     *        SCHNIP(XMIT,YMIT,XV(J),YV(J),XV(I3(2)),YV(I3(2)),
     *               XV(I3(3)),YV(I3(3)),GENAU)) GOTO 1
C
C          WENN DER POTENTIELLE DRECK TLW. ODER GANZ ENTARTET IST
100        CONTINUE
CENT       IF(ENTART(XV(IACK(1)),YV(IACK(1)),XV(IACK(2)),YV(IACK(2)),
CENT *               XV(J),YV(J))) GOTO 1
           ITEST(1)=IACK(1)
           ITEST(2)=IACK(2)
           ITEST(3)=J
C          PRUEFEN, OB IN DEM UMKREIS DES MIT DER AKTUELLEN SEITE
C          UND (XV(J),YV(J)) WEITERE PUNKTE LIEGEN, WENN JA:
C          WEITERSUCHEN
           IF(RDRIN2(XV,YV,N,ITEST,XSTOR,YSTOR,NSTOR,VONWO,
     *               OUTLAW,GENAU,I3,WOHIN,IACK,NOSPI)) GOTO 1
C
              IF(HABMIN) GOTO 2
                 XWURZ=XMIT-XV(J)
                 YWURZ=YMIT-YV(J)
                 DMIN=XWURZ*XWURZ+YWURZ*YWURZ
                 HABMIN=.TRUE.
                 NEAR2=J
                 GOTO 1
2             XWURZ=XMIT-XV(J)
              YWURZ=YMIT-YV(J)
              TEST=XWURZ*XWURZ+YWURZ*YWURZ
              IF(TEST.GT.DMIN) GOTO 1
                 DMIN=TEST
                 NEAR2=J
1          CONTINUE
      RETURN
      END
      SUBROUTINE RUNDO (XV,YV,NR,OPEN,ILOCH,HSYM,SW,ZIFF,NKOMMA,ZAHL,
     *                  RELAUS,ABSAUS,DRIN,LSTRIN,ABST,XVALS,YVALS,
     *                  NVMAX,NV)
      REAL XV(NR),YV(NR),L,M1,M2,HSYM,RELAUS,ABSAUS,LSTRIN,ABST
      INTEGER ILOCH,ZIFF,NKOMMA
      LOGICAL ENDE,OPEN,LOCH,ZAHL,DRIN
      REAL XVALS(NVMAX),YVALS(NVMAX)
      IF(NR.EQ.1) RETURN
CZ       CALL PLOT (XV(1),YV(1),3)
      IF(NR.GT.2) GOTO 10
CZ       CALL PLOT (XV(2),YV(2),2)
         RETURN
10    ENDE=.FALSE.
C
C     BERECHNEN DER STARTSTEIGUNG AUS DEM ERSTEN POLYGONSTUECKCHEN
C     UND DAS DURCH DEN LETZTEN PUNKT UND DEN ERSTEN AUFGESPANNTEN
C     POLYGONSTUECKS
      IF(OPEN) GOTO 15
         PHI1=PHI(XV(1),YV(1),XV(2),YV(2))
         PHI2=PHI(XV(NR-2),YV(NR-2),XV(1),YV(1))
         ALPHA=PHINEW(PHI1,PHI2)
C
15    DO 1000 I=3,NR
              LOCH=.FALSE.
              IF(I-2.EQ.ILOCH.AND.DRIN) LOCH=.TRUE.
              L=SQRT((YV(I-1)-YV(I-2))*(YV(I-1)-YV(I-2))+
     *               (XV(I-1)-XV(I-2))*(XV(I-1)-XV(I-2)))
              PHI2=PHI(XV(I-1),YV(I-1),XV(I),YV(I))
              PHI1=PHI(XV(I-2),YV(I-2),XV(I-1),YV(I-1))
              BETA=PHINEW(PHI1,PHI2)
              IF(I.EQ.3.AND.OPEN) ALPHA=PHI1
              M1=ALPHA-PHI1
              M2=BETA-PHI1
C
20            M1=(SIN(M1))/(COS(M1))
              M2=(SIN(M2))/(COS(M2))
              IF(.NOT.ENDE) CALL MALE (XV(I-2),YV(I-2),XV(I-1),
     *                                 YV(I-1),L,M1,M2,PHI1,LOCH,
     *                                 SW,NKOMMA,HSYM,ZAHL,
     *                                 RELAUS,ABSAUS,LSTRIN,ABST,
     *                                 XVALS,YVALS,NVMAX,NV)
              IF(ENDE) CALL MALE (XV(I-1),YV(I-1),XV(I),YV(I),L,M1,
     *                            M2,PHI2,LOCH,SW,NKOMMA,HSYM,
     *                            ZAHL,RELAUS,ABSAUS,LSTRIN,ABST,
     *                            XVALS,YVALS,NVMAX,NV)
              ALPHA=BETA
              IF(I.LT.NR) GOTO 1000
              IF(.NOT.OPEN.OR.ENDE) R E T U R N
C
C             PLOTTEN DES LETZTEN STUECKS, EINZIGER UNTERSCHIED
C             ZWISCHEN OFFEN UND GESCHLOSSEN IST DER ZIELWINKEL
              BETA=PHI2
              ENDE=.TRUE.
              LOCH=.FALSE.
              IF(I-1.EQ.ILOCH.AND.DRIN) LOCH=.TRUE.
              L=SQRT((YV(I)-YV(I-1))*(YV(I)-YV(I-1))+
     *              (XV(I)-XV(I-1))*(XV(I)-XV(I-1)))
                    M1=ALPHA-PHI2
                    M2=BETA-PHI2
                    GOTO 20
1000          CONTINUE
      RETURN
      END
      SUBROUTINE MALE (X1,Y1,X2,Y2,L,M1,M2,CHI,LOCH,SW,NKOMMA,
     *                 HSYM,ZAHL,RELAUS,ABSAUS,LSTRIN,DELTA,
     *                 XVALS,YVALS,NVMAX,NV)
      REAL L,M1,M2,X1,Y1,X2,Y2,CHI,A,B,C,COSCHI,SINCHI,X(4000),Y(4000),
     *     MAXAUS,DELTA,HSYM,XLOCH,LSTOP,LSTRIN,RELAUS,ABSAUS
      REAL XVALS(NVMAX),YVALS(NVMAX)
      INTEGER ZIFF,NKOMMA
      LOGICAL LOCH,INLOCH,ZAHL,STAUCH
      REAL XSYAUT,YSYAUT,HSYAUT,SWAUT,NKOAUT,CHIAUT,RIHOLE
      COMMON /ZPAR/ XSYAUT,YSYAUT,HSYAUT,SWAUT,NKOAUT,CHIAUT,RIHOLE,ZL
      CONST=6.*HSYM/7.
C     WRITE (6,7711) X1,Y1,X2,Y2,L
C7711  FORMAT (1X,'X1=',F8.2,' Y1=',F8.2,' X2=',F8.2,' Y2=',F8.2,' L=',
C     *        F8.2)
C     WRITE (6,*) 'NV BEI BEGINN=',NV
      C=M1
      B= - ((M2+2.*M1)/L)
      A= (-B*L*L-M1*L)/(L*L*L)
C
C
      IF(.NOT.LOCH) GOTO 100
C
C        BERECHNEN DER LAGE DES LOCHS
         XLOCH=0.5*L-0.5*LSTRIN
         NREND1=(XLOCH/DELTA)+1
         NSTART=((XLOCH+LSTRIN)/DELTA)+1
         CONST=CONST*0.5
C     ATH: "X2" ENTSPRICHT "L"
C
C
C     Y2 IST JA AUCH 0.
100   COSCHI=COS(CHI)
      SINCHI=SIN(CHI)
      X(1)=DELTA
      Y(1)=A*X(1)*X(1)*X(1)+B*X(1)*X(1)+C*X(1)
      IF(NV.GT.0) GOTO 110
         X(1)=0.
         Y(1)=0.
110   CONTINUE
      NR=1
C     LSTOP=L-DELTA
      LSTOP=L
C
C     JETZT DIE X UND Y WERTE IM HILFSSYSTEM AUSRECHNEN UND SPEICHERN
C
1     CONTINUE
         NR=NR+1
         IF(NR.GT.3999) GOTO 150
            X(NR)=X(NR-1)+DELTA
            Y(NR)=A*X(NR)*X(NR)*X(NR)+B*X(NR)*X(NR)+C*X(NR)
2           IF(X(NR).LT.LSTOP) GOTO 1
C              NR=NR+1
C              X(NR)=L
C              Y(NR)=A*X(NR)*X(NR)*X(NR)+B*X(NR)*X(NR)+C*X(NR)
               GOTO 200
         GOTO 100
150   NR=3999
      WRITE (6,102)
102   FORMAT (1X,'FEHLER: Nicht genug Platz in X und Y. ABST zu klein.',
     *      /,1X,' oder Plot zu gross.')
C
C     JETZT DIE MAXIMALE AUSLENKUNG BESTIMMEN UM DIE STAUCHUNG DURCHZU-
C     FUEHEREN
200   MAXAUS=ABS(Y(1))
      DO 300 I=1,NR
             TEST=ABS(Y(I))
             IF(TEST.GT.MAXAUS) MAXAUS=TEST
300          CONTINUE
C
C     DIE MAXIMALE AUSLENKUNG SOLL RELAUS - DER STRECKENLAENGE SEIN,
C     HOECHSTENS JEDOCH ABSAUS CM
      FAKMAX=1.
      IF(MAXAUS.GT.RELAUS*L) FAKMAX=RELAUS*L/MAXAUS
      IF(FAKMAX*MAXAUS.GT.ABSAUS) FAKMAX=ABSAUS/MAXAUS
C
      NEND=NR
      ISTART=1
      IF(LOCH) NEND=NREND1
      INLOCH=.FALSE.
      FAKP=1.
      IF(MAXAUS.EQ.0.) MAXAUS=1.E-07
      XPHI=X1-DELTA
450   DO 400 I=ISTART,NEND
         FAKP=FAKMAX**(SQRT(ABS(Y(I))/MAXAUS))
         YROT=Y(I)*FAKP
         IF(YROT.GT.ABSAUS) YROT=ABSAUS
         IF(YROT.LT.-ABSAUS) YROT=-ABSAUS
         XP=X1+X(I)*COSCHI-YROT*SINCHI
         YP=Y1+X(I)*SINCHI+YROT*COSCHI
CZ       CALL PLOT (XP,YP,2)
C        NUR BEIM ALLERERSTEN SEGMENT DARF DAS ERSTE PIXEL GESPEICHERT
C        WERDEN
C        IF(NV.NE.0.AND.I.EQ.ISTART) GOTO 400
         NV=NV+1
         IF(NV.GT.NVMAX) GOTO 410
            XVALS(NV)=XP
            YVALS(NV)=YP
400      CONTINUE
      IF(.NOT.LOCH.OR.INLOCH) RETURN
410   CONTINUE
      WRITE (6,411) NVMAX
411   FORMAT (1X,'FEHLER: LAENGE VON XVALS, YVALS ZU KLEIN ',
     *           '(NVMAX/ISPAM) ',/,1X,'======> ',I5,' REICHT NICHT.')
C
C
      IF(.NOT.LOCH.OR.INLOCH) RETURN
C
C       ANSONSTEN DIE ZAHL PLOTTEN
        INLOCH=.TRUE.
        ISTART=NSTART
        NEND=NR
        FAKP=FAKMAX**(SQRT(ABS(Y(ISTART))/MAXAUS))
        XP2=X1+X(ISTART)*COSCHI-Y(ISTART)*SINCHI*FAKP
        YP2=Y1+X(ISTART)*SINCHI+Y(ISTART)*COSCHI*FAKP
        XSYM=XP+0.5*HSYM*SINCHI+CONST*COSCHI
        YSYM=YP-0.5*HSYM*COSCHI+CONST*SINCHI
        CHIAUT=CHI*360./6.28
C
CZ      IF(ZAHL) CALL NUMBER (XSYM,YSYM,HSYM,SW,CHIAUT,NKOMMA)
CZ      CALL PLOT (XP2,YP2,3)
        ISTART=ISTART+1
        XSYAUT=XSYM
        YSYAUT=YSYM
        HSYAUT=HSYM
        SWAUT=SW
        NKOAUT=NKOMMA
        GOTO 450
      END
//E.SYSIN DD *
WELTWEITE TEMPERATUREN UND MAECHTIGKEITEN
ISOPACHEN T=0-1 M.A.
PA 10942200000000002  2         0.00  14.09   6.62  23.48   9.83   0.26   0.09
TA 10942200000000002  2        -9.90  16.95  27.16  27.19  -9.90  -9.90  -9.90
(...)
/*
//*.FT09F001 DD SYSOUT=D
//FT09F001 DD DSN=SGP36.ZGRID9,DISP=SHR
//*T10F001 DD SYSOUT=R
//* DATEN UM DOPPELTE BEREINIGT
//FT04F001 DD SYSOUT=T
//*T04F001 DD *
//*T08F001 DD SYSOUT=R
//*T08F001 DD *