c/*****          DIES IST ZUNAECHST MAL EINE RUINE
c/*****  CPU-ZEITEN:
c/*****  SORT FUER DEN GANZEN SUED OHNE AC = 730000 REC. =>   8 SEC
c/*****  SORT FUER DEN GANZEN SUED MIT  AC =1220000 REC. =>  25 SEC
c/*****  SORT MASTER 2                                   =>   1.5 SEC
c/*****  COMPILE                                              1.5 SEC
c/*****  GO MASTER 2                                          9.5 SEC
c/*****  GO DIE ERSTEN 23000 STERNE (OPT(3))                 23.5 SEC
c/*****  GO DIE ZWEITEN 20000 STERNE (OPT(3))                29   SEC
c/*****  GO ALLE STERNE                                     360   SEC
c/*
c/* DIES IST S19A:GSCAC.PPM, ERSTELLEN EINES KOMPILATIONS-KATALOGS
c/*                  AUS EINEM LEONID-IDFILE
c/*
c/*       PROGRAMM PPM - VERSION 13-03-1995:
c/*       - INPUT NUR:       LEONID-IDFILE ( 30 BYTES)
c/*
c/*
c/*       - ES WERDEN NICHT MEHR BEARBEITET (D.H. "UEBERGANGEN"):
c/*
c/*
c/*
c/*       - ES WERDEN NICHT MEHR IN DAS KATALOG-AUSGABE-FILE
c/*         GESCHRIEBEN:
c/*
c/*
c/*
c/*
c/*       PROGRAMM PPM - VERSION 06-11-1990:
c/*       STATISTIK GESTRAFFT UND RICHTIGGESTELLT. IN DER
c/*       VERSION 29-02-90 WAREN FUER EINIGE DER STATISTIKEN
c/*       DIE FALSCHEN STERNE AUSGEWAEHLT WORDEN.
c/*
c/*       PROGRAMM PPM - VERSION 29-02-1990:
c/*       NEUBEARBEITUNG DES PROGRAMMS FUER PPM-SUED.
c/*       NEUERUNGEN: FILE-FORMATE 1.90 - IA=1 WIEDER
c/*       EINGEBAUT - STATISTIK GESTRAFFT - CASE
c/*       ROUTINE GEAENDERT -
c/*
c/*       PROGRAMM PPM - VERSION Dezember 2004
c/*       Versuch einer Neubearbeitung fuer das Ausgleichsprogramm
c/*       NEUERUNGEN: Die Subroutine GETSTA soll das ganze
c/*       Beobachtungsfile verwalten. Sie stellt dem Hauptprogramm
c/*       Daten zur Verfuegung
c/*       Records muessen nach Starnet Records sortiert sein
c/*       Das Beobachtungsfile steht in Unit = 3
c/*       Das Problemfallfile  steht in Unit = 94
c/*       Das Ergibnisfile     steht in Unit = 95 Format noch festl.
c             weitere Verbesserung (aenderung) der Routine
c                 zum Einbau aller 3 beobcat (2MASS, UCAC und Tycho-2)
c     pgf77 ppm.f ppmsub.f getsta.f suchsta.f liessta.f
c/**********************************************************
c/*
C
C **************************************************************
C *                                                            *
C *                PROGRAMM   P P M                            *
C *                                                            *
C *   DIESES PROGRAMM FUEHRT DIE AUSGLEICHUNG VON GEMESSENEN   *
C *    STERNPOSITIONEN ZU EINEM KOMPILATIONSKATALOG DURCH      *
C *                                                            *
C *   MIT AUSREISSERTEST, AUSREISSERELIMINATION, TEST AUF      *
C *   CHI-QUADRAT, AUSFUEHRLICHER STATISTIK ETC.               *
C *   AUSGABE DER PROBLEMFAELLE IN EIN SEPARATES FILE.         *
C *                                                            *
C **************************************************************
C
C DAS PROGRAMM LAEUFT (IMPLIZIT) ALS SCHLEIFE UEBER DIE RECORDS EINES
C LEONID-IDFILES.
C
C DIESES MUSS NACH MC-NUMMERN (ALS ERSTEM KRITERIUM)
C UND NACH EPOCHEN (ALS ZWEITEM KRITERIUM) SORTIERT
C VORLIEGEN.    (ABSTEIGEND)
C
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (IDIM=30)
      PARAMETER (M=6,MMP1=21)
      PARAMETER (KDER=2,IUU=3,ILL=210)
C
      CHARACTER CFORM*1,TEXT(17)*72
      CHARACTER*12 CALP,CDEL,AWERT,DWERT
      CHARACTER*60 fname
      CHARACTER*24 ipix
C
C FUER BEOB-FILE:
C     GSCREC enthaelt in der neuen version einen Satz Sterndaten
C     zum rausschreiben fuer Problemfaelle Characterstring muss
c     angepasst werden
c
c      CHARACTER GSCREC*104,isatz *104,iset*154
      CHARACTER GSCREC*120,isatz *124,iset*172
      CHARACTER ID*30, PLNR*4,STNR*4,STID*4
      INTEGER*2 ICAT,IMAG,IN,IPMA,IPMD,IEPA,IEPD,ISA,ISD,ISPA,ISPD
C FUER DIE BEOB-DATEN:
      DIMENSION PLNR(IDIM),STNR(IDIM)
      DIMENSION AMAG(IDIM)
      DIMENSION ICAT(IDIM)
      DIMENSION TA(IDIM),TD(IDIM)
      DIMENSION DALP(IDIM),DDEL(IDIM),ALP(IDIM),DEL(IDIM)
      DIMENSION WA(IDIM),WD(IDIM),RESA(IDIM),RESD(IDIM)
      DIMENSION GSCREC(IDIM),ISATZ(idim)
C FUER TEST AUF CHI-QUADRAT:
      DIMENSION CHILIM(IDIM)
      real*4 rCHISI,reali,CHILIMi
C FUER HISTOGRAMM DER BEOBACHTUNGSANZAHLEN:
      INTEGER IHISTO(IDIM)
C FUER HISTOGRAMM DER VERSCHIEDENEN TESTERGEBNISSE
      DIMENSION NCASE(6),NCASED(6),NAU(6),NAUD(6)
C FUER BECORA:
      DIMENSION X(M),XMD(M),SD(M),RD(MMP1)
      DIMENSION SXI(M),SXISQ(M),SXIXJ(MMP1)
C FUER AUSR:
      DIMENSION H(IDIM),A(IDIM,KDER),G(IUU),Q(ILL),ABCRMS(IDIM)
      DIMENSION HH(IDIM),IV(IDIM),IVD(IDIM)
C
      DATA (Q(I),I=1,ILL)/ILL*0.D0/
C
C STATISTIK-AKKUMULATOREN
      DATA N,NBEC/2*0/
      DATA N000,N001,N010,N011/4*0/
      DATA N00,N01,N02,N03,N20,N23/6*0/
      DATA NLOE,NOUT,NEPO/3*0/
      DATA (NCASE(I),I=1,6)/6*0/,(NAU(I),I=1,6)/6*0/
      DATA (NCASED(I),I=1,6)/6*0/,(NAUD(I),I=1,6)/6*0/
      DATA (IHISTO(I),I=1,IDIM)/IDIM*0/
C
C LOGISCHE EINHEITEN (PROBLEMFALL-AUSGABE, KATALOG-AUSGABE,
C     BEOB-FILE-EINGABE, MASTER-EINGABE)
      DATA ISTATI,IKAT,LOESCH,IBEO,IAGK/94,6,2,5,4/
      do ise = 1,154
      iset(ise:ise) = ' '
      end do
C
C ZAHLENWERTE
C     DATA IFF,RFF,R8FF/Z80000000,ZFFFFFFFF,ZFFFFFFFFFFFFFFFF/
      SQRT2=DSQRT(2.D0)
      PI=3.1415926535897932D0
      PIH = .5D0*PI
      ZPI = 2.D0*PI
      ARCSEC = PI/(180.D0*3600.D0)
      TICSEC = .01D0*ARCSEC
      ARCSEC=(180.D0*3600.D0)/PI
      DEG=(180.D0        )/PI
C     NFEHL=0
C GEWICHT FUER MITTL. FEHLER 1 RAD BEI GEWICHTSEINHEITSFEHLER 0.18"
      wunico = .0324D0
      WUNISQ=wunico/(ARCSEC*ARCSEC)
C
C *******************************************
C ANFANGSWERTE SETZEN, INITIALISIERUNGEN ETC.
C *******************************************
C
      CALL BEJD(2000.D0,TJ2000)
C TEXTE
c     WRITE(0,*)
c     DO 123 I=1,17
c     READ(5,'(A)') TEXT(I)
c     WRITE(0,*) TEXT(I)
c 123 CONTINUE
C GRENZEN IM BEOB-FILE
c     READ (5,*) MCANF,MCEND
c     READ (5,*) IDECO,IDECU
c     DELANF =( DFLOAT(IDECO)+0.1D0)/DEG
c     DELEND =( DFLOAT(IDECU)-0.1D0)/DEG
C SIGNIFIKANZNIVEAU FUER TEST AUF CHI-QUADRAT
c     READ(5,*) CHISIG
      CHISIG = 0.999
C SIGNIFIKANZNIVEAU FUER AUSREISSERTEST
c     READ(5,*) SLDIS
      SLDIS  = 0.99
C GRENZEN FUER CHI-QUADRAT
c       Modifikation, hier wird single Prez. gerechnet,
c       weil MDCHI dies verlangt
c
      rCHISI = CHISIG
      DO 124 I=1,IDIM
      reali  = FLOAT(I)
      CALL MDCHI(rchisi,reali,chilimi,IER)
      CHILIM(I) = CHILIMi
      IF(IER.NE.0) WRITE(0,*) CHISIG,I,DFLOAT(I),CHILIM(I),IER
      IF(IER.NE.0) STOP 'MDCHI HAS FAILED'
  124 CONTINUE
C
      WRITE(0,*)
      WRITE(0,*) 'EINGELESENE PARAMETER:'
      WRITE(0,*) '======================'
      WRITE(0,*)
      WRITE(0,'(2A,2F10.6)') ' SIGNIFIKANZNIVEAUS FUER TEST AUF'
     *   ,' CHI-QUADRAT UND AUSREISSERTEST:  ',CHISIG,SLDIS
c     WRITE(0,*) 'MASTER-NUMMERN DER ZU BEARBEITENDEN STERNE:      '
c    *                            ,MCANF,MCEND
c     WRITE(0,'(A,2I10)')
c    *  ' DEKL.-BEREICH DER ZU BEARBEITENDEN STERNE (GRAD):'
c    *                                         ,IDECO,IDECU
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*) 'ABSCHLUSSMELDUNG:'
      WRITE(0,*) '================='
      WRITE(0,*)
C
C BEOB-FILE UND LOESCH-FILE INITIALISIEREN
C
c      fname='/work/Tux3/roeser/starnet2/DB2/inbig'
c      fname='testdaten'
c      fname='/home/Tux/msdemlei/usnob/obspos.dump' 
c      OPEN(unit=ibeo,file=fname,access='sequential',form='formatted')
      OPEN(unit=istati,file='problemfaelle',
     *access='sequential',form='formatted')
c      OPEN(unit=ikat,file='/work/Tux3/roeser/starnet2/DB2/loesungen',
c     *access='sequential',form='formatted')
C
      IA=1
      IEOF=0
      IENDE=0
      IG =0
      MC =0
      MCLOE=999999999
C
C ******************************************************************
C                       LOS GEHT'S
C EINEN STERN AUS DEM BEOBACHTUNGSFILE IN TABELLEN EINLESEN
C ******************************************************************
C
      iout = idim 
  101 CONTINUE
      IF(IEOF.EQ.0)
     *call liessTA(ibeo,idim,ig,iout,gscrec,ieof)
      call suchsTA(idim,iout,ig,gscrec,is,isatz,iende)
      CALL GETSTA(idim,is,ia,ticsec,
     *   amag,icat,PLNR,STNR,TA,TD,ALP,DEL,WA,WD,isatz
     *,alpagk,delagk,pma,pmd,ipix)
c     do 1094 khilf = 1, ia
c     write(99,'(a11,i4,f6.3,4d15.7)')
c    *isatz(1)(140:150),khilf,amag(khilf),alp(khilf),del(khilf)
c    *,ta(khilf),td(khilf)
c1094 continue
C
C    VORSICHT : AUS GETSTA KOMMEN SPD HERAUS
C
      N=N+1
c     if(mod(n,1000).eq.0)   print *, n
c     if(n.ge.0) write(99,'(i7,6i4)') n,idim,iout,ig,is,ieof,iende
c      if(n.eq.100000)    goto 99
      MARK=0
C
C STERNE OHNE MESSUNG (NUR BEI CFORM=F MOEGLICH) ERKENNEN UND UEBERGEHEN
C
      IF(IA.EQ.0)
     *THEN
      N=N-1
      GOTO 102
      END IF
C
C STERNE MIT NUR EINER MESSUNG ERKENNEN UND UEBERGEHEN
C
      IF(IA.EQ.1)
     *THEN
      IHISTO(1)=IHISTO(1)+1
      write (58,'(a)') isatz(1)(1:74)
      MARK=1
      N01=N01+1
      N=N-1
      GOTO 102
      END IF
C
C STERNE MIT NUR ZWEI MESSUNGEN ERKENNEN UND, FALLS 'CCC' ENTFERNT
C                            WIRD, UEBERGEHEN.
C
      IF(IA.EQ.2)
     *THEN
      MARK=2
      N02=N02+1
CCC   N=N-1
CCC   GOTO 102
      END IF
C
C STERNE, DIE ZU GERINGE EPOCHENDIFFERENZ HABEN (<10 JAHRE )
C ERKENNEN UND UEBERGEHEN
C
      TMIN=TA(1)
      TMAX=TA(1)
      DO 1011 I=1,IA
      IF(TA(I).LT.TMIN) TMIN=TA(I)
      IF(TA(I).GT.TMAX) TMAX=TA(I)
 1011 CONTINUE
      IF((TMAX-TMIN).LT.10.D0)
     *THEN
      NEPO=NEPO+1
      N=N-1
      GOTO 102
      END IF
C
C
C MASTER-DATEN BESORGEN  ( D.H. HIER NAEHERUNGSWERTE BERECHNEN )
      ALPAGK = 0.D0
      DELAGK = 0.D0
      PMA    = 0.D0
      PMD    = 0.D0
      RMAG   = 0.D0
      K = 0
C     PRINT *, MCNEXT, IA
      DO 450   I = 1,IA
      DEL(I) = DEL(I) - PIH
C     CALL RADCHA(ALP(I),'HH MM SS.SSS',AWERT,IERR,6)
C     CALL RADCHA(DEL(I),'VDD MM SS.SS',DWERT,IERR,6)
C     PRINT *, AWERT,DWERT, ICAT(I), TA(I),TD(I),WA(I),WD(I)
      WA(I) = wunico/(WA(I)*WA(I))
      WD(I) = wunico/(WD(I)*WD(I))
      IF(ICAT(I) .EQ. 1 )    GOTO 451
      STID = STNR(I)
      RMAG = RMAG+AMAG(I)
      K = K + 1
c451  continue
c450  continue
 451  ALPAGK =ALPAGK + ALP(I)
 450  DELAGK =DELAGK + DEL(I)
      DELAGK =DELAGK /DFLOAT(IA)
      ALPAGK =ALp(1)
C     CALL RADCHA(DELAGK,'VDD MM SS.SS',DWERT,IERR,6)
      RMAG = RMAG/DFLOAT(K)
      COSDEL=DCOS(DELAGK)
      DO 452   I = 1,IA
      XX = ALP(I) - ALPAGK
      IF(XX.GT.PI)   XX = XX - ZPI
      IF(XX.LT.-PI)   XX = XX + ZPI
      DALP(I) = XX
      DDEL(I) = DEL(I) - DELAGK
c     write(99,'(a11,i4,f6.3,4d15.7)')
c    *isatz(1)(140:150),i,amag(i),dalp(i),ddel(i)
c    *,ta(i),td(i)
 452  CONTINUE
C
C NUR ZUR ERINNERUNG:
C     DELPRZ=DELAGK-0.00484*COS(ALPAGK)
C
C STERNE MIT NUR ZWEI MESSUNGEN ERKENNEN UND MARKIEREN
C
C     IF(IA.EQ.2)
C    *THEN
C     MARK=2
C     N02=N02+1
C     END IF
C
C STERNE MIT NUR DREI MESSUNGEN ERKENNEN UND MARKIEREN
C
      IF(IA.EQ.3)
     *THEN
      MARK=3
      N03=N03+1
      END IF
C
C
C**********************************************************
C
C AUSGLEICHUNG, AUSREISSERTEST, AUSREISSSERELIMINATION MIT
C ITERATION, ALLES GETRENNT IN ALPHA UND DELTA
C
C**********************************************************
C
C BERECHNUNG VON EINGABEGROESSEN FUER AUSR, ALPHA
      IAU=0
      DO 501 I=1,IA
      A(I,1)=1.D0
      ABCRMS(I)=SQRT(wunico/WA(I))
      IV(I)=0
      Q(I*(I+1)/2)=WA(I)
  501 CONTINUE
C
C AUSGLEICHUNG DURCHFUEHREN, ALPHA
  511 CALL LINF2(IA,TA,DALP,WA,IV,IAU,
     *                         TMA,ALPM,DPMA,X0,SALPM,SPMA0,S0A)
C
C RESIDUEN (BOGENSEK.) UND EINGABEGROESSEN FUER AUSR BERECHNEN, ALPHA
      DO 201 I=1,IA
      IF(IV(I).EQ.1) THEN
      A(I,1)=0.D0
      A(I,2)=0.D0
      ELSE
      A(I,2)=TA(I)-TMA
      END IF
  201 RESA(I)= ( DALP(I)-ALPM-DPMA*(TA(I)-TMA) ) *COSDEL*ARCSEC
C
C AUSREISSERTEST
      IF(IA.LT.3.OR.S0A.EQ.0.D0)
     *THEN
      ICASE=1
      ELSE
      G(1)=wunico/(S0A*S0A)*SALPM*SALPM
      G(3)=wunico/(S0A*S0A)*SPMA0*SPMA0
      G(2)=0.D0
      CALL AUSR(SLDIS,RESA,H,A,G,Q,ABCRMS,HH,IDIM,KDER,
     *          IUU,KDER,IA,ILL,IAU,IAU0,IV,IER)
      CALL CASE(IA,TA,PLNR,IV,IAU,IAU0,ICASE)
      IF(ICASE.EQ.0) GOTO 511
      END IF
c     if(icase.ne.1) then
c     write(99,'(5I7)')  (iv(kpp),kpp=1,5)
c     write(99,'(5I7)')  icase,iau,iau0
c     do 1096 khilf = 1, ia
c     write(99,'(a11,i4,f6.3,4d15.7)')
c    *isatz(1)(140:150),iv(khilf),wa(khilf),alp(khilf),resa(khilf)
c    *,dalp(khilf),ta(khilf)
c1096 continue
c     end if
C
C         *******************************
C
C BERECHNUNG DER EINGABEGROESSEN FUER AUSR, DELTA
      IAUD=0
      DO 502 I=1,IA
      A(I,1)=1.D0
      ABCRMS(I)=SQRT(wunico/WD(I))
      IVD(I)=0
      Q(I*(I+1)/2)=WD(I)
  502 CONTINUE
C
C AUSGLEICHUNG DURCHFUEHREN, DELTA
  512 CALL LINF2(IA,TD,DDEL,WD,IVD,IAUD,
     *                         TMD,DELM,DPMD,X0,SDELM,SPMD0,S0D)
C
C RESIDUEN (BOGENSEK.) UND EINGABEGROESSEN F. AUSR BERECHNEN, DELTA
      DO 202 I=1,IA
      IF(IVD(I).EQ.1) THEN
      A(I,1)=0.D0
      A(I,2)=0.D0
      ELSE
      A(I,2)=TD(I)-TMD
      END IF
  202 RESD(I)= ( DDEL(I)-DELM-DPMD*(TD(I)-TMD) )        *ARCSEC
C
C AUSREISSERTEST
      IF(IA.LT.3.OR.S0D.EQ.0.D0)
     *THEN
      ICASED=1
      ELSE
      G(1)=wunico/(S0D*S0D)*SDELM*SDELM
      G(3)=wunico/(S0D*S0D)*SPMD0*SPMD0
      G(2)=0.D0
      CALL AUSR(SLDIS,RESD,H,A,G,Q,ABCRMS,HH,IDIM,KDER,
     *          IUU,KDER,IA,ILL,IAUD,IAU0D,IVD,IER)
      CALL CASE(IA,TD,PLNR,IVD,IAUD,IAU0D,ICASED)
      IF(ICASED.EQ.0) GOTO 512
      END IF
C
C AUSREISSERSTATISTIK AKKUMULIEREN
      IF(ICASE.LT.1.OR.ICASE.GT.6.OR.
     *   ICASED.LT.1.OR.ICASED.GT.6)
     *THEN
      WRITE(0,*) 'ICASE,ICASED: ',ICASE,ICASED
      STOP
      END IF
      NCASE(ICASE)=  NCASE(ICASE)+1
      NCASED(ICASED)=NCASED(ICASED)+1
      IF(IAU.GT.0)  NAU(IAU)=NAU(IAU)+1
      IF(IAUD.GT.0) NAUD(IAUD)=NAUD(IAUD)+1
C
C**********************************************************
C
C ENDE DES TEILS FUER DEN AUSREISSERTEST
C
C**********************************************************
C
C
C WIDERSPRUECHE ERKENNEN (TEST AUF CHI-QUADRAT)
      ISIG=IA-IAU-2
      ISIGD=IA-IAUD-2
      CHIA=0.D0
      CHID=0.D0
      IF(ISIG.LT.1.OR.ISIGD.LT.1) GOTO 458
      CHIA=S0A*S0A*(ISIG )/WUNISQ*COSDEL*COSDEL
      CHID=S0D*S0D*(ISIGD)/WUNISQ
      IF(CHIA.GT.CHILIM(ISIG ).OR.
     *   CHID.GT.CHILIM(ISIGD))
     *MARK=MARK+20
  458 CONTINUE
C
C STATISTIK DER WIDERSPRUECHE AKKUMULIEREN
      IF(MARK.EQ.0) N00=N00+1
      IF(MARK.EQ.20)N20=N20+1
      IF(MARK.EQ.23)N23=N23+1
C STATISTIK DER PROBLEMFAELLE/WIDERSPRUECHE AKKUMULIEREN
      IF(MARK.LT.20.AND.(ICASE.EQ.1.AND.ICASED.EQ.1)) N000=N000+1
      IF(MARK.LT.20.AND.(ICASE.NE.1.OR .ICASED.NE.1)) N001=N001+1
      IF(MARK.GE.20.AND.(ICASE.EQ.1.AND.ICASED.EQ.1)) N010=N010+1
      IF(MARK.GE.20.AND.(ICASE.NE.1.OR .ICASED.NE.1)) N011=N011+1
C
C
C ASTROM. PARAMETER FUER DEN STERN AUS DEM AUSGLG.-ERGEBNIS BERECHNEN
C ZUERST KLEINE KORREKTUR, UM AUF GEMEINSAME MITTL. EPOCHE ZU KOMMEN
C
      EPODA = TMA+TMD
      EPODA = EPODA*.5D0
      CALL BEJD(EPODA,TJEPOD)
      ALPKAT=ALPAGK+ALPM+DPMA*(EPODA-TMA)
      IF(alpkat.GT.zPI)  alpkat = alpkat - ZPI
      IF(alpkat.lT.0.d0)  alpkat = alpkat + ZPI
      DELKAT=DELAGK+DELM+DPMD*(EPODA-TMD)
      PMAKAT=PMA+DPMA*100.D0
      PMDKAT=PMD+DPMD*100.D0
      CALL TPMPM(ALPKAT,DELKAT,PMAKAT,PMDKAT,0.D0,TJEPOD,TJ2000,
     *                  ALPNEU,DELNEU,PMANEU,PMDNEU)
      SWA=0.D0
      SWD=0.D0
      SWTTA=0.D0
      SWTTD=0.D0
      DO 402 I=1,IA
      IF(IV (I).NE.1) SWA=SWA+WA(I)
      IF(IVD(I).NE.1) SWD=SWD+WD(I)
      IF(IV (I).NE.1) SWTTA=SWTTA+WA(I)*(TA(I)-TMA)*(TA(I)-TMA)
      IF(IVD(I).NE.1) SWTTD=SWTTD+WD(I)*(TD(I)-TMD)*(TD(I)-TMD)
  402 CONTINUE
      SALPM=SQRT(WUNISQ/SWA)/COSDEL
      SDELM=SQRT(WUNISQ/SWD)
      SPMA=SQRT(WUNISQ/SWTTA)*100.D0/COSDEL
      SPMD=SQRT(WUNISQ/SWTTD)*100.D0
C
C ALPHA-GROESSEN AUF WINKEL UMRECHNEN
C
      S0AA=S0A*COSDEL
      SPMAA=SPMA0*COSDEL
      ALPMA=ALPM*COSDEL
      DPMAA=DPMA*COSDEL
      SALPMA=SALPM*COSDEL
C UMRECHNUNGEN UND LESBARE AUSGABE (ALLES IN BOGENSEKUNDEN)
C
      ALPOUT=ALPMA*ARCSEC
      DELOUT=DELM*ARCSEC
      S0AOUT=S0AA*ARCSEC
      S0DOUT=S0D*ARCSEC
      PMAOUT=DPMAA*ARCSEC
      PMDOUT=DPMD*ARCSEC
      SPMAOU=SPMAA*ARCSEC
      SPMDOU=SPMD0*ARCSEC
      SALPOU=SALPMA*ARCSEC
      SDELOU=SDELM*ARCSEC
C
C       UMRECHNUNGEN FUER GSC-OUTPUT FILE
C
C      PRINT *, S0AOUT,SALPOU,SPMAOU,TMA
C      PRINT *, S0DOUT,SDELOU,SPMDOU,TMD
C     CALL RADCHA(ALPKAT,'HH MM SS.SSS',AWERT,IERR,6)
C     CALL RADCHA(DELKAT,'VDD MM SS.SS',DWERT,IERR,6)
C     PRINT *, AWERT,DWERT
C     CALL RADCHA(ALPNEU,'HH MM SS.SSS',AWERT,IERR,6)
C     CALL RADCHA(DELNEU,'VDD MM SS.SS',DWERT,IERR,6)
C     PRINT *, AWERT,DWERT,PMANEU*COSDEL*ARCSEC,PMDNEU*ARCSEC
       RMAG = RMAG*100.D0
       JEP = NINT(RMAG)
       IMAG = JEP
       ALPHA = ALPNEU/TICSEC*10.d0
       IAL = NINT(ALPHA)
       DELTA = DELNEU/TICSEC*10.d0
       IDEL= NINT(DELTA)
       JPMA= NINT(PMANEU/TICSEC*10.D0*cosdel)
       MPMA= NINT(PMAKAT/TICSEC*10.D0*cosdel)
       JPMD= NINT(PMDNEU/TICSEC*10.D0)
       IN = IA
      BE = TMA - 1800.D0
      IEA = NINT(BE*100.D0)
      IEPA = IEA
      BE = TMD - 1800.D0
      IED = NINT(BE*100.D0)
      IEPD = IED
      JSA  = NINT(SALPOU*1000.D0)
      JSD  = NINT(SDELOU*1000.D0)
      JSPA = NINT(SPMA*COSDEL*ARCSEC*100.D0)
      JSPD = NINT(SPMD*ARCSEC*100.D0)
      ISA = JSA
      ISD = JSD
c     ISPA = JSPA
c     ISPD = JSPD
c      read(isatz(1)(41:54),'(2i7)') lpma,lpmd
c      npma = jpma-lpma
c      npmd = jpmd-lpmd
c     if(iabs(npma).gt.10000.or.iabs(npmd).gt.10000)  then
c     if(icase.ne.1)  then
c     write(99,'(2i7)') icase,icased
c     write(99,'(a)') isatz(1)(1:163)
c     do 4567 ihil = 1,is
c567  write(99,'(a)') isatz(ihil)(197:359)
c     end if
C
       IMARK= MARK + ICASED * 1 000 + ICASE * 1 000 000
C
C FUER DIE NORMALFAELLE: ERGEBNISSE INS KATALOG-AUSGABE-FILE SCHREIBEN
C
CC    IF(ICASE.EQ.1.AND.ICASED.EQ.1.AND.MARK.NE.23)
C     IF(DELNEU.LE.DELANF.AND.DELNEU.GE.DELEND)    THEN
CC   *THEN
cc    WRITE(IKAT,'(a)') isatz(1)(1:196)
      WRITE(Iset(1:22),'(2i11)') ial,idel
      WRITE(Iset(23:66),'(2i7,2i4,2i6,2i5)') jpma,jpmd,
     *jspa,jspd,iepa,iepd,isa,isd
      WRITE(Iset(67:75),'(i2,i7)') in,imark
      iset(77:126) = isatz(1)(1:50)
c      iset(128:151)  = isatz(1)(51:74)
      iset(128:151)  = ipix
      iset(152:172)  = isatz(1)(101:120)
      WRITE(IKAT,'(a)') iset
c     if(iabs(npma).gt.10000.or.iabs(npmd).gt.10000)  then
c     if(icase.ne.1)  then
c     WRITE( 99 ,'(a)') isatz(1)(1:196)
c     write(99,'(2i11)') npma,npmd
c     end if
c     WRITE(IKAT,'(a11,2i10,i5,i3,i10,4i6,2i5,2i4)') isatz(1)(140:150),
c    *     IAL,IDEL,IMAG,IN,IMARK,IPMA,IPMD,IEPA,IEPD,ISA,ISD,ISPA,ISPD
ccc  *,MCALT
      NOUT=NOUT+1
CC    END IF
C     END IF
C
C     IF(N.LE.10)
C    *WRITE(0,*) 'TEST: ',RMAG,' ',SPECT,' ',
C    *          SNGL(PMANEU*ARCSEC),SNGL(PMDNEU*ARCSEC),
C    *          '       ',SNGL(PMANEU*ARCSEC*COSDEL),
C    *          '       ',SNGL(PMANEU*ARCSEC/COSDEL)
C
C FUER DIE NORMALFAELLE OHNE WIDERSPRUECHE: STATISTIK AKKUMULIEREN
C
c
c       Fuer statistik wollen wir nun eb in mas/year
c
      IF(ICASE.EQ.1.AND.ICASED.EQ.1.AND.MARK.NE.1.AND.MARK.NE.2
     *   .AND.MARK.NE.20.AND.MARK.NE.23.and.ia.ge.4)
     *THEN
      X(1)=         S0AOUT*S0AOUT
      X(2)=         S0DOUT*S0DOUT
      X(3)=         SPMAOU*SPMAOU
      X(4)=         SPMDOU*SPMDOU
c      X(5)=         Dfloat(jpma-lpma)*.01d0
c      X(6)=         Dfloat(jpmd-lpmd)*.01d0
      X(5)=         Dfloat(jpma)*.01d0
      X(6)=         Dfloat(jpmd)*.01d0
C
       
      CALL BECORA(1,M,MMP1,X,NBEC,XMD,SD,RD,SXI,SXISQ,SXIXJ)
C
      END IF
C
C FUER DIE PROBLEMFAELLE: DATEN INS PROBLEMFILE SCHREIBEN
C
ccc     
ccc      IF(ICASE.GT.1.OR.ICASED.GT.1.OR.MARK.EQ.23)
CCC  *   .OR.SPMD*ARCSEC.GT.3.0D0.OR.SPMA*ARCSEC*COSDEL.GT.2.6D0)
CCC   IF(1.EQ.1)
ccc  *THEN
CCC   CALL RADCHA(ALPAGK,'HH MM SS.SSS',CALP,IER,6)
CCC   IF(IER.NE.0) STOP 'MURKS IN RADCHA ALPHA'
CCC   CALL RADCHA(DELAGK,'VDD MM SS.SS',CDEL,IER,6)
CCC   IF(IER.NE.0) STOP 'MURKS IN RADCHA DELTA'
CCC   WRITE(ISTATI,'(1X,I6,2(2X,A12),1X,2(F8.4),1X,F6.1,2X,
CCC  *               A2,2X,F7.1,   27X        ,A)')
CCC  *MCALT,CALP,CDEL,PMA*COSDEL*ARCSEC*.01D0,PMD*ARCSEC*.01D0,EPODA,
CCC  *SPECT,RMAG,             ' * MASTER *'
CCC   WRITE(ISTATI,'(1X,I6,1X,2(F8.2),1X,2(F8.3),1X,2(F8.4),
CCC  *             1X,2(F6.3),1X,2(F7.4),1X,2(F6.3),1X,2(F6.1),A)')
CCC  *MCALT,TMA,TMD,ALPOUT,DELOUT,PMAOUT,PMDOUT,
CCC  *SALPM*ARCSEC*COSDEL,SDELM*COSDEL,
CCC  *SPMA *ARCSEC*COSDEL,SPMD *COSDEL,
CCC  *S0AOUT,S0DOUT,CHIA,CHID,' * PPM *'
CCC   WRITE(ISTATI,'(1X,I6,A7,I2,A8,I1,A9,I1,A5,I2,A6,I2,A7,I2,
CCC  *               A10,F9.6)')
CCC  *  MCALT,'  MARK=',MARK,'  ICASE=',ICASE,'  ICASED=',ICASED,
CCC  *           '  IA=',IA,'  IAU=',IAU,'  IAUD=',IAUD,
CCC  *'   COSDEL=',COSDEL
ccc   DO 403 I=1,Is
ccc   WRITE(ISTATI,'(A)') isatz(I)
CCC   WRITE(ISTATI,'(1X,I6,2X,A6,1X,A6,1X,2(F8.2),1X,2(F6.3),
CCC  *               1X,2(F8.3),1X,2(F7.2),2I3,A)')
CCC  *MCALT,PLNR(I),STNR(I)(3:8),TA(I),TD(I),WA(I),WD(I),
CCC  *DALP(I)*COSDEL*ARCSEC,DDEL(I)*ARCSEC,RESA(I),RESD(I),IV(I),IVD(I)
CCC  *,' * BEOB *'
cc403 CONTINUE
cc    END IF
C
C HISTOGRAMM DER BEOB-ANZAHLEN AKKUMULIEREN
C
      IHISTO(IA)=IHISTO(IA)+1
C
C*******************************************************
C SPRUNG ZUM PROGRAMMENDE ODER
C WEITERSCHALTEN ZUM NAECHSTEN STERN:
C ZURUECKSETZEN DES BEOB.-FILES UM EINEN RECORD (nicht mehr noetig)
C UM DIE OBEN WEGGESCHMISSENEN DATEN NOCHMAL EINZULESEN.
C RUECKSPRUNG ZUM EINLESETEIL FUER DAS BEOB.-FILE.
C*******************************************************
C
C
  102 CONTINUE
      MC = MC + 1
      IF(IENDE.EQ.1)
     *GOTO 99
C
      IA=1
      GOTO 101
C
C
C
C
C*************************************************
C
C         AUSGAENGE, ABSCHLUSSMELDUNGEN ETC.
C
C*************************************************
C
c  98 WRITE(0,'('' ENDE DER ZU BEARBEITENDEN MC-NUMMERN ERREICHT.''/)')
c     GOTO 95
   99 WRITE(0,'('' ENDE DES BEOBACHTUNGSFILES ERREICHT.''/)')
c  95 CONTINUE
C
C*************************************************
C
C      STATISTIKAUSGABE
C
C*************************************************
C
C
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*) 'STATISTIK DES BEOB-FILES:'
      WRITE(0,*) '========================='
      WRITE(0,*)
c     WRITE(0,*) 'ZAHL DER ZU BEARBEITENDEN STERNE:      '
c    *                            ,1+MCANF-MCEND
c     WRITE(0,*)
c     WRITE(0,*) 'DAVON NICHT BEARBEITET:'
c     WRITE(0,*) '   STERNE OHNE MESSUNGEN (IA=0)           '
c    *                            ,1+MCANF-MCEND-N-N01-N02-NLOE-NEPO
c     WRITE(0,*) '   STERNE MIT NUR EINER MESSUNG (IA=1)    '
c    *                            ,N01
CC    WRITE(0,*) '   STERNE MIT NUR ZWEI MESSUNGEN (IA=2)   '
CC   *                            ,N02
c     WRITE(0,*) '   STERNE MIT IA>2, ABER IM "LOESCH"-FILE '
c    *                            ,NLOE
c     WRITE(0,*) '   STERNE MIT IA>2 ABER MAX. EP.DIFF.<25J '
c    *                            ,NEPO
C     WRITE(0,*) 'LUECKEN IM BEOB-FILE:                  '
C    *                            ,NFEHL
      WRITE(0,*)
      WRITE(0,*) 'HISTOGRAMM FUER ZAHL DER MESSUNGEN (VON 1 BIS 20):'
      WRITE(0,'(1X,10I7)') (IHISTO(I),I=1,10)
      WRITE(0,'(1X,10I7)') (IHISTO(I),I=11,20)
C TEXTE (ZWEITER SEITENKOPF)
      WRITE(0,'(''1'')')
      WRITE(0,*)
      DO 146 I=12,17
C      WRITE(0,*) TEXT(I)
  146 CONTINUE
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*) 'ERFOLGSSTATISTIKEN:'
      WRITE(0,*) '==================='
      WRITE(0,*)
      WRITE(0,*) 'MERKE:'
      WRITE(0,*) 'DER ERZEUGTE KOMPILATIONSKATALOG ENTHAELT',
     *           ' NUR DIE AUSGEGEBENEN STERNE'
      WRITE(0,*)
      WRITE(0,*) 'ZAHL DER BEARBEITETEN STERNE              : ', N
      WRITE(0,*) 'ZAHL DER AUSGEGEBENEN STERNE              : ', NOUT
      WRITE(0,*) 'DAVON STERNE MIT NUR ZWEI MESSUNGEN (IA=2): ', N02
      WRITE(0,*) 'DAVON STERNE MIT NUR DREI MESSUNGEN (IA=3): ', N03
      WRITE(0,*)
C
      WRITE(0,*)
      WRITE(0,*) 'HISTOGRAMM FUER DIE AUSREISSER-ELIMINATION',
     *           ' (VON 1 BIS 6):'
      WRITE(0,*) 'IN ALPHA ',(NAU(I),I=1,6)
      WRITE(0,*) 'IN DELTA ',(NAUD(I),I=1,6)
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*) 'ERFOLGSSTATISTIK DER AUSREISSER-ELIMINATION',
     *           ' (JEWEILS GETRENNT IN ALPHA UND DELTA):'
      WRITE(0,*)
      WRITE(0,8) 'ERFOLGSFALL, KEINE WEITEREN AUSREISSER LIEGEN VOR: ',
     *           NCASE(1),NCASED(1), '  (NCASE BZW. NCASED=1)'
      WRITE(0,8) 'PROBLEMFALL, WENIGER ALS 4 MSG. WUERDEN BLEIBEN:   ',
     *           NCASE(6),NCASED(6), '  (NCASE BZW. NCASED=6)'
      WRITE(0,8) 'PROBLEMFALL, MEHR ALS 2 MSG. WUERDEN ELIMINIERT:   ',
     *           NCASE(5),NCASED(5), '  (NCASE BZW. NCASED=5)'
C     WRITE(0,8) 'PROBLEMFALL, FOKAT-MESSUNG WUERDE ELIMINIERT:      ',
C    *           NCASE(3),NCASED(3), '  (NCASE BZW. NCASED=3)'
C     WRITE(0,8) 'ICASE BZW. ICASED=2 ( AGK2 WUERDE ELIMINIERT )     ',
C    *           NCASE(2),NCASED(2)
    8 FORMAT(1X,A,I7,I7,A)
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*) 'ERGEBNIS DER TESTS AUF WIDERSPRUECHE (CHI-QUADRAT)',
     *           ' NACH DER AUSREISSER-ELIMINATION:'
      WRITE(0,*)
      WRITE(0,*) 'ZAHL DER HIER VERWENDETEN STERNE:   ',N00+N03+N20
      WRITE(0,*) ' ( = ALLE STERNE MIT MEHR ALS 2 MSG.)'
      WRITE(0,*) 'ZAHL DER STERNE OHNE WIDERSPRUECHE: ',N00+N03-N23
      WRITE(0,*) 'ZAHL DER STERNE MIT WIDERSPRUECHEN: ', N20+N23
      WRITE(0,*) 'DAVON STERNE MIT NUR DREI MSG.:     ', N23
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*) 'STATISTIK DER PROBLEMFAELLE/WIDERSPRUECHE:'
      WRITE(0,*)
      WRITE(0,*) 'KEIN PROBLEMFALL UND KEINE WIDERSPRUECHE:   ',N000
      WRITE(0,*) 'KEIN PROBLEMFALL, ABER WIDERSPRUECHE:       ',N010
      WRITE(0,*) '     PROBLEMFALL UND WIDERSPRUECHE:         ',N011
      WRITE(0,*) '     PROBLEMFALL, ABER KEINE WIDERSPRUECHE: ',N001
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*)
C
C BECORA-STATISTIK ABSCHLIESSEN (BECORA MIT L=2)
      IF(NBEC.NE.0)
     *CALL BECORA(2,M,MMP1,X,NBEC,XMD,SD,RD,SXI,SXISQ,SXIXJ)
C
C ERKLAERUNGEN DAZU:
C
C     DIE VARIANZEN VON X(1) UND X(2)
C     LIEFERN GUTE SCHAETZUNGEN DES QUADRIERTEN GEWICHTSEINHEITS-
C     FEHLERS AUS DEN RESIDUEN NACH DER AUSGLEICHUNG
C
C     X(3) UND X(4) GEBEN KEINEN STATISTISCH VERNUENFTIGEN WERT.
C     ES WIRD HALT EIN LINEARER UND EIN QUADRATISCHER MITTELWERT DER
C     EIGENBEWEGUNGSFEHLER BERECHNET. MAN KRIEGT EIN GEFUEHL FUER DIE
C     GROESSENORDNUNG, MEHR NICHT.
C
C     X(5) UND X(6) GEBEN LINEARE MITTELWERTE UND QUADRATISCHE
C     MITTELWERTE (STREUUNGEN) DER EIGENBEWEGUNGSZUSCHLAEGE
C     ZUM VERGLEICH MIT DEN MITTL. FEHLERN DER MASTER-EIGENBEWEGGEN.
C
      WRITE(0,*) 'STATISTIK AUS SUBROUTINE BECORA:'
      WRITE(0,*) '================================'
      WRITE(0,*)
C
      WRITE(0,*) 'ZAHL DER HIER VERWENDETEN STERNE:      ',NBEC
      WRITE(0,*) '( = MEHR ALS 2 MSG, KEIN PROBL-FALL, KEIN WIDERSPR)'
      WRITE(0,'(A,13X,F7.3,A)')
     *          ' GEWICHTSEINHEITSFEHLER IN ALPHA (AUS VPV): ',
     *            DSQRT(XMD(1)),' ARCSEC'
      WRITE(0,'(A,13X,F7.3,A)')
     *          ' GEWICHTSEINHEITSFEHLER IN DELTA (AUS VPV): ',
     *            DSQRT(XMD(2)),' ARCSEC'
      WRITE(0,'(2A,F7.3,A)')
     *          ' MITTL. FEHLER DER RESULT. EIGENBEW. IN ALPHA ',
     *            '(AUS VPV): ',DSQRT(XMD(3))*1000.D0,' MAS/YEAR'
      WRITE(0,'(2A,F7.3,A)')
     *          ' MITTL. FEHLER DER RESULT. EIGENBEW. IN DELTA ',
     *            '(AUS VPV): ',DSQRT(XMD(4))*1000.D0,' MAS/YEAR'
      WRITE(0,'(A,6X,F7.3,A)')
     *          ' MITTELW. D. ZUSCHLAEGE ZU DEN EIGENBEW. IN ALPHA: ',
     *                  XMD(5)        ,' MAS/YEAR'
      WRITE(0,'(A,6X,F7.3,A)')
     *          ' MITTELW. D. ZUSCHLAEGE ZU DEN EIGENBEW. IN DELTA: ',
     *                  XMD(6)        ,' MAS/YEAR'
      WRITE(0,'(A,6X,F7.3,A)')
     *          ' STREUUNG D. ZUSCHLAEGE ZU DEN EIGENBEW. IN ALPHA: ',
     *                  SD(5)        ,' MAS/YEAR'
      WRITE(0,'(A,6X,F7.3,A)')
     *          ' STREUUNG D. ZUSCHLAEGE ZU DEN EIGENBEW. IN DELTA: ',
     *                  SD(6)        ,' MAS/YEAR'
        
C
C************************************************************
C
C            ENDE
C
C************************************************************
C
      WRITE(0,*)
      WRITE(0,*)
      WRITE(0,*)
      STOP  'NORMALES ENDE ERREICHT'
      END
C
C
      SUBROUTINE CASE(IA,TA,PLNR,IV,IAU,IAU0,ICASE)
C
C ERKLAERUNG DER EINZELNEN FAELLE IN ABSTEIGENDER PRIORITAET:
C
C ICASE=6   ES SOLL NOCH EINE MESSUNG RAUSGESCHMISSEN WERDEN UND
C           WENIGER ALS 3 MESSUNGEN WUERDEN UEBRIG BLEIBEN
C ICASE=5   MEHR ALS 1 MESSUNGEN WUERDEN RAUSGESCHMISSEN
C ICASE=4   DURCH 'CCCC' GELOESCHT. MAXIMALE EPOCHENDIFFERENZ WUERDE
C           KLEINER ALS 50 JAHRE.
C ICASE=3   2. Epoche Starnet WUERDE RAUSGESCHMISSEN
C ICASE=2   1. Epoche Starnet WUERDE RAUSGESCHMISSEN
C ICASE=1   IN ORDNUNG, KEINE MESSUNG SOLL MEHR RAUSGESCHMISSEN WERDEN
C ICASE=0   WEITER ITERIEREN KEINE DER OBIGEN ABBRUCHBEDINGUNGEN IST
C           ERFUELLT, ABER ES SOLL NOCH EINE MESSUNG RAUSGESCHMISSEN
C           WERDEN.
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER*6 PLNR
      DIMENSION IV(IA),TA(IA),PLNR(IA)
C
      ICASE=-99
C
C ERSTER TEIL: ES SOLL KEINE MESSUNG MEHR RAUSGESCHMISSEN WERDEN
C
      IF(IAU0.EQ.0) THEN
      ICASE=1
      RETURN
      END IF
C
C ZWEITER TEIL: ES SOLL NOCH EINE RAUSGESCHMISSEN WERDEN
C   hier wurde versuchsweise 3 gesetzt
      IF((IA-IAU).LT.3) THEN
      ICASE=6
      RETURN
      ELSE IF(IAU.GT.1) THEN
      ICASE=5
      RETURN
C
      ELSE
CCCC  TMIN=TA(1)
CCCC  TMAX=TA(1)
C     DO 101 I=1,IA
CC    IF(IV(I).EQ.1.AND.PLNR(I).EQ.'  AGK2') ICASE=2
C     IF(IV(I).EQ.1.AND.PLNR(I).EQ.' FOKFI') ICASE=3
CCCC  IF(IV(I).EQ.0.AND.TA(I).GT.TMAX) TMAX=TA(I)
C 101 CONTINUE
      IF(IV(1).EQ.1.)  ICASE=2
      IF(IV(2).EQ.1.)  ICASE=3
      END IF
C
CCCC  IF((TMAX-TMIN).LT.50.D0.AND.(IA-IAU).LT.4) THEN
CCCC  ICASE=4
CCCC  RETURN
CCCC  END IF
      IF(ICASE.EQ.2.OR.ICASE.EQ.3)
     *RETURN
      ICASE=0
      RETURN
      END
c****************************************************************
c*                                                             **
c*      PROGRAMM PPM - VERSION 13-03-1995/13-09-2005           **
c*                                                             **
c*      VERSION FUER Starnet2                                  **
c*      ID-FILES der Groesse 392                               **
c*                                                             **
c*      VERWENDET DIE          GEREINIGTEN ID-FILES 13.9.05    **
c*                                                             **
c*                                                             **
c****************************************************************
c*                                                             **
c*  Starnet2        , ERSTER PROBELAUF                         **
c*                                                             **
c****************************************************************