C *******************************************************************
C *****                                                             *
C *****                  UNTERPROGRAMM  CHARAD                      *
C *****                                                             *
C *****   UMWANDLUNG EINES WINKELS, DER IN GRAD ODER STUNDEN ODER   *
C *****   MINUTEN (ZEIT ODER BOGEN-) ODER IN SEKUNDEN (ZEIT ODER    *
C *****   BOGEN-) ODER IN EINER SINNVOLLEN KOMBINATION DER GENANN-  *
C *****   TEN EINHEITEN ALS CHARCTERSTRING ANGEGEBEN IST, IN        *
C *****   BOGENMASS (DOPPELTGENAUE REALGROESSE).                    *
C *****                                                             *
C *******************************************************************
C *****                                                             *
C *****  AUFGERUFEN WIRD DAS UNTERPROGRAM MIT                       *
C *****                                                             *
C *****     CALL CHARAD (C1,C2,RDG,IER,LUNERR)                      *
C *****                                                             *
C *****     WOBEI BEDEUTEN :                                        *
C *****     C1     =  WINKEL IN D,H,M,S ETC    C*(*)    EINGABE     *
C *****     C2     =  FORMAT VON C1            C*(*)    EINGABE     *
C *****     RDG    =  WINKEL IM BOGENMASS      R*8      AUSGABE     *
C *****     IER    =  FEHLERMELDUNG            I3       AUSGABE     *
C *****     LUNERR =  LOGICAL UNIT NUMBER FUER DIE AUSGABE EINER    *
C *****               FEHLERMELDUNG            I2       EINGABE     *
C *****                                                             *
C *******************************************************************
      SUBROUTINE CHARAD(CHA,INFORMAT,RAD,IER,LUNERR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DATA FZ,SZ /15.D0,60.D0/
      CHARACTER*1 CH(20),KCH(20)
      CHARACTER*(*) CHA,INFORMAT,ierstr*3
      CHARACTER*70 text0,text1,text2,text3,text4,text5,text6,text7
      CHARACTER*70 text8
			CHARACTER*80 FORMAT
      ILE1= LEN(CHA)
      ILE2= LEN(INFORMAT)
C
      text0 = 'von charad behoben, Fehlerangabe nur zur Information'
      text1 = 'XSTAR8(3 bzw 6) auf -9999.d0   KENNX8(3 bzw 6) auf 0 setz
     *en'
      text2 = 'korrigierter Wert ist in die Datei korrektur einzutragen'
      text3 = 'Koordinate fehlt'
      text4 = 'XSTAR8(3 bzw 6) auf -8888.d0   KENNX8(3 bzw 6) auf 0 setz
     *en'
      text5 = 'falls es zuviele sind charad ueberspringen'
      text6 = 'Fehler in der Formatangabe des Charad-Aufrufes'
      text7 = 'im Leseprogramm zu korrigieren'
      text8 = 'ergaenzte Koordinate ist in die Datei korrektur einzutrag
     *en'
C  Erstmal den Formatstring auf Grossbuchstaben bringen
      FORMAT = INFORMAT
      do i=1,ile2
       call upcase(FORMAT(i:i))
      end do
      IF(ILE1.NE.ILE2) THEN
      IER = 93
      GOTO 900
      END IF
      DO 99 I=ILE1,1,-1
      IF (CHA(I:I).NE.' ') GOTO 9
   99 CONTINUE
      IER = 99
      GOTO 900
    9 LCHA=I
C *******************************************************************
C *****                                                             *
C *****   RA   = 1   WENN DER WINKEL IN GRAD, BOGENMINUTEN ODER     *
C *****              -SEKUNDEN ANGEBEN IST                          *
C *****        = 15  WENN DER WINKEL IN STUNDEN, ZEITMINUTEN        *
C *****                   -SEKUNDEN ANGEBEN IST                     *
C *****        = 0   WENN EIN FEHLER AUFGETRETEN IST, DER MIT       *
C *****              IER-MELDUNG ENDET                              *
C *****        ZU BEGINN DES PROGRAMMS WIRD RA=1 GESETZT            *
C *****                                                             *
C *****   IER  =  0  KEIN FEHLER BEI DER EINGABE                    *
C *****        >  0  FEHLER BEI DER EINGABE                         *
C *****              WENN MOD(10) = 0  FEHLER IN FORMATEINAGE (C2)  *
C *****              WENN MOD(10) > 0  FEHLER IN WERTEINGABE  (C1)  *
C *****        ZU BEGINN DES PROGRAMMS WIRD IER=0 GESETZT           *
C *****                                                             *
C *****   IVA  =  1  POSITIVES VORZEICHEN (' ' , + , & )            *
C *****        = -1  NEGATIVES VORZEICHEN ( - )                     *
C *****        ZU BEGINN DES PROGRAMMS WIRD IVA=1 GESETZT           *
C *****                                                             *
C *****   IVK  =  0  KEINE UEBERLOCHUNG DER LETZTEN STELLE IN C1    *
C *****        =  1  UEBERLOCHUNG       DER LETZTEN STELLE IN C1    *
C *****        ZU BEGINN DES PROGRAMMS WIRD IVK=0 GESET
C *****                                                             *
C *******************************************************************
      RA=1.D0
      PI = 3.1415926535897932D0
      IER = 0
      IVA=1
      IVK=0
      A=3600.D0
      RADZ=0.D0
      DO 10 I=1,LCHA
      CH(I)=CHA(I:I)
      KCH(I)=FORMAT(I:I)
   10 CONTINUE
C *******************************************************************
C *****                                                             *
C *****   ABFRAGE DES FORMATS, IN WELCHER EINHEIT C1 ANGEGEBEN IST  *
C *****                                                             *
C *****   H  =  STUNDEN (REKTASZENSION)                             *
C *****   D  =  GRAD    (DEKLINATION, GAL.BREITE ETC.)              *
C *****   L  =  LAENGE  (GAL.LAENGE)                                *
C *****   T  =  ZEIT-   (-MINUTEN ODER -SEKUNDEN)                   *
C *****   A  =  BOGEN   (-MINUTEN ODER -SEKUNDEN)                   *
C *****   V  =  VORZEICHEN (POS: ' ','+','&')                       *
C *****                    (NEG: '-')                               *
C *****   X  =  UEBERLOCHUNG (DER 1. ODER LETZTEN STELLE)           *
C *****   M  =  MINUTEN  (ZUSAMMEN MIT T ODER HH : ZEIT
C *****                  (MIT A, DD ODER ' '     : BOGENMINUTEN)    *
C *****   S  =  SEKUNDEN (ZUSAMMEN MIT T ODER HH : ZEITSEKUNDEN)    *
C *****                  (MIT A, DD ODER ' '     : BOGENSEKUNDEN)   *
C *****                                                             *
C *******************************************************************
      IF  (KCH(2).EQ.'H') GOTO 100
      IF  (KCH(2).EQ.'D') GOTO 200
      IF  (KCH(2).EQ.'L') GOTO 300
      J=1
      IF  (KCH(1).NE.'T') GOTO  20
      RA=FZ
      GOTO 50
   20 IF (KCH(1).EQ.'A') GOTO 50
      IF (KCH(1).EQ.'V') GOTO 30
      IF (KCH(1).EQ.'X') GOTO 50
      IF (KCH(LCHA).EQ.'X') GOTO 40
      IF (KCH(1).EQ.'Y') GOTO 61
      IF (KCH(LCHA).EQ.'Y') GOTO 60
      GOTO 50
   61 RA=FZ
      GOTO 50
   60 RA=FZ
      GOTO 40
   29 IF (KCH(1).EQ.'D') GOTO 401
      IF (KCH(1).EQ.'M') GOTO 411
      IF (KCH(1).EQ.'S') GOTO 421
      GOTO 90
   50 IF  (KCH(2).EQ.'M') GOTO 210
      A=SZ
      IF  (KCH(2).EQ.'S') GOTO 220
   90 IER =  90
      GOTO 900
   30 IVA=1
      IF (CH(1).EQ.'-') IVA=-1
      J=J+1
      IF (KCH(2).EQ.'T') RA=FZ
      IF (KCH(3).EQ.'M') GOTO 210
      IF (KCH(3).EQ.'S') GOTO 220
      GOTO 90
   40 IVK=1
      CALL INPUT(CH(LCHA),Z,IV,IE)
      IF (IE.EQ.0) GOTO 41
      IF (IE.GT.0) IER = 91
      IF (IE.LT.0) IER = 92
      GOTO 900
   41 B=Z
      IVA=IV
      IF (LCHA.EQ.2) GOTO 29
      GOTO 50
C *******************************************************************
C *****                                                             *
C *****              UMRECHNUNG VON STUNDENWINKELN                  *
C *****                                                             *
C *******************************************************************
  100 RA=FZ
      J=0
      ZW=0.D0
      DO 102 K=10,1,-9
      J=J+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 1010
      IF (IE.GT.0) IER = 151
      IF (IE.LT.0) IER = 152
      GOTO 900
 1010 ZZ = Z * DBLE(K)
      ZW = ZW + ZZ
      IF (ZW.LE.24.) GOTO 101
      IER = 111
      GOTO 900
  101 RADZ=RADZ + ZZ * 3600.D0
      IF (J.GE.LCHA) GOTO 900
  102 CONTINUE
  103 J=J+1
      IF (KCH(J).EQ.' ')  GOTO 103
      IF (KCH(J).EQ.'M')  GOTO 110
      IF (KCH(J).EQ.'.')  GOTO 150
      IF (KCH(J).EQ.'H')  GOTO 151
      IER = 110
      GOTO 900
  110 J=J-1
      ZW = 0.D0
      DO 112 K=10,1,-9
      J=J+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 1100
      IF (IE.GT.0) IER = 151
      IF (IE.LT.0) IER = 152
      GOTO 900
 1100 ZZ = Z * DBLE(K)
      ZW = ZW + ZZ
      IF (ZW.LE.SZ) GOTO 111
      IER = 121
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     GOTO 900
  111 RADZ = RADZ + ZZ * SZ
      IF (J.GE.LCHA) GOTO 900
  112 CONTINUE
      A=A/SZ
  115 J=J+1
      IF (KCH(J).EQ.' ')  GOTO 115
      IF (KCH(J).EQ.'S')  GOTO 120
      IF (KCH(J).EQ.'.')  GOTO 150
      IF (KCH(J).EQ.'M')  GOTO 151
      IER = 120
      GOTO 900
  120 J=J-1
      ZW = 0.D0
      DO 122 K=10,1,-9
      J=J+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 1200
      IF (IE.GT.0) IER = 151
      IF (IE.LT.0) IER = 152
      GOTO 900
 1200 ZZ = Z * DBLE (K)
      ZW = ZW + ZZ
      IF (ZW.LE.SZ) GOTO 121
      IER = 131
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     GOTO 900
  121 RADZ = RADZ + Z * DBLE(K)
      IF (J.GE.LCHA) GOTO 900
  122 CONTINUE
      A=A/SZ
  123 J=J+1
      IF (KCH(J).EQ.'.') GOTO 150
      IF (KCH(J).EQ.'S') GOTO 151
      IF (KCH(J).EQ.' ') GOTO 123
      IER = 130
      GOTO 900
  150 J=J+1
  151 CONTINUE
      DO 152 K=J,LCHA
      CALL INPUT (CH(K),Z,IV,IE)
      IF (IE.EQ.0) GOTO 1520
      IF (IE.GT.0) IER = 91
      IF (IE.LT.0) IER = 92
      GOTO 900
 1520 RADZ = RADZ +A * Z/(10.D0**DBLE(K-J+1))
  152 CONTINUE
      GOTO 900
C *******************************************************************
C *****                                                             *
C *****                UMRECHNUNG VON GRAD                          *
C *****                                                             *
C *******************************************************************
  200 IVK=0
      IV =0
      J=0
      IVA=1
      N=0
      IF (KCH(LCHA).EQ.'X')     GOTO 270
      IF (KCH(1).EQ.'X')        GOTO 203
      IF (KCH(1).EQ.'D')        GOTO 203
      IF (CH(1).EQ.'-')      GOTO 201
      IF (CH(1).EQ.'&')      GOTO 202
      IF (CH(1).EQ.'+')      GOTO 202
      IF (CH(1).EQ.' ')      GOTO 202
      IER = 200
      GOTO 900
  201 IVA=-1
  202 J=J+1
  203 IF (KCH(2).EQ.'X') GOTO 401
      ZW = 0.D0
      DO 204 K=10,1,-9
      J=J+1
      N=N+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 2203
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 2203 IF(IVA.LT.0) GOTO 2204
      IF(K.EQ.10) IVA=IV
 2204 ZZ = Z * DBLE(K)
      ZW = ZW + ZZ
      IF (ZW.LE.90.D0) GOTO 204
      IER = 211
      GOTO 900
  204 RADZ = (RADZ + ZZ * 3600.D0)
      IF (J.GE.LCHA) GOTO 900
  205 CONTINUE
  206 J=J+1
      IF (KCH(J).EQ.' ')  GOTO 206
      IF (KCH(J).EQ.'M')  GOTO 210
      IF (KCH(J).EQ.'.')  GOTO 250
      IF (KCH(J).EQ.'D')  GOTO 251
      IF (KCH(J).EQ.'X')  GOTO 251
      IER = 210
      GOTO 900
  210 IF (KCH(J+1).EQ.'X') GOTO 411
      J=J-1
      ZW = 0.D0
      DO 212 K=10,1,-9
      J=J+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 2110
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 2110 ZZ = Z * DBLE(K)
      ZW = ZW + ZZ
      IF (ZW.LE.SZ) GOTO 211
      IER = 221
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     GOTO 900
  211 RADZ = RADZ + Z * DBLE(K) * SZ
      IF (J.GE.LCHA) GOTO 900
  212 CONTINUE
      A=A/SZ
  215 J=J+1
      IF (KCH(J).EQ.' ')  GOTO 215
      IF (KCH(J).EQ.'S')  GOTO 220
      IF (KCH(J).EQ.'.')  GOTO 250
      IF (KCH(J).EQ.'M')  GOTO 251
      IF (KCH(J).EQ.'X')  GOTO 251
      IER = 220
      GOTO 900
  220 IF (KCH(J+1).EQ.'X') GOTO 421
      J=J-1
      ZW = 0.D0
      DO 222 K=10,1,-9
      J=J+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 2200
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 2200 ZZ = Z * DBLE(K)
      ZW = ZW + ZZ
      IF (ZW.LE.SZ) GOTO 221
      IER = 231
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     GOTO 900
  221 RADZ = RADZ + Z * DBLE(K)
      IF (J.GE.LCHA) GOTO 900
  222 CONTINUE
      A=A/SZ
  223 J=J+1
      IF(KCH(J).EQ.'.')  GOTO 250
      IF(KCH(J).EQ.'S')  GOTO 251
      IF(KCH(J).EQ.' ')  GOTO 223
      IF(KCH(J).EQ.'X')  GOTO 251
      IER = 230
      GOTO 900
  250 J=J+1
  251 J1 = LCHA
      IF (IVK.NE.1)  GOTO 252
      J1 = J1-1
      RADZ = RADZ + A * B/(10.D0**DBLE(LCHA-J+1))
  252 IF (J.GT.J1) GOTO 900
      DO 253 K=J,J1
      CALL INPUT (CH(K),Z,IV,IE)
      IF (IE.EQ.0) GOTO 2520
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 2520 RADZ = RADZ + A * Z/(10.D0** DBLE(K-J+1))
  253 CONTINUE
      GOTO 900
  270 IVK=1
      CALL INPUT (CH(LCHA),Z,IV,IE)
      IF (IE.EQ.0) GOTO 2700
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 2700 B=Z
      IVA=IV
      GOTO 203
  401 CALL INPUT(CH(1),Z,IV,IE)
      IF (IE.EQ.0) GOTO 4010
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 4010 ZW=10.D0*Z
      IF (ZW.LE.90.D0) GOTO 402
      IER = 211
      GOTO 900
  402 RADZ = RADZ + Z * 36000.D0 + B * 3600.D0
      GOTO 900
  411 CALL INPUT(CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 4110
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 4110 ZW=10.D0*Z
      IF (ZW.LE.SZ) GOTO 412
      IER = 221
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     GOTO 900
  412 RADZ = RADZ + Z * 600.D0 + B * SZ
      GOTO 900
  421 CALL INPUT(CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 4210
      IF (IE.GT.0) IER = 251
      IF (IE.LT.0) IER = 252
      GOTO 900
 4210 ZW=10.D0*Z
      IF (ZW.LE.SZ) GOTO 422
      IER = 231
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     go to 900
  422 RADZ = RADZ + Z * 10.D0 + B
      GOTO 900
C *******************************************************************
C *****                                                             *
C *****              UMRECHNUNG VON GAL.LAENGE                      *
C *****                                                             *
C *******************************************************************
  300 J=1
      IVA=1
      IF(CH(1).EQ.'-') IVA=-1
      ZW=0.D0
      DO 302 K=2,0,-1
      J=J+1
      CALL INPUT(CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 3000
      IF (IE.GT.0) IER = 351
      IF (IE.LT.0) IER = 352
      GOTO 900
 3000 ZZ=Z*10.D0**DBLE(K)
      ZW=ZW+ZZ
      IF (ZZ.LE.360.D0) GOTO 301
      IER = 311
      GOTO 900
  301 RADZ=RADZ+ZZ*3600.D0
      IF (J.GE.LCHA) GOTO 900
  302 CONTINUE
  303 J=J+1
      IF (KCH(J).EQ.' ') GOTO 303
      IF (KCH(J).EQ.'M') GOTO 310
      IF (KCH(J).EQ.'.') GOTO 350
      IF (KCH(J).EQ.'L') GOTO 351
      IER = 310
      GOTO 900
  310 J=J-1
      ZW = 0.D0
      DO 312 K=10,1,-9
      J=J+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 3100
      IF (IE.GT.0) IER = 351
      IF (IE.LT.0) IER = 352
      GOTO 900
 3100 ZZ = Z * DBLE(K)
      ZW = ZW + ZZ
      IF (ZW.LE.SZ) GOTO 311
      IER = 321
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     GOTO 900
  311 RADZ = RADZ + ZZ * SZ
      IF (J.GE.LCHA) GOTO 900
  312 CONTINUE
      A=A/SZ
  315 J=J+1
      IF (KCH(J).EQ.' ')  GOTO 315
      IF (KCH(J).EQ.'S')  GOTO 320
      IF (KCH(J).EQ.'.')  GOTO 350
      IF (KCH(J).EQ.'M')  GOTO 351
      IER = 320
      GOTO 900
  320 J=J-1
      ZW = 0.D0
      DO 322 K=10,1,-9
      J=J+1
      CALL INPUT (CH(J),Z,IV,IE)
      IF (IE.EQ.0) GOTO 3200
      IF (IE.GT.0) IER = 351
      IF (IE.LT.0) IER = 352
      GOTO 900
 3200 ZZ = Z * DBLE (K)
      ZW = ZW + ZZ
      IF (ZW.LE.SZ) GOTO 321
      IER = 331
      WRITE (LUNERR,1111) CHA,IER,FORMAT
C
      print *, text0
C
C     GOTO 900
  321 RADZ = RADZ + Z * DBLE(K)
      IF (J.GE.LCHA) GOTO 900
  322 CONTINUE
      A=A/SZ
  323 J=J+1
      IF (KCH(J).EQ.'.') GOTO 350
      IF (KCH(J).EQ.'S') GOTO 351
      IF (KCH(J).EQ.' ') GOTO 323
      IER = 330
      GOTO 900
  350 J=J+1
  351 CONTINUE
      DO 352 K=J,LCHA
      CALL INPUT (CH(K),Z,IV,IE)
      IF (IE.EQ.0) GOTO 3510
      IF (IE.GT.0) IER = 351
      IF (IE.LT.0) IER = 352
      GOTO 900
 3510 RADZ = RADZ +A * Z/(10.D0**DBLE(K-J+1))
  352 CONTINUE
      GOTO 900
  900 CONTINUE
      IF (IER.EQ.0) GOTO 910
      IF (IER.EQ.121) GOTO 910
      IF (IER.EQ.131) GOTO 910
      IF (IER.EQ.221) GOTO 910
      IF (IER.EQ.231) GOTO 910
      WRITE (LUNERR,1111) CHA,IER,FORMAT
 1111 FORMAT (//, 'FEHLER AUFGETRETEN BEI UMRECHNUNG VON'/
     *1X,A,' IN RAD. FEHLERMELDUNG = ',I3/1X,A)
C
      write(ierstr,'(i3)')ier
C
      if(ier.eq.99)then
         print *, text3
         print *, text4
         print *, text8
         print *, text5
      end if
C
       if(ierstr(3:3).eq.'0')then
         print *, text6
         print *, text7
      else
          if(ier.gt.100)then
            print *, text1
            print *, text2
         end if
      end if
C
      RAD = 0.D0
      GOTO 920
  910 RAD = ( RADZ / 3600.D0 ) * RA * ( PI / 180.D0)
      IF (IVA.EQ.-1) RAD=-RAD
  920 CONTINUE
      RETURN
      END

C *******************************************************************
C *****                                                             *
C *****          UNTERPROGRAMM : INPUT                              *
C *****                                                             *
C *****   UMWANDLUNG EINER CHARCTERGROESSE IN EINE REALGROESSE      *
C *****                                                             *
C *******************************************************************
C *****                                                             *
C *****   AUFGERUFEN WIRD DAS UNTERPROGRAMM MIT                     *
C *****                                                             *
C *****    CALL INPUT(C,R,IV,IE)                                    *
C *****                                                             *
C *****    WOBEI BEDEUTEN                                           *
C *****    C   =   CHARACTERGROESSE                A*1  EINGABE     *
C *****    R   =   REALGROESSE (DOPPELTGENAU)      R*8  AUSGABE     *
C *****    IV  =   VORZEICHEN                      A*1  AUSGABE     *
C *****            WIRD DURCH INPUT NUR GEAENDERT, WENN EINE        *
C *****            ENTSPRECHENDE UEBERLOCHUNG VORLIEGT              *
C *****    IE  =   FEHLERMELDUNG                   I1   AUSGABE     *
C *****            =  1   WENN   C   NICHT MIT DEM VORGEGEBENEN     *
C *****                   ZEICHENSATZ  UEBEREINSTIMMT               *
C *****                   BEWIRKT, DASS   IER = 301                 *
C *****            = -1   WENN   C  =  '.' (PUNKT)                  *
C *****                   BEWIRKT, DASS   IER = 311                 *
C *****                                                             *
C *******************************************************************
      SUBROUTINE INPUT(C,Z,IV,IE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*1 C,IZI(10),IBUP(10),IBUN(10)
      DATA IZI/'0','1','2','3','4','5','6','7','8','9'/
      DATA IBUN/ '}','J','K','L','M','N','O','P','Q','R'/
      DATA IBUP/ '{','A','B','C','D','E','F','G','H','I'/
      IV =1
      IE = 0
      IF (C.NE.' ') GOTO 9
      I=1
      GOTO 21
    9 CONTINUE
      DO 10 I=1,10
      IF (C.EQ.IZI(I))   GOTO 21
      IF (C.EQ.IBUP(I))  GOTO 21
      IF (C.EQ.IBUN(I))  GOTO 20
   10 CONTINUE
      IE = 1
      IF  (C.EQ.'.')     IE=-1
      Z = 0.D0
      GOTO 22
   20 IV=-1
   21 Z = DBLE(I-1)
   22 CONTINUE
      RETURN
      END
! Gemeinsame Definitionen fuer die Korrekturgeschichten
! (loadcor.f und applycor.f)
c
c     integer*4 prounit,flgsz !siehe unten
c     integer*2 korsz
c
c     parameter (prounit=1001) !unit, in die das Protokoll geschrieben wird
c     parameter (korsz=2000) ! Maximale Zahl von Korrekturen
c     parameter (flgsz=6300000)
!flgsz ist die Groesse des Flagfeldes, eines Feldes, mit dessen Hilfe
!schnell festgestellt werden kann, ob eine Korrektur fuer den betreffenden
!Stern vorliegt oder nicht. Mit dem gegebenen Parameter lassen
!sich alle fuenfstelligen Katalognummern verarbeiten.
c
c     type t_cor ! beschreibt eine Korrektur (vgl. docs/korrektur.doc)
c      sequence
c      real*8    realval ! Neuer Wert fuer XSTAR
c      integer*4 catcn   ! Katalognummer
c      integer*2 dest    ! nii, wo n=1..7, ii Feldindex
c      integer*2 app     ! appendix
c      integer*4 intval  ! Neuer Wert fuer ISTAR und KENNX
c      character*8 bem   ! Erste acht Zeichen einer evtl. Bemerkung
c     end type
c
c     type t_cordata ! Korrekturen fuer Katalog
c      sequence
c      type (t_cor)  cors(korsz) !Feld fuer Korrekturen
c      integer*2 korflags(flgsz) ! bitfeld, in dem fuer jeden zu korrigierenden
			    ! Stern das Bit catcn gesetzt ist
c      integer*2 nokor ! Gesamtzahl der Korrekturen
c      integer*2 hasapp !1, wenn Appendices zu beruecksichtigen, 0 sonst
c     end type
c
c
      SUBROUTINE DATA(DONE)
	 PARAMETER (NRFILE=14)
      LOGICAL*4 EX
	 INTEGER I,J,NRUNIT(NRFILE),POS1,POS2
	 CHARACTER*72 FNAME(NRFILE),STR*72
	 LOGICAL DONE

       DATA (NRUNIT(I),I=1,NRFILE) /11,21,22,23,24,25,26,27,28,29,30,31
     &	   ,32,33/
	 DONE = .FALSE.
C      STR = '/work/Her/Arigfh/s07/ari/'
ccc    STR = '/work/Crux2/Arigfh/s07/ari/'
ccc
       STR = '../refcats/'
ccc
	 CALL SEEK(STR,1,POS1,POS2)
C HIER WERDEN  DIE DATEIEN FUER REFERENZKATALOGE ZUR VERFUEGUNG GESTELLT
	 FNAME(1) = STR(POS1:POS2)//'fk5pext'
	 FNAME(2) = STR(POS1:POS2)//'fk4psup'
	 FNAME(3) = STR(POS1:POS2)//'fk3o4000'
	 FNAME(4) = STR(POS1:POS2)//'nfk'
	 FNAME(5) = STR(POS1:POS2)//'gc'
	 FNAME(6) = STR(POS1:POS2)//'fk3r'
	 FNAME(7) = STR(POS1:POS2)//'pfksz'
	 FNAME(8) = STR(POS1:POS2)//'fk3m4000'
	 FNAME(9) = STR(POS1:POS2)//'eichel'
	 FNAME(10) = STR(POS1:POS2)//'nfkav'
	 FNAME(11) = STR(POS1:POS2)//'pgc'
	 FNAME(12) = STR(POS1:POS2)//'newcomb'
	 FNAME(13) = STR(POS1:POS2)//'erosref'
      FNAME(14) = STR(POS1:POS2)//'ksv'
      DO I = 1,NRFILE
	 CALL FILEOP(NRUNIT(I),FNAME(I),'F',EX)
	 END DO
	 DONE = .TRUE.
	 END
C
C     DIESE SUBROUTINE CONVERTIERT DIE BISHERIGEN
C     DOPPELSTERNCODES IN DAS NEUE DS-SYSTEM.
C
      SUBROUTINE DSCONV (DATSANA,SP1,SP2,IDSNEU,IERR)
C-------------------------------------------------------
C       D E F I N I T I O N
C---------------------------------------------------------
      INTEGER SP1,SP2,DN1,DN2,DN3,S
      INTEGER*2 IDSNEU
      CHARACTER DATSANA*(*)
C IN SP1 UND SP2 SIND DIE SPALTEN IN DENEN DIE
C DOPPELSTERNCODES LAUT FORMAT EINGEGEBEN WURDEN.
C WENN SP2 LEER IST WIRD ANBENOMMEN DASS ES NUR EINE
C SPALTE (SP1) ALS DS-CODE GIBT. SP2 MUSS GROESSER SP1 SEIN.
      S=1
C S IST EIN ZAEHLER FUER DIE DO-SCHLEIFE
C SOLL.
      DN1=0
      DN3=0
      DN2=0
C DN1-DN3 BEINHALTEN DIE UMGEWANDELTEN WERTE DER DOPPELSTERN-CODES
      IERR=0
      IDSNEU=0
C------------------------------------------------------
C    P R U E F E N AUF RICHTIGKEIT DER WERTE
C-----------------------------------------------------------------------
      IF ((SP1.LT.1) .OR. (SP1 .GT. 80)) THEN
         IERR=1
      ELSE IF ((SP2.LT.1) .OR. (SP2 .GT. 80)) THEN
         IERR=1
      ENDIF
      IF (IERR .NE. 0) THEN
         WRITE(*,'('' '',A)')'FALSCHE SPALTENANGABE '
         GOTO 289
      ENDIF
C-----------------------------------------------------------
C P R O G R A M M
C------------------------------------------------------------
C   S C H L E I F E  UM DOSTERN-SPALTEN AUS FORMAT IN DIE WERTE DN1-DN3
C                    ZU UEBERTRAGEN.
C---------------------------------------------------------------------
      DO 279 S = SP1,SP2
         IF (DATSANA(S:S).EQ. '1') THEN
            DN3=1
         ELSE IF (DATSANA(S:S) .EQ. '2') THEN
            DN3=2
         ELSE IF (DATSANA(S:S) .EQ. '3') THEN
            DN1=1
         ELSE IF (DATSANA(S:S) .EQ. '4') THEN
            DN1=2
         ELSE IF (DATSANA(S:S) .EQ. '5') THEN
            DN2=1
         ELSE IF (DATSANA(S:S) .EQ. '6') THEN
            DN2=2
         ELSE IF (DATSANA(S:S) .EQ. '7') THEN
            DN3=87
         ELSE IF (DATSANA(S:S) .EQ. '8') THEN
            DN3=88
         ELSE IF (DATSANA(S:S) .EQ. '9') THEN
            DN3=89
         ELSE IF (DATSANA(S:S) .EQ. '0') THEN
            DN3=80
         ELSE IF (DATSANA(S:S) .EQ. '-') THEN
            DN3=90
         ELSE IF (DATSANA(S:S) .NE. ' ') THEN
            IERR = 0815
            WRITE(*,'('' '',A,I10)')'FALSCHER DOPPELSTERNCODE ',
     !DATSANA(S:S)
         ENDIF
 279  CONTINUE
C-----------------------------------------------------
C    F O R M E L  UM DEN NEUEN DOPPELSTERNCODE ZU ERHALTEN
C----------------------------------------------------------
      IDSNEU=(1000*DN1)+(100*DN2)+DN3
C     WRITE(*,'('' '',A,I10)')'DN1=',DN1
C     WRITE(*,'('' '',A,I10)')'DN2=',DN2
C     WRITE(*,'('' '',A,I10)')'DN3=',DN3
C     WRITE(*,'('' '',A,A)')'DATSANA=',DATSANA
289   RETURN
      END
        SUBROUTINE FILEOP(UNITNR,DATANAM,FFORM,EX)
        INTEGER I,J,K,UNITNR,POS1,POS2
        CHARACTER*(*) DATANAM,FFORM*1
        LOGICAL EX
        EX = .FALSE.
        CALL SEEK(DATANAM,1,POS1,POS2)
        INQUIRE (FILE=DATANAM(POS1:POS2),EXIST=EX)
        IF (FFORM .EQ. 'F') THEN
                IF (EX .EQV. .TRUE.) THEN
                OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='OLD',
     &            FORM='FORMATTED')
                ELSE
                OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='NEW',
     &            FORM='FORMATTED')
                END IF
        ELSE
                IF (EX .EQV. .TRUE.) THEN
                OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='OLD',
     &            FORM='UNFORMATTED')
                ELSE
                OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='NEW',
     &            FORM='UNFORMATTED')
                END IF
        END IF
        END
        SUBROUTINE FILEOPDA(UNITNR,DATANAM,FFORM,LREC,EX)
        INTEGER I,J,K,UNITNR,POS1,POS2,LREC
        CHARACTER*(*) DATANAM,FFORM*1
        LOGICAL EX
        EX = .FALSE.
        CALL SEEK(DATANAM,1,POS1,POS2)
        INQUIRE (FILE=DATANAM(POS1:POS2),EXIST=EX)
        IF (FFORM .EQ. 'F') THEN
                IF (EX .EQV. .TRUE.) THEN
        OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='OLD',
     &            ACCESS= 'DIRECT',RECL=LREC,FORM='FORMATTED',
     &            CONVERT='BIG_ENDIAN')
                ELSE
        OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='NEW',
     &            ACCESS= 'DIRECT',RECL=LREC,FORM='FORMATTED',
     &            CONVERT='BIG_ENDIAN')
                END IF
        ELSE
                IF (EX .EQV. .TRUE.) THEN
        OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='OLD',
     &            ACCESS= 'DIRECT',RECL=LREC,FORM='UNFORMATTED',
     &            CONVERT='BIG_ENDIAN')
                ELSE
        OPEN(UNITNR,FILE=DATANAM(POS1:POS2),STATUS='NEW',
     &            ACCESS= 'DIRECT',RECL=LREC,FORM='UNFORMATTED',
     &            CONVERT='BIG_ENDIAN')
                END IF
        END IF
c
c     write(*,*)  'Habe geoeffnet',datanam(pos1:pos2)
c
        END
        SUBROUTINE IDCREATE(NINDEX,DATNAM1,DATNAM2,NTOT)
        INTEGER NINDEX(NTOT),I,IST4(10),K
        INTEGER*2 IST2(30)
        REAL*8 XST8(20)
        REAL*4 XST4(15)
        integer*4 kennx8(20), kennx4(15)
        CHARACTER*(*) DATNAM1,DATNAM2
      LOGICAL*4 EX

        CALL FILEOPDA(9,DATNAM1,'U',320,EX)
        CALL FILEOP(10,DATNAM2,'U',EX)
cc    write(*,*) 'Datei DATNAM1 = ',datnam1,'  auf Einheit 9'
cc    write(*,*) 'Datei DATNAM2 = ',datnam2,'  auf Einheit 10'

        DO K = 1,NTOT
       READ(9,REC=NINDEX(K))(XST8(I),I=1,14),
     & (KENNX8(I), I=1,12),
     & (XST4(I),I=1,9),
     & (KENNX4(I),I=1,6),
     & (IST4(I),I=1,2),
     & (KENNX8(I),I=13,14),
     & (KENNX4(I),I=7,12),
     & (IST2(I),I=1,30)
       WRITE(10) (XST8(I),I=1,14),
     & (KENNX8(I), I=1,12),
     & (XST4(I),I=1,9),
     & (KENNX4(I),I=1,6),
     & (IST4(I),I=1,2),
     & (KENNX8(I),I=13,14),
     & (KENNX4(I),I=7,12),
     & (IST2(I),I=1,30)
ccc     WRITE(*,*) ist4(1),ist4(2),XST8(6)
ccc     read (*,'(i1)') iii
        END DO
      CLOSE(9,STATUS='DELETE')
        CLOSE(10)
        END
C Kanal 3 kommt aus MAINID und wurde dort mit id?.id belegt
        SUBROUTINE IDCREATE2(NINDEX,DATNAM1,DATNAM2,NTOT)
        PARAMETER (NSTAR=612627)
        INTEGER NINDEX(3000000),NTOT,arinr,catc
        CHARACTER*(*) DATNAM1,DATNAM2,STR*34
        COMMON /headlen/ headlen
        integer headlen
        character*34 hdstr
        LOGICAL*4 EX

      CALL FILEOPDA(8,DATNAM1,'U',34,EX)
      CALL FILEOP(12,DATNAM2,'U',EX)
          rewind(3)
          do i=1,headlen
           read(3) hdstr
      end do
      i = 0
      DO K = 1,NTOT
           read(3,end=10) str
           write(8,rec=k) str
       i = i + 1
      END DO
 10     continue
        DO K = 1,NTOT
       READ(8,REC=NINDEX(K)) STR
          IF (K .LT. 20) THEN
              READ(STR(9:12),'(A4)') ARINR
              READ(STR(27:30),'(A4)') CATC
           PRINT*,ARINR,' ',CATC
          END IF
        WRITE(12) STR
 100    END DO
      CLOSE(8,STATUS='DELETE')
        CLOSE(12)
      CLOSE(3,status='delete')
        END

      SUBROUTINE LISTMAKE(XINDEX,NINDEX,STRI)
      INTEGER NSTAR
      PARAMETER (NSTAR = 612627)
      INTEGER   POS1,POS2,NINDEX(3000000)
      REAL*8    ALFA,DELTA,RET
      REAL*8    PMA,PMD,EPOSTART,EPOZIEL
      REAL*8    AEQUZIEL,AEQUSTART,TDIFF
      REAL*8    MUALF,MUDEL,EPO
      REAL*8    XMTX(3,3),XINDEX(3000000)
      REAL*8    AEQJDA,AEQJDZ,EPJDA,EPJDZ
      REAL*8    PHI,THETA,ZETA
        REAL*4    MV,MB
      CHARACTER*72 STR*45,STRI(34),KOMP*1
      LOGICAL   EX
      COMMON /MATRIX/ XMTX
      COMMON /YEAR/ EPO
ccc   character*39 mastername     ! Her oder And
ccc   character*41 mastername     ! Crux2
ccc   character*40 mastername     ! Tuc5
      character*72 mastername     !  mod. am 17.2.05
      common /mastername/ mastername

      IZ = 0
      AEQUSTART= 2000.D0
      EPOSTART= 2000.D0
c
ccc   Das folgende war die Oeffnung des UNIX-Masters
c
c      CALL FILEOPDA(2,mastername,'U',45,EX)
c
c
ccc   Das folgende ist die Oeffnung des LINUX-Masters
c
      CALL FILEOPDA(2,mastername,'U',45,EX)
c
C      CALL READALL(STRI)
C      CALL SEEK(STRI(25),17,POS1,POS2)
C      CALL FILEOP(2,'/home/Boo/heiko/ari/'//STRI(25)(POS1:POS2),'U',EX)
      CALL SEEK(STRI(29),17,POS1,POS2)
      READ (STRI(29)(POS1:POS2),'(F6.1)') EPOZIEL
        EPO = EPOZIEL
      CALL SEEK(STRI(28),17,POS1,POS2)
      READ (STRI(28)(POS1:POS2),'(F6.1)') AEQUZIEL
      PRINT*, 'Master wird auf',EPOZIEL,AEQUZIEL,'transformiert'
      CALL BEJD(AEQUSTART,AEQJDA)
      CALL BEJD(AEQUZIEL,AEQJDZ)
C CREATING MATRIX XMTX FOR CHANGING Of EQUINOX
      CALL KSTPRZ(AEQJDA,AEQJDZ,PHI,THETA,ZETA)
      CALL PRZMTX(PHI,THETA,ZETA,XMTX)
C TRANSFORMING ALFA,DELTA AND MYS TO NEW EPOCHS AND EQUINOXES
        DO I = 1,NSTAR
           READ(2,REC=I) NR,DELTA,ALFA,MUDEL,MUALF,MV,MB,KOMP
           CALL TRANSF(EPOSTART,EPOZIEL,XMTX,ALFA,DELTA,
     &                    MUALF,MUDEL)
         XINDEX(I) = DELTA
         NINDEX(I) = I
        END DO
C       print*,xmtx(1,1),xmtx(2,2),xmtx(3,3)
      CLOSE(2)
      END
      SUBROUTINE  POLDEC(IVERS,IPG,IPM,PS,DEC)
C
C     UMRECHNUNG VON POLDISTANZEN IN DEKLINATION
C
C     EINGABE:
C
C     IVERS = 1:  ES SIND NOERDLICHE POLDISTANZEN GEGEBEN
C     IVERS = 2:  ES SIND SUEDLICHE  POLDISTANZEN GEGEBEN
C
C     IPG:  ANZAHL DER GRAD          DER POLDISTANZ
C     IPM:  ANZAHL DER BOGENMINUTEN  DER POLDISTANZ
C     PS :  ANZAHL DER BOGENSEKUNDEN DER POLDISTANZ
C
C     AUSGABE:
C
C     DEC:  DEKLINATION IN RADIAN
C--------------------------------------------------------------------
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      TRD = 1.745329251994329D-02
C
C     POLDISTANZ ALS DEZIMALZAHL UMWANDELN
C
      PDIST = IPG + IPM/60.D0 + PS/3600.D0
C
C     UMRECHNUNG IN DEKLINATION
C
      DEC = 90.D0 - PDIST
      IF (IVERS.EQ.2)  DEC = -DEC
C
C     WRITE(6,2525) IPG,IPM,PS,PDIST,DEC
C2525 FORMAT(1X,2I3,F6.2,2F15.8)
C
C     UMRECHNUNG IN RADIAN
C
      DEC = DEC*TRD
      RETURN
      END
C********************************************************************
      SUBROUTINE RADCHA(RADX,C2_ARG,CWERT,IER,LUNERR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*(*) C2_ARG,CWERT
      CHARACTER*10 CBT
      CHARACTER*1 CHR(20),CZ(4)
      CHARACTER*2 CH,CM,CS,CD,CV
			CHARACTER*80 C2
      DATA CZ/' ','1','2','3'/
      C2=C2_ARG
      ILE1= LEN(C2_ARG)
      ILE2= LEN(CWERT)
C Erstmal den Formatstring auf Grossbuchstaben bringen
      do i=1,ile1
       call upcase(c2(i:i))
      end do
      RAD=RADX
      IE1=0
      INULF=0
      DO 99 I=ILE1,1,-1
      IF (C2(I:I).NE.' ') GOTO 98
   99 CONTINUE
      IER=90
      GOTO 900
   98 LAE=I
      IF (C2(I:I).NE.'F') GOTO 97
      LAE=I-1
      INULF=1
   97 CONTINUE
      IF (C2(ILE1:ILE1).EQ.'F') ILE1 = ILE1 - 1
      IF(ILE1.NE.ILE2) THEN
      IER = 93
      GOTO 900
      END IF
      DO 96 I=1,ILE2
      CWERT(I:I)=' '
      CHR(I)=' '
   96 CONTINUE
      DO 95 I=1,LAE
      CHR(I)=C2(I:I)
   95 CONTINUE
      RA=1.
      PI = 3.1415926535897932D0
      IER=0
      IVA=1
      IH=0
      IRUND=0
      K1=0
      IF (RAD.LT.0.D0) IVA=-1
      RAD = RAD * IVA
      IF (CHR(2).EQ.'H') IH=1
      IF (CHR(1).EQ.'T') IH=1
      IF (CHR(2).EQ.'T') IH=1
      IF (IH.EQ.1) GOTO 50
C********************************************************************
C
C
C
C********************************************************************
      R1=RAD*180.D0/PI
      RD=DINT(R1)
      RDB=R1-RD
      R2=RDB*60.D0
      RM=DINT(R2)
      RMB=R2-RM
      R3=RMB*60.D0
      RS=DINT(R3)
      RSB=R3-RS
      IF (RS.LT.60.D0) GOTO 41
      RS=RS-60.D0
      RM=RM+1.D0
   41 IF (RM.LT.60.D0) GOTO 42
      RM=RM-60.D0
      RD=RD+1.D0
   42 IF (CHR(2).EQ.'M') GOTO 60
      IF (CHR(2).EQ.'A') GOTO 60
      IF (CHR(2).EQ.'L' .AND. RD.LT.360.D0) GOTO 60
      IF (CHR(2).EQ.'D' .AND. RD.LT.90.D0) GOTO 60
      IF (CHR(2).EQ.'L')  RD=RD-360.D0
      IF (CHR(2).EQ.'D')  RD=RD-90.D0
      GOTO 42
C********************************************************************
C
C
C
C********************************************************************
   50 R1=RAD*180.D0/(PI*15.D0)
      RH=DINT(R1)
      RHB=R1-RH
      R2=RHB*60.D0
      RM=DINT(R2)
      RMB=R2-RM
      R3=RMB*60.D0
      RS=DINT(R3)
      RSB=R3-RS
      IF (RS.LT.60.D0) GOTO 51
      RS=RS-60.D0
      RM=RM+1.D0
   51 IF (RM.LT.60.D0) GOTO 52
      RM=RM-60.D0
      RH=RH+1.D0
   52 IF (RH.LT.24.D0) GOTO 60
      RH=RH-24.D0
      GOTO 52
C********************************************************************
C
C
C
C********************************************************************
   60 IF (CHR(1).EQ.'H') GOTO 100
      IF (CHR(2).EQ.'D') GOTO 200
      IF (CHR(2).EQ.'L') GOTO 500
      IF (CHR(2).EQ.'T') GOTO 600
      IF (CHR(2).EQ.'A') GOTO 700
      IF (CHR(2).EQ.'M') GOTO 700
C********************************************************************
C
C
C
C********************************************************************
  100 IE1=0
      IF (INULF.EQ.1) GOTO 180
      CALL INPUT1(RH,CH,IE)
      IE1=IE1+IE
      CALL INPUT1(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT1(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 190
      IER=101
      GOTO 900
  180 CALL INPUT2(RH,CH,IE)
      IE1=IE1+IE
      CALL INPUT2(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT2(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 190
      IER=102
      GOTO 900
  190 CWERT(1:2)=CH
      J=2
  101 J=J+1
      IF (J.GT.LAE) GOTO 401
      IF (CHR(J).NE.' ') GOTO 102
      CWERT(J:J)=' '
      GOTO 101
  102 IF (CHR(J).NE.'M') GOTO 110
C     CWERT=CWERT//CM
      J1=J
      J2=J+1
      CWERT(J1:J2)=CM
      J=J+1
  103 J=J+1
      IF (J.GT.LAE) GOTO 402
      IF (CHR(J).NE.' ') GOTO 104
      CWERT(J:J)=' '
      GOTO 103
  104 IF (CHR(J).NE.'S') GOTO 120
      J1=J
      J2=J+1
      CWERT(J1:J2)=CS
      J=J+1
C     J=J+2
      IF (J.GT.LAE) GOTO 403
  105 J=J+1
      IF (J.GT.LAE) GOTO 403
      IF (CHR(J).NE.' ') GOTO 130
      CWERT(J:J)=' '
      GOTO 105
  110 IF (CHR(J).NE.'.') GOTO 112
      CWERT(J:J)='.'
  111 J=J+1
      IF (J.GT.LAE) GOTO 401
      IF (CHR(J).NE.' ') GOTO 112
      CWERT(J:J)=' '
      GOTO 111
  112 IF (CHR(J).NE.'H') GOTO 113
      BT=RHB
      K1=1
      GOTO 350
  113 IF (CHR(J).NE.' ') GOTO 114
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 401
      GOTO 112
  114 IER=111
      GOTO 900
  120 IF (CHR(J).NE.'.') GOTO 122
      CWERT(J:J)='.'
  121 J=J+1
      IF (J.GT.LAE) GOTO 402
      IF (CHR(J).NE.' ') GOTO 122
      CWERT(J:J)=' '
      GOTO 121
  122 IF (CHR(J).NE.'M') GOTO 123
      BT=RMB
      K1=2
      GOTO 350
  123 IF (CHR(J).NE.' ') GOTO 124
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 402
      GOTO 122
  124 IER=121
      GOTO 900
  130 IF (CHR(J).NE.'.') GOTO 132
      CWERT(J:J)='.'
  131 J=J+1
      IF (J.GT.LAE) GOTO 403
      IF (CHR(J).NE.' ') GOTO 132
      CWERT(J:J)=' '
      GOTO 131
  132 IF (CHR(J).NE.'S') GOTO 133
      BT=RSB
      K1=3
      GOTO 350
  133 IF (CHR(J).NE.' ') GOTO 134
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 403
      GOTO 132
  134 IER=131
      GOTO 900
C********************************************************************
C
C
C
C********************************************************************
  200 IE1=0
      IF (INULF.EQ.1) GOTO 280
      CALL INPUT1(RD,CD,IE)
      IE1=IE1+IE
      CALL INPUT1(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT1(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 290
      IER=201
      GOTO 900
  280 CALL INPUT2(RD,CD,IE)
      IE1=IE1+IE
      CALL INPUT2(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT2(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 290
      IER=202
      GOTO 900
  290 CWERT(2:3)=CD
      J=3
  201 J=J+1
      IF (J.GT.LAE) GOTO 411
      IF (CHR(J).NE.' ') GOTO 202
      CWERT(J:J)=' '
      GOTO 201
  202 IF (CHR(J).NE.'M') GOTO 210
      J1=J
      J2=J+1
      CWERT(J1:J2)=CM
      J=J+1
  203 J=J+1
      IF (J.GT.LAE) GOTO 412
      IF (CHR(J).NE.' ') GOTO 204
      CWERT(J:J)=' '
      GOTO 203
  204 IF (CHR(J).NE.'S') GOTO 220
      J1=J
      J2=J+1
      CWERT(J1:J2)=CS
      J=J+1
      IF (J.GT.LAE) GOTO 413
  205 J=J+1
      IF (J.GT.LAE) GOTO 413
      IF (CHR(J).NE.' ') GOTO 230
      CWERT(J:J)=' '
      GOTO 205
  210 IF (CHR(J).NE.'.') GOTO 212
      CWERT(J:J)='.'
  211 J=J+1
      IF (J.GT.LAE) GOTO 411
      IF (CHR(J).NE.' ') GOTO 212
      CWERT(J:J)=' '
      GOTO 211
  212 IF (CHR(J).NE.'D') GOTO 213
      BT=RDB
      K1=4
      GOTO 350
  213 IF (CHR(J).NE.' ') GOTO 214
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 411
      GOTO 212
  214 IER=211
      GOTO 900
  220 IF (CHR(J).NE.'.') GOTO 222
      CWERT(J:J)='.'
  221 J=J+1
      IF (J.GT.LAE) GOTO 412
      IF (CHR(J).NE.' ') GOTO 222
      CWERT(J:J)=' '
      GOTO 221
  222 IF (CHR(J).NE.'M') GOTO 223
      BT=RMB
      K1=5
      GOTO 350
  223 IF (CHR(J).NE.' ') GOTO 224
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 412
      GOTO 222
  224 IER=221
      GOTO 900
  230 IF (CHR(J).NE.'.') GOTO 232
      CWERT(J:J)='.'
  231 J=J+1
      IF (J.GT.LAE) GOTO 413
      IF (CHR(J).NE.' ') GOTO 232
      CWERT(J:J)=' '
      GOTO 231
  232 IF (CHR(J).NE.'S') GOTO 233
      BT=RSB
      K1=6
      GOTO 350
  233 IF (CHR(J).NE.' ') GOTO 234
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 413
      GOTO 232
  234 IER=231
      GOTO 900
C********************************************************************
C
C
C
C********************************************************************
  500 IE1=0
      IF (RD.LT.360.D0) GOTO 591
      RD=RD-360.D0
      GOTO 500
  591 RD1=DINT(RD/100.D0)
      RD2=RD-RD1*100.D0
      IF (INULF.EQ.1) GOTO 580
      CALL INPUT1(RD2,CD,IE)
      IE1=IE1+IE
      CALL INPUT1(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT1(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 590
      IER=301
      GOTO 900
  580 CALL INPUT2(RD2,CD,IE)
      IE1=IE1+IE
      CALL INPUT2(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT2(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 590
      IER=302
      GOTO 900
  590 CONTINUE
      DO 599 I=0,3
      IF (RD1.EQ.DBLE(I)) GOTO 598
  599 CONTINUE
      IER=301
      GOTO 900
  598 CWERT(2:2)=CZ(I+1)
      CWERT(3:4)=CD
      IF (CWERT(2:2).NE.' '.AND.CWERT(3:3).EQ.' ') CWERT(3:3)='0'
      IF (INULF.NE.1) GOTO 597
      IF (CWERT(2:2).EQ.' ') CWERT(2:2)='0'
      IF (CWERT(3:3).EQ.' ') CWERT(3:3)='0'
  597 J=4
  501 J=J+1
      IF (J.GT.LAE) GOTO 421
      IF (CHR(J).NE.' ') GOTO 502
      CWERT(J:J)=' '
      GOTO 501
  502 IF (CHR(J).NE.'M') GOTO 510
      J1=J
      J2=J+1
      CWERT(J1:J2)=CM
      J=J+1
  503 J=J+1
      IF (J.GT.LAE) GOTO 422
      IF (CHR(J).NE.' ') GOTO 504
      CWERT(J:J)=' '
      GOTO 503
  504 IF (CHR(J).NE.'S') GOTO 520
      J1=J
      J2=J+1
      CWERT(J1:J2)=CS
      J=J+1
      IF (J.GT.LAE) GOTO 423
  505 J=J+1
      IF (J.GT.LAE) GOTO 423
      IF (CHR(J).NE.' ') GOTO 530
      CWERT(J:J)=' '
      GOTO 505
  510 IF (CHR(J).NE.'.') GOTO 512
      CWERT(J:J)='.'
  511 J=J+1
      IF (J.GT.LAE) GOTO 421
      IF (CHR(J).NE.' ') GOTO 512
      CWERT(J:J)=' '
      GOTO 511
  512 IF (CHR(J).NE.'L') GOTO 513
      BT=RDB
      K1=7
      GOTO 350
  513 IF (CHR(J).NE.' ') GOTO 514
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 421
      GOTO 512
  514 IER=311
      GOTO 900
  520 IF (CHR(J).NE.'.') GOTO 522
      CWERT(J:J)='.'
  521 J=J+1
      IF (J.GT.LAE) GOTO 422
      IF (CHR(J).NE.' ') GOTO 522
      CWERT(J:J)=' '
      GOTO 521
  522 IF (CHR(J).NE.'M') GOTO 523
      BT=RMB
      K1=8
      GOTO 350
  523 IF (CHR(J).NE.' ') GOTO 524
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 422
      GOTO 522
  524 IER=321
      GOTO 900
  530 IF (CHR(J).NE.'.') GOTO 532
      CWERT(J:J)='.'
  531 J=J+1
      IF (J.GT.LAE) GOTO 423
      IF (CHR(J).NE.' ') GOTO 532
      CWERT(J:J)=' '
      GOTO 531
  532 IF (CHR(J).NE.'S') GOTO 533
      BT=RSB
      K1=9
      GOTO 350
  533 IF (CHR(J).NE.' ') GOTO 534
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 423
      GOTO 532
  534 IER=331
      GOTO 900
C********************************************************************
C
C
C
C********************************************************************
  600 IE1=0
      IF (INULF.EQ.1) GOTO 680
      CALL INPUT1(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT1(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 690
      IER=101
      GOTO 900
  680 CALL INPUT2(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT2(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 690
      IER=102
      GOTO 900
  690 CWERT(2:3)=CM
      J=3
  603 J=J+1
      IF (J.GT.LAE) GOTO 432
      IF (CHR(J).NE.' ') GOTO 604
      CWERT(J:J)=' '
      GOTO 603
  604 IF (CHR(J).NE.'S') GOTO 620
      J1=J
      J2=J+1
      CWERT(J1:J2)=CS
      J=J+1
      IF (J.GT.LAE) GOTO 433
  605 J=J+1
      IF (J.GT.LAE) GOTO 433
      IF (CHR(J).NE.' ') GOTO 630
      CWERT(J:J)=' '
      GOTO 605
  620 IF (CHR(J).NE.'.') GOTO 622
      CWERT(J:J)='.'
  621 J=J+1
      IF (J.GT.LAE) GOTO 432
      IF (CHR(J).NE.' ') GOTO 622
      CWERT(J:J)=' '
      GOTO 621
  622 IF (CHR(J).NE.'M') GOTO 623
      BT=RMB
      K1=11
      GOTO 350
  623 IF (CHR(J).NE.' ') GOTO 624
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 432
      GOTO 622
  624 IER=121
      GOTO 900
  630 IF (CHR(J).NE.'.') GOTO 632
      CWERT(J:J)='.'
  631 J=J+1
      IF (J.GT.LAE) GOTO 433
      IF (CHR(J).NE.' ') GOTO 632
      CWERT(J:J)=' '
      GOTO 631
  632 IF (CHR(J).NE.'S') GOTO 633
      BT=RSB
      K1=12
      GOTO 350
  633 IF (CHR(J).NE.' ') GOTO 634
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 433
      GOTO 632
  634 IER=131
      GOTO 900
C********************************************************************
C
C
C
C
C********************************************************************
  700 IE1=0
      IF (INULF.EQ.1) GOTO 780
      CALL INPUT1(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT1(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 790
      IER=201
      GOTO 900
  780 CALL INPUT2(RM,CM,IE)
      IE1=IE1+IE
      CALL INPUT2(RS,CS,IE)
      IE1=IE1+IE
      IF (IE1.EQ.0) GOTO 790
      IER=202
      GOTO 900
  790 CWERT(2:3)=CM
      J=3
  703 J=J+1
      IF (J.GT.LAE) GOTO 442
      IF (CHR(J).NE.' ') GOTO 704
      CWERT(J:J)=' '
      GOTO 703
  704 IF (CHR(J).NE.'S') GOTO 720
      J1=J
      J2=J+1
      CWERT(J1:J2)=CS
      J=J+1
      IF (J.GT.LAE) GOTO 443
  705 J=J+1
      IF (J.GT.LAE) GOTO 443
      IF (CHR(J).NE.' ') GOTO 730
      CWERT(J:J)=' '
      GOTO 705
  720 IF (CHR(J).NE.'.') GOTO 722
      CWERT(J:J)='.'
  721 J=J+1
      IF (J.GT.LAE) GOTO 442
      IF (CHR(J).NE.' ') GOTO 722
      CWERT(J:J)=' '
      GOTO 721
  722 IF (CHR(J).NE.'M') GOTO 723
      BT=RMB
      K1=13
      GOTO 350
  723 IF (CHR(J).NE.' ') GOTO 724
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 442
      GOTO 722
  724 IER=221
      GOTO 900
  730 IF (CHR(J).NE.'.') GOTO 732
      CWERT(J:J)='.'
  731 J=J+1
      IF (J.GT.LAE) GOTO 443
      IF (CHR(J).NE.' ') GOTO 732
      CWERT(J:J)=' '
      GOTO 731
  732 IF (CHR(J).NE.'S') GOTO 733
      BT=RSB
      K1=15
      GOTO 350
  733 IF (CHR(J).NE.' ') GOTO 734
      CWERT(J:J)=' '
      J=J+1
      IF (J.GT.LAE) GOTO 443
      GOTO 732
  734 IER=231
      GOTO 900
C********************************************************************
C
C
C
C********************************************************************
  350 IF (IRUND.NE.0) GOTO 380
      K=LAE-J+1
      A=DBLE(K)
      BT=DINT(BT*10.**A+0.5D0)
      AT=BT/(10.D0**A)
      IF (AT.LT.1.D0) GOTO 380
      BT=BT-10.D0**(A+1.D0)
      IRUND=1
      IF (K1.EQ.1)  GOTO 361
      IF (K1.EQ.4)  GOTO 364
      IF (K1.EQ.7)  GOTO 367
      IF (K1.EQ.2)  GOTO 362
      IF (K1.EQ.5)  GOTO 365
      IF (K1.EQ.8)  GOTO 368
      IF (K1.EQ.3)  GOTO 363
      IF (K1.EQ.6)  GOTO 366
      IF (K1.EQ.9)  GOTO 369
      IF (K1.EQ.11) GOTO 371
      IF (K1.EQ.12) GOTO 372
      IF (K1.EQ.14) GOTO 374
      IF (K1.EQ.15) GOTO 375
  361 RH=RH+1
      IF (RH.EQ.24.) RH=0.D0
      IF (RH.EQ.25.) RH=1.D0
      GOTO 100
  362 RM=RM+1
      IF (RM.LT.60.D0) GOTO 100
      RM=RM-60.D0
      GOTO 361
  363 RS=RS+1
      IF (RS.LT.60.D0) GOTO 100
      RS=RS-60.D0
      GOTO 362
  364 RD=RD+1
      GOTO 200
  365 RM=RM+1
      IF (RM.LT.60.D0) GOTO 200
      RM=RM-60.D0
      GOTO 364
  366 RS=RS+1
      IF (RS.LT.60.D0) GOTO 200
      RS=RS-60.D0
      GOTO 365
  367 RD=RD+1
      IF (RD.GE.360.D0) RD=RD-360.D0
      GOTO 500
  368 RM=RM+1
      IF (RM.LT.60.D0) GOTO 500
      RM=RM-60.D0
      GOTO 367
  369 RS=RS+1
      IF (RS.LT.60.D0) GOTO 500
      RS=RS-60.D0
      GOTO 368
  371 RM=RM+1
      IF (RM.LT.60.D0) GOTO 600
      RM=RM-60.D0
      GOTO 600
  372 RS=RS+1
      IF (RS.LT.60.D0) GOTO 600
      RS=RS-60.D0
      GOTO 371
  374 RM=RM+1
      IF (RM.LT.60.D0) GOTO 700
      RM=RM-60.D0
      GOTO 700
  375 RS=RS+1
      IF (RS.LT.60.D0) GOTO 700
      RS=RS-60.D0
      GOTO 374
C********************************************************************
C
C
C
C********************************************************************
  380 CALL INPUT3(BT,K,CBT,IE)
      J1=J
      J2=LAE
      CWERT(J1:J2)=CBT
      GOTO 900
C********************************************************************
C
C
C
C********************************************************************
  401 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RHB1=RHB+0.5D0
      IF (RHB1.LT.1.0D0) GOTO 900
      GOTO 361
  402 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RMB1=RMB+0.5D0
      IF (RMB1.LT.1.0D0) GOTO 900
      GOTO 362
  403 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RSB1=RSB+0.5D0
      IF (RSB1.LT.1.0D0) GOTO 900
      GOTO 363
  411 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RDB1=RDB+0.5D0
      IF (RDB1.LT.1.0D0) GOTO 900
      GOTO 364
  412 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RMB1=RMB+0.5D0
      IF (RMB1.LT.1.0D0) GOTO 900
      GOTO 365
  413 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RSB1=RSB+0.5D0
      IF (RSB1.LT.1.0D0) GOTO 900
      GOTO 366
  421 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RDB1=RDB+0.5D0
      IF (RDB1.LT.1.0D0) GOTO 900
      GOTO 367
  422 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RMB1=RMB+0.5D0
      IF (RMB1.LT.1.0D0) GOTO 900
      GOTO 368
  423 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RSB1=RSB+0.5D0
      IF (RSB1.LT.1.0D0) GOTO 900
      GOTO 369
  432 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RMB1=RMB+0.5D0
      IF (RMB1.LT.1.0D0) GOTO 900
      GOTO 371
  433 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RSB1=RSB+0.5D0
      IF (RSB1.LT.1.0D0) GOTO 900
      GOTO 372
  442 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RMB1=RMB+0.5D0
      IF (RMB1.LT.1.0D0) GOTO 900
      GOTO 374
  443 IF (IRUND.EQ.1) GOTO 900
      IRUND=1
      RSB1=RSB+0.5D0
      IF (RSB1.LT.1.0D0) GOTO 900
      GOTO 375
C********************************************************************
C
C
C
C********************************************************************
  900 CONTINUE
      IF (IER.EQ.0) GOTO 910
      WRITE(LUNERR,1111) RAD,C2,IER
 1111 FORMAT (1X, 'FEHLER AUFGETRETEN BEI UMRECHNUNG VON'/
     *1X,F11.8,' IN ',A/1X,'FEHLERMELDUNG = ',I3//)
      RAD = 0.D0
      GOTO 920
  910 CONTINUE
      CV='+'
      IF (CHR(1).EQ.'N') CV=' '
      IF (IVA.EQ.-1) CV='-'
      IF (IH.NE.1) CWERT(1:1)=CV
      IF (IH.EQ.1 .AND. CHR(2).EQ.'T') CWERT(1:1)=CV
  920 CONTINUE
  999 CONTINUE
      RETURN
      END
C********************************************************************
C
C
C
C********************************************************************
      SUBROUTINE INPUT1(Z,C,IE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*2 IZI(100),C
      DATA IZI/' 0',' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9',
     *'10','11','12','13','14','15','16','17','18','19',
     *'20','21','22','23','24','25','26','27','28','29',
     *'30','31','32','33','34','35','36','37','38','39',
     *'40','41','42','43','44','45','46','47','48','49',
     *'50','51','52','53','54','55','56','57','58','59',
     *'60','61','62','63','64','65','66','67','68','69',
     *'70','71','72','73','74','75','76','77','78','79',
     *'80','81','82','83','84','85','86','87','88','89',
     *'90','91','92','93','94','95','96','97','98','99'/
      IE = 0
      DO 10 I=0,99
      IF (Z.EQ.DBLE(I))  C=IZI(I+1)
   10 CONTINUE
      RETURN
      END
C********************************************************************
C
C
C
C********************************************************************
      SUBROUTINE INPUT2(Z,C,IE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*2 IZI(100),C
      DATA IZI/'00','01','02','03','04','05','06','07','08','09',
     *'10','11','12','13','14','15','16','17','18','19',
     *'20','21','22','23','24','25','26','27','28','29',
     *'30','31','32','33','34','35','36','37','38','39',
     *'40','41','42','43','44','45','46','47','48','49',
     *'50','51','52','53','54','55','56','57','58','59',
     *'60','61','62','63','64','65','66','67','68','69',
     *'70','71','72','73','74','75','76','77','78','79',
     *'80','81','82','83','84','85','86','87','88','89',
     *'90','91','92','93','94','95','96','97','98','99'/
      IE = 0
      DO 10 I=0,99
      IF (Z.EQ.DBLE(I))  C=IZI(I+1)
   10 CONTINUE
      RETURN
      END
C********************************************************************
C
C
C********************************************************************
      SUBROUTINE INPUT3(B,L,CC,IE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Z(9)
      CHARACTER*10 CC
      CHARACTER*1 IZ(10),IZI(10)
      DATA IZ/'0','1','2','3','4','5','6','7','8','9'/
      DO 99 I=1,10
      CC(I:I)=' '
   99 CONTINUE
      IF (L.GT.9) GOTO 90
      DO 10 I=1,9
      Z(I)=0
      IZI(I)=' '
   10 CONTINUE
      GOTO(1,2,3,4,5,6,7,8,9) L
    9 Z(9)=DINT(B/10.**8.D0)
    8 Z(8)=DINT((B-Z(9)*10.D0**8.D0)/10.**7.D0)
    7 Z(7)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0)/10.**6.D0)
    6 Z(6)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0-
     F             Z(7)*10.D0**6.D0)/10.**5.D0)
    5 Z(5)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0-
     F             Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0)/10.**4.D0)
    4 Z(4)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0-
     F             Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0-
     F             Z(5)*10.D0**4.D0)/1000.)
    3 Z(3)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0-
     F             Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0-
     F             Z(5)*10.D0**4.D0-Z(4)*10.D0**3.D0)/100.)
    2 Z(2)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0-
     F             Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0-
     F             Z(5)*10.D0**4.D0-Z(4)*10.D0**3.D0-
     F             Z(3)*10.D0**2.D0)/10.)
    1 Z(1)= DINT(B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0-
     F             Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0-
     F             Z(5)*10.D0**4.D0-Z(4)*10.D0**3.D0-
     F             Z(3)*10.D0**2.D0-Z(2)*10.D0**1.D0)
      DO 12 I=0,9
      DO 11 J=1,9
      IF (Z(J).EQ.DBLE(I)) IZI(J)=IZ(I+1)
   11 CONTINUE
   12 CONTINUE
      CC(1:1)=IZI(L)
      DO 13 I=L-1,1,-1
      L1=L-I+1
      CC(L1:L1)=IZI(I)
   13 CONTINUE
      GOTO 14
   90 IE=1
   14 CONTINUE
      RETURN
C********************************************************************
C
C
C
C********************************************************************
      END

C Wandeln von Klein- nach Grossbuchstaben

      Subroutine Upcase(c)
      character c*1
      integer i

      i = ichar(c)
      if ((i.ge.97).and.(i.le.122)) then
       c = char(i-32)
      end if
      end
      SUBROUTINE READALL(ST)
      CHARACTER*72 ST(34)
      INTEGER I

      open (99,file='input',status='old')
c
      DO I = 1,34
c        READ(5,'(A)',END=10) ST(I)
         READ(99,'(A)',END=10) ST(I)
      END DO
 10   END
        SUBROUTINE READOUT(XINDEX,NINDEX,NMAX)
        INTEGER NSTAR
        PARAMETER (NSTAR = 612627)
        INTEGER NINDEX(3000000),ARINR,ICOUNT,NMAX,CATCN
        INTEGER i,headlen
        REAL*8 XINDEX(3000000),faktor
        CHARACTER*34 STR
        LOGICAL EX
        COMMON /headlen/ headlen
        parameter (faktor = 1.d0/10000000.0)
c
        REWIND 3
        ICOUNT = 0
        do i = 1,headlen
         read(3) STR
        end do
10      READ(3,end = 100) STR
        ICOUNT = ICOUNT + 1
        READ(STR(9:12),'(A4)') ARINR
        READ(STR(27:30),'(A4)') CATCN
C     IF (ICOUNT .LE. 20) PRINT*,ARINR
        XINDEX(ICOUNT) = DFLOAT(ARINR)+DFLOAT(CATCN)*FAKTOR
c       IF (ICOUNT .LE. 20) PRINT*,ARINR
        NINDEX(ICOUNT) = ICOUNT
      GOTO 10
  100   NMAX = ICOUNT
        REWIND 3
        do i = 1,headlen
         read(3) STR
        end do
      END
C
      SUBROUTINE SCLPRD (A,B,R,M)
C
C     SKALRAPRODUKT R = A.B ZWEIER VEKTOREN
C
C     A = NAME DES 1. EINGABEVEKTORS (M-MAL-1 MATRIX)
C     B = NAME DES 2. EINGABEVEKTORS (M-MAL-1 MATRIX)
C     R = SKALAR-PRODUKT
C     M = ZAHL DER ZEILEN VON A = ZAHL DER ZEILEN VON B
C
C
      IMPLICIT REAL*8  (A-H,O-Z)
      DIMENSION  A(M,1),B(M,1)
C
      R = 0.D0
C
      DO 10  I = 1,M
 10   R = R + A(I,1)*B(I,1)
      RETURN
      END
      SUBROUTINE SEEK(ST,AN,PN1,PN2)
      CHARACTER*(*) ST
      INTEGER I,PN1,PN2,AN,LMAX
ccc   write(*,'(2a)') 'Eingabestring fuer SEEK:  ',st
      I=AN
        LMAX = LEN(ST)
 10   IF (ST(I:I) .EQ. ' ') THEN
               I = I + 1
               GOTO 10
      ELSE
              PN1 = I
      END IF
      IF (PN1.EQ.0) THEN
          PRINT*,'FALSCHE EINGABE BEI ',ST
          GOTO 30
      END IF
      PN2 = PN1
      I=PN2+1
        DO I = PN1,LMAX
         IF (ST(I:I) .NE. ' ') THEN
            PN2 = I
         END IF
        END DO
cc    write(*,*) 'PN1, PN2 =  ',pn1,pn2
C     IF (POS2.EQ.POS1) THEN
C         PRINT*,'FALSCHE EINGABE BEI ',ST
C     END IF
  30  END
      SUBROUTINE TRANSF(EPOSTART,EPOZIEL,XMTX,ALFA,DELTA,PMA,PMD)
      REAL*8    ALFA,DELTA
      REAL*8    PMA,PMD,EPOSTART,EPOZIEL,TDIFF
      REAL*8    MUALF,MUDEL
      REAL*8    XMTX(3,3)
      REAL*8    EPJDA,EPJDZ
      REAL*8    PHI,THETA,ZETA
C      CALL BEJD (EPOZIEL,EPJDZ)
C      CALL BEJD (EPOSTART,EPJDA)
        MUALF = PMA
        MUDEL = PMD
      IF (PMA .EQ. -999.D0) MUALF = 0.D0
      IF (PMD .EQ. -999.D0) MUDEL = 0.D0
      TDIFF = EPOSTART - EPOZIEL
      ALFA = ALFA - TDIFF * MUALF
      DELTA = DELTA - TDIFF *MUDEL
      CALL AEQUINOX(XMTX,ALFA,DELTA)
        IF (PMA .GT. -999.D0) THEN
            PMA= PMA*100.D0
        ELSE
           PMA = 0.D0
        END IF
        IF (PMD .GT. -999.D0) THEN
            PMD= PMD*100.D0
        ELSE
           PMD = 0.D0
        END IF
      END
      SUBROUTINE AEQUINOX(MATRIX,AL,DEL)
      REAL*8 MATRIX(3,3)
      REAL*8 XR(3,1),XS(3,1)
      REAL*8 AL,DEL
      CALL DIRCOS(AL,DEL,XR)
      CALL GMPRD(MATRIX,XR,XS,3,3,1)
      CALL ANGLE(XS,AL,DEL)
      END
      SUBROUTINE UELWEG(SPALTE,ZIFFER,UELOCH,IER)
C     DIESE SUBROUTINE TEILT UEBERLOCHTE ZIFFERN IN 2 SPALTEN AUF
C     umrechnung auf unix angepasst - ba.
      CHARACTER*1 SPALTE,ZIFFER,UELOCH
      UELOCH=' '
      IER=0
C
      IF (SPALTE.GE.'A'.AND.SPALTE.LE.'I') THEN
         ZIFFER=CHAR(ICHAR(SPALTE)-16)
         UELOCH='+'
      else if (spalte.eq.'{') then
         ZIFFER='0'
         UELOCH='+'
      ELSE IF(SPALTE.GE.'J'.AND.SPALTE.LE.'R')THEN
         ZIFFER=CHAR(ICHAR(SPALTE)-25)
         UELOCH='-'
      else if (spalte.eq.'}') then
         ZIFFER='0'
         UELOCH='-'
      ELSE
      IF(SPALTE.LT.'0'.OR.SPALTE.GT.'9') IER=1
      ZIFFER=SPALTE
      END IF
      RETURN
      END
        SUBROUTINE XSORT(XINDEX,NINDEX,NTOT)
        INTEGER I,K,NTOT,L,IR
        INTEGER NINDEX(NTOT),NRM
        REAL*8 XINDEX(NTOT),RRA
C
       if (ntot.le.2) goto 30
        L = 0.5D0 * NTOT + 1
        IR = NTOT
 10   CONTINUE
        IF (L .GT. 1) THEN
           L = L - 1
           RRA = XINDEX(L)
           NRM = NINDEX(L)
        ELSE
           RRA = XINDEX(IR)
           NRM = NINDEX(IR)
           XINDEX(IR) = XINDEX(1)
           NINDEX(IR) = NINDEX(1)
           IR = IR - 1
           IF ( IR .EQ. 1) THEN
             XINDEX(1) = RRA
             NINDEX(1) = NRM
               RETURN
           END IF
        END IF
        I = L
        J = L + L
 20    IF ( J .LE. IR) THEN
             IF ( J .LT. IR) THEN
                 IF (XINDEX(J) .LT. XINDEX(J+1)) J=J +1
             END IF
             IF (RRA .LT. XINDEX(J) ) THEN
                XINDEX(I) = XINDEX(J)
                NINDEX(I) = NINDEX(J)
                I = J
                J = J + J
             ELSE
                J = IR + 1
             END IF
             GOTO 20
          END IF
          XINDEX(I) = RRA
          NINDEX(I) = NRM
        GOTO 10
 30   continue
        END