C  Apparent Places using procedure Astronomical Almanac 2007 B68
C  H. Lenhardt      ARI July 2007
C  catalogue: FK6
      implicit real*8 (a-h,o-z)
      dimension q(3),p1(3),p2(3),p3(3),xv(3),p4(3),p(3),PP(3)
      dimension EB(3),EV(3),SB(3),E(3),es(3)
      dimension r(6)
      real*8    m(3)
      real*8    RBPN(3,3),RC2I(3,3)
      character * 200 zeile
      character * 1   sign
C
      pi = 4.d0 * atan(1.d0)
      dtr = 180.d0/pi
C to be defined by user:
      istar = 14576
      Jahr = 2009
      Monat =  10
      itag  =  10
      ihour =   0
C read FK6:
      if(istar.gt.0) then
      open(unit=10,file='fk61cp01.html',
     $     status='old')
      do 101 jj=1,19
      read(10,'(a200)') zeile
101   continue
C  read data set:
      do 100 jj=1,100000
C     read(10,'(a200)')    zeile
C     write(6,'(a200 ')    zeile
C     backspace 10
      read(10,666,err=110) id,iafkh,iafkm,afks,sign,idfkd,idfkm,dfks,
     &                     rmuafk,rmudfk,parfk,rvfk
C     write(6,666)         id,iafkh,iafkm,afks,idfkd,idfkm,dfks,
C    &                     rmuafk,rmudfk,parfk,rvfk
C66   format(1x,i5,32x,2i3,1x,f9.6,4x,i3,1x,i2,1x,f8.5,
666   format(1x,i5,32x,2i3,1x,f9.6,4x,a1,i2,1x,i2,1x,f8.5,
     &       2x,F10.2,2x,f10.2,56x,f7.2,17x,f7.1)
      parfk = parfk/1000.d0
      if(id.eq.istar) goto 200
100   continue
C
110   continue
      write(6,665)  istar
665   format(//'  Stern nicht gefunden',I10)
      stop
      end if
C
200   continue
C     write(6,'(i5)')     id
C     write(6,'(i3)')     iafkh
C     write(6,'(i3)')     iafkm
C     write(6,'(f9.6)')   afks
C     write(6,'(i3)')     idfkd
C     write(6,'(i2)')     idfkm
C     write(6,'(f8.5)')   dfks
C     write(6,'(f10.2)')  rmuafk
C     write(6,'(f10.2)')  rmudfk
C     write(6,'(f7.2)')   parfk*1000.d0
C     write(6,'(f7.1)')   rvfk
C  TEST STAR ALMANAC 2007/2008: cccccccccccccccccccc
      if(istar.eq.-99)  then
      iafkh = 14
      iafkm = 39
      afks  = 36.4958 d0
      idfkd =-60
      idfkm = 50
      dfks  = 2.309 d0
      rmuafk=-3678.08
      rmudfk=  482.87 d0
      parfk =  0.742  d0
      rvfk  =  -21.6  d0
C     Jahr = 2007
C     Jahr = 2008
      Jahr = 2009                                                              Test mit Almanac 2009
      Monat = 1
      itag  = 1
      ihour  = 0
      sign = '-'
      end if
Ccccccccc     ENDE TEST STAR  ccccccccccccccccccccccc
      alpha0 =
     & (dble(iafkh)+ (dble(iafkm)*60.d0 + afks)/3600.d0) * 15.d0
      delta0 =
     & dble(iabs(idfkd)) + (dble(idfkm)*60.d0 +  dfks)/3600.d0
Ca    if(idfkd.lt.0)  delta0 = -delta0
      if(sign.eq.'-') delta0 = -delta0
C
      call cappplc (alpha0,delta0,rmuafk,rmudfk,parfk,rvfk,
     &              jahr,monat,itag,ihour,
     &              racioout,raequout,decout)
C
c Ausgabe
      alpha = raequout
      delta = decout
      alpha = alpha / 15.d0
      write(6,*) alpha
      write(6,*) delta
      idega = int(alpha)
      imina= int(alpha*60.d0 - dble(idega)*60.d0)
      seca = abs(alpha)*3600.d0
     &      -dble(iabs(idega))*3600.d0-dble(imina)*60.d0
      write(6,999) idega , imina, seca
999   format(' alpha = ',I4,2x,i2,2x,f10.4,'    Equinox-Method')
      idegd = int(delta)
      imind = int(abs(delta*60.d0) - dble(iabs(idegd))*60.d0)
      secd  = abs(delta)*3600.d0
     &      -dble(iabs(idegd))*3600.d0-dble(imind)*60.d0
      sign = ' '
      if(delta.lt.0.d0) sign='-'
      write(6,998) sign,iabs(idegd) , imind, secd
998   format(' delta = ',1x,a1,i2,2x,i2,2x,f10.4,'    Equinox-Method')
c Step 5b  (CIO-Method)
      alpha = racioout
      delta = decout
      alpha = alpha / 15.d0
      write(6,*) alpha
      write(6,*) delta
      idega = int(alpha)
      imina= int(alpha*60.d0 - dble(idega)*60.d0)
      seca = abs(alpha)*3600.d0
     &      -dble(iabs(idega))*3600.d0-dble(imina)*60.d0
      write(6,888) idega , imina, seca
      imind = int(abs(delta*60.d0) - dble(iabs(idegd))*60.d0)
      secd  = abs(delta)*3600.d0
     &      -dble(iabs(idegd))*3600.d0-dble(imind)*60.d0
      sign = ' '
      if(delta.lt.0.d0) sign='-'
      write(6,887) sign,iabs(idegd) , imind, secd
888   format(' alpha = ',I4,2x,i2,2x,f10.4,'        CIO-Method')
887   format(' delta = ',1x,a1,i2,2x,i2,2x,f10.4,'        CIO-Method')
      stop
      end
C
      include 'iau_subroutines.f'
      include 'sbr_pleph.f'
      include 'apfscompute.f'